From a7378e1d17207e2866a46c4090c645896240e5da Mon Sep 17 00:00:00 2001 From: John Alanbrook Date: Wed, 19 Jan 2022 22:43:21 +0000 Subject: [PATCH] Organized files --- Makefile | 107 +- source/editor/editor.cpp | 10 +- source/editor/editor.h | 6 +- source/editor/imgui/LICENSE.txt | 21 + .../imgui/backends/imgui_impl_allegro5.cpp | 477 + .../imgui/backends/imgui_impl_allegro5.h | 31 + .../imgui/backends/imgui_impl_android.cpp | 187 + .../imgui/backends/imgui_impl_android.h | 27 + .../editor/imgui/backends/imgui_impl_dx10.cpp | 577 + .../editor/imgui/backends/imgui_impl_dx10.h | 25 + .../editor/imgui/backends/imgui_impl_dx11.cpp | 593 + .../editor/imgui/backends/imgui_impl_dx11.h | 26 + .../editor/imgui/backends/imgui_impl_dx12.cpp | 745 + .../editor/imgui/backends/imgui_impl_dx12.h | 49 + .../editor/imgui/backends/imgui_impl_dx9.cpp | 377 + source/editor/imgui/backends/imgui_impl_dx9.h | 25 + .../editor/imgui/backends/imgui_impl_glfw.cpp | 453 + .../editor/imgui/backends/imgui_impl_glfw.h | 41 + .../editor/imgui/backends/imgui_impl_glut.cpp | 217 + .../editor/imgui/backends/imgui_impl_glut.h | 37 + .../imgui/backends/imgui_impl_marmalade.cpp | 318 + .../imgui/backends/imgui_impl_marmalade.h | 28 + .../editor/imgui/backends/imgui_impl_metal.h | 29 + .../editor/imgui/backends/imgui_impl_metal.mm | 556 + .../imgui/backends/imgui_impl_opengl2.cpp | 284 + .../imgui/backends/imgui_impl_opengl2.h | 32 + .../imgui/backends/imgui_impl_opengl3.cpp | 777 + .../imgui/backends/imgui_impl_opengl3.h | 55 + .../backends/imgui_impl_opengl3_loader.h | 752 + source/editor/imgui/backends/imgui_impl_osx.h | 24 + .../editor/imgui/backends/imgui_impl_osx.mm | 369 + .../editor/imgui/backends/imgui_impl_sdl.cpp | 443 + source/editor/imgui/backends/imgui_impl_sdl.h | 34 + .../imgui/backends/imgui_impl_vulkan.cpp | 1462 + .../editor/imgui/backends/imgui_impl_vulkan.h | 149 + .../editor/imgui/backends/imgui_impl_wgpu.cpp | 717 + .../editor/imgui/backends/imgui_impl_wgpu.h | 25 + .../imgui/backends/imgui_impl_win32.cpp | 615 + .../editor/imgui/backends/imgui_impl_win32.h | 42 + .../imgui/backends/vulkan/generate_spv.sh | 6 + .../imgui/backends/vulkan/glsl_shader.frag | 14 + .../imgui/backends/vulkan/glsl_shader.vert | 25 + source/editor/imgui/imconfig.h | 123 + source/editor/imgui/imgui.cpp | 11936 + source/editor/imgui/imgui.h | 2906 + source/editor/imgui/imgui_demo.cpp | 7653 + source/editor/imgui/imgui_draw.cpp | 4177 + source/editor/imgui/imgui_internal.h | 2758 + source/editor/imgui/imgui_tables.cpp | 4050 + source/editor/imgui/imgui_widgets.cpp | 8200 + source/editor/imgui/imstb_rectpack.h | 639 + source/editor/imgui/imstb_textedit.h | 1449 + source/editor/imgui/imstb_truetype.h | 4903 + source/engine/camera.c | 2 +- source/engine/config.h | 3 + source/engine/datastream.c | 9 +- source/engine/datastream.h | 4 +- source/{editor => engine}/debugdraw.c | 0 source/{editor => engine}/debugdraw.h | 0 source/engine/engine.c | 142 +- source/engine/engine.h | 19 + source/engine/font.c | 31 +- source/engine/font.h | 5 +- source/engine/gameobject.c | 5 + source/engine/gameobject.h | 1 + source/engine/input.c | 6 +- source/engine/input.h | 2 +- source/engine/log.h | 2 +- source/engine/mathc.h | 1 + source/engine/model.c | 1 - source/engine/openglrender.c | 37 +- source/engine/openglrender.h | 5 +- source/engine/render.h | 2 +- source/engine/resources.c | 25 +- source/engine/resources.h | 3 +- source/engine/shader.c | 4 +- source/engine/skybox.c | 1 - source/engine/sound.c | 94 + source/engine/sound.h | 46 + source/engine/sprite.c | 21 +- source/engine/sprite.h | 7 +- source/engine/static_actor.c | 1 - source/engine/texture.c | 67 +- source/engine/texture.h | 18 +- .../engine/thirdparty/Chipmunk2D/LICENSE.txt | 19 + .../engine/thirdparty/Chipmunk2D/VERSION.txt | 300 + .../thirdparty/Chipmunk2D/doc/examples.html | 119 + .../doc/examples/BreakableJoint.html | 22 + .../doc/examples/CollisionCallback.html | 38 + .../Chipmunk2D/doc/examples/Crushing.html | 23 + .../doc/examples/DynamicStatic.html | 18 + .../doc/examples/Hello Chipmunk.html | 64 + .../doc/examples/JointRecipies.html | 17 + .../Chipmunk2D/doc/examples/Moments.html | 14 + .../doc/examples/PlaySoundOnCollision.html | 15 + .../Chipmunk2D/doc/examples/Sleeping.html | 25 + .../Chipmunk2D/doc/examples/cpConvexHull.html | 25 + .../doc/examples/cpSpaceEachBody.html | 12 + .../Chipmunk2D/doc/images/hash_just_right.png | Bin 0 -> 10953 bytes .../Chipmunk2D/doc/images/hash_too_big.png | Bin 0 -> 10756 bytes .../Chipmunk2D/doc/images/hash_too_small.png | Bin 0 -> 8771 bytes .../Chipmunk2D/doc/images/hms_logo.png | Bin 0 -> 11800 bytes .../Chipmunk2D/doc/images/logo1_med.png | Bin 0 -> 6448 bytes .../thirdparty/Chipmunk2D/doc/stylesheet.css | 72 + .../Chipmunk2D/include/chipmunk/chipmunk.h | 234 + .../include/chipmunk/chipmunk_ffi.h | 105 + .../include/chipmunk/chipmunk_private.h | 344 + .../include/chipmunk/chipmunk_structs.h | 450 + .../include/chipmunk/chipmunk_types.h | 268 + .../include/chipmunk/chipmunk_unsafe.h | 66 + .../Chipmunk2D/include/chipmunk/cpArbiter.h | 145 + .../Chipmunk2D/include/chipmunk/cpBB.h | 187 + .../Chipmunk2D/include/chipmunk/cpBody.h | 189 + .../include/chipmunk/cpConstraint.h | 95 + .../include/chipmunk/cpDampedRotarySpring.h | 58 + .../include/chipmunk/cpDampedSpring.h | 68 + .../Chipmunk2D/include/chipmunk/cpGearJoint.h | 45 + .../include/chipmunk/cpGrooveJoint.h | 50 + .../include/chipmunk/cpHastySpace.h | 27 + .../Chipmunk2D/include/chipmunk/cpMarch.h | 28 + .../Chipmunk2D/include/chipmunk/cpPinJoint.h | 50 + .../include/chipmunk/cpPivotJoint.h | 47 + .../Chipmunk2D/include/chipmunk/cpPolyShape.h | 56 + .../Chipmunk2D/include/chipmunk/cpPolyline.h | 70 + .../include/chipmunk/cpRatchetJoint.h | 50 + .../Chipmunk2D/include/chipmunk/cpRobust.h | 11 + .../include/chipmunk/cpRotaryLimitJoint.h | 45 + .../Chipmunk2D/include/chipmunk/cpShape.h | 199 + .../include/chipmunk/cpSimpleMotor.h | 43 + .../include/chipmunk/cpSlideJoint.h | 55 + .../Chipmunk2D/include/chipmunk/cpSpace.h | 319 + .../include/chipmunk/cpSpatialIndex.h | 227 + .../Chipmunk2D/include/chipmunk/cpTransform.h | 198 + .../Chipmunk2D/include/chipmunk/cpVect.h | 230 + .../thirdparty/Chipmunk2D/src/chipmunk.c | 331 + .../thirdparty/Chipmunk2D/src/cpArbiter.c | 498 + .../thirdparty/Chipmunk2D/src/cpArray.c | 101 + .../thirdparty/Chipmunk2D/src/cpBBTree.c | 896 + .../engine/thirdparty/Chipmunk2D/src/cpBody.c | 626 + .../thirdparty/Chipmunk2D/src/cpCollision.c | 726 + .../thirdparty/Chipmunk2D/src/cpConstraint.c | 173 + .../Chipmunk2D/src/cpDampedRotarySpring.c | 178 + .../Chipmunk2D/src/cpDampedSpring.c | 216 + .../thirdparty/Chipmunk2D/src/cpGearJoint.c | 145 + .../thirdparty/Chipmunk2D/src/cpGrooveJoint.c | 197 + .../thirdparty/Chipmunk2D/src/cpHashSet.c | 253 + .../thirdparty/Chipmunk2D/src/cpHastySpace.c | 700 + .../thirdparty/Chipmunk2D/src/cpMarch.c | 157 + .../thirdparty/Chipmunk2D/src/cpPinJoint.c | 172 + .../thirdparty/Chipmunk2D/src/cpPivotJoint.c | 152 + .../thirdparty/Chipmunk2D/src/cpPolyShape.c | 324 + .../thirdparty/Chipmunk2D/src/cpPolyline.c | 652 + .../Chipmunk2D/src/cpRatchetJoint.c | 179 + .../thirdparty/Chipmunk2D/src/cpRobust.c | 13 + .../Chipmunk2D/src/cpRotaryLimitJoint.c | 160 + .../thirdparty/Chipmunk2D/src/cpShape.c | 604 + .../thirdparty/Chipmunk2D/src/cpSimpleMotor.c | 123 + .../thirdparty/Chipmunk2D/src/cpSlideJoint.c | 195 + .../thirdparty/Chipmunk2D/src/cpSpace.c | 701 + .../Chipmunk2D/src/cpSpaceComponent.c | 349 + .../thirdparty/Chipmunk2D/src/cpSpaceDebug.c | 187 + .../thirdparty/Chipmunk2D/src/cpSpaceHash.c | 634 + .../thirdparty/Chipmunk2D/src/cpSpaceQuery.c | 246 + .../thirdparty/Chipmunk2D/src/cpSpaceStep.c | 445 + .../Chipmunk2D/src/cpSpatialIndex.c | 69 + .../thirdparty/Chipmunk2D/src/cpSweep1D.c | 254 + .../engine/thirdparty/Chipmunk2D/src/prime.h | 68 + .../engine/thirdparty/bitmap-outliner/LICENSE | 20 + .../thirdparty/bitmap-outliner/README.md | 123 + .../bitmap-outliner/bitmap-outliner-print.c | 77 + .../bitmap-outliner/bitmap-outliner-print.h | 10 + .../bitmap-outliner/bitmap-outliner.c | 628 + .../bitmap-outliner/bitmap-outliner.h | 98 + source/engine/thirdparty/cgltf/LICENSE | 7 + source/engine/thirdparty/cgltf/README.md | 156 + source/engine/thirdparty/cgltf/cgltf.h | 6434 + source/engine/thirdparty/cgltf/cgltf_write.h | 1333 + source/engine/thirdparty/enet/ChangeLog | 200 + source/engine/thirdparty/enet/LICENSE | 7 + source/engine/thirdparty/enet/README | 15 + source/engine/thirdparty/enet/docs/FAQ.dox | 24 + source/engine/thirdparty/enet/docs/design.dox | 126 + .../engine/thirdparty/enet/docs/install.dox | 63 + .../engine/thirdparty/enet/docs/license.dox | 26 + .../engine/thirdparty/enet/docs/mainpage.dox | 59 + .../engine/thirdparty/enet/docs/tutorial.dox | 366 + .../thirdparty/enet/include/enet/callbacks.h | 27 + .../thirdparty/enet/include/enet/enet.h | 613 + .../thirdparty/enet/include/enet/list.h | 43 + .../thirdparty/enet/include/enet/protocol.h | 198 + .../thirdparty/enet/include/enet/time.h | 18 + .../thirdparty/enet/include/enet/types.h | 13 + .../thirdparty/enet/include/enet/unix.h | 48 + .../thirdparty/enet/include/enet/utility.h | 13 + .../thirdparty/enet/include/enet/win32.h | 59 + source/engine/thirdparty/enet/src/callbacks.c | 53 + source/engine/thirdparty/enet/src/compress.c | 654 + source/engine/thirdparty/enet/src/host.c | 501 + source/engine/thirdparty/enet/src/list.c | 75 + source/engine/thirdparty/enet/src/packet.c | 165 + source/engine/thirdparty/enet/src/peer.c | 1004 + source/engine/thirdparty/enet/src/protocol.c | 1877 + source/engine/thirdparty/enet/src/unix.c | 615 + source/engine/thirdparty/enet/src/win32.c | 442 + source/engine/thirdparty/pl_mpeg/README.md | 55 + source/engine/thirdparty/pl_mpeg/pl_mpeg.h | 4273 + .../pl_mpeg/pl_mpeg_extract_frames.c | 79 + .../thirdparty/pl_mpeg/pl_mpeg_player.c | 439 + source/engine/thirdparty/s7/mus-config.h | 1 + source/engine/thirdparty/s7/s7.c | 114091 +++++++ source/engine/thirdparty/s7/s7.h | 1452 + source/engine/thirdparty/s7/s7.html | 10552 + source/engine/thirdparty/sqlite3/README.txt | 113 + source/engine/thirdparty/sqlite3/shell.c | 22857 ++ source/engine/thirdparty/sqlite3/sqlite3.c | 237435 +++++++++++++++ source/engine/thirdparty/sqlite3/sqlite3.h | 12492 + source/engine/thirdparty/sqlite3/sqlite3ext.h | 675 + source/engine/thirdparty/stb/LICENSE | 37 + source/engine/thirdparty/stb/README.md | 181 + .../engine/thirdparty/stb/docs/other_libs.md | 1 + .../engine/thirdparty/stb/docs/stb_howto.txt | 185 + .../stb/docs/stb_voxel_render_interview.md | 173 + .../thirdparty/stb/docs/why_public_domain.md | 117 + source/engine/thirdparty/stb/stb_c_lexer.h | 940 + .../thirdparty/stb/stb_connected_components.h | 1049 + source/engine/thirdparty/stb/stb_divide.h | 433 + source/engine/thirdparty/stb/stb_ds.h | 1895 + source/engine/thirdparty/stb/stb_dxt.h | 719 + source/engine/thirdparty/stb/stb_easy_font.h | 305 + .../stb/stb_herringbone_wang_tile.h | 1221 + source/engine/thirdparty/stb/stb_hexwave.h | 680 + source/engine/thirdparty/stb/stb_image.h | 7897 + .../engine/thirdparty/stb/stb_image_resize.h | 2634 + .../engine/thirdparty/stb/stb_image_write.h | 1724 + source/engine/thirdparty/stb/stb_include.h | 295 + source/engine/thirdparty/stb/stb_leakcheck.h | 194 + source/engine/thirdparty/stb/stb_rect_pack.h | 623 + source/engine/thirdparty/stb/stb_sprintf.h | 1906 + source/engine/thirdparty/stb/stb_textedit.h | 1429 + .../thirdparty/stb/stb_tilemap_editor.h | 4187 + source/engine/thirdparty/stb/stb_truetype.h | 5077 + source/engine/thirdparty/stb/stb_vorbis.c | 5584 + .../engine/thirdparty/stb/stb_voxel_render.h | 3807 + source/engine/window.c | 20 + source/engine/window.h | 8 +- source/engine/yugine.c | 73 + source/{engine => pinball}/pinball.c | 0 source/{engine => pinball}/pinball.h | 0 248 files changed, 539445 insertions(+), 264 deletions(-) create mode 100644 source/editor/imgui/LICENSE.txt create mode 100644 source/editor/imgui/backends/imgui_impl_allegro5.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_allegro5.h create mode 100644 source/editor/imgui/backends/imgui_impl_android.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_android.h create mode 100644 source/editor/imgui/backends/imgui_impl_dx10.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_dx10.h create mode 100644 source/editor/imgui/backends/imgui_impl_dx11.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_dx11.h create mode 100644 source/editor/imgui/backends/imgui_impl_dx12.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_dx12.h create mode 100644 source/editor/imgui/backends/imgui_impl_dx9.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_dx9.h create mode 100644 source/editor/imgui/backends/imgui_impl_glfw.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_glfw.h create mode 100644 source/editor/imgui/backends/imgui_impl_glut.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_glut.h create mode 100644 source/editor/imgui/backends/imgui_impl_marmalade.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_marmalade.h create mode 100644 source/editor/imgui/backends/imgui_impl_metal.h create mode 100644 source/editor/imgui/backends/imgui_impl_metal.mm create mode 100644 source/editor/imgui/backends/imgui_impl_opengl2.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_opengl2.h create mode 100644 source/editor/imgui/backends/imgui_impl_opengl3.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_opengl3.h create mode 100644 source/editor/imgui/backends/imgui_impl_opengl3_loader.h create mode 100644 source/editor/imgui/backends/imgui_impl_osx.h create mode 100644 source/editor/imgui/backends/imgui_impl_osx.mm create mode 100644 source/editor/imgui/backends/imgui_impl_sdl.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_sdl.h create mode 100644 source/editor/imgui/backends/imgui_impl_vulkan.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_vulkan.h create mode 100644 source/editor/imgui/backends/imgui_impl_wgpu.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_wgpu.h create mode 100644 source/editor/imgui/backends/imgui_impl_win32.cpp create mode 100644 source/editor/imgui/backends/imgui_impl_win32.h create mode 100755 source/editor/imgui/backends/vulkan/generate_spv.sh create mode 100644 source/editor/imgui/backends/vulkan/glsl_shader.frag create mode 100644 source/editor/imgui/backends/vulkan/glsl_shader.vert create mode 100644 source/editor/imgui/imconfig.h create mode 100644 source/editor/imgui/imgui.cpp create mode 100644 source/editor/imgui/imgui.h create mode 100644 source/editor/imgui/imgui_demo.cpp create mode 100644 source/editor/imgui/imgui_draw.cpp create mode 100644 source/editor/imgui/imgui_internal.h create mode 100644 source/editor/imgui/imgui_tables.cpp create mode 100644 source/editor/imgui/imgui_widgets.cpp create mode 100644 source/editor/imgui/imstb_rectpack.h create mode 100644 source/editor/imgui/imstb_textedit.h create mode 100644 source/editor/imgui/imstb_truetype.h rename source/{editor => engine}/debugdraw.c (100%) rename source/{editor => engine}/debugdraw.h (100%) create mode 100644 source/engine/engine.h create mode 100644 source/engine/sound.c create mode 100644 source/engine/sound.h create mode 100644 source/engine/thirdparty/Chipmunk2D/LICENSE.txt create mode 100644 source/engine/thirdparty/Chipmunk2D/VERSION.txt create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/examples.html create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/examples/BreakableJoint.html create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/examples/CollisionCallback.html create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/examples/Crushing.html create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/examples/DynamicStatic.html create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/examples/Hello Chipmunk.html create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/examples/JointRecipies.html create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/examples/Moments.html create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/examples/PlaySoundOnCollision.html create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/examples/Sleeping.html create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/examples/cpConvexHull.html create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/examples/cpSpaceEachBody.html create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/images/hash_just_right.png create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/images/hash_too_big.png create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/images/hash_too_small.png create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/images/hms_logo.png create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/images/logo1_med.png create mode 100644 source/engine/thirdparty/Chipmunk2D/doc/stylesheet.css create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_ffi.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_private.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_structs.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_types.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_unsafe.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpArbiter.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpBB.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpBody.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpConstraint.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpDampedRotarySpring.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpDampedSpring.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpGearJoint.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpGrooveJoint.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpHastySpace.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpMarch.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPinJoint.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPivotJoint.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPolyShape.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPolyline.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpRatchetJoint.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpRobust.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpRotaryLimitJoint.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpShape.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSimpleMotor.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSlideJoint.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSpace.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSpatialIndex.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpTransform.h create mode 100644 source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpVect.h create mode 100644 source/engine/thirdparty/Chipmunk2D/src/chipmunk.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpArbiter.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpArray.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpBBTree.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpBody.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpCollision.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpConstraint.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpDampedRotarySpring.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpDampedSpring.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpGearJoint.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpGrooveJoint.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpHashSet.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpHastySpace.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpMarch.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpPinJoint.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpPivotJoint.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpPolyShape.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpPolyline.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpRatchetJoint.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpRobust.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpRotaryLimitJoint.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpShape.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpSimpleMotor.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpSlideJoint.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpSpace.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpSpaceComponent.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpSpaceDebug.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpSpaceHash.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpSpaceQuery.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpSpaceStep.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpSpatialIndex.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/cpSweep1D.c create mode 100644 source/engine/thirdparty/Chipmunk2D/src/prime.h create mode 100644 source/engine/thirdparty/bitmap-outliner/LICENSE create mode 100644 source/engine/thirdparty/bitmap-outliner/README.md create mode 100644 source/engine/thirdparty/bitmap-outliner/bitmap-outliner-print.c create mode 100644 source/engine/thirdparty/bitmap-outliner/bitmap-outliner-print.h create mode 100644 source/engine/thirdparty/bitmap-outliner/bitmap-outliner.c create mode 100644 source/engine/thirdparty/bitmap-outliner/bitmap-outliner.h create mode 100644 source/engine/thirdparty/cgltf/LICENSE create mode 100644 source/engine/thirdparty/cgltf/README.md create mode 100644 source/engine/thirdparty/cgltf/cgltf.h create mode 100644 source/engine/thirdparty/cgltf/cgltf_write.h create mode 100644 source/engine/thirdparty/enet/ChangeLog create mode 100644 source/engine/thirdparty/enet/LICENSE create mode 100644 source/engine/thirdparty/enet/README create mode 100644 source/engine/thirdparty/enet/docs/FAQ.dox create mode 100644 source/engine/thirdparty/enet/docs/design.dox create mode 100644 source/engine/thirdparty/enet/docs/install.dox create mode 100644 source/engine/thirdparty/enet/docs/license.dox create mode 100644 source/engine/thirdparty/enet/docs/mainpage.dox create mode 100644 source/engine/thirdparty/enet/docs/tutorial.dox create mode 100644 source/engine/thirdparty/enet/include/enet/callbacks.h create mode 100644 source/engine/thirdparty/enet/include/enet/enet.h create mode 100644 source/engine/thirdparty/enet/include/enet/list.h create mode 100644 source/engine/thirdparty/enet/include/enet/protocol.h create mode 100644 source/engine/thirdparty/enet/include/enet/time.h create mode 100644 source/engine/thirdparty/enet/include/enet/types.h create mode 100644 source/engine/thirdparty/enet/include/enet/unix.h create mode 100644 source/engine/thirdparty/enet/include/enet/utility.h create mode 100644 source/engine/thirdparty/enet/include/enet/win32.h create mode 100644 source/engine/thirdparty/enet/src/callbacks.c create mode 100644 source/engine/thirdparty/enet/src/compress.c create mode 100644 source/engine/thirdparty/enet/src/host.c create mode 100644 source/engine/thirdparty/enet/src/list.c create mode 100644 source/engine/thirdparty/enet/src/packet.c create mode 100644 source/engine/thirdparty/enet/src/peer.c create mode 100644 source/engine/thirdparty/enet/src/protocol.c create mode 100644 source/engine/thirdparty/enet/src/unix.c create mode 100644 source/engine/thirdparty/enet/src/win32.c create mode 100644 source/engine/thirdparty/pl_mpeg/README.md create mode 100644 source/engine/thirdparty/pl_mpeg/pl_mpeg.h create mode 100644 source/engine/thirdparty/pl_mpeg/pl_mpeg_extract_frames.c create mode 100644 source/engine/thirdparty/pl_mpeg/pl_mpeg_player.c create mode 100644 source/engine/thirdparty/s7/mus-config.h create mode 100644 source/engine/thirdparty/s7/s7.c create mode 100644 source/engine/thirdparty/s7/s7.h create mode 100644 source/engine/thirdparty/s7/s7.html create mode 100644 source/engine/thirdparty/sqlite3/README.txt create mode 100644 source/engine/thirdparty/sqlite3/shell.c create mode 100644 source/engine/thirdparty/sqlite3/sqlite3.c create mode 100644 source/engine/thirdparty/sqlite3/sqlite3.h create mode 100644 source/engine/thirdparty/sqlite3/sqlite3ext.h create mode 100644 source/engine/thirdparty/stb/LICENSE create mode 100644 source/engine/thirdparty/stb/README.md create mode 100644 source/engine/thirdparty/stb/docs/other_libs.md create mode 100644 source/engine/thirdparty/stb/docs/stb_howto.txt create mode 100644 source/engine/thirdparty/stb/docs/stb_voxel_render_interview.md create mode 100644 source/engine/thirdparty/stb/docs/why_public_domain.md create mode 100644 source/engine/thirdparty/stb/stb_c_lexer.h create mode 100644 source/engine/thirdparty/stb/stb_connected_components.h create mode 100644 source/engine/thirdparty/stb/stb_divide.h create mode 100644 source/engine/thirdparty/stb/stb_ds.h create mode 100644 source/engine/thirdparty/stb/stb_dxt.h create mode 100644 source/engine/thirdparty/stb/stb_easy_font.h create mode 100644 source/engine/thirdparty/stb/stb_herringbone_wang_tile.h create mode 100644 source/engine/thirdparty/stb/stb_hexwave.h create mode 100644 source/engine/thirdparty/stb/stb_image.h create mode 100644 source/engine/thirdparty/stb/stb_image_resize.h create mode 100644 source/engine/thirdparty/stb/stb_image_write.h create mode 100644 source/engine/thirdparty/stb/stb_include.h create mode 100644 source/engine/thirdparty/stb/stb_leakcheck.h create mode 100644 source/engine/thirdparty/stb/stb_rect_pack.h create mode 100644 source/engine/thirdparty/stb/stb_sprintf.h create mode 100644 source/engine/thirdparty/stb/stb_textedit.h create mode 100644 source/engine/thirdparty/stb/stb_tilemap_editor.h create mode 100644 source/engine/thirdparty/stb/stb_truetype.h create mode 100644 source/engine/thirdparty/stb/stb_vorbis.c create mode 100644 source/engine/thirdparty/stb/stb_voxel_render.h create mode 100644 source/engine/yugine.c rename source/{engine => pinball}/pinball.c (100%) rename source/{engine => pinball}/pinball.h (100%) diff --git a/Makefile b/Makefile index 058c893..b6adfa5 100644 --- a/Makefile +++ b/Makefile @@ -1,11 +1,5 @@ MAKEFLAGS := --jobs=$(shell nproc) -TARGET := game -INFO := - -EDITOR := 1 -DEBUG := 1 - UNAME := $(shell uname) ifeq ($(OS),Windows_NT) @@ -18,13 +12,6 @@ UNAME_P := $(shell uname -m) CC = clang -x c --std=c99 CXX = clang++ -DEFFLAGS := - -ifeq ($(EDITOR), 1) - DEFFLAGS += -DEDITOR - TARGET = editor -endif - ifeq ($(DEBUG), 1) DEFFALGS += -DDEBUG INFO = dbg @@ -33,28 +20,38 @@ endif BINDIR := ./bin BUILDDIR := ./obj -THIRDPARTY_DIR := ./source/thirdparty -THIRDPARTY_DIRS := ${sort ${dir ${wildcard ${THIRDPARTY_DIR}/*/}}} -THIRDPARTY_I := $(addsuffix include, ${THIRDPARTY_DIRS}) $(addsuffix src, $(THIRDPARTY_DIRS)) $(THIRDPARTY_DIRS) $(addsuffix build/include, $(THIRDPARTY_DIRS)) $(addsuffix include/chipmunk, $(THIRDPARTY_DIRS)) -THIRDPARTY_L := $(addsuffix build/lib, $(THIRDPARTY_DIRS)) $(addsuffix build, ${THIRDPARTY_DIRS}) $(addsuffix build/bin, $(THIRDPARTY_DIRS) $(addsuffix build/src, $(THIRDPARTY_DIRS))) +objprefix = ./obj -# imgui sources -IMGUI_DIR := ${THIRDPARTY_DIR}/imgui -imgui = $(addprefix ${IMGUI_DIR}/, imgui imgui_draw imgui_widgets imgui_tables) -imguibackends = $(addprefix ${IMGUI_DIR}/backends/, imgui_impl_sdl imgui_impl_opengl3) -imguiobjs := $(addsuffix .cpp, $(imgui) $(imguibackends)) +DIRS := engine pinball editor brainstorm -plmpeg_objs := ${THIRDPARTY_DIR}/pl_mpeg/pl_mpeg_extract_frames.c -cpobjs := $(wildcard ${THIRDPARTY_DIR}/Chipmunk2D/src/*.c) -s7objs := ${THIRDPARTY_DIR}/s7/s7.c +# All other sources +esrcs := $(shell find ./source/engine -name '*.c*') +esrcs := $(filter-out %sqlite3.c %shell.c %s7.c, $(esrcs)) +eheaders := $(shell find ./source/engine -name '*.h') +edirs := $(shell find ./source/engine -type d) +edirs := $(filter-out %docs %doc %include% %src %examples , $(edirs)) -includeflag := $(addprefix -I, $(THIRDPARTY_I) ./source/engine ./source/editor $(IMGUI_DIR) $(IMGUI_DIR)/backends) +eobjects := $(sort $(patsubst .%.cpp, $(objprefix)%.o, $(filter %.cpp, $(esrcs))) $(patsubst .%.c, $(objprefix)%.o, $(filter %.c, $(esrcs)))) -#LIBRARY_PATHS specifies the additional library paths we'll need -LIB_PATHS := $(addprefix -L, $(THIRDPARTY_L)) +edsrcs := $(shell find ./source/editor -name '*.c*') +edheaders := $(shell find ./source/editor -name '*.h') +eddirs := $(shell find ./source/editor -type d) -# Engine sources -sources := $(wildcard ./source/engine/*.cpp ./source/engine/*.c ./source/editor/*.c ./source/editor/*.cpp) $(imguiobjs) $(s7objs) $(cpobjs) +edobjects := $(sort $(patsubst .%.cpp, $(objprefix)%.o, $(filter %.cpp, $(edsrcs))) $(patsubst .%.c, $(objprefix)%.o, $(filter %.c, $(edsrcs)))) + +bssrcs := $(shell find ./source/brainstorm -name '*.c*') +bsheaders := $(shell find ./source/brainstorm -name '*.h') +eddirs := $(shell find ./source/brainstorm -type d) + +bsobjects := $(sort $(patsubst .%.cpp, $(objprefix)%.o, $(filter %.cpp, $(bssrcs))) $(patsubst .%.c, $(objprefix)%.o, $(filter %.c, $(bssrcs)))) + +pinsrcs := $(shell find ./source/editor -name '*.c*') +pinheaders := $(shell find ./source/editor -name '*.h') +pindirs := $(shell find ./source/pinball -type d) + +edobjects := $(sort $(patsubst .%.cpp, $(objprefix)%.o, $(filter %.cpp, $(edsrcs))) $(patsubst .%.c, $(objprefix)%.o, $(filter %.c, $(edsrcs)))) + +includeflag := $(addprefix -I, $(edirs) $(eddirs) $(pindirs) $(bsdirs)) #COMPILER_FLAGS specifies the additional compilation options we're using WARNING_FLAGS := -w #-pedantic -Wall -Wextra -Wwrite-strings @@ -70,57 +67,43 @@ ifeq ($(UNAME), Windows_NT) else LINKER_FLAGS := ELIBS := - CLIBS := SDL2 GLEW GL dl pthread + CLIBS := SDL2 SDL2_mixer GLEW GL dl pthread EXT := endif LELIBS := -Wl,-Bstatic $(addprefix -l, ${ELIBS}) -Wl,-Bdynamic $(addprefix -l, $(CLIBS)) -BUILDD = -DGLEW_STATIC - dir_guard = @mkdir -p $(@D) -objprefix = ./obj/$(UNAME)/$(UNAME_P)/$(TARGET)$(INFO) - -objects := $(patsubst .%.cpp, $(objprefix)%.o, $(filter %.cpp, $(sources))) $(patsubst .%.c, $(objprefix)%.o, $(filter %.c, $(sources))) -objects := $(sort $(objects)) -depends := $(patsubst %.o, %.d, $(objects)) - FILENAME = $(TARGET)$(INFO)_$(UNAME_P)$(EXT) -all: install +eobjects := $(filter-out %yugine.o, $(eobjects)) -$(TARGET): $(objects) - @echo Linking $(TARGET) - @$(CXX) $^ -DGLEW_STATIC $(LINKER_FLAGS) $(LIB_PATHS) $(LELIBS) -o $@ +.SECONARY: $(eobjects) -install: $(TARGET) - mkdir -p bin/$(UNAME) && cp $(TARGET) bin/$(UNAME)/$(FILENAME) - cp $(TARGET) yugine/$(FILENAME) - rm $(TARGET) +engine: engine.a + @echo Linking engine + -$(CXX) $^ -DGLEW_STATIC $(LINKER_FLAGS) $(LELIBS) -o $@ --include $(depends) +engine.a: $(eobjects) + @echo Making library engine.a + -@ar -rv engine.a $(eobjects) + +brainstorms: engine.a $(bsobjects) + @echo Making brainstorm + $(CXX) $^ -DGLEW_STATIC $(LINKER_FLAGS) $(LELIBS) -o $@ $(objprefix)/%.o:%.cpp $(dir_guard) - @echo Making C++ object $(notdir $@) - -@$(CXX) $(BUILDD) $(DEFFLAGS) $(includeflag) $(COMPILER_FLAGS) -MD -c $< -o $@ + @echo Making C++ object $@ + -@$(CXX) $(includeflag) $(COMPILER_FLAGS) -c $< -o $@ $(objprefix)/%.o:%.c $(dir_guard) - @echo Making C object $(notdir $@) - -@$(CC) $(BUILDD) $(DEFFLAGS) $(includeflag) $(COMPILER_FLAGS) -MD -c $< -o $@ + @echo Making C object $@ + $(CC) $(includeflag) $(COMPILER_FLAGS) -c $< -o $@ clean: @echo Cleaning project - @rm -f $(objects) $(depends) + @rm -f $(eobjects) -bsclean: - rm -f $(bsobjects) - -gameclean: - rm -f $(gameobjects) - -TAGS: $(sources) $(edsources) - @echo Generating TAGS file - @ctags -eR $^ diff --git a/source/editor/editor.cpp b/source/editor/editor.cpp index 3b3a5ef..a119314 100644 --- a/source/editor/editor.cpp +++ b/source/editor/editor.cpp @@ -260,7 +260,7 @@ void editor_save() fclose(feditor); } -void editor_init(struct mSDLWindow *mwindow) +void editor_init(struct mSDLWindow *window) { projects = vec_make(sizeof(struct gameproject), 5); levels = vec_make(MAXNAME, 10); @@ -286,7 +286,7 @@ void editor_init(struct mSDLWindow *mwindow) ImGui_ImplOpenGL3_Init(); } -void editor_input(SDL_Event * e) +void editor_input(struct mSDLWindow *window, SDL_Event * e) { ImGui_ImplSDL2_ProcessEvent(e); io = &ImGui::GetIO(); @@ -840,9 +840,7 @@ void editor_selectasset(struct fileasset *asset) const char *ext = get_extension(asset->filename); if (!strcmp(ext + 1, "png") || !strcmp(ext + 1, "jpg")) { - asset->data = - texture_loadfromfile((struct Texture *) asset->data, - asset->filename); + asset->data = texture_loadfromfile(asset->filename); tex_gui_anim.tex = (struct Texture *) asset->data; asset->type = ASSET_TYPE_IMAGE; tex_anim_set(&tex_gui_anim); @@ -1046,7 +1044,7 @@ void editor_proj_select_gui() void editor_init_project(struct gameproject *gp) { cur_project = gp; - DATA_PATH = gp->path; + DATA_PATH = strdup(gp->path); stemlen = strlen(DATA_PATH); findPrefabs(); get_levels(); diff --git a/source/editor/editor.h b/source/editor/editor.h index a0861bd..021bde4 100644 --- a/source/editor/editor.h +++ b/source/editor/editor.h @@ -2,7 +2,7 @@ #define EDITOR_H #include "config.h" -#include +#include #include #include "resources.h" @@ -45,8 +45,8 @@ struct Texture; void pickGameObject(int pickID); int is_allowed_extension(const char *ext); -void editor_init(struct mSDLWindow *mwindow); -void editor_input(SDL_Event * e); +void editor_init(struct mSDLWindow *window); +void editor_input(struct mSDLWindow *window, SDL_Event * e); void editor_render(); int editor_wantkeyboard(); void editor_save(); diff --git a/source/editor/imgui/LICENSE.txt b/source/editor/imgui/LICENSE.txt new file mode 100644 index 0000000..780533d --- /dev/null +++ b/source/editor/imgui/LICENSE.txt @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2014-2021 Omar Cornut + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/source/editor/imgui/backends/imgui_impl_allegro5.cpp b/source/editor/imgui/backends/imgui_impl_allegro5.cpp new file mode 100644 index 0000000..93d84f1 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_allegro5.cpp @@ -0,0 +1,477 @@ +// dear imgui: Renderer + Platform Backend for Allegro 5 +// (Info: Allegro 5 is a cross-platform general purpose library for handling windows, inputs, graphics, etc.) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'ALLEGRO_BITMAP*' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Platform: Clipboard support (from Allegro 5.1.12) +// [X] Platform: Mouse cursor shape and visibility. Disable with 'io.ConfigFlags |= ImGuiConfigFlags_NoMouseCursorChange'. +// Issues: +// [ ] Renderer: The renderer is suboptimal as we need to unindex our buffers and convert vertices manually. +// [ ] Platform: Missing gamepad support. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-08-17: Calling io.AddFocusEvent() on ALLEGRO_EVENT_DISPLAY_SWITCH_OUT/ALLEGRO_EVENT_DISPLAY_SWITCH_IN events. +// 2021-06-29: Reorganized backend to pull data from a single structure to facilitate usage with multiple-contexts (all g_XXXX access changed to bd->XXXX). +// 2021-05-19: Renderer: Replaced direct access to ImDrawCmd::TextureId with a call to ImDrawCmd::GetTexID(). (will become a requirement) +// 2021-02-18: Change blending equation to preserve alpha in output buffer. +// 2020-08-10: Inputs: Fixed horizontal mouse wheel direction. +// 2019-12-05: Inputs: Added support for ImGuiMouseCursor_NotAllowed mouse cursor. +// 2019-07-21: Inputs: Added mapping for ImGuiKey_KeyPadEnter. +// 2019-05-11: Inputs: Don't filter character value from ALLEGRO_EVENT_KEY_CHAR before calling AddInputCharacter(). +// 2019-04-30: Renderer: Added support for special ImDrawCallback_ResetRenderState callback to reset render state. +// 2018-11-30: Platform: Added touchscreen support. +// 2018-11-30: Misc: Setting up io.BackendPlatformName/io.BackendRendererName so they can be displayed in the About Window. +// 2018-06-13: Platform: Added clipboard support (from Allegro 5.1.12). +// 2018-06-13: Renderer: Use draw_data->DisplayPos and draw_data->DisplaySize to setup projection matrix and clipping rectangle. +// 2018-06-13: Renderer: Backup/restore transform and clipping rectangle. +// 2018-06-11: Misc: Setup io.BackendFlags ImGuiBackendFlags_HasMouseCursors flag + honor ImGuiConfigFlags_NoMouseCursorChange flag. +// 2018-04-18: Misc: Renamed file from imgui_impl_a5.cpp to imgui_impl_allegro5.cpp. +// 2018-04-18: Misc: Added support for 32-bit vertex indices to avoid conversion at runtime. Added imconfig_allegro5.h to enforce 32-bit indices when included from imgui.h. +// 2018-02-16: Misc: Obsoleted the io.RenderDrawListsFn callback and exposed ImGui_ImplAllegro5_RenderDrawData() in the .h file so you can call it yourself. +// 2018-02-06: Misc: Removed call to ImGui::Shutdown() which is not available from 1.60 WIP, user needs to call CreateContext/DestroyContext themselves. +// 2018-02-06: Inputs: Added mapping for ImGuiKey_Space. + +#include // uint64_t +#include // memcpy +#include "imgui.h" +#include "imgui_impl_allegro5.h" + +// Allegro +#include +#include +#ifdef _WIN32 +#include +#endif +#define ALLEGRO_HAS_CLIPBOARD (ALLEGRO_VERSION_INT >= ((5 << 24) | (1 << 16) | (12 << 8))) // Clipboard only supported from Allegro 5.1.12 + +// Visual Studio warnings +#ifdef _MSC_VER +#pragma warning (disable: 4127) // condition expression is constant +#endif + +// Allegro Data +struct ImGui_ImplAllegro5_Data +{ + ALLEGRO_DISPLAY* Display; + ALLEGRO_BITMAP* Texture; + double Time; + ALLEGRO_MOUSE_CURSOR* MouseCursorInvisible; + ALLEGRO_VERTEX_DECL* VertexDecl; + char* ClipboardTextData; + + ImGui_ImplAllegro5_Data() { memset(this, 0, sizeof(*this)); } +}; + +// Backend data stored in io.BackendPlatformUserData to allow support for multiple Dear ImGui contexts +// It is STRONGLY preferred that you use docking branch with multi-viewports (== single Dear ImGui context + multiple windows) instead of multiple Dear ImGui contexts. +// FIXME: multi-context support is not well tested and probably dysfunctional in this backend. +static ImGui_ImplAllegro5_Data* ImGui_ImplAllegro5_GetBackendData() { return ImGui::GetCurrentContext() ? (ImGui_ImplAllegro5_Data*)ImGui::GetIO().BackendPlatformUserData : NULL; } + +struct ImDrawVertAllegro +{ + ImVec2 pos; + ImVec2 uv; + ALLEGRO_COLOR col; +}; + +static void ImGui_ImplAllegro5_SetupRenderState(ImDrawData* draw_data) +{ + // Setup blending + al_set_separate_blender(ALLEGRO_ADD, ALLEGRO_ALPHA, ALLEGRO_INVERSE_ALPHA, ALLEGRO_ADD, ALLEGRO_ONE, ALLEGRO_INVERSE_ALPHA); + + // Setup orthographic projection matrix + // Our visible imgui space lies from draw_data->DisplayPos (top left) to draw_data->DisplayPos+data_data->DisplaySize (bottom right). + { + float L = draw_data->DisplayPos.x; + float R = draw_data->DisplayPos.x + draw_data->DisplaySize.x; + float T = draw_data->DisplayPos.y; + float B = draw_data->DisplayPos.y + draw_data->DisplaySize.y; + ALLEGRO_TRANSFORM transform; + al_identity_transform(&transform); + al_use_transform(&transform); + al_orthographic_transform(&transform, L, T, 1.0f, R, B, -1.0f); + al_use_projection_transform(&transform); + } +} + +// Render function. +void ImGui_ImplAllegro5_RenderDrawData(ImDrawData* draw_data) +{ + // Avoid rendering when minimized + if (draw_data->DisplaySize.x <= 0.0f || draw_data->DisplaySize.y <= 0.0f) + return; + + // Backup Allegro state that will be modified + ImGui_ImplAllegro5_Data* bd = ImGui_ImplAllegro5_GetBackendData(); + ALLEGRO_TRANSFORM last_transform = *al_get_current_transform(); + ALLEGRO_TRANSFORM last_projection_transform = *al_get_current_projection_transform(); + int last_clip_x, last_clip_y, last_clip_w, last_clip_h; + al_get_clipping_rectangle(&last_clip_x, &last_clip_y, &last_clip_w, &last_clip_h); + int last_blender_op, last_blender_src, last_blender_dst; + al_get_blender(&last_blender_op, &last_blender_src, &last_blender_dst); + + // Setup desired render state + ImGui_ImplAllegro5_SetupRenderState(draw_data); + + // Render command lists + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + + // Allegro's implementation of al_draw_indexed_prim() for DX9 is completely broken. Unindex our buffers ourselves. + // FIXME-OPT: Unfortunately Allegro doesn't support 32-bit packed colors so we have to convert them to 4 float as well.. + static ImVector vertices; + vertices.resize(cmd_list->IdxBuffer.Size); + for (int i = 0; i < cmd_list->IdxBuffer.Size; i++) + { + const ImDrawVert* src_v = &cmd_list->VtxBuffer[cmd_list->IdxBuffer[i]]; + ImDrawVertAllegro* dst_v = &vertices[i]; + dst_v->pos = src_v->pos; + dst_v->uv = src_v->uv; + unsigned char* c = (unsigned char*)&src_v->col; + dst_v->col = al_map_rgba(c[0], c[1], c[2], c[3]); + } + + const int* indices = NULL; + if (sizeof(ImDrawIdx) == 2) + { + // FIXME-OPT: Unfortunately Allegro doesn't support 16-bit indices.. You can '#define ImDrawIdx int' in imconfig.h to request Dear ImGui to output 32-bit indices. + // Otherwise, we convert them from 16-bit to 32-bit at runtime here, which works perfectly but is a little wasteful. + static ImVector indices_converted; + indices_converted.resize(cmd_list->IdxBuffer.Size); + for (int i = 0; i < cmd_list->IdxBuffer.Size; ++i) + indices_converted[i] = (int)cmd_list->IdxBuffer.Data[i]; + indices = indices_converted.Data; + } + else if (sizeof(ImDrawIdx) == 4) + { + indices = (const int*)cmd_list->IdxBuffer.Data; + } + + // Render command lists + int idx_offset = 0; + ImVec2 clip_off = draw_data->DisplayPos; + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + const ImDrawCmd* pcmd = &cmd_list->CmdBuffer[cmd_i]; + if (pcmd->UserCallback) + { + // User callback, registered via ImDrawList::AddCallback() + // (ImDrawCallback_ResetRenderState is a special callback value used by the user to request the renderer to reset render state.) + if (pcmd->UserCallback == ImDrawCallback_ResetRenderState) + ImGui_ImplAllegro5_SetupRenderState(draw_data); + else + pcmd->UserCallback(cmd_list, pcmd); + } + else + { + // Project scissor/clipping rectangles into framebuffer space + ImVec2 clip_min(pcmd->ClipRect.x - clip_off.x, pcmd->ClipRect.y - clip_off.y); + ImVec2 clip_max(pcmd->ClipRect.z - clip_off.x, pcmd->ClipRect.w - clip_off.y); + if (clip_max.x < clip_min.x || clip_max.y < clip_min.y) + continue; + + // Apply scissor/clipping rectangle, Draw + ALLEGRO_BITMAP* texture = (ALLEGRO_BITMAP*)pcmd->GetTexID(); + al_set_clipping_rectangle(clip_min.x, clip_min.y, clip_max.x - clip_min.x, clip_max.y - clip_min.y); + al_draw_prim(&vertices[0], bd->VertexDecl, texture, idx_offset, idx_offset + pcmd->ElemCount, ALLEGRO_PRIM_TRIANGLE_LIST); + } + idx_offset += pcmd->ElemCount; + } + } + + // Restore modified Allegro state + al_set_blender(last_blender_op, last_blender_src, last_blender_dst); + al_set_clipping_rectangle(last_clip_x, last_clip_y, last_clip_w, last_clip_h); + al_use_transform(&last_transform); + al_use_projection_transform(&last_projection_transform); +} + +bool ImGui_ImplAllegro5_CreateDeviceObjects() +{ + // Build texture atlas + ImGui_ImplAllegro5_Data* bd = ImGui_ImplAllegro5_GetBackendData(); + ImGuiIO& io = ImGui::GetIO(); + unsigned char* pixels; + int width, height; + io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height); + + // Create texture + int flags = al_get_new_bitmap_flags(); + int fmt = al_get_new_bitmap_format(); + al_set_new_bitmap_flags(ALLEGRO_MEMORY_BITMAP | ALLEGRO_MIN_LINEAR | ALLEGRO_MAG_LINEAR); + al_set_new_bitmap_format(ALLEGRO_PIXEL_FORMAT_ABGR_8888_LE); + ALLEGRO_BITMAP* img = al_create_bitmap(width, height); + al_set_new_bitmap_flags(flags); + al_set_new_bitmap_format(fmt); + if (!img) + return false; + + ALLEGRO_LOCKED_REGION* locked_img = al_lock_bitmap(img, al_get_bitmap_format(img), ALLEGRO_LOCK_WRITEONLY); + if (!locked_img) + { + al_destroy_bitmap(img); + return false; + } + memcpy(locked_img->data, pixels, sizeof(int) * width * height); + al_unlock_bitmap(img); + + // Convert software texture to hardware texture. + ALLEGRO_BITMAP* cloned_img = al_clone_bitmap(img); + al_destroy_bitmap(img); + if (!cloned_img) + return false; + + // Store our identifier + io.Fonts->SetTexID((void*)cloned_img); + bd->Texture = cloned_img; + + // Create an invisible mouse cursor + // Because al_hide_mouse_cursor() seems to mess up with the actual inputs.. + ALLEGRO_BITMAP* mouse_cursor = al_create_bitmap(8, 8); + bd->MouseCursorInvisible = al_create_mouse_cursor(mouse_cursor, 0, 0); + al_destroy_bitmap(mouse_cursor); + + return true; +} + +void ImGui_ImplAllegro5_InvalidateDeviceObjects() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplAllegro5_Data* bd = ImGui_ImplAllegro5_GetBackendData(); + if (bd->Texture) + { + io.Fonts->SetTexID(NULL); + al_destroy_bitmap(bd->Texture); + bd->Texture = NULL; + } + if (bd->MouseCursorInvisible) + { + al_destroy_mouse_cursor(bd->MouseCursorInvisible); + bd->MouseCursorInvisible = NULL; + } +} + +#if ALLEGRO_HAS_CLIPBOARD +static const char* ImGui_ImplAllegro5_GetClipboardText(void*) +{ + ImGui_ImplAllegro5_Data* bd = ImGui_ImplAllegro5_GetBackendData(); + if (bd->ClipboardTextData) + al_free(bd->ClipboardTextData); + bd->ClipboardTextData = al_get_clipboard_text(bd->Display); + return bd->ClipboardTextData; +} + +static void ImGui_ImplAllegro5_SetClipboardText(void*, const char* text) +{ + ImGui_ImplAllegro5_Data* bd = ImGui_ImplAllegro5_GetBackendData(); + al_set_clipboard_text(bd->Display, text); +} +#endif + +bool ImGui_ImplAllegro5_Init(ALLEGRO_DISPLAY* display) +{ + ImGuiIO& io = ImGui::GetIO(); + IM_ASSERT(io.BackendPlatformUserData == NULL && "Already initialized a platform backend!"); + + // Setup backend capabilities flags + ImGui_ImplAllegro5_Data* bd = IM_NEW(ImGui_ImplAllegro5_Data)(); + io.BackendPlatformUserData = (void*)bd; + io.BackendPlatformName = io.BackendRendererName = "imgui_impl_allegro5"; + io.BackendFlags |= ImGuiBackendFlags_HasMouseCursors; // We can honor GetMouseCursor() values (optional) + + bd->Display = display; + + // Create custom vertex declaration. + // Unfortunately Allegro doesn't support 32-bit packed colors so we have to convert them to 4 floats. + // We still use a custom declaration to use 'ALLEGRO_PRIM_TEX_COORD' instead of 'ALLEGRO_PRIM_TEX_COORD_PIXEL' else we can't do a reliable conversion. + ALLEGRO_VERTEX_ELEMENT elems[] = + { + { ALLEGRO_PRIM_POSITION, ALLEGRO_PRIM_FLOAT_2, IM_OFFSETOF(ImDrawVertAllegro, pos) }, + { ALLEGRO_PRIM_TEX_COORD, ALLEGRO_PRIM_FLOAT_2, IM_OFFSETOF(ImDrawVertAllegro, uv) }, + { ALLEGRO_PRIM_COLOR_ATTR, 0, IM_OFFSETOF(ImDrawVertAllegro, col) }, + { 0, 0, 0 } + }; + bd->VertexDecl = al_create_vertex_decl(elems, sizeof(ImDrawVertAllegro)); + + io.KeyMap[ImGuiKey_Tab] = ALLEGRO_KEY_TAB; + io.KeyMap[ImGuiKey_LeftArrow] = ALLEGRO_KEY_LEFT; + io.KeyMap[ImGuiKey_RightArrow] = ALLEGRO_KEY_RIGHT; + io.KeyMap[ImGuiKey_UpArrow] = ALLEGRO_KEY_UP; + io.KeyMap[ImGuiKey_DownArrow] = ALLEGRO_KEY_DOWN; + io.KeyMap[ImGuiKey_PageUp] = ALLEGRO_KEY_PGUP; + io.KeyMap[ImGuiKey_PageDown] = ALLEGRO_KEY_PGDN; + io.KeyMap[ImGuiKey_Home] = ALLEGRO_KEY_HOME; + io.KeyMap[ImGuiKey_End] = ALLEGRO_KEY_END; + io.KeyMap[ImGuiKey_Insert] = ALLEGRO_KEY_INSERT; + io.KeyMap[ImGuiKey_Delete] = ALLEGRO_KEY_DELETE; + io.KeyMap[ImGuiKey_Backspace] = ALLEGRO_KEY_BACKSPACE; + io.KeyMap[ImGuiKey_Space] = ALLEGRO_KEY_SPACE; + io.KeyMap[ImGuiKey_Enter] = ALLEGRO_KEY_ENTER; + io.KeyMap[ImGuiKey_Escape] = ALLEGRO_KEY_ESCAPE; + io.KeyMap[ImGuiKey_KeyPadEnter] = ALLEGRO_KEY_PAD_ENTER; + io.KeyMap[ImGuiKey_A] = ALLEGRO_KEY_A; + io.KeyMap[ImGuiKey_C] = ALLEGRO_KEY_C; + io.KeyMap[ImGuiKey_V] = ALLEGRO_KEY_V; + io.KeyMap[ImGuiKey_X] = ALLEGRO_KEY_X; + io.KeyMap[ImGuiKey_Y] = ALLEGRO_KEY_Y; + io.KeyMap[ImGuiKey_Z] = ALLEGRO_KEY_Z; + io.MousePos = ImVec2(-FLT_MAX, -FLT_MAX); + +#if ALLEGRO_HAS_CLIPBOARD + io.SetClipboardTextFn = ImGui_ImplAllegro5_SetClipboardText; + io.GetClipboardTextFn = ImGui_ImplAllegro5_GetClipboardText; + io.ClipboardUserData = NULL; +#endif + + return true; +} + +void ImGui_ImplAllegro5_Shutdown() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplAllegro5_Data* bd = ImGui_ImplAllegro5_GetBackendData(); + + ImGui_ImplAllegro5_InvalidateDeviceObjects(); + if (bd->VertexDecl) + al_destroy_vertex_decl(bd->VertexDecl); + if (bd->ClipboardTextData) + al_free(bd->ClipboardTextData); + + io.BackendPlatformUserData = NULL; + io.BackendPlatformName = io.BackendRendererName = NULL; + IM_DELETE(bd); +} + +// You can read the io.WantCaptureMouse, io.WantCaptureKeyboard flags to tell if dear imgui wants to use your inputs. +// - When io.WantCaptureMouse is true, do not dispatch mouse input data to your main application. +// - When io.WantCaptureKeyboard is true, do not dispatch keyboard input data to your main application. +// Generally you may always pass all inputs to dear imgui, and hide them from your application based on those two flags. +bool ImGui_ImplAllegro5_ProcessEvent(ALLEGRO_EVENT* ev) +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplAllegro5_Data* bd = ImGui_ImplAllegro5_GetBackendData(); + + switch (ev->type) + { + case ALLEGRO_EVENT_MOUSE_AXES: + if (ev->mouse.display == bd->Display) + { + io.MouseWheel += ev->mouse.dz; + io.MouseWheelH -= ev->mouse.dw; + io.MousePos = ImVec2(ev->mouse.x, ev->mouse.y); + } + return true; + case ALLEGRO_EVENT_MOUSE_BUTTON_DOWN: + case ALLEGRO_EVENT_MOUSE_BUTTON_UP: + if (ev->mouse.display == bd->Display && ev->mouse.button <= 5) + io.MouseDown[ev->mouse.button - 1] = (ev->type == ALLEGRO_EVENT_MOUSE_BUTTON_DOWN); + return true; + case ALLEGRO_EVENT_TOUCH_MOVE: + if (ev->touch.display == bd->Display) + io.MousePos = ImVec2(ev->touch.x, ev->touch.y); + return true; + case ALLEGRO_EVENT_TOUCH_BEGIN: + case ALLEGRO_EVENT_TOUCH_END: + case ALLEGRO_EVENT_TOUCH_CANCEL: + if (ev->touch.display == bd->Display && ev->touch.primary) + io.MouseDown[0] = (ev->type == ALLEGRO_EVENT_TOUCH_BEGIN); + return true; + case ALLEGRO_EVENT_MOUSE_LEAVE_DISPLAY: + if (ev->mouse.display == bd->Display) + io.MousePos = ImVec2(-FLT_MAX, -FLT_MAX); + return true; + case ALLEGRO_EVENT_KEY_CHAR: + if (ev->keyboard.display == bd->Display) + if (ev->keyboard.unichar != 0) + io.AddInputCharacter((unsigned int)ev->keyboard.unichar); + return true; + case ALLEGRO_EVENT_KEY_DOWN: + case ALLEGRO_EVENT_KEY_UP: + if (ev->keyboard.display == bd->Display) + io.KeysDown[ev->keyboard.keycode] = (ev->type == ALLEGRO_EVENT_KEY_DOWN); + return true; + case ALLEGRO_EVENT_DISPLAY_SWITCH_OUT: + if (ev->display.source == bd->Display) + io.AddFocusEvent(false); + return true; + case ALLEGRO_EVENT_DISPLAY_SWITCH_IN: + if (ev->display.source == bd->Display) + { + io.AddFocusEvent(true); +#if defined(ALLEGRO_UNSTABLE) + al_clear_keyboard_state(bd->Display); +#endif + } + return true; + } + return false; +} + +static void ImGui_ImplAllegro5_UpdateMouseCursor() +{ + ImGuiIO& io = ImGui::GetIO(); + if (io.ConfigFlags & ImGuiConfigFlags_NoMouseCursorChange) + return; + + ImGui_ImplAllegro5_Data* bd = ImGui_ImplAllegro5_GetBackendData(); + ImGuiMouseCursor imgui_cursor = ImGui::GetMouseCursor(); + if (io.MouseDrawCursor || imgui_cursor == ImGuiMouseCursor_None) + { + // Hide OS mouse cursor if imgui is drawing it or if it wants no cursor + al_set_mouse_cursor(bd->Display, bd->MouseCursorInvisible); + } + else + { + ALLEGRO_SYSTEM_MOUSE_CURSOR cursor_id = ALLEGRO_SYSTEM_MOUSE_CURSOR_DEFAULT; + switch (imgui_cursor) + { + case ImGuiMouseCursor_TextInput: cursor_id = ALLEGRO_SYSTEM_MOUSE_CURSOR_EDIT; break; + case ImGuiMouseCursor_ResizeAll: cursor_id = ALLEGRO_SYSTEM_MOUSE_CURSOR_MOVE; break; + case ImGuiMouseCursor_ResizeNS: cursor_id = ALLEGRO_SYSTEM_MOUSE_CURSOR_RESIZE_N; break; + case ImGuiMouseCursor_ResizeEW: cursor_id = ALLEGRO_SYSTEM_MOUSE_CURSOR_RESIZE_E; break; + case ImGuiMouseCursor_ResizeNESW: cursor_id = ALLEGRO_SYSTEM_MOUSE_CURSOR_RESIZE_NE; break; + case ImGuiMouseCursor_ResizeNWSE: cursor_id = ALLEGRO_SYSTEM_MOUSE_CURSOR_RESIZE_NW; break; + case ImGuiMouseCursor_NotAllowed: cursor_id = ALLEGRO_SYSTEM_MOUSE_CURSOR_UNAVAILABLE; break; + } + al_set_system_mouse_cursor(bd->Display, cursor_id); + } +} + +void ImGui_ImplAllegro5_NewFrame() +{ + ImGui_ImplAllegro5_Data* bd = ImGui_ImplAllegro5_GetBackendData(); + IM_ASSERT(bd != NULL && "Did you call ImGui_ImplAllegro5_Init()?"); + + if (!bd->Texture) + ImGui_ImplAllegro5_CreateDeviceObjects(); + + ImGuiIO& io = ImGui::GetIO(); + + // Setup display size (every frame to accommodate for window resizing) + int w, h; + w = al_get_display_width(bd->Display); + h = al_get_display_height(bd->Display); + io.DisplaySize = ImVec2((float)w, (float)h); + + // Setup time step + double current_time = al_get_time(); + io.DeltaTime = bd->Time > 0.0 ? (float)(current_time - bd->Time) : (float)(1.0f / 60.0f); + bd->Time = current_time; + + // Setup inputs + ALLEGRO_KEYBOARD_STATE keys; + al_get_keyboard_state(&keys); + io.KeyCtrl = al_key_down(&keys, ALLEGRO_KEY_LCTRL) || al_key_down(&keys, ALLEGRO_KEY_RCTRL); + io.KeyShift = al_key_down(&keys, ALLEGRO_KEY_LSHIFT) || al_key_down(&keys, ALLEGRO_KEY_RSHIFT); + io.KeyAlt = al_key_down(&keys, ALLEGRO_KEY_ALT) || al_key_down(&keys, ALLEGRO_KEY_ALTGR); + io.KeySuper = al_key_down(&keys, ALLEGRO_KEY_LWIN) || al_key_down(&keys, ALLEGRO_KEY_RWIN); + + ImGui_ImplAllegro5_UpdateMouseCursor(); +} diff --git a/source/editor/imgui/backends/imgui_impl_allegro5.h b/source/editor/imgui/backends/imgui_impl_allegro5.h new file mode 100644 index 0000000..06c7120 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_allegro5.h @@ -0,0 +1,31 @@ +// dear imgui: Renderer + Platform Backend for Allegro 5 +// (Info: Allegro 5 is a cross-platform general purpose library for handling windows, inputs, graphics, etc.) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'ALLEGRO_BITMAP*' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Platform: Clipboard support (from Allegro 5.1.12) +// [X] Platform: Mouse cursor shape and visibility. Disable with 'io.ConfigFlags |= ImGuiConfigFlags_NoMouseCursorChange'. +// Issues: +// [ ] Renderer: The renderer is suboptimal as we need to unindex our buffers and convert vertices manually. +// [ ] Platform: Missing gamepad support. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +struct ALLEGRO_DISPLAY; +union ALLEGRO_EVENT; + +IMGUI_IMPL_API bool ImGui_ImplAllegro5_Init(ALLEGRO_DISPLAY* display); +IMGUI_IMPL_API void ImGui_ImplAllegro5_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplAllegro5_NewFrame(); +IMGUI_IMPL_API void ImGui_ImplAllegro5_RenderDrawData(ImDrawData* draw_data); +IMGUI_IMPL_API bool ImGui_ImplAllegro5_ProcessEvent(ALLEGRO_EVENT* event); + +// Use if you want to reset your rendering device without losing Dear ImGui state. +IMGUI_IMPL_API bool ImGui_ImplAllegro5_CreateDeviceObjects(); +IMGUI_IMPL_API void ImGui_ImplAllegro5_InvalidateDeviceObjects(); diff --git a/source/editor/imgui/backends/imgui_impl_android.cpp b/source/editor/imgui/backends/imgui_impl_android.cpp new file mode 100644 index 0000000..aae8e6b --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_android.cpp @@ -0,0 +1,187 @@ +// dear imgui: Platform Binding for Android native app +// This needs to be used along with the OpenGL 3 Renderer (imgui_impl_opengl3) + +// Implemented features: +// [X] Platform: Keyboard arrays indexed using AKEYCODE_* codes, e.g. ImGui::IsKeyPressed(AKEYCODE_SPACE). +// Missing features: +// [ ] Platform: Clipboard support. +// [ ] Platform: Gamepad support. Enable with 'io.ConfigFlags |= ImGuiConfigFlags_NavEnableGamepad'. +// [ ] Platform: Mouse cursor shape and visibility. Disable with 'io.ConfigFlags |= ImGuiConfigFlags_NoMouseCursorChange'. FIXME: Check if this is even possible with Android. +// Important: +// - FIXME: On-screen keyboard currently needs to be enabled by the application (see examples/ and issue #3446) +// - FIXME: Unicode character inputs needs to be passed by Dear ImGui by the application (see examples/ and issue #3446) + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-03-04: Initial version. + +#include "imgui.h" +#include "imgui_impl_android.h" +#include +#include +#include +#include +#include +#include +#include + +// Android data +static double g_Time = 0.0; +static ANativeWindow* g_Window; +static char g_LogTag[] = "ImGuiExample"; +static std::map> g_KeyEventQueues; // FIXME: Remove dependency on map and queue once we use upcoming input queue. + +int32_t ImGui_ImplAndroid_HandleInputEvent(AInputEvent* input_event) +{ + ImGuiIO& io = ImGui::GetIO(); + int32_t event_type = AInputEvent_getType(input_event); + switch (event_type) + { + case AINPUT_EVENT_TYPE_KEY: + { + int32_t event_key_code = AKeyEvent_getKeyCode(input_event); + int32_t event_action = AKeyEvent_getAction(input_event); + int32_t event_meta_state = AKeyEvent_getMetaState(input_event); + + io.KeyCtrl = ((event_meta_state & AMETA_CTRL_ON) != 0); + io.KeyShift = ((event_meta_state & AMETA_SHIFT_ON) != 0); + io.KeyAlt = ((event_meta_state & AMETA_ALT_ON) != 0); + + switch (event_action) + { + // FIXME: AKEY_EVENT_ACTION_DOWN and AKEY_EVENT_ACTION_UP occur at once as soon as a touch pointer + // goes up from a key. We use a simple key event queue/ and process one event per key per frame in + // ImGui_ImplAndroid_NewFrame()...or consider using IO queue, if suitable: https://github.com/ocornut/imgui/issues/2787 + case AKEY_EVENT_ACTION_DOWN: + case AKEY_EVENT_ACTION_UP: + g_KeyEventQueues[event_key_code].push(event_action); + break; + default: + break; + } + break; + } + case AINPUT_EVENT_TYPE_MOTION: + { + int32_t event_action = AMotionEvent_getAction(input_event); + int32_t event_pointer_index = (event_action & AMOTION_EVENT_ACTION_POINTER_INDEX_MASK) >> AMOTION_EVENT_ACTION_POINTER_INDEX_SHIFT; + event_action &= AMOTION_EVENT_ACTION_MASK; + switch (event_action) + { + case AMOTION_EVENT_ACTION_DOWN: + case AMOTION_EVENT_ACTION_UP: + // Physical mouse buttons (and probably other physical devices) also invoke the actions AMOTION_EVENT_ACTION_DOWN/_UP, + // but we have to process them separately to identify the actual button pressed. This is done below via + // AMOTION_EVENT_ACTION_BUTTON_PRESS/_RELEASE. Here, we only process "FINGER" input (and "UNKNOWN", as a fallback). + if((AMotionEvent_getToolType(input_event, event_pointer_index) == AMOTION_EVENT_TOOL_TYPE_FINGER) + || (AMotionEvent_getToolType(input_event, event_pointer_index) == AMOTION_EVENT_TOOL_TYPE_UNKNOWN)) + { + io.MouseDown[0] = (event_action == AMOTION_EVENT_ACTION_DOWN); + io.MousePos = ImVec2(AMotionEvent_getX(input_event, event_pointer_index), AMotionEvent_getY(input_event, event_pointer_index)); + } + break; + case AMOTION_EVENT_ACTION_BUTTON_PRESS: + case AMOTION_EVENT_ACTION_BUTTON_RELEASE: + { + int32_t button_state = AMotionEvent_getButtonState(input_event); + io.MouseDown[0] = ((button_state & AMOTION_EVENT_BUTTON_PRIMARY) != 0); + io.MouseDown[1] = ((button_state & AMOTION_EVENT_BUTTON_SECONDARY) != 0); + io.MouseDown[2] = ((button_state & AMOTION_EVENT_BUTTON_TERTIARY) != 0); + } + break; + case AMOTION_EVENT_ACTION_HOVER_MOVE: // Hovering: Tool moves while NOT pressed (such as a physical mouse) + case AMOTION_EVENT_ACTION_MOVE: // Touch pointer moves while DOWN + io.MousePos = ImVec2(AMotionEvent_getX(input_event, event_pointer_index), AMotionEvent_getY(input_event, event_pointer_index)); + break; + case AMOTION_EVENT_ACTION_SCROLL: + io.MouseWheel = AMotionEvent_getAxisValue(input_event, AMOTION_EVENT_AXIS_VSCROLL, event_pointer_index); + io.MouseWheelH = AMotionEvent_getAxisValue(input_event, AMOTION_EVENT_AXIS_HSCROLL, event_pointer_index); + break; + default: + break; + } + } + return 1; + default: + break; + } + + return 0; +} + +bool ImGui_ImplAndroid_Init(ANativeWindow* window) +{ + g_Window = window; + g_Time = 0.0; + + // Setup backend capabilities flags + ImGuiIO& io = ImGui::GetIO(); + io.BackendPlatformName = "imgui_impl_android"; + + // Keyboard mapping. Dear ImGui will use those indices to peek into the io.KeysDown[] array. + io.KeyMap[ImGuiKey_Tab] = AKEYCODE_TAB; + io.KeyMap[ImGuiKey_LeftArrow] = AKEYCODE_DPAD_LEFT; // also covers physical keyboard arrow key + io.KeyMap[ImGuiKey_RightArrow] = AKEYCODE_DPAD_RIGHT; // also covers physical keyboard arrow key + io.KeyMap[ImGuiKey_UpArrow] = AKEYCODE_DPAD_UP; // also covers physical keyboard arrow key + io.KeyMap[ImGuiKey_DownArrow] = AKEYCODE_DPAD_DOWN; // also covers physical keyboard arrow key + io.KeyMap[ImGuiKey_PageUp] = AKEYCODE_PAGE_UP; + io.KeyMap[ImGuiKey_PageDown] = AKEYCODE_PAGE_DOWN; + io.KeyMap[ImGuiKey_Home] = AKEYCODE_MOVE_HOME; + io.KeyMap[ImGuiKey_End] = AKEYCODE_MOVE_END; + io.KeyMap[ImGuiKey_Insert] = AKEYCODE_INSERT; + io.KeyMap[ImGuiKey_Delete] = AKEYCODE_FORWARD_DEL; + io.KeyMap[ImGuiKey_Backspace] = AKEYCODE_DEL; + io.KeyMap[ImGuiKey_Space] = AKEYCODE_SPACE; + io.KeyMap[ImGuiKey_Enter] = AKEYCODE_ENTER; + io.KeyMap[ImGuiKey_Escape] = AKEYCODE_ESCAPE; + io.KeyMap[ImGuiKey_KeyPadEnter] = AKEYCODE_NUMPAD_ENTER; + io.KeyMap[ImGuiKey_A] = AKEYCODE_A; + io.KeyMap[ImGuiKey_C] = AKEYCODE_C; + io.KeyMap[ImGuiKey_V] = AKEYCODE_V; + io.KeyMap[ImGuiKey_X] = AKEYCODE_X; + io.KeyMap[ImGuiKey_Y] = AKEYCODE_Y; + io.KeyMap[ImGuiKey_Z] = AKEYCODE_Z; + + return true; +} + +void ImGui_ImplAndroid_Shutdown() +{ +} + +void ImGui_ImplAndroid_NewFrame() +{ + ImGuiIO& io = ImGui::GetIO(); + + // Process queued key events + // FIXME: This is a workaround for multiple key event actions occurring at once (see above) and can be removed once we use upcoming input queue. + for (auto& key_queue : g_KeyEventQueues) + { + if (key_queue.second.empty()) + continue; + io.KeysDown[key_queue.first] = (key_queue.second.front() == AKEY_EVENT_ACTION_DOWN); + key_queue.second.pop(); + } + + // Setup display size (every frame to accommodate for window resizing) + int32_t window_width = ANativeWindow_getWidth(g_Window); + int32_t window_height = ANativeWindow_getHeight(g_Window); + int display_width = window_width; + int display_height = window_height; + + io.DisplaySize = ImVec2((float)window_width, (float)window_height); + if (window_width > 0 && window_height > 0) + io.DisplayFramebufferScale = ImVec2((float)display_width / window_width, (float)display_height / window_height); + + // Setup time step + struct timespec current_timespec; + clock_gettime(CLOCK_MONOTONIC, ¤t_timespec); + double current_time = (double)(current_timespec.tv_sec) + (current_timespec.tv_nsec / 1000000000.0); + io.DeltaTime = g_Time > 0.0 ? (float)(current_time - g_Time) : (float)(1.0f / 60.0f); + g_Time = current_time; +} diff --git a/source/editor/imgui/backends/imgui_impl_android.h b/source/editor/imgui/backends/imgui_impl_android.h new file mode 100644 index 0000000..92b466b --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_android.h @@ -0,0 +1,27 @@ +// dear imgui: Platform Binding for Android native app +// This needs to be used along with the OpenGL 3 Renderer (imgui_impl_opengl3) + +// Implemented features: +// [X] Platform: Keyboard arrays indexed using AKEYCODE_* codes, e.g. ImGui::IsKeyPressed(AKEYCODE_SPACE). +// Missing features: +// [ ] Platform: Clipboard support. +// [ ] Platform: Gamepad support. Enable with 'io.ConfigFlags |= ImGuiConfigFlags_NavEnableGamepad'. +// [ ] Platform: Mouse cursor shape and visibility. Disable with 'io.ConfigFlags |= ImGuiConfigFlags_NoMouseCursorChange'. FIXME: Check if this is even possible with Android. +// Important: +// - FIXME: On-screen keyboard currently needs to be enabled by the application (see examples/ and issue #3446) +// - FIXME: Unicode character inputs needs to be passed by Dear ImGui by the application (see examples/ and issue #3446) + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#pragma once + +struct ANativeWindow; +struct AInputEvent; + +IMGUI_IMPL_API bool ImGui_ImplAndroid_Init(ANativeWindow* window); +IMGUI_IMPL_API int32_t ImGui_ImplAndroid_HandleInputEvent(AInputEvent* input_event); +IMGUI_IMPL_API void ImGui_ImplAndroid_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplAndroid_NewFrame(); diff --git a/source/editor/imgui/backends/imgui_impl_dx10.cpp b/source/editor/imgui/backends/imgui_impl_dx10.cpp new file mode 100644 index 0000000..8a3206f --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_dx10.cpp @@ -0,0 +1,577 @@ +// dear imgui: Renderer Backend for DirectX10 +// This needs to be used along with a Platform Backend (e.g. Win32) + +// Implemented features: +// [X] Renderer: User texture backend. Use 'ID3D10ShaderResourceView*' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-06-29: Reorganized backend to pull data from a single structure to facilitate usage with multiple-contexts (all g_XXXX access changed to bd->XXXX). +// 2021-05-19: DirectX10: Replaced direct access to ImDrawCmd::TextureId with a call to ImDrawCmd::GetTexID(). (will become a requirement) +// 2021-02-18: DirectX10: Change blending equation to preserve alpha in output buffer. +// 2019-07-21: DirectX10: Backup, clear and restore Geometry Shader is any is bound when calling ImGui_ImplDX10_RenderDrawData(). +// 2019-05-29: DirectX10: Added support for large mesh (64K+ vertices), enable ImGuiBackendFlags_RendererHasVtxOffset flag. +// 2019-04-30: DirectX10: Added support for special ImDrawCallback_ResetRenderState callback to reset render state. +// 2018-12-03: Misc: Added #pragma comment statement to automatically link with d3dcompiler.lib when using D3DCompile(). +// 2018-11-30: Misc: Setting up io.BackendRendererName so it can be displayed in the About Window. +// 2018-07-13: DirectX10: Fixed unreleased resources in Init and Shutdown functions. +// 2018-06-08: Misc: Extracted imgui_impl_dx10.cpp/.h away from the old combined DX10+Win32 example. +// 2018-06-08: DirectX10: Use draw_data->DisplayPos and draw_data->DisplaySize to setup projection matrix and clipping rectangle. +// 2018-04-09: Misc: Fixed erroneous call to io.Fonts->ClearInputData() + ClearTexData() that was left in DX10 example but removed in 1.47 (Nov 2015) on other backends. +// 2018-02-16: Misc: Obsoleted the io.RenderDrawListsFn callback and exposed ImGui_ImplDX10_RenderDrawData() in the .h file so you can call it yourself. +// 2018-02-06: Misc: Removed call to ImGui::Shutdown() which is not available from 1.60 WIP, user needs to call CreateContext/DestroyContext themselves. +// 2016-05-07: DirectX10: Disabling depth-write. + +#include "imgui.h" +#include "imgui_impl_dx10.h" + +// DirectX +#include +#include +#include +#include +#ifdef _MSC_VER +#pragma comment(lib, "d3dcompiler") // Automatically link with d3dcompiler.lib as we are using D3DCompile() below. +#endif + +// DirectX data +struct ImGui_ImplDX10_Data +{ + ID3D10Device* pd3dDevice; + IDXGIFactory* pFactory; + ID3D10Buffer* pVB; + ID3D10Buffer* pIB; + ID3D10VertexShader* pVertexShader; + ID3D10InputLayout* pInputLayout; + ID3D10Buffer* pVertexConstantBuffer; + ID3D10PixelShader* pPixelShader; + ID3D10SamplerState* pFontSampler; + ID3D10ShaderResourceView* pFontTextureView; + ID3D10RasterizerState* pRasterizerState; + ID3D10BlendState* pBlendState; + ID3D10DepthStencilState* pDepthStencilState; + int VertexBufferSize; + int IndexBufferSize; + + ImGui_ImplDX10_Data() { memset(this, 0, sizeof(*this)); VertexBufferSize = 5000; IndexBufferSize = 10000; } +}; + +struct VERTEX_CONSTANT_BUFFER +{ + float mvp[4][4]; +}; + +// Backend data stored in io.BackendRendererUserData to allow support for multiple Dear ImGui contexts +// It is STRONGLY preferred that you use docking branch with multi-viewports (== single Dear ImGui context + multiple windows) instead of multiple Dear ImGui contexts. +static ImGui_ImplDX10_Data* ImGui_ImplDX10_GetBackendData() +{ + return ImGui::GetCurrentContext() ? (ImGui_ImplDX10_Data*)ImGui::GetIO().BackendRendererUserData : NULL; +} + +// Functions +static void ImGui_ImplDX10_SetupRenderState(ImDrawData* draw_data, ID3D10Device* ctx) +{ + ImGui_ImplDX10_Data* bd = ImGui_ImplDX10_GetBackendData(); + + // Setup viewport + D3D10_VIEWPORT vp; + memset(&vp, 0, sizeof(D3D10_VIEWPORT)); + vp.Width = (UINT)draw_data->DisplaySize.x; + vp.Height = (UINT)draw_data->DisplaySize.y; + vp.MinDepth = 0.0f; + vp.MaxDepth = 1.0f; + vp.TopLeftX = vp.TopLeftY = 0; + ctx->RSSetViewports(1, &vp); + + // Bind shader and vertex buffers + unsigned int stride = sizeof(ImDrawVert); + unsigned int offset = 0; + ctx->IASetInputLayout(bd->pInputLayout); + ctx->IASetVertexBuffers(0, 1, &bd->pVB, &stride, &offset); + ctx->IASetIndexBuffer(bd->pIB, sizeof(ImDrawIdx) == 2 ? DXGI_FORMAT_R16_UINT : DXGI_FORMAT_R32_UINT, 0); + ctx->IASetPrimitiveTopology(D3D10_PRIMITIVE_TOPOLOGY_TRIANGLELIST); + ctx->VSSetShader(bd->pVertexShader); + ctx->VSSetConstantBuffers(0, 1, &bd->pVertexConstantBuffer); + ctx->PSSetShader(bd->pPixelShader); + ctx->PSSetSamplers(0, 1, &bd->pFontSampler); + ctx->GSSetShader(NULL); + + // Setup render state + const float blend_factor[4] = { 0.f, 0.f, 0.f, 0.f }; + ctx->OMSetBlendState(bd->pBlendState, blend_factor, 0xffffffff); + ctx->OMSetDepthStencilState(bd->pDepthStencilState, 0); + ctx->RSSetState(bd->pRasterizerState); +} + +// Render function +void ImGui_ImplDX10_RenderDrawData(ImDrawData* draw_data) +{ + // Avoid rendering when minimized + if (draw_data->DisplaySize.x <= 0.0f || draw_data->DisplaySize.y <= 0.0f) + return; + + ImGui_ImplDX10_Data* bd = ImGui_ImplDX10_GetBackendData(); + ID3D10Device* ctx = bd->pd3dDevice; + + // Create and grow vertex/index buffers if needed + if (!bd->pVB || bd->VertexBufferSize < draw_data->TotalVtxCount) + { + if (bd->pVB) { bd->pVB->Release(); bd->pVB = NULL; } + bd->VertexBufferSize = draw_data->TotalVtxCount + 5000; + D3D10_BUFFER_DESC desc; + memset(&desc, 0, sizeof(D3D10_BUFFER_DESC)); + desc.Usage = D3D10_USAGE_DYNAMIC; + desc.ByteWidth = bd->VertexBufferSize * sizeof(ImDrawVert); + desc.BindFlags = D3D10_BIND_VERTEX_BUFFER; + desc.CPUAccessFlags = D3D10_CPU_ACCESS_WRITE; + desc.MiscFlags = 0; + if (ctx->CreateBuffer(&desc, NULL, &bd->pVB) < 0) + return; + } + + if (!bd->pIB || bd->IndexBufferSize < draw_data->TotalIdxCount) + { + if (bd->pIB) { bd->pIB->Release(); bd->pIB = NULL; } + bd->IndexBufferSize = draw_data->TotalIdxCount + 10000; + D3D10_BUFFER_DESC desc; + memset(&desc, 0, sizeof(D3D10_BUFFER_DESC)); + desc.Usage = D3D10_USAGE_DYNAMIC; + desc.ByteWidth = bd->IndexBufferSize * sizeof(ImDrawIdx); + desc.BindFlags = D3D10_BIND_INDEX_BUFFER; + desc.CPUAccessFlags = D3D10_CPU_ACCESS_WRITE; + if (ctx->CreateBuffer(&desc, NULL, &bd->pIB) < 0) + return; + } + + // Copy and convert all vertices into a single contiguous buffer + ImDrawVert* vtx_dst = NULL; + ImDrawIdx* idx_dst = NULL; + bd->pVB->Map(D3D10_MAP_WRITE_DISCARD, 0, (void**)&vtx_dst); + bd->pIB->Map(D3D10_MAP_WRITE_DISCARD, 0, (void**)&idx_dst); + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + memcpy(vtx_dst, cmd_list->VtxBuffer.Data, cmd_list->VtxBuffer.Size * sizeof(ImDrawVert)); + memcpy(idx_dst, cmd_list->IdxBuffer.Data, cmd_list->IdxBuffer.Size * sizeof(ImDrawIdx)); + vtx_dst += cmd_list->VtxBuffer.Size; + idx_dst += cmd_list->IdxBuffer.Size; + } + bd->pVB->Unmap(); + bd->pIB->Unmap(); + + // Setup orthographic projection matrix into our constant buffer + // Our visible imgui space lies from draw_data->DisplayPos (top left) to draw_data->DisplayPos+data_data->DisplaySize (bottom right). DisplayPos is (0,0) for single viewport apps. + { + void* mapped_resource; + if (bd->pVertexConstantBuffer->Map(D3D10_MAP_WRITE_DISCARD, 0, &mapped_resource) != S_OK) + return; + VERTEX_CONSTANT_BUFFER* constant_buffer = (VERTEX_CONSTANT_BUFFER*)mapped_resource; + float L = draw_data->DisplayPos.x; + float R = draw_data->DisplayPos.x + draw_data->DisplaySize.x; + float T = draw_data->DisplayPos.y; + float B = draw_data->DisplayPos.y + draw_data->DisplaySize.y; + float mvp[4][4] = + { + { 2.0f/(R-L), 0.0f, 0.0f, 0.0f }, + { 0.0f, 2.0f/(T-B), 0.0f, 0.0f }, + { 0.0f, 0.0f, 0.5f, 0.0f }, + { (R+L)/(L-R), (T+B)/(B-T), 0.5f, 1.0f }, + }; + memcpy(&constant_buffer->mvp, mvp, sizeof(mvp)); + bd->pVertexConstantBuffer->Unmap(); + } + + // Backup DX state that will be modified to restore it afterwards (unfortunately this is very ugly looking and verbose. Close your eyes!) + struct BACKUP_DX10_STATE + { + UINT ScissorRectsCount, ViewportsCount; + D3D10_RECT ScissorRects[D3D10_VIEWPORT_AND_SCISSORRECT_OBJECT_COUNT_PER_PIPELINE]; + D3D10_VIEWPORT Viewports[D3D10_VIEWPORT_AND_SCISSORRECT_OBJECT_COUNT_PER_PIPELINE]; + ID3D10RasterizerState* RS; + ID3D10BlendState* BlendState; + FLOAT BlendFactor[4]; + UINT SampleMask; + UINT StencilRef; + ID3D10DepthStencilState* DepthStencilState; + ID3D10ShaderResourceView* PSShaderResource; + ID3D10SamplerState* PSSampler; + ID3D10PixelShader* PS; + ID3D10VertexShader* VS; + ID3D10GeometryShader* GS; + D3D10_PRIMITIVE_TOPOLOGY PrimitiveTopology; + ID3D10Buffer* IndexBuffer, *VertexBuffer, *VSConstantBuffer; + UINT IndexBufferOffset, VertexBufferStride, VertexBufferOffset; + DXGI_FORMAT IndexBufferFormat; + ID3D10InputLayout* InputLayout; + }; + BACKUP_DX10_STATE old = {}; + old.ScissorRectsCount = old.ViewportsCount = D3D10_VIEWPORT_AND_SCISSORRECT_OBJECT_COUNT_PER_PIPELINE; + ctx->RSGetScissorRects(&old.ScissorRectsCount, old.ScissorRects); + ctx->RSGetViewports(&old.ViewportsCount, old.Viewports); + ctx->RSGetState(&old.RS); + ctx->OMGetBlendState(&old.BlendState, old.BlendFactor, &old.SampleMask); + ctx->OMGetDepthStencilState(&old.DepthStencilState, &old.StencilRef); + ctx->PSGetShaderResources(0, 1, &old.PSShaderResource); + ctx->PSGetSamplers(0, 1, &old.PSSampler); + ctx->PSGetShader(&old.PS); + ctx->VSGetShader(&old.VS); + ctx->VSGetConstantBuffers(0, 1, &old.VSConstantBuffer); + ctx->GSGetShader(&old.GS); + ctx->IAGetPrimitiveTopology(&old.PrimitiveTopology); + ctx->IAGetIndexBuffer(&old.IndexBuffer, &old.IndexBufferFormat, &old.IndexBufferOffset); + ctx->IAGetVertexBuffers(0, 1, &old.VertexBuffer, &old.VertexBufferStride, &old.VertexBufferOffset); + ctx->IAGetInputLayout(&old.InputLayout); + + // Setup desired DX state + ImGui_ImplDX10_SetupRenderState(draw_data, ctx); + + // Render command lists + // (Because we merged all buffers into a single one, we maintain our own offset into them) + int global_vtx_offset = 0; + int global_idx_offset = 0; + ImVec2 clip_off = draw_data->DisplayPos; + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + const ImDrawCmd* pcmd = &cmd_list->CmdBuffer[cmd_i]; + if (pcmd->UserCallback) + { + // User callback, registered via ImDrawList::AddCallback() + // (ImDrawCallback_ResetRenderState is a special callback value used by the user to request the renderer to reset render state.) + if (pcmd->UserCallback == ImDrawCallback_ResetRenderState) + ImGui_ImplDX10_SetupRenderState(draw_data, ctx); + else + pcmd->UserCallback(cmd_list, pcmd); + } + else + { + // Project scissor/clipping rectangles into framebuffer space + ImVec2 clip_min(pcmd->ClipRect.x - clip_off.x, pcmd->ClipRect.y - clip_off.y); + ImVec2 clip_max(pcmd->ClipRect.z - clip_off.x, pcmd->ClipRect.w - clip_off.y); + if (clip_max.x < clip_min.x || clip_max.y < clip_min.y) + continue; + + // Apply scissor/clipping rectangle + const D3D10_RECT r = { (LONG)clip_min.x, (LONG)clip_min.y, (LONG)clip_max.x, (LONG)clip_max.y }; + ctx->RSSetScissorRects(1, &r); + + // Bind texture, Draw + ID3D10ShaderResourceView* texture_srv = (ID3D10ShaderResourceView*)pcmd->GetTexID(); + ctx->PSSetShaderResources(0, 1, &texture_srv); + ctx->DrawIndexed(pcmd->ElemCount, pcmd->IdxOffset + global_idx_offset, pcmd->VtxOffset + global_vtx_offset); + } + } + global_idx_offset += cmd_list->IdxBuffer.Size; + global_vtx_offset += cmd_list->VtxBuffer.Size; + } + + // Restore modified DX state + ctx->RSSetScissorRects(old.ScissorRectsCount, old.ScissorRects); + ctx->RSSetViewports(old.ViewportsCount, old.Viewports); + ctx->RSSetState(old.RS); if (old.RS) old.RS->Release(); + ctx->OMSetBlendState(old.BlendState, old.BlendFactor, old.SampleMask); if (old.BlendState) old.BlendState->Release(); + ctx->OMSetDepthStencilState(old.DepthStencilState, old.StencilRef); if (old.DepthStencilState) old.DepthStencilState->Release(); + ctx->PSSetShaderResources(0, 1, &old.PSShaderResource); if (old.PSShaderResource) old.PSShaderResource->Release(); + ctx->PSSetSamplers(0, 1, &old.PSSampler); if (old.PSSampler) old.PSSampler->Release(); + ctx->PSSetShader(old.PS); if (old.PS) old.PS->Release(); + ctx->VSSetShader(old.VS); if (old.VS) old.VS->Release(); + ctx->GSSetShader(old.GS); if (old.GS) old.GS->Release(); + ctx->VSSetConstantBuffers(0, 1, &old.VSConstantBuffer); if (old.VSConstantBuffer) old.VSConstantBuffer->Release(); + ctx->IASetPrimitiveTopology(old.PrimitiveTopology); + ctx->IASetIndexBuffer(old.IndexBuffer, old.IndexBufferFormat, old.IndexBufferOffset); if (old.IndexBuffer) old.IndexBuffer->Release(); + ctx->IASetVertexBuffers(0, 1, &old.VertexBuffer, &old.VertexBufferStride, &old.VertexBufferOffset); if (old.VertexBuffer) old.VertexBuffer->Release(); + ctx->IASetInputLayout(old.InputLayout); if (old.InputLayout) old.InputLayout->Release(); +} + +static void ImGui_ImplDX10_CreateFontsTexture() +{ + // Build texture atlas + ImGui_ImplDX10_Data* bd = ImGui_ImplDX10_GetBackendData(); + ImGuiIO& io = ImGui::GetIO(); + unsigned char* pixels; + int width, height; + io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height); + + // Upload texture to graphics system + { + D3D10_TEXTURE2D_DESC desc; + ZeroMemory(&desc, sizeof(desc)); + desc.Width = width; + desc.Height = height; + desc.MipLevels = 1; + desc.ArraySize = 1; + desc.Format = DXGI_FORMAT_R8G8B8A8_UNORM; + desc.SampleDesc.Count = 1; + desc.Usage = D3D10_USAGE_DEFAULT; + desc.BindFlags = D3D10_BIND_SHADER_RESOURCE; + desc.CPUAccessFlags = 0; + + ID3D10Texture2D* pTexture = NULL; + D3D10_SUBRESOURCE_DATA subResource; + subResource.pSysMem = pixels; + subResource.SysMemPitch = desc.Width * 4; + subResource.SysMemSlicePitch = 0; + bd->pd3dDevice->CreateTexture2D(&desc, &subResource, &pTexture); + IM_ASSERT(pTexture != NULL); + + // Create texture view + D3D10_SHADER_RESOURCE_VIEW_DESC srv_desc; + ZeroMemory(&srv_desc, sizeof(srv_desc)); + srv_desc.Format = DXGI_FORMAT_R8G8B8A8_UNORM; + srv_desc.ViewDimension = D3D10_SRV_DIMENSION_TEXTURE2D; + srv_desc.Texture2D.MipLevels = desc.MipLevels; + srv_desc.Texture2D.MostDetailedMip = 0; + bd->pd3dDevice->CreateShaderResourceView(pTexture, &srv_desc, &bd->pFontTextureView); + pTexture->Release(); + } + + // Store our identifier + io.Fonts->SetTexID((ImTextureID)bd->pFontTextureView); + + // Create texture sampler + { + D3D10_SAMPLER_DESC desc; + ZeroMemory(&desc, sizeof(desc)); + desc.Filter = D3D10_FILTER_MIN_MAG_MIP_LINEAR; + desc.AddressU = D3D10_TEXTURE_ADDRESS_WRAP; + desc.AddressV = D3D10_TEXTURE_ADDRESS_WRAP; + desc.AddressW = D3D10_TEXTURE_ADDRESS_WRAP; + desc.MipLODBias = 0.f; + desc.ComparisonFunc = D3D10_COMPARISON_ALWAYS; + desc.MinLOD = 0.f; + desc.MaxLOD = 0.f; + bd->pd3dDevice->CreateSamplerState(&desc, &bd->pFontSampler); + } +} + +bool ImGui_ImplDX10_CreateDeviceObjects() +{ + ImGui_ImplDX10_Data* bd = ImGui_ImplDX10_GetBackendData(); + if (!bd->pd3dDevice) + return false; + if (bd->pFontSampler) + ImGui_ImplDX10_InvalidateDeviceObjects(); + + // By using D3DCompile() from / d3dcompiler.lib, we introduce a dependency to a given version of d3dcompiler_XX.dll (see D3DCOMPILER_DLL_A) + // If you would like to use this DX10 sample code but remove this dependency you can: + // 1) compile once, save the compiled shader blobs into a file or source code and pass them to CreateVertexShader()/CreatePixelShader() [preferred solution] + // 2) use code to detect any version of the DLL and grab a pointer to D3DCompile from the DLL. + // See https://github.com/ocornut/imgui/pull/638 for sources and details. + + // Create the vertex shader + { + static const char* vertexShader = + "cbuffer vertexBuffer : register(b0) \ + {\ + float4x4 ProjectionMatrix; \ + };\ + struct VS_INPUT\ + {\ + float2 pos : POSITION;\ + float4 col : COLOR0;\ + float2 uv : TEXCOORD0;\ + };\ + \ + struct PS_INPUT\ + {\ + float4 pos : SV_POSITION;\ + float4 col : COLOR0;\ + float2 uv : TEXCOORD0;\ + };\ + \ + PS_INPUT main(VS_INPUT input)\ + {\ + PS_INPUT output;\ + output.pos = mul( ProjectionMatrix, float4(input.pos.xy, 0.f, 1.f));\ + output.col = input.col;\ + output.uv = input.uv;\ + return output;\ + }"; + + ID3DBlob* vertexShaderBlob; + if (FAILED(D3DCompile(vertexShader, strlen(vertexShader), NULL, NULL, NULL, "main", "vs_4_0", 0, 0, &vertexShaderBlob, NULL))) + return false; // NB: Pass ID3DBlob* pErrorBlob to D3DCompile() to get error showing in (const char*)pErrorBlob->GetBufferPointer(). Make sure to Release() the blob! + if (bd->pd3dDevice->CreateVertexShader(vertexShaderBlob->GetBufferPointer(), vertexShaderBlob->GetBufferSize(), &bd->pVertexShader) != S_OK) + { + vertexShaderBlob->Release(); + return false; + } + + // Create the input layout + D3D10_INPUT_ELEMENT_DESC local_layout[] = + { + { "POSITION", 0, DXGI_FORMAT_R32G32_FLOAT, 0, (UINT)IM_OFFSETOF(ImDrawVert, pos), D3D10_INPUT_PER_VERTEX_DATA, 0 }, + { "TEXCOORD", 0, DXGI_FORMAT_R32G32_FLOAT, 0, (UINT)IM_OFFSETOF(ImDrawVert, uv), D3D10_INPUT_PER_VERTEX_DATA, 0 }, + { "COLOR", 0, DXGI_FORMAT_R8G8B8A8_UNORM, 0, (UINT)IM_OFFSETOF(ImDrawVert, col), D3D10_INPUT_PER_VERTEX_DATA, 0 }, + }; + if (bd->pd3dDevice->CreateInputLayout(local_layout, 3, vertexShaderBlob->GetBufferPointer(), vertexShaderBlob->GetBufferSize(), &bd->pInputLayout) != S_OK) + { + vertexShaderBlob->Release(); + return false; + } + vertexShaderBlob->Release(); + + // Create the constant buffer + { + D3D10_BUFFER_DESC desc; + desc.ByteWidth = sizeof(VERTEX_CONSTANT_BUFFER); + desc.Usage = D3D10_USAGE_DYNAMIC; + desc.BindFlags = D3D10_BIND_CONSTANT_BUFFER; + desc.CPUAccessFlags = D3D10_CPU_ACCESS_WRITE; + desc.MiscFlags = 0; + bd->pd3dDevice->CreateBuffer(&desc, NULL, &bd->pVertexConstantBuffer); + } + } + + // Create the pixel shader + { + static const char* pixelShader = + "struct PS_INPUT\ + {\ + float4 pos : SV_POSITION;\ + float4 col : COLOR0;\ + float2 uv : TEXCOORD0;\ + };\ + sampler sampler0;\ + Texture2D texture0;\ + \ + float4 main(PS_INPUT input) : SV_Target\ + {\ + float4 out_col = input.col * texture0.Sample(sampler0, input.uv); \ + return out_col; \ + }"; + + ID3DBlob* pixelShaderBlob; + if (FAILED(D3DCompile(pixelShader, strlen(pixelShader), NULL, NULL, NULL, "main", "ps_4_0", 0, 0, &pixelShaderBlob, NULL))) + return false; // NB: Pass ID3DBlob* pErrorBlob to D3DCompile() to get error showing in (const char*)pErrorBlob->GetBufferPointer(). Make sure to Release() the blob! + if (bd->pd3dDevice->CreatePixelShader(pixelShaderBlob->GetBufferPointer(), pixelShaderBlob->GetBufferSize(), &bd->pPixelShader) != S_OK) + { + pixelShaderBlob->Release(); + return false; + } + pixelShaderBlob->Release(); + } + + // Create the blending setup + { + D3D10_BLEND_DESC desc; + ZeroMemory(&desc, sizeof(desc)); + desc.AlphaToCoverageEnable = false; + desc.BlendEnable[0] = true; + desc.SrcBlend = D3D10_BLEND_SRC_ALPHA; + desc.DestBlend = D3D10_BLEND_INV_SRC_ALPHA; + desc.BlendOp = D3D10_BLEND_OP_ADD; + desc.SrcBlendAlpha = D3D10_BLEND_ONE; + desc.DestBlendAlpha = D3D10_BLEND_INV_SRC_ALPHA; + desc.BlendOpAlpha = D3D10_BLEND_OP_ADD; + desc.RenderTargetWriteMask[0] = D3D10_COLOR_WRITE_ENABLE_ALL; + bd->pd3dDevice->CreateBlendState(&desc, &bd->pBlendState); + } + + // Create the rasterizer state + { + D3D10_RASTERIZER_DESC desc; + ZeroMemory(&desc, sizeof(desc)); + desc.FillMode = D3D10_FILL_SOLID; + desc.CullMode = D3D10_CULL_NONE; + desc.ScissorEnable = true; + desc.DepthClipEnable = true; + bd->pd3dDevice->CreateRasterizerState(&desc, &bd->pRasterizerState); + } + + // Create depth-stencil State + { + D3D10_DEPTH_STENCIL_DESC desc; + ZeroMemory(&desc, sizeof(desc)); + desc.DepthEnable = false; + desc.DepthWriteMask = D3D10_DEPTH_WRITE_MASK_ALL; + desc.DepthFunc = D3D10_COMPARISON_ALWAYS; + desc.StencilEnable = false; + desc.FrontFace.StencilFailOp = desc.FrontFace.StencilDepthFailOp = desc.FrontFace.StencilPassOp = D3D10_STENCIL_OP_KEEP; + desc.FrontFace.StencilFunc = D3D10_COMPARISON_ALWAYS; + desc.BackFace = desc.FrontFace; + bd->pd3dDevice->CreateDepthStencilState(&desc, &bd->pDepthStencilState); + } + + ImGui_ImplDX10_CreateFontsTexture(); + + return true; +} + +void ImGui_ImplDX10_InvalidateDeviceObjects() +{ + ImGui_ImplDX10_Data* bd = ImGui_ImplDX10_GetBackendData(); + if (!bd->pd3dDevice) + return; + + if (bd->pFontSampler) { bd->pFontSampler->Release(); bd->pFontSampler = NULL; } + if (bd->pFontTextureView) { bd->pFontTextureView->Release(); bd->pFontTextureView = NULL; ImGui::GetIO().Fonts->SetTexID(NULL); } // We copied bd->pFontTextureView to io.Fonts->TexID so let's clear that as well. + if (bd->pIB) { bd->pIB->Release(); bd->pIB = NULL; } + if (bd->pVB) { bd->pVB->Release(); bd->pVB = NULL; } + if (bd->pBlendState) { bd->pBlendState->Release(); bd->pBlendState = NULL; } + if (bd->pDepthStencilState) { bd->pDepthStencilState->Release(); bd->pDepthStencilState = NULL; } + if (bd->pRasterizerState) { bd->pRasterizerState->Release(); bd->pRasterizerState = NULL; } + if (bd->pPixelShader) { bd->pPixelShader->Release(); bd->pPixelShader = NULL; } + if (bd->pVertexConstantBuffer) { bd->pVertexConstantBuffer->Release(); bd->pVertexConstantBuffer = NULL; } + if (bd->pInputLayout) { bd->pInputLayout->Release(); bd->pInputLayout = NULL; } + if (bd->pVertexShader) { bd->pVertexShader->Release(); bd->pVertexShader = NULL; } +} + +bool ImGui_ImplDX10_Init(ID3D10Device* device) +{ + ImGuiIO& io = ImGui::GetIO(); + IM_ASSERT(io.BackendRendererUserData == NULL && "Already initialized a renderer backend!"); + + // Setup backend capabilities flags + ImGui_ImplDX10_Data* bd = IM_NEW(ImGui_ImplDX10_Data)(); + io.BackendRendererUserData = (void*)bd; + io.BackendRendererName = "imgui_impl_dx10"; + io.BackendFlags |= ImGuiBackendFlags_RendererHasVtxOffset; // We can honor the ImDrawCmd::VtxOffset field, allowing for large meshes. + + // Get factory from device + IDXGIDevice* pDXGIDevice = NULL; + IDXGIAdapter* pDXGIAdapter = NULL; + IDXGIFactory* pFactory = NULL; + if (device->QueryInterface(IID_PPV_ARGS(&pDXGIDevice)) == S_OK) + if (pDXGIDevice->GetParent(IID_PPV_ARGS(&pDXGIAdapter)) == S_OK) + if (pDXGIAdapter->GetParent(IID_PPV_ARGS(&pFactory)) == S_OK) + { + bd->pd3dDevice = device; + bd->pFactory = pFactory; + } + if (pDXGIDevice) pDXGIDevice->Release(); + if (pDXGIAdapter) pDXGIAdapter->Release(); + bd->pd3dDevice->AddRef(); + + return true; +} + +void ImGui_ImplDX10_Shutdown() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplDX10_Data* bd = ImGui_ImplDX10_GetBackendData(); + + ImGui_ImplDX10_InvalidateDeviceObjects(); + if (bd->pFactory) { bd->pFactory->Release(); } + if (bd->pd3dDevice) { bd->pd3dDevice->Release(); } + io.BackendRendererName = NULL; + io.BackendRendererUserData = NULL; + IM_DELETE(bd); +} + +void ImGui_ImplDX10_NewFrame() +{ + ImGui_ImplDX10_Data* bd = ImGui_ImplDX10_GetBackendData(); + IM_ASSERT(bd != NULL && "Did you call ImGui_ImplDX10_Init()?"); + + if (!bd->pFontSampler) + ImGui_ImplDX10_CreateDeviceObjects(); +} diff --git a/source/editor/imgui/backends/imgui_impl_dx10.h b/source/editor/imgui/backends/imgui_impl_dx10.h new file mode 100644 index 0000000..31e62ac --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_dx10.h @@ -0,0 +1,25 @@ +// dear imgui: Renderer Backend for DirectX10 +// This needs to be used along with a Platform Backend (e.g. Win32) + +// Implemented features: +// [X] Renderer: User texture backend. Use 'ID3D10ShaderResourceView*' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +struct ID3D10Device; + +IMGUI_IMPL_API bool ImGui_ImplDX10_Init(ID3D10Device* device); +IMGUI_IMPL_API void ImGui_ImplDX10_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplDX10_NewFrame(); +IMGUI_IMPL_API void ImGui_ImplDX10_RenderDrawData(ImDrawData* draw_data); + +// Use if you want to reset your rendering device without losing Dear ImGui state. +IMGUI_IMPL_API void ImGui_ImplDX10_InvalidateDeviceObjects(); +IMGUI_IMPL_API bool ImGui_ImplDX10_CreateDeviceObjects(); diff --git a/source/editor/imgui/backends/imgui_impl_dx11.cpp b/source/editor/imgui/backends/imgui_impl_dx11.cpp new file mode 100644 index 0000000..a56b757 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_dx11.cpp @@ -0,0 +1,593 @@ +// dear imgui: Renderer Backend for DirectX11 +// This needs to be used along with a Platform Backend (e.g. Win32) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'ID3D11ShaderResourceView*' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-06-29: Reorganized backend to pull data from a single structure to facilitate usage with multiple-contexts (all g_XXXX access changed to bd->XXXX). +// 2021-05-19: DirectX11: Replaced direct access to ImDrawCmd::TextureId with a call to ImDrawCmd::GetTexID(). (will become a requirement) +// 2021-02-18: DirectX11: Change blending equation to preserve alpha in output buffer. +// 2019-08-01: DirectX11: Fixed code querying the Geometry Shader state (would generally error with Debug layer enabled). +// 2019-07-21: DirectX11: Backup, clear and restore Geometry Shader is any is bound when calling ImGui_ImplDX10_RenderDrawData. Clearing Hull/Domain/Compute shaders without backup/restore. +// 2019-05-29: DirectX11: Added support for large mesh (64K+ vertices), enable ImGuiBackendFlags_RendererHasVtxOffset flag. +// 2019-04-30: DirectX11: Added support for special ImDrawCallback_ResetRenderState callback to reset render state. +// 2018-12-03: Misc: Added #pragma comment statement to automatically link with d3dcompiler.lib when using D3DCompile(). +// 2018-11-30: Misc: Setting up io.BackendRendererName so it can be displayed in the About Window. +// 2018-08-01: DirectX11: Querying for IDXGIFactory instead of IDXGIFactory1 to increase compatibility. +// 2018-07-13: DirectX11: Fixed unreleased resources in Init and Shutdown functions. +// 2018-06-08: Misc: Extracted imgui_impl_dx11.cpp/.h away from the old combined DX11+Win32 example. +// 2018-06-08: DirectX11: Use draw_data->DisplayPos and draw_data->DisplaySize to setup projection matrix and clipping rectangle. +// 2018-02-16: Misc: Obsoleted the io.RenderDrawListsFn callback and exposed ImGui_ImplDX11_RenderDrawData() in the .h file so you can call it yourself. +// 2018-02-06: Misc: Removed call to ImGui::Shutdown() which is not available from 1.60 WIP, user needs to call CreateContext/DestroyContext themselves. +// 2016-05-07: DirectX11: Disabling depth-write. + +#include "imgui.h" +#include "imgui_impl_dx11.h" + +// DirectX +#include +#include +#include +#ifdef _MSC_VER +#pragma comment(lib, "d3dcompiler") // Automatically link with d3dcompiler.lib as we are using D3DCompile() below. +#endif + +// DirectX11 data +struct ImGui_ImplDX11_Data +{ + ID3D11Device* pd3dDevice; + ID3D11DeviceContext* pd3dDeviceContext; + IDXGIFactory* pFactory; + ID3D11Buffer* pVB; + ID3D11Buffer* pIB; + ID3D11VertexShader* pVertexShader; + ID3D11InputLayout* pInputLayout; + ID3D11Buffer* pVertexConstantBuffer; + ID3D11PixelShader* pPixelShader; + ID3D11SamplerState* pFontSampler; + ID3D11ShaderResourceView* pFontTextureView; + ID3D11RasterizerState* pRasterizerState; + ID3D11BlendState* pBlendState; + ID3D11DepthStencilState* pDepthStencilState; + int VertexBufferSize; + int IndexBufferSize; + + ImGui_ImplDX11_Data() { memset(this, 0, sizeof(*this)); VertexBufferSize = 5000; IndexBufferSize = 10000; } +}; + +struct VERTEX_CONSTANT_BUFFER +{ + float mvp[4][4]; +}; + +// Backend data stored in io.BackendRendererUserData to allow support for multiple Dear ImGui contexts +// It is STRONGLY preferred that you use docking branch with multi-viewports (== single Dear ImGui context + multiple windows) instead of multiple Dear ImGui contexts. +static ImGui_ImplDX11_Data* ImGui_ImplDX11_GetBackendData() +{ + return ImGui::GetCurrentContext() ? (ImGui_ImplDX11_Data*)ImGui::GetIO().BackendRendererUserData : NULL; +} + +// Functions +static void ImGui_ImplDX11_SetupRenderState(ImDrawData* draw_data, ID3D11DeviceContext* ctx) +{ + ImGui_ImplDX11_Data* bd = ImGui_ImplDX11_GetBackendData(); + + // Setup viewport + D3D11_VIEWPORT vp; + memset(&vp, 0, sizeof(D3D11_VIEWPORT)); + vp.Width = draw_data->DisplaySize.x; + vp.Height = draw_data->DisplaySize.y; + vp.MinDepth = 0.0f; + vp.MaxDepth = 1.0f; + vp.TopLeftX = vp.TopLeftY = 0; + ctx->RSSetViewports(1, &vp); + + // Setup shader and vertex buffers + unsigned int stride = sizeof(ImDrawVert); + unsigned int offset = 0; + ctx->IASetInputLayout(bd->pInputLayout); + ctx->IASetVertexBuffers(0, 1, &bd->pVB, &stride, &offset); + ctx->IASetIndexBuffer(bd->pIB, sizeof(ImDrawIdx) == 2 ? DXGI_FORMAT_R16_UINT : DXGI_FORMAT_R32_UINT, 0); + ctx->IASetPrimitiveTopology(D3D11_PRIMITIVE_TOPOLOGY_TRIANGLELIST); + ctx->VSSetShader(bd->pVertexShader, NULL, 0); + ctx->VSSetConstantBuffers(0, 1, &bd->pVertexConstantBuffer); + ctx->PSSetShader(bd->pPixelShader, NULL, 0); + ctx->PSSetSamplers(0, 1, &bd->pFontSampler); + ctx->GSSetShader(NULL, NULL, 0); + ctx->HSSetShader(NULL, NULL, 0); // In theory we should backup and restore this as well.. very infrequently used.. + ctx->DSSetShader(NULL, NULL, 0); // In theory we should backup and restore this as well.. very infrequently used.. + ctx->CSSetShader(NULL, NULL, 0); // In theory we should backup and restore this as well.. very infrequently used.. + + // Setup blend state + const float blend_factor[4] = { 0.f, 0.f, 0.f, 0.f }; + ctx->OMSetBlendState(bd->pBlendState, blend_factor, 0xffffffff); + ctx->OMSetDepthStencilState(bd->pDepthStencilState, 0); + ctx->RSSetState(bd->pRasterizerState); +} + +// Render function +void ImGui_ImplDX11_RenderDrawData(ImDrawData* draw_data) +{ + // Avoid rendering when minimized + if (draw_data->DisplaySize.x <= 0.0f || draw_data->DisplaySize.y <= 0.0f) + return; + + ImGui_ImplDX11_Data* bd = ImGui_ImplDX11_GetBackendData(); + ID3D11DeviceContext* ctx = bd->pd3dDeviceContext; + + // Create and grow vertex/index buffers if needed + if (!bd->pVB || bd->VertexBufferSize < draw_data->TotalVtxCount) + { + if (bd->pVB) { bd->pVB->Release(); bd->pVB = NULL; } + bd->VertexBufferSize = draw_data->TotalVtxCount + 5000; + D3D11_BUFFER_DESC desc; + memset(&desc, 0, sizeof(D3D11_BUFFER_DESC)); + desc.Usage = D3D11_USAGE_DYNAMIC; + desc.ByteWidth = bd->VertexBufferSize * sizeof(ImDrawVert); + desc.BindFlags = D3D11_BIND_VERTEX_BUFFER; + desc.CPUAccessFlags = D3D11_CPU_ACCESS_WRITE; + desc.MiscFlags = 0; + if (bd->pd3dDevice->CreateBuffer(&desc, NULL, &bd->pVB) < 0) + return; + } + if (!bd->pIB || bd->IndexBufferSize < draw_data->TotalIdxCount) + { + if (bd->pIB) { bd->pIB->Release(); bd->pIB = NULL; } + bd->IndexBufferSize = draw_data->TotalIdxCount + 10000; + D3D11_BUFFER_DESC desc; + memset(&desc, 0, sizeof(D3D11_BUFFER_DESC)); + desc.Usage = D3D11_USAGE_DYNAMIC; + desc.ByteWidth = bd->IndexBufferSize * sizeof(ImDrawIdx); + desc.BindFlags = D3D11_BIND_INDEX_BUFFER; + desc.CPUAccessFlags = D3D11_CPU_ACCESS_WRITE; + if (bd->pd3dDevice->CreateBuffer(&desc, NULL, &bd->pIB) < 0) + return; + } + + // Upload vertex/index data into a single contiguous GPU buffer + D3D11_MAPPED_SUBRESOURCE vtx_resource, idx_resource; + if (ctx->Map(bd->pVB, 0, D3D11_MAP_WRITE_DISCARD, 0, &vtx_resource) != S_OK) + return; + if (ctx->Map(bd->pIB, 0, D3D11_MAP_WRITE_DISCARD, 0, &idx_resource) != S_OK) + return; + ImDrawVert* vtx_dst = (ImDrawVert*)vtx_resource.pData; + ImDrawIdx* idx_dst = (ImDrawIdx*)idx_resource.pData; + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + memcpy(vtx_dst, cmd_list->VtxBuffer.Data, cmd_list->VtxBuffer.Size * sizeof(ImDrawVert)); + memcpy(idx_dst, cmd_list->IdxBuffer.Data, cmd_list->IdxBuffer.Size * sizeof(ImDrawIdx)); + vtx_dst += cmd_list->VtxBuffer.Size; + idx_dst += cmd_list->IdxBuffer.Size; + } + ctx->Unmap(bd->pVB, 0); + ctx->Unmap(bd->pIB, 0); + + // Setup orthographic projection matrix into our constant buffer + // Our visible imgui space lies from draw_data->DisplayPos (top left) to draw_data->DisplayPos+data_data->DisplaySize (bottom right). DisplayPos is (0,0) for single viewport apps. + { + D3D11_MAPPED_SUBRESOURCE mapped_resource; + if (ctx->Map(bd->pVertexConstantBuffer, 0, D3D11_MAP_WRITE_DISCARD, 0, &mapped_resource) != S_OK) + return; + VERTEX_CONSTANT_BUFFER* constant_buffer = (VERTEX_CONSTANT_BUFFER*)mapped_resource.pData; + float L = draw_data->DisplayPos.x; + float R = draw_data->DisplayPos.x + draw_data->DisplaySize.x; + float T = draw_data->DisplayPos.y; + float B = draw_data->DisplayPos.y + draw_data->DisplaySize.y; + float mvp[4][4] = + { + { 2.0f/(R-L), 0.0f, 0.0f, 0.0f }, + { 0.0f, 2.0f/(T-B), 0.0f, 0.0f }, + { 0.0f, 0.0f, 0.5f, 0.0f }, + { (R+L)/(L-R), (T+B)/(B-T), 0.5f, 1.0f }, + }; + memcpy(&constant_buffer->mvp, mvp, sizeof(mvp)); + ctx->Unmap(bd->pVertexConstantBuffer, 0); + } + + // Backup DX state that will be modified to restore it afterwards (unfortunately this is very ugly looking and verbose. Close your eyes!) + struct BACKUP_DX11_STATE + { + UINT ScissorRectsCount, ViewportsCount; + D3D11_RECT ScissorRects[D3D11_VIEWPORT_AND_SCISSORRECT_OBJECT_COUNT_PER_PIPELINE]; + D3D11_VIEWPORT Viewports[D3D11_VIEWPORT_AND_SCISSORRECT_OBJECT_COUNT_PER_PIPELINE]; + ID3D11RasterizerState* RS; + ID3D11BlendState* BlendState; + FLOAT BlendFactor[4]; + UINT SampleMask; + UINT StencilRef; + ID3D11DepthStencilState* DepthStencilState; + ID3D11ShaderResourceView* PSShaderResource; + ID3D11SamplerState* PSSampler; + ID3D11PixelShader* PS; + ID3D11VertexShader* VS; + ID3D11GeometryShader* GS; + UINT PSInstancesCount, VSInstancesCount, GSInstancesCount; + ID3D11ClassInstance *PSInstances[256], *VSInstances[256], *GSInstances[256]; // 256 is max according to PSSetShader documentation + D3D11_PRIMITIVE_TOPOLOGY PrimitiveTopology; + ID3D11Buffer* IndexBuffer, *VertexBuffer, *VSConstantBuffer; + UINT IndexBufferOffset, VertexBufferStride, VertexBufferOffset; + DXGI_FORMAT IndexBufferFormat; + ID3D11InputLayout* InputLayout; + }; + BACKUP_DX11_STATE old = {}; + old.ScissorRectsCount = old.ViewportsCount = D3D11_VIEWPORT_AND_SCISSORRECT_OBJECT_COUNT_PER_PIPELINE; + ctx->RSGetScissorRects(&old.ScissorRectsCount, old.ScissorRects); + ctx->RSGetViewports(&old.ViewportsCount, old.Viewports); + ctx->RSGetState(&old.RS); + ctx->OMGetBlendState(&old.BlendState, old.BlendFactor, &old.SampleMask); + ctx->OMGetDepthStencilState(&old.DepthStencilState, &old.StencilRef); + ctx->PSGetShaderResources(0, 1, &old.PSShaderResource); + ctx->PSGetSamplers(0, 1, &old.PSSampler); + old.PSInstancesCount = old.VSInstancesCount = old.GSInstancesCount = 256; + ctx->PSGetShader(&old.PS, old.PSInstances, &old.PSInstancesCount); + ctx->VSGetShader(&old.VS, old.VSInstances, &old.VSInstancesCount); + ctx->VSGetConstantBuffers(0, 1, &old.VSConstantBuffer); + ctx->GSGetShader(&old.GS, old.GSInstances, &old.GSInstancesCount); + + ctx->IAGetPrimitiveTopology(&old.PrimitiveTopology); + ctx->IAGetIndexBuffer(&old.IndexBuffer, &old.IndexBufferFormat, &old.IndexBufferOffset); + ctx->IAGetVertexBuffers(0, 1, &old.VertexBuffer, &old.VertexBufferStride, &old.VertexBufferOffset); + ctx->IAGetInputLayout(&old.InputLayout); + + // Setup desired DX state + ImGui_ImplDX11_SetupRenderState(draw_data, ctx); + + // Render command lists + // (Because we merged all buffers into a single one, we maintain our own offset into them) + int global_idx_offset = 0; + int global_vtx_offset = 0; + ImVec2 clip_off = draw_data->DisplayPos; + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + const ImDrawCmd* pcmd = &cmd_list->CmdBuffer[cmd_i]; + if (pcmd->UserCallback != NULL) + { + // User callback, registered via ImDrawList::AddCallback() + // (ImDrawCallback_ResetRenderState is a special callback value used by the user to request the renderer to reset render state.) + if (pcmd->UserCallback == ImDrawCallback_ResetRenderState) + ImGui_ImplDX11_SetupRenderState(draw_data, ctx); + else + pcmd->UserCallback(cmd_list, pcmd); + } + else + { + // Project scissor/clipping rectangles into framebuffer space + ImVec2 clip_min(pcmd->ClipRect.x - clip_off.x, pcmd->ClipRect.y - clip_off.y); + ImVec2 clip_max(pcmd->ClipRect.z - clip_off.x, pcmd->ClipRect.w - clip_off.y); + if (clip_max.x < clip_min.x || clip_max.y < clip_min.y) + continue; + + // Apply scissor/clipping rectangle + const D3D11_RECT r = { (LONG)clip_min.x, (LONG)clip_min.y, (LONG)clip_max.x, (LONG)clip_max.y }; + ctx->RSSetScissorRects(1, &r); + + // Bind texture, Draw + ID3D11ShaderResourceView* texture_srv = (ID3D11ShaderResourceView*)pcmd->GetTexID(); + ctx->PSSetShaderResources(0, 1, &texture_srv); + ctx->DrawIndexed(pcmd->ElemCount, pcmd->IdxOffset + global_idx_offset, pcmd->VtxOffset + global_vtx_offset); + } + } + global_idx_offset += cmd_list->IdxBuffer.Size; + global_vtx_offset += cmd_list->VtxBuffer.Size; + } + + // Restore modified DX state + ctx->RSSetScissorRects(old.ScissorRectsCount, old.ScissorRects); + ctx->RSSetViewports(old.ViewportsCount, old.Viewports); + ctx->RSSetState(old.RS); if (old.RS) old.RS->Release(); + ctx->OMSetBlendState(old.BlendState, old.BlendFactor, old.SampleMask); if (old.BlendState) old.BlendState->Release(); + ctx->OMSetDepthStencilState(old.DepthStencilState, old.StencilRef); if (old.DepthStencilState) old.DepthStencilState->Release(); + ctx->PSSetShaderResources(0, 1, &old.PSShaderResource); if (old.PSShaderResource) old.PSShaderResource->Release(); + ctx->PSSetSamplers(0, 1, &old.PSSampler); if (old.PSSampler) old.PSSampler->Release(); + ctx->PSSetShader(old.PS, old.PSInstances, old.PSInstancesCount); if (old.PS) old.PS->Release(); + for (UINT i = 0; i < old.PSInstancesCount; i++) if (old.PSInstances[i]) old.PSInstances[i]->Release(); + ctx->VSSetShader(old.VS, old.VSInstances, old.VSInstancesCount); if (old.VS) old.VS->Release(); + ctx->VSSetConstantBuffers(0, 1, &old.VSConstantBuffer); if (old.VSConstantBuffer) old.VSConstantBuffer->Release(); + ctx->GSSetShader(old.GS, old.GSInstances, old.GSInstancesCount); if (old.GS) old.GS->Release(); + for (UINT i = 0; i < old.VSInstancesCount; i++) if (old.VSInstances[i]) old.VSInstances[i]->Release(); + ctx->IASetPrimitiveTopology(old.PrimitiveTopology); + ctx->IASetIndexBuffer(old.IndexBuffer, old.IndexBufferFormat, old.IndexBufferOffset); if (old.IndexBuffer) old.IndexBuffer->Release(); + ctx->IASetVertexBuffers(0, 1, &old.VertexBuffer, &old.VertexBufferStride, &old.VertexBufferOffset); if (old.VertexBuffer) old.VertexBuffer->Release(); + ctx->IASetInputLayout(old.InputLayout); if (old.InputLayout) old.InputLayout->Release(); +} + +static void ImGui_ImplDX11_CreateFontsTexture() +{ + // Build texture atlas + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplDX11_Data* bd = ImGui_ImplDX11_GetBackendData(); + unsigned char* pixels; + int width, height; + io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height); + + // Upload texture to graphics system + { + D3D11_TEXTURE2D_DESC desc; + ZeroMemory(&desc, sizeof(desc)); + desc.Width = width; + desc.Height = height; + desc.MipLevels = 1; + desc.ArraySize = 1; + desc.Format = DXGI_FORMAT_R8G8B8A8_UNORM; + desc.SampleDesc.Count = 1; + desc.Usage = D3D11_USAGE_DEFAULT; + desc.BindFlags = D3D11_BIND_SHADER_RESOURCE; + desc.CPUAccessFlags = 0; + + ID3D11Texture2D* pTexture = NULL; + D3D11_SUBRESOURCE_DATA subResource; + subResource.pSysMem = pixels; + subResource.SysMemPitch = desc.Width * 4; + subResource.SysMemSlicePitch = 0; + bd->pd3dDevice->CreateTexture2D(&desc, &subResource, &pTexture); + IM_ASSERT(pTexture != NULL); + + // Create texture view + D3D11_SHADER_RESOURCE_VIEW_DESC srvDesc; + ZeroMemory(&srvDesc, sizeof(srvDesc)); + srvDesc.Format = DXGI_FORMAT_R8G8B8A8_UNORM; + srvDesc.ViewDimension = D3D11_SRV_DIMENSION_TEXTURE2D; + srvDesc.Texture2D.MipLevels = desc.MipLevels; + srvDesc.Texture2D.MostDetailedMip = 0; + bd->pd3dDevice->CreateShaderResourceView(pTexture, &srvDesc, &bd->pFontTextureView); + pTexture->Release(); + } + + // Store our identifier + io.Fonts->SetTexID((ImTextureID)bd->pFontTextureView); + + // Create texture sampler + { + D3D11_SAMPLER_DESC desc; + ZeroMemory(&desc, sizeof(desc)); + desc.Filter = D3D11_FILTER_MIN_MAG_MIP_LINEAR; + desc.AddressU = D3D11_TEXTURE_ADDRESS_WRAP; + desc.AddressV = D3D11_TEXTURE_ADDRESS_WRAP; + desc.AddressW = D3D11_TEXTURE_ADDRESS_WRAP; + desc.MipLODBias = 0.f; + desc.ComparisonFunc = D3D11_COMPARISON_ALWAYS; + desc.MinLOD = 0.f; + desc.MaxLOD = 0.f; + bd->pd3dDevice->CreateSamplerState(&desc, &bd->pFontSampler); + } +} + +bool ImGui_ImplDX11_CreateDeviceObjects() +{ + ImGui_ImplDX11_Data* bd = ImGui_ImplDX11_GetBackendData(); + if (!bd->pd3dDevice) + return false; + if (bd->pFontSampler) + ImGui_ImplDX11_InvalidateDeviceObjects(); + + // By using D3DCompile() from / d3dcompiler.lib, we introduce a dependency to a given version of d3dcompiler_XX.dll (see D3DCOMPILER_DLL_A) + // If you would like to use this DX11 sample code but remove this dependency you can: + // 1) compile once, save the compiled shader blobs into a file or source code and pass them to CreateVertexShader()/CreatePixelShader() [preferred solution] + // 2) use code to detect any version of the DLL and grab a pointer to D3DCompile from the DLL. + // See https://github.com/ocornut/imgui/pull/638 for sources and details. + + // Create the vertex shader + { + static const char* vertexShader = + "cbuffer vertexBuffer : register(b0) \ + {\ + float4x4 ProjectionMatrix; \ + };\ + struct VS_INPUT\ + {\ + float2 pos : POSITION;\ + float4 col : COLOR0;\ + float2 uv : TEXCOORD0;\ + };\ + \ + struct PS_INPUT\ + {\ + float4 pos : SV_POSITION;\ + float4 col : COLOR0;\ + float2 uv : TEXCOORD0;\ + };\ + \ + PS_INPUT main(VS_INPUT input)\ + {\ + PS_INPUT output;\ + output.pos = mul( ProjectionMatrix, float4(input.pos.xy, 0.f, 1.f));\ + output.col = input.col;\ + output.uv = input.uv;\ + return output;\ + }"; + + ID3DBlob* vertexShaderBlob; + if (FAILED(D3DCompile(vertexShader, strlen(vertexShader), NULL, NULL, NULL, "main", "vs_4_0", 0, 0, &vertexShaderBlob, NULL))) + return false; // NB: Pass ID3DBlob* pErrorBlob to D3DCompile() to get error showing in (const char*)pErrorBlob->GetBufferPointer(). Make sure to Release() the blob! + if (bd->pd3dDevice->CreateVertexShader(vertexShaderBlob->GetBufferPointer(), vertexShaderBlob->GetBufferSize(), NULL, &bd->pVertexShader) != S_OK) + { + vertexShaderBlob->Release(); + return false; + } + + // Create the input layout + D3D11_INPUT_ELEMENT_DESC local_layout[] = + { + { "POSITION", 0, DXGI_FORMAT_R32G32_FLOAT, 0, (UINT)IM_OFFSETOF(ImDrawVert, pos), D3D11_INPUT_PER_VERTEX_DATA, 0 }, + { "TEXCOORD", 0, DXGI_FORMAT_R32G32_FLOAT, 0, (UINT)IM_OFFSETOF(ImDrawVert, uv), D3D11_INPUT_PER_VERTEX_DATA, 0 }, + { "COLOR", 0, DXGI_FORMAT_R8G8B8A8_UNORM, 0, (UINT)IM_OFFSETOF(ImDrawVert, col), D3D11_INPUT_PER_VERTEX_DATA, 0 }, + }; + if (bd->pd3dDevice->CreateInputLayout(local_layout, 3, vertexShaderBlob->GetBufferPointer(), vertexShaderBlob->GetBufferSize(), &bd->pInputLayout) != S_OK) + { + vertexShaderBlob->Release(); + return false; + } + vertexShaderBlob->Release(); + + // Create the constant buffer + { + D3D11_BUFFER_DESC desc; + desc.ByteWidth = sizeof(VERTEX_CONSTANT_BUFFER); + desc.Usage = D3D11_USAGE_DYNAMIC; + desc.BindFlags = D3D11_BIND_CONSTANT_BUFFER; + desc.CPUAccessFlags = D3D11_CPU_ACCESS_WRITE; + desc.MiscFlags = 0; + bd->pd3dDevice->CreateBuffer(&desc, NULL, &bd->pVertexConstantBuffer); + } + } + + // Create the pixel shader + { + static const char* pixelShader = + "struct PS_INPUT\ + {\ + float4 pos : SV_POSITION;\ + float4 col : COLOR0;\ + float2 uv : TEXCOORD0;\ + };\ + sampler sampler0;\ + Texture2D texture0;\ + \ + float4 main(PS_INPUT input) : SV_Target\ + {\ + float4 out_col = input.col * texture0.Sample(sampler0, input.uv); \ + return out_col; \ + }"; + + ID3DBlob* pixelShaderBlob; + if (FAILED(D3DCompile(pixelShader, strlen(pixelShader), NULL, NULL, NULL, "main", "ps_4_0", 0, 0, &pixelShaderBlob, NULL))) + return false; // NB: Pass ID3DBlob* pErrorBlob to D3DCompile() to get error showing in (const char*)pErrorBlob->GetBufferPointer(). Make sure to Release() the blob! + if (bd->pd3dDevice->CreatePixelShader(pixelShaderBlob->GetBufferPointer(), pixelShaderBlob->GetBufferSize(), NULL, &bd->pPixelShader) != S_OK) + { + pixelShaderBlob->Release(); + return false; + } + pixelShaderBlob->Release(); + } + + // Create the blending setup + { + D3D11_BLEND_DESC desc; + ZeroMemory(&desc, sizeof(desc)); + desc.AlphaToCoverageEnable = false; + desc.RenderTarget[0].BlendEnable = true; + desc.RenderTarget[0].SrcBlend = D3D11_BLEND_SRC_ALPHA; + desc.RenderTarget[0].DestBlend = D3D11_BLEND_INV_SRC_ALPHA; + desc.RenderTarget[0].BlendOp = D3D11_BLEND_OP_ADD; + desc.RenderTarget[0].SrcBlendAlpha = D3D11_BLEND_ONE; + desc.RenderTarget[0].DestBlendAlpha = D3D11_BLEND_INV_SRC_ALPHA; + desc.RenderTarget[0].BlendOpAlpha = D3D11_BLEND_OP_ADD; + desc.RenderTarget[0].RenderTargetWriteMask = D3D11_COLOR_WRITE_ENABLE_ALL; + bd->pd3dDevice->CreateBlendState(&desc, &bd->pBlendState); + } + + // Create the rasterizer state + { + D3D11_RASTERIZER_DESC desc; + ZeroMemory(&desc, sizeof(desc)); + desc.FillMode = D3D11_FILL_SOLID; + desc.CullMode = D3D11_CULL_NONE; + desc.ScissorEnable = true; + desc.DepthClipEnable = true; + bd->pd3dDevice->CreateRasterizerState(&desc, &bd->pRasterizerState); + } + + // Create depth-stencil State + { + D3D11_DEPTH_STENCIL_DESC desc; + ZeroMemory(&desc, sizeof(desc)); + desc.DepthEnable = false; + desc.DepthWriteMask = D3D11_DEPTH_WRITE_MASK_ALL; + desc.DepthFunc = D3D11_COMPARISON_ALWAYS; + desc.StencilEnable = false; + desc.FrontFace.StencilFailOp = desc.FrontFace.StencilDepthFailOp = desc.FrontFace.StencilPassOp = D3D11_STENCIL_OP_KEEP; + desc.FrontFace.StencilFunc = D3D11_COMPARISON_ALWAYS; + desc.BackFace = desc.FrontFace; + bd->pd3dDevice->CreateDepthStencilState(&desc, &bd->pDepthStencilState); + } + + ImGui_ImplDX11_CreateFontsTexture(); + + return true; +} + +void ImGui_ImplDX11_InvalidateDeviceObjects() +{ + ImGui_ImplDX11_Data* bd = ImGui_ImplDX11_GetBackendData(); + if (!bd->pd3dDevice) + return; + + if (bd->pFontSampler) { bd->pFontSampler->Release(); bd->pFontSampler = NULL; } + if (bd->pFontTextureView) { bd->pFontTextureView->Release(); bd->pFontTextureView = NULL; ImGui::GetIO().Fonts->SetTexID(NULL); } // We copied data->pFontTextureView to io.Fonts->TexID so let's clear that as well. + if (bd->pIB) { bd->pIB->Release(); bd->pIB = NULL; } + if (bd->pVB) { bd->pVB->Release(); bd->pVB = NULL; } + if (bd->pBlendState) { bd->pBlendState->Release(); bd->pBlendState = NULL; } + if (bd->pDepthStencilState) { bd->pDepthStencilState->Release(); bd->pDepthStencilState = NULL; } + if (bd->pRasterizerState) { bd->pRasterizerState->Release(); bd->pRasterizerState = NULL; } + if (bd->pPixelShader) { bd->pPixelShader->Release(); bd->pPixelShader = NULL; } + if (bd->pVertexConstantBuffer) { bd->pVertexConstantBuffer->Release(); bd->pVertexConstantBuffer = NULL; } + if (bd->pInputLayout) { bd->pInputLayout->Release(); bd->pInputLayout = NULL; } + if (bd->pVertexShader) { bd->pVertexShader->Release(); bd->pVertexShader = NULL; } +} + +bool ImGui_ImplDX11_Init(ID3D11Device* device, ID3D11DeviceContext* device_context) +{ + ImGuiIO& io = ImGui::GetIO(); + IM_ASSERT(io.BackendRendererUserData == NULL && "Already initialized a renderer backend!"); + + // Setup backend capabilities flags + ImGui_ImplDX11_Data* bd = IM_NEW(ImGui_ImplDX11_Data)(); + io.BackendRendererUserData = (void*)bd; + io.BackendRendererName = "imgui_impl_dx11"; + io.BackendFlags |= ImGuiBackendFlags_RendererHasVtxOffset; // We can honor the ImDrawCmd::VtxOffset field, allowing for large meshes. + + // Get factory from device + IDXGIDevice* pDXGIDevice = NULL; + IDXGIAdapter* pDXGIAdapter = NULL; + IDXGIFactory* pFactory = NULL; + + if (device->QueryInterface(IID_PPV_ARGS(&pDXGIDevice)) == S_OK) + if (pDXGIDevice->GetParent(IID_PPV_ARGS(&pDXGIAdapter)) == S_OK) + if (pDXGIAdapter->GetParent(IID_PPV_ARGS(&pFactory)) == S_OK) + { + bd->pd3dDevice = device; + bd->pd3dDeviceContext = device_context; + bd->pFactory = pFactory; + } + if (pDXGIDevice) pDXGIDevice->Release(); + if (pDXGIAdapter) pDXGIAdapter->Release(); + bd->pd3dDevice->AddRef(); + bd->pd3dDeviceContext->AddRef(); + + return true; +} + +void ImGui_ImplDX11_Shutdown() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplDX11_Data* bd = ImGui_ImplDX11_GetBackendData(); + + ImGui_ImplDX11_InvalidateDeviceObjects(); + if (bd->pFactory) { bd->pFactory->Release(); } + if (bd->pd3dDevice) { bd->pd3dDevice->Release(); } + if (bd->pd3dDeviceContext) { bd->pd3dDeviceContext->Release(); } + io.BackendRendererName = NULL; + io.BackendRendererUserData = NULL; + IM_DELETE(bd); +} + +void ImGui_ImplDX11_NewFrame() +{ + ImGui_ImplDX11_Data* bd = ImGui_ImplDX11_GetBackendData(); + IM_ASSERT(bd != NULL && "Did you call ImGui_ImplDX11_Init()?"); + + if (!bd->pFontSampler) + ImGui_ImplDX11_CreateDeviceObjects(); +} diff --git a/source/editor/imgui/backends/imgui_impl_dx11.h b/source/editor/imgui/backends/imgui_impl_dx11.h new file mode 100644 index 0000000..a83bce1 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_dx11.h @@ -0,0 +1,26 @@ +// dear imgui: Renderer Backend for DirectX11 +// This needs to be used along with a Platform Backend (e.g. Win32) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'ID3D11ShaderResourceView*' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +struct ID3D11Device; +struct ID3D11DeviceContext; + +IMGUI_IMPL_API bool ImGui_ImplDX11_Init(ID3D11Device* device, ID3D11DeviceContext* device_context); +IMGUI_IMPL_API void ImGui_ImplDX11_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplDX11_NewFrame(); +IMGUI_IMPL_API void ImGui_ImplDX11_RenderDrawData(ImDrawData* draw_data); + +// Use if you want to reset your rendering device without losing Dear ImGui state. +IMGUI_IMPL_API void ImGui_ImplDX11_InvalidateDeviceObjects(); +IMGUI_IMPL_API bool ImGui_ImplDX11_CreateDeviceObjects(); diff --git a/source/editor/imgui/backends/imgui_impl_dx12.cpp b/source/editor/imgui/backends/imgui_impl_dx12.cpp new file mode 100644 index 0000000..98e5623 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_dx12.cpp @@ -0,0 +1,745 @@ +// dear imgui: Renderer Backend for DirectX12 +// This needs to be used along with a Platform Backend (e.g. Win32) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'D3D12_GPU_DESCRIPTOR_HANDLE' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. + +// Important: to compile on 32-bit systems, this backend requires code to be compiled with '#define ImTextureID ImU64'. +// This is because we need ImTextureID to carry a 64-bit value and by default ImTextureID is defined as void*. +// To build this on 32-bit systems: +// - [Solution 1] IDE/msbuild: in "Properties/C++/Preprocessor Definitions" add 'ImTextureID=ImU64' (this is what we do in the 'example_win32_direct12/example_win32_direct12.vcxproj' project file) +// - [Solution 2] IDE/msbuild: in "Properties/C++/Preprocessor Definitions" add 'IMGUI_USER_CONFIG="my_imgui_config.h"' and inside 'my_imgui_config.h' add '#define ImTextureID ImU64' and as many other options as you like. +// - [Solution 3] IDE/msbuild: edit imconfig.h and add '#define ImTextureID ImU64' (prefer solution 2 to create your own config file!) +// - [Solution 4] command-line: add '/D ImTextureID=ImU64' to your cl.exe command-line (this is what we do in the example_win32_direct12/build_win32.bat file) + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-06-29: Reorganized backend to pull data from a single structure to facilitate usage with multiple-contexts (all g_XXXX access changed to bd->XXXX). +// 2021-05-19: DirectX12: Replaced direct access to ImDrawCmd::TextureId with a call to ImDrawCmd::GetTexID(). (will become a requirement) +// 2021-02-18: DirectX12: Change blending equation to preserve alpha in output buffer. +// 2021-01-11: DirectX12: Improve Windows 7 compatibility (for D3D12On7) by loading d3d12.dll dynamically. +// 2020-09-16: DirectX12: Avoid rendering calls with zero-sized scissor rectangle since it generates a validation layer warning. +// 2020-09-08: DirectX12: Clarified support for building on 32-bit systems by redefining ImTextureID. +// 2019-10-18: DirectX12: *BREAKING CHANGE* Added extra ID3D12DescriptorHeap parameter to ImGui_ImplDX12_Init() function. +// 2019-05-29: DirectX12: Added support for large mesh (64K+ vertices), enable ImGuiBackendFlags_RendererHasVtxOffset flag. +// 2019-04-30: DirectX12: Added support for special ImDrawCallback_ResetRenderState callback to reset render state. +// 2019-03-29: Misc: Various minor tidying up. +// 2018-12-03: Misc: Added #pragma comment statement to automatically link with d3dcompiler.lib when using D3DCompile(). +// 2018-11-30: Misc: Setting up io.BackendRendererName so it can be displayed in the About Window. +// 2018-06-12: DirectX12: Moved the ID3D12GraphicsCommandList* parameter from NewFrame() to RenderDrawData(). +// 2018-06-08: Misc: Extracted imgui_impl_dx12.cpp/.h away from the old combined DX12+Win32 example. +// 2018-06-08: DirectX12: Use draw_data->DisplayPos and draw_data->DisplaySize to setup projection matrix and clipping rectangle (to ease support for future multi-viewport). +// 2018-02-22: Merged into master with all Win32 code synchronized to other examples. + +#include "imgui.h" +#include "imgui_impl_dx12.h" + +// DirectX +#include +#include +#include +#ifdef _MSC_VER +#pragma comment(lib, "d3dcompiler") // Automatically link with d3dcompiler.lib as we are using D3DCompile() below. +#endif + +// DirectX data +struct ImGui_ImplDX12_RenderBuffers +{ + ID3D12Resource* IndexBuffer; + ID3D12Resource* VertexBuffer; + int IndexBufferSize; + int VertexBufferSize; +}; + +struct ImGui_ImplDX12_Data +{ + ID3D12Device* pd3dDevice; + ID3D12RootSignature* pRootSignature; + ID3D12PipelineState* pPipelineState; + DXGI_FORMAT RTVFormat; + ID3D12Resource* pFontTextureResource; + D3D12_CPU_DESCRIPTOR_HANDLE hFontSrvCpuDescHandle; + D3D12_GPU_DESCRIPTOR_HANDLE hFontSrvGpuDescHandle; + + ImGui_ImplDX12_RenderBuffers* pFrameResources; + UINT numFramesInFlight; + UINT frameIndex; + + ImGui_ImplDX12_Data() { memset(this, 0, sizeof(*this)); frameIndex = UINT_MAX; } +}; + +struct VERTEX_CONSTANT_BUFFER +{ + float mvp[4][4]; +}; + +// Backend data stored in io.BackendRendererUserData to allow support for multiple Dear ImGui contexts +// It is STRONGLY preferred that you use docking branch with multi-viewports (== single Dear ImGui context + multiple windows) instead of multiple Dear ImGui contexts. +static ImGui_ImplDX12_Data* ImGui_ImplDX12_GetBackendData() +{ + return ImGui::GetCurrentContext() ? (ImGui_ImplDX12_Data*)ImGui::GetIO().BackendRendererUserData : NULL; +} + +// Functions +static void ImGui_ImplDX12_SetupRenderState(ImDrawData* draw_data, ID3D12GraphicsCommandList* ctx, ImGui_ImplDX12_RenderBuffers* fr) +{ + ImGui_ImplDX12_Data* bd = ImGui_ImplDX12_GetBackendData(); + + // Setup orthographic projection matrix into our constant buffer + // Our visible imgui space lies from draw_data->DisplayPos (top left) to draw_data->DisplayPos+data_data->DisplaySize (bottom right). + VERTEX_CONSTANT_BUFFER vertex_constant_buffer; + { + float L = draw_data->DisplayPos.x; + float R = draw_data->DisplayPos.x + draw_data->DisplaySize.x; + float T = draw_data->DisplayPos.y; + float B = draw_data->DisplayPos.y + draw_data->DisplaySize.y; + float mvp[4][4] = + { + { 2.0f/(R-L), 0.0f, 0.0f, 0.0f }, + { 0.0f, 2.0f/(T-B), 0.0f, 0.0f }, + { 0.0f, 0.0f, 0.5f, 0.0f }, + { (R+L)/(L-R), (T+B)/(B-T), 0.5f, 1.0f }, + }; + memcpy(&vertex_constant_buffer.mvp, mvp, sizeof(mvp)); + } + + // Setup viewport + D3D12_VIEWPORT vp; + memset(&vp, 0, sizeof(D3D12_VIEWPORT)); + vp.Width = draw_data->DisplaySize.x; + vp.Height = draw_data->DisplaySize.y; + vp.MinDepth = 0.0f; + vp.MaxDepth = 1.0f; + vp.TopLeftX = vp.TopLeftY = 0.0f; + ctx->RSSetViewports(1, &vp); + + // Bind shader and vertex buffers + unsigned int stride = sizeof(ImDrawVert); + unsigned int offset = 0; + D3D12_VERTEX_BUFFER_VIEW vbv; + memset(&vbv, 0, sizeof(D3D12_VERTEX_BUFFER_VIEW)); + vbv.BufferLocation = fr->VertexBuffer->GetGPUVirtualAddress() + offset; + vbv.SizeInBytes = fr->VertexBufferSize * stride; + vbv.StrideInBytes = stride; + ctx->IASetVertexBuffers(0, 1, &vbv); + D3D12_INDEX_BUFFER_VIEW ibv; + memset(&ibv, 0, sizeof(D3D12_INDEX_BUFFER_VIEW)); + ibv.BufferLocation = fr->IndexBuffer->GetGPUVirtualAddress(); + ibv.SizeInBytes = fr->IndexBufferSize * sizeof(ImDrawIdx); + ibv.Format = sizeof(ImDrawIdx) == 2 ? DXGI_FORMAT_R16_UINT : DXGI_FORMAT_R32_UINT; + ctx->IASetIndexBuffer(&ibv); + ctx->IASetPrimitiveTopology(D3D_PRIMITIVE_TOPOLOGY_TRIANGLELIST); + ctx->SetPipelineState(bd->pPipelineState); + ctx->SetGraphicsRootSignature(bd->pRootSignature); + ctx->SetGraphicsRoot32BitConstants(0, 16, &vertex_constant_buffer, 0); + + // Setup blend factor + const float blend_factor[4] = { 0.f, 0.f, 0.f, 0.f }; + ctx->OMSetBlendFactor(blend_factor); +} + +template +static inline void SafeRelease(T*& res) +{ + if (res) + res->Release(); + res = NULL; +} + +// Render function +void ImGui_ImplDX12_RenderDrawData(ImDrawData* draw_data, ID3D12GraphicsCommandList* ctx) +{ + // Avoid rendering when minimized + if (draw_data->DisplaySize.x <= 0.0f || draw_data->DisplaySize.y <= 0.0f) + return; + + // FIXME: I'm assuming that this only gets called once per frame! + // If not, we can't just re-allocate the IB or VB, we'll have to do a proper allocator. + ImGui_ImplDX12_Data* bd = ImGui_ImplDX12_GetBackendData(); + bd->frameIndex = bd->frameIndex + 1; + ImGui_ImplDX12_RenderBuffers* fr = &bd->pFrameResources[bd->frameIndex % bd->numFramesInFlight]; + + // Create and grow vertex/index buffers if needed + if (fr->VertexBuffer == NULL || fr->VertexBufferSize < draw_data->TotalVtxCount) + { + SafeRelease(fr->VertexBuffer); + fr->VertexBufferSize = draw_data->TotalVtxCount + 5000; + D3D12_HEAP_PROPERTIES props; + memset(&props, 0, sizeof(D3D12_HEAP_PROPERTIES)); + props.Type = D3D12_HEAP_TYPE_UPLOAD; + props.CPUPageProperty = D3D12_CPU_PAGE_PROPERTY_UNKNOWN; + props.MemoryPoolPreference = D3D12_MEMORY_POOL_UNKNOWN; + D3D12_RESOURCE_DESC desc; + memset(&desc, 0, sizeof(D3D12_RESOURCE_DESC)); + desc.Dimension = D3D12_RESOURCE_DIMENSION_BUFFER; + desc.Width = fr->VertexBufferSize * sizeof(ImDrawVert); + desc.Height = 1; + desc.DepthOrArraySize = 1; + desc.MipLevels = 1; + desc.Format = DXGI_FORMAT_UNKNOWN; + desc.SampleDesc.Count = 1; + desc.Layout = D3D12_TEXTURE_LAYOUT_ROW_MAJOR; + desc.Flags = D3D12_RESOURCE_FLAG_NONE; + if (bd->pd3dDevice->CreateCommittedResource(&props, D3D12_HEAP_FLAG_NONE, &desc, D3D12_RESOURCE_STATE_GENERIC_READ, NULL, IID_PPV_ARGS(&fr->VertexBuffer)) < 0) + return; + } + if (fr->IndexBuffer == NULL || fr->IndexBufferSize < draw_data->TotalIdxCount) + { + SafeRelease(fr->IndexBuffer); + fr->IndexBufferSize = draw_data->TotalIdxCount + 10000; + D3D12_HEAP_PROPERTIES props; + memset(&props, 0, sizeof(D3D12_HEAP_PROPERTIES)); + props.Type = D3D12_HEAP_TYPE_UPLOAD; + props.CPUPageProperty = D3D12_CPU_PAGE_PROPERTY_UNKNOWN; + props.MemoryPoolPreference = D3D12_MEMORY_POOL_UNKNOWN; + D3D12_RESOURCE_DESC desc; + memset(&desc, 0, sizeof(D3D12_RESOURCE_DESC)); + desc.Dimension = D3D12_RESOURCE_DIMENSION_BUFFER; + desc.Width = fr->IndexBufferSize * sizeof(ImDrawIdx); + desc.Height = 1; + desc.DepthOrArraySize = 1; + desc.MipLevels = 1; + desc.Format = DXGI_FORMAT_UNKNOWN; + desc.SampleDesc.Count = 1; + desc.Layout = D3D12_TEXTURE_LAYOUT_ROW_MAJOR; + desc.Flags = D3D12_RESOURCE_FLAG_NONE; + if (bd->pd3dDevice->CreateCommittedResource(&props, D3D12_HEAP_FLAG_NONE, &desc, D3D12_RESOURCE_STATE_GENERIC_READ, NULL, IID_PPV_ARGS(&fr->IndexBuffer)) < 0) + return; + } + + // Upload vertex/index data into a single contiguous GPU buffer + void* vtx_resource, *idx_resource; + D3D12_RANGE range; + memset(&range, 0, sizeof(D3D12_RANGE)); + if (fr->VertexBuffer->Map(0, &range, &vtx_resource) != S_OK) + return; + if (fr->IndexBuffer->Map(0, &range, &idx_resource) != S_OK) + return; + ImDrawVert* vtx_dst = (ImDrawVert*)vtx_resource; + ImDrawIdx* idx_dst = (ImDrawIdx*)idx_resource; + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + memcpy(vtx_dst, cmd_list->VtxBuffer.Data, cmd_list->VtxBuffer.Size * sizeof(ImDrawVert)); + memcpy(idx_dst, cmd_list->IdxBuffer.Data, cmd_list->IdxBuffer.Size * sizeof(ImDrawIdx)); + vtx_dst += cmd_list->VtxBuffer.Size; + idx_dst += cmd_list->IdxBuffer.Size; + } + fr->VertexBuffer->Unmap(0, &range); + fr->IndexBuffer->Unmap(0, &range); + + // Setup desired DX state + ImGui_ImplDX12_SetupRenderState(draw_data, ctx, fr); + + // Render command lists + // (Because we merged all buffers into a single one, we maintain our own offset into them) + int global_vtx_offset = 0; + int global_idx_offset = 0; + ImVec2 clip_off = draw_data->DisplayPos; + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + const ImDrawCmd* pcmd = &cmd_list->CmdBuffer[cmd_i]; + if (pcmd->UserCallback != NULL) + { + // User callback, registered via ImDrawList::AddCallback() + // (ImDrawCallback_ResetRenderState is a special callback value used by the user to request the renderer to reset render state.) + if (pcmd->UserCallback == ImDrawCallback_ResetRenderState) + ImGui_ImplDX12_SetupRenderState(draw_data, ctx, fr); + else + pcmd->UserCallback(cmd_list, pcmd); + } + else + { + // Project scissor/clipping rectangles into framebuffer space + ImVec2 clip_min(pcmd->ClipRect.x - clip_off.x, pcmd->ClipRect.y - clip_off.y); + ImVec2 clip_max(pcmd->ClipRect.z - clip_off.x, pcmd->ClipRect.w - clip_off.y); + if (clip_max.x < clip_min.x || clip_max.y < clip_min.y) + continue; + + // Apply Scissor/clipping rectangle, Bind texture, Draw + const D3D12_RECT r = { (LONG)clip_min.x, (LONG)clip_min.y, (LONG)clip_max.x, (LONG)clip_max.y }; + D3D12_GPU_DESCRIPTOR_HANDLE texture_handle = {}; + texture_handle.ptr = (UINT64)pcmd->GetTexID(); + ctx->SetGraphicsRootDescriptorTable(1, texture_handle); + ctx->RSSetScissorRects(1, &r); + ctx->DrawIndexedInstanced(pcmd->ElemCount, 1, pcmd->IdxOffset + global_idx_offset, pcmd->VtxOffset + global_vtx_offset, 0); + } + } + global_idx_offset += cmd_list->IdxBuffer.Size; + global_vtx_offset += cmd_list->VtxBuffer.Size; + } +} + +static void ImGui_ImplDX12_CreateFontsTexture() +{ + // Build texture atlas + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplDX12_Data* bd = ImGui_ImplDX12_GetBackendData(); + unsigned char* pixels; + int width, height; + io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height); + + // Upload texture to graphics system + { + D3D12_HEAP_PROPERTIES props; + memset(&props, 0, sizeof(D3D12_HEAP_PROPERTIES)); + props.Type = D3D12_HEAP_TYPE_DEFAULT; + props.CPUPageProperty = D3D12_CPU_PAGE_PROPERTY_UNKNOWN; + props.MemoryPoolPreference = D3D12_MEMORY_POOL_UNKNOWN; + + D3D12_RESOURCE_DESC desc; + ZeroMemory(&desc, sizeof(desc)); + desc.Dimension = D3D12_RESOURCE_DIMENSION_TEXTURE2D; + desc.Alignment = 0; + desc.Width = width; + desc.Height = height; + desc.DepthOrArraySize = 1; + desc.MipLevels = 1; + desc.Format = DXGI_FORMAT_R8G8B8A8_UNORM; + desc.SampleDesc.Count = 1; + desc.SampleDesc.Quality = 0; + desc.Layout = D3D12_TEXTURE_LAYOUT_UNKNOWN; + desc.Flags = D3D12_RESOURCE_FLAG_NONE; + + ID3D12Resource* pTexture = NULL; + bd->pd3dDevice->CreateCommittedResource(&props, D3D12_HEAP_FLAG_NONE, &desc, + D3D12_RESOURCE_STATE_COPY_DEST, NULL, IID_PPV_ARGS(&pTexture)); + + UINT uploadPitch = (width * 4 + D3D12_TEXTURE_DATA_PITCH_ALIGNMENT - 1u) & ~(D3D12_TEXTURE_DATA_PITCH_ALIGNMENT - 1u); + UINT uploadSize = height * uploadPitch; + desc.Dimension = D3D12_RESOURCE_DIMENSION_BUFFER; + desc.Alignment = 0; + desc.Width = uploadSize; + desc.Height = 1; + desc.DepthOrArraySize = 1; + desc.MipLevels = 1; + desc.Format = DXGI_FORMAT_UNKNOWN; + desc.SampleDesc.Count = 1; + desc.SampleDesc.Quality = 0; + desc.Layout = D3D12_TEXTURE_LAYOUT_ROW_MAJOR; + desc.Flags = D3D12_RESOURCE_FLAG_NONE; + + props.Type = D3D12_HEAP_TYPE_UPLOAD; + props.CPUPageProperty = D3D12_CPU_PAGE_PROPERTY_UNKNOWN; + props.MemoryPoolPreference = D3D12_MEMORY_POOL_UNKNOWN; + + ID3D12Resource* uploadBuffer = NULL; + HRESULT hr = bd->pd3dDevice->CreateCommittedResource(&props, D3D12_HEAP_FLAG_NONE, &desc, + D3D12_RESOURCE_STATE_GENERIC_READ, NULL, IID_PPV_ARGS(&uploadBuffer)); + IM_ASSERT(SUCCEEDED(hr)); + + void* mapped = NULL; + D3D12_RANGE range = { 0, uploadSize }; + hr = uploadBuffer->Map(0, &range, &mapped); + IM_ASSERT(SUCCEEDED(hr)); + for (int y = 0; y < height; y++) + memcpy((void*) ((uintptr_t) mapped + y * uploadPitch), pixels + y * width * 4, width * 4); + uploadBuffer->Unmap(0, &range); + + D3D12_TEXTURE_COPY_LOCATION srcLocation = {}; + srcLocation.pResource = uploadBuffer; + srcLocation.Type = D3D12_TEXTURE_COPY_TYPE_PLACED_FOOTPRINT; + srcLocation.PlacedFootprint.Footprint.Format = DXGI_FORMAT_R8G8B8A8_UNORM; + srcLocation.PlacedFootprint.Footprint.Width = width; + srcLocation.PlacedFootprint.Footprint.Height = height; + srcLocation.PlacedFootprint.Footprint.Depth = 1; + srcLocation.PlacedFootprint.Footprint.RowPitch = uploadPitch; + + D3D12_TEXTURE_COPY_LOCATION dstLocation = {}; + dstLocation.pResource = pTexture; + dstLocation.Type = D3D12_TEXTURE_COPY_TYPE_SUBRESOURCE_INDEX; + dstLocation.SubresourceIndex = 0; + + D3D12_RESOURCE_BARRIER barrier = {}; + barrier.Type = D3D12_RESOURCE_BARRIER_TYPE_TRANSITION; + barrier.Flags = D3D12_RESOURCE_BARRIER_FLAG_NONE; + barrier.Transition.pResource = pTexture; + barrier.Transition.Subresource = D3D12_RESOURCE_BARRIER_ALL_SUBRESOURCES; + barrier.Transition.StateBefore = D3D12_RESOURCE_STATE_COPY_DEST; + barrier.Transition.StateAfter = D3D12_RESOURCE_STATE_PIXEL_SHADER_RESOURCE; + + ID3D12Fence* fence = NULL; + hr = bd->pd3dDevice->CreateFence(0, D3D12_FENCE_FLAG_NONE, IID_PPV_ARGS(&fence)); + IM_ASSERT(SUCCEEDED(hr)); + + HANDLE event = CreateEvent(0, 0, 0, 0); + IM_ASSERT(event != NULL); + + D3D12_COMMAND_QUEUE_DESC queueDesc = {}; + queueDesc.Type = D3D12_COMMAND_LIST_TYPE_DIRECT; + queueDesc.Flags = D3D12_COMMAND_QUEUE_FLAG_NONE; + queueDesc.NodeMask = 1; + + ID3D12CommandQueue* cmdQueue = NULL; + hr = bd->pd3dDevice->CreateCommandQueue(&queueDesc, IID_PPV_ARGS(&cmdQueue)); + IM_ASSERT(SUCCEEDED(hr)); + + ID3D12CommandAllocator* cmdAlloc = NULL; + hr = bd->pd3dDevice->CreateCommandAllocator(D3D12_COMMAND_LIST_TYPE_DIRECT, IID_PPV_ARGS(&cmdAlloc)); + IM_ASSERT(SUCCEEDED(hr)); + + ID3D12GraphicsCommandList* cmdList = NULL; + hr = bd->pd3dDevice->CreateCommandList(0, D3D12_COMMAND_LIST_TYPE_DIRECT, cmdAlloc, NULL, IID_PPV_ARGS(&cmdList)); + IM_ASSERT(SUCCEEDED(hr)); + + cmdList->CopyTextureRegion(&dstLocation, 0, 0, 0, &srcLocation, NULL); + cmdList->ResourceBarrier(1, &barrier); + + hr = cmdList->Close(); + IM_ASSERT(SUCCEEDED(hr)); + + cmdQueue->ExecuteCommandLists(1, (ID3D12CommandList* const*)&cmdList); + hr = cmdQueue->Signal(fence, 1); + IM_ASSERT(SUCCEEDED(hr)); + + fence->SetEventOnCompletion(1, event); + WaitForSingleObject(event, INFINITE); + + cmdList->Release(); + cmdAlloc->Release(); + cmdQueue->Release(); + CloseHandle(event); + fence->Release(); + uploadBuffer->Release(); + + // Create texture view + D3D12_SHADER_RESOURCE_VIEW_DESC srvDesc; + ZeroMemory(&srvDesc, sizeof(srvDesc)); + srvDesc.Format = DXGI_FORMAT_R8G8B8A8_UNORM; + srvDesc.ViewDimension = D3D12_SRV_DIMENSION_TEXTURE2D; + srvDesc.Texture2D.MipLevels = desc.MipLevels; + srvDesc.Texture2D.MostDetailedMip = 0; + srvDesc.Shader4ComponentMapping = D3D12_DEFAULT_SHADER_4_COMPONENT_MAPPING; + bd->pd3dDevice->CreateShaderResourceView(pTexture, &srvDesc, bd->hFontSrvCpuDescHandle); + SafeRelease(bd->pFontTextureResource); + bd->pFontTextureResource = pTexture; + } + + // Store our identifier + // READ THIS IF THE STATIC_ASSERT() TRIGGERS: + // - Important: to compile on 32-bit systems, this backend requires code to be compiled with '#define ImTextureID ImU64'. + // - This is because we need ImTextureID to carry a 64-bit value and by default ImTextureID is defined as void*. + // [Solution 1] IDE/msbuild: in "Properties/C++/Preprocessor Definitions" add 'ImTextureID=ImU64' (this is what we do in the 'example_win32_direct12/example_win32_direct12.vcxproj' project file) + // [Solution 2] IDE/msbuild: in "Properties/C++/Preprocessor Definitions" add 'IMGUI_USER_CONFIG="my_imgui_config.h"' and inside 'my_imgui_config.h' add '#define ImTextureID ImU64' and as many other options as you like. + // [Solution 3] IDE/msbuild: edit imconfig.h and add '#define ImTextureID ImU64' (prefer solution 2 to create your own config file!) + // [Solution 4] command-line: add '/D ImTextureID=ImU64' to your cl.exe command-line (this is what we do in the example_win32_direct12/build_win32.bat file) + static_assert(sizeof(ImTextureID) >= sizeof(bd->hFontSrvGpuDescHandle.ptr), "Can't pack descriptor handle into TexID, 32-bit not supported yet."); + io.Fonts->SetTexID((ImTextureID)bd->hFontSrvGpuDescHandle.ptr); +} + +bool ImGui_ImplDX12_CreateDeviceObjects() +{ + ImGui_ImplDX12_Data* bd = ImGui_ImplDX12_GetBackendData(); + if (!bd || !bd->pd3dDevice) + return false; + if (bd->pPipelineState) + ImGui_ImplDX12_InvalidateDeviceObjects(); + + // Create the root signature + { + D3D12_DESCRIPTOR_RANGE descRange = {}; + descRange.RangeType = D3D12_DESCRIPTOR_RANGE_TYPE_SRV; + descRange.NumDescriptors = 1; + descRange.BaseShaderRegister = 0; + descRange.RegisterSpace = 0; + descRange.OffsetInDescriptorsFromTableStart = 0; + + D3D12_ROOT_PARAMETER param[2] = {}; + + param[0].ParameterType = D3D12_ROOT_PARAMETER_TYPE_32BIT_CONSTANTS; + param[0].Constants.ShaderRegister = 0; + param[0].Constants.RegisterSpace = 0; + param[0].Constants.Num32BitValues = 16; + param[0].ShaderVisibility = D3D12_SHADER_VISIBILITY_VERTEX; + + param[1].ParameterType = D3D12_ROOT_PARAMETER_TYPE_DESCRIPTOR_TABLE; + param[1].DescriptorTable.NumDescriptorRanges = 1; + param[1].DescriptorTable.pDescriptorRanges = &descRange; + param[1].ShaderVisibility = D3D12_SHADER_VISIBILITY_PIXEL; + + D3D12_STATIC_SAMPLER_DESC staticSampler = {}; + staticSampler.Filter = D3D12_FILTER_MIN_MAG_MIP_LINEAR; + staticSampler.AddressU = D3D12_TEXTURE_ADDRESS_MODE_WRAP; + staticSampler.AddressV = D3D12_TEXTURE_ADDRESS_MODE_WRAP; + staticSampler.AddressW = D3D12_TEXTURE_ADDRESS_MODE_WRAP; + staticSampler.MipLODBias = 0.f; + staticSampler.MaxAnisotropy = 0; + staticSampler.ComparisonFunc = D3D12_COMPARISON_FUNC_ALWAYS; + staticSampler.BorderColor = D3D12_STATIC_BORDER_COLOR_TRANSPARENT_BLACK; + staticSampler.MinLOD = 0.f; + staticSampler.MaxLOD = 0.f; + staticSampler.ShaderRegister = 0; + staticSampler.RegisterSpace = 0; + staticSampler.ShaderVisibility = D3D12_SHADER_VISIBILITY_PIXEL; + + D3D12_ROOT_SIGNATURE_DESC desc = {}; + desc.NumParameters = _countof(param); + desc.pParameters = param; + desc.NumStaticSamplers = 1; + desc.pStaticSamplers = &staticSampler; + desc.Flags = + D3D12_ROOT_SIGNATURE_FLAG_ALLOW_INPUT_ASSEMBLER_INPUT_LAYOUT | + D3D12_ROOT_SIGNATURE_FLAG_DENY_HULL_SHADER_ROOT_ACCESS | + D3D12_ROOT_SIGNATURE_FLAG_DENY_DOMAIN_SHADER_ROOT_ACCESS | + D3D12_ROOT_SIGNATURE_FLAG_DENY_GEOMETRY_SHADER_ROOT_ACCESS; + + // Load d3d12.dll and D3D12SerializeRootSignature() function address dynamically to facilitate using with D3D12On7. + // See if any version of d3d12.dll is already loaded in the process. If so, give preference to that. + static HINSTANCE d3d12_dll = ::GetModuleHandleA("d3d12.dll"); + if (d3d12_dll == NULL) + { + // Attempt to load d3d12.dll from local directories. This will only succeed if + // (1) the current OS is Windows 7, and + // (2) there exists a version of d3d12.dll for Windows 7 (D3D12On7) in one of the following directories. + // See https://github.com/ocornut/imgui/pull/3696 for details. + const char* localD3d12Paths[] = { ".\\d3d12.dll", ".\\d3d12on7\\d3d12.dll", ".\\12on7\\d3d12.dll" }; // A. current directory, B. used by some games, C. used in Microsoft D3D12On7 sample + for (int i = 0; i < IM_ARRAYSIZE(localD3d12Paths); i++) + if ((d3d12_dll = ::LoadLibraryA(localD3d12Paths[i])) != NULL) + break; + + // If failed, we are on Windows >= 10. + if (d3d12_dll == NULL) + d3d12_dll = ::LoadLibraryA("d3d12.dll"); + + if (d3d12_dll == NULL) + return false; + } + + PFN_D3D12_SERIALIZE_ROOT_SIGNATURE D3D12SerializeRootSignatureFn = (PFN_D3D12_SERIALIZE_ROOT_SIGNATURE)::GetProcAddress(d3d12_dll, "D3D12SerializeRootSignature"); + if (D3D12SerializeRootSignatureFn == NULL) + return false; + + ID3DBlob* blob = NULL; + if (D3D12SerializeRootSignatureFn(&desc, D3D_ROOT_SIGNATURE_VERSION_1, &blob, NULL) != S_OK) + return false; + + bd->pd3dDevice->CreateRootSignature(0, blob->GetBufferPointer(), blob->GetBufferSize(), IID_PPV_ARGS(&bd->pRootSignature)); + blob->Release(); + } + + // By using D3DCompile() from / d3dcompiler.lib, we introduce a dependency to a given version of d3dcompiler_XX.dll (see D3DCOMPILER_DLL_A) + // If you would like to use this DX12 sample code but remove this dependency you can: + // 1) compile once, save the compiled shader blobs into a file or source code and pass them to CreateVertexShader()/CreatePixelShader() [preferred solution] + // 2) use code to detect any version of the DLL and grab a pointer to D3DCompile from the DLL. + // See https://github.com/ocornut/imgui/pull/638 for sources and details. + + D3D12_GRAPHICS_PIPELINE_STATE_DESC psoDesc; + memset(&psoDesc, 0, sizeof(D3D12_GRAPHICS_PIPELINE_STATE_DESC)); + psoDesc.NodeMask = 1; + psoDesc.PrimitiveTopologyType = D3D12_PRIMITIVE_TOPOLOGY_TYPE_TRIANGLE; + psoDesc.pRootSignature = bd->pRootSignature; + psoDesc.SampleMask = UINT_MAX; + psoDesc.NumRenderTargets = 1; + psoDesc.RTVFormats[0] = bd->RTVFormat; + psoDesc.SampleDesc.Count = 1; + psoDesc.Flags = D3D12_PIPELINE_STATE_FLAG_NONE; + + ID3DBlob* vertexShaderBlob; + ID3DBlob* pixelShaderBlob; + + // Create the vertex shader + { + static const char* vertexShader = + "cbuffer vertexBuffer : register(b0) \ + {\ + float4x4 ProjectionMatrix; \ + };\ + struct VS_INPUT\ + {\ + float2 pos : POSITION;\ + float4 col : COLOR0;\ + float2 uv : TEXCOORD0;\ + };\ + \ + struct PS_INPUT\ + {\ + float4 pos : SV_POSITION;\ + float4 col : COLOR0;\ + float2 uv : TEXCOORD0;\ + };\ + \ + PS_INPUT main(VS_INPUT input)\ + {\ + PS_INPUT output;\ + output.pos = mul( ProjectionMatrix, float4(input.pos.xy, 0.f, 1.f));\ + output.col = input.col;\ + output.uv = input.uv;\ + return output;\ + }"; + + if (FAILED(D3DCompile(vertexShader, strlen(vertexShader), NULL, NULL, NULL, "main", "vs_5_0", 0, 0, &vertexShaderBlob, NULL))) + return false; // NB: Pass ID3D10Blob* pErrorBlob to D3DCompile() to get error showing in (const char*)pErrorBlob->GetBufferPointer(). Make sure to Release() the blob! + psoDesc.VS = { vertexShaderBlob->GetBufferPointer(), vertexShaderBlob->GetBufferSize() }; + + // Create the input layout + static D3D12_INPUT_ELEMENT_DESC local_layout[] = + { + { "POSITION", 0, DXGI_FORMAT_R32G32_FLOAT, 0, (UINT)IM_OFFSETOF(ImDrawVert, pos), D3D12_INPUT_CLASSIFICATION_PER_VERTEX_DATA, 0 }, + { "TEXCOORD", 0, DXGI_FORMAT_R32G32_FLOAT, 0, (UINT)IM_OFFSETOF(ImDrawVert, uv), D3D12_INPUT_CLASSIFICATION_PER_VERTEX_DATA, 0 }, + { "COLOR", 0, DXGI_FORMAT_R8G8B8A8_UNORM, 0, (UINT)IM_OFFSETOF(ImDrawVert, col), D3D12_INPUT_CLASSIFICATION_PER_VERTEX_DATA, 0 }, + }; + psoDesc.InputLayout = { local_layout, 3 }; + } + + // Create the pixel shader + { + static const char* pixelShader = + "struct PS_INPUT\ + {\ + float4 pos : SV_POSITION;\ + float4 col : COLOR0;\ + float2 uv : TEXCOORD0;\ + };\ + SamplerState sampler0 : register(s0);\ + Texture2D texture0 : register(t0);\ + \ + float4 main(PS_INPUT input) : SV_Target\ + {\ + float4 out_col = input.col * texture0.Sample(sampler0, input.uv); \ + return out_col; \ + }"; + + if (FAILED(D3DCompile(pixelShader, strlen(pixelShader), NULL, NULL, NULL, "main", "ps_5_0", 0, 0, &pixelShaderBlob, NULL))) + { + vertexShaderBlob->Release(); + return false; // NB: Pass ID3D10Blob* pErrorBlob to D3DCompile() to get error showing in (const char*)pErrorBlob->GetBufferPointer(). Make sure to Release() the blob! + } + psoDesc.PS = { pixelShaderBlob->GetBufferPointer(), pixelShaderBlob->GetBufferSize() }; + } + + // Create the blending setup + { + D3D12_BLEND_DESC& desc = psoDesc.BlendState; + desc.AlphaToCoverageEnable = false; + desc.RenderTarget[0].BlendEnable = true; + desc.RenderTarget[0].SrcBlend = D3D12_BLEND_SRC_ALPHA; + desc.RenderTarget[0].DestBlend = D3D12_BLEND_INV_SRC_ALPHA; + desc.RenderTarget[0].BlendOp = D3D12_BLEND_OP_ADD; + desc.RenderTarget[0].SrcBlendAlpha = D3D12_BLEND_ONE; + desc.RenderTarget[0].DestBlendAlpha = D3D12_BLEND_INV_SRC_ALPHA; + desc.RenderTarget[0].BlendOpAlpha = D3D12_BLEND_OP_ADD; + desc.RenderTarget[0].RenderTargetWriteMask = D3D12_COLOR_WRITE_ENABLE_ALL; + } + + // Create the rasterizer state + { + D3D12_RASTERIZER_DESC& desc = psoDesc.RasterizerState; + desc.FillMode = D3D12_FILL_MODE_SOLID; + desc.CullMode = D3D12_CULL_MODE_NONE; + desc.FrontCounterClockwise = FALSE; + desc.DepthBias = D3D12_DEFAULT_DEPTH_BIAS; + desc.DepthBiasClamp = D3D12_DEFAULT_DEPTH_BIAS_CLAMP; + desc.SlopeScaledDepthBias = D3D12_DEFAULT_SLOPE_SCALED_DEPTH_BIAS; + desc.DepthClipEnable = true; + desc.MultisampleEnable = FALSE; + desc.AntialiasedLineEnable = FALSE; + desc.ForcedSampleCount = 0; + desc.ConservativeRaster = D3D12_CONSERVATIVE_RASTERIZATION_MODE_OFF; + } + + // Create depth-stencil State + { + D3D12_DEPTH_STENCIL_DESC& desc = psoDesc.DepthStencilState; + desc.DepthEnable = false; + desc.DepthWriteMask = D3D12_DEPTH_WRITE_MASK_ALL; + desc.DepthFunc = D3D12_COMPARISON_FUNC_ALWAYS; + desc.StencilEnable = false; + desc.FrontFace.StencilFailOp = desc.FrontFace.StencilDepthFailOp = desc.FrontFace.StencilPassOp = D3D12_STENCIL_OP_KEEP; + desc.FrontFace.StencilFunc = D3D12_COMPARISON_FUNC_ALWAYS; + desc.BackFace = desc.FrontFace; + } + + HRESULT result_pipeline_state = bd->pd3dDevice->CreateGraphicsPipelineState(&psoDesc, IID_PPV_ARGS(&bd->pPipelineState)); + vertexShaderBlob->Release(); + pixelShaderBlob->Release(); + if (result_pipeline_state != S_OK) + return false; + + ImGui_ImplDX12_CreateFontsTexture(); + + return true; +} + +void ImGui_ImplDX12_InvalidateDeviceObjects() +{ + ImGui_ImplDX12_Data* bd = ImGui_ImplDX12_GetBackendData(); + if (!bd || !bd->pd3dDevice) + return; + ImGuiIO& io = ImGui::GetIO(); + + SafeRelease(bd->pRootSignature); + SafeRelease(bd->pPipelineState); + SafeRelease(bd->pFontTextureResource); + io.Fonts->SetTexID(NULL); // We copied bd->pFontTextureView to io.Fonts->TexID so let's clear that as well. + + for (UINT i = 0; i < bd->numFramesInFlight; i++) + { + ImGui_ImplDX12_RenderBuffers* fr = &bd->pFrameResources[i]; + SafeRelease(fr->IndexBuffer); + SafeRelease(fr->VertexBuffer); + } +} + +bool ImGui_ImplDX12_Init(ID3D12Device* device, int num_frames_in_flight, DXGI_FORMAT rtv_format, ID3D12DescriptorHeap* cbv_srv_heap, + D3D12_CPU_DESCRIPTOR_HANDLE font_srv_cpu_desc_handle, D3D12_GPU_DESCRIPTOR_HANDLE font_srv_gpu_desc_handle) +{ + ImGuiIO& io = ImGui::GetIO(); + IM_ASSERT(io.BackendRendererUserData == NULL && "Already initialized a renderer backend!"); + + // Setup backend capabilities flags + ImGui_ImplDX12_Data* bd = IM_NEW(ImGui_ImplDX12_Data)(); + io.BackendRendererUserData = (void*)bd; + io.BackendRendererName = "imgui_impl_dx12"; + io.BackendFlags |= ImGuiBackendFlags_RendererHasVtxOffset; // We can honor the ImDrawCmd::VtxOffset field, allowing for large meshes. + + bd->pd3dDevice = device; + bd->RTVFormat = rtv_format; + bd->hFontSrvCpuDescHandle = font_srv_cpu_desc_handle; + bd->hFontSrvGpuDescHandle = font_srv_gpu_desc_handle; + bd->pFrameResources = new ImGui_ImplDX12_RenderBuffers[num_frames_in_flight]; + bd->numFramesInFlight = num_frames_in_flight; + bd->frameIndex = UINT_MAX; + IM_UNUSED(cbv_srv_heap); // Unused in master branch (will be used by multi-viewports) + + // Create buffers with a default size (they will later be grown as needed) + for (int i = 0; i < num_frames_in_flight; i++) + { + ImGui_ImplDX12_RenderBuffers* fr = &bd->pFrameResources[i]; + fr->IndexBuffer = NULL; + fr->VertexBuffer = NULL; + fr->IndexBufferSize = 10000; + fr->VertexBufferSize = 5000; + } + + return true; +} + +void ImGui_ImplDX12_Shutdown() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplDX12_Data* bd = ImGui_ImplDX12_GetBackendData(); + + ImGui_ImplDX12_InvalidateDeviceObjects(); + delete[] bd->pFrameResources; + io.BackendRendererName = NULL; + io.BackendRendererUserData = NULL; + IM_DELETE(bd); +} + +void ImGui_ImplDX12_NewFrame() +{ + ImGui_ImplDX12_Data* bd = ImGui_ImplDX12_GetBackendData(); + IM_ASSERT(bd != NULL && "Did you call ImGui_ImplDX12_Init()?"); + + if (!bd->pPipelineState) + ImGui_ImplDX12_CreateDeviceObjects(); +} diff --git a/source/editor/imgui/backends/imgui_impl_dx12.h b/source/editor/imgui/backends/imgui_impl_dx12.h new file mode 100644 index 0000000..cd35584 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_dx12.h @@ -0,0 +1,49 @@ +// dear imgui: Renderer Backend for DirectX12 +// This needs to be used along with a Platform Backend (e.g. Win32) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'D3D12_GPU_DESCRIPTOR_HANDLE' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. + +// Important: to compile on 32-bit systems, this backend requires code to be compiled with '#define ImTextureID ImU64'. +// This is because we need ImTextureID to carry a 64-bit value and by default ImTextureID is defined as void*. +// This define is set in the example .vcxproj file and need to be replicated in your app or by adding it to your imconfig.h file. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +#ifdef _MSC_VER +#pragma warning (push) +#pragma warning (disable: 4471) // a forward declaration of an unscoped enumeration must have an underlying type +#endif + +enum DXGI_FORMAT; +struct ID3D12Device; +struct ID3D12DescriptorHeap; +struct ID3D12GraphicsCommandList; +struct D3D12_CPU_DESCRIPTOR_HANDLE; +struct D3D12_GPU_DESCRIPTOR_HANDLE; + +// cmd_list is the command list that the implementation will use to render imgui draw lists. +// Before calling the render function, caller must prepare cmd_list by resetting it and setting the appropriate +// render target and descriptor heap that contains font_srv_cpu_desc_handle/font_srv_gpu_desc_handle. +// font_srv_cpu_desc_handle and font_srv_gpu_desc_handle are handles to a single SRV descriptor to use for the internal font texture. +IMGUI_IMPL_API bool ImGui_ImplDX12_Init(ID3D12Device* device, int num_frames_in_flight, DXGI_FORMAT rtv_format, ID3D12DescriptorHeap* cbv_srv_heap, + D3D12_CPU_DESCRIPTOR_HANDLE font_srv_cpu_desc_handle, D3D12_GPU_DESCRIPTOR_HANDLE font_srv_gpu_desc_handle); +IMGUI_IMPL_API void ImGui_ImplDX12_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplDX12_NewFrame(); +IMGUI_IMPL_API void ImGui_ImplDX12_RenderDrawData(ImDrawData* draw_data, ID3D12GraphicsCommandList* graphics_command_list); + +// Use if you want to reset your rendering device without losing Dear ImGui state. +IMGUI_IMPL_API void ImGui_ImplDX12_InvalidateDeviceObjects(); +IMGUI_IMPL_API bool ImGui_ImplDX12_CreateDeviceObjects(); + +#ifdef _MSC_VER +#pragma warning (pop) +#endif + diff --git a/source/editor/imgui/backends/imgui_impl_dx9.cpp b/source/editor/imgui/backends/imgui_impl_dx9.cpp new file mode 100644 index 0000000..259ce92 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_dx9.cpp @@ -0,0 +1,377 @@ +// dear imgui: Renderer Backend for DirectX9 +// This needs to be used along with a Platform Backend (e.g. Win32) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'LPDIRECT3DTEXTURE9' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-06-29: Reorganized backend to pull data from a single structure to facilitate usage with multiple-contexts (all g_XXXX access changed to bd->XXXX). +// 2021-06-25: DirectX9: Explicitly disable texture state stages after >= 1. +// 2021-05-19: DirectX9: Replaced direct access to ImDrawCmd::TextureId with a call to ImDrawCmd::GetTexID(). (will become a requirement) +// 2021-04-23: DirectX9: Explicitly setting up more graphics states to increase compatibility with unusual non-default states. +// 2021-03-18: DirectX9: Calling IDirect3DStateBlock9::Capture() after CreateStateBlock() as a workaround for state restoring issues (see #3857). +// 2021-03-03: DirectX9: Added support for IMGUI_USE_BGRA_PACKED_COLOR in user's imconfig file. +// 2021-02-18: DirectX9: Change blending equation to preserve alpha in output buffer. +// 2019-05-29: DirectX9: Added support for large mesh (64K+ vertices), enable ImGuiBackendFlags_RendererHasVtxOffset flag. +// 2019-04-30: DirectX9: Added support for special ImDrawCallback_ResetRenderState callback to reset render state. +// 2019-03-29: Misc: Fixed erroneous assert in ImGui_ImplDX9_InvalidateDeviceObjects(). +// 2019-01-16: Misc: Disabled fog before drawing UI's. Fixes issue #2288. +// 2018-11-30: Misc: Setting up io.BackendRendererName so it can be displayed in the About Window. +// 2018-06-08: Misc: Extracted imgui_impl_dx9.cpp/.h away from the old combined DX9+Win32 example. +// 2018-06-08: DirectX9: Use draw_data->DisplayPos and draw_data->DisplaySize to setup projection matrix and clipping rectangle. +// 2018-05-07: Render: Saving/restoring Transform because they don't seem to be included in the StateBlock. Setting shading mode to Gouraud. +// 2018-02-16: Misc: Obsoleted the io.RenderDrawListsFn callback and exposed ImGui_ImplDX9_RenderDrawData() in the .h file so you can call it yourself. +// 2018-02-06: Misc: Removed call to ImGui::Shutdown() which is not available from 1.60 WIP, user needs to call CreateContext/DestroyContext themselves. + +#include "imgui.h" +#include "imgui_impl_dx9.h" + +// DirectX +#include + +// DirectX data +struct ImGui_ImplDX9_Data +{ + LPDIRECT3DDEVICE9 pd3dDevice; + LPDIRECT3DVERTEXBUFFER9 pVB; + LPDIRECT3DINDEXBUFFER9 pIB; + LPDIRECT3DTEXTURE9 FontTexture; + int VertexBufferSize; + int IndexBufferSize; + + ImGui_ImplDX9_Data() { memset(this, 0, sizeof(*this)); VertexBufferSize = 5000; IndexBufferSize = 10000; } +}; + +struct CUSTOMVERTEX +{ + float pos[3]; + D3DCOLOR col; + float uv[2]; +}; +#define D3DFVF_CUSTOMVERTEX (D3DFVF_XYZ|D3DFVF_DIFFUSE|D3DFVF_TEX1) + +#ifdef IMGUI_USE_BGRA_PACKED_COLOR +#define IMGUI_COL_TO_DX9_ARGB(_COL) (_COL) +#else +#define IMGUI_COL_TO_DX9_ARGB(_COL) (((_COL) & 0xFF00FF00) | (((_COL) & 0xFF0000) >> 16) | (((_COL) & 0xFF) << 16)) +#endif + +// Backend data stored in io.BackendRendererUserData to allow support for multiple Dear ImGui contexts +// It is STRONGLY preferred that you use docking branch with multi-viewports (== single Dear ImGui context + multiple windows) instead of multiple Dear ImGui contexts. +static ImGui_ImplDX9_Data* ImGui_ImplDX9_GetBackendData() +{ + return ImGui::GetCurrentContext() ? (ImGui_ImplDX9_Data*)ImGui::GetIO().BackendRendererUserData : NULL; +} + +// Functions +static void ImGui_ImplDX9_SetupRenderState(ImDrawData* draw_data) +{ + ImGui_ImplDX9_Data* bd = ImGui_ImplDX9_GetBackendData(); + + // Setup viewport + D3DVIEWPORT9 vp; + vp.X = vp.Y = 0; + vp.Width = (DWORD)draw_data->DisplaySize.x; + vp.Height = (DWORD)draw_data->DisplaySize.y; + vp.MinZ = 0.0f; + vp.MaxZ = 1.0f; + bd->pd3dDevice->SetViewport(&vp); + + // Setup render state: fixed-pipeline, alpha-blending, no face culling, no depth testing, shade mode (for gradient) + bd->pd3dDevice->SetPixelShader(NULL); + bd->pd3dDevice->SetVertexShader(NULL); + bd->pd3dDevice->SetRenderState(D3DRS_FILLMODE, D3DFILL_SOLID); + bd->pd3dDevice->SetRenderState(D3DRS_SHADEMODE, D3DSHADE_GOURAUD); + bd->pd3dDevice->SetRenderState(D3DRS_ZWRITEENABLE, FALSE); + bd->pd3dDevice->SetRenderState(D3DRS_ALPHATESTENABLE, FALSE); + bd->pd3dDevice->SetRenderState(D3DRS_CULLMODE, D3DCULL_NONE); + bd->pd3dDevice->SetRenderState(D3DRS_ZENABLE, FALSE); + bd->pd3dDevice->SetRenderState(D3DRS_ALPHABLENDENABLE, TRUE); + bd->pd3dDevice->SetRenderState(D3DRS_BLENDOP, D3DBLENDOP_ADD); + bd->pd3dDevice->SetRenderState(D3DRS_SRCBLEND, D3DBLEND_SRCALPHA); + bd->pd3dDevice->SetRenderState(D3DRS_DESTBLEND, D3DBLEND_INVSRCALPHA); + bd->pd3dDevice->SetRenderState(D3DRS_SEPARATEALPHABLENDENABLE, TRUE); + bd->pd3dDevice->SetRenderState(D3DRS_SRCBLENDALPHA, D3DBLEND_ONE); + bd->pd3dDevice->SetRenderState(D3DRS_DESTBLENDALPHA, D3DBLEND_INVSRCALPHA); + bd->pd3dDevice->SetRenderState(D3DRS_SCISSORTESTENABLE, TRUE); + bd->pd3dDevice->SetRenderState(D3DRS_FOGENABLE, FALSE); + bd->pd3dDevice->SetRenderState(D3DRS_RANGEFOGENABLE, FALSE); + bd->pd3dDevice->SetRenderState(D3DRS_SPECULARENABLE, FALSE); + bd->pd3dDevice->SetRenderState(D3DRS_STENCILENABLE, FALSE); + bd->pd3dDevice->SetRenderState(D3DRS_CLIPPING, TRUE); + bd->pd3dDevice->SetRenderState(D3DRS_LIGHTING, FALSE); + bd->pd3dDevice->SetTextureStageState(0, D3DTSS_COLOROP, D3DTOP_MODULATE); + bd->pd3dDevice->SetTextureStageState(0, D3DTSS_COLORARG1, D3DTA_TEXTURE); + bd->pd3dDevice->SetTextureStageState(0, D3DTSS_COLORARG2, D3DTA_DIFFUSE); + bd->pd3dDevice->SetTextureStageState(0, D3DTSS_ALPHAOP, D3DTOP_MODULATE); + bd->pd3dDevice->SetTextureStageState(0, D3DTSS_ALPHAARG1, D3DTA_TEXTURE); + bd->pd3dDevice->SetTextureStageState(0, D3DTSS_ALPHAARG2, D3DTA_DIFFUSE); + bd->pd3dDevice->SetTextureStageState(1, D3DTSS_COLOROP, D3DTOP_DISABLE); + bd->pd3dDevice->SetTextureStageState(1, D3DTSS_ALPHAOP, D3DTOP_DISABLE); + bd->pd3dDevice->SetSamplerState(0, D3DSAMP_MINFILTER, D3DTEXF_LINEAR); + bd->pd3dDevice->SetSamplerState(0, D3DSAMP_MAGFILTER, D3DTEXF_LINEAR); + + // Setup orthographic projection matrix + // Our visible imgui space lies from draw_data->DisplayPos (top left) to draw_data->DisplayPos+data_data->DisplaySize (bottom right). DisplayPos is (0,0) for single viewport apps. + // Being agnostic of whether or can be used, we aren't relying on D3DXMatrixIdentity()/D3DXMatrixOrthoOffCenterLH() or DirectX::XMMatrixIdentity()/DirectX::XMMatrixOrthographicOffCenterLH() + { + float L = draw_data->DisplayPos.x + 0.5f; + float R = draw_data->DisplayPos.x + draw_data->DisplaySize.x + 0.5f; + float T = draw_data->DisplayPos.y + 0.5f; + float B = draw_data->DisplayPos.y + draw_data->DisplaySize.y + 0.5f; + D3DMATRIX mat_identity = { { { 1.0f, 0.0f, 0.0f, 0.0f, 0.0f, 1.0f, 0.0f, 0.0f, 0.0f, 0.0f, 1.0f, 0.0f, 0.0f, 0.0f, 0.0f, 1.0f } } }; + D3DMATRIX mat_projection = + { { { + 2.0f/(R-L), 0.0f, 0.0f, 0.0f, + 0.0f, 2.0f/(T-B), 0.0f, 0.0f, + 0.0f, 0.0f, 0.5f, 0.0f, + (L+R)/(L-R), (T+B)/(B-T), 0.5f, 1.0f + } } }; + bd->pd3dDevice->SetTransform(D3DTS_WORLD, &mat_identity); + bd->pd3dDevice->SetTransform(D3DTS_VIEW, &mat_identity); + bd->pd3dDevice->SetTransform(D3DTS_PROJECTION, &mat_projection); + } +} + +// Render function. +void ImGui_ImplDX9_RenderDrawData(ImDrawData* draw_data) +{ + // Avoid rendering when minimized + if (draw_data->DisplaySize.x <= 0.0f || draw_data->DisplaySize.y <= 0.0f) + return; + + // Create and grow buffers if needed + ImGui_ImplDX9_Data* bd = ImGui_ImplDX9_GetBackendData(); + if (!bd->pVB || bd->VertexBufferSize < draw_data->TotalVtxCount) + { + if (bd->pVB) { bd->pVB->Release(); bd->pVB = NULL; } + bd->VertexBufferSize = draw_data->TotalVtxCount + 5000; + if (bd->pd3dDevice->CreateVertexBuffer(bd->VertexBufferSize * sizeof(CUSTOMVERTEX), D3DUSAGE_DYNAMIC | D3DUSAGE_WRITEONLY, D3DFVF_CUSTOMVERTEX, D3DPOOL_DEFAULT, &bd->pVB, NULL) < 0) + return; + } + if (!bd->pIB || bd->IndexBufferSize < draw_data->TotalIdxCount) + { + if (bd->pIB) { bd->pIB->Release(); bd->pIB = NULL; } + bd->IndexBufferSize = draw_data->TotalIdxCount + 10000; + if (bd->pd3dDevice->CreateIndexBuffer(bd->IndexBufferSize * sizeof(ImDrawIdx), D3DUSAGE_DYNAMIC | D3DUSAGE_WRITEONLY, sizeof(ImDrawIdx) == 2 ? D3DFMT_INDEX16 : D3DFMT_INDEX32, D3DPOOL_DEFAULT, &bd->pIB, NULL) < 0) + return; + } + + // Backup the DX9 state + IDirect3DStateBlock9* d3d9_state_block = NULL; + if (bd->pd3dDevice->CreateStateBlock(D3DSBT_ALL, &d3d9_state_block) < 0) + return; + if (d3d9_state_block->Capture() < 0) + { + d3d9_state_block->Release(); + return; + } + + // Backup the DX9 transform (DX9 documentation suggests that it is included in the StateBlock but it doesn't appear to) + D3DMATRIX last_world, last_view, last_projection; + bd->pd3dDevice->GetTransform(D3DTS_WORLD, &last_world); + bd->pd3dDevice->GetTransform(D3DTS_VIEW, &last_view); + bd->pd3dDevice->GetTransform(D3DTS_PROJECTION, &last_projection); + + // Allocate buffers + CUSTOMVERTEX* vtx_dst; + ImDrawIdx* idx_dst; + if (bd->pVB->Lock(0, (UINT)(draw_data->TotalVtxCount * sizeof(CUSTOMVERTEX)), (void**)&vtx_dst, D3DLOCK_DISCARD) < 0) + { + d3d9_state_block->Release(); + return; + } + if (bd->pIB->Lock(0, (UINT)(draw_data->TotalIdxCount * sizeof(ImDrawIdx)), (void**)&idx_dst, D3DLOCK_DISCARD) < 0) + { + bd->pVB->Unlock(); + d3d9_state_block->Release(); + return; + } + + // Copy and convert all vertices into a single contiguous buffer, convert colors to DX9 default format. + // FIXME-OPT: This is a minor waste of resource, the ideal is to use imconfig.h and + // 1) to avoid repacking colors: #define IMGUI_USE_BGRA_PACKED_COLOR + // 2) to avoid repacking vertices: #define IMGUI_OVERRIDE_DRAWVERT_STRUCT_LAYOUT struct ImDrawVert { ImVec2 pos; float z; ImU32 col; ImVec2 uv; } + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + const ImDrawVert* vtx_src = cmd_list->VtxBuffer.Data; + for (int i = 0; i < cmd_list->VtxBuffer.Size; i++) + { + vtx_dst->pos[0] = vtx_src->pos.x; + vtx_dst->pos[1] = vtx_src->pos.y; + vtx_dst->pos[2] = 0.0f; + vtx_dst->col = IMGUI_COL_TO_DX9_ARGB(vtx_src->col); + vtx_dst->uv[0] = vtx_src->uv.x; + vtx_dst->uv[1] = vtx_src->uv.y; + vtx_dst++; + vtx_src++; + } + memcpy(idx_dst, cmd_list->IdxBuffer.Data, cmd_list->IdxBuffer.Size * sizeof(ImDrawIdx)); + idx_dst += cmd_list->IdxBuffer.Size; + } + bd->pVB->Unlock(); + bd->pIB->Unlock(); + bd->pd3dDevice->SetStreamSource(0, bd->pVB, 0, sizeof(CUSTOMVERTEX)); + bd->pd3dDevice->SetIndices(bd->pIB); + bd->pd3dDevice->SetFVF(D3DFVF_CUSTOMVERTEX); + + // Setup desired DX state + ImGui_ImplDX9_SetupRenderState(draw_data); + + // Render command lists + // (Because we merged all buffers into a single one, we maintain our own offset into them) + int global_vtx_offset = 0; + int global_idx_offset = 0; + ImVec2 clip_off = draw_data->DisplayPos; + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + const ImDrawCmd* pcmd = &cmd_list->CmdBuffer[cmd_i]; + if (pcmd->UserCallback != NULL) + { + // User callback, registered via ImDrawList::AddCallback() + // (ImDrawCallback_ResetRenderState is a special callback value used by the user to request the renderer to reset render state.) + if (pcmd->UserCallback == ImDrawCallback_ResetRenderState) + ImGui_ImplDX9_SetupRenderState(draw_data); + else + pcmd->UserCallback(cmd_list, pcmd); + } + else + { + // Project scissor/clipping rectangles into framebuffer space + ImVec2 clip_min(pcmd->ClipRect.x - clip_off.x, pcmd->ClipRect.y - clip_off.y); + ImVec2 clip_max(pcmd->ClipRect.z - clip_off.x, pcmd->ClipRect.w - clip_off.y); + if (clip_max.x < clip_min.x || clip_max.y < clip_min.y) + continue; + + // Apply Scissor/clipping rectangle, Bind texture, Draw + const RECT r = { (LONG)clip_min.x, (LONG)clip_min.y, (LONG)clip_max.x, (LONG)clip_max.y }; + const LPDIRECT3DTEXTURE9 texture = (LPDIRECT3DTEXTURE9)pcmd->GetTexID(); + bd->pd3dDevice->SetTexture(0, texture); + bd->pd3dDevice->SetScissorRect(&r); + bd->pd3dDevice->DrawIndexedPrimitive(D3DPT_TRIANGLELIST, pcmd->VtxOffset + global_vtx_offset, 0, (UINT)cmd_list->VtxBuffer.Size, pcmd->IdxOffset + global_idx_offset, pcmd->ElemCount / 3); + } + } + global_idx_offset += cmd_list->IdxBuffer.Size; + global_vtx_offset += cmd_list->VtxBuffer.Size; + } + + // Restore the DX9 transform + bd->pd3dDevice->SetTransform(D3DTS_WORLD, &last_world); + bd->pd3dDevice->SetTransform(D3DTS_VIEW, &last_view); + bd->pd3dDevice->SetTransform(D3DTS_PROJECTION, &last_projection); + + // Restore the DX9 state + d3d9_state_block->Apply(); + d3d9_state_block->Release(); +} + +bool ImGui_ImplDX9_Init(IDirect3DDevice9* device) +{ + ImGuiIO& io = ImGui::GetIO(); + IM_ASSERT(io.BackendRendererUserData == NULL && "Already initialized a renderer backend!"); + + // Setup backend capabilities flags + ImGui_ImplDX9_Data* bd = IM_NEW(ImGui_ImplDX9_Data)(); + io.BackendRendererUserData = (void*)bd; + io.BackendRendererName = "imgui_impl_dx9"; + io.BackendFlags |= ImGuiBackendFlags_RendererHasVtxOffset; // We can honor the ImDrawCmd::VtxOffset field, allowing for large meshes. + + bd->pd3dDevice = device; + bd->pd3dDevice->AddRef(); + + return true; +} + +void ImGui_ImplDX9_Shutdown() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplDX9_Data* bd = ImGui_ImplDX9_GetBackendData(); + + ImGui_ImplDX9_InvalidateDeviceObjects(); + if (bd->pd3dDevice) { bd->pd3dDevice->Release(); } + io.BackendRendererName = NULL; + io.BackendRendererUserData = NULL; + IM_DELETE(bd); +} + +static bool ImGui_ImplDX9_CreateFontsTexture() +{ + // Build texture atlas + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplDX9_Data* bd = ImGui_ImplDX9_GetBackendData(); + unsigned char* pixels; + int width, height, bytes_per_pixel; + io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height, &bytes_per_pixel); + + // Convert RGBA32 to BGRA32 (because RGBA32 is not well supported by DX9 devices) +#ifndef IMGUI_USE_BGRA_PACKED_COLOR + if (io.Fonts->TexPixelsUseColors) + { + ImU32* dst_start = (ImU32*)ImGui::MemAlloc((size_t)width * height * bytes_per_pixel); + for (ImU32* src = (ImU32*)pixels, *dst = dst_start, *dst_end = dst_start + (size_t)width * height; dst < dst_end; src++, dst++) + *dst = IMGUI_COL_TO_DX9_ARGB(*src); + pixels = (unsigned char*)dst_start; + } +#endif + + // Upload texture to graphics system + bd->FontTexture = NULL; + if (bd->pd3dDevice->CreateTexture(width, height, 1, D3DUSAGE_DYNAMIC, D3DFMT_A8R8G8B8, D3DPOOL_DEFAULT, &bd->FontTexture, NULL) < 0) + return false; + D3DLOCKED_RECT tex_locked_rect; + if (bd->FontTexture->LockRect(0, &tex_locked_rect, NULL, 0) != D3D_OK) + return false; + for (int y = 0; y < height; y++) + memcpy((unsigned char*)tex_locked_rect.pBits + (size_t)tex_locked_rect.Pitch * y, pixels + (size_t)width * bytes_per_pixel * y, (size_t)width * bytes_per_pixel); + bd->FontTexture->UnlockRect(0); + + // Store our identifier + io.Fonts->SetTexID((ImTextureID)bd->FontTexture); + +#ifndef IMGUI_USE_BGRA_PACKED_COLOR + if (io.Fonts->TexPixelsUseColors) + ImGui::MemFree(pixels); +#endif + + return true; +} + +bool ImGui_ImplDX9_CreateDeviceObjects() +{ + ImGui_ImplDX9_Data* bd = ImGui_ImplDX9_GetBackendData(); + if (!bd || !bd->pd3dDevice) + return false; + if (!ImGui_ImplDX9_CreateFontsTexture()) + return false; + return true; +} + +void ImGui_ImplDX9_InvalidateDeviceObjects() +{ + ImGui_ImplDX9_Data* bd = ImGui_ImplDX9_GetBackendData(); + if (!bd || !bd->pd3dDevice) + return; + if (bd->pVB) { bd->pVB->Release(); bd->pVB = NULL; } + if (bd->pIB) { bd->pIB->Release(); bd->pIB = NULL; } + if (bd->FontTexture) { bd->FontTexture->Release(); bd->FontTexture = NULL; ImGui::GetIO().Fonts->SetTexID(NULL); } // We copied bd->pFontTextureView to io.Fonts->TexID so let's clear that as well. +} + +void ImGui_ImplDX9_NewFrame() +{ + ImGui_ImplDX9_Data* bd = ImGui_ImplDX9_GetBackendData(); + IM_ASSERT(bd != NULL && "Did you call ImGui_ImplDX9_Init()?"); + + if (!bd->FontTexture) + ImGui_ImplDX9_CreateDeviceObjects(); +} diff --git a/source/editor/imgui/backends/imgui_impl_dx9.h b/source/editor/imgui/backends/imgui_impl_dx9.h new file mode 100644 index 0000000..6dc805b --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_dx9.h @@ -0,0 +1,25 @@ +// dear imgui: Renderer Backend for DirectX9 +// This needs to be used along with a Platform Backend (e.g. Win32) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'LPDIRECT3DTEXTURE9' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +struct IDirect3DDevice9; + +IMGUI_IMPL_API bool ImGui_ImplDX9_Init(IDirect3DDevice9* device); +IMGUI_IMPL_API void ImGui_ImplDX9_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplDX9_NewFrame(); +IMGUI_IMPL_API void ImGui_ImplDX9_RenderDrawData(ImDrawData* draw_data); + +// Use if you want to reset your rendering device without losing Dear ImGui state. +IMGUI_IMPL_API bool ImGui_ImplDX9_CreateDeviceObjects(); +IMGUI_IMPL_API void ImGui_ImplDX9_InvalidateDeviceObjects(); diff --git a/source/editor/imgui/backends/imgui_impl_glfw.cpp b/source/editor/imgui/backends/imgui_impl_glfw.cpp new file mode 100644 index 0000000..8cac724 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_glfw.cpp @@ -0,0 +1,453 @@ +// dear imgui: Platform Backend for GLFW +// This needs to be used along with a Renderer (e.g. OpenGL3, Vulkan, WebGPU..) +// (Info: GLFW is a cross-platform general purpose library for handling windows, inputs, OpenGL/Vulkan graphics context creation, etc.) +// (Requires: GLFW 3.1+) + +// Implemented features: +// [X] Platform: Clipboard support. +// [X] Platform: Gamepad support. Enable with 'io.ConfigFlags |= ImGuiConfigFlags_NavEnableGamepad'. +// [X] Platform: Mouse cursor shape and visibility. Disable with 'io.ConfigFlags |= ImGuiConfigFlags_NoMouseCursorChange' (note: the resizing cursors requires GLFW 3.4+). +// [X] Platform: Keyboard arrays indexed using GLFW_KEY_* codes, e.g. ImGui::IsKeyPressed(GLFW_KEY_SPACE). + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-08-17: *BREAKING CHANGE*: Now using glfwSetWindowFocusCallback() to calling io.AddFocusEvent(). If you called ImGui_ImplGlfw_InitXXX() with install_callbacks = false, you MUST install glfwSetWindowFocusCallback() and forward it to the backend via ImGui_ImplGlfw_WindowFocusCallback(). +// 2021-07-29: *BREAKING CHANGE*: Now using glfwSetCursorEnterCallback(). MousePos is correctly reported when the host platform window is hovered but not focused. If you called ImGui_ImplGlfw_InitXXX() with install_callbacks = false, you MUST install glfwSetWindowFocusCallback() callback and forward it to the backend via ImGui_ImplGlfw_CursorEnterCallback(). +// 2021-06-29: Reorganized backend to pull data from a single structure to facilitate usage with multiple-contexts (all g_XXXX access changed to bd->XXXX). +// 2020-01-17: Inputs: Disable error callback while assigning mouse cursors because some X11 setup don't have them and it generates errors. +// 2019-12-05: Inputs: Added support for new mouse cursors added in GLFW 3.4+ (resizing cursors, not allowed cursor). +// 2019-10-18: Misc: Previously installed user callbacks are now restored on shutdown. +// 2019-07-21: Inputs: Added mapping for ImGuiKey_KeyPadEnter. +// 2019-05-11: Inputs: Don't filter value from character callback before calling AddInputCharacter(). +// 2019-03-12: Misc: Preserve DisplayFramebufferScale when main window is minimized. +// 2018-11-30: Misc: Setting up io.BackendPlatformName so it can be displayed in the About Window. +// 2018-11-07: Inputs: When installing our GLFW callbacks, we save user's previously installed ones - if any - and chain call them. +// 2018-08-01: Inputs: Workaround for Emscripten which doesn't seem to handle focus related calls. +// 2018-06-29: Inputs: Added support for the ImGuiMouseCursor_Hand cursor. +// 2018-06-08: Misc: Extracted imgui_impl_glfw.cpp/.h away from the old combined GLFW+OpenGL/Vulkan examples. +// 2018-03-20: Misc: Setup io.BackendFlags ImGuiBackendFlags_HasMouseCursors flag + honor ImGuiConfigFlags_NoMouseCursorChange flag. +// 2018-02-20: Inputs: Added support for mouse cursors (ImGui::GetMouseCursor() value, passed to glfwSetCursor()). +// 2018-02-06: Misc: Removed call to ImGui::Shutdown() which is not available from 1.60 WIP, user needs to call CreateContext/DestroyContext themselves. +// 2018-02-06: Inputs: Added mapping for ImGuiKey_Space. +// 2018-01-25: Inputs: Added gamepad support if ImGuiConfigFlags_NavEnableGamepad is set. +// 2018-01-25: Inputs: Honoring the io.WantSetMousePos by repositioning the mouse (when using navigation and ImGuiConfigFlags_NavMoveMouse is set). +// 2018-01-20: Inputs: Added Horizontal Mouse Wheel support. +// 2018-01-18: Inputs: Added mapping for ImGuiKey_Insert. +// 2017-08-25: Inputs: MousePos set to -FLT_MAX,-FLT_MAX when mouse is unavailable/missing (instead of -1,-1). +// 2016-10-15: Misc: Added a void* user_data parameter to Clipboard function handlers. + +#include "imgui.h" +#include "imgui_impl_glfw.h" + +// GLFW +#include +#ifdef _WIN32 +#undef APIENTRY +#define GLFW_EXPOSE_NATIVE_WIN32 +#include // for glfwGetWin32Window +#endif +#define GLFW_HAS_WINDOW_TOPMOST (GLFW_VERSION_MAJOR * 1000 + GLFW_VERSION_MINOR * 100 >= 3200) // 3.2+ GLFW_FLOATING +#define GLFW_HAS_WINDOW_HOVERED (GLFW_VERSION_MAJOR * 1000 + GLFW_VERSION_MINOR * 100 >= 3300) // 3.3+ GLFW_HOVERED +#define GLFW_HAS_WINDOW_ALPHA (GLFW_VERSION_MAJOR * 1000 + GLFW_VERSION_MINOR * 100 >= 3300) // 3.3+ glfwSetWindowOpacity +#define GLFW_HAS_PER_MONITOR_DPI (GLFW_VERSION_MAJOR * 1000 + GLFW_VERSION_MINOR * 100 >= 3300) // 3.3+ glfwGetMonitorContentScale +#define GLFW_HAS_VULKAN (GLFW_VERSION_MAJOR * 1000 + GLFW_VERSION_MINOR * 100 >= 3200) // 3.2+ glfwCreateWindowSurface +#ifdef GLFW_RESIZE_NESW_CURSOR // Let's be nice to people who pulled GLFW between 2019-04-16 (3.4 define) and 2019-11-29 (cursors defines) // FIXME: Remove when GLFW 3.4 is released? +#define GLFW_HAS_NEW_CURSORS (GLFW_VERSION_MAJOR * 1000 + GLFW_VERSION_MINOR * 100 >= 3400) // 3.4+ GLFW_RESIZE_ALL_CURSOR, GLFW_RESIZE_NESW_CURSOR, GLFW_RESIZE_NWSE_CURSOR, GLFW_NOT_ALLOWED_CURSOR +#else +#define GLFW_HAS_NEW_CURSORS (0) +#endif + +// GLFW data +enum GlfwClientApi +{ + GlfwClientApi_Unknown, + GlfwClientApi_OpenGL, + GlfwClientApi_Vulkan +}; + +struct ImGui_ImplGlfw_Data +{ + GLFWwindow* Window; + GlfwClientApi ClientApi; + double Time; + GLFWwindow* MouseWindow; + bool MouseJustPressed[ImGuiMouseButton_COUNT]; + GLFWcursor* MouseCursors[ImGuiMouseCursor_COUNT]; + bool InstalledCallbacks; + + // Chain GLFW callbacks: our callbacks will call the user's previously installed callbacks, if any. + GLFWwindowfocusfun PrevUserCallbackWindowFocus; + GLFWcursorenterfun PrevUserCallbackCursorEnter; + GLFWmousebuttonfun PrevUserCallbackMousebutton; + GLFWscrollfun PrevUserCallbackScroll; + GLFWkeyfun PrevUserCallbackKey; + GLFWcharfun PrevUserCallbackChar; + GLFWmonitorfun PrevUserCallbackMonitor; + + ImGui_ImplGlfw_Data() { memset(this, 0, sizeof(*this)); } +}; + +// Backend data stored in io.BackendPlatformUserData to allow support for multiple Dear ImGui contexts +// It is STRONGLY preferred that you use docking branch with multi-viewports (== single Dear ImGui context + multiple windows) instead of multiple Dear ImGui contexts. +// FIXME: multi-context support is not well tested and probably dysfunctional in this backend. +// - Because glfwPollEvents() process all windows and some events may be called outside of it, you will need to register your own callbacks +// (passing install_callbacks=false in ImGui_ImplGlfw_InitXXX functions), set the current dear imgui context and then call our callbacks. +// - Otherwise we may need to store a GLFWWindow* -> ImGuiContext* map and handle this in the backend, adding a little bit of extra complexity to it. +// FIXME: some shared resources (mouse cursor shape, gamepad) are mishandled when using multi-context. +static ImGui_ImplGlfw_Data* ImGui_ImplGlfw_GetBackendData() +{ + return ImGui::GetCurrentContext() ? (ImGui_ImplGlfw_Data*)ImGui::GetIO().BackendPlatformUserData : NULL; +} + +// Functions +static const char* ImGui_ImplGlfw_GetClipboardText(void* user_data) +{ + return glfwGetClipboardString((GLFWwindow*)user_data); +} + +static void ImGui_ImplGlfw_SetClipboardText(void* user_data, const char* text) +{ + glfwSetClipboardString((GLFWwindow*)user_data, text); +} + +void ImGui_ImplGlfw_MouseButtonCallback(GLFWwindow* window, int button, int action, int mods) +{ + ImGui_ImplGlfw_Data* bd = ImGui_ImplGlfw_GetBackendData(); + if (bd->PrevUserCallbackMousebutton != NULL && window == bd->Window) + bd->PrevUserCallbackMousebutton(window, button, action, mods); + + if (action == GLFW_PRESS && button >= 0 && button < IM_ARRAYSIZE(bd->MouseJustPressed)) + bd->MouseJustPressed[button] = true; +} + +void ImGui_ImplGlfw_ScrollCallback(GLFWwindow* window, double xoffset, double yoffset) +{ + ImGui_ImplGlfw_Data* bd = ImGui_ImplGlfw_GetBackendData(); + if (bd->PrevUserCallbackScroll != NULL && window == bd->Window) + bd->PrevUserCallbackScroll(window, xoffset, yoffset); + + ImGuiIO& io = ImGui::GetIO(); + io.MouseWheelH += (float)xoffset; + io.MouseWheel += (float)yoffset; +} + +void ImGui_ImplGlfw_KeyCallback(GLFWwindow* window, int key, int scancode, int action, int mods) +{ + ImGui_ImplGlfw_Data* bd = ImGui_ImplGlfw_GetBackendData(); + if (bd->PrevUserCallbackKey != NULL && window == bd->Window) + bd->PrevUserCallbackKey(window, key, scancode, action, mods); + + ImGuiIO& io = ImGui::GetIO(); + if (key >= 0 && key < IM_ARRAYSIZE(io.KeysDown)) + { + if (action == GLFW_PRESS) + io.KeysDown[key] = true; + if (action == GLFW_RELEASE) + io.KeysDown[key] = false; + } + + // Modifiers are not reliable across systems + io.KeyCtrl = io.KeysDown[GLFW_KEY_LEFT_CONTROL] || io.KeysDown[GLFW_KEY_RIGHT_CONTROL]; + io.KeyShift = io.KeysDown[GLFW_KEY_LEFT_SHIFT] || io.KeysDown[GLFW_KEY_RIGHT_SHIFT]; + io.KeyAlt = io.KeysDown[GLFW_KEY_LEFT_ALT] || io.KeysDown[GLFW_KEY_RIGHT_ALT]; +#ifdef _WIN32 + io.KeySuper = false; +#else + io.KeySuper = io.KeysDown[GLFW_KEY_LEFT_SUPER] || io.KeysDown[GLFW_KEY_RIGHT_SUPER]; +#endif +} + +void ImGui_ImplGlfw_WindowFocusCallback(GLFWwindow* window, int focused) +{ + ImGui_ImplGlfw_Data* bd = ImGui_ImplGlfw_GetBackendData(); + if (bd->PrevUserCallbackWindowFocus != NULL && window == bd->Window) + bd->PrevUserCallbackWindowFocus(window, focused); + + ImGuiIO& io = ImGui::GetIO(); + io.AddFocusEvent(focused != 0); +} + +void ImGui_ImplGlfw_CursorEnterCallback(GLFWwindow* window, int entered) +{ + ImGui_ImplGlfw_Data* bd = ImGui_ImplGlfw_GetBackendData(); + if (bd->PrevUserCallbackCursorEnter != NULL && window == bd->Window) + bd->PrevUserCallbackCursorEnter(window, entered); + + if (entered) + bd->MouseWindow = window; + if (!entered && bd->MouseWindow == window) + bd->MouseWindow = NULL; +} + +void ImGui_ImplGlfw_CharCallback(GLFWwindow* window, unsigned int c) +{ + ImGui_ImplGlfw_Data* bd = ImGui_ImplGlfw_GetBackendData(); + if (bd->PrevUserCallbackChar != NULL && window == bd->Window) + bd->PrevUserCallbackChar(window, c); + + ImGuiIO& io = ImGui::GetIO(); + io.AddInputCharacter(c); +} + +void ImGui_ImplGlfw_MonitorCallback(GLFWmonitor*, int) +{ + // Unused in 'master' branch but 'docking' branch will use this, so we declare it ahead of it so if you have to install callbacks you can install this one too. +} + +static bool ImGui_ImplGlfw_Init(GLFWwindow* window, bool install_callbacks, GlfwClientApi client_api) +{ + ImGuiIO& io = ImGui::GetIO(); + IM_ASSERT(io.BackendPlatformUserData == NULL && "Already initialized a platform backend!"); + + // Setup backend capabilities flags + ImGui_ImplGlfw_Data* bd = IM_NEW(ImGui_ImplGlfw_Data)(); + io.BackendPlatformUserData = (void*)bd; + io.BackendPlatformName = "imgui_impl_glfw"; + io.BackendFlags |= ImGuiBackendFlags_HasMouseCursors; // We can honor GetMouseCursor() values (optional) + io.BackendFlags |= ImGuiBackendFlags_HasSetMousePos; // We can honor io.WantSetMousePos requests (optional, rarely used) + + bd->Window = window; + bd->Time = 0.0; + + // Keyboard mapping. Dear ImGui will use those indices to peek into the io.KeysDown[] array. + io.KeyMap[ImGuiKey_Tab] = GLFW_KEY_TAB; + io.KeyMap[ImGuiKey_LeftArrow] = GLFW_KEY_LEFT; + io.KeyMap[ImGuiKey_RightArrow] = GLFW_KEY_RIGHT; + io.KeyMap[ImGuiKey_UpArrow] = GLFW_KEY_UP; + io.KeyMap[ImGuiKey_DownArrow] = GLFW_KEY_DOWN; + io.KeyMap[ImGuiKey_PageUp] = GLFW_KEY_PAGE_UP; + io.KeyMap[ImGuiKey_PageDown] = GLFW_KEY_PAGE_DOWN; + io.KeyMap[ImGuiKey_Home] = GLFW_KEY_HOME; + io.KeyMap[ImGuiKey_End] = GLFW_KEY_END; + io.KeyMap[ImGuiKey_Insert] = GLFW_KEY_INSERT; + io.KeyMap[ImGuiKey_Delete] = GLFW_KEY_DELETE; + io.KeyMap[ImGuiKey_Backspace] = GLFW_KEY_BACKSPACE; + io.KeyMap[ImGuiKey_Space] = GLFW_KEY_SPACE; + io.KeyMap[ImGuiKey_Enter] = GLFW_KEY_ENTER; + io.KeyMap[ImGuiKey_Escape] = GLFW_KEY_ESCAPE; + io.KeyMap[ImGuiKey_KeyPadEnter] = GLFW_KEY_KP_ENTER; + io.KeyMap[ImGuiKey_A] = GLFW_KEY_A; + io.KeyMap[ImGuiKey_C] = GLFW_KEY_C; + io.KeyMap[ImGuiKey_V] = GLFW_KEY_V; + io.KeyMap[ImGuiKey_X] = GLFW_KEY_X; + io.KeyMap[ImGuiKey_Y] = GLFW_KEY_Y; + io.KeyMap[ImGuiKey_Z] = GLFW_KEY_Z; + + io.SetClipboardTextFn = ImGui_ImplGlfw_SetClipboardText; + io.GetClipboardTextFn = ImGui_ImplGlfw_GetClipboardText; + io.ClipboardUserData = bd->Window; +#if defined(_WIN32) + io.ImeWindowHandle = (void*)glfwGetWin32Window(bd->Window); +#endif + + // Create mouse cursors + // (By design, on X11 cursors are user configurable and some cursors may be missing. When a cursor doesn't exist, + // GLFW will emit an error which will often be printed by the app, so we temporarily disable error reporting. + // Missing cursors will return NULL and our _UpdateMouseCursor() function will use the Arrow cursor instead.) + GLFWerrorfun prev_error_callback = glfwSetErrorCallback(NULL); + bd->MouseCursors[ImGuiMouseCursor_Arrow] = glfwCreateStandardCursor(GLFW_ARROW_CURSOR); + bd->MouseCursors[ImGuiMouseCursor_TextInput] = glfwCreateStandardCursor(GLFW_IBEAM_CURSOR); + bd->MouseCursors[ImGuiMouseCursor_ResizeNS] = glfwCreateStandardCursor(GLFW_VRESIZE_CURSOR); + bd->MouseCursors[ImGuiMouseCursor_ResizeEW] = glfwCreateStandardCursor(GLFW_HRESIZE_CURSOR); + bd->MouseCursors[ImGuiMouseCursor_Hand] = glfwCreateStandardCursor(GLFW_HAND_CURSOR); +#if GLFW_HAS_NEW_CURSORS + bd->MouseCursors[ImGuiMouseCursor_ResizeAll] = glfwCreateStandardCursor(GLFW_RESIZE_ALL_CURSOR); + bd->MouseCursors[ImGuiMouseCursor_ResizeNESW] = glfwCreateStandardCursor(GLFW_RESIZE_NESW_CURSOR); + bd->MouseCursors[ImGuiMouseCursor_ResizeNWSE] = glfwCreateStandardCursor(GLFW_RESIZE_NWSE_CURSOR); + bd->MouseCursors[ImGuiMouseCursor_NotAllowed] = glfwCreateStandardCursor(GLFW_NOT_ALLOWED_CURSOR); +#else + bd->MouseCursors[ImGuiMouseCursor_ResizeAll] = glfwCreateStandardCursor(GLFW_ARROW_CURSOR); + bd->MouseCursors[ImGuiMouseCursor_ResizeNESW] = glfwCreateStandardCursor(GLFW_ARROW_CURSOR); + bd->MouseCursors[ImGuiMouseCursor_ResizeNWSE] = glfwCreateStandardCursor(GLFW_ARROW_CURSOR); + bd->MouseCursors[ImGuiMouseCursor_NotAllowed] = glfwCreateStandardCursor(GLFW_ARROW_CURSOR); +#endif + glfwSetErrorCallback(prev_error_callback); + + // Chain GLFW callbacks: our callbacks will call the user's previously installed callbacks, if any. + bd->PrevUserCallbackWindowFocus = NULL; + bd->PrevUserCallbackMousebutton = NULL; + bd->PrevUserCallbackScroll = NULL; + bd->PrevUserCallbackKey = NULL; + bd->PrevUserCallbackChar = NULL; + bd->PrevUserCallbackMonitor = NULL; + if (install_callbacks) + { + bd->InstalledCallbacks = true; + bd->PrevUserCallbackWindowFocus = glfwSetWindowFocusCallback(window, ImGui_ImplGlfw_WindowFocusCallback); + bd->PrevUserCallbackCursorEnter = glfwSetCursorEnterCallback(window, ImGui_ImplGlfw_CursorEnterCallback); + bd->PrevUserCallbackMousebutton = glfwSetMouseButtonCallback(window, ImGui_ImplGlfw_MouseButtonCallback); + bd->PrevUserCallbackScroll = glfwSetScrollCallback(window, ImGui_ImplGlfw_ScrollCallback); + bd->PrevUserCallbackKey = glfwSetKeyCallback(window, ImGui_ImplGlfw_KeyCallback); + bd->PrevUserCallbackChar = glfwSetCharCallback(window, ImGui_ImplGlfw_CharCallback); + bd->PrevUserCallbackMonitor = glfwSetMonitorCallback(ImGui_ImplGlfw_MonitorCallback); + } + + bd->ClientApi = client_api; + return true; +} + +bool ImGui_ImplGlfw_InitForOpenGL(GLFWwindow* window, bool install_callbacks) +{ + return ImGui_ImplGlfw_Init(window, install_callbacks, GlfwClientApi_OpenGL); +} + +bool ImGui_ImplGlfw_InitForVulkan(GLFWwindow* window, bool install_callbacks) +{ + return ImGui_ImplGlfw_Init(window, install_callbacks, GlfwClientApi_Vulkan); +} + +bool ImGui_ImplGlfw_InitForOther(GLFWwindow* window, bool install_callbacks) +{ + return ImGui_ImplGlfw_Init(window, install_callbacks, GlfwClientApi_Unknown); +} + +void ImGui_ImplGlfw_Shutdown() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplGlfw_Data* bd = ImGui_ImplGlfw_GetBackendData(); + + if (bd->InstalledCallbacks) + { + glfwSetWindowFocusCallback(bd->Window, bd->PrevUserCallbackWindowFocus); + glfwSetCursorEnterCallback(bd->Window, bd->PrevUserCallbackCursorEnter); + glfwSetMouseButtonCallback(bd->Window, bd->PrevUserCallbackMousebutton); + glfwSetScrollCallback(bd->Window, bd->PrevUserCallbackScroll); + glfwSetKeyCallback(bd->Window, bd->PrevUserCallbackKey); + glfwSetCharCallback(bd->Window, bd->PrevUserCallbackChar); + glfwSetMonitorCallback(bd->PrevUserCallbackMonitor); + } + + for (ImGuiMouseCursor cursor_n = 0; cursor_n < ImGuiMouseCursor_COUNT; cursor_n++) + glfwDestroyCursor(bd->MouseCursors[cursor_n]); + + io.BackendPlatformName = NULL; + io.BackendPlatformUserData = NULL; + IM_DELETE(bd); +} + +static void ImGui_ImplGlfw_UpdateMousePosAndButtons() +{ + ImGui_ImplGlfw_Data* bd = ImGui_ImplGlfw_GetBackendData(); + ImGuiIO& io = ImGui::GetIO(); + + const ImVec2 mouse_pos_prev = io.MousePos; + io.MousePos = ImVec2(-FLT_MAX, -FLT_MAX); + + // Update mouse buttons + // (if a mouse press event came, always pass it as "mouse held this frame", so we don't miss click-release events that are shorter than 1 frame) + for (int i = 0; i < IM_ARRAYSIZE(io.MouseDown); i++) + { + io.MouseDown[i] = bd->MouseJustPressed[i] || glfwGetMouseButton(bd->Window, i) != 0; + bd->MouseJustPressed[i] = false; + } + +#ifdef __EMSCRIPTEN__ + const bool focused = true; +#else + const bool focused = glfwGetWindowAttrib(bd->Window, GLFW_FOCUSED) != 0; +#endif + GLFWwindow* mouse_window = (bd->MouseWindow == bd->Window || focused) ? bd->Window : NULL; + + // Set OS mouse position from Dear ImGui if requested (rarely used, only when ImGuiConfigFlags_NavEnableSetMousePos is enabled by user) + if (io.WantSetMousePos && focused) + glfwSetCursorPos(bd->Window, (double)mouse_pos_prev.x, (double)mouse_pos_prev.y); + + // Set Dear ImGui mouse position from OS position + if (mouse_window != NULL) + { + double mouse_x, mouse_y; + glfwGetCursorPos(mouse_window, &mouse_x, &mouse_y); + io.MousePos = ImVec2((float)mouse_x, (float)mouse_y); + } +} + +static void ImGui_ImplGlfw_UpdateMouseCursor() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplGlfw_Data* bd = ImGui_ImplGlfw_GetBackendData(); + if ((io.ConfigFlags & ImGuiConfigFlags_NoMouseCursorChange) || glfwGetInputMode(bd->Window, GLFW_CURSOR) == GLFW_CURSOR_DISABLED) + return; + + ImGuiMouseCursor imgui_cursor = ImGui::GetMouseCursor(); + if (imgui_cursor == ImGuiMouseCursor_None || io.MouseDrawCursor) + { + // Hide OS mouse cursor if imgui is drawing it or if it wants no cursor + glfwSetInputMode(bd->Window, GLFW_CURSOR, GLFW_CURSOR_HIDDEN); + } + else + { + // Show OS mouse cursor + // FIXME-PLATFORM: Unfocused windows seems to fail changing the mouse cursor with GLFW 3.2, but 3.3 works here. + glfwSetCursor(bd->Window, bd->MouseCursors[imgui_cursor] ? bd->MouseCursors[imgui_cursor] : bd->MouseCursors[ImGuiMouseCursor_Arrow]); + glfwSetInputMode(bd->Window, GLFW_CURSOR, GLFW_CURSOR_NORMAL); + } +} + +static void ImGui_ImplGlfw_UpdateGamepads() +{ + ImGuiIO& io = ImGui::GetIO(); + memset(io.NavInputs, 0, sizeof(io.NavInputs)); + if ((io.ConfigFlags & ImGuiConfigFlags_NavEnableGamepad) == 0) + return; + + // Update gamepad inputs + #define MAP_BUTTON(NAV_NO, BUTTON_NO) { if (buttons_count > BUTTON_NO && buttons[BUTTON_NO] == GLFW_PRESS) io.NavInputs[NAV_NO] = 1.0f; } + #define MAP_ANALOG(NAV_NO, AXIS_NO, V0, V1) { float v = (axes_count > AXIS_NO) ? axes[AXIS_NO] : V0; v = (v - V0) / (V1 - V0); if (v > 1.0f) v = 1.0f; if (io.NavInputs[NAV_NO] < v) io.NavInputs[NAV_NO] = v; } + int axes_count = 0, buttons_count = 0; + const float* axes = glfwGetJoystickAxes(GLFW_JOYSTICK_1, &axes_count); + const unsigned char* buttons = glfwGetJoystickButtons(GLFW_JOYSTICK_1, &buttons_count); + MAP_BUTTON(ImGuiNavInput_Activate, 0); // Cross / A + MAP_BUTTON(ImGuiNavInput_Cancel, 1); // Circle / B + MAP_BUTTON(ImGuiNavInput_Menu, 2); // Square / X + MAP_BUTTON(ImGuiNavInput_Input, 3); // Triangle / Y + MAP_BUTTON(ImGuiNavInput_DpadLeft, 13); // D-Pad Left + MAP_BUTTON(ImGuiNavInput_DpadRight, 11); // D-Pad Right + MAP_BUTTON(ImGuiNavInput_DpadUp, 10); // D-Pad Up + MAP_BUTTON(ImGuiNavInput_DpadDown, 12); // D-Pad Down + MAP_BUTTON(ImGuiNavInput_FocusPrev, 4); // L1 / LB + MAP_BUTTON(ImGuiNavInput_FocusNext, 5); // R1 / RB + MAP_BUTTON(ImGuiNavInput_TweakSlow, 4); // L1 / LB + MAP_BUTTON(ImGuiNavInput_TweakFast, 5); // R1 / RB + MAP_ANALOG(ImGuiNavInput_LStickLeft, 0, -0.3f, -0.9f); + MAP_ANALOG(ImGuiNavInput_LStickRight,0, +0.3f, +0.9f); + MAP_ANALOG(ImGuiNavInput_LStickUp, 1, +0.3f, +0.9f); + MAP_ANALOG(ImGuiNavInput_LStickDown, 1, -0.3f, -0.9f); + #undef MAP_BUTTON + #undef MAP_ANALOG + if (axes_count > 0 && buttons_count > 0) + io.BackendFlags |= ImGuiBackendFlags_HasGamepad; + else + io.BackendFlags &= ~ImGuiBackendFlags_HasGamepad; +} + +void ImGui_ImplGlfw_NewFrame() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplGlfw_Data* bd = ImGui_ImplGlfw_GetBackendData(); + IM_ASSERT(bd != NULL && "Did you call ImGui_ImplGlfw_InitForXXX()?"); + + // Setup display size (every frame to accommodate for window resizing) + int w, h; + int display_w, display_h; + glfwGetWindowSize(bd->Window, &w, &h); + glfwGetFramebufferSize(bd->Window, &display_w, &display_h); + io.DisplaySize = ImVec2((float)w, (float)h); + if (w > 0 && h > 0) + io.DisplayFramebufferScale = ImVec2((float)display_w / w, (float)display_h / h); + + // Setup time step + double current_time = glfwGetTime(); + io.DeltaTime = bd->Time > 0.0 ? (float)(current_time - bd->Time) : (float)(1.0f / 60.0f); + bd->Time = current_time; + + ImGui_ImplGlfw_UpdateMousePosAndButtons(); + ImGui_ImplGlfw_UpdateMouseCursor(); + + // Update game controllers (if enabled and available) + ImGui_ImplGlfw_UpdateGamepads(); +} diff --git a/source/editor/imgui/backends/imgui_impl_glfw.h b/source/editor/imgui/backends/imgui_impl_glfw.h new file mode 100644 index 0000000..5e1fb06 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_glfw.h @@ -0,0 +1,41 @@ +// dear imgui: Platform Backend for GLFW +// This needs to be used along with a Renderer (e.g. OpenGL3, Vulkan, WebGPU..) +// (Info: GLFW is a cross-platform general purpose library for handling windows, inputs, OpenGL/Vulkan graphics context creation, etc.) + +// Implemented features: +// [X] Platform: Clipboard support. +// [X] Platform: Gamepad support. Enable with 'io.ConfigFlags |= ImGuiConfigFlags_NavEnableGamepad'. +// [x] Platform: Mouse cursor shape and visibility. Disable with 'io.ConfigFlags |= ImGuiConfigFlags_NoMouseCursorChange'. FIXME: 3 cursors types are missing from GLFW. +// [X] Platform: Keyboard arrays indexed using GLFW_KEY_* codes, e.g. ImGui::IsKeyPressed(GLFW_KEY_SPACE). + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// About GLSL version: +// The 'glsl_version' initialization parameter defaults to "#version 150" if NULL. +// Only override if your GL version doesn't handle this GLSL version. Keep NULL if unsure! + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +struct GLFWwindow; +struct GLFWmonitor; + +IMGUI_IMPL_API bool ImGui_ImplGlfw_InitForOpenGL(GLFWwindow* window, bool install_callbacks); +IMGUI_IMPL_API bool ImGui_ImplGlfw_InitForVulkan(GLFWwindow* window, bool install_callbacks); +IMGUI_IMPL_API bool ImGui_ImplGlfw_InitForOther(GLFWwindow* window, bool install_callbacks); +IMGUI_IMPL_API void ImGui_ImplGlfw_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplGlfw_NewFrame(); + +// GLFW callbacks +// - When calling Init with 'install_callbacks=true': GLFW callbacks will be installed for you. They will call user's previously installed callbacks, if any. +// - When calling Init with 'install_callbacks=false': GLFW callbacks won't be installed. You will need to call those function yourself from your own GLFW callbacks. +IMGUI_IMPL_API void ImGui_ImplGlfw_WindowFocusCallback(GLFWwindow* window, int focused); +IMGUI_IMPL_API void ImGui_ImplGlfw_CursorEnterCallback(GLFWwindow* window, int entered); +IMGUI_IMPL_API void ImGui_ImplGlfw_MouseButtonCallback(GLFWwindow* window, int button, int action, int mods); +IMGUI_IMPL_API void ImGui_ImplGlfw_ScrollCallback(GLFWwindow* window, double xoffset, double yoffset); +IMGUI_IMPL_API void ImGui_ImplGlfw_KeyCallback(GLFWwindow* window, int key, int scancode, int action, int mods); +IMGUI_IMPL_API void ImGui_ImplGlfw_CharCallback(GLFWwindow* window, unsigned int c); +IMGUI_IMPL_API void ImGui_ImplGlfw_MonitorCallback(GLFWmonitor* monitor, int event); diff --git a/source/editor/imgui/backends/imgui_impl_glut.cpp b/source/editor/imgui/backends/imgui_impl_glut.cpp new file mode 100644 index 0000000..85bea77 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_glut.cpp @@ -0,0 +1,217 @@ +// dear imgui: Platform Backend for GLUT/FreeGLUT +// This needs to be used along with a Renderer (e.g. OpenGL2) + +// !!! GLUT/FreeGLUT IS OBSOLETE PREHISTORIC SOFTWARE. Using GLUT is not recommended unless you really miss the 90's. !!! +// !!! If someone or something is teaching you GLUT today, you are being abused. Please show some resistance. !!! +// !!! Nowadays, prefer using GLFW or SDL instead! + +// Issues: +// [ ] Platform: GLUT is unable to distinguish e.g. Backspace from CTRL+H or TAB from CTRL+I +// [ ] Platform: Missing mouse cursor shape/visibility support. +// [ ] Platform: Missing clipboard support (not supported by Glut). +// [ ] Platform: Missing gamepad support. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2019-04-03: Misc: Renamed imgui_impl_freeglut.cpp/.h to imgui_impl_glut.cpp/.h. +// 2019-03-25: Misc: Made io.DeltaTime always above zero. +// 2018-11-30: Misc: Setting up io.BackendPlatformName so it can be displayed in the About Window. +// 2018-03-22: Added GLUT Platform binding. + +#include "imgui.h" +#include "imgui_impl_glut.h" +#ifdef __APPLE__ +#include +#else +#include +#endif + +#ifdef _MSC_VER +#pragma warning (disable: 4505) // unreferenced local function has been removed (stb stuff) +#endif + +static int g_Time = 0; // Current time, in milliseconds + +bool ImGui_ImplGLUT_Init() +{ + ImGuiIO& io = ImGui::GetIO(); + +#ifdef FREEGLUT + io.BackendPlatformName = "imgui_impl_glut (freeglut)"; +#else + io.BackendPlatformName = "imgui_impl_glut"; +#endif + + g_Time = 0; + + // Glut has 1 function for characters and one for "special keys". We map the characters in the 0..255 range and the keys above. + io.KeyMap[ImGuiKey_Tab] = '\t'; // == 9 == CTRL+I + io.KeyMap[ImGuiKey_LeftArrow] = 256 + GLUT_KEY_LEFT; + io.KeyMap[ImGuiKey_RightArrow] = 256 + GLUT_KEY_RIGHT; + io.KeyMap[ImGuiKey_UpArrow] = 256 + GLUT_KEY_UP; + io.KeyMap[ImGuiKey_DownArrow] = 256 + GLUT_KEY_DOWN; + io.KeyMap[ImGuiKey_PageUp] = 256 + GLUT_KEY_PAGE_UP; + io.KeyMap[ImGuiKey_PageDown] = 256 + GLUT_KEY_PAGE_DOWN; + io.KeyMap[ImGuiKey_Home] = 256 + GLUT_KEY_HOME; + io.KeyMap[ImGuiKey_End] = 256 + GLUT_KEY_END; + io.KeyMap[ImGuiKey_Insert] = 256 + GLUT_KEY_INSERT; + io.KeyMap[ImGuiKey_Delete] = 127; + io.KeyMap[ImGuiKey_Backspace] = 8; // == CTRL+H + io.KeyMap[ImGuiKey_Space] = ' '; + io.KeyMap[ImGuiKey_Enter] = 13; // == CTRL+M + io.KeyMap[ImGuiKey_Escape] = 27; + io.KeyMap[ImGuiKey_KeyPadEnter] = 13; // == CTRL+M + io.KeyMap[ImGuiKey_A] = 'A'; + io.KeyMap[ImGuiKey_C] = 'C'; + io.KeyMap[ImGuiKey_V] = 'V'; + io.KeyMap[ImGuiKey_X] = 'X'; + io.KeyMap[ImGuiKey_Y] = 'Y'; + io.KeyMap[ImGuiKey_Z] = 'Z'; + + return true; +} + +void ImGui_ImplGLUT_InstallFuncs() +{ + glutReshapeFunc(ImGui_ImplGLUT_ReshapeFunc); + glutMotionFunc(ImGui_ImplGLUT_MotionFunc); + glutPassiveMotionFunc(ImGui_ImplGLUT_MotionFunc); + glutMouseFunc(ImGui_ImplGLUT_MouseFunc); +#ifdef __FREEGLUT_EXT_H__ + glutMouseWheelFunc(ImGui_ImplGLUT_MouseWheelFunc); +#endif + glutKeyboardFunc(ImGui_ImplGLUT_KeyboardFunc); + glutKeyboardUpFunc(ImGui_ImplGLUT_KeyboardUpFunc); + glutSpecialFunc(ImGui_ImplGLUT_SpecialFunc); + glutSpecialUpFunc(ImGui_ImplGLUT_SpecialUpFunc); +} + +void ImGui_ImplGLUT_Shutdown() +{ +} + +void ImGui_ImplGLUT_NewFrame() +{ + // Setup time step + ImGuiIO& io = ImGui::GetIO(); + int current_time = glutGet(GLUT_ELAPSED_TIME); + int delta_time_ms = (current_time - g_Time); + if (delta_time_ms <= 0) + delta_time_ms = 1; + io.DeltaTime = delta_time_ms / 1000.0f; + g_Time = current_time; + + // Start the frame + ImGui::NewFrame(); +} + +static void ImGui_ImplGLUT_UpdateKeyboardMods() +{ + ImGuiIO& io = ImGui::GetIO(); + int mods = glutGetModifiers(); + io.KeyCtrl = (mods & GLUT_ACTIVE_CTRL) != 0; + io.KeyShift = (mods & GLUT_ACTIVE_SHIFT) != 0; + io.KeyAlt = (mods & GLUT_ACTIVE_ALT) != 0; +} + +void ImGui_ImplGLUT_KeyboardFunc(unsigned char c, int x, int y) +{ + // Send character to imgui + //printf("char_down_func %d '%c'\n", c, c); + ImGuiIO& io = ImGui::GetIO(); + if (c >= 32) + io.AddInputCharacter((unsigned int)c); + + // Store letters in KeysDown[] array as both uppercase and lowercase + Handle GLUT translating CTRL+A..CTRL+Z as 1..26. + // This is a hacky mess but GLUT is unable to distinguish e.g. a TAB key from CTRL+I so this is probably the best we can do here. + if (c >= 1 && c <= 26) + io.KeysDown[c] = io.KeysDown[c - 1 + 'a'] = io.KeysDown[c - 1 + 'A'] = true; + else if (c >= 'a' && c <= 'z') + io.KeysDown[c] = io.KeysDown[c - 'a' + 'A'] = true; + else if (c >= 'A' && c <= 'Z') + io.KeysDown[c] = io.KeysDown[c - 'A' + 'a'] = true; + else + io.KeysDown[c] = true; + ImGui_ImplGLUT_UpdateKeyboardMods(); + (void)x; (void)y; // Unused +} + +void ImGui_ImplGLUT_KeyboardUpFunc(unsigned char c, int x, int y) +{ + //printf("char_up_func %d '%c'\n", c, c); + ImGuiIO& io = ImGui::GetIO(); + if (c >= 1 && c <= 26) + io.KeysDown[c] = io.KeysDown[c - 1 + 'a'] = io.KeysDown[c - 1 + 'A'] = false; + else if (c >= 'a' && c <= 'z') + io.KeysDown[c] = io.KeysDown[c - 'a' + 'A'] = false; + else if (c >= 'A' && c <= 'Z') + io.KeysDown[c] = io.KeysDown[c - 'A' + 'a'] = false; + else + io.KeysDown[c] = false; + ImGui_ImplGLUT_UpdateKeyboardMods(); + (void)x; (void)y; // Unused +} + +void ImGui_ImplGLUT_SpecialFunc(int key, int x, int y) +{ + //printf("key_down_func %d\n", key); + ImGuiIO& io = ImGui::GetIO(); + if (key + 256 < IM_ARRAYSIZE(io.KeysDown)) + io.KeysDown[key + 256] = true; + ImGui_ImplGLUT_UpdateKeyboardMods(); + (void)x; (void)y; // Unused +} + +void ImGui_ImplGLUT_SpecialUpFunc(int key, int x, int y) +{ + //printf("key_up_func %d\n", key); + ImGuiIO& io = ImGui::GetIO(); + if (key + 256 < IM_ARRAYSIZE(io.KeysDown)) + io.KeysDown[key + 256] = false; + ImGui_ImplGLUT_UpdateKeyboardMods(); + (void)x; (void)y; // Unused +} + +void ImGui_ImplGLUT_MouseFunc(int glut_button, int state, int x, int y) +{ + ImGuiIO& io = ImGui::GetIO(); + io.MousePos = ImVec2((float)x, (float)y); + int button = -1; + if (glut_button == GLUT_LEFT_BUTTON) button = 0; + if (glut_button == GLUT_RIGHT_BUTTON) button = 1; + if (glut_button == GLUT_MIDDLE_BUTTON) button = 2; + if (button != -1 && state == GLUT_DOWN) + io.MouseDown[button] = true; + if (button != -1 && state == GLUT_UP) + io.MouseDown[button] = false; +} + +#ifdef __FREEGLUT_EXT_H__ +void ImGui_ImplGLUT_MouseWheelFunc(int button, int dir, int x, int y) +{ + ImGuiIO& io = ImGui::GetIO(); + io.MousePos = ImVec2((float)x, (float)y); + if (dir > 0) + io.MouseWheel += 1.0; + else if (dir < 0) + io.MouseWheel -= 1.0; + (void)button; // Unused +} +#endif + +void ImGui_ImplGLUT_ReshapeFunc(int w, int h) +{ + ImGuiIO& io = ImGui::GetIO(); + io.DisplaySize = ImVec2((float)w, (float)h); +} + +void ImGui_ImplGLUT_MotionFunc(int x, int y) +{ + ImGuiIO& io = ImGui::GetIO(); + io.MousePos = ImVec2((float)x, (float)y); +} diff --git a/source/editor/imgui/backends/imgui_impl_glut.h b/source/editor/imgui/backends/imgui_impl_glut.h new file mode 100644 index 0000000..96c779f --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_glut.h @@ -0,0 +1,37 @@ +// dear imgui: Platform Backend for GLUT/FreeGLUT +// This needs to be used along with a Renderer (e.g. OpenGL2) + +// !!! GLUT/FreeGLUT IS OBSOLETE PREHISTORIC SOFTWARE. Using GLUT is not recommended unless you really miss the 90's. !!! +// !!! If someone or something is teaching you GLUT today, you are being abused. Please show some resistance. !!! +// !!! Nowadays, prefer using GLFW or SDL instead! + +// Issues: +// [ ] Platform: GLUT is unable to distinguish e.g. Backspace from CTRL+H or TAB from CTRL+I +// [ ] Platform: Missing mouse cursor shape/visibility support. +// [ ] Platform: Missing clipboard support (not supported by Glut). +// [ ] Platform: Missing gamepad support. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +IMGUI_IMPL_API bool ImGui_ImplGLUT_Init(); +IMGUI_IMPL_API void ImGui_ImplGLUT_InstallFuncs(); +IMGUI_IMPL_API void ImGui_ImplGLUT_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplGLUT_NewFrame(); + +// You can call ImGui_ImplGLUT_InstallFuncs() to get all those functions installed automatically, +// or call them yourself from your own GLUT handlers. We are using the same weird names as GLUT for consistency.. +//---------------------------------------- GLUT name --------------------------------------------- Decent Name --------- +IMGUI_IMPL_API void ImGui_ImplGLUT_ReshapeFunc(int w, int h); // ~ ResizeFunc +IMGUI_IMPL_API void ImGui_ImplGLUT_MotionFunc(int x, int y); // ~ MouseMoveFunc +IMGUI_IMPL_API void ImGui_ImplGLUT_MouseFunc(int button, int state, int x, int y); // ~ MouseButtonFunc +IMGUI_IMPL_API void ImGui_ImplGLUT_MouseWheelFunc(int button, int dir, int x, int y); // ~ MouseWheelFunc +IMGUI_IMPL_API void ImGui_ImplGLUT_KeyboardFunc(unsigned char c, int x, int y); // ~ CharPressedFunc +IMGUI_IMPL_API void ImGui_ImplGLUT_KeyboardUpFunc(unsigned char c, int x, int y); // ~ CharReleasedFunc +IMGUI_IMPL_API void ImGui_ImplGLUT_SpecialFunc(int key, int x, int y); // ~ KeyPressedFunc +IMGUI_IMPL_API void ImGui_ImplGLUT_SpecialUpFunc(int key, int x, int y); // ~ KeyReleasedFunc diff --git a/source/editor/imgui/backends/imgui_impl_marmalade.cpp b/source/editor/imgui/backends/imgui_impl_marmalade.cpp new file mode 100644 index 0000000..aa6b320 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_marmalade.cpp @@ -0,0 +1,318 @@ +// dear imgui: Renderer + Platform Backend for Marmalade + IwGx +// Marmalade code: Copyright (C) 2015 by Giovanni Zito (this file is part of Dear ImGui) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'CIwTexture*' as ImTextureID. Read the FAQ about ImTextureID! +// Missing features: +// [ ] Renderer: Clipping rectangles are not honored. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-05-19: Renderer: Replaced direct access to ImDrawCmd::TextureId with a call to ImDrawCmd::GetTexID(). (will become a requirement) +// 2019-07-21: Inputs: Added mapping for ImGuiKey_KeyPadEnter. +// 2019-05-11: Inputs: Don't filter value from character callback before calling AddInputCharacter(). +// 2018-11-30: Misc: Setting up io.BackendPlatformName/io.BackendRendererName so they can be displayed in the About Window. +// 2018-02-16: Misc: Obsoleted the io.RenderDrawListsFn callback and exposed ImGui_Marmalade_RenderDrawData() in the .h file so you can call it yourself. +// 2018-02-06: Misc: Removed call to ImGui::Shutdown() which is not available from 1.60 WIP, user needs to call CreateContext/DestroyContext themselves. +// 2018-02-06: Inputs: Added mapping for ImGuiKey_Space. + +#include "imgui.h" +#include "imgui_impl_marmalade.h" + +#include +#include +#include +#include +#include + +// Data +static double g_Time = 0.0f; +static bool g_MousePressed[3] = { false, false, false }; +static CIwTexture* g_FontTexture = NULL; +static char* g_ClipboardText = NULL; +static bool g_osdKeyboardEnabled = false; + +// use this setting to scale the interface - e.g. on device you could use 2 or 3 scale factor +static ImVec2 g_RenderScale = ImVec2(1.0f, 1.0f); + +// Render function. +void ImGui_Marmalade_RenderDrawData(ImDrawData* draw_data) +{ + // Avoid rendering when minimized + if (draw_data->DisplaySize.x <= 0.0f || draw_data->DisplaySize.y <= 0.0f) + return; + + // Render command lists + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + const ImDrawIdx* idx_buffer = cmd_list->IdxBuffer.Data; + const int nVert = cmd_list->VtxBuffer.Size; + CIwFVec2* pVertStream = IW_GX_ALLOC(CIwFVec2, nVert); + CIwFVec2* pUVStream = IW_GX_ALLOC(CIwFVec2, nVert); + CIwColour* pColStream = IW_GX_ALLOC(CIwColour, nVert); + + for (int i = 0; i < nVert; i++) + { + // FIXME-OPT: optimize multiplication on GPU using vertex shader/projection matrix. + pVertStream[i].x = cmd_list->VtxBuffer[i].pos.x * g_RenderScale.x; + pVertStream[i].y = cmd_list->VtxBuffer[i].pos.y * g_RenderScale.y; + pUVStream[i].x = cmd_list->VtxBuffer[i].uv.x; + pUVStream[i].y = cmd_list->VtxBuffer[i].uv.y; + pColStream[i] = cmd_list->VtxBuffer[i].col; + } + + IwGxSetVertStreamScreenSpace(pVertStream, nVert); + IwGxSetUVStream(pUVStream); + IwGxSetColStream(pColStream, nVert); + IwGxSetNormStream(0); + + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + const ImDrawCmd* pcmd = &cmd_list->CmdBuffer[cmd_i]; + if (pcmd->UserCallback) + { + pcmd->UserCallback(cmd_list, pcmd); + } + else + { + // FIXME: Not honoring ClipRect fields. + CIwMaterial* pCurrentMaterial = IW_GX_ALLOC_MATERIAL(); + pCurrentMaterial->SetShadeMode(CIwMaterial::SHADE_FLAT); + pCurrentMaterial->SetCullMode(CIwMaterial::CULL_NONE); + pCurrentMaterial->SetFiltering(false); + pCurrentMaterial->SetAlphaMode(CIwMaterial::ALPHA_BLEND); + pCurrentMaterial->SetDepthWriteMode(CIwMaterial::DEPTH_WRITE_NORMAL); + pCurrentMaterial->SetAlphaTestMode(CIwMaterial::ALPHATEST_DISABLED); + pCurrentMaterial->SetTexture((CIwTexture*)pcmd->GetTexID()); + IwGxSetMaterial(pCurrentMaterial); + IwGxDrawPrims(IW_GX_TRI_LIST, (uint16*)idx_buffer, pcmd->ElemCount); + } + idx_buffer += pcmd->ElemCount; + } + IwGxFlush(); + } + + // TODO: restore modified state (i.e. mvp matrix) +} + +static const char* ImGui_Marmalade_GetClipboardText(void* /*user_data*/) +{ + if (!s3eClipboardAvailable()) + return NULL; + + if (int size = s3eClipboardGetText(NULL, 0)) + { + if (g_ClipboardText) + delete[] g_ClipboardText; + g_ClipboardText = new char[size]; + g_ClipboardText[0] = '\0'; + s3eClipboardGetText(g_ClipboardText, size); + } + + return g_ClipboardText; +} + +static void ImGui_Marmalade_SetClipboardText(void* /*user_data*/, const char* text) +{ + if (s3eClipboardAvailable()) + s3eClipboardSetText(text); +} + +int32 ImGui_Marmalade_PointerButtonEventCallback(void* system_data, void* user_data) +{ + // pEvent->m_Button is of type s3ePointerButton and indicates which mouse + // button was pressed. For touchscreen this should always have the value + // S3E_POINTER_BUTTON_SELECT + s3ePointerEvent* pEvent = (s3ePointerEvent*)system_data; + + if (pEvent->m_Pressed == 1) + { + if (pEvent->m_Button == S3E_POINTER_BUTTON_LEFTMOUSE) + g_MousePressed[0] = true; + if (pEvent->m_Button == S3E_POINTER_BUTTON_RIGHTMOUSE) + g_MousePressed[1] = true; + if (pEvent->m_Button == S3E_POINTER_BUTTON_MIDDLEMOUSE) + g_MousePressed[2] = true; + if (pEvent->m_Button == S3E_POINTER_BUTTON_MOUSEWHEELUP) + io.MouseWheel += pEvent->m_y; + if (pEvent->m_Button == S3E_POINTER_BUTTON_MOUSEWHEELDOWN) + io.MouseWheel += pEvent->m_y; + } + + return 0; +} + +int32 ImGui_Marmalade_KeyCallback(void* system_data, void* user_data) +{ + ImGuiIO& io = ImGui::GetIO(); + s3eKeyboardEvent* e = (s3eKeyboardEvent*)system_data; + if (e->m_Pressed == 1) + io.KeysDown[e->m_Key] = true; + if (e->m_Pressed == 0) + io.KeysDown[e->m_Key] = false; + + io.KeyCtrl = s3eKeyboardGetState(s3eKeyLeftControl) == S3E_KEY_STATE_DOWN || s3eKeyboardGetState(s3eKeyRightControl) == S3E_KEY_STATE_DOWN; + io.KeyShift = s3eKeyboardGetState(s3eKeyLeftShift) == S3E_KEY_STATE_DOWN || s3eKeyboardGetState(s3eKeyRightShift) == S3E_KEY_STATE_DOWN; + io.KeyAlt = s3eKeyboardGetState(s3eKeyLeftAlt) == S3E_KEY_STATE_DOWN || s3eKeyboardGetState(s3eKeyRightAlt) == S3E_KEY_STATE_DOWN; + io.KeySuper = s3eKeyboardGetState(s3eKeyLeftWindows) == S3E_KEY_STATE_DOWN || s3eKeyboardGetState(s3eKeyRightWindows) == S3E_KEY_STATE_DOWN; + + return 0; +} + +int32 ImGui_Marmalade_CharCallback(void* system_data, void* user_data) +{ + ImGuiIO& io = ImGui::GetIO(); + s3eKeyboardCharEvent* e = (s3eKeyboardCharEvent*)system_data; + io.AddInputCharacter((unsigned int)e->m_Char); + + return 0; +} + +bool ImGui_Marmalade_CreateDeviceObjects() +{ + // Build texture atlas + ImGuiIO& io = ImGui::GetIO(); + unsigned char* pixels; + int width, height; + io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height); + + // Upload texture to graphics system + g_FontTexture = new CIwTexture(); + g_FontTexture->SetModifiable(true); + CIwImage& image = g_FontTexture->GetImage(); + image.SetFormat(CIwImage::ARGB_8888); + image.SetWidth(width); + image.SetHeight(height); + image.SetBuffers(); // allocates and own buffers + image.ReadTexels(pixels); + g_FontTexture->SetMipMapping(false); + g_FontTexture->SetFiltering(false); + g_FontTexture->Upload(); + + // Store our identifier + io.Fonts->SetTexID((ImTextureID)g_FontTexture); + + return true; +} + +void ImGui_Marmalade_InvalidateDeviceObjects() +{ + if (g_ClipboardText) + { + delete[] g_ClipboardText; + g_ClipboardText = NULL; + } + + if (g_FontTexture) + { + ImGui::GetIO().Fonts->SetTexID(0); + delete g_FontTexture; + g_FontTexture = NULL; + } +} + +bool ImGui_Marmalade_Init(bool install_callbacks) +{ + ImGuiIO& io = ImGui::GetIO(); + io.BackendPlatformName = io.BackendRendererName = "imgui_impl_marmalade"; + + // Keyboard mapping. Dear ImGui will use those indices to peek into the io.KeysDown[] array. + io.KeyMap[ImGuiKey_Tab] = s3eKeyTab + io.KeyMap[ImGuiKey_LeftArrow] = s3eKeyLeft; + io.KeyMap[ImGuiKey_RightArrow] = s3eKeyRight; + io.KeyMap[ImGuiKey_UpArrow] = s3eKeyUp; + io.KeyMap[ImGuiKey_DownArrow] = s3eKeyDown; + io.KeyMap[ImGuiKey_PageUp] = s3eKeyPageUp; + io.KeyMap[ImGuiKey_PageDown] = s3eKeyPageDown; + io.KeyMap[ImGuiKey_Home] = s3eKeyHome; + io.KeyMap[ImGuiKey_End] = s3eKeyEnd; + io.KeyMap[ImGuiKey_Insert] = s3eKeyInsert; + io.KeyMap[ImGuiKey_Delete] = s3eKeyDelete; + io.KeyMap[ImGuiKey_Backspace] = s3eKeyBackspace; + io.KeyMap[ImGuiKey_Space] = s3eKeySpace; + io.KeyMap[ImGuiKey_Enter] = s3eKeyEnter; + io.KeyMap[ImGuiKey_Escape] = s3eKeyEsc; + io.KeyMap[ImGuiKey_KeyPadEnter] = s3eKeyNumPadEnter; + io.KeyMap[ImGuiKey_A] = s3eKeyA; + io.KeyMap[ImGuiKey_C] = s3eKeyC; + io.KeyMap[ImGuiKey_V] = s3eKeyV; + io.KeyMap[ImGuiKey_X] = s3eKeyX; + io.KeyMap[ImGuiKey_Y] = s3eKeyY; + io.KeyMap[ImGuiKey_Z] = s3eKeyZ; + + io.SetClipboardTextFn = ImGui_Marmalade_SetClipboardText; + io.GetClipboardTextFn = ImGui_Marmalade_GetClipboardText; + + if (install_callbacks) + { + s3ePointerRegister(S3E_POINTER_BUTTON_EVENT, ImGui_Marmalade_PointerButtonEventCallback, 0); + s3eKeyboardRegister(S3E_KEYBOARD_KEY_EVENT, ImGui_Marmalade_KeyCallback, 0); + s3eKeyboardRegister(S3E_KEYBOARD_CHAR_EVENT, ImGui_Marmalade_CharCallback, 0); + } + + return true; +} + +void ImGui_Marmalade_Shutdown() +{ + ImGui_Marmalade_InvalidateDeviceObjects(); +} + +void ImGui_Marmalade_NewFrame() +{ + if (!g_FontTexture) + ImGui_Marmalade_CreateDeviceObjects(); + + ImGuiIO& io = ImGui::GetIO(); + + // Setup display size (every frame to accommodate for window resizing) + int w = IwGxGetScreenWidth(), h = IwGxGetScreenHeight(); + io.DisplaySize = ImVec2((float)w, (float)h); + // For retina display or other situations where window coordinates are different from framebuffer coordinates. User storage only, presently not used by ImGui. + io.DisplayFramebufferScale = g_scale; + + // Setup time step + double current_time = s3eTimerGetUST() / 1000.0f; + io.DeltaTime = g_Time > 0.0 ? (float)(current_time - g_Time) : (float)(1.0f / 60.0f); + g_Time = current_time; + + double mouse_x, mouse_y; + mouse_x = s3ePointerGetX(); + mouse_y = s3ePointerGetY(); + io.MousePos = ImVec2((float)mouse_x / g_scale.x, (float)mouse_y / g_scale.y); // Mouse position (set to -FLT_MAX,-FLT_MAX if no mouse / on another screen, etc.) + + for (int i = 0; i < 3; i++) + { + io.MouseDown[i] = g_MousePressed[i] || s3ePointerGetState((s3ePointerButton)i) != S3E_POINTER_STATE_UP; // If a mouse press event came, always pass it as "mouse held this frame", so we don't miss click-release events that are shorter than 1 frame. + g_MousePressed[i] = false; + } + + // TODO: Hide OS mouse cursor if ImGui is drawing it + // s3ePointerSetInt(S3E_POINTER_HIDE_CURSOR,(io.MouseDrawCursor ? 0 : 1)); + + // Show/hide OSD keyboard + if (io.WantTextInput) + { + // Some text input widget is active? + if (!g_osdKeyboardEnabled) + { + g_osdKeyboardEnabled = true; + s3eKeyboardSetInt(S3E_KEYBOARD_GET_CHAR, 1); // show OSD keyboard + } + } + else + { + // No text input widget is active + if (g_osdKeyboardEnabled) + { + g_osdKeyboardEnabled = false; + s3eKeyboardSetInt(S3E_KEYBOARD_GET_CHAR, 0); // hide OSD keyboard + } + } +} diff --git a/source/editor/imgui/backends/imgui_impl_marmalade.h b/source/editor/imgui/backends/imgui_impl_marmalade.h new file mode 100644 index 0000000..87aaa47 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_marmalade.h @@ -0,0 +1,28 @@ +// dear imgui: Renderer + Platform Backend for Marmalade + IwGx +// Marmalade code: Copyright (C) 2015 by Giovanni Zito (this file is part of Dear ImGui) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'CIwTexture*' as ImTextureID. Read the FAQ about ImTextureID! + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +IMGUI_IMPL_API bool ImGui_Marmalade_Init(bool install_callbacks); +IMGUI_IMPL_API void ImGui_Marmalade_Shutdown(); +IMGUI_IMPL_API void ImGui_Marmalade_NewFrame(); +IMGUI_IMPL_API void ImGui_Marmalade_RenderDrawData(ImDrawData* draw_data); + +// Use if you want to reset your rendering device without losing Dear ImGui state. +IMGUI_IMPL_API void ImGui_Marmalade_InvalidateDeviceObjects(); +IMGUI_IMPL_API bool ImGui_Marmalade_CreateDeviceObjects(); + +// Callbacks (installed by default if you enable 'install_callbacks' during initialization) +// You can also handle inputs yourself and use those as a reference. +IMGUI_IMPL_API int32 ImGui_Marmalade_PointerButtonEventCallback(void* system_data, void* user_data); +IMGUI_IMPL_API int32 ImGui_Marmalade_KeyCallback(void* system_data, void* user_data); +IMGUI_IMPL_API int32 ImGui_Marmalade_CharCallback(void* system_data, void* user_data); diff --git a/source/editor/imgui/backends/imgui_impl_metal.h b/source/editor/imgui/backends/imgui_impl_metal.h new file mode 100644 index 0000000..c0c6018 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_metal.h @@ -0,0 +1,29 @@ +// dear imgui: Renderer Backend for Metal +// This needs to be used along with a Platform Backend (e.g. OSX) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'MTLTexture' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#include "imgui.h" // IMGUI_IMPL_API + +@class MTLRenderPassDescriptor; +@protocol MTLDevice, MTLCommandBuffer, MTLRenderCommandEncoder; + +IMGUI_IMPL_API bool ImGui_ImplMetal_Init(id device); +IMGUI_IMPL_API void ImGui_ImplMetal_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplMetal_NewFrame(MTLRenderPassDescriptor* renderPassDescriptor); +IMGUI_IMPL_API void ImGui_ImplMetal_RenderDrawData(ImDrawData* draw_data, + id commandBuffer, + id commandEncoder); + +// Called by Init/NewFrame/Shutdown +IMGUI_IMPL_API bool ImGui_ImplMetal_CreateFontsTexture(id device); +IMGUI_IMPL_API void ImGui_ImplMetal_DestroyFontsTexture(); +IMGUI_IMPL_API bool ImGui_ImplMetal_CreateDeviceObjects(id device); +IMGUI_IMPL_API void ImGui_ImplMetal_DestroyDeviceObjects(); diff --git a/source/editor/imgui/backends/imgui_impl_metal.mm b/source/editor/imgui/backends/imgui_impl_metal.mm new file mode 100644 index 0000000..18dcc91 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_metal.mm @@ -0,0 +1,556 @@ +// dear imgui: Renderer Backend for Metal +// This needs to be used along with a Platform Backend (e.g. OSX) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'MTLTexture' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-08-24: Metal: Fixed a crash when clipping rect larger than framebuffer is submitted. (#4464) +// 2021-05-19: Metal: Replaced direct access to ImDrawCmd::TextureId with a call to ImDrawCmd::GetTexID(). (will become a requirement) +// 2021-02-18: Metal: Change blending equation to preserve alpha in output buffer. +// 2021-01-25: Metal: Fixed texture storage mode when building on Mac Catalyst. +// 2019-05-29: Metal: Added support for large mesh (64K+ vertices), enable ImGuiBackendFlags_RendererHasVtxOffset flag. +// 2019-04-30: Metal: Added support for special ImDrawCallback_ResetRenderState callback to reset render state. +// 2019-02-11: Metal: Projecting clipping rectangles correctly using draw_data->FramebufferScale to allow multi-viewports for retina display. +// 2018-11-30: Misc: Setting up io.BackendRendererName so it can be displayed in the About Window. +// 2018-07-05: Metal: Added new Metal backend implementation. + +#include "imgui.h" +#include "imgui_impl_metal.h" + +#import +// #import // Not supported in XCode 9.2. Maybe a macro to detect the SDK version can be used (something like #if MACOS_SDK >= 10.13 ...) +#import + +#pragma mark - Support classes + +// A wrapper around a MTLBuffer object that knows the last time it was reused +@interface MetalBuffer : NSObject +@property (nonatomic, strong) id buffer; +@property (nonatomic, assign) NSTimeInterval lastReuseTime; +- (instancetype)initWithBuffer:(id)buffer; +@end + +// An object that encapsulates the data necessary to uniquely identify a +// render pipeline state. These are used as cache keys. +@interface FramebufferDescriptor : NSObject +@property (nonatomic, assign) unsigned long sampleCount; +@property (nonatomic, assign) MTLPixelFormat colorPixelFormat; +@property (nonatomic, assign) MTLPixelFormat depthPixelFormat; +@property (nonatomic, assign) MTLPixelFormat stencilPixelFormat; +- (instancetype)initWithRenderPassDescriptor:(MTLRenderPassDescriptor *)renderPassDescriptor; +@end + +// A singleton that stores long-lived objects that are needed by the Metal +// renderer backend. Stores the render pipeline state cache and the default +// font texture, and manages the reusable buffer cache. +@interface MetalContext : NSObject +@property (nonatomic, strong) id depthStencilState; +@property (nonatomic, strong) FramebufferDescriptor *framebufferDescriptor; // framebuffer descriptor for current frame; transient +@property (nonatomic, strong) NSMutableDictionary *renderPipelineStateCache; // pipeline cache; keyed on framebuffer descriptors +@property (nonatomic, strong, nullable) id fontTexture; +@property (nonatomic, strong) NSMutableArray *bufferCache; +@property (nonatomic, assign) NSTimeInterval lastBufferCachePurge; +- (void)makeDeviceObjectsWithDevice:(id)device; +- (void)makeFontTextureWithDevice:(id)device; +- (MetalBuffer *)dequeueReusableBufferOfLength:(NSUInteger)length device:(id)device; +- (void)enqueueReusableBuffer:(MetalBuffer *)buffer; +- (id)renderPipelineStateForFrameAndDevice:(id)device; +- (void)emptyRenderPipelineStateCache; +- (void)setupRenderState:(ImDrawData *)drawData + commandBuffer:(id)commandBuffer + commandEncoder:(id)commandEncoder + renderPipelineState:(id)renderPipelineState + vertexBuffer:(MetalBuffer *)vertexBuffer + vertexBufferOffset:(size_t)vertexBufferOffset; +- (void)renderDrawData:(ImDrawData *)drawData + commandBuffer:(id)commandBuffer + commandEncoder:(id)commandEncoder; +@end + +static MetalContext *g_sharedMetalContext = nil; + +#pragma mark - ImGui API implementation + +bool ImGui_ImplMetal_Init(id device) +{ + ImGuiIO& io = ImGui::GetIO(); + io.BackendRendererName = "imgui_impl_metal"; + io.BackendFlags |= ImGuiBackendFlags_RendererHasVtxOffset; // We can honor the ImDrawCmd::VtxOffset field, allowing for large meshes. + + static dispatch_once_t onceToken; + dispatch_once(&onceToken, ^{ + g_sharedMetalContext = [[MetalContext alloc] init]; + }); + + ImGui_ImplMetal_CreateDeviceObjects(device); + + return true; +} + +void ImGui_ImplMetal_Shutdown() +{ + ImGui_ImplMetal_DestroyDeviceObjects(); +} + +void ImGui_ImplMetal_NewFrame(MTLRenderPassDescriptor *renderPassDescriptor) +{ + IM_ASSERT(g_sharedMetalContext != nil && "No Metal context. Did you call ImGui_ImplMetal_Init() ?"); + + g_sharedMetalContext.framebufferDescriptor = [[FramebufferDescriptor alloc] initWithRenderPassDescriptor:renderPassDescriptor]; +} + +// Metal Render function. +void ImGui_ImplMetal_RenderDrawData(ImDrawData* draw_data, id commandBuffer, id commandEncoder) +{ + [g_sharedMetalContext renderDrawData:draw_data commandBuffer:commandBuffer commandEncoder:commandEncoder]; +} + +bool ImGui_ImplMetal_CreateFontsTexture(id device) +{ + [g_sharedMetalContext makeFontTextureWithDevice:device]; + + ImGuiIO& io = ImGui::GetIO(); + io.Fonts->SetTexID((__bridge void *)g_sharedMetalContext.fontTexture); // ImTextureID == void* + + return (g_sharedMetalContext.fontTexture != nil); +} + +void ImGui_ImplMetal_DestroyFontsTexture() +{ + ImGuiIO& io = ImGui::GetIO(); + g_sharedMetalContext.fontTexture = nil; + io.Fonts->SetTexID(nullptr); +} + +bool ImGui_ImplMetal_CreateDeviceObjects(id device) +{ + [g_sharedMetalContext makeDeviceObjectsWithDevice:device]; + + ImGui_ImplMetal_CreateFontsTexture(device); + + return true; +} + +void ImGui_ImplMetal_DestroyDeviceObjects() +{ + ImGui_ImplMetal_DestroyFontsTexture(); + [g_sharedMetalContext emptyRenderPipelineStateCache]; +} + +#pragma mark - MetalBuffer implementation + +@implementation MetalBuffer +- (instancetype)initWithBuffer:(id)buffer +{ + if ((self = [super init])) + { + _buffer = buffer; + _lastReuseTime = [NSDate date].timeIntervalSince1970; + } + return self; +} +@end + +#pragma mark - FramebufferDescriptor implementation + +@implementation FramebufferDescriptor +- (instancetype)initWithRenderPassDescriptor:(MTLRenderPassDescriptor *)renderPassDescriptor +{ + if ((self = [super init])) + { + _sampleCount = renderPassDescriptor.colorAttachments[0].texture.sampleCount; + _colorPixelFormat = renderPassDescriptor.colorAttachments[0].texture.pixelFormat; + _depthPixelFormat = renderPassDescriptor.depthAttachment.texture.pixelFormat; + _stencilPixelFormat = renderPassDescriptor.stencilAttachment.texture.pixelFormat; + } + return self; +} + +- (nonnull id)copyWithZone:(nullable NSZone *)zone +{ + FramebufferDescriptor *copy = [[FramebufferDescriptor allocWithZone:zone] init]; + copy.sampleCount = self.sampleCount; + copy.colorPixelFormat = self.colorPixelFormat; + copy.depthPixelFormat = self.depthPixelFormat; + copy.stencilPixelFormat = self.stencilPixelFormat; + return copy; +} + +- (NSUInteger)hash +{ + NSUInteger sc = _sampleCount & 0x3; + NSUInteger cf = _colorPixelFormat & 0x3FF; + NSUInteger df = _depthPixelFormat & 0x3FF; + NSUInteger sf = _stencilPixelFormat & 0x3FF; + NSUInteger hash = (sf << 22) | (df << 12) | (cf << 2) | sc; + return hash; +} + +- (BOOL)isEqual:(id)object +{ + FramebufferDescriptor *other = object; + if (![other isKindOfClass:[FramebufferDescriptor class]]) + return NO; + return other.sampleCount == self.sampleCount && + other.colorPixelFormat == self.colorPixelFormat && + other.depthPixelFormat == self.depthPixelFormat && + other.stencilPixelFormat == self.stencilPixelFormat; +} + +@end + +#pragma mark - MetalContext implementation + +@implementation MetalContext +- (instancetype)init { + if ((self = [super init])) + { + _renderPipelineStateCache = [NSMutableDictionary dictionary]; + _bufferCache = [NSMutableArray array]; + _lastBufferCachePurge = [NSDate date].timeIntervalSince1970; + } + return self; +} + +- (void)makeDeviceObjectsWithDevice:(id)device +{ + MTLDepthStencilDescriptor *depthStencilDescriptor = [[MTLDepthStencilDescriptor alloc] init]; + depthStencilDescriptor.depthWriteEnabled = NO; + depthStencilDescriptor.depthCompareFunction = MTLCompareFunctionAlways; + self.depthStencilState = [device newDepthStencilStateWithDescriptor:depthStencilDescriptor]; +} + +// We are retrieving and uploading the font atlas as a 4-channels RGBA texture here. +// In theory we could call GetTexDataAsAlpha8() and upload a 1-channel texture to save on memory access bandwidth. +// However, using a shader designed for 1-channel texture would make it less obvious to use the ImTextureID facility to render users own textures. +// You can make that change in your implementation. +- (void)makeFontTextureWithDevice:(id)device +{ + ImGuiIO &io = ImGui::GetIO(); + unsigned char* pixels; + int width, height; + io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height); + MTLTextureDescriptor *textureDescriptor = [MTLTextureDescriptor texture2DDescriptorWithPixelFormat:MTLPixelFormatRGBA8Unorm + width:(NSUInteger)width + height:(NSUInteger)height + mipmapped:NO]; + textureDescriptor.usage = MTLTextureUsageShaderRead; +#if TARGET_OS_OSX || TARGET_OS_MACCATALYST + textureDescriptor.storageMode = MTLStorageModeManaged; +#else + textureDescriptor.storageMode = MTLStorageModeShared; +#endif + id texture = [device newTextureWithDescriptor:textureDescriptor]; + [texture replaceRegion:MTLRegionMake2D(0, 0, (NSUInteger)width, (NSUInteger)height) mipmapLevel:0 withBytes:pixels bytesPerRow:(NSUInteger)width * 4]; + self.fontTexture = texture; +} + +- (MetalBuffer *)dequeueReusableBufferOfLength:(NSUInteger)length device:(id)device +{ + NSTimeInterval now = [NSDate date].timeIntervalSince1970; + + // Purge old buffers that haven't been useful for a while + if (now - self.lastBufferCachePurge > 1.0) + { + NSMutableArray *survivors = [NSMutableArray array]; + for (MetalBuffer *candidate in self.bufferCache) + { + if (candidate.lastReuseTime > self.lastBufferCachePurge) + { + [survivors addObject:candidate]; + } + } + self.bufferCache = [survivors mutableCopy]; + self.lastBufferCachePurge = now; + } + + // See if we have a buffer we can reuse + MetalBuffer *bestCandidate = nil; + for (MetalBuffer *candidate in self.bufferCache) + if (candidate.buffer.length >= length && (bestCandidate == nil || bestCandidate.lastReuseTime > candidate.lastReuseTime)) + bestCandidate = candidate; + + if (bestCandidate != nil) + { + [self.bufferCache removeObject:bestCandidate]; + bestCandidate.lastReuseTime = now; + return bestCandidate; + } + + // No luck; make a new buffer + id backing = [device newBufferWithLength:length options:MTLResourceStorageModeShared]; + return [[MetalBuffer alloc] initWithBuffer:backing]; +} + +- (void)enqueueReusableBuffer:(MetalBuffer *)buffer +{ + [self.bufferCache addObject:buffer]; +} + +- (_Nullable id)renderPipelineStateForFrameAndDevice:(id)device +{ + // Try to retrieve a render pipeline state that is compatible with the framebuffer config for this frame + // The hit rate for this cache should be very near 100%. + id renderPipelineState = self.renderPipelineStateCache[self.framebufferDescriptor]; + + if (renderPipelineState == nil) + { + // No luck; make a new render pipeline state + renderPipelineState = [self _renderPipelineStateForFramebufferDescriptor:self.framebufferDescriptor device:device]; + // Cache render pipeline state for later reuse + self.renderPipelineStateCache[self.framebufferDescriptor] = renderPipelineState; + } + + return renderPipelineState; +} + +- (id)_renderPipelineStateForFramebufferDescriptor:(FramebufferDescriptor *)descriptor device:(id)device +{ + NSError *error = nil; + + NSString *shaderSource = @"" + "#include \n" + "using namespace metal;\n" + "\n" + "struct Uniforms {\n" + " float4x4 projectionMatrix;\n" + "};\n" + "\n" + "struct VertexIn {\n" + " float2 position [[attribute(0)]];\n" + " float2 texCoords [[attribute(1)]];\n" + " uchar4 color [[attribute(2)]];\n" + "};\n" + "\n" + "struct VertexOut {\n" + " float4 position [[position]];\n" + " float2 texCoords;\n" + " float4 color;\n" + "};\n" + "\n" + "vertex VertexOut vertex_main(VertexIn in [[stage_in]],\n" + " constant Uniforms &uniforms [[buffer(1)]]) {\n" + " VertexOut out;\n" + " out.position = uniforms.projectionMatrix * float4(in.position, 0, 1);\n" + " out.texCoords = in.texCoords;\n" + " out.color = float4(in.color) / float4(255.0);\n" + " return out;\n" + "}\n" + "\n" + "fragment half4 fragment_main(VertexOut in [[stage_in]],\n" + " texture2d texture [[texture(0)]]) {\n" + " constexpr sampler linearSampler(coord::normalized, min_filter::linear, mag_filter::linear, mip_filter::linear);\n" + " half4 texColor = texture.sample(linearSampler, in.texCoords);\n" + " return half4(in.color) * texColor;\n" + "}\n"; + + id library = [device newLibraryWithSource:shaderSource options:nil error:&error]; + if (library == nil) + { + NSLog(@"Error: failed to create Metal library: %@", error); + return nil; + } + + id vertexFunction = [library newFunctionWithName:@"vertex_main"]; + id fragmentFunction = [library newFunctionWithName:@"fragment_main"]; + + if (vertexFunction == nil || fragmentFunction == nil) + { + NSLog(@"Error: failed to find Metal shader functions in library: %@", error); + return nil; + } + + MTLVertexDescriptor *vertexDescriptor = [MTLVertexDescriptor vertexDescriptor]; + vertexDescriptor.attributes[0].offset = IM_OFFSETOF(ImDrawVert, pos); + vertexDescriptor.attributes[0].format = MTLVertexFormatFloat2; // position + vertexDescriptor.attributes[0].bufferIndex = 0; + vertexDescriptor.attributes[1].offset = IM_OFFSETOF(ImDrawVert, uv); + vertexDescriptor.attributes[1].format = MTLVertexFormatFloat2; // texCoords + vertexDescriptor.attributes[1].bufferIndex = 0; + vertexDescriptor.attributes[2].offset = IM_OFFSETOF(ImDrawVert, col); + vertexDescriptor.attributes[2].format = MTLVertexFormatUChar4; // color + vertexDescriptor.attributes[2].bufferIndex = 0; + vertexDescriptor.layouts[0].stepRate = 1; + vertexDescriptor.layouts[0].stepFunction = MTLVertexStepFunctionPerVertex; + vertexDescriptor.layouts[0].stride = sizeof(ImDrawVert); + + MTLRenderPipelineDescriptor *pipelineDescriptor = [[MTLRenderPipelineDescriptor alloc] init]; + pipelineDescriptor.vertexFunction = vertexFunction; + pipelineDescriptor.fragmentFunction = fragmentFunction; + pipelineDescriptor.vertexDescriptor = vertexDescriptor; + pipelineDescriptor.sampleCount = self.framebufferDescriptor.sampleCount; + pipelineDescriptor.colorAttachments[0].pixelFormat = self.framebufferDescriptor.colorPixelFormat; + pipelineDescriptor.colorAttachments[0].blendingEnabled = YES; + pipelineDescriptor.colorAttachments[0].rgbBlendOperation = MTLBlendOperationAdd; + pipelineDescriptor.colorAttachments[0].sourceRGBBlendFactor = MTLBlendFactorSourceAlpha; + pipelineDescriptor.colorAttachments[0].destinationRGBBlendFactor = MTLBlendFactorOneMinusSourceAlpha; + pipelineDescriptor.colorAttachments[0].alphaBlendOperation = MTLBlendOperationAdd; + pipelineDescriptor.colorAttachments[0].sourceAlphaBlendFactor = MTLBlendFactorOne; + pipelineDescriptor.colorAttachments[0].destinationAlphaBlendFactor = MTLBlendFactorOneMinusSourceAlpha; + pipelineDescriptor.depthAttachmentPixelFormat = self.framebufferDescriptor.depthPixelFormat; + pipelineDescriptor.stencilAttachmentPixelFormat = self.framebufferDescriptor.stencilPixelFormat; + + id renderPipelineState = [device newRenderPipelineStateWithDescriptor:pipelineDescriptor error:&error]; + if (error != nil) + { + NSLog(@"Error: failed to create Metal pipeline state: %@", error); + } + + return renderPipelineState; +} + +- (void)emptyRenderPipelineStateCache +{ + [self.renderPipelineStateCache removeAllObjects]; +} + +- (void)setupRenderState:(ImDrawData *)drawData + commandBuffer:(id)commandBuffer + commandEncoder:(id)commandEncoder + renderPipelineState:(id)renderPipelineState + vertexBuffer:(MetalBuffer *)vertexBuffer + vertexBufferOffset:(size_t)vertexBufferOffset +{ + [commandEncoder setCullMode:MTLCullModeNone]; + [commandEncoder setDepthStencilState:g_sharedMetalContext.depthStencilState]; + + // Setup viewport, orthographic projection matrix + // Our visible imgui space lies from draw_data->DisplayPos (top left) to + // draw_data->DisplayPos+data_data->DisplaySize (bottom right). DisplayMin is typically (0,0) for single viewport apps. + MTLViewport viewport = + { + .originX = 0.0, + .originY = 0.0, + .width = (double)(drawData->DisplaySize.x * drawData->FramebufferScale.x), + .height = (double)(drawData->DisplaySize.y * drawData->FramebufferScale.y), + .znear = 0.0, + .zfar = 1.0 + }; + [commandEncoder setViewport:viewport]; + + float L = drawData->DisplayPos.x; + float R = drawData->DisplayPos.x + drawData->DisplaySize.x; + float T = drawData->DisplayPos.y; + float B = drawData->DisplayPos.y + drawData->DisplaySize.y; + float N = (float)viewport.znear; + float F = (float)viewport.zfar; + const float ortho_projection[4][4] = + { + { 2.0f/(R-L), 0.0f, 0.0f, 0.0f }, + { 0.0f, 2.0f/(T-B), 0.0f, 0.0f }, + { 0.0f, 0.0f, 1/(F-N), 0.0f }, + { (R+L)/(L-R), (T+B)/(B-T), N/(F-N), 1.0f }, + }; + [commandEncoder setVertexBytes:&ortho_projection length:sizeof(ortho_projection) atIndex:1]; + + [commandEncoder setRenderPipelineState:renderPipelineState]; + + [commandEncoder setVertexBuffer:vertexBuffer.buffer offset:0 atIndex:0]; + [commandEncoder setVertexBufferOffset:vertexBufferOffset atIndex:0]; +} + +- (void)renderDrawData:(ImDrawData *)drawData + commandBuffer:(id)commandBuffer + commandEncoder:(id)commandEncoder +{ + // Avoid rendering when minimized, scale coordinates for retina displays (screen coordinates != framebuffer coordinates) + int fb_width = (int)(drawData->DisplaySize.x * drawData->FramebufferScale.x); + int fb_height = (int)(drawData->DisplaySize.y * drawData->FramebufferScale.y); + if (fb_width <= 0 || fb_height <= 0 || drawData->CmdListsCount == 0) + return; + + id renderPipelineState = [self renderPipelineStateForFrameAndDevice:commandBuffer.device]; + + size_t vertexBufferLength = (size_t)drawData->TotalVtxCount * sizeof(ImDrawVert); + size_t indexBufferLength = (size_t)drawData->TotalIdxCount * sizeof(ImDrawIdx); + MetalBuffer* vertexBuffer = [self dequeueReusableBufferOfLength:vertexBufferLength device:commandBuffer.device]; + MetalBuffer* indexBuffer = [self dequeueReusableBufferOfLength:indexBufferLength device:commandBuffer.device]; + + [self setupRenderState:drawData commandBuffer:commandBuffer commandEncoder:commandEncoder renderPipelineState:renderPipelineState vertexBuffer:vertexBuffer vertexBufferOffset:0]; + + // Will project scissor/clipping rectangles into framebuffer space + ImVec2 clip_off = drawData->DisplayPos; // (0,0) unless using multi-viewports + ImVec2 clip_scale = drawData->FramebufferScale; // (1,1) unless using retina display which are often (2,2) + + // Render command lists + size_t vertexBufferOffset = 0; + size_t indexBufferOffset = 0; + for (int n = 0; n < drawData->CmdListsCount; n++) + { + const ImDrawList* cmd_list = drawData->CmdLists[n]; + + memcpy((char *)vertexBuffer.buffer.contents + vertexBufferOffset, cmd_list->VtxBuffer.Data, (size_t)cmd_list->VtxBuffer.Size * sizeof(ImDrawVert)); + memcpy((char *)indexBuffer.buffer.contents + indexBufferOffset, cmd_list->IdxBuffer.Data, (size_t)cmd_list->IdxBuffer.Size * sizeof(ImDrawIdx)); + + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + const ImDrawCmd* pcmd = &cmd_list->CmdBuffer[cmd_i]; + if (pcmd->UserCallback) + { + // User callback, registered via ImDrawList::AddCallback() + // (ImDrawCallback_ResetRenderState is a special callback value used by the user to request the renderer to reset render state.) + if (pcmd->UserCallback == ImDrawCallback_ResetRenderState) + [self setupRenderState:drawData commandBuffer:commandBuffer commandEncoder:commandEncoder renderPipelineState:renderPipelineState vertexBuffer:vertexBuffer vertexBufferOffset:vertexBufferOffset]; + else + pcmd->UserCallback(cmd_list, pcmd); + } + else + { + // Project scissor/clipping rectangles into framebuffer space + ImVec2 clip_min((pcmd->ClipRect.x - clip_off.x) * clip_scale.x, (pcmd->ClipRect.y - clip_off.y) * clip_scale.y); + ImVec2 clip_max((pcmd->ClipRect.z - clip_off.x) * clip_scale.x, (pcmd->ClipRect.w - clip_off.y) * clip_scale.y); + + // Clamp to viewport as setScissorRect() won't accept values that are off bounds + if (clip_min.x < 0.0f) { clip_min.x = 0.0f; } + if (clip_min.y < 0.0f) { clip_min.y = 0.0f; } + if (clip_max.x > fb_width) { clip_max.x = (float)fb_width; } + if (clip_max.y > fb_height) { clip_max.y = (float)fb_height; } + if (clip_max.x < clip_min.x || clip_max.y < clip_min.y) + continue; + + // Apply scissor/clipping rectangle + MTLScissorRect scissorRect = + { + .x = NSUInteger(clip_min.x), + .y = NSUInteger(clip_min.y), + .width = NSUInteger(clip_max.x - clip_min.x), + .height = NSUInteger(clip_max.y - clip_min.y) + }; + [commandEncoder setScissorRect:scissorRect]; + + // Bind texture, Draw + if (ImTextureID tex_id = pcmd->GetTexID()) + [commandEncoder setFragmentTexture:(__bridge id)(tex_id) atIndex:0]; + + [commandEncoder setVertexBufferOffset:(vertexBufferOffset + pcmd->VtxOffset * sizeof(ImDrawVert)) atIndex:0]; + [commandEncoder drawIndexedPrimitives:MTLPrimitiveTypeTriangle + indexCount:pcmd->ElemCount + indexType:sizeof(ImDrawIdx) == 2 ? MTLIndexTypeUInt16 : MTLIndexTypeUInt32 + indexBuffer:indexBuffer.buffer + indexBufferOffset:indexBufferOffset + pcmd->IdxOffset * sizeof(ImDrawIdx)]; + } + } + + vertexBufferOffset += (size_t)cmd_list->VtxBuffer.Size * sizeof(ImDrawVert); + indexBufferOffset += (size_t)cmd_list->IdxBuffer.Size * sizeof(ImDrawIdx); + } + + __weak id weakSelf = self; + [commandBuffer addCompletedHandler:^(id) + { + dispatch_async(dispatch_get_main_queue(), ^{ + [weakSelf enqueueReusableBuffer:vertexBuffer]; + [weakSelf enqueueReusableBuffer:indexBuffer]; + }); + }]; +} + +@end diff --git a/source/editor/imgui/backends/imgui_impl_opengl2.cpp b/source/editor/imgui/backends/imgui_impl_opengl2.cpp new file mode 100644 index 0000000..b4ab2a3 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_opengl2.cpp @@ -0,0 +1,284 @@ +// dear imgui: Renderer Backend for OpenGL2 (legacy OpenGL, fixed pipeline) +// This needs to be used along with a Platform Backend (e.g. GLFW, SDL, Win32, custom..) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'GLuint' OpenGL texture identifier as void*/ImTextureID. Read the FAQ about ImTextureID! + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// **DO NOT USE THIS CODE IF YOUR CODE/ENGINE IS USING MODERN OPENGL (SHADERS, VBO, VAO, etc.)** +// **Prefer using the code in imgui_impl_opengl3.cpp** +// This code is mostly provided as a reference to learn how ImGui integration works, because it is shorter to read. +// If your code is using GL3+ context or any semi modern OpenGL calls, using this is likely to make everything more +// complicated, will require your code to reset every single OpenGL attributes to their initial state, and might +// confuse your GPU driver. +// The GL2 code is unable to reset attributes or even call e.g. "glUseProgram(0)" because they don't exist in that API. + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-06-29: Reorganized backend to pull data from a single structure to facilitate usage with multiple-contexts (all g_XXXX access changed to bd->XXXX). +// 2021-05-19: OpenGL: Replaced direct access to ImDrawCmd::TextureId with a call to ImDrawCmd::GetTexID(). (will become a requirement) +// 2021-01-03: OpenGL: Backup, setup and restore GL_SHADE_MODEL state, disable GL_STENCIL_TEST and disable GL_NORMAL_ARRAY client state to increase compatibility with legacy OpenGL applications. +// 2020-01-23: OpenGL: Backup, setup and restore GL_TEXTURE_ENV to increase compatibility with legacy OpenGL applications. +// 2019-04-30: OpenGL: Added support for special ImDrawCallback_ResetRenderState callback to reset render state. +// 2019-02-11: OpenGL: Projecting clipping rectangles correctly using draw_data->FramebufferScale to allow multi-viewports for retina display. +// 2018-11-30: Misc: Setting up io.BackendRendererName so it can be displayed in the About Window. +// 2018-08-03: OpenGL: Disabling/restoring GL_LIGHTING and GL_COLOR_MATERIAL to increase compatibility with legacy OpenGL applications. +// 2018-06-08: Misc: Extracted imgui_impl_opengl2.cpp/.h away from the old combined GLFW/SDL+OpenGL2 examples. +// 2018-06-08: OpenGL: Use draw_data->DisplayPos and draw_data->DisplaySize to setup projection matrix and clipping rectangle. +// 2018-02-16: Misc: Obsoleted the io.RenderDrawListsFn callback and exposed ImGui_ImplOpenGL2_RenderDrawData() in the .h file so you can call it yourself. +// 2017-09-01: OpenGL: Save and restore current polygon mode. +// 2016-09-10: OpenGL: Uploading font texture as RGBA32 to increase compatibility with users shaders (not ideal). +// 2016-09-05: OpenGL: Fixed save and restore of current scissor rectangle. + +#include "imgui.h" +#include "imgui_impl_opengl2.h" +#if defined(_MSC_VER) && _MSC_VER <= 1500 // MSVC 2008 or earlier +#include // intptr_t +#else +#include // intptr_t +#endif + +// Include OpenGL header (without an OpenGL loader) requires a bit of fiddling +#if defined(_WIN32) && !defined(APIENTRY) +#define APIENTRY __stdcall // It is customary to use APIENTRY for OpenGL function pointer declarations on all platforms. Additionally, the Windows OpenGL header needs APIENTRY. +#endif +#if defined(_WIN32) && !defined(WINGDIAPI) +#define WINGDIAPI __declspec(dllimport) // Some Windows OpenGL headers need this +#endif +#if defined(__APPLE__) +#define GL_SILENCE_DEPRECATION +#include +#else +#include +#endif + +struct ImGui_ImplOpenGL2_Data +{ + GLuint FontTexture; + + ImGui_ImplOpenGL2_Data() { memset(this, 0, sizeof(*this)); } +}; + +// Backend data stored in io.BackendRendererUserData to allow support for multiple Dear ImGui contexts +// It is STRONGLY preferred that you use docking branch with multi-viewports (== single Dear ImGui context + multiple windows) instead of multiple Dear ImGui contexts. +static ImGui_ImplOpenGL2_Data* ImGui_ImplOpenGL2_GetBackendData() +{ + return ImGui::GetCurrentContext() ? (ImGui_ImplOpenGL2_Data*)ImGui::GetIO().BackendRendererUserData : NULL; +} + +// Functions +bool ImGui_ImplOpenGL2_Init() +{ + ImGuiIO& io = ImGui::GetIO(); + IM_ASSERT(io.BackendRendererUserData == NULL && "Already initialized a renderer backend!"); + + // Setup backend capabilities flags + ImGui_ImplOpenGL2_Data* bd = IM_NEW(ImGui_ImplOpenGL2_Data)(); + io.BackendRendererUserData = (void*)bd; + io.BackendRendererName = "imgui_impl_opengl2"; + + return true; +} + +void ImGui_ImplOpenGL2_Shutdown() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplOpenGL2_Data* bd = ImGui_ImplOpenGL2_GetBackendData(); + + ImGui_ImplOpenGL2_DestroyDeviceObjects(); + io.BackendRendererName = NULL; + io.BackendRendererUserData = NULL; + IM_DELETE(bd); +} + +void ImGui_ImplOpenGL2_NewFrame() +{ + ImGui_ImplOpenGL2_Data* bd = ImGui_ImplOpenGL2_GetBackendData(); + IM_ASSERT(bd != NULL && "Did you call ImGui_ImplOpenGL2_Init()?"); + + if (!bd->FontTexture) + ImGui_ImplOpenGL2_CreateDeviceObjects(); +} + +static void ImGui_ImplOpenGL2_SetupRenderState(ImDrawData* draw_data, int fb_width, int fb_height) +{ + // Setup render state: alpha-blending enabled, no face culling, no depth testing, scissor enabled, vertex/texcoord/color pointers, polygon fill. + glEnable(GL_BLEND); + glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); + //glBlendFuncSeparate(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA, GL_ONE, GL_ONE_MINUS_SRC_ALPHA); // In order to composite our output buffer we need to preserve alpha + glDisable(GL_CULL_FACE); + glDisable(GL_DEPTH_TEST); + glDisable(GL_STENCIL_TEST); + glDisable(GL_LIGHTING); + glDisable(GL_COLOR_MATERIAL); + glEnable(GL_SCISSOR_TEST); + glEnableClientState(GL_VERTEX_ARRAY); + glEnableClientState(GL_TEXTURE_COORD_ARRAY); + glEnableClientState(GL_COLOR_ARRAY); + glDisableClientState(GL_NORMAL_ARRAY); + glEnable(GL_TEXTURE_2D); + glPolygonMode(GL_FRONT_AND_BACK, GL_FILL); + glShadeModel(GL_SMOOTH); + glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE); + + // If you are using this code with non-legacy OpenGL header/contexts (which you should not, prefer using imgui_impl_opengl3.cpp!!), + // you may need to backup/reset/restore other state, e.g. for current shader using the commented lines below. + // (DO NOT MODIFY THIS FILE! Add the code in your calling function) + // GLint last_program; + // glGetIntegerv(GL_CURRENT_PROGRAM, &last_program); + // glUseProgram(0); + // ImGui_ImplOpenGL2_RenderDrawData(...); + // glUseProgram(last_program) + // There are potentially many more states you could need to clear/setup that we can't access from default headers. + // e.g. glBindBuffer(GL_ARRAY_BUFFER, 0), glDisable(GL_TEXTURE_CUBE_MAP). + + // Setup viewport, orthographic projection matrix + // Our visible imgui space lies from draw_data->DisplayPos (top left) to draw_data->DisplayPos+data_data->DisplaySize (bottom right). DisplayPos is (0,0) for single viewport apps. + glViewport(0, 0, (GLsizei)fb_width, (GLsizei)fb_height); + glMatrixMode(GL_PROJECTION); + glPushMatrix(); + glLoadIdentity(); + glOrtho(draw_data->DisplayPos.x, draw_data->DisplayPos.x + draw_data->DisplaySize.x, draw_data->DisplayPos.y + draw_data->DisplaySize.y, draw_data->DisplayPos.y, -1.0f, +1.0f); + glMatrixMode(GL_MODELVIEW); + glPushMatrix(); + glLoadIdentity(); +} + +// OpenGL2 Render function. +// Note that this implementation is little overcomplicated because we are saving/setting up/restoring every OpenGL state explicitly. +// This is in order to be able to run within an OpenGL engine that doesn't do so. +void ImGui_ImplOpenGL2_RenderDrawData(ImDrawData* draw_data) +{ + // Avoid rendering when minimized, scale coordinates for retina displays (screen coordinates != framebuffer coordinates) + int fb_width = (int)(draw_data->DisplaySize.x * draw_data->FramebufferScale.x); + int fb_height = (int)(draw_data->DisplaySize.y * draw_data->FramebufferScale.y); + if (fb_width == 0 || fb_height == 0) + return; + + // Backup GL state + GLint last_texture; glGetIntegerv(GL_TEXTURE_BINDING_2D, &last_texture); + GLint last_polygon_mode[2]; glGetIntegerv(GL_POLYGON_MODE, last_polygon_mode); + GLint last_viewport[4]; glGetIntegerv(GL_VIEWPORT, last_viewport); + GLint last_scissor_box[4]; glGetIntegerv(GL_SCISSOR_BOX, last_scissor_box); + GLint last_shade_model; glGetIntegerv(GL_SHADE_MODEL, &last_shade_model); + GLint last_tex_env_mode; glGetTexEnviv(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, &last_tex_env_mode); + glPushAttrib(GL_ENABLE_BIT | GL_COLOR_BUFFER_BIT | GL_TRANSFORM_BIT); + + // Setup desired GL state + ImGui_ImplOpenGL2_SetupRenderState(draw_data, fb_width, fb_height); + + // Will project scissor/clipping rectangles into framebuffer space + ImVec2 clip_off = draw_data->DisplayPos; // (0,0) unless using multi-viewports + ImVec2 clip_scale = draw_data->FramebufferScale; // (1,1) unless using retina display which are often (2,2) + + // Render command lists + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + const ImDrawVert* vtx_buffer = cmd_list->VtxBuffer.Data; + const ImDrawIdx* idx_buffer = cmd_list->IdxBuffer.Data; + glVertexPointer(2, GL_FLOAT, sizeof(ImDrawVert), (const GLvoid*)((const char*)vtx_buffer + IM_OFFSETOF(ImDrawVert, pos))); + glTexCoordPointer(2, GL_FLOAT, sizeof(ImDrawVert), (const GLvoid*)((const char*)vtx_buffer + IM_OFFSETOF(ImDrawVert, uv))); + glColorPointer(4, GL_UNSIGNED_BYTE, sizeof(ImDrawVert), (const GLvoid*)((const char*)vtx_buffer + IM_OFFSETOF(ImDrawVert, col))); + + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + const ImDrawCmd* pcmd = &cmd_list->CmdBuffer[cmd_i]; + if (pcmd->UserCallback) + { + // User callback, registered via ImDrawList::AddCallback() + // (ImDrawCallback_ResetRenderState is a special callback value used by the user to request the renderer to reset render state.) + if (pcmd->UserCallback == ImDrawCallback_ResetRenderState) + ImGui_ImplOpenGL2_SetupRenderState(draw_data, fb_width, fb_height); + else + pcmd->UserCallback(cmd_list, pcmd); + } + else + { + // Project scissor/clipping rectangles into framebuffer space + ImVec2 clip_min((pcmd->ClipRect.x - clip_off.x) * clip_scale.x, (pcmd->ClipRect.y - clip_off.y) * clip_scale.y); + ImVec2 clip_max((pcmd->ClipRect.z - clip_off.x) * clip_scale.x, (pcmd->ClipRect.w - clip_off.y) * clip_scale.y); + if (clip_max.x < clip_min.x || clip_max.y < clip_min.y) + continue; + + // Apply scissor/clipping rectangle (Y is inverted in OpenGL) + glScissor((int)clip_min.x, (int)(fb_height - clip_max.y), (int)(clip_max.x - clip_min.x), (int)(clip_max.y - clip_min.y)); + + // Bind texture, Draw + glBindTexture(GL_TEXTURE_2D, (GLuint)(intptr_t)pcmd->GetTexID()); + glDrawElements(GL_TRIANGLES, (GLsizei)pcmd->ElemCount, sizeof(ImDrawIdx) == 2 ? GL_UNSIGNED_SHORT : GL_UNSIGNED_INT, idx_buffer); + } + idx_buffer += pcmd->ElemCount; + } + } + + // Restore modified GL state + glDisableClientState(GL_COLOR_ARRAY); + glDisableClientState(GL_TEXTURE_COORD_ARRAY); + glDisableClientState(GL_VERTEX_ARRAY); + glBindTexture(GL_TEXTURE_2D, (GLuint)last_texture); + glMatrixMode(GL_MODELVIEW); + glPopMatrix(); + glMatrixMode(GL_PROJECTION); + glPopMatrix(); + glPopAttrib(); + glPolygonMode(GL_FRONT, (GLenum)last_polygon_mode[0]); glPolygonMode(GL_BACK, (GLenum)last_polygon_mode[1]); + glViewport(last_viewport[0], last_viewport[1], (GLsizei)last_viewport[2], (GLsizei)last_viewport[3]); + glScissor(last_scissor_box[0], last_scissor_box[1], (GLsizei)last_scissor_box[2], (GLsizei)last_scissor_box[3]); + glShadeModel(last_shade_model); + glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, last_tex_env_mode); +} + +bool ImGui_ImplOpenGL2_CreateFontsTexture() +{ + // Build texture atlas + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplOpenGL2_Data* bd = ImGui_ImplOpenGL2_GetBackendData(); + unsigned char* pixels; + int width, height; + io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height); // Load as RGBA 32-bit (75% of the memory is wasted, but default font is so small) because it is more likely to be compatible with user's existing shaders. If your ImTextureId represent a higher-level concept than just a GL texture id, consider calling GetTexDataAsAlpha8() instead to save on GPU memory. + + // Upload texture to graphics system + GLint last_texture; + glGetIntegerv(GL_TEXTURE_BINDING_2D, &last_texture); + glGenTextures(1, &bd->FontTexture); + glBindTexture(GL_TEXTURE_2D, bd->FontTexture); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); + glPixelStorei(GL_UNPACK_ROW_LENGTH, 0); + glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, width, height, 0, GL_RGBA, GL_UNSIGNED_BYTE, pixels); + + // Store our identifier + io.Fonts->SetTexID((ImTextureID)(intptr_t)bd->FontTexture); + + // Restore state + glBindTexture(GL_TEXTURE_2D, last_texture); + + return true; +} + +void ImGui_ImplOpenGL2_DestroyFontsTexture() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplOpenGL2_Data* bd = ImGui_ImplOpenGL2_GetBackendData(); + if (bd->FontTexture) + { + glDeleteTextures(1, &bd->FontTexture); + io.Fonts->SetTexID(0); + bd->FontTexture = 0; + } +} + +bool ImGui_ImplOpenGL2_CreateDeviceObjects() +{ + return ImGui_ImplOpenGL2_CreateFontsTexture(); +} + +void ImGui_ImplOpenGL2_DestroyDeviceObjects() +{ + ImGui_ImplOpenGL2_DestroyFontsTexture(); +} diff --git a/source/editor/imgui/backends/imgui_impl_opengl2.h b/source/editor/imgui/backends/imgui_impl_opengl2.h new file mode 100644 index 0000000..d00d27f --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_opengl2.h @@ -0,0 +1,32 @@ +// dear imgui: Renderer Backend for OpenGL2 (legacy OpenGL, fixed pipeline) +// This needs to be used along with a Platform Backend (e.g. GLFW, SDL, Win32, custom..) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'GLuint' OpenGL texture identifier as void*/ImTextureID. Read the FAQ about ImTextureID! + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// **DO NOT USE THIS CODE IF YOUR CODE/ENGINE IS USING MODERN OPENGL (SHADERS, VBO, VAO, etc.)** +// **Prefer using the code in imgui_impl_opengl3.cpp** +// This code is mostly provided as a reference to learn how ImGui integration works, because it is shorter to read. +// If your code is using GL3+ context or any semi modern OpenGL calls, using this is likely to make everything more +// complicated, will require your code to reset every single OpenGL attributes to their initial state, and might +// confuse your GPU driver. +// The GL2 code is unable to reset attributes or even call e.g. "glUseProgram(0)" because they don't exist in that API. + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +IMGUI_IMPL_API bool ImGui_ImplOpenGL2_Init(); +IMGUI_IMPL_API void ImGui_ImplOpenGL2_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplOpenGL2_NewFrame(); +IMGUI_IMPL_API void ImGui_ImplOpenGL2_RenderDrawData(ImDrawData* draw_data); + +// Called by Init/NewFrame/Shutdown +IMGUI_IMPL_API bool ImGui_ImplOpenGL2_CreateFontsTexture(); +IMGUI_IMPL_API void ImGui_ImplOpenGL2_DestroyFontsTexture(); +IMGUI_IMPL_API bool ImGui_ImplOpenGL2_CreateDeviceObjects(); +IMGUI_IMPL_API void ImGui_ImplOpenGL2_DestroyDeviceObjects(); diff --git a/source/editor/imgui/backends/imgui_impl_opengl3.cpp b/source/editor/imgui/backends/imgui_impl_opengl3.cpp new file mode 100644 index 0000000..dc07ba5 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_opengl3.cpp @@ -0,0 +1,777 @@ +// dear imgui: Renderer Backend for modern OpenGL with shaders / programmatic pipeline +// - Desktop GL: 2.x 3.x 4.x +// - Embedded GL: ES 2.0 (WebGL 1.0), ES 3.0 (WebGL 2.0) +// This needs to be used along with a Platform Backend (e.g. GLFW, SDL, Win32, custom..) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'GLuint' OpenGL texture identifier as void*/ImTextureID. Read the FAQ about ImTextureID! +// [x] Renderer: Desktop GL only: Support for large meshes (64k+ vertices) with 16-bit indices. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-08-23: OpenGL: Fixed ES 3.0 shader ("#version 300 es") use normal precision floats to avoid wobbly rendering at HD resolutions. +// 2021-08-19: OpenGL: Embed and use our own minimal GL loader (imgui_impl_opengl3_loader.h), removing requirement and support for third-party loader. +// 2021-06-29: Reorganized backend to pull data from a single structure to facilitate usage with multiple-contexts (all g_XXXX access changed to bd->XXXX). +// 2021-06-25: OpenGL: Use OES_vertex_array extension on Emscripten + backup/restore current state. +// 2021-06-21: OpenGL: Destroy individual vertex/fragment shader objects right after they are linked into the main shader. +// 2021-05-24: OpenGL: Access GL_CLIP_ORIGIN when "GL_ARB_clip_control" extension is detected, inside of just OpenGL 4.5 version. +// 2021-05-19: OpenGL: Replaced direct access to ImDrawCmd::TextureId with a call to ImDrawCmd::GetTexID(). (will become a requirement) +// 2021-04-06: OpenGL: Don't try to read GL_CLIP_ORIGIN unless we're OpenGL 4.5 or greater. +// 2021-02-18: OpenGL: Change blending equation to preserve alpha in output buffer. +// 2021-01-03: OpenGL: Backup, setup and restore GL_STENCIL_TEST state. +// 2020-10-23: OpenGL: Backup, setup and restore GL_PRIMITIVE_RESTART state. +// 2020-10-15: OpenGL: Use glGetString(GL_VERSION) instead of glGetIntegerv(GL_MAJOR_VERSION, ...) when the later returns zero (e.g. Desktop GL 2.x) +// 2020-09-17: OpenGL: Fix to avoid compiling/calling glBindSampler() on ES or pre 3.3 context which have the defines set by a loader. +// 2020-07-10: OpenGL: Added support for glad2 OpenGL loader. +// 2020-05-08: OpenGL: Made default GLSL version 150 (instead of 130) on OSX. +// 2020-04-21: OpenGL: Fixed handling of glClipControl(GL_UPPER_LEFT) by inverting projection matrix. +// 2020-04-12: OpenGL: Fixed context version check mistakenly testing for 4.0+ instead of 3.2+ to enable ImGuiBackendFlags_RendererHasVtxOffset. +// 2020-03-24: OpenGL: Added support for glbinding 2.x OpenGL loader. +// 2020-01-07: OpenGL: Added support for glbinding 3.x OpenGL loader. +// 2019-10-25: OpenGL: Using a combination of GL define and runtime GL version to decide whether to use glDrawElementsBaseVertex(). Fix building with pre-3.2 GL loaders. +// 2019-09-22: OpenGL: Detect default GL loader using __has_include compiler facility. +// 2019-09-16: OpenGL: Tweak initialization code to allow application calling ImGui_ImplOpenGL3_CreateFontsTexture() before the first NewFrame() call. +// 2019-05-29: OpenGL: Desktop GL only: Added support for large mesh (64K+ vertices), enable ImGuiBackendFlags_RendererHasVtxOffset flag. +// 2019-04-30: OpenGL: Added support for special ImDrawCallback_ResetRenderState callback to reset render state. +// 2019-03-29: OpenGL: Not calling glBindBuffer more than necessary in the render loop. +// 2019-03-15: OpenGL: Added a GL call + comments in ImGui_ImplOpenGL3_Init() to detect uninitialized GL function loaders early. +// 2019-03-03: OpenGL: Fix support for ES 2.0 (WebGL 1.0). +// 2019-02-20: OpenGL: Fix for OSX not supporting OpenGL 4.5, we don't try to read GL_CLIP_ORIGIN even if defined by the headers/loader. +// 2019-02-11: OpenGL: Projecting clipping rectangles correctly using draw_data->FramebufferScale to allow multi-viewports for retina display. +// 2019-02-01: OpenGL: Using GLSL 410 shaders for any version over 410 (e.g. 430, 450). +// 2018-11-30: Misc: Setting up io.BackendRendererName so it can be displayed in the About Window. +// 2018-11-13: OpenGL: Support for GL 4.5's glClipControl(GL_UPPER_LEFT) / GL_CLIP_ORIGIN. +// 2018-08-29: OpenGL: Added support for more OpenGL loaders: glew and glad, with comments indicative that any loader can be used. +// 2018-08-09: OpenGL: Default to OpenGL ES 3 on iOS and Android. GLSL version default to "#version 300 ES". +// 2018-07-30: OpenGL: Support for GLSL 300 ES and 410 core. Fixes for Emscripten compilation. +// 2018-07-10: OpenGL: Support for more GLSL versions (based on the GLSL version string). Added error output when shaders fail to compile/link. +// 2018-06-08: Misc: Extracted imgui_impl_opengl3.cpp/.h away from the old combined GLFW/SDL+OpenGL3 examples. +// 2018-06-08: OpenGL: Use draw_data->DisplayPos and draw_data->DisplaySize to setup projection matrix and clipping rectangle. +// 2018-05-25: OpenGL: Removed unnecessary backup/restore of GL_ELEMENT_ARRAY_BUFFER_BINDING since this is part of the VAO state. +// 2018-05-14: OpenGL: Making the call to glBindSampler() optional so 3.2 context won't fail if the function is a NULL pointer. +// 2018-03-06: OpenGL: Added const char* glsl_version parameter to ImGui_ImplOpenGL3_Init() so user can override the GLSL version e.g. "#version 150". +// 2018-02-23: OpenGL: Create the VAO in the render function so the setup can more easily be used with multiple shared GL context. +// 2018-02-16: Misc: Obsoleted the io.RenderDrawListsFn callback and exposed ImGui_ImplSdlGL3_RenderDrawData() in the .h file so you can call it yourself. +// 2018-01-07: OpenGL: Changed GLSL shader version from 330 to 150. +// 2017-09-01: OpenGL: Save and restore current bound sampler. Save and restore current polygon mode. +// 2017-05-01: OpenGL: Fixed save and restore of current blend func state. +// 2017-05-01: OpenGL: Fixed save and restore of current GL_ACTIVE_TEXTURE. +// 2016-09-05: OpenGL: Fixed save and restore of current scissor rectangle. +// 2016-07-29: OpenGL: Explicitly setting GL_UNPACK_ROW_LENGTH to reduce issues because SDL changes it. (#752) + +//---------------------------------------- +// OpenGL GLSL GLSL +// version version string +//---------------------------------------- +// 2.0 110 "#version 110" +// 2.1 120 "#version 120" +// 3.0 130 "#version 130" +// 3.1 140 "#version 140" +// 3.2 150 "#version 150" +// 3.3 330 "#version 330 core" +// 4.0 400 "#version 400 core" +// 4.1 410 "#version 410 core" +// 4.2 420 "#version 410 core" +// 4.3 430 "#version 430 core" +// ES 2.0 100 "#version 100" = WebGL 1.0 +// ES 3.0 300 "#version 300 es" = WebGL 2.0 +//---------------------------------------- + +#if defined(_MSC_VER) && !defined(_CRT_SECURE_NO_WARNINGS) +#define _CRT_SECURE_NO_WARNINGS +#endif + +#include "imgui.h" +#include "imgui_impl_opengl3.h" +#include +#if defined(_MSC_VER) && _MSC_VER <= 1500 // MSVC 2008 or earlier +#include // intptr_t +#else +#include // intptr_t +#endif + +// GL includes +#if defined(IMGUI_IMPL_OPENGL_ES2) +#include +#if defined(__EMSCRIPTEN__) +#ifndef GL_GLEXT_PROTOTYPES +#define GL_GLEXT_PROTOTYPES +#endif +#include +#endif +#elif defined(IMGUI_IMPL_OPENGL_ES3) +#if defined(__APPLE__) +#include +#endif +#if (defined(__APPLE__) && (TARGET_OS_IOS || TARGET_OS_TV)) +#include // Use GL ES 3 +#else +#include // Use GL ES 3 +#endif +#elif !defined(IMGUI_IMPL_OPENGL_LOADER_CUSTOM) +// Modern desktop OpenGL doesn't have a standard portable header file to load OpenGL function pointers. +// Helper libraries are often used for this purpose! Here we are using our own minimal custom loader based on gl3w. +// In the rest of your app/engine, you can use another loader of your choice (gl3w, glew, glad, glbinding, glext, glLoadGen, etc.). +// If you happen to be developing a new feature for this backend (imgui_impl_opengl3.cpp): +// - You may need to regenerate imgui_impl_opengl3_loader.h to add new symbols. See https://github.com/dearimgui/gl3w_stripped +// - You can temporarily use an unstripped version. See https://github.com/dearimgui/gl3w_stripped/releases +// Changes to this backend using new APIs should be accompanied by a regenerated stripped loader version. +#define IMGL3W_IMPL +#include "imgui_impl_opengl3_loader.h" +#endif + +// Vertex arrays are not supported on ES2/WebGL1 unless Emscripten which uses an extension +#ifndef IMGUI_IMPL_OPENGL_ES2 +#define IMGUI_IMPL_OPENGL_USE_VERTEX_ARRAY +#elif defined(__EMSCRIPTEN__) +#define IMGUI_IMPL_OPENGL_USE_VERTEX_ARRAY +#define glBindVertexArray glBindVertexArrayOES +#define glGenVertexArrays glGenVertexArraysOES +#define glDeleteVertexArrays glDeleteVertexArraysOES +#define GL_VERTEX_ARRAY_BINDING GL_VERTEX_ARRAY_BINDING_OES +#endif + +// Desktop GL 2.0+ has glPolygonMode() which GL ES and WebGL don't have. +#ifdef GL_POLYGON_MODE +#define IMGUI_IMPL_HAS_POLYGON_MODE +#endif + +// Desktop GL 3.2+ has glDrawElementsBaseVertex() which GL ES and WebGL don't have. +#if !defined(IMGUI_IMPL_OPENGL_ES2) && !defined(IMGUI_IMPL_OPENGL_ES3) && defined(GL_VERSION_3_2) +#define IMGUI_IMPL_OPENGL_MAY_HAVE_VTX_OFFSET +#endif + +// Desktop GL 3.3+ has glBindSampler() +#if !defined(IMGUI_IMPL_OPENGL_ES2) && !defined(IMGUI_IMPL_OPENGL_ES3) && defined(GL_VERSION_3_3) +#define IMGUI_IMPL_OPENGL_MAY_HAVE_BIND_SAMPLER +#endif + +// Desktop GL 3.1+ has GL_PRIMITIVE_RESTART state +#if !defined(IMGUI_IMPL_OPENGL_ES2) && !defined(IMGUI_IMPL_OPENGL_ES3) && defined(GL_VERSION_3_1) +#define IMGUI_IMPL_OPENGL_MAY_HAVE_PRIMITIVE_RESTART +#endif + +// Desktop GL use extension detection +#if !defined(IMGUI_IMPL_OPENGL_ES2) && !defined(IMGUI_IMPL_OPENGL_ES3) +#define IMGUI_IMPL_OPENGL_MAY_HAVE_EXTENSIONS +#endif + +// OpenGL Data +struct ImGui_ImplOpenGL3_Data +{ + GLuint GlVersion; // Extracted at runtime using GL_MAJOR_VERSION, GL_MINOR_VERSION queries (e.g. 320 for GL 3.2) + char GlslVersionString[32]; // Specified by user or detected based on compile time GL settings. + GLuint FontTexture; + GLuint ShaderHandle; + GLint AttribLocationTex; // Uniforms location + GLint AttribLocationProjMtx; + GLuint AttribLocationVtxPos; // Vertex attributes location + GLuint AttribLocationVtxUV; + GLuint AttribLocationVtxColor; + unsigned int VboHandle, ElementsHandle; + bool HasClipOrigin; + + ImGui_ImplOpenGL3_Data() { memset(this, 0, sizeof(*this)); } +}; + +// Backend data stored in io.BackendRendererUserData to allow support for multiple Dear ImGui contexts +// It is STRONGLY preferred that you use docking branch with multi-viewports (== single Dear ImGui context + multiple windows) instead of multiple Dear ImGui contexts. +static ImGui_ImplOpenGL3_Data* ImGui_ImplOpenGL3_GetBackendData() +{ + return ImGui::GetCurrentContext() ? (ImGui_ImplOpenGL3_Data*)ImGui::GetIO().BackendRendererUserData : NULL; +} + +// Functions +bool ImGui_ImplOpenGL3_Init(const char* glsl_version) +{ + ImGuiIO& io = ImGui::GetIO(); + IM_ASSERT(io.BackendRendererUserData == NULL && "Already initialized a renderer backend!"); + + // Initialize our loader +#if !defined(IMGUI_IMPL_OPENGL_ES2) && !defined(IMGUI_IMPL_OPENGL_ES3) && !defined(IMGUI_IMPL_OPENGL_LOADER_CUSTOM) + if (imgl3wInit() != 0) + { + fprintf(stderr, "Failed to initialize OpenGL loader!\n"); + return false; + } +#endif + + // Setup backend capabilities flags + ImGui_ImplOpenGL3_Data* bd = IM_NEW(ImGui_ImplOpenGL3_Data)(); + io.BackendRendererUserData = (void*)bd; + io.BackendRendererName = "imgui_impl_opengl3"; + + // Query for GL version (e.g. 320 for GL 3.2) +#if !defined(IMGUI_IMPL_OPENGL_ES2) + GLint major = 0; + GLint minor = 0; + glGetIntegerv(GL_MAJOR_VERSION, &major); + glGetIntegerv(GL_MINOR_VERSION, &minor); + if (major == 0 && minor == 0) + { + // Query GL_VERSION in desktop GL 2.x, the string will start with "." + const char* gl_version = (const char*)glGetString(GL_VERSION); + sscanf(gl_version, "%d.%d", &major, &minor); + } + bd->GlVersion = (GLuint)(major * 100 + minor * 10); +#else + bd->GlVersion = 200; // GLES 2 +#endif + +#ifdef IMGUI_IMPL_OPENGL_MAY_HAVE_VTX_OFFSET + if (bd->GlVersion >= 320) + io.BackendFlags |= ImGuiBackendFlags_RendererHasVtxOffset; // We can honor the ImDrawCmd::VtxOffset field, allowing for large meshes. +#endif + + // Store GLSL version string so we can refer to it later in case we recreate shaders. + // Note: GLSL version is NOT the same as GL version. Leave this to NULL if unsure. + if (glsl_version == NULL) + { +#if defined(IMGUI_IMPL_OPENGL_ES2) + glsl_version = "#version 100"; +#elif defined(IMGUI_IMPL_OPENGL_ES3) + glsl_version = "#version 300 es"; +#elif defined(__APPLE__) + glsl_version = "#version 150"; +#else + glsl_version = "#version 130"; +#endif + } + IM_ASSERT((int)strlen(glsl_version) + 2 < IM_ARRAYSIZE(bd->GlslVersionString)); + strcpy(bd->GlslVersionString, glsl_version); + strcat(bd->GlslVersionString, "\n"); + + // Make an arbitrary GL call (we don't actually need the result) + // IF YOU GET A CRASH HERE: it probably means the OpenGL function loader didn't do its job. Let us know! + GLint current_texture; + glGetIntegerv(GL_TEXTURE_BINDING_2D, ¤t_texture); + + // Detect extensions we support + bd->HasClipOrigin = (bd->GlVersion >= 450); +#ifdef IMGUI_IMPL_OPENGL_MAY_HAVE_EXTENSIONS + GLint num_extensions = 0; + glGetIntegerv(GL_NUM_EXTENSIONS, &num_extensions); + for (GLint i = 0; i < num_extensions; i++) + { + const char* extension = (const char*)glGetStringi(GL_EXTENSIONS, i); + if (extension != NULL && strcmp(extension, "GL_ARB_clip_control") == 0) + bd->HasClipOrigin = true; + } +#endif + + return true; +} + +void ImGui_ImplOpenGL3_Shutdown() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplOpenGL3_Data* bd = ImGui_ImplOpenGL3_GetBackendData(); + + ImGui_ImplOpenGL3_DestroyDeviceObjects(); + io.BackendRendererName = NULL; + io.BackendRendererUserData = NULL; + IM_DELETE(bd); +} + +void ImGui_ImplOpenGL3_NewFrame() +{ + ImGui_ImplOpenGL3_Data* bd = ImGui_ImplOpenGL3_GetBackendData(); + IM_ASSERT(bd != NULL && "Did you call ImGui_ImplOpenGL3_Init()?"); + + if (!bd->ShaderHandle) + ImGui_ImplOpenGL3_CreateDeviceObjects(); +} + +static void ImGui_ImplOpenGL3_SetupRenderState(ImDrawData* draw_data, int fb_width, int fb_height, GLuint vertex_array_object) +{ + ImGui_ImplOpenGL3_Data* bd = ImGui_ImplOpenGL3_GetBackendData(); + + // Setup render state: alpha-blending enabled, no face culling, no depth testing, scissor enabled, polygon fill + glEnable(GL_BLEND); + glBlendEquation(GL_FUNC_ADD); + glBlendFuncSeparate(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA, GL_ONE, GL_ONE_MINUS_SRC_ALPHA); + glDisable(GL_CULL_FACE); + glDisable(GL_DEPTH_TEST); + glDisable(GL_STENCIL_TEST); + glEnable(GL_SCISSOR_TEST); +#ifdef IMGUI_IMPL_OPENGL_MAY_HAVE_PRIMITIVE_RESTART + if (bd->GlVersion >= 310) + glDisable(GL_PRIMITIVE_RESTART); +#endif +#ifdef IMGUI_IMPL_HAS_POLYGON_MODE + glPolygonMode(GL_FRONT_AND_BACK, GL_FILL); +#endif + + // Support for GL 4.5 rarely used glClipControl(GL_UPPER_LEFT) +#if defined(GL_CLIP_ORIGIN) + bool clip_origin_lower_left = true; + if (bd->HasClipOrigin) + { + GLenum current_clip_origin = 0; glGetIntegerv(GL_CLIP_ORIGIN, (GLint*)¤t_clip_origin); + if (current_clip_origin == GL_UPPER_LEFT) + clip_origin_lower_left = false; + } +#endif + + // Setup viewport, orthographic projection matrix + // Our visible imgui space lies from draw_data->DisplayPos (top left) to draw_data->DisplayPos+data_data->DisplaySize (bottom right). DisplayPos is (0,0) for single viewport apps. + glViewport(0, 0, (GLsizei)fb_width, (GLsizei)fb_height); + float L = draw_data->DisplayPos.x; + float R = draw_data->DisplayPos.x + draw_data->DisplaySize.x; + float T = draw_data->DisplayPos.y; + float B = draw_data->DisplayPos.y + draw_data->DisplaySize.y; +#if defined(GL_CLIP_ORIGIN) + if (!clip_origin_lower_left) { float tmp = T; T = B; B = tmp; } // Swap top and bottom if origin is upper left +#endif + const float ortho_projection[4][4] = + { + { 2.0f/(R-L), 0.0f, 0.0f, 0.0f }, + { 0.0f, 2.0f/(T-B), 0.0f, 0.0f }, + { 0.0f, 0.0f, -1.0f, 0.0f }, + { (R+L)/(L-R), (T+B)/(B-T), 0.0f, 1.0f }, + }; + glUseProgram(bd->ShaderHandle); + glUniform1i(bd->AttribLocationTex, 0); + glUniformMatrix4fv(bd->AttribLocationProjMtx, 1, GL_FALSE, &ortho_projection[0][0]); + +#ifdef IMGUI_IMPL_OPENGL_MAY_HAVE_BIND_SAMPLER + if (bd->GlVersion >= 330) + glBindSampler(0, 0); // We use combined texture/sampler state. Applications using GL 3.3 may set that otherwise. +#endif + + (void)vertex_array_object; +#ifdef IMGUI_IMPL_OPENGL_USE_VERTEX_ARRAY + glBindVertexArray(vertex_array_object); +#endif + + // Bind vertex/index buffers and setup attributes for ImDrawVert + glBindBuffer(GL_ARRAY_BUFFER, bd->VboHandle); + glBindBuffer(GL_ELEMENT_ARRAY_BUFFER, bd->ElementsHandle); + glEnableVertexAttribArray(bd->AttribLocationVtxPos); + glEnableVertexAttribArray(bd->AttribLocationVtxUV); + glEnableVertexAttribArray(bd->AttribLocationVtxColor); + glVertexAttribPointer(bd->AttribLocationVtxPos, 2, GL_FLOAT, GL_FALSE, sizeof(ImDrawVert), (GLvoid*)IM_OFFSETOF(ImDrawVert, pos)); + glVertexAttribPointer(bd->AttribLocationVtxUV, 2, GL_FLOAT, GL_FALSE, sizeof(ImDrawVert), (GLvoid*)IM_OFFSETOF(ImDrawVert, uv)); + glVertexAttribPointer(bd->AttribLocationVtxColor, 4, GL_UNSIGNED_BYTE, GL_TRUE, sizeof(ImDrawVert), (GLvoid*)IM_OFFSETOF(ImDrawVert, col)); +} + +// OpenGL3 Render function. +// Note that this implementation is little overcomplicated because we are saving/setting up/restoring every OpenGL state explicitly. +// This is in order to be able to run within an OpenGL engine that doesn't do so. +void ImGui_ImplOpenGL3_RenderDrawData(ImDrawData* draw_data) +{ + // Avoid rendering when minimized, scale coordinates for retina displays (screen coordinates != framebuffer coordinates) + int fb_width = (int)(draw_data->DisplaySize.x * draw_data->FramebufferScale.x); + int fb_height = (int)(draw_data->DisplaySize.y * draw_data->FramebufferScale.y); + if (fb_width <= 0 || fb_height <= 0) + return; + + ImGui_ImplOpenGL3_Data* bd = ImGui_ImplOpenGL3_GetBackendData(); + + // Backup GL state + GLenum last_active_texture; glGetIntegerv(GL_ACTIVE_TEXTURE, (GLint*)&last_active_texture); + glActiveTexture(GL_TEXTURE0); + GLuint last_program; glGetIntegerv(GL_CURRENT_PROGRAM, (GLint*)&last_program); + GLuint last_texture; glGetIntegerv(GL_TEXTURE_BINDING_2D, (GLint*)&last_texture); +#ifdef IMGUI_IMPL_OPENGL_MAY_HAVE_BIND_SAMPLER + GLuint last_sampler; if (bd->GlVersion >= 330) { glGetIntegerv(GL_SAMPLER_BINDING, (GLint*)&last_sampler); } else { last_sampler = 0; } +#endif + GLuint last_array_buffer; glGetIntegerv(GL_ARRAY_BUFFER_BINDING, (GLint*)&last_array_buffer); +#ifdef IMGUI_IMPL_OPENGL_USE_VERTEX_ARRAY + GLuint last_vertex_array_object; glGetIntegerv(GL_VERTEX_ARRAY_BINDING, (GLint*)&last_vertex_array_object); +#endif +#ifdef IMGUI_IMPL_HAS_POLYGON_MODE + GLint last_polygon_mode[2]; glGetIntegerv(GL_POLYGON_MODE, last_polygon_mode); +#endif + GLint last_viewport[4]; glGetIntegerv(GL_VIEWPORT, last_viewport); + GLint last_scissor_box[4]; glGetIntegerv(GL_SCISSOR_BOX, last_scissor_box); + GLenum last_blend_src_rgb; glGetIntegerv(GL_BLEND_SRC_RGB, (GLint*)&last_blend_src_rgb); + GLenum last_blend_dst_rgb; glGetIntegerv(GL_BLEND_DST_RGB, (GLint*)&last_blend_dst_rgb); + GLenum last_blend_src_alpha; glGetIntegerv(GL_BLEND_SRC_ALPHA, (GLint*)&last_blend_src_alpha); + GLenum last_blend_dst_alpha; glGetIntegerv(GL_BLEND_DST_ALPHA, (GLint*)&last_blend_dst_alpha); + GLenum last_blend_equation_rgb; glGetIntegerv(GL_BLEND_EQUATION_RGB, (GLint*)&last_blend_equation_rgb); + GLenum last_blend_equation_alpha; glGetIntegerv(GL_BLEND_EQUATION_ALPHA, (GLint*)&last_blend_equation_alpha); + GLboolean last_enable_blend = glIsEnabled(GL_BLEND); + GLboolean last_enable_cull_face = glIsEnabled(GL_CULL_FACE); + GLboolean last_enable_depth_test = glIsEnabled(GL_DEPTH_TEST); + GLboolean last_enable_stencil_test = glIsEnabled(GL_STENCIL_TEST); + GLboolean last_enable_scissor_test = glIsEnabled(GL_SCISSOR_TEST); +#ifdef IMGUI_IMPL_OPENGL_MAY_HAVE_PRIMITIVE_RESTART + GLboolean last_enable_primitive_restart = (bd->GlVersion >= 310) ? glIsEnabled(GL_PRIMITIVE_RESTART) : GL_FALSE; +#endif + + // Setup desired GL state + // Recreate the VAO every time (this is to easily allow multiple GL contexts to be rendered to. VAO are not shared among GL contexts) + // The renderer would actually work without any VAO bound, but then our VertexAttrib calls would overwrite the default one currently bound. + GLuint vertex_array_object = 0; +#ifdef IMGUI_IMPL_OPENGL_USE_VERTEX_ARRAY + glGenVertexArrays(1, &vertex_array_object); +#endif + ImGui_ImplOpenGL3_SetupRenderState(draw_data, fb_width, fb_height, vertex_array_object); + + // Will project scissor/clipping rectangles into framebuffer space + ImVec2 clip_off = draw_data->DisplayPos; // (0,0) unless using multi-viewports + ImVec2 clip_scale = draw_data->FramebufferScale; // (1,1) unless using retina display which are often (2,2) + + // Render command lists + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + + // Upload vertex/index buffers + glBufferData(GL_ARRAY_BUFFER, (GLsizeiptr)cmd_list->VtxBuffer.Size * (int)sizeof(ImDrawVert), (const GLvoid*)cmd_list->VtxBuffer.Data, GL_STREAM_DRAW); + glBufferData(GL_ELEMENT_ARRAY_BUFFER, (GLsizeiptr)cmd_list->IdxBuffer.Size * (int)sizeof(ImDrawIdx), (const GLvoid*)cmd_list->IdxBuffer.Data, GL_STREAM_DRAW); + + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + const ImDrawCmd* pcmd = &cmd_list->CmdBuffer[cmd_i]; + if (pcmd->UserCallback != NULL) + { + // User callback, registered via ImDrawList::AddCallback() + // (ImDrawCallback_ResetRenderState is a special callback value used by the user to request the renderer to reset render state.) + if (pcmd->UserCallback == ImDrawCallback_ResetRenderState) + ImGui_ImplOpenGL3_SetupRenderState(draw_data, fb_width, fb_height, vertex_array_object); + else + pcmd->UserCallback(cmd_list, pcmd); + } + else + { + // Project scissor/clipping rectangles into framebuffer space + ImVec2 clip_min((pcmd->ClipRect.x - clip_off.x) * clip_scale.x, (pcmd->ClipRect.y - clip_off.y) * clip_scale.y); + ImVec2 clip_max((pcmd->ClipRect.z - clip_off.x) * clip_scale.x, (pcmd->ClipRect.w - clip_off.y) * clip_scale.y); + if (clip_max.x < clip_min.x || clip_max.y < clip_min.y) + continue; + + // Apply scissor/clipping rectangle (Y is inverted in OpenGL) + glScissor((int)clip_min.x, (int)(fb_height - clip_max.y), (int)(clip_max.x - clip_min.x), (int)(clip_max.y - clip_min.y)); + + // Bind texture, Draw + glBindTexture(GL_TEXTURE_2D, (GLuint)(intptr_t)pcmd->GetTexID()); +#ifdef IMGUI_IMPL_OPENGL_MAY_HAVE_VTX_OFFSET + if (bd->GlVersion >= 320) + glDrawElementsBaseVertex(GL_TRIANGLES, (GLsizei)pcmd->ElemCount, sizeof(ImDrawIdx) == 2 ? GL_UNSIGNED_SHORT : GL_UNSIGNED_INT, (void*)(intptr_t)(pcmd->IdxOffset * sizeof(ImDrawIdx)), (GLint)pcmd->VtxOffset); + else +#endif + glDrawElements(GL_TRIANGLES, (GLsizei)pcmd->ElemCount, sizeof(ImDrawIdx) == 2 ? GL_UNSIGNED_SHORT : GL_UNSIGNED_INT, (void*)(intptr_t)(pcmd->IdxOffset * sizeof(ImDrawIdx))); + } + } + } + + // Destroy the temporary VAO +#ifdef IMGUI_IMPL_OPENGL_USE_VERTEX_ARRAY + glDeleteVertexArrays(1, &vertex_array_object); +#endif + + // Restore modified GL state + glUseProgram(last_program); + glBindTexture(GL_TEXTURE_2D, last_texture); +#ifdef IMGUI_IMPL_OPENGL_MAY_HAVE_BIND_SAMPLER + if (bd->GlVersion >= 330) + glBindSampler(0, last_sampler); +#endif + glActiveTexture(last_active_texture); +#ifdef IMGUI_IMPL_OPENGL_USE_VERTEX_ARRAY + glBindVertexArray(last_vertex_array_object); +#endif + glBindBuffer(GL_ARRAY_BUFFER, last_array_buffer); + glBlendEquationSeparate(last_blend_equation_rgb, last_blend_equation_alpha); + glBlendFuncSeparate(last_blend_src_rgb, last_blend_dst_rgb, last_blend_src_alpha, last_blend_dst_alpha); + if (last_enable_blend) glEnable(GL_BLEND); else glDisable(GL_BLEND); + if (last_enable_cull_face) glEnable(GL_CULL_FACE); else glDisable(GL_CULL_FACE); + if (last_enable_depth_test) glEnable(GL_DEPTH_TEST); else glDisable(GL_DEPTH_TEST); + if (last_enable_stencil_test) glEnable(GL_STENCIL_TEST); else glDisable(GL_STENCIL_TEST); + if (last_enable_scissor_test) glEnable(GL_SCISSOR_TEST); else glDisable(GL_SCISSOR_TEST); +#ifdef IMGUI_IMPL_OPENGL_MAY_HAVE_PRIMITIVE_RESTART + if (bd->GlVersion >= 310) { if (last_enable_primitive_restart) glEnable(GL_PRIMITIVE_RESTART); else glDisable(GL_PRIMITIVE_RESTART); } +#endif + +#ifdef IMGUI_IMPL_HAS_POLYGON_MODE + glPolygonMode(GL_FRONT_AND_BACK, (GLenum)last_polygon_mode[0]); +#endif + glViewport(last_viewport[0], last_viewport[1], (GLsizei)last_viewport[2], (GLsizei)last_viewport[3]); + glScissor(last_scissor_box[0], last_scissor_box[1], (GLsizei)last_scissor_box[2], (GLsizei)last_scissor_box[3]); + (void)bd; // Not all compilation paths use this +} + +bool ImGui_ImplOpenGL3_CreateFontsTexture() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplOpenGL3_Data* bd = ImGui_ImplOpenGL3_GetBackendData(); + + // Build texture atlas + unsigned char* pixels; + int width, height; + io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height); // Load as RGBA 32-bit (75% of the memory is wasted, but default font is so small) because it is more likely to be compatible with user's existing shaders. If your ImTextureId represent a higher-level concept than just a GL texture id, consider calling GetTexDataAsAlpha8() instead to save on GPU memory. + + // Upload texture to graphics system + GLint last_texture; + glGetIntegerv(GL_TEXTURE_BINDING_2D, &last_texture); + glGenTextures(1, &bd->FontTexture); + glBindTexture(GL_TEXTURE_2D, bd->FontTexture); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); +#ifdef GL_UNPACK_ROW_LENGTH // Not on WebGL/ES + glPixelStorei(GL_UNPACK_ROW_LENGTH, 0); +#endif + glTexImage2D(GL_TEXTURE_2D, 0, GL_RGBA, width, height, 0, GL_RGBA, GL_UNSIGNED_BYTE, pixels); + + // Store our identifier + io.Fonts->SetTexID((ImTextureID)(intptr_t)bd->FontTexture); + + // Restore state + glBindTexture(GL_TEXTURE_2D, last_texture); + + return true; +} + +void ImGui_ImplOpenGL3_DestroyFontsTexture() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplOpenGL3_Data* bd = ImGui_ImplOpenGL3_GetBackendData(); + if (bd->FontTexture) + { + glDeleteTextures(1, &bd->FontTexture); + io.Fonts->SetTexID(0); + bd->FontTexture = 0; + } +} + +// If you get an error please report on github. You may try different GL context version or GLSL version. See GL<>GLSL version table at the top of this file. +static bool CheckShader(GLuint handle, const char* desc) +{ + ImGui_ImplOpenGL3_Data* bd = ImGui_ImplOpenGL3_GetBackendData(); + GLint status = 0, log_length = 0; + glGetShaderiv(handle, GL_COMPILE_STATUS, &status); + glGetShaderiv(handle, GL_INFO_LOG_LENGTH, &log_length); + if ((GLboolean)status == GL_FALSE) + fprintf(stderr, "ERROR: ImGui_ImplOpenGL3_CreateDeviceObjects: failed to compile %s! With GLSL: %s\n", desc, bd->GlslVersionString); + if (log_length > 1) + { + ImVector buf; + buf.resize((int)(log_length + 1)); + glGetShaderInfoLog(handle, log_length, NULL, (GLchar*)buf.begin()); + fprintf(stderr, "%s\n", buf.begin()); + } + return (GLboolean)status == GL_TRUE; +} + +// If you get an error please report on GitHub. You may try different GL context version or GLSL version. +static bool CheckProgram(GLuint handle, const char* desc) +{ + ImGui_ImplOpenGL3_Data* bd = ImGui_ImplOpenGL3_GetBackendData(); + GLint status = 0, log_length = 0; + glGetProgramiv(handle, GL_LINK_STATUS, &status); + glGetProgramiv(handle, GL_INFO_LOG_LENGTH, &log_length); + if ((GLboolean)status == GL_FALSE) + fprintf(stderr, "ERROR: ImGui_ImplOpenGL3_CreateDeviceObjects: failed to link %s! With GLSL %s\n", desc, bd->GlslVersionString); + if (log_length > 1) + { + ImVector buf; + buf.resize((int)(log_length + 1)); + glGetProgramInfoLog(handle, log_length, NULL, (GLchar*)buf.begin()); + fprintf(stderr, "%s\n", buf.begin()); + } + return (GLboolean)status == GL_TRUE; +} + +bool ImGui_ImplOpenGL3_CreateDeviceObjects() +{ + ImGui_ImplOpenGL3_Data* bd = ImGui_ImplOpenGL3_GetBackendData(); + + // Backup GL state + GLint last_texture, last_array_buffer; + glGetIntegerv(GL_TEXTURE_BINDING_2D, &last_texture); + glGetIntegerv(GL_ARRAY_BUFFER_BINDING, &last_array_buffer); +#ifdef IMGUI_IMPL_OPENGL_USE_VERTEX_ARRAY + GLint last_vertex_array; + glGetIntegerv(GL_VERTEX_ARRAY_BINDING, &last_vertex_array); +#endif + + // Parse GLSL version string + int glsl_version = 130; + sscanf(bd->GlslVersionString, "#version %d", &glsl_version); + + const GLchar* vertex_shader_glsl_120 = + "uniform mat4 ProjMtx;\n" + "attribute vec2 Position;\n" + "attribute vec2 UV;\n" + "attribute vec4 Color;\n" + "varying vec2 Frag_UV;\n" + "varying vec4 Frag_Color;\n" + "void main()\n" + "{\n" + " Frag_UV = UV;\n" + " Frag_Color = Color;\n" + " gl_Position = ProjMtx * vec4(Position.xy,0,1);\n" + "}\n"; + + const GLchar* vertex_shader_glsl_130 = + "uniform mat4 ProjMtx;\n" + "in vec2 Position;\n" + "in vec2 UV;\n" + "in vec4 Color;\n" + "out vec2 Frag_UV;\n" + "out vec4 Frag_Color;\n" + "void main()\n" + "{\n" + " Frag_UV = UV;\n" + " Frag_Color = Color;\n" + " gl_Position = ProjMtx * vec4(Position.xy,0,1);\n" + "}\n"; + + const GLchar* vertex_shader_glsl_300_es = + "precision highp float;\n" + "layout (location = 0) in vec2 Position;\n" + "layout (location = 1) in vec2 UV;\n" + "layout (location = 2) in vec4 Color;\n" + "uniform mat4 ProjMtx;\n" + "out vec2 Frag_UV;\n" + "out vec4 Frag_Color;\n" + "void main()\n" + "{\n" + " Frag_UV = UV;\n" + " Frag_Color = Color;\n" + " gl_Position = ProjMtx * vec4(Position.xy,0,1);\n" + "}\n"; + + const GLchar* vertex_shader_glsl_410_core = + "layout (location = 0) in vec2 Position;\n" + "layout (location = 1) in vec2 UV;\n" + "layout (location = 2) in vec4 Color;\n" + "uniform mat4 ProjMtx;\n" + "out vec2 Frag_UV;\n" + "out vec4 Frag_Color;\n" + "void main()\n" + "{\n" + " Frag_UV = UV;\n" + " Frag_Color = Color;\n" + " gl_Position = ProjMtx * vec4(Position.xy,0,1);\n" + "}\n"; + + const GLchar* fragment_shader_glsl_120 = + "#ifdef GL_ES\n" + " precision mediump float;\n" + "#endif\n" + "uniform sampler2D Texture;\n" + "varying vec2 Frag_UV;\n" + "varying vec4 Frag_Color;\n" + "void main()\n" + "{\n" + " gl_FragColor = Frag_Color * texture2D(Texture, Frag_UV.st);\n" + "}\n"; + + const GLchar* fragment_shader_glsl_130 = + "uniform sampler2D Texture;\n" + "in vec2 Frag_UV;\n" + "in vec4 Frag_Color;\n" + "out vec4 Out_Color;\n" + "void main()\n" + "{\n" + " Out_Color = Frag_Color * texture(Texture, Frag_UV.st);\n" + "}\n"; + + const GLchar* fragment_shader_glsl_300_es = + "precision mediump float;\n" + "uniform sampler2D Texture;\n" + "in vec2 Frag_UV;\n" + "in vec4 Frag_Color;\n" + "layout (location = 0) out vec4 Out_Color;\n" + "void main()\n" + "{\n" + " Out_Color = Frag_Color * texture(Texture, Frag_UV.st);\n" + "}\n"; + + const GLchar* fragment_shader_glsl_410_core = + "in vec2 Frag_UV;\n" + "in vec4 Frag_Color;\n" + "uniform sampler2D Texture;\n" + "layout (location = 0) out vec4 Out_Color;\n" + "void main()\n" + "{\n" + " Out_Color = Frag_Color * texture(Texture, Frag_UV.st);\n" + "}\n"; + + // Select shaders matching our GLSL versions + const GLchar* vertex_shader = NULL; + const GLchar* fragment_shader = NULL; + if (glsl_version < 130) + { + vertex_shader = vertex_shader_glsl_120; + fragment_shader = fragment_shader_glsl_120; + } + else if (glsl_version >= 410) + { + vertex_shader = vertex_shader_glsl_410_core; + fragment_shader = fragment_shader_glsl_410_core; + } + else if (glsl_version == 300) + { + vertex_shader = vertex_shader_glsl_300_es; + fragment_shader = fragment_shader_glsl_300_es; + } + else + { + vertex_shader = vertex_shader_glsl_130; + fragment_shader = fragment_shader_glsl_130; + } + + // Create shaders + const GLchar* vertex_shader_with_version[2] = { bd->GlslVersionString, vertex_shader }; + GLuint vert_handle = glCreateShader(GL_VERTEX_SHADER); + glShaderSource(vert_handle, 2, vertex_shader_with_version, NULL); + glCompileShader(vert_handle); + CheckShader(vert_handle, "vertex shader"); + + const GLchar* fragment_shader_with_version[2] = { bd->GlslVersionString, fragment_shader }; + GLuint frag_handle = glCreateShader(GL_FRAGMENT_SHADER); + glShaderSource(frag_handle, 2, fragment_shader_with_version, NULL); + glCompileShader(frag_handle); + CheckShader(frag_handle, "fragment shader"); + + // Link + bd->ShaderHandle = glCreateProgram(); + glAttachShader(bd->ShaderHandle, vert_handle); + glAttachShader(bd->ShaderHandle, frag_handle); + glLinkProgram(bd->ShaderHandle); + CheckProgram(bd->ShaderHandle, "shader program"); + + glDetachShader(bd->ShaderHandle, vert_handle); + glDetachShader(bd->ShaderHandle, frag_handle); + glDeleteShader(vert_handle); + glDeleteShader(frag_handle); + + bd->AttribLocationTex = glGetUniformLocation(bd->ShaderHandle, "Texture"); + bd->AttribLocationProjMtx = glGetUniformLocation(bd->ShaderHandle, "ProjMtx"); + bd->AttribLocationVtxPos = (GLuint)glGetAttribLocation(bd->ShaderHandle, "Position"); + bd->AttribLocationVtxUV = (GLuint)glGetAttribLocation(bd->ShaderHandle, "UV"); + bd->AttribLocationVtxColor = (GLuint)glGetAttribLocation(bd->ShaderHandle, "Color"); + + // Create buffers + glGenBuffers(1, &bd->VboHandle); + glGenBuffers(1, &bd->ElementsHandle); + + ImGui_ImplOpenGL3_CreateFontsTexture(); + + // Restore modified GL state + glBindTexture(GL_TEXTURE_2D, last_texture); + glBindBuffer(GL_ARRAY_BUFFER, last_array_buffer); +#ifdef IMGUI_IMPL_OPENGL_USE_VERTEX_ARRAY + glBindVertexArray(last_vertex_array); +#endif + + return true; +} + +void ImGui_ImplOpenGL3_DestroyDeviceObjects() +{ + ImGui_ImplOpenGL3_Data* bd = ImGui_ImplOpenGL3_GetBackendData(); + if (bd->VboHandle) { glDeleteBuffers(1, &bd->VboHandle); bd->VboHandle = 0; } + if (bd->ElementsHandle) { glDeleteBuffers(1, &bd->ElementsHandle); bd->ElementsHandle = 0; } + if (bd->ShaderHandle) { glDeleteProgram(bd->ShaderHandle); bd->ShaderHandle = 0; } + ImGui_ImplOpenGL3_DestroyFontsTexture(); +} diff --git a/source/editor/imgui/backends/imgui_impl_opengl3.h b/source/editor/imgui/backends/imgui_impl_opengl3.h new file mode 100644 index 0000000..98c9aca --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_opengl3.h @@ -0,0 +1,55 @@ +// dear imgui: Renderer Backend for modern OpenGL with shaders / programmatic pipeline +// - Desktop GL: 2.x 3.x 4.x +// - Embedded GL: ES 2.0 (WebGL 1.0), ES 3.0 (WebGL 2.0) +// This needs to be used along with a Platform Backend (e.g. GLFW, SDL, Win32, custom..) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'GLuint' OpenGL texture identifier as void*/ImTextureID. Read the FAQ about ImTextureID! +// [x] Renderer: Desktop GL only: Support for large meshes (64k+ vertices) with 16-bit indices. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// About GLSL version: +// The 'glsl_version' initialization parameter should be NULL (default) or a "#version XXX" string. +// On computer platform the GLSL version default to "#version 130". On OpenGL ES 3 platform it defaults to "#version 300 es" +// Only override if your GL version doesn't handle this GLSL version. See GLSL version table at the top of imgui_impl_opengl3.cpp. + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +// Backend API +IMGUI_IMPL_API bool ImGui_ImplOpenGL3_Init(const char* glsl_version = NULL); +IMGUI_IMPL_API void ImGui_ImplOpenGL3_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplOpenGL3_NewFrame(); +IMGUI_IMPL_API void ImGui_ImplOpenGL3_RenderDrawData(ImDrawData* draw_data); + +// (Optional) Called by Init/NewFrame/Shutdown +IMGUI_IMPL_API bool ImGui_ImplOpenGL3_CreateFontsTexture(); +IMGUI_IMPL_API void ImGui_ImplOpenGL3_DestroyFontsTexture(); +IMGUI_IMPL_API bool ImGui_ImplOpenGL3_CreateDeviceObjects(); +IMGUI_IMPL_API void ImGui_ImplOpenGL3_DestroyDeviceObjects(); + +// Specific OpenGL ES versions +//#define IMGUI_IMPL_OPENGL_ES2 // Auto-detected on Emscripten +//#define IMGUI_IMPL_OPENGL_ES3 // Auto-detected on iOS/Android + +// You can explicitly select GLES2 or GLES3 API by using one of the '#define IMGUI_IMPL_OPENGL_LOADER_XXX' in imconfig.h or compiler command-line. +#if !defined(IMGUI_IMPL_OPENGL_ES2) \ + && !defined(IMGUI_IMPL_OPENGL_ES3) + +// Try to detect GLES on matching platforms +#if defined(__APPLE__) +#include +#endif +#if (defined(__APPLE__) && (TARGET_OS_IOS || TARGET_OS_TV)) || (defined(__ANDROID__)) +#define IMGUI_IMPL_OPENGL_ES3 // iOS, Android -> GL ES 3, "#version 300 es" +#elif defined(__EMSCRIPTEN__) +#define IMGUI_IMPL_OPENGL_ES2 // Emscripten -> GL ES 2, "#version 100" +#else +// Otherwise imgui_impl_opengl3_loader.h will be used. +#endif + +#endif diff --git a/source/editor/imgui/backends/imgui_impl_opengl3_loader.h b/source/editor/imgui/backends/imgui_impl_opengl3_loader.h new file mode 100644 index 0000000..9313ded --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_opengl3_loader.h @@ -0,0 +1,752 @@ +//----------------------------------------------------------------------------- +// About imgui_impl_opengl3_loader.h: +// +// We embed our own OpenGL loader to not require user to provide their own or to have to use ours, +// which proved to be endless problems for users. +// Our loader is custom-generated, based on gl3w but automatically filtered to only include +// enums/functions that we use in our imgui_impl_opengl3.cpp source file in order to be small. +// +// YOU SHOULD NOT NEED TO INCLUDE/USE THIS DIRECTLY. THIS IS USED BY imgui_impl_opengl3.cpp ONLY. +// THE REST OF YOUR APP SHOULD USE A DIFFERENT GL LOADER: ANY GL LOADER OF YOUR CHOICE. +// +// Regenerate with: +// python gl3w_gen.py --output ../imgui/backends/imgui_impl_opengl3_loader.h --ref ../imgui/backends/imgui_impl_opengl3.cpp ./extra_symbols.txt +// +// More info: +// https://github.com/dearimgui/gl3w_stripped +// https://github.com/ocornut/imgui/issues/4445 +//----------------------------------------------------------------------------- + +/* + * This file was generated with gl3w_gen.py, part of imgl3w + * (hosted at https://github.com/dearimgui/gl3w_stripped) + * + * This is free and unencumbered software released into the public domain. + * + * Anyone is free to copy, modify, publish, use, compile, sell, or + * distribute this software, either in source code form or as a compiled + * binary, for any purpose, commercial or non-commercial, and by any + * means. + * + * In jurisdictions that recognize copyright laws, the author or authors + * of this software dedicate any and all copyright interest in the + * software to the public domain. We make this dedication for the benefit + * of the public at large and to the detriment of our heirs and + * successors. We intend this dedication to be an overt act of + * relinquishment in perpetuity of all present and future rights to this + * software under copyright law. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR + * OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, + * ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + * OTHER DEALINGS IN THE SOFTWARE. + */ + +#ifndef __gl3w_h_ +#define __gl3w_h_ + +// Adapted from KHR/khrplatform.h to avoid including entire file. +#ifndef __khrplatform_h_ +typedef float khronos_float_t; +typedef signed char khronos_int8_t; +typedef unsigned char khronos_uint8_t; +typedef signed short int khronos_int16_t; +typedef unsigned short int khronos_uint16_t; +#ifdef _WIN64 +typedef signed long long int khronos_intptr_t; +typedef signed long long int khronos_ssize_t; +#else +typedef signed long int khronos_intptr_t; +typedef signed long int khronos_ssize_t; +#endif + +#if defined(_MSC_VER) && !defined(__clang__) +typedef signed __int64 khronos_int64_t; +typedef unsigned __int64 khronos_uint64_t; +#elif (defined(__clang__) || defined(__GNUC__)) && (__cplusplus < 201100) +#include +typedef int64_t khronos_int64_t; +typedef uint64_t khronos_uint64_t; +#else +typedef signed long long khronos_int64_t; +typedef unsigned long long khronos_uint64_t; +#endif +#endif // __khrplatform_h_ + +#ifndef __gl_glcorearb_h_ +#define __gl_glcorearb_h_ 1 +#ifdef __cplusplus +extern "C" { +#endif +/* +** Copyright 2013-2020 The Khronos Group Inc. +** SPDX-License-Identifier: MIT +** +** This header is generated from the Khronos OpenGL / OpenGL ES XML +** API Registry. The current version of the Registry, generator scripts +** used to make the header, and the header can be found at +** https://github.com/KhronosGroup/OpenGL-Registry +*/ +#if defined(_WIN32) && !defined(APIENTRY) && !defined(__CYGWIN__) && !defined(__SCITECH_SNAP__) +#ifndef WIN32_LEAN_AND_MEAN +#define WIN32_LEAN_AND_MEAN 1 +#endif +#include +#endif +#ifndef APIENTRY +#define APIENTRY +#endif +#ifndef APIENTRYP +#define APIENTRYP APIENTRY * +#endif +#ifndef GLAPI +#define GLAPI extern +#endif +/* glcorearb.h is for use with OpenGL core profile implementations. +** It should should be placed in the same directory as gl.h and +** included as . +** +** glcorearb.h includes only APIs in the latest OpenGL core profile +** implementation together with APIs in newer ARB extensions which +** can be supported by the core profile. It does not, and never will +** include functionality removed from the core profile, such as +** fixed-function vertex and fragment processing. +** +** Do not #include both and either of or +** in the same source file. +*/ +/* Generated C header for: + * API: gl + * Profile: core + * Versions considered: .* + * Versions emitted: .* + * Default extensions included: glcore + * Additional extensions included: _nomatch_^ + * Extensions removed: _nomatch_^ + */ +#ifndef GL_VERSION_1_0 +typedef void GLvoid; +typedef unsigned int GLenum; + +typedef khronos_float_t GLfloat; +typedef int GLint; +typedef int GLsizei; +typedef unsigned int GLbitfield; +typedef double GLdouble; +typedef unsigned int GLuint; +typedef unsigned char GLboolean; +typedef khronos_uint8_t GLubyte; +#define GL_COLOR_BUFFER_BIT 0x00004000 +#define GL_FALSE 0 +#define GL_TRUE 1 +#define GL_TRIANGLES 0x0004 +#define GL_ONE 1 +#define GL_SRC_ALPHA 0x0302 +#define GL_ONE_MINUS_SRC_ALPHA 0x0303 +#define GL_FRONT_AND_BACK 0x0408 +#define GL_POLYGON_MODE 0x0B40 +#define GL_CULL_FACE 0x0B44 +#define GL_DEPTH_TEST 0x0B71 +#define GL_STENCIL_TEST 0x0B90 +#define GL_VIEWPORT 0x0BA2 +#define GL_BLEND 0x0BE2 +#define GL_SCISSOR_BOX 0x0C10 +#define GL_SCISSOR_TEST 0x0C11 +#define GL_UNPACK_ROW_LENGTH 0x0CF2 +#define GL_PACK_ALIGNMENT 0x0D05 +#define GL_TEXTURE_2D 0x0DE1 +#define GL_UNSIGNED_BYTE 0x1401 +#define GL_UNSIGNED_SHORT 0x1403 +#define GL_UNSIGNED_INT 0x1405 +#define GL_FLOAT 0x1406 +#define GL_RGBA 0x1908 +#define GL_FILL 0x1B02 +#define GL_VERSION 0x1F02 +#define GL_EXTENSIONS 0x1F03 +#define GL_LINEAR 0x2601 +#define GL_TEXTURE_MAG_FILTER 0x2800 +#define GL_TEXTURE_MIN_FILTER 0x2801 +typedef void (APIENTRYP PFNGLPOLYGONMODEPROC) (GLenum face, GLenum mode); +typedef void (APIENTRYP PFNGLSCISSORPROC) (GLint x, GLint y, GLsizei width, GLsizei height); +typedef void (APIENTRYP PFNGLTEXPARAMETERIPROC) (GLenum target, GLenum pname, GLint param); +typedef void (APIENTRYP PFNGLTEXIMAGE2DPROC) (GLenum target, GLint level, GLint internalformat, GLsizei width, GLsizei height, GLint border, GLenum format, GLenum type, const void *pixels); +typedef void (APIENTRYP PFNGLCLEARPROC) (GLbitfield mask); +typedef void (APIENTRYP PFNGLCLEARCOLORPROC) (GLfloat red, GLfloat green, GLfloat blue, GLfloat alpha); +typedef void (APIENTRYP PFNGLDISABLEPROC) (GLenum cap); +typedef void (APIENTRYP PFNGLENABLEPROC) (GLenum cap); +typedef void (APIENTRYP PFNGLPIXELSTOREIPROC) (GLenum pname, GLint param); +typedef void (APIENTRYP PFNGLREADPIXELSPROC) (GLint x, GLint y, GLsizei width, GLsizei height, GLenum format, GLenum type, void *pixels); +typedef GLenum (APIENTRYP PFNGLGETERRORPROC) (void); +typedef void (APIENTRYP PFNGLGETINTEGERVPROC) (GLenum pname, GLint *data); +typedef const GLubyte *(APIENTRYP PFNGLGETSTRINGPROC) (GLenum name); +typedef GLboolean (APIENTRYP PFNGLISENABLEDPROC) (GLenum cap); +typedef void (APIENTRYP PFNGLVIEWPORTPROC) (GLint x, GLint y, GLsizei width, GLsizei height); +#ifdef GL_GLEXT_PROTOTYPES +GLAPI void APIENTRY glPolygonMode (GLenum face, GLenum mode); +GLAPI void APIENTRY glScissor (GLint x, GLint y, GLsizei width, GLsizei height); +GLAPI void APIENTRY glTexParameteri (GLenum target, GLenum pname, GLint param); +GLAPI void APIENTRY glTexImage2D (GLenum target, GLint level, GLint internalformat, GLsizei width, GLsizei height, GLint border, GLenum format, GLenum type, const void *pixels); +GLAPI void APIENTRY glClear (GLbitfield mask); +GLAPI void APIENTRY glClearColor (GLfloat red, GLfloat green, GLfloat blue, GLfloat alpha); +GLAPI void APIENTRY glDisable (GLenum cap); +GLAPI void APIENTRY glEnable (GLenum cap); +GLAPI void APIENTRY glPixelStorei (GLenum pname, GLint param); +GLAPI void APIENTRY glReadPixels (GLint x, GLint y, GLsizei width, GLsizei height, GLenum format, GLenum type, void *pixels); +GLAPI GLenum APIENTRY glGetError (void); +GLAPI void APIENTRY glGetIntegerv (GLenum pname, GLint *data); +GLAPI const GLubyte *APIENTRY glGetString (GLenum name); +GLAPI GLboolean APIENTRY glIsEnabled (GLenum cap); +GLAPI void APIENTRY glViewport (GLint x, GLint y, GLsizei width, GLsizei height); +#endif +#endif /* GL_VERSION_1_0 */ +#ifndef GL_VERSION_1_1 +typedef khronos_float_t GLclampf; +typedef double GLclampd; +#define GL_TEXTURE_BINDING_2D 0x8069 +typedef void (APIENTRYP PFNGLDRAWELEMENTSPROC) (GLenum mode, GLsizei count, GLenum type, const void *indices); +typedef void (APIENTRYP PFNGLBINDTEXTUREPROC) (GLenum target, GLuint texture); +typedef void (APIENTRYP PFNGLDELETETEXTURESPROC) (GLsizei n, const GLuint *textures); +typedef void (APIENTRYP PFNGLGENTEXTURESPROC) (GLsizei n, GLuint *textures); +#ifdef GL_GLEXT_PROTOTYPES +GLAPI void APIENTRY glDrawElements (GLenum mode, GLsizei count, GLenum type, const void *indices); +GLAPI void APIENTRY glBindTexture (GLenum target, GLuint texture); +GLAPI void APIENTRY glDeleteTextures (GLsizei n, const GLuint *textures); +GLAPI void APIENTRY glGenTextures (GLsizei n, GLuint *textures); +#endif +#endif /* GL_VERSION_1_1 */ +#ifndef GL_VERSION_1_3 +#define GL_TEXTURE0 0x84C0 +#define GL_ACTIVE_TEXTURE 0x84E0 +typedef void (APIENTRYP PFNGLACTIVETEXTUREPROC) (GLenum texture); +#ifdef GL_GLEXT_PROTOTYPES +GLAPI void APIENTRY glActiveTexture (GLenum texture); +#endif +#endif /* GL_VERSION_1_3 */ +#ifndef GL_VERSION_1_4 +#define GL_BLEND_DST_RGB 0x80C8 +#define GL_BLEND_SRC_RGB 0x80C9 +#define GL_BLEND_DST_ALPHA 0x80CA +#define GL_BLEND_SRC_ALPHA 0x80CB +#define GL_FUNC_ADD 0x8006 +typedef void (APIENTRYP PFNGLBLENDFUNCSEPARATEPROC) (GLenum sfactorRGB, GLenum dfactorRGB, GLenum sfactorAlpha, GLenum dfactorAlpha); +typedef void (APIENTRYP PFNGLBLENDEQUATIONPROC) (GLenum mode); +#ifdef GL_GLEXT_PROTOTYPES +GLAPI void APIENTRY glBlendFuncSeparate (GLenum sfactorRGB, GLenum dfactorRGB, GLenum sfactorAlpha, GLenum dfactorAlpha); +GLAPI void APIENTRY glBlendEquation (GLenum mode); +#endif +#endif /* GL_VERSION_1_4 */ +#ifndef GL_VERSION_1_5 +typedef khronos_ssize_t GLsizeiptr; +typedef khronos_intptr_t GLintptr; +#define GL_ARRAY_BUFFER 0x8892 +#define GL_ELEMENT_ARRAY_BUFFER 0x8893 +#define GL_ARRAY_BUFFER_BINDING 0x8894 +#define GL_STREAM_DRAW 0x88E0 +typedef void (APIENTRYP PFNGLBINDBUFFERPROC) (GLenum target, GLuint buffer); +typedef void (APIENTRYP PFNGLDELETEBUFFERSPROC) (GLsizei n, const GLuint *buffers); +typedef void (APIENTRYP PFNGLGENBUFFERSPROC) (GLsizei n, GLuint *buffers); +typedef void (APIENTRYP PFNGLBUFFERDATAPROC) (GLenum target, GLsizeiptr size, const void *data, GLenum usage); +#ifdef GL_GLEXT_PROTOTYPES +GLAPI void APIENTRY glBindBuffer (GLenum target, GLuint buffer); +GLAPI void APIENTRY glDeleteBuffers (GLsizei n, const GLuint *buffers); +GLAPI void APIENTRY glGenBuffers (GLsizei n, GLuint *buffers); +GLAPI void APIENTRY glBufferData (GLenum target, GLsizeiptr size, const void *data, GLenum usage); +#endif +#endif /* GL_VERSION_1_5 */ +#ifndef GL_VERSION_2_0 +typedef char GLchar; +typedef khronos_int16_t GLshort; +typedef khronos_int8_t GLbyte; +typedef khronos_uint16_t GLushort; +#define GL_BLEND_EQUATION_RGB 0x8009 +#define GL_BLEND_EQUATION_ALPHA 0x883D +#define GL_FRAGMENT_SHADER 0x8B30 +#define GL_VERTEX_SHADER 0x8B31 +#define GL_COMPILE_STATUS 0x8B81 +#define GL_LINK_STATUS 0x8B82 +#define GL_INFO_LOG_LENGTH 0x8B84 +#define GL_CURRENT_PROGRAM 0x8B8D +#define GL_UPPER_LEFT 0x8CA2 +typedef void (APIENTRYP PFNGLBLENDEQUATIONSEPARATEPROC) (GLenum modeRGB, GLenum modeAlpha); +typedef void (APIENTRYP PFNGLATTACHSHADERPROC) (GLuint program, GLuint shader); +typedef void (APIENTRYP PFNGLCOMPILESHADERPROC) (GLuint shader); +typedef GLuint (APIENTRYP PFNGLCREATEPROGRAMPROC) (void); +typedef GLuint (APIENTRYP PFNGLCREATESHADERPROC) (GLenum type); +typedef void (APIENTRYP PFNGLDELETEPROGRAMPROC) (GLuint program); +typedef void (APIENTRYP PFNGLDELETESHADERPROC) (GLuint shader); +typedef void (APIENTRYP PFNGLDETACHSHADERPROC) (GLuint program, GLuint shader); +typedef void (APIENTRYP PFNGLENABLEVERTEXATTRIBARRAYPROC) (GLuint index); +typedef GLint (APIENTRYP PFNGLGETATTRIBLOCATIONPROC) (GLuint program, const GLchar *name); +typedef void (APIENTRYP PFNGLGETPROGRAMIVPROC) (GLuint program, GLenum pname, GLint *params); +typedef void (APIENTRYP PFNGLGETPROGRAMINFOLOGPROC) (GLuint program, GLsizei bufSize, GLsizei *length, GLchar *infoLog); +typedef void (APIENTRYP PFNGLGETSHADERIVPROC) (GLuint shader, GLenum pname, GLint *params); +typedef void (APIENTRYP PFNGLGETSHADERINFOLOGPROC) (GLuint shader, GLsizei bufSize, GLsizei *length, GLchar *infoLog); +typedef GLint (APIENTRYP PFNGLGETUNIFORMLOCATIONPROC) (GLuint program, const GLchar *name); +typedef void (APIENTRYP PFNGLLINKPROGRAMPROC) (GLuint program); +typedef void (APIENTRYP PFNGLSHADERSOURCEPROC) (GLuint shader, GLsizei count, const GLchar *const*string, const GLint *length); +typedef void (APIENTRYP PFNGLUSEPROGRAMPROC) (GLuint program); +typedef void (APIENTRYP PFNGLUNIFORM1IPROC) (GLint location, GLint v0); +typedef void (APIENTRYP PFNGLUNIFORMMATRIX4FVPROC) (GLint location, GLsizei count, GLboolean transpose, const GLfloat *value); +typedef void (APIENTRYP PFNGLVERTEXATTRIBPOINTERPROC) (GLuint index, GLint size, GLenum type, GLboolean normalized, GLsizei stride, const void *pointer); +#ifdef GL_GLEXT_PROTOTYPES +GLAPI void APIENTRY glBlendEquationSeparate (GLenum modeRGB, GLenum modeAlpha); +GLAPI void APIENTRY glAttachShader (GLuint program, GLuint shader); +GLAPI void APIENTRY glCompileShader (GLuint shader); +GLAPI GLuint APIENTRY glCreateProgram (void); +GLAPI GLuint APIENTRY glCreateShader (GLenum type); +GLAPI void APIENTRY glDeleteProgram (GLuint program); +GLAPI void APIENTRY glDeleteShader (GLuint shader); +GLAPI void APIENTRY glDetachShader (GLuint program, GLuint shader); +GLAPI void APIENTRY glEnableVertexAttribArray (GLuint index); +GLAPI GLint APIENTRY glGetAttribLocation (GLuint program, const GLchar *name); +GLAPI void APIENTRY glGetProgramiv (GLuint program, GLenum pname, GLint *params); +GLAPI void APIENTRY glGetProgramInfoLog (GLuint program, GLsizei bufSize, GLsizei *length, GLchar *infoLog); +GLAPI void APIENTRY glGetShaderiv (GLuint shader, GLenum pname, GLint *params); +GLAPI void APIENTRY glGetShaderInfoLog (GLuint shader, GLsizei bufSize, GLsizei *length, GLchar *infoLog); +GLAPI GLint APIENTRY glGetUniformLocation (GLuint program, const GLchar *name); +GLAPI void APIENTRY glLinkProgram (GLuint program); +GLAPI void APIENTRY glShaderSource (GLuint shader, GLsizei count, const GLchar *const*string, const GLint *length); +GLAPI void APIENTRY glUseProgram (GLuint program); +GLAPI void APIENTRY glUniform1i (GLint location, GLint v0); +GLAPI void APIENTRY glUniformMatrix4fv (GLint location, GLsizei count, GLboolean transpose, const GLfloat *value); +GLAPI void APIENTRY glVertexAttribPointer (GLuint index, GLint size, GLenum type, GLboolean normalized, GLsizei stride, const void *pointer); +#endif +#endif /* GL_VERSION_2_0 */ +#ifndef GL_VERSION_3_0 +typedef khronos_uint16_t GLhalf; +#define GL_MAJOR_VERSION 0x821B +#define GL_MINOR_VERSION 0x821C +#define GL_NUM_EXTENSIONS 0x821D +#define GL_FRAMEBUFFER_SRGB 0x8DB9 +#define GL_VERTEX_ARRAY_BINDING 0x85B5 +typedef void (APIENTRYP PFNGLGETBOOLEANI_VPROC) (GLenum target, GLuint index, GLboolean *data); +typedef void (APIENTRYP PFNGLGETINTEGERI_VPROC) (GLenum target, GLuint index, GLint *data); +typedef const GLubyte *(APIENTRYP PFNGLGETSTRINGIPROC) (GLenum name, GLuint index); +typedef void (APIENTRYP PFNGLBINDVERTEXARRAYPROC) (GLuint array); +typedef void (APIENTRYP PFNGLDELETEVERTEXARRAYSPROC) (GLsizei n, const GLuint *arrays); +typedef void (APIENTRYP PFNGLGENVERTEXARRAYSPROC) (GLsizei n, GLuint *arrays); +#ifdef GL_GLEXT_PROTOTYPES +GLAPI const GLubyte *APIENTRY glGetStringi (GLenum name, GLuint index); +GLAPI void APIENTRY glBindVertexArray (GLuint array); +GLAPI void APIENTRY glDeleteVertexArrays (GLsizei n, const GLuint *arrays); +GLAPI void APIENTRY glGenVertexArrays (GLsizei n, GLuint *arrays); +#endif +#endif /* GL_VERSION_3_0 */ +#ifndef GL_VERSION_3_1 +#define GL_VERSION_3_1 1 +#define GL_PRIMITIVE_RESTART 0x8F9D +#endif /* GL_VERSION_3_1 */ +#ifndef GL_VERSION_3_2 +#define GL_VERSION_3_2 1 +typedef struct __GLsync *GLsync; +typedef khronos_uint64_t GLuint64; +typedef khronos_int64_t GLint64; +typedef void (APIENTRYP PFNGLDRAWELEMENTSBASEVERTEXPROC) (GLenum mode, GLsizei count, GLenum type, const void *indices, GLint basevertex); +typedef void (APIENTRYP PFNGLGETINTEGER64I_VPROC) (GLenum target, GLuint index, GLint64 *data); +#ifdef GL_GLEXT_PROTOTYPES +GLAPI void APIENTRY glDrawElementsBaseVertex (GLenum mode, GLsizei count, GLenum type, const void *indices, GLint basevertex); +#endif +#endif /* GL_VERSION_3_2 */ +#ifndef GL_VERSION_3_3 +#define GL_VERSION_3_3 1 +#define GL_SAMPLER_BINDING 0x8919 +typedef void (APIENTRYP PFNGLBINDSAMPLERPROC) (GLuint unit, GLuint sampler); +#ifdef GL_GLEXT_PROTOTYPES +GLAPI void APIENTRY glBindSampler (GLuint unit, GLuint sampler); +#endif +#endif /* GL_VERSION_3_3 */ +#ifndef GL_VERSION_4_1 +typedef void (APIENTRYP PFNGLGETFLOATI_VPROC) (GLenum target, GLuint index, GLfloat *data); +typedef void (APIENTRYP PFNGLGETDOUBLEI_VPROC) (GLenum target, GLuint index, GLdouble *data); +#endif /* GL_VERSION_4_1 */ +#ifndef GL_VERSION_4_3 +typedef void (APIENTRY *GLDEBUGPROC)(GLenum source,GLenum type,GLuint id,GLenum severity,GLsizei length,const GLchar *message,const void *userParam); +#endif /* GL_VERSION_4_3 */ +#ifndef GL_VERSION_4_5 +#define GL_CLIP_ORIGIN 0x935C +typedef void (APIENTRYP PFNGLGETTRANSFORMFEEDBACKI_VPROC) (GLuint xfb, GLenum pname, GLuint index, GLint *param); +typedef void (APIENTRYP PFNGLGETTRANSFORMFEEDBACKI64_VPROC) (GLuint xfb, GLenum pname, GLuint index, GLint64 *param); +#endif /* GL_VERSION_4_5 */ +#ifndef GL_ARB_bindless_texture +typedef khronos_uint64_t GLuint64EXT; +#endif /* GL_ARB_bindless_texture */ +#ifndef GL_ARB_cl_event +struct _cl_context; +struct _cl_event; +#endif /* GL_ARB_cl_event */ +#ifndef GL_ARB_clip_control +#define GL_ARB_clip_control 1 +#endif /* GL_ARB_clip_control */ +#ifndef GL_ARB_debug_output +typedef void (APIENTRY *GLDEBUGPROCARB)(GLenum source,GLenum type,GLuint id,GLenum severity,GLsizei length,const GLchar *message,const void *userParam); +#endif /* GL_ARB_debug_output */ +#ifndef GL_EXT_EGL_image_storage +typedef void *GLeglImageOES; +#endif /* GL_EXT_EGL_image_storage */ +#ifndef GL_EXT_direct_state_access +typedef void (APIENTRYP PFNGLGETFLOATI_VEXTPROC) (GLenum pname, GLuint index, GLfloat *params); +typedef void (APIENTRYP PFNGLGETDOUBLEI_VEXTPROC) (GLenum pname, GLuint index, GLdouble *params); +typedef void (APIENTRYP PFNGLGETPOINTERI_VEXTPROC) (GLenum pname, GLuint index, void **params); +typedef void (APIENTRYP PFNGLGETVERTEXARRAYINTEGERI_VEXTPROC) (GLuint vaobj, GLuint index, GLenum pname, GLint *param); +typedef void (APIENTRYP PFNGLGETVERTEXARRAYPOINTERI_VEXTPROC) (GLuint vaobj, GLuint index, GLenum pname, void **param); +#endif /* GL_EXT_direct_state_access */ +#ifndef GL_NV_draw_vulkan_image +typedef void (APIENTRY *GLVULKANPROCNV)(void); +#endif /* GL_NV_draw_vulkan_image */ +#ifndef GL_NV_gpu_shader5 +typedef khronos_int64_t GLint64EXT; +#endif /* GL_NV_gpu_shader5 */ +#ifndef GL_NV_vertex_buffer_unified_memory +typedef void (APIENTRYP PFNGLGETINTEGERUI64I_VNVPROC) (GLenum value, GLuint index, GLuint64EXT *result); +#endif /* GL_NV_vertex_buffer_unified_memory */ +#ifdef __cplusplus +} +#endif +#endif + +#ifndef GL3W_API +#define GL3W_API +#endif + +#ifndef __gl_h_ +#define __gl_h_ +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +#define GL3W_OK 0 +#define GL3W_ERROR_INIT -1 +#define GL3W_ERROR_LIBRARY_OPEN -2 +#define GL3W_ERROR_OPENGL_VERSION -3 + +typedef void (*GL3WglProc)(void); +typedef GL3WglProc (*GL3WGetProcAddressProc)(const char *proc); + +/* gl3w api */ +GL3W_API int imgl3wInit(void); +GL3W_API int imgl3wInit2(GL3WGetProcAddressProc proc); +GL3W_API int imgl3wIsSupported(int major, int minor); +GL3W_API GL3WglProc imgl3wGetProcAddress(const char *proc); + +/* gl3w internal state */ +union GL3WProcs { + GL3WglProc ptr[53]; + struct { + PFNGLACTIVETEXTUREPROC ActiveTexture; + PFNGLATTACHSHADERPROC AttachShader; + PFNGLBINDBUFFERPROC BindBuffer; + PFNGLBINDSAMPLERPROC BindSampler; + PFNGLBINDTEXTUREPROC BindTexture; + PFNGLBINDVERTEXARRAYPROC BindVertexArray; + PFNGLBLENDEQUATIONPROC BlendEquation; + PFNGLBLENDEQUATIONSEPARATEPROC BlendEquationSeparate; + PFNGLBLENDFUNCSEPARATEPROC BlendFuncSeparate; + PFNGLBUFFERDATAPROC BufferData; + PFNGLCLEARPROC Clear; + PFNGLCLEARCOLORPROC ClearColor; + PFNGLCOMPILESHADERPROC CompileShader; + PFNGLCREATEPROGRAMPROC CreateProgram; + PFNGLCREATESHADERPROC CreateShader; + PFNGLDELETEBUFFERSPROC DeleteBuffers; + PFNGLDELETEPROGRAMPROC DeleteProgram; + PFNGLDELETESHADERPROC DeleteShader; + PFNGLDELETETEXTURESPROC DeleteTextures; + PFNGLDELETEVERTEXARRAYSPROC DeleteVertexArrays; + PFNGLDETACHSHADERPROC DetachShader; + PFNGLDISABLEPROC Disable; + PFNGLDRAWELEMENTSPROC DrawElements; + PFNGLDRAWELEMENTSBASEVERTEXPROC DrawElementsBaseVertex; + PFNGLENABLEPROC Enable; + PFNGLENABLEVERTEXATTRIBARRAYPROC EnableVertexAttribArray; + PFNGLGENBUFFERSPROC GenBuffers; + PFNGLGENTEXTURESPROC GenTextures; + PFNGLGENVERTEXARRAYSPROC GenVertexArrays; + PFNGLGETATTRIBLOCATIONPROC GetAttribLocation; + PFNGLGETERRORPROC GetError; + PFNGLGETINTEGERVPROC GetIntegerv; + PFNGLGETPROGRAMINFOLOGPROC GetProgramInfoLog; + PFNGLGETPROGRAMIVPROC GetProgramiv; + PFNGLGETSHADERINFOLOGPROC GetShaderInfoLog; + PFNGLGETSHADERIVPROC GetShaderiv; + PFNGLGETSTRINGPROC GetString; + PFNGLGETSTRINGIPROC GetStringi; + PFNGLGETUNIFORMLOCATIONPROC GetUniformLocation; + PFNGLISENABLEDPROC IsEnabled; + PFNGLLINKPROGRAMPROC LinkProgram; + PFNGLPIXELSTOREIPROC PixelStorei; + PFNGLPOLYGONMODEPROC PolygonMode; + PFNGLREADPIXELSPROC ReadPixels; + PFNGLSCISSORPROC Scissor; + PFNGLSHADERSOURCEPROC ShaderSource; + PFNGLTEXIMAGE2DPROC TexImage2D; + PFNGLTEXPARAMETERIPROC TexParameteri; + PFNGLUNIFORM1IPROC Uniform1i; + PFNGLUNIFORMMATRIX4FVPROC UniformMatrix4fv; + PFNGLUSEPROGRAMPROC UseProgram; + PFNGLVERTEXATTRIBPOINTERPROC VertexAttribPointer; + PFNGLVIEWPORTPROC Viewport; + } gl; +}; + +GL3W_API extern union GL3WProcs imgl3wProcs; + +/* OpenGL functions */ +#define glActiveTexture imgl3wProcs.gl.ActiveTexture +#define glAttachShader imgl3wProcs.gl.AttachShader +#define glBindBuffer imgl3wProcs.gl.BindBuffer +#define glBindSampler imgl3wProcs.gl.BindSampler +#define glBindTexture imgl3wProcs.gl.BindTexture +#define glBindVertexArray imgl3wProcs.gl.BindVertexArray +#define glBlendEquation imgl3wProcs.gl.BlendEquation +#define glBlendEquationSeparate imgl3wProcs.gl.BlendEquationSeparate +#define glBlendFuncSeparate imgl3wProcs.gl.BlendFuncSeparate +#define glBufferData imgl3wProcs.gl.BufferData +#define glClear imgl3wProcs.gl.Clear +#define glClearColor imgl3wProcs.gl.ClearColor +#define glCompileShader imgl3wProcs.gl.CompileShader +#define glCreateProgram imgl3wProcs.gl.CreateProgram +#define glCreateShader imgl3wProcs.gl.CreateShader +#define glDeleteBuffers imgl3wProcs.gl.DeleteBuffers +#define glDeleteProgram imgl3wProcs.gl.DeleteProgram +#define glDeleteShader imgl3wProcs.gl.DeleteShader +#define glDeleteTextures imgl3wProcs.gl.DeleteTextures +#define glDeleteVertexArrays imgl3wProcs.gl.DeleteVertexArrays +#define glDetachShader imgl3wProcs.gl.DetachShader +#define glDisable imgl3wProcs.gl.Disable +#define glDrawElements imgl3wProcs.gl.DrawElements +#define glDrawElementsBaseVertex imgl3wProcs.gl.DrawElementsBaseVertex +#define glEnable imgl3wProcs.gl.Enable +#define glEnableVertexAttribArray imgl3wProcs.gl.EnableVertexAttribArray +#define glGenBuffers imgl3wProcs.gl.GenBuffers +#define glGenTextures imgl3wProcs.gl.GenTextures +#define glGenVertexArrays imgl3wProcs.gl.GenVertexArrays +#define glGetAttribLocation imgl3wProcs.gl.GetAttribLocation +#define glGetError imgl3wProcs.gl.GetError +#define glGetIntegerv imgl3wProcs.gl.GetIntegerv +#define glGetProgramInfoLog imgl3wProcs.gl.GetProgramInfoLog +#define glGetProgramiv imgl3wProcs.gl.GetProgramiv +#define glGetShaderInfoLog imgl3wProcs.gl.GetShaderInfoLog +#define glGetShaderiv imgl3wProcs.gl.GetShaderiv +#define glGetString imgl3wProcs.gl.GetString +#define glGetStringi imgl3wProcs.gl.GetStringi +#define glGetUniformLocation imgl3wProcs.gl.GetUniformLocation +#define glIsEnabled imgl3wProcs.gl.IsEnabled +#define glLinkProgram imgl3wProcs.gl.LinkProgram +#define glPixelStorei imgl3wProcs.gl.PixelStorei +#define glPolygonMode imgl3wProcs.gl.PolygonMode +#define glReadPixels imgl3wProcs.gl.ReadPixels +#define glScissor imgl3wProcs.gl.Scissor +#define glShaderSource imgl3wProcs.gl.ShaderSource +#define glTexImage2D imgl3wProcs.gl.TexImage2D +#define glTexParameteri imgl3wProcs.gl.TexParameteri +#define glUniform1i imgl3wProcs.gl.Uniform1i +#define glUniformMatrix4fv imgl3wProcs.gl.UniformMatrix4fv +#define glUseProgram imgl3wProcs.gl.UseProgram +#define glVertexAttribPointer imgl3wProcs.gl.VertexAttribPointer +#define glViewport imgl3wProcs.gl.Viewport + +#ifdef __cplusplus +} +#endif + +#endif + +#ifdef IMGL3W_IMPL +#ifdef __cplusplus +extern "C" { +#endif + +#include + +#define ARRAY_SIZE(x) (sizeof(x) / sizeof((x)[0])) + +#if defined(_WIN32) +#ifndef WIN32_LEAN_AND_MEAN +#define WIN32_LEAN_AND_MEAN 1 +#endif +#include + +static HMODULE libgl; +typedef PROC(__stdcall* GL3WglGetProcAddr)(LPCSTR); +static GL3WglGetProcAddr wgl_get_proc_address; + +static int open_libgl(void) +{ + libgl = LoadLibraryA("opengl32.dll"); + if (!libgl) + return GL3W_ERROR_LIBRARY_OPEN; + wgl_get_proc_address = (GL3WglGetProcAddr)GetProcAddress(libgl, "wglGetProcAddress"); + return GL3W_OK; +} + +static void close_libgl(void) { FreeLibrary(libgl); } +static GL3WglProc get_proc(const char *proc) +{ + GL3WglProc res; + res = (GL3WglProc)wgl_get_proc_address(proc); + if (!res) + res = (GL3WglProc)GetProcAddress(libgl, proc); + return res; +} +#elif defined(__APPLE__) +#include + +static void *libgl; +static int open_libgl(void) +{ + libgl = dlopen("/System/Library/Frameworks/OpenGL.framework/OpenGL", RTLD_LAZY | RTLD_LOCAL); + if (!libgl) + return GL3W_ERROR_LIBRARY_OPEN; + return GL3W_OK; +} + +static void close_libgl(void) { dlclose(libgl); } + +static GL3WglProc get_proc(const char *proc) +{ + GL3WglProc res; + *(void **)(&res) = dlsym(libgl, proc); + return res; +} +#else +#include + +static void *libgl; +static GL3WglProc (*glx_get_proc_address)(const GLubyte *); + +static int open_libgl(void) +{ + libgl = dlopen("libGL.so.1", RTLD_LAZY | RTLD_LOCAL); + if (!libgl) + return GL3W_ERROR_LIBRARY_OPEN; + *(void **)(&glx_get_proc_address) = dlsym(libgl, "glXGetProcAddressARB"); + return GL3W_OK; +} + +static void close_libgl(void) { dlclose(libgl); } + +static GL3WglProc get_proc(const char *proc) +{ + GL3WglProc res; + res = glx_get_proc_address((const GLubyte *)proc); + if (!res) + *(void **)(&res) = dlsym(libgl, proc); + return res; +} +#endif + +static struct { int major, minor; } version; + +static int parse_version(void) +{ + if (!glGetIntegerv) + return GL3W_ERROR_INIT; + glGetIntegerv(GL_MAJOR_VERSION, &version.major); + glGetIntegerv(GL_MINOR_VERSION, &version.minor); + if (version.major < 3) + return GL3W_ERROR_OPENGL_VERSION; + return GL3W_OK; +} + +static void load_procs(GL3WGetProcAddressProc proc); + +int imgl3wInit(void) +{ + int res = open_libgl(); + if (res) + return res; + atexit(close_libgl); + return imgl3wInit2(get_proc); +} + +int imgl3wInit2(GL3WGetProcAddressProc proc) +{ + load_procs(proc); + return parse_version(); +} + +int imgl3wIsSupported(int major, int minor) +{ + if (major < 3) + return 0; + if (version.major == major) + return version.minor >= minor; + return version.major >= major; +} + +GL3WglProc imgl3wGetProcAddress(const char *proc) { return get_proc(proc); } + +static const char *proc_names[] = { + "glActiveTexture", + "glAttachShader", + "glBindBuffer", + "glBindSampler", + "glBindTexture", + "glBindVertexArray", + "glBlendEquation", + "glBlendEquationSeparate", + "glBlendFuncSeparate", + "glBufferData", + "glClear", + "glClearColor", + "glCompileShader", + "glCreateProgram", + "glCreateShader", + "glDeleteBuffers", + "glDeleteProgram", + "glDeleteShader", + "glDeleteTextures", + "glDeleteVertexArrays", + "glDetachShader", + "glDisable", + "glDrawElements", + "glDrawElementsBaseVertex", + "glEnable", + "glEnableVertexAttribArray", + "glGenBuffers", + "glGenTextures", + "glGenVertexArrays", + "glGetAttribLocation", + "glGetError", + "glGetIntegerv", + "glGetProgramInfoLog", + "glGetProgramiv", + "glGetShaderInfoLog", + "glGetShaderiv", + "glGetString", + "glGetStringi", + "glGetUniformLocation", + "glIsEnabled", + "glLinkProgram", + "glPixelStorei", + "glPolygonMode", + "glReadPixels", + "glScissor", + "glShaderSource", + "glTexImage2D", + "glTexParameteri", + "glUniform1i", + "glUniformMatrix4fv", + "glUseProgram", + "glVertexAttribPointer", + "glViewport", +}; + +GL3W_API union GL3WProcs imgl3wProcs; + +static void load_procs(GL3WGetProcAddressProc proc) +{ + size_t i; + for (i = 0; i < ARRAY_SIZE(proc_names); i++) + imgl3wProcs.ptr[i] = proc(proc_names[i]); +} + +#ifdef __cplusplus +} +#endif +#endif diff --git a/source/editor/imgui/backends/imgui_impl_osx.h b/source/editor/imgui/backends/imgui_impl_osx.h new file mode 100644 index 0000000..e4c1d04 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_osx.h @@ -0,0 +1,24 @@ +// dear imgui: Platform Backend for OSX / Cocoa +// This needs to be used along with a Renderer (e.g. OpenGL2, OpenGL3, Vulkan, Metal..) +// [ALPHA] Early backend, not well tested. If you want a portable application, prefer using the GLFW or SDL platform Backends on Mac. + +// Implemented features: +// [X] Platform: Mouse cursor shape and visibility. Disable with 'io.ConfigFlags |= ImGuiConfigFlags_NoMouseCursorChange'. +// [X] Platform: OSX clipboard is supported within core Dear ImGui (no specific code in this backend). +// Issues: +// [ ] Platform: Keys are all generally very broken. Best using [event keycode] and not [event characters].. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#include "imgui.h" // IMGUI_IMPL_API + +@class NSEvent; +@class NSView; + +IMGUI_IMPL_API bool ImGui_ImplOSX_Init(); +IMGUI_IMPL_API void ImGui_ImplOSX_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplOSX_NewFrame(NSView* _Nullable view); +IMGUI_IMPL_API bool ImGui_ImplOSX_HandleEvent(NSEvent* _Nonnull event, NSView* _Nullable view); diff --git a/source/editor/imgui/backends/imgui_impl_osx.mm b/source/editor/imgui/backends/imgui_impl_osx.mm new file mode 100644 index 0000000..1eb79d9 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_osx.mm @@ -0,0 +1,369 @@ +// dear imgui: Platform Backend for OSX / Cocoa +// This needs to be used along with a Renderer (e.g. OpenGL2, OpenGL3, Vulkan, Metal..) +// [ALPHA] Early backend, not well tested. If you want a portable application, prefer using the GLFW or SDL platform Backends on Mac. + +// Implemented features: +// [X] Platform: Mouse cursor shape and visibility. Disable with 'io.ConfigFlags |= ImGuiConfigFlags_NoMouseCursorChange'. +// [X] Platform: OSX clipboard is supported within core Dear ImGui (no specific code in this backend). +// Issues: +// [ ] Platform: Keys are all generally very broken. Best using [event keycode] and not [event characters].. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#include "imgui.h" +#include "imgui_impl_osx.h" +#import + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-08-17: Calling io.AddFocusEvent() on NSApplicationDidBecomeActiveNotification/NSApplicationDidResignActiveNotification events. +// 2021-06-23: Inputs: Added a fix for shortcuts using CTRL key instead of CMD key. +// 2021-04-19: Inputs: Added a fix for keys remaining stuck in pressed state when CMD-tabbing into different application. +// 2021-01-27: Inputs: Added a fix for mouse position not being reported when mouse buttons other than left one are down. +// 2020-10-28: Inputs: Added a fix for handling keypad-enter key. +// 2020-05-25: Inputs: Added a fix for missing trackpad clicks when done with "soft tap". +// 2019-12-05: Inputs: Added support for ImGuiMouseCursor_NotAllowed mouse cursor. +// 2019-10-11: Inputs: Fix using Backspace key. +// 2019-07-21: Re-added clipboard handlers as they are not enabled by default in core imgui.cpp (reverted 2019-05-18 change). +// 2019-05-28: Inputs: Added mouse cursor shape and visibility support. +// 2019-05-18: Misc: Removed clipboard handlers as they are now supported by core imgui.cpp. +// 2019-05-11: Inputs: Don't filter character values before calling AddInputCharacter() apart from 0xF700..0xFFFF range. +// 2018-11-30: Misc: Setting up io.BackendPlatformName so it can be displayed in the About Window. +// 2018-07-07: Initial version. + +@class ImFocusObserver; + +// Data +static CFAbsoluteTime g_Time = 0.0; +static NSCursor* g_MouseCursors[ImGuiMouseCursor_COUNT] = {}; +static bool g_MouseCursorHidden = false; +static bool g_MouseJustPressed[ImGuiMouseButton_COUNT] = {}; +static bool g_MouseDown[ImGuiMouseButton_COUNT] = {}; +static ImFocusObserver* g_FocusObserver = NULL; + +// Undocumented methods for creating cursors. +@interface NSCursor() ++ (id)_windowResizeNorthWestSouthEastCursor; ++ (id)_windowResizeNorthEastSouthWestCursor; ++ (id)_windowResizeNorthSouthCursor; ++ (id)_windowResizeEastWestCursor; +@end + +static void resetKeys() +{ + ImGuiIO& io = ImGui::GetIO(); + memset(io.KeysDown, 0, sizeof(io.KeysDown)); + io.KeyCtrl = io.KeyShift = io.KeyAlt = io.KeySuper = false; +} + +@interface ImFocusObserver : NSObject + +- (void)onApplicationBecomeActive:(NSNotification*)aNotification; +- (void)onApplicationBecomeInactive:(NSNotification*)aNotification; + +@end + +@implementation ImFocusObserver + +- (void)onApplicationBecomeActive:(NSNotification*)aNotification +{ + ImGuiIO& io = ImGui::GetIO(); + io.AddFocusEvent(true); +} + +- (void)onApplicationBecomeInactive:(NSNotification*)aNotification +{ + ImGuiIO& io = ImGui::GetIO(); + io.AddFocusEvent(false); + + // Unfocused applications do not receive input events, therefore we must manually + // release any pressed keys when application loses focus, otherwise they would remain + // stuck in a pressed state. https://github.com/ocornut/imgui/issues/3832 + resetKeys(); +} + +@end + +// Functions +bool ImGui_ImplOSX_Init() +{ + ImGuiIO& io = ImGui::GetIO(); + + // Setup backend capabilities flags + io.BackendFlags |= ImGuiBackendFlags_HasMouseCursors; // We can honor GetMouseCursor() values (optional) + //io.BackendFlags |= ImGuiBackendFlags_HasSetMousePos; // We can honor io.WantSetMousePos requests (optional, rarely used) + //io.BackendFlags |= ImGuiBackendFlags_PlatformHasViewports; // We can create multi-viewports on the Platform side (optional) + //io.BackendFlags |= ImGuiBackendFlags_HasMouseHoveredViewport; // We can set io.MouseHoveredViewport correctly (optional, not easy) + io.BackendPlatformName = "imgui_impl_osx"; + + // Keyboard mapping. Dear ImGui will use those indices to peek into the io.KeyDown[] array. + const int offset_for_function_keys = 256 - 0xF700; + io.KeyMap[ImGuiKey_Tab] = '\t'; + io.KeyMap[ImGuiKey_LeftArrow] = NSLeftArrowFunctionKey + offset_for_function_keys; + io.KeyMap[ImGuiKey_RightArrow] = NSRightArrowFunctionKey + offset_for_function_keys; + io.KeyMap[ImGuiKey_UpArrow] = NSUpArrowFunctionKey + offset_for_function_keys; + io.KeyMap[ImGuiKey_DownArrow] = NSDownArrowFunctionKey + offset_for_function_keys; + io.KeyMap[ImGuiKey_PageUp] = NSPageUpFunctionKey + offset_for_function_keys; + io.KeyMap[ImGuiKey_PageDown] = NSPageDownFunctionKey + offset_for_function_keys; + io.KeyMap[ImGuiKey_Home] = NSHomeFunctionKey + offset_for_function_keys; + io.KeyMap[ImGuiKey_End] = NSEndFunctionKey + offset_for_function_keys; + io.KeyMap[ImGuiKey_Insert] = NSInsertFunctionKey + offset_for_function_keys; + io.KeyMap[ImGuiKey_Delete] = NSDeleteFunctionKey + offset_for_function_keys; + io.KeyMap[ImGuiKey_Backspace] = 127; + io.KeyMap[ImGuiKey_Space] = 32; + io.KeyMap[ImGuiKey_Enter] = 13; + io.KeyMap[ImGuiKey_Escape] = 27; + io.KeyMap[ImGuiKey_KeyPadEnter] = 3; + io.KeyMap[ImGuiKey_A] = 'A'; + io.KeyMap[ImGuiKey_C] = 'C'; + io.KeyMap[ImGuiKey_V] = 'V'; + io.KeyMap[ImGuiKey_X] = 'X'; + io.KeyMap[ImGuiKey_Y] = 'Y'; + io.KeyMap[ImGuiKey_Z] = 'Z'; + + // Load cursors. Some of them are undocumented. + g_MouseCursorHidden = false; + g_MouseCursors[ImGuiMouseCursor_Arrow] = [NSCursor arrowCursor]; + g_MouseCursors[ImGuiMouseCursor_TextInput] = [NSCursor IBeamCursor]; + g_MouseCursors[ImGuiMouseCursor_ResizeAll] = [NSCursor closedHandCursor]; + g_MouseCursors[ImGuiMouseCursor_Hand] = [NSCursor pointingHandCursor]; + g_MouseCursors[ImGuiMouseCursor_NotAllowed] = [NSCursor operationNotAllowedCursor]; + g_MouseCursors[ImGuiMouseCursor_ResizeNS] = [NSCursor respondsToSelector:@selector(_windowResizeNorthSouthCursor)] ? [NSCursor _windowResizeNorthSouthCursor] : [NSCursor resizeUpDownCursor]; + g_MouseCursors[ImGuiMouseCursor_ResizeEW] = [NSCursor respondsToSelector:@selector(_windowResizeEastWestCursor)] ? [NSCursor _windowResizeEastWestCursor] : [NSCursor resizeLeftRightCursor]; + g_MouseCursors[ImGuiMouseCursor_ResizeNESW] = [NSCursor respondsToSelector:@selector(_windowResizeNorthEastSouthWestCursor)] ? [NSCursor _windowResizeNorthEastSouthWestCursor] : [NSCursor closedHandCursor]; + g_MouseCursors[ImGuiMouseCursor_ResizeNWSE] = [NSCursor respondsToSelector:@selector(_windowResizeNorthWestSouthEastCursor)] ? [NSCursor _windowResizeNorthWestSouthEastCursor] : [NSCursor closedHandCursor]; + + // Note that imgui.cpp also include default OSX clipboard handlers which can be enabled + // by adding '#define IMGUI_ENABLE_OSX_DEFAULT_CLIPBOARD_FUNCTIONS' in imconfig.h and adding '-framework ApplicationServices' to your linker command-line. + // Since we are already in ObjC land here, it is easy for us to add a clipboard handler using the NSPasteboard api. + io.SetClipboardTextFn = [](void*, const char* str) -> void + { + NSPasteboard* pasteboard = [NSPasteboard generalPasteboard]; + [pasteboard declareTypes:[NSArray arrayWithObject:NSPasteboardTypeString] owner:nil]; + [pasteboard setString:[NSString stringWithUTF8String:str] forType:NSPasteboardTypeString]; + }; + + io.GetClipboardTextFn = [](void*) -> const char* + { + NSPasteboard* pasteboard = [NSPasteboard generalPasteboard]; + NSString* available = [pasteboard availableTypeFromArray: [NSArray arrayWithObject:NSPasteboardTypeString]]; + if (![available isEqualToString:NSPasteboardTypeString]) + return NULL; + + NSString* string = [pasteboard stringForType:NSPasteboardTypeString]; + if (string == nil) + return NULL; + + const char* string_c = (const char*)[string UTF8String]; + size_t string_len = strlen(string_c); + static ImVector s_clipboard; + s_clipboard.resize((int)string_len + 1); + strcpy(s_clipboard.Data, string_c); + return s_clipboard.Data; + }; + + g_FocusObserver = [[ImFocusObserver alloc] init]; + [[NSNotificationCenter defaultCenter] addObserver:g_FocusObserver + selector:@selector(onApplicationBecomeActive:) + name:NSApplicationDidBecomeActiveNotification + object:nil]; + [[NSNotificationCenter defaultCenter] addObserver:g_FocusObserver + selector:@selector(onApplicationBecomeInactive:) + name:NSApplicationDidResignActiveNotification + object:nil]; + + return true; +} + +void ImGui_ImplOSX_Shutdown() +{ + g_FocusObserver = NULL; +} + +static void ImGui_ImplOSX_UpdateMouseCursorAndButtons() +{ + // Update buttons + ImGuiIO& io = ImGui::GetIO(); + for (int i = 0; i < IM_ARRAYSIZE(io.MouseDown); i++) + { + // If a mouse press event came, always pass it as "mouse held this frame", so we don't miss click-release events that are shorter than 1 frame. + io.MouseDown[i] = g_MouseJustPressed[i] || g_MouseDown[i]; + g_MouseJustPressed[i] = false; + } + + if (io.ConfigFlags & ImGuiConfigFlags_NoMouseCursorChange) + return; + + ImGuiMouseCursor imgui_cursor = ImGui::GetMouseCursor(); + if (io.MouseDrawCursor || imgui_cursor == ImGuiMouseCursor_None) + { + // Hide OS mouse cursor if imgui is drawing it or if it wants no cursor + if (!g_MouseCursorHidden) + { + g_MouseCursorHidden = true; + [NSCursor hide]; + } + } + else + { + // Show OS mouse cursor + [g_MouseCursors[g_MouseCursors[imgui_cursor] ? imgui_cursor : ImGuiMouseCursor_Arrow] set]; + if (g_MouseCursorHidden) + { + g_MouseCursorHidden = false; + [NSCursor unhide]; + } + } +} + +void ImGui_ImplOSX_NewFrame(NSView* view) +{ + // Setup display size + ImGuiIO& io = ImGui::GetIO(); + if (view) + { + const float dpi = (float)[view.window backingScaleFactor]; + io.DisplaySize = ImVec2((float)view.bounds.size.width, (float)view.bounds.size.height); + io.DisplayFramebufferScale = ImVec2(dpi, dpi); + } + + // Setup time step + if (g_Time == 0.0) + g_Time = CFAbsoluteTimeGetCurrent(); + CFAbsoluteTime current_time = CFAbsoluteTimeGetCurrent(); + io.DeltaTime = (float)(current_time - g_Time); + g_Time = current_time; + + ImGui_ImplOSX_UpdateMouseCursorAndButtons(); +} + +static int mapCharacterToKey(int c) +{ + if (c >= 'a' && c <= 'z') + return c - 'a' + 'A'; + if (c == 25) // SHIFT+TAB -> TAB + return 9; + if (c >= 0 && c < 256) + return c; + if (c >= 0xF700 && c < 0xF700 + 256) + return c - 0xF700 + 256; + return -1; +} + +bool ImGui_ImplOSX_HandleEvent(NSEvent* event, NSView* view) +{ + ImGuiIO& io = ImGui::GetIO(); + + if (event.type == NSEventTypeLeftMouseDown || event.type == NSEventTypeRightMouseDown || event.type == NSEventTypeOtherMouseDown) + { + int button = (int)[event buttonNumber]; + if (button >= 0 && button < IM_ARRAYSIZE(g_MouseDown)) + g_MouseDown[button] = g_MouseJustPressed[button] = true; + return io.WantCaptureMouse; + } + + if (event.type == NSEventTypeLeftMouseUp || event.type == NSEventTypeRightMouseUp || event.type == NSEventTypeOtherMouseUp) + { + int button = (int)[event buttonNumber]; + if (button >= 0 && button < IM_ARRAYSIZE(g_MouseDown)) + g_MouseDown[button] = false; + return io.WantCaptureMouse; + } + + if (event.type == NSEventTypeMouseMoved || event.type == NSEventTypeLeftMouseDragged || event.type == NSEventTypeRightMouseDragged || event.type == NSEventTypeOtherMouseDragged) + { + NSPoint mousePoint = event.locationInWindow; + mousePoint = [view convertPoint:mousePoint fromView:nil]; + mousePoint = NSMakePoint(mousePoint.x, view.bounds.size.height - mousePoint.y); + io.MousePos = ImVec2((float)mousePoint.x, (float)mousePoint.y); + } + + if (event.type == NSEventTypeScrollWheel) + { + double wheel_dx = 0.0; + double wheel_dy = 0.0; + + #if MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 + if (floor(NSAppKitVersionNumber) > NSAppKitVersionNumber10_6) + { + wheel_dx = [event scrollingDeltaX]; + wheel_dy = [event scrollingDeltaY]; + if ([event hasPreciseScrollingDeltas]) + { + wheel_dx *= 0.1; + wheel_dy *= 0.1; + } + } + else + #endif // MAC_OS_X_VERSION_MAX_ALLOWED + { + wheel_dx = [event deltaX]; + wheel_dy = [event deltaY]; + } + + if (fabs(wheel_dx) > 0.0) + io.MouseWheelH += (float)wheel_dx * 0.1f; + if (fabs(wheel_dy) > 0.0) + io.MouseWheel += (float)wheel_dy * 0.1f; + return io.WantCaptureMouse; + } + + // FIXME: All the key handling is wrong and broken. Refer to GLFW's cocoa_init.mm and cocoa_window.mm. + if (event.type == NSEventTypeKeyDown) + { + NSString* str = [event characters]; + NSUInteger len = [str length]; + for (NSUInteger i = 0; i < len; i++) + { + int c = [str characterAtIndex:i]; + if (!io.KeySuper && !(c >= 0xF700 && c <= 0xFFFF) && c != 127) + io.AddInputCharacter((unsigned int)c); + + // We must reset in case we're pressing a sequence of special keys while keeping the command pressed + int key = mapCharacterToKey(c); + if (key != -1 && key < 256 && !io.KeySuper) + resetKeys(); + if (key != -1) + io.KeysDown[key] = true; + } + return io.WantCaptureKeyboard; + } + + if (event.type == NSEventTypeKeyUp) + { + NSString* str = [event characters]; + NSUInteger len = [str length]; + for (NSUInteger i = 0; i < len; i++) + { + int c = [str characterAtIndex:i]; + int key = mapCharacterToKey(c); + if (key != -1) + io.KeysDown[key] = false; + } + return io.WantCaptureKeyboard; + } + + if (event.type == NSEventTypeFlagsChanged) + { + unsigned int flags = [event modifierFlags] & NSEventModifierFlagDeviceIndependentFlagsMask; + + bool oldKeyCtrl = io.KeyCtrl; + bool oldKeyShift = io.KeyShift; + bool oldKeyAlt = io.KeyAlt; + bool oldKeySuper = io.KeySuper; + io.KeyCtrl = flags & NSEventModifierFlagControl; + io.KeyShift = flags & NSEventModifierFlagShift; + io.KeyAlt = flags & NSEventModifierFlagOption; + io.KeySuper = flags & NSEventModifierFlagCommand; + + // We must reset them as we will not receive any keyUp event if they where pressed with a modifier + if ((oldKeyShift && !io.KeyShift) || (oldKeyCtrl && !io.KeyCtrl) || (oldKeyAlt && !io.KeyAlt) || (oldKeySuper && !io.KeySuper)) + resetKeys(); + return io.WantCaptureKeyboard; + } + + return false; +} diff --git a/source/editor/imgui/backends/imgui_impl_sdl.cpp b/source/editor/imgui/backends/imgui_impl_sdl.cpp new file mode 100644 index 0000000..669c7b7 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_sdl.cpp @@ -0,0 +1,443 @@ +// dear imgui: Platform Backend for SDL2 +// This needs to be used along with a Renderer (e.g. DirectX11, OpenGL3, Vulkan..) +// (Info: SDL2 is a cross-platform general purpose library for handling windows, inputs, graphics context creation, etc.) +// (Prefer SDL 2.0.5+ for full feature support.) + +// Implemented features: +// [X] Platform: Mouse cursor shape and visibility. Disable with 'io.ConfigFlags |= ImGuiConfigFlags_NoMouseCursorChange'. +// [X] Platform: Clipboard support. +// [X] Platform: Keyboard arrays indexed using SDL_SCANCODE_* codes, e.g. ImGui::IsKeyPressed(SDL_SCANCODE_SPACE). +// [X] Platform: Gamepad support. Enabled with 'io.ConfigFlags |= ImGuiConfigFlags_NavEnableGamepad'. +// Missing features: +// [ ] Platform: SDL2 handling of IME under Windows appears to be broken and it explicitly disable the regular Windows IME. You can restore Windows IME by compiling SDL with SDL_DISABLE_WINDOWS_IME. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-08-17: Calling io.AddFocusEvent() on SDL_WINDOWEVENT_FOCUS_GAINED/SDL_WINDOWEVENT_FOCUS_LOST. +// 2021-07-29: Inputs: MousePos is correctly reported when the host platform window is hovered but not focused (using SDL_GetMouseFocus() + SDL_HINT_MOUSE_FOCUS_CLICKTHROUGH, requires SDL 2.0.5+) +// 2021-06-29: *BREAKING CHANGE* Removed 'SDL_Window* window' parameter to ImGui_ImplSDL2_NewFrame() which was unnecessary. +// 2021-06-29: Reorganized backend to pull data from a single structure to facilitate usage with multiple-contexts (all g_XXXX access changed to bd->XXXX). +// 2021-03-22: Rework global mouse pos availability check listing supported platforms explicitly, effectively fixing mouse access on Raspberry Pi. (#2837, #3950) +// 2020-05-25: Misc: Report a zero display-size when window is minimized, to be consistent with other backends. +// 2020-02-20: Inputs: Fixed mapping for ImGuiKey_KeyPadEnter (using SDL_SCANCODE_KP_ENTER instead of SDL_SCANCODE_RETURN2). +// 2019-12-17: Inputs: On Wayland, use SDL_GetMouseState (because there is no global mouse state). +// 2019-12-05: Inputs: Added support for ImGuiMouseCursor_NotAllowed mouse cursor. +// 2019-07-21: Inputs: Added mapping for ImGuiKey_KeyPadEnter. +// 2019-04-23: Inputs: Added support for SDL_GameController (if ImGuiConfigFlags_NavEnableGamepad is set by user application). +// 2019-03-12: Misc: Preserve DisplayFramebufferScale when main window is minimized. +// 2018-12-21: Inputs: Workaround for Android/iOS which don't seem to handle focus related calls. +// 2018-11-30: Misc: Setting up io.BackendPlatformName so it can be displayed in the About Window. +// 2018-11-14: Changed the signature of ImGui_ImplSDL2_ProcessEvent() to take a 'const SDL_Event*'. +// 2018-08-01: Inputs: Workaround for Emscripten which doesn't seem to handle focus related calls. +// 2018-06-29: Inputs: Added support for the ImGuiMouseCursor_Hand cursor. +// 2018-06-08: Misc: Extracted imgui_impl_sdl.cpp/.h away from the old combined SDL2+OpenGL/Vulkan examples. +// 2018-06-08: Misc: ImGui_ImplSDL2_InitForOpenGL() now takes a SDL_GLContext parameter. +// 2018-05-09: Misc: Fixed clipboard paste memory leak (we didn't call SDL_FreeMemory on the data returned by SDL_GetClipboardText). +// 2018-03-20: Misc: Setup io.BackendFlags ImGuiBackendFlags_HasMouseCursors flag + honor ImGuiConfigFlags_NoMouseCursorChange flag. +// 2018-02-16: Inputs: Added support for mouse cursors, honoring ImGui::GetMouseCursor() value. +// 2018-02-06: Misc: Removed call to ImGui::Shutdown() which is not available from 1.60 WIP, user needs to call CreateContext/DestroyContext themselves. +// 2018-02-06: Inputs: Added mapping for ImGuiKey_Space. +// 2018-02-05: Misc: Using SDL_GetPerformanceCounter() instead of SDL_GetTicks() to be able to handle very high framerate (1000+ FPS). +// 2018-02-05: Inputs: Keyboard mapping is using scancodes everywhere instead of a confusing mixture of keycodes and scancodes. +// 2018-01-20: Inputs: Added Horizontal Mouse Wheel support. +// 2018-01-19: Inputs: When available (SDL 2.0.4+) using SDL_CaptureMouse() to retrieve coordinates outside of client area when dragging. Otherwise (SDL 2.0.3 and before) testing for SDL_WINDOW_INPUT_FOCUS instead of SDL_WINDOW_MOUSE_FOCUS. +// 2018-01-18: Inputs: Added mapping for ImGuiKey_Insert. +// 2017-08-25: Inputs: MousePos set to -FLT_MAX,-FLT_MAX when mouse is unavailable/missing (instead of -1,-1). +// 2016-10-15: Misc: Added a void* user_data parameter to Clipboard function handlers. + +#include "imgui.h" +#include "imgui_impl_sdl.h" + +// SDL +#include +#include +#if defined(__APPLE__) +#include +#endif + +#if SDL_VERSION_ATLEAST(2,0,4) && !defined(__EMSCRIPTEN__) && !defined(__ANDROID__) && !(defined(__APPLE__) && TARGET_OS_IOS) +#define SDL_HAS_CAPTURE_AND_GLOBAL_MOUSE 1 +#else +#define SDL_HAS_CAPTURE_AND_GLOBAL_MOUSE 0 +#endif +#define SDL_HAS_MOUSE_FOCUS_CLICKTHROUGH SDL_VERSION_ATLEAST(2,0,5) +#define SDL_HAS_VULKAN SDL_VERSION_ATLEAST(2,0,6) + +// SDL Data +struct ImGui_ImplSDL2_Data +{ + SDL_Window* Window; + Uint64 Time; + bool MousePressed[3]; + SDL_Cursor* MouseCursors[ImGuiMouseCursor_COUNT]; + char* ClipboardTextData; + bool MouseCanUseGlobalState; + + ImGui_ImplSDL2_Data() { memset(this, 0, sizeof(*this)); } +}; + +// Backend data stored in io.BackendPlatformUserData to allow support for multiple Dear ImGui contexts +// It is STRONGLY preferred that you use docking branch with multi-viewports (== single Dear ImGui context + multiple windows) instead of multiple Dear ImGui contexts. +// FIXME: multi-context support is not well tested and probably dysfunctional in this backend. +// FIXME: some shared resources (mouse cursor shape, gamepad) are mishandled when using multi-context. +static ImGui_ImplSDL2_Data* ImGui_ImplSDL2_GetBackendData() +{ + return ImGui::GetCurrentContext() ? (ImGui_ImplSDL2_Data*)ImGui::GetIO().BackendPlatformUserData : NULL; +} + +// Functions +static const char* ImGui_ImplSDL2_GetClipboardText(void*) +{ + ImGui_ImplSDL2_Data* bd = ImGui_ImplSDL2_GetBackendData(); + if (bd->ClipboardTextData) + SDL_free(bd->ClipboardTextData); + bd->ClipboardTextData = SDL_GetClipboardText(); + return bd->ClipboardTextData; +} + +static void ImGui_ImplSDL2_SetClipboardText(void*, const char* text) +{ + SDL_SetClipboardText(text); +} + +// You can read the io.WantCaptureMouse, io.WantCaptureKeyboard flags to tell if dear imgui wants to use your inputs. +// - When io.WantCaptureMouse is true, do not dispatch mouse input data to your main application. +// - When io.WantCaptureKeyboard is true, do not dispatch keyboard input data to your main application. +// Generally you may always pass all inputs to dear imgui, and hide them from your application based on those two flags. +// If you have multiple SDL events and some of them are not meant to be used by dear imgui, you may need to filter events based on their windowID field. +bool ImGui_ImplSDL2_ProcessEvent(const SDL_Event* event) +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplSDL2_Data* bd = ImGui_ImplSDL2_GetBackendData(); + + switch (event->type) + { + case SDL_MOUSEWHEEL: + { + if (event->wheel.x > 0) io.MouseWheelH += 1; + if (event->wheel.x < 0) io.MouseWheelH -= 1; + if (event->wheel.y > 0) io.MouseWheel += 1; + if (event->wheel.y < 0) io.MouseWheel -= 1; + return true; + } + case SDL_MOUSEBUTTONDOWN: + { + if (event->button.button == SDL_BUTTON_LEFT) { bd->MousePressed[0] = true; } + if (event->button.button == SDL_BUTTON_RIGHT) { bd->MousePressed[1] = true; } + if (event->button.button == SDL_BUTTON_MIDDLE) { bd->MousePressed[2] = true; } + return true; + } + case SDL_TEXTINPUT: + { + io.AddInputCharactersUTF8(event->text.text); + return true; + } + case SDL_KEYDOWN: + case SDL_KEYUP: + { + int key = event->key.keysym.scancode; + IM_ASSERT(key >= 0 && key < IM_ARRAYSIZE(io.KeysDown)); + io.KeysDown[key] = (event->type == SDL_KEYDOWN); + io.KeyShift = ((SDL_GetModState() & KMOD_SHIFT) != 0); + io.KeyCtrl = ((SDL_GetModState() & KMOD_CTRL) != 0); + io.KeyAlt = ((SDL_GetModState() & KMOD_ALT) != 0); +#ifdef _WIN32 + io.KeySuper = false; +#else + io.KeySuper = ((SDL_GetModState() & KMOD_GUI) != 0); +#endif + return true; + } + case SDL_WINDOWEVENT: + { + if (event->window.event == SDL_WINDOWEVENT_FOCUS_GAINED) + io.AddFocusEvent(true); + else if (event->window.event == SDL_WINDOWEVENT_FOCUS_LOST) + io.AddFocusEvent(false); + return true; + } + } + return false; +} + +static bool ImGui_ImplSDL2_Init(SDL_Window* window) +{ + ImGuiIO& io = ImGui::GetIO(); + IM_ASSERT(io.BackendPlatformUserData == NULL && "Already initialized a platform backend!"); + + // Check and store if we are on a SDL backend that supports global mouse position + // ("wayland" and "rpi" don't support it, but we chose to use a white-list instead of a black-list) + bool mouse_can_use_global_state = false; +#if SDL_HAS_CAPTURE_AND_GLOBAL_MOUSE + const char* sdl_backend = SDL_GetCurrentVideoDriver(); + const char* global_mouse_whitelist[] = { "windows", "cocoa", "x11", "DIVE", "VMAN" }; + for (int n = 0; n < IM_ARRAYSIZE(global_mouse_whitelist); n++) + if (strncmp(sdl_backend, global_mouse_whitelist[n], strlen(global_mouse_whitelist[n])) == 0) + mouse_can_use_global_state = true; +#endif + + // Setup backend capabilities flags + ImGui_ImplSDL2_Data* bd = IM_NEW(ImGui_ImplSDL2_Data)(); + io.BackendPlatformUserData = (void*)bd; + io.BackendPlatformName = "imgui_impl_sdl"; + io.BackendFlags |= ImGuiBackendFlags_HasMouseCursors; // We can honor GetMouseCursor() values (optional) + io.BackendFlags |= ImGuiBackendFlags_HasSetMousePos; // We can honor io.WantSetMousePos requests (optional, rarely used) + + bd->Window = window; + bd->MouseCanUseGlobalState = mouse_can_use_global_state; + + // Keyboard mapping. Dear ImGui will use those indices to peek into the io.KeysDown[] array. + io.KeyMap[ImGuiKey_Tab] = SDL_SCANCODE_TAB; + io.KeyMap[ImGuiKey_LeftArrow] = SDL_SCANCODE_LEFT; + io.KeyMap[ImGuiKey_RightArrow] = SDL_SCANCODE_RIGHT; + io.KeyMap[ImGuiKey_UpArrow] = SDL_SCANCODE_UP; + io.KeyMap[ImGuiKey_DownArrow] = SDL_SCANCODE_DOWN; + io.KeyMap[ImGuiKey_PageUp] = SDL_SCANCODE_PAGEUP; + io.KeyMap[ImGuiKey_PageDown] = SDL_SCANCODE_PAGEDOWN; + io.KeyMap[ImGuiKey_Home] = SDL_SCANCODE_HOME; + io.KeyMap[ImGuiKey_End] = SDL_SCANCODE_END; + io.KeyMap[ImGuiKey_Insert] = SDL_SCANCODE_INSERT; + io.KeyMap[ImGuiKey_Delete] = SDL_SCANCODE_DELETE; + io.KeyMap[ImGuiKey_Backspace] = SDL_SCANCODE_BACKSPACE; + io.KeyMap[ImGuiKey_Space] = SDL_SCANCODE_SPACE; + io.KeyMap[ImGuiKey_Enter] = SDL_SCANCODE_RETURN; + io.KeyMap[ImGuiKey_Escape] = SDL_SCANCODE_ESCAPE; + io.KeyMap[ImGuiKey_KeyPadEnter] = SDL_SCANCODE_KP_ENTER; + io.KeyMap[ImGuiKey_A] = SDL_SCANCODE_A; + io.KeyMap[ImGuiKey_C] = SDL_SCANCODE_C; + io.KeyMap[ImGuiKey_V] = SDL_SCANCODE_V; + io.KeyMap[ImGuiKey_X] = SDL_SCANCODE_X; + io.KeyMap[ImGuiKey_Y] = SDL_SCANCODE_Y; + io.KeyMap[ImGuiKey_Z] = SDL_SCANCODE_Z; + + io.SetClipboardTextFn = ImGui_ImplSDL2_SetClipboardText; + io.GetClipboardTextFn = ImGui_ImplSDL2_GetClipboardText; + io.ClipboardUserData = NULL; + + // Load mouse cursors + bd->MouseCursors[ImGuiMouseCursor_Arrow] = SDL_CreateSystemCursor(SDL_SYSTEM_CURSOR_ARROW); + bd->MouseCursors[ImGuiMouseCursor_TextInput] = SDL_CreateSystemCursor(SDL_SYSTEM_CURSOR_IBEAM); + bd->MouseCursors[ImGuiMouseCursor_ResizeAll] = SDL_CreateSystemCursor(SDL_SYSTEM_CURSOR_SIZEALL); + bd->MouseCursors[ImGuiMouseCursor_ResizeNS] = SDL_CreateSystemCursor(SDL_SYSTEM_CURSOR_SIZENS); + bd->MouseCursors[ImGuiMouseCursor_ResizeEW] = SDL_CreateSystemCursor(SDL_SYSTEM_CURSOR_SIZEWE); + bd->MouseCursors[ImGuiMouseCursor_ResizeNESW] = SDL_CreateSystemCursor(SDL_SYSTEM_CURSOR_SIZENESW); + bd->MouseCursors[ImGuiMouseCursor_ResizeNWSE] = SDL_CreateSystemCursor(SDL_SYSTEM_CURSOR_SIZENWSE); + bd->MouseCursors[ImGuiMouseCursor_Hand] = SDL_CreateSystemCursor(SDL_SYSTEM_CURSOR_HAND); + bd->MouseCursors[ImGuiMouseCursor_NotAllowed] = SDL_CreateSystemCursor(SDL_SYSTEM_CURSOR_NO); + +#ifdef _WIN32 + SDL_SysWMinfo info; + SDL_VERSION(&info.version); + if (SDL_GetWindowWMInfo(window, &info)) + io.ImeWindowHandle = info.info.win.window; +#else + (void)window; +#endif + + // Set SDL hint to receive mouse click events on window focus, otherwise SDL doesn't emit the event. + // Without this, when clicking to gain focus, our widgets wouldn't activate even though they showed as hovered. + // (This is unfortunately a global SDL setting, so enabling it might have a side-effect on your application. + // It is unlikely to make a difference, but if your app absolutely needs to ignore the initial on-focus click: + // you can ignore SDL_MOUSEBUTTONDOWN events coming right after a SDL_WINDOWEVENT_FOCUS_GAINED) +#if SDL_HAS_MOUSE_FOCUS_CLICKTHROUGH + SDL_SetHint(SDL_HINT_MOUSE_FOCUS_CLICKTHROUGH, "1"); +#endif + + return true; +} + +bool ImGui_ImplSDL2_InitForOpenGL(SDL_Window* window, void* sdl_gl_context) +{ + IM_UNUSED(sdl_gl_context); // Viewport branch will need this. + return ImGui_ImplSDL2_Init(window); +} + +bool ImGui_ImplSDL2_InitForVulkan(SDL_Window* window) +{ +#if !SDL_HAS_VULKAN + IM_ASSERT(0 && "Unsupported"); +#endif + return ImGui_ImplSDL2_Init(window); +} + +bool ImGui_ImplSDL2_InitForD3D(SDL_Window* window) +{ +#if !defined(_WIN32) + IM_ASSERT(0 && "Unsupported"); +#endif + return ImGui_ImplSDL2_Init(window); +} + +bool ImGui_ImplSDL2_InitForMetal(SDL_Window* window) +{ + return ImGui_ImplSDL2_Init(window); +} + +void ImGui_ImplSDL2_Shutdown() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplSDL2_Data* bd = ImGui_ImplSDL2_GetBackendData(); + + if (bd->ClipboardTextData) + SDL_free(bd->ClipboardTextData); + for (ImGuiMouseCursor cursor_n = 0; cursor_n < ImGuiMouseCursor_COUNT; cursor_n++) + SDL_FreeCursor(bd->MouseCursors[cursor_n]); + + io.BackendPlatformName = NULL; + io.BackendPlatformUserData = NULL; + IM_DELETE(bd); +} + +static void ImGui_ImplSDL2_UpdateMousePosAndButtons() +{ + ImGui_ImplSDL2_Data* bd = ImGui_ImplSDL2_GetBackendData(); + ImGuiIO& io = ImGui::GetIO(); + + ImVec2 mouse_pos_prev = io.MousePos; + io.MousePos = ImVec2(-FLT_MAX, -FLT_MAX); + + // Update mouse buttons + int mouse_x_local, mouse_y_local; + Uint32 mouse_buttons = SDL_GetMouseState(&mouse_x_local, &mouse_y_local); + io.MouseDown[0] = bd->MousePressed[0] || (mouse_buttons & SDL_BUTTON(SDL_BUTTON_LEFT)) != 0; // If a mouse press event came, always pass it as "mouse held this frame", so we don't miss click-release events that are shorter than 1 frame. + io.MouseDown[1] = bd->MousePressed[1] || (mouse_buttons & SDL_BUTTON(SDL_BUTTON_RIGHT)) != 0; + io.MouseDown[2] = bd->MousePressed[2] || (mouse_buttons & SDL_BUTTON(SDL_BUTTON_MIDDLE)) != 0; + bd->MousePressed[0] = bd->MousePressed[1] = bd->MousePressed[2] = false; + + // Obtain focused and hovered window. We forward mouse input when focused or when hovered (and no other window is capturing) +#if SDL_HAS_CAPTURE_AND_GLOBAL_MOUSE + SDL_Window* focused_window = SDL_GetKeyboardFocus(); + SDL_Window* hovered_window = SDL_HAS_MOUSE_FOCUS_CLICKTHROUGH ? SDL_GetMouseFocus() : NULL; // This is better but is only reliably useful with SDL 2.0.5+ and SDL_HINT_MOUSE_FOCUS_CLICKTHROUGH. + SDL_Window* mouse_window = NULL; + if (hovered_window && bd->Window == hovered_window) + mouse_window = hovered_window; + else if (focused_window && bd->Window == focused_window) + mouse_window = focused_window; + + // SDL_CaptureMouse() let the OS know e.g. that our imgui drag outside the SDL window boundaries shouldn't e.g. trigger other operations outside + SDL_CaptureMouse(ImGui::IsAnyMouseDown() ? SDL_TRUE : SDL_FALSE); +#else + // SDL 2.0.3 and non-windowed systems: single-viewport only + SDL_Window* mouse_window = (SDL_GetWindowFlags(bd->Window) & SDL_WINDOW_INPUT_FOCUS) ? bd->Window : NULL; +#endif + + if (mouse_window == NULL) + return; + + // Set OS mouse position from Dear ImGui if requested (rarely used, only when ImGuiConfigFlags_NavEnableSetMousePos is enabled by user) + if (io.WantSetMousePos) + SDL_WarpMouseInWindow(bd->Window, (int)mouse_pos_prev.x, (int)mouse_pos_prev.y); + + // Set Dear ImGui mouse position from OS position + get buttons. (this is the common behavior) + if (bd->MouseCanUseGlobalState) + { + // Single-viewport mode: mouse position in client window coordinates (io.MousePos is (0,0) when the mouse is on the upper-left corner of the app window) + // Unlike local position obtained earlier this will be valid when straying out of bounds. + int mouse_x_global, mouse_y_global; + SDL_GetGlobalMouseState(&mouse_x_global, &mouse_y_global); + int window_x, window_y; + SDL_GetWindowPosition(mouse_window, &window_x, &window_y); + io.MousePos = ImVec2((float)(mouse_x_global - window_x), (float)(mouse_y_global - window_y)); + } + else + { + io.MousePos = ImVec2((float)mouse_x_local, (float)mouse_y_local); + } +} + +static void ImGui_ImplSDL2_UpdateMouseCursor() +{ + ImGuiIO& io = ImGui::GetIO(); + if (io.ConfigFlags & ImGuiConfigFlags_NoMouseCursorChange) + return; + ImGui_ImplSDL2_Data* bd = ImGui_ImplSDL2_GetBackendData(); + + ImGuiMouseCursor imgui_cursor = ImGui::GetMouseCursor(); + if (io.MouseDrawCursor || imgui_cursor == ImGuiMouseCursor_None) + { + // Hide OS mouse cursor if imgui is drawing it or if it wants no cursor + SDL_ShowCursor(SDL_FALSE); + } + else + { + // Show OS mouse cursor + SDL_SetCursor(bd->MouseCursors[imgui_cursor] ? bd->MouseCursors[imgui_cursor] : bd->MouseCursors[ImGuiMouseCursor_Arrow]); + SDL_ShowCursor(SDL_TRUE); + } +} + +static void ImGui_ImplSDL2_UpdateGamepads() +{ + ImGuiIO& io = ImGui::GetIO(); + memset(io.NavInputs, 0, sizeof(io.NavInputs)); + if ((io.ConfigFlags & ImGuiConfigFlags_NavEnableGamepad) == 0) + return; + + // Get gamepad + SDL_GameController* game_controller = SDL_GameControllerOpen(0); + if (!game_controller) + { + io.BackendFlags &= ~ImGuiBackendFlags_HasGamepad; + return; + } + + // Update gamepad inputs + #define MAP_BUTTON(NAV_NO, BUTTON_NO) { io.NavInputs[NAV_NO] = (SDL_GameControllerGetButton(game_controller, BUTTON_NO) != 0) ? 1.0f : 0.0f; } + #define MAP_ANALOG(NAV_NO, AXIS_NO, V0, V1) { float vn = (float)(SDL_GameControllerGetAxis(game_controller, AXIS_NO) - V0) / (float)(V1 - V0); if (vn > 1.0f) vn = 1.0f; if (vn > 0.0f && io.NavInputs[NAV_NO] < vn) io.NavInputs[NAV_NO] = vn; } + const int thumb_dead_zone = 8000; // SDL_gamecontroller.h suggests using this value. + MAP_BUTTON(ImGuiNavInput_Activate, SDL_CONTROLLER_BUTTON_A); // Cross / A + MAP_BUTTON(ImGuiNavInput_Cancel, SDL_CONTROLLER_BUTTON_B); // Circle / B + MAP_BUTTON(ImGuiNavInput_Menu, SDL_CONTROLLER_BUTTON_X); // Square / X + MAP_BUTTON(ImGuiNavInput_Input, SDL_CONTROLLER_BUTTON_Y); // Triangle / Y + MAP_BUTTON(ImGuiNavInput_DpadLeft, SDL_CONTROLLER_BUTTON_DPAD_LEFT); // D-Pad Left + MAP_BUTTON(ImGuiNavInput_DpadRight, SDL_CONTROLLER_BUTTON_DPAD_RIGHT); // D-Pad Right + MAP_BUTTON(ImGuiNavInput_DpadUp, SDL_CONTROLLER_BUTTON_DPAD_UP); // D-Pad Up + MAP_BUTTON(ImGuiNavInput_DpadDown, SDL_CONTROLLER_BUTTON_DPAD_DOWN); // D-Pad Down + MAP_BUTTON(ImGuiNavInput_FocusPrev, SDL_CONTROLLER_BUTTON_LEFTSHOULDER); // L1 / LB + MAP_BUTTON(ImGuiNavInput_FocusNext, SDL_CONTROLLER_BUTTON_RIGHTSHOULDER); // R1 / RB + MAP_BUTTON(ImGuiNavInput_TweakSlow, SDL_CONTROLLER_BUTTON_LEFTSHOULDER); // L1 / LB + MAP_BUTTON(ImGuiNavInput_TweakFast, SDL_CONTROLLER_BUTTON_RIGHTSHOULDER); // R1 / RB + MAP_ANALOG(ImGuiNavInput_LStickLeft, SDL_CONTROLLER_AXIS_LEFTX, -thumb_dead_zone, -32768); + MAP_ANALOG(ImGuiNavInput_LStickRight, SDL_CONTROLLER_AXIS_LEFTX, +thumb_dead_zone, +32767); + MAP_ANALOG(ImGuiNavInput_LStickUp, SDL_CONTROLLER_AXIS_LEFTY, -thumb_dead_zone, -32767); + MAP_ANALOG(ImGuiNavInput_LStickDown, SDL_CONTROLLER_AXIS_LEFTY, +thumb_dead_zone, +32767); + + io.BackendFlags |= ImGuiBackendFlags_HasGamepad; + #undef MAP_BUTTON + #undef MAP_ANALOG +} + +void ImGui_ImplSDL2_NewFrame() +{ + ImGui_ImplSDL2_Data* bd = ImGui_ImplSDL2_GetBackendData(); + IM_ASSERT(bd != NULL && "Did you call ImGui_ImplSDL2_Init()?"); + ImGuiIO& io = ImGui::GetIO(); + + // Setup display size (every frame to accommodate for window resizing) + int w, h; + int display_w, display_h; + SDL_GetWindowSize(bd->Window, &w, &h); + if (SDL_GetWindowFlags(bd->Window) & SDL_WINDOW_MINIMIZED) + w = h = 0; + SDL_GL_GetDrawableSize(bd->Window, &display_w, &display_h); + io.DisplaySize = ImVec2((float)w, (float)h); + if (w > 0 && h > 0) + io.DisplayFramebufferScale = ImVec2((float)display_w / w, (float)display_h / h); + + // Setup time step (we don't use SDL_GetTicks() because it is using millisecond resolution) + static Uint64 frequency = SDL_GetPerformanceFrequency(); + Uint64 current_time = SDL_GetPerformanceCounter(); + io.DeltaTime = bd->Time > 0 ? (float)((double)(current_time - bd->Time) / frequency) : (float)(1.0f / 60.0f); + bd->Time = current_time; + + ImGui_ImplSDL2_UpdateMousePosAndButtons(); + ImGui_ImplSDL2_UpdateMouseCursor(); + + // Update game controllers (if enabled and available) + ImGui_ImplSDL2_UpdateGamepads(); +} diff --git a/source/editor/imgui/backends/imgui_impl_sdl.h b/source/editor/imgui/backends/imgui_impl_sdl.h new file mode 100644 index 0000000..9b40a67 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_sdl.h @@ -0,0 +1,34 @@ +// dear imgui: Platform Backend for SDL2 +// This needs to be used along with a Renderer (e.g. DirectX11, OpenGL3, Vulkan..) +// (Info: SDL2 is a cross-platform general purpose library for handling windows, inputs, graphics context creation, etc.) + +// Implemented features: +// [X] Platform: Mouse cursor shape and visibility. Disable with 'io.ConfigFlags |= ImGuiConfigFlags_NoMouseCursorChange'. +// [X] Platform: Clipboard support. +// [X] Platform: Keyboard arrays indexed using SDL_SCANCODE_* codes, e.g. ImGui::IsKeyPressed(SDL_SCANCODE_SPACE). +// [X] Platform: Gamepad support. Enabled with 'io.ConfigFlags |= ImGuiConfigFlags_NavEnableGamepad'. +// Missing features: +// [ ] Platform: SDL2 handling of IME under Windows appears to be broken and it explicitly disable the regular Windows IME. You can restore Windows IME by compiling SDL with SDL_DISABLE_WINDOWS_IME. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +struct SDL_Window; +typedef union SDL_Event SDL_Event; + +IMGUI_IMPL_API bool ImGui_ImplSDL2_InitForOpenGL(SDL_Window* window, void* sdl_gl_context); +IMGUI_IMPL_API bool ImGui_ImplSDL2_InitForVulkan(SDL_Window* window); +IMGUI_IMPL_API bool ImGui_ImplSDL2_InitForD3D(SDL_Window* window); +IMGUI_IMPL_API bool ImGui_ImplSDL2_InitForMetal(SDL_Window* window); +IMGUI_IMPL_API void ImGui_ImplSDL2_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplSDL2_NewFrame(); +IMGUI_IMPL_API bool ImGui_ImplSDL2_ProcessEvent(const SDL_Event* event); + +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS +static inline void ImGui_ImplSDL2_NewFrame(SDL_Window*) { ImGui_ImplSDL2_NewFrame(); } // 1.84: removed unnecessary parameter +#endif diff --git a/source/editor/imgui/backends/imgui_impl_vulkan.cpp b/source/editor/imgui/backends/imgui_impl_vulkan.cpp new file mode 100644 index 0000000..40dd0bc --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_vulkan.cpp @@ -0,0 +1,1462 @@ +// dear imgui: Renderer Backend for Vulkan +// This needs to be used along with a Platform Backend (e.g. GLFW, SDL, Win32, custom..) + +// Implemented features: +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. +// Missing features: +// [ ] Renderer: User texture binding. Changes of ImTextureID aren't supported by this backend! See https://github.com/ocornut/imgui/pull/914 + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// The aim of imgui_impl_vulkan.h/.cpp is to be usable in your engine without any modification. +// IF YOU FEEL YOU NEED TO MAKE ANY CHANGE TO THIS CODE, please share them and your feedback at https://github.com/ocornut/imgui/ + +// Important note to the reader who wish to integrate imgui_impl_vulkan.cpp/.h in their own engine/app. +// - Common ImGui_ImplVulkan_XXX functions and structures are used to interface with imgui_impl_vulkan.cpp/.h. +// You will use those if you want to use this rendering backend in your engine/app. +// - Helper ImGui_ImplVulkanH_XXX functions and structures are only used by this example (main.cpp) and by +// the backend itself (imgui_impl_vulkan.cpp), but should PROBABLY NOT be used by your own engine/app code. +// Read comments in imgui_impl_vulkan.h. + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-06-29: Reorganized backend to pull data from a single structure to facilitate usage with multiple-contexts (all g_XXXX access changed to bd->XXXX). +// 2021-03-22: Vulkan: Fix mapped memory validation error when buffer sizes are not multiple of VkPhysicalDeviceLimits::nonCoherentAtomSize. +// 2021-02-18: Vulkan: Change blending equation to preserve alpha in output buffer. +// 2021-01-27: Vulkan: Added support for custom function load and IMGUI_IMPL_VULKAN_NO_PROTOTYPES by using ImGui_ImplVulkan_LoadFunctions(). +// 2020-11-11: Vulkan: Added support for specifying which subpass to reference during VkPipeline creation. +// 2020-09-07: Vulkan: Added VkPipeline parameter to ImGui_ImplVulkan_RenderDrawData (default to one passed to ImGui_ImplVulkan_Init). +// 2020-05-04: Vulkan: Fixed crash if initial frame has no vertices. +// 2020-04-26: Vulkan: Fixed edge case where render callbacks wouldn't be called if the ImDrawData didn't have vertices. +// 2019-08-01: Vulkan: Added support for specifying multisample count. Set ImGui_ImplVulkan_InitInfo::MSAASamples to one of the VkSampleCountFlagBits values to use, default is non-multisampled as before. +// 2019-05-29: Vulkan: Added support for large mesh (64K+ vertices), enable ImGuiBackendFlags_RendererHasVtxOffset flag. +// 2019-04-30: Vulkan: Added support for special ImDrawCallback_ResetRenderState callback to reset render state. +// 2019-04-04: *BREAKING CHANGE*: Vulkan: Added ImageCount/MinImageCount fields in ImGui_ImplVulkan_InitInfo, required for initialization (was previously a hard #define IMGUI_VK_QUEUED_FRAMES 2). Added ImGui_ImplVulkan_SetMinImageCount(). +// 2019-04-04: Vulkan: Added VkInstance argument to ImGui_ImplVulkanH_CreateWindow() optional helper. +// 2019-04-04: Vulkan: Avoid passing negative coordinates to vkCmdSetScissor, which debug validation layers do not like. +// 2019-04-01: Vulkan: Support for 32-bit index buffer (#define ImDrawIdx unsigned int). +// 2019-02-16: Vulkan: Viewport and clipping rectangles correctly using draw_data->FramebufferScale to allow retina display. +// 2018-11-30: Misc: Setting up io.BackendRendererName so it can be displayed in the About Window. +// 2018-08-25: Vulkan: Fixed mishandled VkSurfaceCapabilitiesKHR::maxImageCount=0 case. +// 2018-06-22: Inverted the parameters to ImGui_ImplVulkan_RenderDrawData() to be consistent with other backends. +// 2018-06-08: Misc: Extracted imgui_impl_vulkan.cpp/.h away from the old combined GLFW+Vulkan example. +// 2018-06-08: Vulkan: Use draw_data->DisplayPos and draw_data->DisplaySize to setup projection matrix and clipping rectangle. +// 2018-03-03: Vulkan: Various refactor, created a couple of ImGui_ImplVulkanH_XXX helper that the example can use and that viewport support will use. +// 2018-03-01: Vulkan: Renamed ImGui_ImplVulkan_Init_Info to ImGui_ImplVulkan_InitInfo and fields to match more closely Vulkan terminology. +// 2018-02-16: Misc: Obsoleted the io.RenderDrawListsFn callback, ImGui_ImplVulkan_Render() calls ImGui_ImplVulkan_RenderDrawData() itself. +// 2018-02-06: Misc: Removed call to ImGui::Shutdown() which is not available from 1.60 WIP, user needs to call CreateContext/DestroyContext themselves. +// 2017-05-15: Vulkan: Fix scissor offset being negative. Fix new Vulkan validation warnings. Set required depth member for buffer image copy. +// 2016-11-13: Vulkan: Fix validation layer warnings and errors and redeclare gl_PerVertex. +// 2016-10-18: Vulkan: Add location decorators & change to use structs as in/out in glsl, update embedded spv (produced with glslangValidator -x). Null the released resources. +// 2016-08-27: Vulkan: Fix Vulkan example for use when a depth buffer is active. + +#include "imgui_impl_vulkan.h" +#include + +// Reusable buffers used for rendering 1 current in-flight frame, for ImGui_ImplVulkan_RenderDrawData() +// [Please zero-clear before use!] +struct ImGui_ImplVulkanH_FrameRenderBuffers +{ + VkDeviceMemory VertexBufferMemory; + VkDeviceMemory IndexBufferMemory; + VkDeviceSize VertexBufferSize; + VkDeviceSize IndexBufferSize; + VkBuffer VertexBuffer; + VkBuffer IndexBuffer; +}; + +// Each viewport will hold 1 ImGui_ImplVulkanH_WindowRenderBuffers +// [Please zero-clear before use!] +struct ImGui_ImplVulkanH_WindowRenderBuffers +{ + uint32_t Index; + uint32_t Count; + ImGui_ImplVulkanH_FrameRenderBuffers* FrameRenderBuffers; +}; + +// Vulkan data +struct ImGui_ImplVulkan_Data +{ + ImGui_ImplVulkan_InitInfo VulkanInitInfo; + VkRenderPass RenderPass; + VkDeviceSize BufferMemoryAlignment; + VkPipelineCreateFlags PipelineCreateFlags; + VkDescriptorSetLayout DescriptorSetLayout; + VkPipelineLayout PipelineLayout; + VkDescriptorSet DescriptorSet; + VkPipeline Pipeline; + uint32_t Subpass; + VkShaderModule ShaderModuleVert; + VkShaderModule ShaderModuleFrag; + + // Font data + VkSampler FontSampler; + VkDeviceMemory FontMemory; + VkImage FontImage; + VkImageView FontView; + VkDeviceMemory UploadBufferMemory; + VkBuffer UploadBuffer; + + // Render buffers + ImGui_ImplVulkanH_WindowRenderBuffers MainWindowRenderBuffers; + + ImGui_ImplVulkan_Data() + { + memset(this, 0, sizeof(*this)); + BufferMemoryAlignment = 256; + } +}; + +// Forward Declarations +bool ImGui_ImplVulkan_CreateDeviceObjects(); +void ImGui_ImplVulkan_DestroyDeviceObjects(); +void ImGui_ImplVulkanH_DestroyFrame(VkDevice device, ImGui_ImplVulkanH_Frame* fd, const VkAllocationCallbacks* allocator); +void ImGui_ImplVulkanH_DestroyFrameSemaphores(VkDevice device, ImGui_ImplVulkanH_FrameSemaphores* fsd, const VkAllocationCallbacks* allocator); +void ImGui_ImplVulkanH_DestroyFrameRenderBuffers(VkDevice device, ImGui_ImplVulkanH_FrameRenderBuffers* buffers, const VkAllocationCallbacks* allocator); +void ImGui_ImplVulkanH_DestroyWindowRenderBuffers(VkDevice device, ImGui_ImplVulkanH_WindowRenderBuffers* buffers, const VkAllocationCallbacks* allocator); +void ImGui_ImplVulkanH_CreateWindowSwapChain(VkPhysicalDevice physical_device, VkDevice device, ImGui_ImplVulkanH_Window* wd, const VkAllocationCallbacks* allocator, int w, int h, uint32_t min_image_count); +void ImGui_ImplVulkanH_CreateWindowCommandBuffers(VkPhysicalDevice physical_device, VkDevice device, ImGui_ImplVulkanH_Window* wd, uint32_t queue_family, const VkAllocationCallbacks* allocator); + +// Vulkan prototypes for use with custom loaders +// (see description of IMGUI_IMPL_VULKAN_NO_PROTOTYPES in imgui_impl_vulkan.h +#ifdef VK_NO_PROTOTYPES +static bool g_FunctionsLoaded = false; +#else +static bool g_FunctionsLoaded = true; +#endif +#ifdef VK_NO_PROTOTYPES +#define IMGUI_VULKAN_FUNC_MAP(IMGUI_VULKAN_FUNC_MAP_MACRO) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkAllocateCommandBuffers) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkAllocateDescriptorSets) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkAllocateMemory) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkBindBufferMemory) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkBindImageMemory) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCmdBindDescriptorSets) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCmdBindIndexBuffer) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCmdBindPipeline) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCmdBindVertexBuffers) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCmdCopyBufferToImage) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCmdDrawIndexed) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCmdPipelineBarrier) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCmdPushConstants) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCmdSetScissor) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCmdSetViewport) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateBuffer) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateCommandPool) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateDescriptorSetLayout) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateFence) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateFramebuffer) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateGraphicsPipelines) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateImage) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateImageView) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreatePipelineLayout) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateRenderPass) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateSampler) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateSemaphore) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateShaderModule) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkCreateSwapchainKHR) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroyBuffer) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroyCommandPool) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroyDescriptorSetLayout) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroyFence) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroyFramebuffer) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroyImage) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroyImageView) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroyPipeline) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroyPipelineLayout) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroyRenderPass) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroySampler) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroySemaphore) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroyShaderModule) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroySurfaceKHR) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDestroySwapchainKHR) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkDeviceWaitIdle) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkFlushMappedMemoryRanges) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkFreeCommandBuffers) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkFreeMemory) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkGetBufferMemoryRequirements) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkGetImageMemoryRequirements) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkGetPhysicalDeviceMemoryProperties) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkGetPhysicalDeviceSurfaceCapabilitiesKHR) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkGetPhysicalDeviceSurfaceFormatsKHR) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkGetPhysicalDeviceSurfacePresentModesKHR) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkGetSwapchainImagesKHR) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkMapMemory) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkUnmapMemory) \ + IMGUI_VULKAN_FUNC_MAP_MACRO(vkUpdateDescriptorSets) + +// Define function pointers +#define IMGUI_VULKAN_FUNC_DEF(func) static PFN_##func func; +IMGUI_VULKAN_FUNC_MAP(IMGUI_VULKAN_FUNC_DEF) +#undef IMGUI_VULKAN_FUNC_DEF +#endif // VK_NO_PROTOTYPES + +//----------------------------------------------------------------------------- +// SHADERS +//----------------------------------------------------------------------------- + +// glsl_shader.vert, compiled with: +// # glslangValidator -V -x -o glsl_shader.vert.u32 glsl_shader.vert +/* +#version 450 core +layout(location = 0) in vec2 aPos; +layout(location = 1) in vec2 aUV; +layout(location = 2) in vec4 aColor; +layout(push_constant) uniform uPushConstant { vec2 uScale; vec2 uTranslate; } pc; + +out gl_PerVertex { vec4 gl_Position; }; +layout(location = 0) out struct { vec4 Color; vec2 UV; } Out; + +void main() +{ + Out.Color = aColor; + Out.UV = aUV; + gl_Position = vec4(aPos * pc.uScale + pc.uTranslate, 0, 1); +} +*/ +static uint32_t __glsl_shader_vert_spv[] = +{ + 0x07230203,0x00010000,0x00080001,0x0000002e,0x00000000,0x00020011,0x00000001,0x0006000b, + 0x00000001,0x4c534c47,0x6474732e,0x3035342e,0x00000000,0x0003000e,0x00000000,0x00000001, + 0x000a000f,0x00000000,0x00000004,0x6e69616d,0x00000000,0x0000000b,0x0000000f,0x00000015, + 0x0000001b,0x0000001c,0x00030003,0x00000002,0x000001c2,0x00040005,0x00000004,0x6e69616d, + 0x00000000,0x00030005,0x00000009,0x00000000,0x00050006,0x00000009,0x00000000,0x6f6c6f43, + 0x00000072,0x00040006,0x00000009,0x00000001,0x00005655,0x00030005,0x0000000b,0x0074754f, + 0x00040005,0x0000000f,0x6c6f4361,0x0000726f,0x00030005,0x00000015,0x00565561,0x00060005, + 0x00000019,0x505f6c67,0x65567265,0x78657472,0x00000000,0x00060006,0x00000019,0x00000000, + 0x505f6c67,0x7469736f,0x006e6f69,0x00030005,0x0000001b,0x00000000,0x00040005,0x0000001c, + 0x736f5061,0x00000000,0x00060005,0x0000001e,0x73755075,0x6e6f4368,0x6e617473,0x00000074, + 0x00050006,0x0000001e,0x00000000,0x61635375,0x0000656c,0x00060006,0x0000001e,0x00000001, + 0x61725475,0x616c736e,0x00006574,0x00030005,0x00000020,0x00006370,0x00040047,0x0000000b, + 0x0000001e,0x00000000,0x00040047,0x0000000f,0x0000001e,0x00000002,0x00040047,0x00000015, + 0x0000001e,0x00000001,0x00050048,0x00000019,0x00000000,0x0000000b,0x00000000,0x00030047, + 0x00000019,0x00000002,0x00040047,0x0000001c,0x0000001e,0x00000000,0x00050048,0x0000001e, + 0x00000000,0x00000023,0x00000000,0x00050048,0x0000001e,0x00000001,0x00000023,0x00000008, + 0x00030047,0x0000001e,0x00000002,0x00020013,0x00000002,0x00030021,0x00000003,0x00000002, + 0x00030016,0x00000006,0x00000020,0x00040017,0x00000007,0x00000006,0x00000004,0x00040017, + 0x00000008,0x00000006,0x00000002,0x0004001e,0x00000009,0x00000007,0x00000008,0x00040020, + 0x0000000a,0x00000003,0x00000009,0x0004003b,0x0000000a,0x0000000b,0x00000003,0x00040015, + 0x0000000c,0x00000020,0x00000001,0x0004002b,0x0000000c,0x0000000d,0x00000000,0x00040020, + 0x0000000e,0x00000001,0x00000007,0x0004003b,0x0000000e,0x0000000f,0x00000001,0x00040020, + 0x00000011,0x00000003,0x00000007,0x0004002b,0x0000000c,0x00000013,0x00000001,0x00040020, + 0x00000014,0x00000001,0x00000008,0x0004003b,0x00000014,0x00000015,0x00000001,0x00040020, + 0x00000017,0x00000003,0x00000008,0x0003001e,0x00000019,0x00000007,0x00040020,0x0000001a, + 0x00000003,0x00000019,0x0004003b,0x0000001a,0x0000001b,0x00000003,0x0004003b,0x00000014, + 0x0000001c,0x00000001,0x0004001e,0x0000001e,0x00000008,0x00000008,0x00040020,0x0000001f, + 0x00000009,0x0000001e,0x0004003b,0x0000001f,0x00000020,0x00000009,0x00040020,0x00000021, + 0x00000009,0x00000008,0x0004002b,0x00000006,0x00000028,0x00000000,0x0004002b,0x00000006, + 0x00000029,0x3f800000,0x00050036,0x00000002,0x00000004,0x00000000,0x00000003,0x000200f8, + 0x00000005,0x0004003d,0x00000007,0x00000010,0x0000000f,0x00050041,0x00000011,0x00000012, + 0x0000000b,0x0000000d,0x0003003e,0x00000012,0x00000010,0x0004003d,0x00000008,0x00000016, + 0x00000015,0x00050041,0x00000017,0x00000018,0x0000000b,0x00000013,0x0003003e,0x00000018, + 0x00000016,0x0004003d,0x00000008,0x0000001d,0x0000001c,0x00050041,0x00000021,0x00000022, + 0x00000020,0x0000000d,0x0004003d,0x00000008,0x00000023,0x00000022,0x00050085,0x00000008, + 0x00000024,0x0000001d,0x00000023,0x00050041,0x00000021,0x00000025,0x00000020,0x00000013, + 0x0004003d,0x00000008,0x00000026,0x00000025,0x00050081,0x00000008,0x00000027,0x00000024, + 0x00000026,0x00050051,0x00000006,0x0000002a,0x00000027,0x00000000,0x00050051,0x00000006, + 0x0000002b,0x00000027,0x00000001,0x00070050,0x00000007,0x0000002c,0x0000002a,0x0000002b, + 0x00000028,0x00000029,0x00050041,0x00000011,0x0000002d,0x0000001b,0x0000000d,0x0003003e, + 0x0000002d,0x0000002c,0x000100fd,0x00010038 +}; + +// glsl_shader.frag, compiled with: +// # glslangValidator -V -x -o glsl_shader.frag.u32 glsl_shader.frag +/* +#version 450 core +layout(location = 0) out vec4 fColor; +layout(set=0, binding=0) uniform sampler2D sTexture; +layout(location = 0) in struct { vec4 Color; vec2 UV; } In; +void main() +{ + fColor = In.Color * texture(sTexture, In.UV.st); +} +*/ +static uint32_t __glsl_shader_frag_spv[] = +{ + 0x07230203,0x00010000,0x00080001,0x0000001e,0x00000000,0x00020011,0x00000001,0x0006000b, + 0x00000001,0x4c534c47,0x6474732e,0x3035342e,0x00000000,0x0003000e,0x00000000,0x00000001, + 0x0007000f,0x00000004,0x00000004,0x6e69616d,0x00000000,0x00000009,0x0000000d,0x00030010, + 0x00000004,0x00000007,0x00030003,0x00000002,0x000001c2,0x00040005,0x00000004,0x6e69616d, + 0x00000000,0x00040005,0x00000009,0x6c6f4366,0x0000726f,0x00030005,0x0000000b,0x00000000, + 0x00050006,0x0000000b,0x00000000,0x6f6c6f43,0x00000072,0x00040006,0x0000000b,0x00000001, + 0x00005655,0x00030005,0x0000000d,0x00006e49,0x00050005,0x00000016,0x78655473,0x65727574, + 0x00000000,0x00040047,0x00000009,0x0000001e,0x00000000,0x00040047,0x0000000d,0x0000001e, + 0x00000000,0x00040047,0x00000016,0x00000022,0x00000000,0x00040047,0x00000016,0x00000021, + 0x00000000,0x00020013,0x00000002,0x00030021,0x00000003,0x00000002,0x00030016,0x00000006, + 0x00000020,0x00040017,0x00000007,0x00000006,0x00000004,0x00040020,0x00000008,0x00000003, + 0x00000007,0x0004003b,0x00000008,0x00000009,0x00000003,0x00040017,0x0000000a,0x00000006, + 0x00000002,0x0004001e,0x0000000b,0x00000007,0x0000000a,0x00040020,0x0000000c,0x00000001, + 0x0000000b,0x0004003b,0x0000000c,0x0000000d,0x00000001,0x00040015,0x0000000e,0x00000020, + 0x00000001,0x0004002b,0x0000000e,0x0000000f,0x00000000,0x00040020,0x00000010,0x00000001, + 0x00000007,0x00090019,0x00000013,0x00000006,0x00000001,0x00000000,0x00000000,0x00000000, + 0x00000001,0x00000000,0x0003001b,0x00000014,0x00000013,0x00040020,0x00000015,0x00000000, + 0x00000014,0x0004003b,0x00000015,0x00000016,0x00000000,0x0004002b,0x0000000e,0x00000018, + 0x00000001,0x00040020,0x00000019,0x00000001,0x0000000a,0x00050036,0x00000002,0x00000004, + 0x00000000,0x00000003,0x000200f8,0x00000005,0x00050041,0x00000010,0x00000011,0x0000000d, + 0x0000000f,0x0004003d,0x00000007,0x00000012,0x00000011,0x0004003d,0x00000014,0x00000017, + 0x00000016,0x00050041,0x00000019,0x0000001a,0x0000000d,0x00000018,0x0004003d,0x0000000a, + 0x0000001b,0x0000001a,0x00050057,0x00000007,0x0000001c,0x00000017,0x0000001b,0x00050085, + 0x00000007,0x0000001d,0x00000012,0x0000001c,0x0003003e,0x00000009,0x0000001d,0x000100fd, + 0x00010038 +}; + +//----------------------------------------------------------------------------- +// FUNCTIONS +//----------------------------------------------------------------------------- + +// Backend data stored in io.BackendRendererUserData to allow support for multiple Dear ImGui contexts +// It is STRONGLY preferred that you use docking branch with multi-viewports (== single Dear ImGui context + multiple windows) instead of multiple Dear ImGui contexts. +// FIXME: multi-context support is not tested and probably dysfunctional in this backend. +static ImGui_ImplVulkan_Data* ImGui_ImplVulkan_GetBackendData() +{ + return ImGui::GetCurrentContext() ? (ImGui_ImplVulkan_Data*)ImGui::GetIO().BackendRendererUserData : NULL; +} + +static uint32_t ImGui_ImplVulkan_MemoryType(VkMemoryPropertyFlags properties, uint32_t type_bits) +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + ImGui_ImplVulkan_InitInfo* v = &bd->VulkanInitInfo; + VkPhysicalDeviceMemoryProperties prop; + vkGetPhysicalDeviceMemoryProperties(v->PhysicalDevice, &prop); + for (uint32_t i = 0; i < prop.memoryTypeCount; i++) + if ((prop.memoryTypes[i].propertyFlags & properties) == properties && type_bits & (1 << i)) + return i; + return 0xFFFFFFFF; // Unable to find memoryType +} + +static void check_vk_result(VkResult err) +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + if (!bd) + return; + ImGui_ImplVulkan_InitInfo* v = &bd->VulkanInitInfo; + if (v->CheckVkResultFn) + v->CheckVkResultFn(err); +} + +static void CreateOrResizeBuffer(VkBuffer& buffer, VkDeviceMemory& buffer_memory, VkDeviceSize& p_buffer_size, size_t new_size, VkBufferUsageFlagBits usage) +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + ImGui_ImplVulkan_InitInfo* v = &bd->VulkanInitInfo; + VkResult err; + if (buffer != VK_NULL_HANDLE) + vkDestroyBuffer(v->Device, buffer, v->Allocator); + if (buffer_memory != VK_NULL_HANDLE) + vkFreeMemory(v->Device, buffer_memory, v->Allocator); + + VkDeviceSize vertex_buffer_size_aligned = ((new_size - 1) / bd->BufferMemoryAlignment + 1) * bd->BufferMemoryAlignment; + VkBufferCreateInfo buffer_info = {}; + buffer_info.sType = VK_STRUCTURE_TYPE_BUFFER_CREATE_INFO; + buffer_info.size = vertex_buffer_size_aligned; + buffer_info.usage = usage; + buffer_info.sharingMode = VK_SHARING_MODE_EXCLUSIVE; + err = vkCreateBuffer(v->Device, &buffer_info, v->Allocator, &buffer); + check_vk_result(err); + + VkMemoryRequirements req; + vkGetBufferMemoryRequirements(v->Device, buffer, &req); + bd->BufferMemoryAlignment = (bd->BufferMemoryAlignment > req.alignment) ? bd->BufferMemoryAlignment : req.alignment; + VkMemoryAllocateInfo alloc_info = {}; + alloc_info.sType = VK_STRUCTURE_TYPE_MEMORY_ALLOCATE_INFO; + alloc_info.allocationSize = req.size; + alloc_info.memoryTypeIndex = ImGui_ImplVulkan_MemoryType(VK_MEMORY_PROPERTY_HOST_VISIBLE_BIT, req.memoryTypeBits); + err = vkAllocateMemory(v->Device, &alloc_info, v->Allocator, &buffer_memory); + check_vk_result(err); + + err = vkBindBufferMemory(v->Device, buffer, buffer_memory, 0); + check_vk_result(err); + p_buffer_size = req.size; +} + +static void ImGui_ImplVulkan_SetupRenderState(ImDrawData* draw_data, VkPipeline pipeline, VkCommandBuffer command_buffer, ImGui_ImplVulkanH_FrameRenderBuffers* rb, int fb_width, int fb_height) +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + + // Bind pipeline and descriptor sets: + { + vkCmdBindPipeline(command_buffer, VK_PIPELINE_BIND_POINT_GRAPHICS, pipeline); + VkDescriptorSet desc_set[1] = { bd->DescriptorSet }; + vkCmdBindDescriptorSets(command_buffer, VK_PIPELINE_BIND_POINT_GRAPHICS, bd->PipelineLayout, 0, 1, desc_set, 0, NULL); + } + + // Bind Vertex And Index Buffer: + if (draw_data->TotalVtxCount > 0) + { + VkBuffer vertex_buffers[1] = { rb->VertexBuffer }; + VkDeviceSize vertex_offset[1] = { 0 }; + vkCmdBindVertexBuffers(command_buffer, 0, 1, vertex_buffers, vertex_offset); + vkCmdBindIndexBuffer(command_buffer, rb->IndexBuffer, 0, sizeof(ImDrawIdx) == 2 ? VK_INDEX_TYPE_UINT16 : VK_INDEX_TYPE_UINT32); + } + + // Setup viewport: + { + VkViewport viewport; + viewport.x = 0; + viewport.y = 0; + viewport.width = (float)fb_width; + viewport.height = (float)fb_height; + viewport.minDepth = 0.0f; + viewport.maxDepth = 1.0f; + vkCmdSetViewport(command_buffer, 0, 1, &viewport); + } + + // Setup scale and translation: + // Our visible imgui space lies from draw_data->DisplayPps (top left) to draw_data->DisplayPos+data_data->DisplaySize (bottom right). DisplayPos is (0,0) for single viewport apps. + { + float scale[2]; + scale[0] = 2.0f / draw_data->DisplaySize.x; + scale[1] = 2.0f / draw_data->DisplaySize.y; + float translate[2]; + translate[0] = -1.0f - draw_data->DisplayPos.x * scale[0]; + translate[1] = -1.0f - draw_data->DisplayPos.y * scale[1]; + vkCmdPushConstants(command_buffer, bd->PipelineLayout, VK_SHADER_STAGE_VERTEX_BIT, sizeof(float) * 0, sizeof(float) * 2, scale); + vkCmdPushConstants(command_buffer, bd->PipelineLayout, VK_SHADER_STAGE_VERTEX_BIT, sizeof(float) * 2, sizeof(float) * 2, translate); + } +} + +// Render function +void ImGui_ImplVulkan_RenderDrawData(ImDrawData* draw_data, VkCommandBuffer command_buffer, VkPipeline pipeline) +{ + // Avoid rendering when minimized, scale coordinates for retina displays (screen coordinates != framebuffer coordinates) + int fb_width = (int)(draw_data->DisplaySize.x * draw_data->FramebufferScale.x); + int fb_height = (int)(draw_data->DisplaySize.y * draw_data->FramebufferScale.y); + if (fb_width <= 0 || fb_height <= 0) + return; + + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + ImGui_ImplVulkan_InitInfo* v = &bd->VulkanInitInfo; + if (pipeline == VK_NULL_HANDLE) + pipeline = bd->Pipeline; + + // Allocate array to store enough vertex/index buffers + ImGui_ImplVulkanH_WindowRenderBuffers* wrb = &bd->MainWindowRenderBuffers; + if (wrb->FrameRenderBuffers == NULL) + { + wrb->Index = 0; + wrb->Count = v->ImageCount; + wrb->FrameRenderBuffers = (ImGui_ImplVulkanH_FrameRenderBuffers*)IM_ALLOC(sizeof(ImGui_ImplVulkanH_FrameRenderBuffers) * wrb->Count); + memset(wrb->FrameRenderBuffers, 0, sizeof(ImGui_ImplVulkanH_FrameRenderBuffers) * wrb->Count); + } + IM_ASSERT(wrb->Count == v->ImageCount); + wrb->Index = (wrb->Index + 1) % wrb->Count; + ImGui_ImplVulkanH_FrameRenderBuffers* rb = &wrb->FrameRenderBuffers[wrb->Index]; + + if (draw_data->TotalVtxCount > 0) + { + // Create or resize the vertex/index buffers + size_t vertex_size = draw_data->TotalVtxCount * sizeof(ImDrawVert); + size_t index_size = draw_data->TotalIdxCount * sizeof(ImDrawIdx); + if (rb->VertexBuffer == VK_NULL_HANDLE || rb->VertexBufferSize < vertex_size) + CreateOrResizeBuffer(rb->VertexBuffer, rb->VertexBufferMemory, rb->VertexBufferSize, vertex_size, VK_BUFFER_USAGE_VERTEX_BUFFER_BIT); + if (rb->IndexBuffer == VK_NULL_HANDLE || rb->IndexBufferSize < index_size) + CreateOrResizeBuffer(rb->IndexBuffer, rb->IndexBufferMemory, rb->IndexBufferSize, index_size, VK_BUFFER_USAGE_INDEX_BUFFER_BIT); + + // Upload vertex/index data into a single contiguous GPU buffer + ImDrawVert* vtx_dst = NULL; + ImDrawIdx* idx_dst = NULL; + VkResult err = vkMapMemory(v->Device, rb->VertexBufferMemory, 0, rb->VertexBufferSize, 0, (void**)(&vtx_dst)); + check_vk_result(err); + err = vkMapMemory(v->Device, rb->IndexBufferMemory, 0, rb->IndexBufferSize, 0, (void**)(&idx_dst)); + check_vk_result(err); + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + memcpy(vtx_dst, cmd_list->VtxBuffer.Data, cmd_list->VtxBuffer.Size * sizeof(ImDrawVert)); + memcpy(idx_dst, cmd_list->IdxBuffer.Data, cmd_list->IdxBuffer.Size * sizeof(ImDrawIdx)); + vtx_dst += cmd_list->VtxBuffer.Size; + idx_dst += cmd_list->IdxBuffer.Size; + } + VkMappedMemoryRange range[2] = {}; + range[0].sType = VK_STRUCTURE_TYPE_MAPPED_MEMORY_RANGE; + range[0].memory = rb->VertexBufferMemory; + range[0].size = VK_WHOLE_SIZE; + range[1].sType = VK_STRUCTURE_TYPE_MAPPED_MEMORY_RANGE; + range[1].memory = rb->IndexBufferMemory; + range[1].size = VK_WHOLE_SIZE; + err = vkFlushMappedMemoryRanges(v->Device, 2, range); + check_vk_result(err); + vkUnmapMemory(v->Device, rb->VertexBufferMemory); + vkUnmapMemory(v->Device, rb->IndexBufferMemory); + } + + // Setup desired Vulkan state + ImGui_ImplVulkan_SetupRenderState(draw_data, pipeline, command_buffer, rb, fb_width, fb_height); + + // Will project scissor/clipping rectangles into framebuffer space + ImVec2 clip_off = draw_data->DisplayPos; // (0,0) unless using multi-viewports + ImVec2 clip_scale = draw_data->FramebufferScale; // (1,1) unless using retina display which are often (2,2) + + // Render command lists + // (Because we merged all buffers into a single one, we maintain our own offset into them) + int global_vtx_offset = 0; + int global_idx_offset = 0; + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + const ImDrawCmd* pcmd = &cmd_list->CmdBuffer[cmd_i]; + if (pcmd->UserCallback != NULL) + { + // User callback, registered via ImDrawList::AddCallback() + // (ImDrawCallback_ResetRenderState is a special callback value used by the user to request the renderer to reset render state.) + if (pcmd->UserCallback == ImDrawCallback_ResetRenderState) + ImGui_ImplVulkan_SetupRenderState(draw_data, pipeline, command_buffer, rb, fb_width, fb_height); + else + pcmd->UserCallback(cmd_list, pcmd); + } + else + { + // Project scissor/clipping rectangles into framebuffer space + ImVec2 clip_min((pcmd->ClipRect.x - clip_off.x) * clip_scale.x, (pcmd->ClipRect.y - clip_off.y) * clip_scale.y); + ImVec2 clip_max((pcmd->ClipRect.z - clip_off.x) * clip_scale.x, (pcmd->ClipRect.w - clip_off.y) * clip_scale.y); + + // Clamp to viewport as vkCmdSetScissor() won't accept values that are off bounds + if (clip_min.x < 0.0f) { clip_min.x = 0.0f; } + if (clip_min.y < 0.0f) { clip_min.y = 0.0f; } + if (clip_max.x > fb_width) { clip_max.x = (float)fb_width; } + if (clip_max.y > fb_height) { clip_max.y = (float)fb_height; } + if (clip_max.x < clip_min.x || clip_max.y < clip_min.y) + continue; + + // Apply scissor/clipping rectangle + VkRect2D scissor; + scissor.offset.x = (int32_t)(clip_min.x); + scissor.offset.y = (int32_t)(clip_min.y); + scissor.extent.width = (uint32_t)(clip_max.x - clip_min.x); + scissor.extent.height = (uint32_t)(clip_max.y - clip_min.y); + vkCmdSetScissor(command_buffer, 0, 1, &scissor); + + // Draw + vkCmdDrawIndexed(command_buffer, pcmd->ElemCount, 1, pcmd->IdxOffset + global_idx_offset, pcmd->VtxOffset + global_vtx_offset, 0); + } + } + global_idx_offset += cmd_list->IdxBuffer.Size; + global_vtx_offset += cmd_list->VtxBuffer.Size; + } +} + +bool ImGui_ImplVulkan_CreateFontsTexture(VkCommandBuffer command_buffer) +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + ImGui_ImplVulkan_InitInfo* v = &bd->VulkanInitInfo; + + unsigned char* pixels; + int width, height; + io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height); + size_t upload_size = width * height * 4 * sizeof(char); + + VkResult err; + + // Create the Image: + { + VkImageCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_IMAGE_CREATE_INFO; + info.imageType = VK_IMAGE_TYPE_2D; + info.format = VK_FORMAT_R8G8B8A8_UNORM; + info.extent.width = width; + info.extent.height = height; + info.extent.depth = 1; + info.mipLevels = 1; + info.arrayLayers = 1; + info.samples = VK_SAMPLE_COUNT_1_BIT; + info.tiling = VK_IMAGE_TILING_OPTIMAL; + info.usage = VK_IMAGE_USAGE_SAMPLED_BIT | VK_IMAGE_USAGE_TRANSFER_DST_BIT; + info.sharingMode = VK_SHARING_MODE_EXCLUSIVE; + info.initialLayout = VK_IMAGE_LAYOUT_UNDEFINED; + err = vkCreateImage(v->Device, &info, v->Allocator, &bd->FontImage); + check_vk_result(err); + VkMemoryRequirements req; + vkGetImageMemoryRequirements(v->Device, bd->FontImage, &req); + VkMemoryAllocateInfo alloc_info = {}; + alloc_info.sType = VK_STRUCTURE_TYPE_MEMORY_ALLOCATE_INFO; + alloc_info.allocationSize = req.size; + alloc_info.memoryTypeIndex = ImGui_ImplVulkan_MemoryType(VK_MEMORY_PROPERTY_DEVICE_LOCAL_BIT, req.memoryTypeBits); + err = vkAllocateMemory(v->Device, &alloc_info, v->Allocator, &bd->FontMemory); + check_vk_result(err); + err = vkBindImageMemory(v->Device, bd->FontImage, bd->FontMemory, 0); + check_vk_result(err); + } + + // Create the Image View: + { + VkImageViewCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_IMAGE_VIEW_CREATE_INFO; + info.image = bd->FontImage; + info.viewType = VK_IMAGE_VIEW_TYPE_2D; + info.format = VK_FORMAT_R8G8B8A8_UNORM; + info.subresourceRange.aspectMask = VK_IMAGE_ASPECT_COLOR_BIT; + info.subresourceRange.levelCount = 1; + info.subresourceRange.layerCount = 1; + err = vkCreateImageView(v->Device, &info, v->Allocator, &bd->FontView); + check_vk_result(err); + } + + // Update the Descriptor Set: + { + VkDescriptorImageInfo desc_image[1] = {}; + desc_image[0].sampler = bd->FontSampler; + desc_image[0].imageView = bd->FontView; + desc_image[0].imageLayout = VK_IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL; + VkWriteDescriptorSet write_desc[1] = {}; + write_desc[0].sType = VK_STRUCTURE_TYPE_WRITE_DESCRIPTOR_SET; + write_desc[0].dstSet = bd->DescriptorSet; + write_desc[0].descriptorCount = 1; + write_desc[0].descriptorType = VK_DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER; + write_desc[0].pImageInfo = desc_image; + vkUpdateDescriptorSets(v->Device, 1, write_desc, 0, NULL); + } + + // Create the Upload Buffer: + { + VkBufferCreateInfo buffer_info = {}; + buffer_info.sType = VK_STRUCTURE_TYPE_BUFFER_CREATE_INFO; + buffer_info.size = upload_size; + buffer_info.usage = VK_BUFFER_USAGE_TRANSFER_SRC_BIT; + buffer_info.sharingMode = VK_SHARING_MODE_EXCLUSIVE; + err = vkCreateBuffer(v->Device, &buffer_info, v->Allocator, &bd->UploadBuffer); + check_vk_result(err); + VkMemoryRequirements req; + vkGetBufferMemoryRequirements(v->Device, bd->UploadBuffer, &req); + bd->BufferMemoryAlignment = (bd->BufferMemoryAlignment > req.alignment) ? bd->BufferMemoryAlignment : req.alignment; + VkMemoryAllocateInfo alloc_info = {}; + alloc_info.sType = VK_STRUCTURE_TYPE_MEMORY_ALLOCATE_INFO; + alloc_info.allocationSize = req.size; + alloc_info.memoryTypeIndex = ImGui_ImplVulkan_MemoryType(VK_MEMORY_PROPERTY_HOST_VISIBLE_BIT, req.memoryTypeBits); + err = vkAllocateMemory(v->Device, &alloc_info, v->Allocator, &bd->UploadBufferMemory); + check_vk_result(err); + err = vkBindBufferMemory(v->Device, bd->UploadBuffer, bd->UploadBufferMemory, 0); + check_vk_result(err); + } + + // Upload to Buffer: + { + char* map = NULL; + err = vkMapMemory(v->Device, bd->UploadBufferMemory, 0, upload_size, 0, (void**)(&map)); + check_vk_result(err); + memcpy(map, pixels, upload_size); + VkMappedMemoryRange range[1] = {}; + range[0].sType = VK_STRUCTURE_TYPE_MAPPED_MEMORY_RANGE; + range[0].memory = bd->UploadBufferMemory; + range[0].size = upload_size; + err = vkFlushMappedMemoryRanges(v->Device, 1, range); + check_vk_result(err); + vkUnmapMemory(v->Device, bd->UploadBufferMemory); + } + + // Copy to Image: + { + VkImageMemoryBarrier copy_barrier[1] = {}; + copy_barrier[0].sType = VK_STRUCTURE_TYPE_IMAGE_MEMORY_BARRIER; + copy_barrier[0].dstAccessMask = VK_ACCESS_TRANSFER_WRITE_BIT; + copy_barrier[0].oldLayout = VK_IMAGE_LAYOUT_UNDEFINED; + copy_barrier[0].newLayout = VK_IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL; + copy_barrier[0].srcQueueFamilyIndex = VK_QUEUE_FAMILY_IGNORED; + copy_barrier[0].dstQueueFamilyIndex = VK_QUEUE_FAMILY_IGNORED; + copy_barrier[0].image = bd->FontImage; + copy_barrier[0].subresourceRange.aspectMask = VK_IMAGE_ASPECT_COLOR_BIT; + copy_barrier[0].subresourceRange.levelCount = 1; + copy_barrier[0].subresourceRange.layerCount = 1; + vkCmdPipelineBarrier(command_buffer, VK_PIPELINE_STAGE_HOST_BIT, VK_PIPELINE_STAGE_TRANSFER_BIT, 0, 0, NULL, 0, NULL, 1, copy_barrier); + + VkBufferImageCopy region = {}; + region.imageSubresource.aspectMask = VK_IMAGE_ASPECT_COLOR_BIT; + region.imageSubresource.layerCount = 1; + region.imageExtent.width = width; + region.imageExtent.height = height; + region.imageExtent.depth = 1; + vkCmdCopyBufferToImage(command_buffer, bd->UploadBuffer, bd->FontImage, VK_IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL, 1, ®ion); + + VkImageMemoryBarrier use_barrier[1] = {}; + use_barrier[0].sType = VK_STRUCTURE_TYPE_IMAGE_MEMORY_BARRIER; + use_barrier[0].srcAccessMask = VK_ACCESS_TRANSFER_WRITE_BIT; + use_barrier[0].dstAccessMask = VK_ACCESS_SHADER_READ_BIT; + use_barrier[0].oldLayout = VK_IMAGE_LAYOUT_TRANSFER_DST_OPTIMAL; + use_barrier[0].newLayout = VK_IMAGE_LAYOUT_SHADER_READ_ONLY_OPTIMAL; + use_barrier[0].srcQueueFamilyIndex = VK_QUEUE_FAMILY_IGNORED; + use_barrier[0].dstQueueFamilyIndex = VK_QUEUE_FAMILY_IGNORED; + use_barrier[0].image = bd->FontImage; + use_barrier[0].subresourceRange.aspectMask = VK_IMAGE_ASPECT_COLOR_BIT; + use_barrier[0].subresourceRange.levelCount = 1; + use_barrier[0].subresourceRange.layerCount = 1; + vkCmdPipelineBarrier(command_buffer, VK_PIPELINE_STAGE_TRANSFER_BIT, VK_PIPELINE_STAGE_FRAGMENT_SHADER_BIT, 0, 0, NULL, 0, NULL, 1, use_barrier); + } + + // Store our identifier + io.Fonts->SetTexID((ImTextureID)(intptr_t)bd->FontImage); + + return true; +} + +static void ImGui_ImplVulkan_CreateShaderModules(VkDevice device, const VkAllocationCallbacks* allocator) +{ + // Create the shader modules + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + if (bd->ShaderModuleVert == VK_NULL_HANDLE) + { + VkShaderModuleCreateInfo vert_info = {}; + vert_info.sType = VK_STRUCTURE_TYPE_SHADER_MODULE_CREATE_INFO; + vert_info.codeSize = sizeof(__glsl_shader_vert_spv); + vert_info.pCode = (uint32_t*)__glsl_shader_vert_spv; + VkResult err = vkCreateShaderModule(device, &vert_info, allocator, &bd->ShaderModuleVert); + check_vk_result(err); + } + if (bd->ShaderModuleFrag == VK_NULL_HANDLE) + { + VkShaderModuleCreateInfo frag_info = {}; + frag_info.sType = VK_STRUCTURE_TYPE_SHADER_MODULE_CREATE_INFO; + frag_info.codeSize = sizeof(__glsl_shader_frag_spv); + frag_info.pCode = (uint32_t*)__glsl_shader_frag_spv; + VkResult err = vkCreateShaderModule(device, &frag_info, allocator, &bd->ShaderModuleFrag); + check_vk_result(err); + } +} + +static void ImGui_ImplVulkan_CreateFontSampler(VkDevice device, const VkAllocationCallbacks* allocator) +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + if (bd->FontSampler) + return; + + VkSamplerCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_SAMPLER_CREATE_INFO; + info.magFilter = VK_FILTER_LINEAR; + info.minFilter = VK_FILTER_LINEAR; + info.mipmapMode = VK_SAMPLER_MIPMAP_MODE_LINEAR; + info.addressModeU = VK_SAMPLER_ADDRESS_MODE_REPEAT; + info.addressModeV = VK_SAMPLER_ADDRESS_MODE_REPEAT; + info.addressModeW = VK_SAMPLER_ADDRESS_MODE_REPEAT; + info.minLod = -1000; + info.maxLod = 1000; + info.maxAnisotropy = 1.0f; + VkResult err = vkCreateSampler(device, &info, allocator, &bd->FontSampler); + check_vk_result(err); +} + +static void ImGui_ImplVulkan_CreateDescriptorSetLayout(VkDevice device, const VkAllocationCallbacks* allocator) +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + if (bd->DescriptorSetLayout) + return; + + ImGui_ImplVulkan_CreateFontSampler(device, allocator); + VkSampler sampler[1] = { bd->FontSampler }; + VkDescriptorSetLayoutBinding binding[1] = {}; + binding[0].descriptorType = VK_DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER; + binding[0].descriptorCount = 1; + binding[0].stageFlags = VK_SHADER_STAGE_FRAGMENT_BIT; + binding[0].pImmutableSamplers = sampler; + VkDescriptorSetLayoutCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_DESCRIPTOR_SET_LAYOUT_CREATE_INFO; + info.bindingCount = 1; + info.pBindings = binding; + VkResult err = vkCreateDescriptorSetLayout(device, &info, allocator, &bd->DescriptorSetLayout); + check_vk_result(err); +} + +static void ImGui_ImplVulkan_CreatePipelineLayout(VkDevice device, const VkAllocationCallbacks* allocator) +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + if (bd->PipelineLayout) + return; + + // Constants: we are using 'vec2 offset' and 'vec2 scale' instead of a full 3d projection matrix + ImGui_ImplVulkan_CreateDescriptorSetLayout(device, allocator); + VkPushConstantRange push_constants[1] = {}; + push_constants[0].stageFlags = VK_SHADER_STAGE_VERTEX_BIT; + push_constants[0].offset = sizeof(float) * 0; + push_constants[0].size = sizeof(float) * 4; + VkDescriptorSetLayout set_layout[1] = { bd->DescriptorSetLayout }; + VkPipelineLayoutCreateInfo layout_info = {}; + layout_info.sType = VK_STRUCTURE_TYPE_PIPELINE_LAYOUT_CREATE_INFO; + layout_info.setLayoutCount = 1; + layout_info.pSetLayouts = set_layout; + layout_info.pushConstantRangeCount = 1; + layout_info.pPushConstantRanges = push_constants; + VkResult err = vkCreatePipelineLayout(device, &layout_info, allocator, &bd->PipelineLayout); + check_vk_result(err); +} + +static void ImGui_ImplVulkan_CreatePipeline(VkDevice device, const VkAllocationCallbacks* allocator, VkPipelineCache pipelineCache, VkRenderPass renderPass, VkSampleCountFlagBits MSAASamples, VkPipeline* pipeline, uint32_t subpass) +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + ImGui_ImplVulkan_CreateShaderModules(device, allocator); + + VkPipelineShaderStageCreateInfo stage[2] = {}; + stage[0].sType = VK_STRUCTURE_TYPE_PIPELINE_SHADER_STAGE_CREATE_INFO; + stage[0].stage = VK_SHADER_STAGE_VERTEX_BIT; + stage[0].module = bd->ShaderModuleVert; + stage[0].pName = "main"; + stage[1].sType = VK_STRUCTURE_TYPE_PIPELINE_SHADER_STAGE_CREATE_INFO; + stage[1].stage = VK_SHADER_STAGE_FRAGMENT_BIT; + stage[1].module = bd->ShaderModuleFrag; + stage[1].pName = "main"; + + VkVertexInputBindingDescription binding_desc[1] = {}; + binding_desc[0].stride = sizeof(ImDrawVert); + binding_desc[0].inputRate = VK_VERTEX_INPUT_RATE_VERTEX; + + VkVertexInputAttributeDescription attribute_desc[3] = {}; + attribute_desc[0].location = 0; + attribute_desc[0].binding = binding_desc[0].binding; + attribute_desc[0].format = VK_FORMAT_R32G32_SFLOAT; + attribute_desc[0].offset = IM_OFFSETOF(ImDrawVert, pos); + attribute_desc[1].location = 1; + attribute_desc[1].binding = binding_desc[0].binding; + attribute_desc[1].format = VK_FORMAT_R32G32_SFLOAT; + attribute_desc[1].offset = IM_OFFSETOF(ImDrawVert, uv); + attribute_desc[2].location = 2; + attribute_desc[2].binding = binding_desc[0].binding; + attribute_desc[2].format = VK_FORMAT_R8G8B8A8_UNORM; + attribute_desc[2].offset = IM_OFFSETOF(ImDrawVert, col); + + VkPipelineVertexInputStateCreateInfo vertex_info = {}; + vertex_info.sType = VK_STRUCTURE_TYPE_PIPELINE_VERTEX_INPUT_STATE_CREATE_INFO; + vertex_info.vertexBindingDescriptionCount = 1; + vertex_info.pVertexBindingDescriptions = binding_desc; + vertex_info.vertexAttributeDescriptionCount = 3; + vertex_info.pVertexAttributeDescriptions = attribute_desc; + + VkPipelineInputAssemblyStateCreateInfo ia_info = {}; + ia_info.sType = VK_STRUCTURE_TYPE_PIPELINE_INPUT_ASSEMBLY_STATE_CREATE_INFO; + ia_info.topology = VK_PRIMITIVE_TOPOLOGY_TRIANGLE_LIST; + + VkPipelineViewportStateCreateInfo viewport_info = {}; + viewport_info.sType = VK_STRUCTURE_TYPE_PIPELINE_VIEWPORT_STATE_CREATE_INFO; + viewport_info.viewportCount = 1; + viewport_info.scissorCount = 1; + + VkPipelineRasterizationStateCreateInfo raster_info = {}; + raster_info.sType = VK_STRUCTURE_TYPE_PIPELINE_RASTERIZATION_STATE_CREATE_INFO; + raster_info.polygonMode = VK_POLYGON_MODE_FILL; + raster_info.cullMode = VK_CULL_MODE_NONE; + raster_info.frontFace = VK_FRONT_FACE_COUNTER_CLOCKWISE; + raster_info.lineWidth = 1.0f; + + VkPipelineMultisampleStateCreateInfo ms_info = {}; + ms_info.sType = VK_STRUCTURE_TYPE_PIPELINE_MULTISAMPLE_STATE_CREATE_INFO; + ms_info.rasterizationSamples = (MSAASamples != 0) ? MSAASamples : VK_SAMPLE_COUNT_1_BIT; + + VkPipelineColorBlendAttachmentState color_attachment[1] = {}; + color_attachment[0].blendEnable = VK_TRUE; + color_attachment[0].srcColorBlendFactor = VK_BLEND_FACTOR_SRC_ALPHA; + color_attachment[0].dstColorBlendFactor = VK_BLEND_FACTOR_ONE_MINUS_SRC_ALPHA; + color_attachment[0].colorBlendOp = VK_BLEND_OP_ADD; + color_attachment[0].srcAlphaBlendFactor = VK_BLEND_FACTOR_ONE; + color_attachment[0].dstAlphaBlendFactor = VK_BLEND_FACTOR_ONE_MINUS_SRC_ALPHA; + color_attachment[0].alphaBlendOp = VK_BLEND_OP_ADD; + color_attachment[0].colorWriteMask = VK_COLOR_COMPONENT_R_BIT | VK_COLOR_COMPONENT_G_BIT | VK_COLOR_COMPONENT_B_BIT | VK_COLOR_COMPONENT_A_BIT; + + VkPipelineDepthStencilStateCreateInfo depth_info = {}; + depth_info.sType = VK_STRUCTURE_TYPE_PIPELINE_DEPTH_STENCIL_STATE_CREATE_INFO; + + VkPipelineColorBlendStateCreateInfo blend_info = {}; + blend_info.sType = VK_STRUCTURE_TYPE_PIPELINE_COLOR_BLEND_STATE_CREATE_INFO; + blend_info.attachmentCount = 1; + blend_info.pAttachments = color_attachment; + + VkDynamicState dynamic_states[2] = { VK_DYNAMIC_STATE_VIEWPORT, VK_DYNAMIC_STATE_SCISSOR }; + VkPipelineDynamicStateCreateInfo dynamic_state = {}; + dynamic_state.sType = VK_STRUCTURE_TYPE_PIPELINE_DYNAMIC_STATE_CREATE_INFO; + dynamic_state.dynamicStateCount = (uint32_t)IM_ARRAYSIZE(dynamic_states); + dynamic_state.pDynamicStates = dynamic_states; + + ImGui_ImplVulkan_CreatePipelineLayout(device, allocator); + + VkGraphicsPipelineCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_GRAPHICS_PIPELINE_CREATE_INFO; + info.flags = bd->PipelineCreateFlags; + info.stageCount = 2; + info.pStages = stage; + info.pVertexInputState = &vertex_info; + info.pInputAssemblyState = &ia_info; + info.pViewportState = &viewport_info; + info.pRasterizationState = &raster_info; + info.pMultisampleState = &ms_info; + info.pDepthStencilState = &depth_info; + info.pColorBlendState = &blend_info; + info.pDynamicState = &dynamic_state; + info.layout = bd->PipelineLayout; + info.renderPass = renderPass; + info.subpass = subpass; + VkResult err = vkCreateGraphicsPipelines(device, pipelineCache, 1, &info, allocator, pipeline); + check_vk_result(err); +} + +bool ImGui_ImplVulkan_CreateDeviceObjects() +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + ImGui_ImplVulkan_InitInfo* v = &bd->VulkanInitInfo; + VkResult err; + + if (!bd->FontSampler) + { + VkSamplerCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_SAMPLER_CREATE_INFO; + info.magFilter = VK_FILTER_LINEAR; + info.minFilter = VK_FILTER_LINEAR; + info.mipmapMode = VK_SAMPLER_MIPMAP_MODE_LINEAR; + info.addressModeU = VK_SAMPLER_ADDRESS_MODE_REPEAT; + info.addressModeV = VK_SAMPLER_ADDRESS_MODE_REPEAT; + info.addressModeW = VK_SAMPLER_ADDRESS_MODE_REPEAT; + info.minLod = -1000; + info.maxLod = 1000; + info.maxAnisotropy = 1.0f; + err = vkCreateSampler(v->Device, &info, v->Allocator, &bd->FontSampler); + check_vk_result(err); + } + + if (!bd->DescriptorSetLayout) + { + VkSampler sampler[1] = {bd->FontSampler}; + VkDescriptorSetLayoutBinding binding[1] = {}; + binding[0].descriptorType = VK_DESCRIPTOR_TYPE_COMBINED_IMAGE_SAMPLER; + binding[0].descriptorCount = 1; + binding[0].stageFlags = VK_SHADER_STAGE_FRAGMENT_BIT; + binding[0].pImmutableSamplers = sampler; + VkDescriptorSetLayoutCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_DESCRIPTOR_SET_LAYOUT_CREATE_INFO; + info.bindingCount = 1; + info.pBindings = binding; + err = vkCreateDescriptorSetLayout(v->Device, &info, v->Allocator, &bd->DescriptorSetLayout); + check_vk_result(err); + } + + // Create Descriptor Set: + { + VkDescriptorSetAllocateInfo alloc_info = {}; + alloc_info.sType = VK_STRUCTURE_TYPE_DESCRIPTOR_SET_ALLOCATE_INFO; + alloc_info.descriptorPool = v->DescriptorPool; + alloc_info.descriptorSetCount = 1; + alloc_info.pSetLayouts = &bd->DescriptorSetLayout; + err = vkAllocateDescriptorSets(v->Device, &alloc_info, &bd->DescriptorSet); + check_vk_result(err); + } + + if (!bd->PipelineLayout) + { + // Constants: we are using 'vec2 offset' and 'vec2 scale' instead of a full 3d projection matrix + VkPushConstantRange push_constants[1] = {}; + push_constants[0].stageFlags = VK_SHADER_STAGE_VERTEX_BIT; + push_constants[0].offset = sizeof(float) * 0; + push_constants[0].size = sizeof(float) * 4; + VkDescriptorSetLayout set_layout[1] = { bd->DescriptorSetLayout }; + VkPipelineLayoutCreateInfo layout_info = {}; + layout_info.sType = VK_STRUCTURE_TYPE_PIPELINE_LAYOUT_CREATE_INFO; + layout_info.setLayoutCount = 1; + layout_info.pSetLayouts = set_layout; + layout_info.pushConstantRangeCount = 1; + layout_info.pPushConstantRanges = push_constants; + err = vkCreatePipelineLayout(v->Device, &layout_info, v->Allocator, &bd->PipelineLayout); + check_vk_result(err); + } + + ImGui_ImplVulkan_CreatePipeline(v->Device, v->Allocator, v->PipelineCache, bd->RenderPass, v->MSAASamples, &bd->Pipeline, bd->Subpass); + + return true; +} + +void ImGui_ImplVulkan_DestroyFontUploadObjects() +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + ImGui_ImplVulkan_InitInfo* v = &bd->VulkanInitInfo; + if (bd->UploadBuffer) + { + vkDestroyBuffer(v->Device, bd->UploadBuffer, v->Allocator); + bd->UploadBuffer = VK_NULL_HANDLE; + } + if (bd->UploadBufferMemory) + { + vkFreeMemory(v->Device, bd->UploadBufferMemory, v->Allocator); + bd->UploadBufferMemory = VK_NULL_HANDLE; + } +} + +void ImGui_ImplVulkan_DestroyDeviceObjects() +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + ImGui_ImplVulkan_InitInfo* v = &bd->VulkanInitInfo; + ImGui_ImplVulkanH_DestroyWindowRenderBuffers(v->Device, &bd->MainWindowRenderBuffers, v->Allocator); + ImGui_ImplVulkan_DestroyFontUploadObjects(); + + if (bd->ShaderModuleVert) { vkDestroyShaderModule(v->Device, bd->ShaderModuleVert, v->Allocator); bd->ShaderModuleVert = VK_NULL_HANDLE; } + if (bd->ShaderModuleFrag) { vkDestroyShaderModule(v->Device, bd->ShaderModuleFrag, v->Allocator); bd->ShaderModuleFrag = VK_NULL_HANDLE; } + if (bd->FontView) { vkDestroyImageView(v->Device, bd->FontView, v->Allocator); bd->FontView = VK_NULL_HANDLE; } + if (bd->FontImage) { vkDestroyImage(v->Device, bd->FontImage, v->Allocator); bd->FontImage = VK_NULL_HANDLE; } + if (bd->FontMemory) { vkFreeMemory(v->Device, bd->FontMemory, v->Allocator); bd->FontMemory = VK_NULL_HANDLE; } + if (bd->FontSampler) { vkDestroySampler(v->Device, bd->FontSampler, v->Allocator); bd->FontSampler = VK_NULL_HANDLE; } + if (bd->DescriptorSetLayout) { vkDestroyDescriptorSetLayout(v->Device, bd->DescriptorSetLayout, v->Allocator); bd->DescriptorSetLayout = VK_NULL_HANDLE; } + if (bd->PipelineLayout) { vkDestroyPipelineLayout(v->Device, bd->PipelineLayout, v->Allocator); bd->PipelineLayout = VK_NULL_HANDLE; } + if (bd->Pipeline) { vkDestroyPipeline(v->Device, bd->Pipeline, v->Allocator); bd->Pipeline = VK_NULL_HANDLE; } +} + +bool ImGui_ImplVulkan_LoadFunctions(PFN_vkVoidFunction(*loader_func)(const char* function_name, void* user_data), void* user_data) +{ + // Load function pointers + // You can use the default Vulkan loader using: + // ImGui_ImplVulkan_LoadFunctions([](const char* function_name, void*) { return vkGetInstanceProcAddr(your_vk_isntance, function_name); }); + // But this would be equivalent to not setting VK_NO_PROTOTYPES. +#ifdef VK_NO_PROTOTYPES +#define IMGUI_VULKAN_FUNC_LOAD(func) \ + func = reinterpret_cast(loader_func(#func, user_data)); \ + if (func == NULL) \ + return false; + IMGUI_VULKAN_FUNC_MAP(IMGUI_VULKAN_FUNC_LOAD) +#undef IMGUI_VULKAN_FUNC_LOAD +#else + IM_UNUSED(loader_func); + IM_UNUSED(user_data); +#endif + g_FunctionsLoaded = true; + return true; +} + +bool ImGui_ImplVulkan_Init(ImGui_ImplVulkan_InitInfo* info, VkRenderPass render_pass) +{ + IM_ASSERT(g_FunctionsLoaded && "Need to call ImGui_ImplVulkan_LoadFunctions() if IMGUI_IMPL_VULKAN_NO_PROTOTYPES or VK_NO_PROTOTYPES are set!"); + + ImGuiIO& io = ImGui::GetIO(); + IM_ASSERT(io.BackendRendererUserData == NULL && "Already initialized a renderer backend!"); + + // Setup backend capabilities flags + ImGui_ImplVulkan_Data* bd = IM_NEW(ImGui_ImplVulkan_Data)(); + io.BackendRendererUserData = (void*)bd; + io.BackendRendererName = "imgui_impl_vulkan"; + io.BackendFlags |= ImGuiBackendFlags_RendererHasVtxOffset; // We can honor the ImDrawCmd::VtxOffset field, allowing for large meshes. + + IM_ASSERT(info->Instance != VK_NULL_HANDLE); + IM_ASSERT(info->PhysicalDevice != VK_NULL_HANDLE); + IM_ASSERT(info->Device != VK_NULL_HANDLE); + IM_ASSERT(info->Queue != VK_NULL_HANDLE); + IM_ASSERT(info->DescriptorPool != VK_NULL_HANDLE); + IM_ASSERT(info->MinImageCount >= 2); + IM_ASSERT(info->ImageCount >= info->MinImageCount); + IM_ASSERT(render_pass != VK_NULL_HANDLE); + + bd->VulkanInitInfo = *info; + bd->RenderPass = render_pass; + bd->Subpass = info->Subpass; + + ImGui_ImplVulkan_CreateDeviceObjects(); + + return true; +} + +void ImGui_ImplVulkan_Shutdown() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + + ImGui_ImplVulkan_DestroyDeviceObjects(); + io.BackendRendererName = NULL; + io.BackendRendererUserData = NULL; + IM_DELETE(bd); +} + +void ImGui_ImplVulkan_NewFrame() +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + IM_ASSERT(bd != NULL && "Did you call ImGui_ImplVulkan_Init()?"); + IM_UNUSED(bd); +} + +void ImGui_ImplVulkan_SetMinImageCount(uint32_t min_image_count) +{ + ImGui_ImplVulkan_Data* bd = ImGui_ImplVulkan_GetBackendData(); + IM_ASSERT(min_image_count >= 2); + if (bd->VulkanInitInfo.MinImageCount == min_image_count) + return; + + ImGui_ImplVulkan_InitInfo* v = &bd->VulkanInitInfo; + VkResult err = vkDeviceWaitIdle(v->Device); + check_vk_result(err); + ImGui_ImplVulkanH_DestroyWindowRenderBuffers(v->Device, &bd->MainWindowRenderBuffers, v->Allocator); + bd->VulkanInitInfo.MinImageCount = min_image_count; +} + + +//------------------------------------------------------------------------- +// Internal / Miscellaneous Vulkan Helpers +// (Used by example's main.cpp. Used by multi-viewport features. PROBABLY NOT used by your own app.) +//------------------------------------------------------------------------- +// You probably do NOT need to use or care about those functions. +// Those functions only exist because: +// 1) they facilitate the readability and maintenance of the multiple main.cpp examples files. +// 2) the upcoming multi-viewport feature will need them internally. +// Generally we avoid exposing any kind of superfluous high-level helpers in the backends, +// but it is too much code to duplicate everywhere so we exceptionally expose them. +// +// Your engine/app will likely _already_ have code to setup all that stuff (swap chain, render pass, frame buffers, etc.). +// You may read this code to learn about Vulkan, but it is recommended you use you own custom tailored code to do equivalent work. +// (The ImGui_ImplVulkanH_XXX functions do not interact with any of the state used by the regular ImGui_ImplVulkan_XXX functions) +//------------------------------------------------------------------------- + +VkSurfaceFormatKHR ImGui_ImplVulkanH_SelectSurfaceFormat(VkPhysicalDevice physical_device, VkSurfaceKHR surface, const VkFormat* request_formats, int request_formats_count, VkColorSpaceKHR request_color_space) +{ + IM_ASSERT(g_FunctionsLoaded && "Need to call ImGui_ImplVulkan_LoadFunctions() if IMGUI_IMPL_VULKAN_NO_PROTOTYPES or VK_NO_PROTOTYPES are set!"); + IM_ASSERT(request_formats != NULL); + IM_ASSERT(request_formats_count > 0); + + // Per Spec Format and View Format are expected to be the same unless VK_IMAGE_CREATE_MUTABLE_BIT was set at image creation + // Assuming that the default behavior is without setting this bit, there is no need for separate Swapchain image and image view format + // Additionally several new color spaces were introduced with Vulkan Spec v1.0.40, + // hence we must make sure that a format with the mostly available color space, VK_COLOR_SPACE_SRGB_NONLINEAR_KHR, is found and used. + uint32_t avail_count; + vkGetPhysicalDeviceSurfaceFormatsKHR(physical_device, surface, &avail_count, NULL); + ImVector avail_format; + avail_format.resize((int)avail_count); + vkGetPhysicalDeviceSurfaceFormatsKHR(physical_device, surface, &avail_count, avail_format.Data); + + // First check if only one format, VK_FORMAT_UNDEFINED, is available, which would imply that any format is available + if (avail_count == 1) + { + if (avail_format[0].format == VK_FORMAT_UNDEFINED) + { + VkSurfaceFormatKHR ret; + ret.format = request_formats[0]; + ret.colorSpace = request_color_space; + return ret; + } + else + { + // No point in searching another format + return avail_format[0]; + } + } + else + { + // Request several formats, the first found will be used + for (int request_i = 0; request_i < request_formats_count; request_i++) + for (uint32_t avail_i = 0; avail_i < avail_count; avail_i++) + if (avail_format[avail_i].format == request_formats[request_i] && avail_format[avail_i].colorSpace == request_color_space) + return avail_format[avail_i]; + + // If none of the requested image formats could be found, use the first available + return avail_format[0]; + } +} + +VkPresentModeKHR ImGui_ImplVulkanH_SelectPresentMode(VkPhysicalDevice physical_device, VkSurfaceKHR surface, const VkPresentModeKHR* request_modes, int request_modes_count) +{ + IM_ASSERT(g_FunctionsLoaded && "Need to call ImGui_ImplVulkan_LoadFunctions() if IMGUI_IMPL_VULKAN_NO_PROTOTYPES or VK_NO_PROTOTYPES are set!"); + IM_ASSERT(request_modes != NULL); + IM_ASSERT(request_modes_count > 0); + + // Request a certain mode and confirm that it is available. If not use VK_PRESENT_MODE_FIFO_KHR which is mandatory + uint32_t avail_count = 0; + vkGetPhysicalDeviceSurfacePresentModesKHR(physical_device, surface, &avail_count, NULL); + ImVector avail_modes; + avail_modes.resize((int)avail_count); + vkGetPhysicalDeviceSurfacePresentModesKHR(physical_device, surface, &avail_count, avail_modes.Data); + //for (uint32_t avail_i = 0; avail_i < avail_count; avail_i++) + // printf("[vulkan] avail_modes[%d] = %d\n", avail_i, avail_modes[avail_i]); + + for (int request_i = 0; request_i < request_modes_count; request_i++) + for (uint32_t avail_i = 0; avail_i < avail_count; avail_i++) + if (request_modes[request_i] == avail_modes[avail_i]) + return request_modes[request_i]; + + return VK_PRESENT_MODE_FIFO_KHR; // Always available +} + +void ImGui_ImplVulkanH_CreateWindowCommandBuffers(VkPhysicalDevice physical_device, VkDevice device, ImGui_ImplVulkanH_Window* wd, uint32_t queue_family, const VkAllocationCallbacks* allocator) +{ + IM_ASSERT(physical_device != VK_NULL_HANDLE && device != VK_NULL_HANDLE); + (void)physical_device; + (void)allocator; + + // Create Command Buffers + VkResult err; + for (uint32_t i = 0; i < wd->ImageCount; i++) + { + ImGui_ImplVulkanH_Frame* fd = &wd->Frames[i]; + ImGui_ImplVulkanH_FrameSemaphores* fsd = &wd->FrameSemaphores[i]; + { + VkCommandPoolCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_COMMAND_POOL_CREATE_INFO; + info.flags = VK_COMMAND_POOL_CREATE_RESET_COMMAND_BUFFER_BIT; + info.queueFamilyIndex = queue_family; + err = vkCreateCommandPool(device, &info, allocator, &fd->CommandPool); + check_vk_result(err); + } + { + VkCommandBufferAllocateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_COMMAND_BUFFER_ALLOCATE_INFO; + info.commandPool = fd->CommandPool; + info.level = VK_COMMAND_BUFFER_LEVEL_PRIMARY; + info.commandBufferCount = 1; + err = vkAllocateCommandBuffers(device, &info, &fd->CommandBuffer); + check_vk_result(err); + } + { + VkFenceCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_FENCE_CREATE_INFO; + info.flags = VK_FENCE_CREATE_SIGNALED_BIT; + err = vkCreateFence(device, &info, allocator, &fd->Fence); + check_vk_result(err); + } + { + VkSemaphoreCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_SEMAPHORE_CREATE_INFO; + err = vkCreateSemaphore(device, &info, allocator, &fsd->ImageAcquiredSemaphore); + check_vk_result(err); + err = vkCreateSemaphore(device, &info, allocator, &fsd->RenderCompleteSemaphore); + check_vk_result(err); + } + } +} + +int ImGui_ImplVulkanH_GetMinImageCountFromPresentMode(VkPresentModeKHR present_mode) +{ + if (present_mode == VK_PRESENT_MODE_MAILBOX_KHR) + return 3; + if (present_mode == VK_PRESENT_MODE_FIFO_KHR || present_mode == VK_PRESENT_MODE_FIFO_RELAXED_KHR) + return 2; + if (present_mode == VK_PRESENT_MODE_IMMEDIATE_KHR) + return 1; + IM_ASSERT(0); + return 1; +} + +// Also destroy old swap chain and in-flight frames data, if any. +void ImGui_ImplVulkanH_CreateWindowSwapChain(VkPhysicalDevice physical_device, VkDevice device, ImGui_ImplVulkanH_Window* wd, const VkAllocationCallbacks* allocator, int w, int h, uint32_t min_image_count) +{ + VkResult err; + VkSwapchainKHR old_swapchain = wd->Swapchain; + wd->Swapchain = VK_NULL_HANDLE; + err = vkDeviceWaitIdle(device); + check_vk_result(err); + + // We don't use ImGui_ImplVulkanH_DestroyWindow() because we want to preserve the old swapchain to create the new one. + // Destroy old Framebuffer + for (uint32_t i = 0; i < wd->ImageCount; i++) + { + ImGui_ImplVulkanH_DestroyFrame(device, &wd->Frames[i], allocator); + ImGui_ImplVulkanH_DestroyFrameSemaphores(device, &wd->FrameSemaphores[i], allocator); + } + IM_FREE(wd->Frames); + IM_FREE(wd->FrameSemaphores); + wd->Frames = NULL; + wd->FrameSemaphores = NULL; + wd->ImageCount = 0; + if (wd->RenderPass) + vkDestroyRenderPass(device, wd->RenderPass, allocator); + if (wd->Pipeline) + vkDestroyPipeline(device, wd->Pipeline, allocator); + + // If min image count was not specified, request different count of images dependent on selected present mode + if (min_image_count == 0) + min_image_count = ImGui_ImplVulkanH_GetMinImageCountFromPresentMode(wd->PresentMode); + + // Create Swapchain + { + VkSwapchainCreateInfoKHR info = {}; + info.sType = VK_STRUCTURE_TYPE_SWAPCHAIN_CREATE_INFO_KHR; + info.surface = wd->Surface; + info.minImageCount = min_image_count; + info.imageFormat = wd->SurfaceFormat.format; + info.imageColorSpace = wd->SurfaceFormat.colorSpace; + info.imageArrayLayers = 1; + info.imageUsage = VK_IMAGE_USAGE_COLOR_ATTACHMENT_BIT; + info.imageSharingMode = VK_SHARING_MODE_EXCLUSIVE; // Assume that graphics family == present family + info.preTransform = VK_SURFACE_TRANSFORM_IDENTITY_BIT_KHR; + info.compositeAlpha = VK_COMPOSITE_ALPHA_OPAQUE_BIT_KHR; + info.presentMode = wd->PresentMode; + info.clipped = VK_TRUE; + info.oldSwapchain = old_swapchain; + VkSurfaceCapabilitiesKHR cap; + err = vkGetPhysicalDeviceSurfaceCapabilitiesKHR(physical_device, wd->Surface, &cap); + check_vk_result(err); + if (info.minImageCount < cap.minImageCount) + info.minImageCount = cap.minImageCount; + else if (cap.maxImageCount != 0 && info.minImageCount > cap.maxImageCount) + info.minImageCount = cap.maxImageCount; + + if (cap.currentExtent.width == 0xffffffff) + { + info.imageExtent.width = wd->Width = w; + info.imageExtent.height = wd->Height = h; + } + else + { + info.imageExtent.width = wd->Width = cap.currentExtent.width; + info.imageExtent.height = wd->Height = cap.currentExtent.height; + } + err = vkCreateSwapchainKHR(device, &info, allocator, &wd->Swapchain); + check_vk_result(err); + err = vkGetSwapchainImagesKHR(device, wd->Swapchain, &wd->ImageCount, NULL); + check_vk_result(err); + VkImage backbuffers[16] = {}; + IM_ASSERT(wd->ImageCount >= min_image_count); + IM_ASSERT(wd->ImageCount < IM_ARRAYSIZE(backbuffers)); + err = vkGetSwapchainImagesKHR(device, wd->Swapchain, &wd->ImageCount, backbuffers); + check_vk_result(err); + + IM_ASSERT(wd->Frames == NULL); + wd->Frames = (ImGui_ImplVulkanH_Frame*)IM_ALLOC(sizeof(ImGui_ImplVulkanH_Frame) * wd->ImageCount); + wd->FrameSemaphores = (ImGui_ImplVulkanH_FrameSemaphores*)IM_ALLOC(sizeof(ImGui_ImplVulkanH_FrameSemaphores) * wd->ImageCount); + memset(wd->Frames, 0, sizeof(wd->Frames[0]) * wd->ImageCount); + memset(wd->FrameSemaphores, 0, sizeof(wd->FrameSemaphores[0]) * wd->ImageCount); + for (uint32_t i = 0; i < wd->ImageCount; i++) + wd->Frames[i].Backbuffer = backbuffers[i]; + } + if (old_swapchain) + vkDestroySwapchainKHR(device, old_swapchain, allocator); + + // Create the Render Pass + { + VkAttachmentDescription attachment = {}; + attachment.format = wd->SurfaceFormat.format; + attachment.samples = VK_SAMPLE_COUNT_1_BIT; + attachment.loadOp = wd->ClearEnable ? VK_ATTACHMENT_LOAD_OP_CLEAR : VK_ATTACHMENT_LOAD_OP_DONT_CARE; + attachment.storeOp = VK_ATTACHMENT_STORE_OP_STORE; + attachment.stencilLoadOp = VK_ATTACHMENT_LOAD_OP_DONT_CARE; + attachment.stencilStoreOp = VK_ATTACHMENT_STORE_OP_DONT_CARE; + attachment.initialLayout = VK_IMAGE_LAYOUT_UNDEFINED; + attachment.finalLayout = VK_IMAGE_LAYOUT_PRESENT_SRC_KHR; + VkAttachmentReference color_attachment = {}; + color_attachment.attachment = 0; + color_attachment.layout = VK_IMAGE_LAYOUT_COLOR_ATTACHMENT_OPTIMAL; + VkSubpassDescription subpass = {}; + subpass.pipelineBindPoint = VK_PIPELINE_BIND_POINT_GRAPHICS; + subpass.colorAttachmentCount = 1; + subpass.pColorAttachments = &color_attachment; + VkSubpassDependency dependency = {}; + dependency.srcSubpass = VK_SUBPASS_EXTERNAL; + dependency.dstSubpass = 0; + dependency.srcStageMask = VK_PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT; + dependency.dstStageMask = VK_PIPELINE_STAGE_COLOR_ATTACHMENT_OUTPUT_BIT; + dependency.srcAccessMask = 0; + dependency.dstAccessMask = VK_ACCESS_COLOR_ATTACHMENT_WRITE_BIT; + VkRenderPassCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_RENDER_PASS_CREATE_INFO; + info.attachmentCount = 1; + info.pAttachments = &attachment; + info.subpassCount = 1; + info.pSubpasses = &subpass; + info.dependencyCount = 1; + info.pDependencies = &dependency; + err = vkCreateRenderPass(device, &info, allocator, &wd->RenderPass); + check_vk_result(err); + + // We do not create a pipeline by default as this is also used by examples' main.cpp, + // but secondary viewport in multi-viewport mode may want to create one with: + //ImGui_ImplVulkan_CreatePipeline(device, allocator, VK_NULL_HANDLE, wd->RenderPass, VK_SAMPLE_COUNT_1_BIT, &wd->Pipeline, bd->Subpass); + } + + // Create The Image Views + { + VkImageViewCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_IMAGE_VIEW_CREATE_INFO; + info.viewType = VK_IMAGE_VIEW_TYPE_2D; + info.format = wd->SurfaceFormat.format; + info.components.r = VK_COMPONENT_SWIZZLE_R; + info.components.g = VK_COMPONENT_SWIZZLE_G; + info.components.b = VK_COMPONENT_SWIZZLE_B; + info.components.a = VK_COMPONENT_SWIZZLE_A; + VkImageSubresourceRange image_range = { VK_IMAGE_ASPECT_COLOR_BIT, 0, 1, 0, 1 }; + info.subresourceRange = image_range; + for (uint32_t i = 0; i < wd->ImageCount; i++) + { + ImGui_ImplVulkanH_Frame* fd = &wd->Frames[i]; + info.image = fd->Backbuffer; + err = vkCreateImageView(device, &info, allocator, &fd->BackbufferView); + check_vk_result(err); + } + } + + // Create Framebuffer + { + VkImageView attachment[1]; + VkFramebufferCreateInfo info = {}; + info.sType = VK_STRUCTURE_TYPE_FRAMEBUFFER_CREATE_INFO; + info.renderPass = wd->RenderPass; + info.attachmentCount = 1; + info.pAttachments = attachment; + info.width = wd->Width; + info.height = wd->Height; + info.layers = 1; + for (uint32_t i = 0; i < wd->ImageCount; i++) + { + ImGui_ImplVulkanH_Frame* fd = &wd->Frames[i]; + attachment[0] = fd->BackbufferView; + err = vkCreateFramebuffer(device, &info, allocator, &fd->Framebuffer); + check_vk_result(err); + } + } +} + +// Create or resize window +void ImGui_ImplVulkanH_CreateOrResizeWindow(VkInstance instance, VkPhysicalDevice physical_device, VkDevice device, ImGui_ImplVulkanH_Window* wd, uint32_t queue_family, const VkAllocationCallbacks* allocator, int width, int height, uint32_t min_image_count) +{ + IM_ASSERT(g_FunctionsLoaded && "Need to call ImGui_ImplVulkan_LoadFunctions() if IMGUI_IMPL_VULKAN_NO_PROTOTYPES or VK_NO_PROTOTYPES are set!"); + (void)instance; + ImGui_ImplVulkanH_CreateWindowSwapChain(physical_device, device, wd, allocator, width, height, min_image_count); + ImGui_ImplVulkanH_CreateWindowCommandBuffers(physical_device, device, wd, queue_family, allocator); +} + +void ImGui_ImplVulkanH_DestroyWindow(VkInstance instance, VkDevice device, ImGui_ImplVulkanH_Window* wd, const VkAllocationCallbacks* allocator) +{ + vkDeviceWaitIdle(device); // FIXME: We could wait on the Queue if we had the queue in wd-> (otherwise VulkanH functions can't use globals) + //vkQueueWaitIdle(bd->Queue); + + for (uint32_t i = 0; i < wd->ImageCount; i++) + { + ImGui_ImplVulkanH_DestroyFrame(device, &wd->Frames[i], allocator); + ImGui_ImplVulkanH_DestroyFrameSemaphores(device, &wd->FrameSemaphores[i], allocator); + } + IM_FREE(wd->Frames); + IM_FREE(wd->FrameSemaphores); + wd->Frames = NULL; + wd->FrameSemaphores = NULL; + vkDestroyPipeline(device, wd->Pipeline, allocator); + vkDestroyRenderPass(device, wd->RenderPass, allocator); + vkDestroySwapchainKHR(device, wd->Swapchain, allocator); + vkDestroySurfaceKHR(instance, wd->Surface, allocator); + + *wd = ImGui_ImplVulkanH_Window(); +} + +void ImGui_ImplVulkanH_DestroyFrame(VkDevice device, ImGui_ImplVulkanH_Frame* fd, const VkAllocationCallbacks* allocator) +{ + vkDestroyFence(device, fd->Fence, allocator); + vkFreeCommandBuffers(device, fd->CommandPool, 1, &fd->CommandBuffer); + vkDestroyCommandPool(device, fd->CommandPool, allocator); + fd->Fence = VK_NULL_HANDLE; + fd->CommandBuffer = VK_NULL_HANDLE; + fd->CommandPool = VK_NULL_HANDLE; + + vkDestroyImageView(device, fd->BackbufferView, allocator); + vkDestroyFramebuffer(device, fd->Framebuffer, allocator); +} + +void ImGui_ImplVulkanH_DestroyFrameSemaphores(VkDevice device, ImGui_ImplVulkanH_FrameSemaphores* fsd, const VkAllocationCallbacks* allocator) +{ + vkDestroySemaphore(device, fsd->ImageAcquiredSemaphore, allocator); + vkDestroySemaphore(device, fsd->RenderCompleteSemaphore, allocator); + fsd->ImageAcquiredSemaphore = fsd->RenderCompleteSemaphore = VK_NULL_HANDLE; +} + +void ImGui_ImplVulkanH_DestroyFrameRenderBuffers(VkDevice device, ImGui_ImplVulkanH_FrameRenderBuffers* buffers, const VkAllocationCallbacks* allocator) +{ + if (buffers->VertexBuffer) { vkDestroyBuffer(device, buffers->VertexBuffer, allocator); buffers->VertexBuffer = VK_NULL_HANDLE; } + if (buffers->VertexBufferMemory) { vkFreeMemory(device, buffers->VertexBufferMemory, allocator); buffers->VertexBufferMemory = VK_NULL_HANDLE; } + if (buffers->IndexBuffer) { vkDestroyBuffer(device, buffers->IndexBuffer, allocator); buffers->IndexBuffer = VK_NULL_HANDLE; } + if (buffers->IndexBufferMemory) { vkFreeMemory(device, buffers->IndexBufferMemory, allocator); buffers->IndexBufferMemory = VK_NULL_HANDLE; } + buffers->VertexBufferSize = 0; + buffers->IndexBufferSize = 0; +} + +void ImGui_ImplVulkanH_DestroyWindowRenderBuffers(VkDevice device, ImGui_ImplVulkanH_WindowRenderBuffers* buffers, const VkAllocationCallbacks* allocator) +{ + for (uint32_t n = 0; n < buffers->Count; n++) + ImGui_ImplVulkanH_DestroyFrameRenderBuffers(device, &buffers->FrameRenderBuffers[n], allocator); + IM_FREE(buffers->FrameRenderBuffers); + buffers->FrameRenderBuffers = NULL; + buffers->Index = 0; + buffers->Count = 0; +} diff --git a/source/editor/imgui/backends/imgui_impl_vulkan.h b/source/editor/imgui/backends/imgui_impl_vulkan.h new file mode 100644 index 0000000..c770d0c --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_vulkan.h @@ -0,0 +1,149 @@ +// dear imgui: Renderer Backend for Vulkan +// This needs to be used along with a Platform Backend (e.g. GLFW, SDL, Win32, custom..) + +// Implemented features: +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. +// Missing features: +// [ ] Renderer: User texture binding. Changes of ImTextureID aren't supported by this backend! See https://github.com/ocornut/imgui/pull/914 + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// The aim of imgui_impl_vulkan.h/.cpp is to be usable in your engine without any modification. +// IF YOU FEEL YOU NEED TO MAKE ANY CHANGE TO THIS CODE, please share them and your feedback at https://github.com/ocornut/imgui/ + +// Important note to the reader who wish to integrate imgui_impl_vulkan.cpp/.h in their own engine/app. +// - Common ImGui_ImplVulkan_XXX functions and structures are used to interface with imgui_impl_vulkan.cpp/.h. +// You will use those if you want to use this rendering backend in your engine/app. +// - Helper ImGui_ImplVulkanH_XXX functions and structures are only used by this example (main.cpp) and by +// the backend itself (imgui_impl_vulkan.cpp), but should PROBABLY NOT be used by your own engine/app code. +// Read comments in imgui_impl_vulkan.h. + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +// [Configuration] in order to use a custom Vulkan function loader: +// (1) You'll need to disable default Vulkan function prototypes. +// We provide a '#define IMGUI_IMPL_VULKAN_NO_PROTOTYPES' convenience configuration flag. +// In order to make sure this is visible from the imgui_impl_vulkan.cpp compilation unit: +// - Add '#define IMGUI_IMPL_VULKAN_NO_PROTOTYPES' in your imconfig.h file +// - Or as a compilation flag in your build system +// - Or uncomment here (not recommended because you'd be modifying imgui sources!) +// - Do not simply add it in a .cpp file! +// (2) Call ImGui_ImplVulkan_LoadFunctions() before ImGui_ImplVulkan_Init() with your custom function. +// If you have no idea what this is, leave it alone! +//#define IMGUI_IMPL_VULKAN_NO_PROTOTYPES + +// Vulkan includes +#if defined(IMGUI_IMPL_VULKAN_NO_PROTOTYPES) && !defined(VK_NO_PROTOTYPES) +#define VK_NO_PROTOTYPES +#endif +#include + +// Initialization data, for ImGui_ImplVulkan_Init() +// [Please zero-clear before use!] +struct ImGui_ImplVulkan_InitInfo +{ + VkInstance Instance; + VkPhysicalDevice PhysicalDevice; + VkDevice Device; + uint32_t QueueFamily; + VkQueue Queue; + VkPipelineCache PipelineCache; + VkDescriptorPool DescriptorPool; + uint32_t Subpass; + uint32_t MinImageCount; // >= 2 + uint32_t ImageCount; // >= MinImageCount + VkSampleCountFlagBits MSAASamples; // >= VK_SAMPLE_COUNT_1_BIT + const VkAllocationCallbacks* Allocator; + void (*CheckVkResultFn)(VkResult err); +}; + +// Called by user code +IMGUI_IMPL_API bool ImGui_ImplVulkan_Init(ImGui_ImplVulkan_InitInfo* info, VkRenderPass render_pass); +IMGUI_IMPL_API void ImGui_ImplVulkan_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplVulkan_NewFrame(); +IMGUI_IMPL_API void ImGui_ImplVulkan_RenderDrawData(ImDrawData* draw_data, VkCommandBuffer command_buffer, VkPipeline pipeline = VK_NULL_HANDLE); +IMGUI_IMPL_API bool ImGui_ImplVulkan_CreateFontsTexture(VkCommandBuffer command_buffer); +IMGUI_IMPL_API void ImGui_ImplVulkan_DestroyFontUploadObjects(); +IMGUI_IMPL_API void ImGui_ImplVulkan_SetMinImageCount(uint32_t min_image_count); // To override MinImageCount after initialization (e.g. if swap chain is recreated) + +// Optional: load Vulkan functions with a custom function loader +// This is only useful with IMGUI_IMPL_VULKAN_NO_PROTOTYPES / VK_NO_PROTOTYPES +IMGUI_IMPL_API bool ImGui_ImplVulkan_LoadFunctions(PFN_vkVoidFunction(*loader_func)(const char* function_name, void* user_data), void* user_data = NULL); + +//------------------------------------------------------------------------- +// Internal / Miscellaneous Vulkan Helpers +// (Used by example's main.cpp. Used by multi-viewport features. PROBABLY NOT used by your own engine/app.) +//------------------------------------------------------------------------- +// You probably do NOT need to use or care about those functions. +// Those functions only exist because: +// 1) they facilitate the readability and maintenance of the multiple main.cpp examples files. +// 2) the upcoming multi-viewport feature will need them internally. +// Generally we avoid exposing any kind of superfluous high-level helpers in the backends, +// but it is too much code to duplicate everywhere so we exceptionally expose them. +// +// Your engine/app will likely _already_ have code to setup all that stuff (swap chain, render pass, frame buffers, etc.). +// You may read this code to learn about Vulkan, but it is recommended you use you own custom tailored code to do equivalent work. +// (The ImGui_ImplVulkanH_XXX functions do not interact with any of the state used by the regular ImGui_ImplVulkan_XXX functions) +//------------------------------------------------------------------------- + +struct ImGui_ImplVulkanH_Frame; +struct ImGui_ImplVulkanH_Window; + +// Helpers +IMGUI_IMPL_API void ImGui_ImplVulkanH_CreateOrResizeWindow(VkInstance instance, VkPhysicalDevice physical_device, VkDevice device, ImGui_ImplVulkanH_Window* wnd, uint32_t queue_family, const VkAllocationCallbacks* allocator, int w, int h, uint32_t min_image_count); +IMGUI_IMPL_API void ImGui_ImplVulkanH_DestroyWindow(VkInstance instance, VkDevice device, ImGui_ImplVulkanH_Window* wnd, const VkAllocationCallbacks* allocator); +IMGUI_IMPL_API VkSurfaceFormatKHR ImGui_ImplVulkanH_SelectSurfaceFormat(VkPhysicalDevice physical_device, VkSurfaceKHR surface, const VkFormat* request_formats, int request_formats_count, VkColorSpaceKHR request_color_space); +IMGUI_IMPL_API VkPresentModeKHR ImGui_ImplVulkanH_SelectPresentMode(VkPhysicalDevice physical_device, VkSurfaceKHR surface, const VkPresentModeKHR* request_modes, int request_modes_count); +IMGUI_IMPL_API int ImGui_ImplVulkanH_GetMinImageCountFromPresentMode(VkPresentModeKHR present_mode); + +// Helper structure to hold the data needed by one rendering frame +// (Used by example's main.cpp. Used by multi-viewport features. Probably NOT used by your own engine/app.) +// [Please zero-clear before use!] +struct ImGui_ImplVulkanH_Frame +{ + VkCommandPool CommandPool; + VkCommandBuffer CommandBuffer; + VkFence Fence; + VkImage Backbuffer; + VkImageView BackbufferView; + VkFramebuffer Framebuffer; +}; + +struct ImGui_ImplVulkanH_FrameSemaphores +{ + VkSemaphore ImageAcquiredSemaphore; + VkSemaphore RenderCompleteSemaphore; +}; + +// Helper structure to hold the data needed by one rendering context into one OS window +// (Used by example's main.cpp. Used by multi-viewport features. Probably NOT used by your own engine/app.) +struct ImGui_ImplVulkanH_Window +{ + int Width; + int Height; + VkSwapchainKHR Swapchain; + VkSurfaceKHR Surface; + VkSurfaceFormatKHR SurfaceFormat; + VkPresentModeKHR PresentMode; + VkRenderPass RenderPass; + VkPipeline Pipeline; // The window pipeline may uses a different VkRenderPass than the one passed in ImGui_ImplVulkan_InitInfo + bool ClearEnable; + VkClearValue ClearValue; + uint32_t FrameIndex; // Current frame being rendered to (0 <= FrameIndex < FrameInFlightCount) + uint32_t ImageCount; // Number of simultaneous in-flight frames (returned by vkGetSwapchainImagesKHR, usually derived from min_image_count) + uint32_t SemaphoreIndex; // Current set of swapchain wait semaphores we're using (needs to be distinct from per frame data) + ImGui_ImplVulkanH_Frame* Frames; + ImGui_ImplVulkanH_FrameSemaphores* FrameSemaphores; + + ImGui_ImplVulkanH_Window() + { + memset(this, 0, sizeof(*this)); + PresentMode = VK_PRESENT_MODE_MAX_ENUM_KHR; + ClearEnable = true; + } +}; + diff --git a/source/editor/imgui/backends/imgui_impl_wgpu.cpp b/source/editor/imgui/backends/imgui_impl_wgpu.cpp new file mode 100644 index 0000000..d3bf28b --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_wgpu.cpp @@ -0,0 +1,717 @@ +// dear imgui: Renderer for WebGPU +// This needs to be used along with a Platform Binding (e.g. GLFW) +// (Please note that WebGPU is currently experimental, will not run on non-beta browsers, and may break.) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'WGPUTextureView' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-08-24: Fix for latest specs. +// 2021-05-24: Add support for draw_data->FramebufferScale. +// 2021-05-19: Replaced direct access to ImDrawCmd::TextureId with a call to ImDrawCmd::GetTexID(). (will become a requirement) +// 2021-05-16: Update to latest WebGPU specs (compatible with Emscripten 2.0.20 and Chrome Canary 92). +// 2021-02-18: Change blending equation to preserve alpha in output buffer. +// 2021-01-28: Initial version. + +#include "imgui.h" +#include "imgui_impl_wgpu.h" +#include +#include + +#define HAS_EMSCRIPTEN_VERSION(major, minor, tiny) (__EMSCRIPTEN_major__ > (major) || (__EMSCRIPTEN_major__ == (major) && __EMSCRIPTEN_minor__ > (minor)) || (__EMSCRIPTEN_major__ == (major) && __EMSCRIPTEN_minor__ == (minor) && __EMSCRIPTEN_tiny__ >= (tiny))) + +#if defined(__EMSCRIPTEN__) && !HAS_EMSCRIPTEN_VERSION(2, 0, 20) +#error "Requires at least emscripten 2.0.20" +#endif + +// Dear ImGui prototypes from imgui_internal.h +extern ImGuiID ImHashData(const void* data_p, size_t data_size, ImU32 seed = 0); + +// WebGPU data +static WGPUDevice g_wgpuDevice = NULL; +static WGPUQueue g_defaultQueue = NULL; +static WGPUTextureFormat g_renderTargetFormat = WGPUTextureFormat_Undefined; +static WGPURenderPipeline g_pipelineState = NULL; + +struct RenderResources +{ + WGPUTexture FontTexture; // Font texture + WGPUTextureView FontTextureView; // Texture view for font texture + WGPUSampler Sampler; // Sampler for the font texture + WGPUBuffer Uniforms; // Shader uniforms + WGPUBindGroup CommonBindGroup; // Resources bind-group to bind the common resources to pipeline + ImGuiStorage ImageBindGroups; // Resources bind-group to bind the font/image resources to pipeline (this is a key->value map) + WGPUBindGroup ImageBindGroup; // Default font-resource of Dear ImGui + WGPUBindGroupLayout ImageBindGroupLayout; // Cache layout used for the image bind group. Avoids allocating unnecessary JS objects when working with WebASM +}; +static RenderResources g_resources; + +struct FrameResources +{ + WGPUBuffer IndexBuffer; + WGPUBuffer VertexBuffer; + ImDrawIdx* IndexBufferHost; + ImDrawVert* VertexBufferHost; + int IndexBufferSize; + int VertexBufferSize; +}; +static FrameResources* g_pFrameResources = NULL; +static unsigned int g_numFramesInFlight = 0; +static unsigned int g_frameIndex = UINT_MAX; + +struct Uniforms +{ + float MVP[4][4]; +}; + +//----------------------------------------------------------------------------- +// SHADERS +//----------------------------------------------------------------------------- + +// glsl_shader.vert, compiled with: +// # glslangValidator -V -x -o glsl_shader.vert.u32 glsl_shader.vert +/* +#version 450 core +layout(location = 0) in vec2 aPos; +layout(location = 1) in vec2 aUV; +layout(location = 2) in vec4 aColor; +layout(set=0, binding = 0) uniform transform { mat4 mvp; }; + +out gl_PerVertex { vec4 gl_Position; }; +layout(location = 0) out struct { vec4 Color; vec2 UV; } Out; + +void main() +{ + Out.Color = aColor; + Out.UV = aUV; + gl_Position = mvp * vec4(aPos, 0, 1); +} +*/ +static uint32_t __glsl_shader_vert_spv[] = +{ + 0x07230203,0x00010000,0x00080007,0x0000002c,0x00000000,0x00020011,0x00000001,0x0006000b, + 0x00000001,0x4c534c47,0x6474732e,0x3035342e,0x00000000,0x0003000e,0x00000000,0x00000001, + 0x000a000f,0x00000000,0x00000004,0x6e69616d,0x00000000,0x0000000b,0x0000000f,0x00000015, + 0x0000001b,0x00000023,0x00030003,0x00000002,0x000001c2,0x00040005,0x00000004,0x6e69616d, + 0x00000000,0x00030005,0x00000009,0x00000000,0x00050006,0x00000009,0x00000000,0x6f6c6f43, + 0x00000072,0x00040006,0x00000009,0x00000001,0x00005655,0x00030005,0x0000000b,0x0074754f, + 0x00040005,0x0000000f,0x6c6f4361,0x0000726f,0x00030005,0x00000015,0x00565561,0x00060005, + 0x00000019,0x505f6c67,0x65567265,0x78657472,0x00000000,0x00060006,0x00000019,0x00000000, + 0x505f6c67,0x7469736f,0x006e6f69,0x00030005,0x0000001b,0x00000000,0x00050005,0x0000001d, + 0x6e617274,0x726f6673,0x0000006d,0x00040006,0x0000001d,0x00000000,0x0070766d,0x00030005, + 0x0000001f,0x00000000,0x00040005,0x00000023,0x736f5061,0x00000000,0x00040047,0x0000000b, + 0x0000001e,0x00000000,0x00040047,0x0000000f,0x0000001e,0x00000002,0x00040047,0x00000015, + 0x0000001e,0x00000001,0x00050048,0x00000019,0x00000000,0x0000000b,0x00000000,0x00030047, + 0x00000019,0x00000002,0x00040048,0x0000001d,0x00000000,0x00000005,0x00050048,0x0000001d, + 0x00000000,0x00000023,0x00000000,0x00050048,0x0000001d,0x00000000,0x00000007,0x00000010, + 0x00030047,0x0000001d,0x00000002,0x00040047,0x0000001f,0x00000022,0x00000000,0x00040047, + 0x0000001f,0x00000021,0x00000000,0x00040047,0x00000023,0x0000001e,0x00000000,0x00020013, + 0x00000002,0x00030021,0x00000003,0x00000002,0x00030016,0x00000006,0x00000020,0x00040017, + 0x00000007,0x00000006,0x00000004,0x00040017,0x00000008,0x00000006,0x00000002,0x0004001e, + 0x00000009,0x00000007,0x00000008,0x00040020,0x0000000a,0x00000003,0x00000009,0x0004003b, + 0x0000000a,0x0000000b,0x00000003,0x00040015,0x0000000c,0x00000020,0x00000001,0x0004002b, + 0x0000000c,0x0000000d,0x00000000,0x00040020,0x0000000e,0x00000001,0x00000007,0x0004003b, + 0x0000000e,0x0000000f,0x00000001,0x00040020,0x00000011,0x00000003,0x00000007,0x0004002b, + 0x0000000c,0x00000013,0x00000001,0x00040020,0x00000014,0x00000001,0x00000008,0x0004003b, + 0x00000014,0x00000015,0x00000001,0x00040020,0x00000017,0x00000003,0x00000008,0x0003001e, + 0x00000019,0x00000007,0x00040020,0x0000001a,0x00000003,0x00000019,0x0004003b,0x0000001a, + 0x0000001b,0x00000003,0x00040018,0x0000001c,0x00000007,0x00000004,0x0003001e,0x0000001d, + 0x0000001c,0x00040020,0x0000001e,0x00000002,0x0000001d,0x0004003b,0x0000001e,0x0000001f, + 0x00000002,0x00040020,0x00000020,0x00000002,0x0000001c,0x0004003b,0x00000014,0x00000023, + 0x00000001,0x0004002b,0x00000006,0x00000025,0x00000000,0x0004002b,0x00000006,0x00000026, + 0x3f800000,0x00050036,0x00000002,0x00000004,0x00000000,0x00000003,0x000200f8,0x00000005, + 0x0004003d,0x00000007,0x00000010,0x0000000f,0x00050041,0x00000011,0x00000012,0x0000000b, + 0x0000000d,0x0003003e,0x00000012,0x00000010,0x0004003d,0x00000008,0x00000016,0x00000015, + 0x00050041,0x00000017,0x00000018,0x0000000b,0x00000013,0x0003003e,0x00000018,0x00000016, + 0x00050041,0x00000020,0x00000021,0x0000001f,0x0000000d,0x0004003d,0x0000001c,0x00000022, + 0x00000021,0x0004003d,0x00000008,0x00000024,0x00000023,0x00050051,0x00000006,0x00000027, + 0x00000024,0x00000000,0x00050051,0x00000006,0x00000028,0x00000024,0x00000001,0x00070050, + 0x00000007,0x00000029,0x00000027,0x00000028,0x00000025,0x00000026,0x00050091,0x00000007, + 0x0000002a,0x00000022,0x00000029,0x00050041,0x00000011,0x0000002b,0x0000001b,0x0000000d, + 0x0003003e,0x0000002b,0x0000002a,0x000100fd,0x00010038 +}; + +// glsl_shader.frag, compiled with: +// # glslangValidator -V -x -o glsl_shader.frag.u32 glsl_shader.frag +/* +#version 450 core +layout(location = 0) out vec4 fColor; +layout(set=0, binding=1) uniform sampler s; +layout(set=1, binding=0) uniform texture2D t; +layout(location = 0) in struct { vec4 Color; vec2 UV; } In; +void main() +{ + fColor = In.Color * texture(sampler2D(t, s), In.UV.st); +} +*/ +static uint32_t __glsl_shader_frag_spv[] = +{ + 0x07230203,0x00010000,0x00080007,0x00000023,0x00000000,0x00020011,0x00000001,0x0006000b, + 0x00000001,0x4c534c47,0x6474732e,0x3035342e,0x00000000,0x0003000e,0x00000000,0x00000001, + 0x0007000f,0x00000004,0x00000004,0x6e69616d,0x00000000,0x00000009,0x0000000d,0x00030010, + 0x00000004,0x00000007,0x00030003,0x00000002,0x000001c2,0x00040005,0x00000004,0x6e69616d, + 0x00000000,0x00040005,0x00000009,0x6c6f4366,0x0000726f,0x00030005,0x0000000b,0x00000000, + 0x00050006,0x0000000b,0x00000000,0x6f6c6f43,0x00000072,0x00040006,0x0000000b,0x00000001, + 0x00005655,0x00030005,0x0000000d,0x00006e49,0x00030005,0x00000015,0x00000074,0x00030005, + 0x00000019,0x00000073,0x00040047,0x00000009,0x0000001e,0x00000000,0x00040047,0x0000000d, + 0x0000001e,0x00000000,0x00040047,0x00000015,0x00000022,0x00000001,0x00040047,0x00000015, + 0x00000021,0x00000000,0x00040047,0x00000019,0x00000022,0x00000000,0x00040047,0x00000019, + 0x00000021,0x00000001,0x00020013,0x00000002,0x00030021,0x00000003,0x00000002,0x00030016, + 0x00000006,0x00000020,0x00040017,0x00000007,0x00000006,0x00000004,0x00040020,0x00000008, + 0x00000003,0x00000007,0x0004003b,0x00000008,0x00000009,0x00000003,0x00040017,0x0000000a, + 0x00000006,0x00000002,0x0004001e,0x0000000b,0x00000007,0x0000000a,0x00040020,0x0000000c, + 0x00000001,0x0000000b,0x0004003b,0x0000000c,0x0000000d,0x00000001,0x00040015,0x0000000e, + 0x00000020,0x00000001,0x0004002b,0x0000000e,0x0000000f,0x00000000,0x00040020,0x00000010, + 0x00000001,0x00000007,0x00090019,0x00000013,0x00000006,0x00000001,0x00000000,0x00000000, + 0x00000000,0x00000001,0x00000000,0x00040020,0x00000014,0x00000000,0x00000013,0x0004003b, + 0x00000014,0x00000015,0x00000000,0x0002001a,0x00000017,0x00040020,0x00000018,0x00000000, + 0x00000017,0x0004003b,0x00000018,0x00000019,0x00000000,0x0003001b,0x0000001b,0x00000013, + 0x0004002b,0x0000000e,0x0000001d,0x00000001,0x00040020,0x0000001e,0x00000001,0x0000000a, + 0x00050036,0x00000002,0x00000004,0x00000000,0x00000003,0x000200f8,0x00000005,0x00050041, + 0x00000010,0x00000011,0x0000000d,0x0000000f,0x0004003d,0x00000007,0x00000012,0x00000011, + 0x0004003d,0x00000013,0x00000016,0x00000015,0x0004003d,0x00000017,0x0000001a,0x00000019, + 0x00050056,0x0000001b,0x0000001c,0x00000016,0x0000001a,0x00050041,0x0000001e,0x0000001f, + 0x0000000d,0x0000001d,0x0004003d,0x0000000a,0x00000020,0x0000001f,0x00050057,0x00000007, + 0x00000021,0x0000001c,0x00000020,0x00050085,0x00000007,0x00000022,0x00000012,0x00000021, + 0x0003003e,0x00000009,0x00000022,0x000100fd,0x00010038 +}; + +static void SafeRelease(ImDrawIdx*& res) +{ + if (res) + delete[] res; + res = NULL; +} +static void SafeRelease(ImDrawVert*& res) +{ + if (res) + delete[] res; + res = NULL; +} +static void SafeRelease(WGPUBindGroupLayout& res) +{ + if (res) + wgpuBindGroupLayoutRelease(res); + res = NULL; +} +static void SafeRelease(WGPUBindGroup& res) +{ + if (res) + wgpuBindGroupRelease(res); + res = NULL; +} +static void SafeRelease(WGPUBuffer& res) +{ + if (res) + wgpuBufferRelease(res); + res = NULL; +} +static void SafeRelease(WGPURenderPipeline& res) +{ + if (res) + wgpuRenderPipelineRelease(res); + res = NULL; +} +static void SafeRelease(WGPUSampler& res) +{ + if (res) + wgpuSamplerRelease(res); + res = NULL; +} +static void SafeRelease(WGPUShaderModule& res) +{ + if (res) + wgpuShaderModuleRelease(res); + res = NULL; +} +static void SafeRelease(WGPUTextureView& res) +{ + if (res) + wgpuTextureViewRelease(res); + res = NULL; +} +static void SafeRelease(WGPUTexture& res) +{ + if (res) + wgpuTextureRelease(res); + res = NULL; +} + +static void SafeRelease(RenderResources& res) +{ + SafeRelease(res.FontTexture); + SafeRelease(res.FontTextureView); + SafeRelease(res.Sampler); + SafeRelease(res.Uniforms); + SafeRelease(res.CommonBindGroup); + SafeRelease(res.ImageBindGroup); + SafeRelease(res.ImageBindGroupLayout); +}; + +static void SafeRelease(FrameResources& res) +{ + SafeRelease(res.IndexBuffer); + SafeRelease(res.VertexBuffer); + SafeRelease(res.IndexBufferHost); + SafeRelease(res.VertexBufferHost); +} + +static WGPUProgrammableStageDescriptor ImGui_ImplWGPU_CreateShaderModule(uint32_t* binary_data, uint32_t binary_data_size) +{ + WGPUShaderModuleSPIRVDescriptor spirv_desc = {}; + spirv_desc.chain.sType = WGPUSType_ShaderModuleSPIRVDescriptor; + spirv_desc.codeSize = binary_data_size; + spirv_desc.code = binary_data; + + WGPUShaderModuleDescriptor desc; + desc.nextInChain = reinterpret_cast(&spirv_desc); + + WGPUProgrammableStageDescriptor stage_desc = {}; + stage_desc.module = wgpuDeviceCreateShaderModule(g_wgpuDevice, &desc); + stage_desc.entryPoint = "main"; + return stage_desc; +} + +static WGPUBindGroup ImGui_ImplWGPU_CreateImageBindGroup(WGPUBindGroupLayout layout, WGPUTextureView texture) +{ + WGPUBindGroupEntry image_bg_entries[] = { { 0, 0, 0, 0, 0, texture } }; + + WGPUBindGroupDescriptor image_bg_descriptor = {}; + image_bg_descriptor.layout = layout; + image_bg_descriptor.entryCount = sizeof(image_bg_entries) / sizeof(WGPUBindGroupEntry); + image_bg_descriptor.entries = image_bg_entries; + return wgpuDeviceCreateBindGroup(g_wgpuDevice, &image_bg_descriptor); +} + +static void ImGui_ImplWGPU_SetupRenderState(ImDrawData* draw_data, WGPURenderPassEncoder ctx, FrameResources* fr) +{ + // Setup orthographic projection matrix into our constant buffer + // Our visible imgui space lies from draw_data->DisplayPos (top left) to draw_data->DisplayPos+data_data->DisplaySize (bottom right). + { + float L = draw_data->DisplayPos.x; + float R = draw_data->DisplayPos.x + draw_data->DisplaySize.x; + float T = draw_data->DisplayPos.y; + float B = draw_data->DisplayPos.y + draw_data->DisplaySize.y; + float mvp[4][4] = + { + { 2.0f/(R-L), 0.0f, 0.0f, 0.0f }, + { 0.0f, 2.0f/(T-B), 0.0f, 0.0f }, + { 0.0f, 0.0f, 0.5f, 0.0f }, + { (R+L)/(L-R), (T+B)/(B-T), 0.5f, 1.0f }, + }; + wgpuQueueWriteBuffer(g_defaultQueue, g_resources.Uniforms, 0, mvp, sizeof(mvp)); + } + + // Setup viewport + wgpuRenderPassEncoderSetViewport(ctx, 0, 0, draw_data->FramebufferScale.x * draw_data->DisplaySize.x, draw_data->FramebufferScale.y * draw_data->DisplaySize.y, 0, 1); + + // Bind shader and vertex buffers + wgpuRenderPassEncoderSetVertexBuffer(ctx, 0, fr->VertexBuffer, 0, 0); + wgpuRenderPassEncoderSetIndexBuffer(ctx, fr->IndexBuffer, sizeof(ImDrawIdx) == 2 ? WGPUIndexFormat_Uint16 : WGPUIndexFormat_Uint32, 0, 0); + wgpuRenderPassEncoderSetPipeline(ctx, g_pipelineState); + wgpuRenderPassEncoderSetBindGroup(ctx, 0, g_resources.CommonBindGroup, 0, NULL); + + // Setup blend factor + WGPUColor blend_color = { 0.f, 0.f, 0.f, 0.f }; + wgpuRenderPassEncoderSetBlendConstant(ctx, &blend_color); +} + +// Render function +// (this used to be set in io.RenderDrawListsFn and called by ImGui::Render(), but you can now call this directly from your main loop) +void ImGui_ImplWGPU_RenderDrawData(ImDrawData* draw_data, WGPURenderPassEncoder pass_encoder) +{ + // Avoid rendering when minimized + if (draw_data->DisplaySize.x <= 0.0f || draw_data->DisplaySize.y <= 0.0f) + return; + + // FIXME: Assuming that this only gets called once per frame! + // If not, we can't just re-allocate the IB or VB, we'll have to do a proper allocator. + g_frameIndex = g_frameIndex + 1; + FrameResources* fr = &g_pFrameResources[g_frameIndex % g_numFramesInFlight]; + + // Create and grow vertex/index buffers if needed + if (fr->VertexBuffer == NULL || fr->VertexBufferSize < draw_data->TotalVtxCount) + { + if (fr->VertexBuffer) + { + wgpuBufferDestroy(fr->VertexBuffer); + wgpuBufferRelease(fr->VertexBuffer); + } + SafeRelease(fr->VertexBufferHost); + fr->VertexBufferSize = draw_data->TotalVtxCount + 5000; + + WGPUBufferDescriptor vb_desc = + { + NULL, + "Dear ImGui Vertex buffer", + WGPUBufferUsage_CopyDst | WGPUBufferUsage_Vertex, + fr->VertexBufferSize * sizeof(ImDrawVert), + false + }; + fr->VertexBuffer = wgpuDeviceCreateBuffer(g_wgpuDevice, &vb_desc); + if (!fr->VertexBuffer) + return; + + fr->VertexBufferHost = new ImDrawVert[fr->VertexBufferSize]; + } + if (fr->IndexBuffer == NULL || fr->IndexBufferSize < draw_data->TotalIdxCount) + { + if (fr->IndexBuffer) + { + wgpuBufferDestroy(fr->IndexBuffer); + wgpuBufferRelease(fr->IndexBuffer); + } + SafeRelease(fr->IndexBufferHost); + fr->IndexBufferSize = draw_data->TotalIdxCount + 10000; + + WGPUBufferDescriptor ib_desc = + { + NULL, + "Dear ImGui Index buffer", + WGPUBufferUsage_CopyDst | WGPUBufferUsage_Index, + fr->IndexBufferSize * sizeof(ImDrawIdx), + false + }; + fr->IndexBuffer = wgpuDeviceCreateBuffer(g_wgpuDevice, &ib_desc); + if (!fr->IndexBuffer) + return; + + fr->IndexBufferHost = new ImDrawIdx[fr->IndexBufferSize]; + } + + // Upload vertex/index data into a single contiguous GPU buffer + ImDrawVert* vtx_dst = (ImDrawVert*)fr->VertexBufferHost; + ImDrawIdx* idx_dst = (ImDrawIdx*)fr->IndexBufferHost; + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + memcpy(vtx_dst, cmd_list->VtxBuffer.Data, cmd_list->VtxBuffer.Size * sizeof(ImDrawVert)); + memcpy(idx_dst, cmd_list->IdxBuffer.Data, cmd_list->IdxBuffer.Size * sizeof(ImDrawIdx)); + vtx_dst += cmd_list->VtxBuffer.Size; + idx_dst += cmd_list->IdxBuffer.Size; + } + int64_t vb_write_size = ((char*)vtx_dst - (char*)fr->VertexBufferHost + 3) & ~3; + int64_t ib_write_size = ((char*)idx_dst - (char*)fr->IndexBufferHost + 3) & ~3; + wgpuQueueWriteBuffer(g_defaultQueue, fr->VertexBuffer, 0, fr->VertexBufferHost, vb_write_size); + wgpuQueueWriteBuffer(g_defaultQueue, fr->IndexBuffer, 0, fr->IndexBufferHost, ib_write_size); + + // Setup desired render state + ImGui_ImplWGPU_SetupRenderState(draw_data, pass_encoder, fr); + + // Render command lists + // (Because we merged all buffers into a single one, we maintain our own offset into them) + int global_vtx_offset = 0; + int global_idx_offset = 0; + ImVec2 clip_scale = draw_data->FramebufferScale; + ImVec2 clip_off = draw_data->DisplayPos; + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + const ImDrawCmd* pcmd = &cmd_list->CmdBuffer[cmd_i]; + if (pcmd->UserCallback != NULL) + { + // User callback, registered via ImDrawList::AddCallback() + // (ImDrawCallback_ResetRenderState is a special callback value used by the user to request the renderer to reset render state.) + if (pcmd->UserCallback == ImDrawCallback_ResetRenderState) + ImGui_ImplWGPU_SetupRenderState(draw_data, pass_encoder, fr); + else + pcmd->UserCallback(cmd_list, pcmd); + } + else + { + // Bind custom texture + ImTextureID tex_id = pcmd->GetTexID(); + ImGuiID tex_id_hash = ImHashData(&tex_id, sizeof(tex_id)); + auto bind_group = g_resources.ImageBindGroups.GetVoidPtr(tex_id_hash); + if (bind_group) + { + wgpuRenderPassEncoderSetBindGroup(pass_encoder, 1, (WGPUBindGroup)bind_group, 0, NULL); + } + else + { + WGPUBindGroup image_bind_group = ImGui_ImplWGPU_CreateImageBindGroup(g_resources.ImageBindGroupLayout, (WGPUTextureView)tex_id); + g_resources.ImageBindGroups.SetVoidPtr(tex_id_hash, image_bind_group); + wgpuRenderPassEncoderSetBindGroup(pass_encoder, 1, image_bind_group, 0, NULL); + } + + // Project scissor/clipping rectangles into framebuffer space + ImVec2 clip_min((pcmd->ClipRect.x - clip_off.x) * clip_scale.x, (pcmd->ClipRect.y - clip_off.y) * clip_scale.y); + ImVec2 clip_max((pcmd->ClipRect.z - clip_off.x) * clip_scale.x, (pcmd->ClipRect.w - clip_off.y) * clip_scale.y); + if (clip_max.x < clip_min.x || clip_max.y < clip_min.y) + continue; + + // Apply scissor/clipping rectangle, Draw + wgpuRenderPassEncoderSetScissorRect(pass_encoder, (uint32_t)clip_min.x, (uint32_t)clip_min.y, (uint32_t)(clip_max.x - clip_min.x), (uint32_t)(clip_max.y - clip_min.y)); + wgpuRenderPassEncoderDrawIndexed(pass_encoder, pcmd->ElemCount, 1, pcmd->IdxOffset + global_idx_offset, pcmd->VtxOffset + global_vtx_offset, 0); + } + } + global_idx_offset += cmd_list->IdxBuffer.Size; + global_vtx_offset += cmd_list->VtxBuffer.Size; + } +} + +static void ImGui_ImplWGPU_CreateFontsTexture() +{ + // Build texture atlas + ImGuiIO& io = ImGui::GetIO(); + unsigned char* pixels; + int width, height, size_pp; + io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height, &size_pp); + + // Upload texture to graphics system + { + WGPUTextureDescriptor tex_desc = {}; + tex_desc.label = "Dear ImGui Font Texture"; + tex_desc.dimension = WGPUTextureDimension_2D; + tex_desc.size.width = width; + tex_desc.size.height = height; + tex_desc.size.depthOrArrayLayers = 1; + tex_desc.sampleCount = 1; + tex_desc.format = WGPUTextureFormat_RGBA8Unorm; + tex_desc.mipLevelCount = 1; + tex_desc.usage = WGPUTextureUsage_CopyDst | WGPUTextureUsage_Sampled; + g_resources.FontTexture = wgpuDeviceCreateTexture(g_wgpuDevice, &tex_desc); + + WGPUTextureViewDescriptor tex_view_desc = {}; + tex_view_desc.format = WGPUTextureFormat_RGBA8Unorm; + tex_view_desc.dimension = WGPUTextureViewDimension_2D; + tex_view_desc.baseMipLevel = 0; + tex_view_desc.mipLevelCount = 1; + tex_view_desc.baseArrayLayer = 0; + tex_view_desc.arrayLayerCount = 1; + tex_view_desc.aspect = WGPUTextureAspect_All; + g_resources.FontTextureView = wgpuTextureCreateView(g_resources.FontTexture, &tex_view_desc); + } + + // Upload texture data + { + WGPUImageCopyTexture dst_view = {}; + dst_view.texture = g_resources.FontTexture; + dst_view.mipLevel = 0; + dst_view.origin = { 0, 0, 0 }; + dst_view.aspect = WGPUTextureAspect_All; + WGPUTextureDataLayout layout = {}; + layout.offset = 0; + layout.bytesPerRow = width * size_pp; + layout.rowsPerImage = height; + WGPUExtent3D size = { (uint32_t)width, (uint32_t)height, 1 }; + wgpuQueueWriteTexture(g_defaultQueue, &dst_view, pixels, (uint32_t)(width * size_pp * height), &layout, &size); + } + + // Create the associated sampler + { + WGPUSamplerDescriptor sampler_desc = {}; + sampler_desc.minFilter = WGPUFilterMode_Linear; + sampler_desc.magFilter = WGPUFilterMode_Linear; + sampler_desc.mipmapFilter = WGPUFilterMode_Linear; + sampler_desc.addressModeU = WGPUAddressMode_Repeat; + sampler_desc.addressModeV = WGPUAddressMode_Repeat; + sampler_desc.addressModeW = WGPUAddressMode_Repeat; + sampler_desc.maxAnisotropy = 1; + g_resources.Sampler = wgpuDeviceCreateSampler(g_wgpuDevice, &sampler_desc); + } + + // Store our identifier + static_assert(sizeof(ImTextureID) >= sizeof(g_resources.FontTexture), "Can't pack descriptor handle into TexID, 32-bit not supported yet."); + io.Fonts->SetTexID((ImTextureID)g_resources.FontTextureView); +} + +static void ImGui_ImplWGPU_CreateUniformBuffer() +{ + WGPUBufferDescriptor ub_desc = + { + NULL, + "Dear ImGui Uniform buffer", + WGPUBufferUsage_CopyDst | WGPUBufferUsage_Uniform, + sizeof(Uniforms), + false + }; + g_resources.Uniforms = wgpuDeviceCreateBuffer(g_wgpuDevice, &ub_desc); +} + +bool ImGui_ImplWGPU_CreateDeviceObjects() +{ + if (!g_wgpuDevice) + return false; + if (g_pipelineState) + ImGui_ImplWGPU_InvalidateDeviceObjects(); + + // Create render pipeline + WGPURenderPipelineDescriptor graphics_pipeline_desc = {}; + graphics_pipeline_desc.primitive.topology = WGPUPrimitiveTopology_TriangleList; + graphics_pipeline_desc.primitive.stripIndexFormat = WGPUIndexFormat_Undefined; + graphics_pipeline_desc.primitive.frontFace = WGPUFrontFace_CW; + graphics_pipeline_desc.primitive.cullMode = WGPUCullMode_None; + graphics_pipeline_desc.multisample.count = 1; + graphics_pipeline_desc.multisample.mask = UINT_MAX; + graphics_pipeline_desc.multisample.alphaToCoverageEnabled = false; + graphics_pipeline_desc.layout = nullptr; // Use automatic layout generation + + // Create the vertex shader + WGPUProgrammableStageDescriptor vertex_shader_desc = ImGui_ImplWGPU_CreateShaderModule(__glsl_shader_vert_spv, sizeof(__glsl_shader_vert_spv) / sizeof(uint32_t)); + graphics_pipeline_desc.vertex.module = vertex_shader_desc.module; + graphics_pipeline_desc.vertex.entryPoint = vertex_shader_desc.entryPoint; + + // Vertex input configuration + WGPUVertexAttribute attribute_desc[] = + { + { WGPUVertexFormat_Float32x2, (uint64_t)IM_OFFSETOF(ImDrawVert, pos), 0 }, + { WGPUVertexFormat_Float32x2, (uint64_t)IM_OFFSETOF(ImDrawVert, uv), 1 }, + { WGPUVertexFormat_Unorm8x4, (uint64_t)IM_OFFSETOF(ImDrawVert, col), 2 }, + }; + + WGPUVertexBufferLayout buffer_layouts[1]; + buffer_layouts[0].arrayStride = sizeof(ImDrawVert); + buffer_layouts[0].stepMode = WGPUInputStepMode_Vertex; + buffer_layouts[0].attributeCount = 3; + buffer_layouts[0].attributes = attribute_desc; + + graphics_pipeline_desc.vertex.bufferCount = 1; + graphics_pipeline_desc.vertex.buffers = buffer_layouts; + + // Create the pixel shader + WGPUProgrammableStageDescriptor pixel_shader_desc = ImGui_ImplWGPU_CreateShaderModule(__glsl_shader_frag_spv, sizeof(__glsl_shader_frag_spv) / sizeof(uint32_t)); + + // Create the blending setup + WGPUBlendState blend_state = {}; + blend_state.alpha.operation = WGPUBlendOperation_Add; + blend_state.alpha.srcFactor = WGPUBlendFactor_One; + blend_state.alpha.dstFactor = WGPUBlendFactor_OneMinusSrcAlpha; + blend_state.color.operation = WGPUBlendOperation_Add; + blend_state.color.srcFactor = WGPUBlendFactor_SrcAlpha; + blend_state.color.dstFactor = WGPUBlendFactor_OneMinusSrcAlpha; + + WGPUColorTargetState color_state = {}; + color_state.format = g_renderTargetFormat; + color_state.blend = &blend_state; + color_state.writeMask = WGPUColorWriteMask_All; + + WGPUFragmentState fragment_state = {}; + fragment_state.module = pixel_shader_desc.module; + fragment_state.entryPoint = pixel_shader_desc.entryPoint; + fragment_state.targetCount = 1; + fragment_state.targets = &color_state; + + graphics_pipeline_desc.fragment = &fragment_state; + + // Create depth-stencil State + WGPUDepthStencilState depth_stencil_state = {}; + depth_stencil_state.depthBias = 0; + depth_stencil_state.depthBiasClamp = 0; + depth_stencil_state.depthBiasSlopeScale = 0; + + // Configure disabled depth-stencil state + graphics_pipeline_desc.depthStencil = nullptr; + + g_pipelineState = wgpuDeviceCreateRenderPipeline(g_wgpuDevice, &graphics_pipeline_desc); + + ImGui_ImplWGPU_CreateFontsTexture(); + ImGui_ImplWGPU_CreateUniformBuffer(); + + // Create resource bind group + WGPUBindGroupLayout bg_layouts[2]; + bg_layouts[0] = wgpuRenderPipelineGetBindGroupLayout(g_pipelineState, 0); + bg_layouts[1] = wgpuRenderPipelineGetBindGroupLayout(g_pipelineState, 1); + + WGPUBindGroupEntry common_bg_entries[] = + { + { 0, g_resources.Uniforms, 0, sizeof(Uniforms), 0, 0 }, + { 1, 0, 0, 0, g_resources.Sampler, 0 }, + }; + + WGPUBindGroupDescriptor common_bg_descriptor = {}; + common_bg_descriptor.layout = bg_layouts[0]; + common_bg_descriptor.entryCount = sizeof(common_bg_entries) / sizeof(WGPUBindGroupEntry); + common_bg_descriptor.entries = common_bg_entries; + g_resources.CommonBindGroup = wgpuDeviceCreateBindGroup(g_wgpuDevice, &common_bg_descriptor); + + WGPUBindGroup image_bind_group = ImGui_ImplWGPU_CreateImageBindGroup(bg_layouts[1], g_resources.FontTextureView); + g_resources.ImageBindGroup = image_bind_group; + g_resources.ImageBindGroupLayout = bg_layouts[1]; + g_resources.ImageBindGroups.SetVoidPtr(ImHashData(&g_resources.FontTextureView, sizeof(ImTextureID)), image_bind_group); + + SafeRelease(vertex_shader_desc.module); + SafeRelease(pixel_shader_desc.module); + SafeRelease(bg_layouts[0]); + + return true; +} + +void ImGui_ImplWGPU_InvalidateDeviceObjects() +{ + if (!g_wgpuDevice) + return; + + SafeRelease(g_pipelineState); + SafeRelease(g_resources); + + ImGuiIO& io = ImGui::GetIO(); + io.Fonts->SetTexID(NULL); // We copied g_pFontTextureView to io.Fonts->TexID so let's clear that as well. + + for (unsigned int i = 0; i < g_numFramesInFlight; i++) + SafeRelease(g_pFrameResources[i]); +} + +bool ImGui_ImplWGPU_Init(WGPUDevice device, int num_frames_in_flight, WGPUTextureFormat rt_format) +{ + // Setup backend capabilities flags + ImGuiIO& io = ImGui::GetIO(); + io.BackendRendererName = "imgui_impl_webgpu"; + io.BackendFlags |= ImGuiBackendFlags_RendererHasVtxOffset; // We can honor the ImDrawCmd::VtxOffset field, allowing for large meshes. + + g_wgpuDevice = device; + g_defaultQueue = wgpuDeviceGetQueue(g_wgpuDevice); + g_renderTargetFormat = rt_format; + g_pFrameResources = new FrameResources[num_frames_in_flight]; + g_numFramesInFlight = num_frames_in_flight; + g_frameIndex = UINT_MAX; + + g_resources.FontTexture = NULL; + g_resources.FontTextureView = NULL; + g_resources.Sampler = NULL; + g_resources.Uniforms = NULL; + g_resources.CommonBindGroup = NULL; + g_resources.ImageBindGroups.Data.reserve(100); + g_resources.ImageBindGroup = NULL; + g_resources.ImageBindGroupLayout = NULL; + + // Create buffers with a default size (they will later be grown as needed) + for (int i = 0; i < num_frames_in_flight; i++) + { + FrameResources* fr = &g_pFrameResources[i]; + fr->IndexBuffer = NULL; + fr->VertexBuffer = NULL; + fr->IndexBufferHost = NULL; + fr->VertexBufferHost = NULL; + fr->IndexBufferSize = 10000; + fr->VertexBufferSize = 5000; + } + + return true; +} + +void ImGui_ImplWGPU_Shutdown() +{ + ImGui_ImplWGPU_InvalidateDeviceObjects(); + delete[] g_pFrameResources; + g_pFrameResources = NULL; + wgpuQueueRelease(g_defaultQueue); + g_wgpuDevice = NULL; + g_numFramesInFlight = 0; + g_frameIndex = UINT_MAX; +} + +void ImGui_ImplWGPU_NewFrame() +{ + if (!g_pipelineState) + ImGui_ImplWGPU_CreateDeviceObjects(); +} diff --git a/source/editor/imgui/backends/imgui_impl_wgpu.h b/source/editor/imgui/backends/imgui_impl_wgpu.h new file mode 100644 index 0000000..ec10768 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_wgpu.h @@ -0,0 +1,25 @@ +// dear imgui: Renderer for WebGPU +// This needs to be used along with a Platform Binding (e.g. GLFW) +// (Please note that WebGPU is currently experimental, will not run on non-beta browsers, and may break.) + +// Implemented features: +// [X] Renderer: User texture binding. Use 'WGPUTextureView' as ImTextureID. Read the FAQ about ImTextureID! +// [X] Renderer: Support for large meshes (64k+ vertices) with 16-bit indices. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API +#include + +IMGUI_IMPL_API bool ImGui_ImplWGPU_Init(WGPUDevice device, int num_frames_in_flight, WGPUTextureFormat rt_format); +IMGUI_IMPL_API void ImGui_ImplWGPU_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplWGPU_NewFrame(); +IMGUI_IMPL_API void ImGui_ImplWGPU_RenderDrawData(ImDrawData* draw_data, WGPURenderPassEncoder pass_encoder); + +// Use if you want to reset your rendering device without losing Dear ImGui state. +IMGUI_IMPL_API void ImGui_ImplWGPU_InvalidateDeviceObjects(); +IMGUI_IMPL_API bool ImGui_ImplWGPU_CreateDeviceObjects(); diff --git a/source/editor/imgui/backends/imgui_impl_win32.cpp b/source/editor/imgui/backends/imgui_impl_win32.cpp new file mode 100644 index 0000000..740b176 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_win32.cpp @@ -0,0 +1,615 @@ +// dear imgui: Platform Backend for Windows (standard windows API for 32 and 64 bits applications) +// This needs to be used along with a Renderer (e.g. DirectX11, OpenGL3, Vulkan..) + +// Implemented features: +// [X] Platform: Clipboard support (for Win32 this is actually part of core dear imgui) +// [X] Platform: Mouse cursor shape and visibility. Disable with 'io.ConfigFlags |= ImGuiConfigFlags_NoMouseCursorChange'. +// [X] Platform: Keyboard arrays indexed using VK_* Virtual Key Codes, e.g. ImGui::IsKeyPressed(VK_SPACE). +// [X] Platform: Gamepad support. Enabled with 'io.ConfigFlags |= ImGuiConfigFlags_NavEnableGamepad'. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#include "imgui.h" +#include "imgui_impl_win32.h" +#ifndef WIN32_LEAN_AND_MEAN +#define WIN32_LEAN_AND_MEAN +#endif +#include +#include +#include + +// Configuration flags to add in your imconfig.h file: +//#define IMGUI_IMPL_WIN32_DISABLE_GAMEPAD // Disable gamepad support. This was meaningful before <1.81 but we now load XInput dynamically so the option is now less relevant. + +// Using XInput for gamepad (will load DLL dynamically) +#ifndef IMGUI_IMPL_WIN32_DISABLE_GAMEPAD +#include +typedef DWORD (WINAPI *PFN_XInputGetCapabilities)(DWORD, DWORD, XINPUT_CAPABILITIES*); +typedef DWORD (WINAPI *PFN_XInputGetState)(DWORD, XINPUT_STATE*); +#endif + +// CHANGELOG +// (minor and older changes stripped away, please see git history for details) +// 2021-08-17: Calling io.AddFocusEvent() on WM_SETFOCUS/WM_KILLFOCUS messages. +// 2021-08-02: Inputs: Fixed keyboard modifiers being reported when host windo doesn't have focus. +// 2021-07-29: Inputs: MousePos is correctly reported when the host platform window is hovered but not focused (using TrackMouseEvent() to receive WM_MOUSELEAVE events). +// 2021-06-29: Reorganized backend to pull data from a single structure to facilitate usage with multiple-contexts (all g_XXXX access changed to bd->XXXX). +// 2021-06-08: Fixed ImGui_ImplWin32_EnableDpiAwareness() and ImGui_ImplWin32_GetDpiScaleForMonitor() to handle Windows 8.1/10 features without a manifest (per-monitor DPI, and properly calls SetProcessDpiAwareness() on 8.1). +// 2021-03-23: Inputs: Clearing keyboard down array when losing focus (WM_KILLFOCUS). +// 2021-02-18: Added ImGui_ImplWin32_EnableAlphaCompositing(). Non Visual Studio users will need to link with dwmapi.lib (MinGW/gcc: use -ldwmapi). +// 2021-02-17: Fixed ImGui_ImplWin32_EnableDpiAwareness() attempting to get SetProcessDpiAwareness from shcore.dll on Windows 8 whereas it is only supported on Windows 8.1. +// 2021-01-25: Inputs: Dynamically loading XInput DLL. +// 2020-12-04: Misc: Fixed setting of io.DisplaySize to invalid/uninitialized data when after hwnd has been closed. +// 2020-03-03: Inputs: Calling AddInputCharacterUTF16() to support surrogate pairs leading to codepoint >= 0x10000 (for more complete CJK inputs) +// 2020-02-17: Added ImGui_ImplWin32_EnableDpiAwareness(), ImGui_ImplWin32_GetDpiScaleForHwnd(), ImGui_ImplWin32_GetDpiScaleForMonitor() helper functions. +// 2020-01-14: Inputs: Added support for #define IMGUI_IMPL_WIN32_DISABLE_GAMEPAD/IMGUI_IMPL_WIN32_DISABLE_LINKING_XINPUT. +// 2019-12-05: Inputs: Added support for ImGuiMouseCursor_NotAllowed mouse cursor. +// 2019-05-11: Inputs: Don't filter value from WM_CHAR before calling AddInputCharacter(). +// 2019-01-17: Misc: Using GetForegroundWindow()+IsChild() instead of GetActiveWindow() to be compatible with windows created in a different thread or parent. +// 2019-01-17: Inputs: Added support for mouse buttons 4 and 5 via WM_XBUTTON* messages. +// 2019-01-15: Inputs: Added support for XInput gamepads (if ImGuiConfigFlags_NavEnableGamepad is set by user application). +// 2018-11-30: Misc: Setting up io.BackendPlatformName so it can be displayed in the About Window. +// 2018-06-29: Inputs: Added support for the ImGuiMouseCursor_Hand cursor. +// 2018-06-10: Inputs: Fixed handling of mouse wheel messages to support fine position messages (typically sent by track-pads). +// 2018-06-08: Misc: Extracted imgui_impl_win32.cpp/.h away from the old combined DX9/DX10/DX11/DX12 examples. +// 2018-03-20: Misc: Setup io.BackendFlags ImGuiBackendFlags_HasMouseCursors and ImGuiBackendFlags_HasSetMousePos flags + honor ImGuiConfigFlags_NoMouseCursorChange flag. +// 2018-02-20: Inputs: Added support for mouse cursors (ImGui::GetMouseCursor() value and WM_SETCURSOR message handling). +// 2018-02-06: Inputs: Added mapping for ImGuiKey_Space. +// 2018-02-06: Inputs: Honoring the io.WantSetMousePos by repositioning the mouse (when using navigation and ImGuiConfigFlags_NavMoveMouse is set). +// 2018-02-06: Misc: Removed call to ImGui::Shutdown() which is not available from 1.60 WIP, user needs to call CreateContext/DestroyContext themselves. +// 2018-01-20: Inputs: Added Horizontal Mouse Wheel support. +// 2018-01-08: Inputs: Added mapping for ImGuiKey_Insert. +// 2018-01-05: Inputs: Added WM_LBUTTONDBLCLK double-click handlers for window classes with the CS_DBLCLKS flag. +// 2017-10-23: Inputs: Added WM_SYSKEYDOWN / WM_SYSKEYUP handlers so e.g. the VK_MENU key can be read. +// 2017-10-23: Inputs: Using Win32 ::SetCapture/::GetCapture() to retrieve mouse positions outside the client area when dragging. +// 2016-11-12: Inputs: Only call Win32 ::SetCursor(NULL) when io.MouseDrawCursor is set. + +struct ImGui_ImplWin32_Data +{ + HWND hWnd; + HWND MouseHwnd; + bool MouseTracked; + INT64 Time; + INT64 TicksPerSecond; + ImGuiMouseCursor LastMouseCursor; + bool HasGamepad; + bool WantUpdateHasGamepad; + +#ifndef IMGUI_IMPL_WIN32_DISABLE_GAMEPAD + HMODULE XInputDLL; + PFN_XInputGetCapabilities XInputGetCapabilities; + PFN_XInputGetState XInputGetState; +#endif + + ImGui_ImplWin32_Data() { memset(this, 0, sizeof(*this)); } +}; + +// Backend data stored in io.BackendPlatformUserData to allow support for multiple Dear ImGui contexts +// It is STRONGLY preferred that you use docking branch with multi-viewports (== single Dear ImGui context + multiple windows) instead of multiple Dear ImGui contexts. +// FIXME: multi-context support is not well tested and probably dysfunctional in this backend. +// FIXME: some shared resources (mouse cursor shape, gamepad) are mishandled when using multi-context. +static ImGui_ImplWin32_Data* ImGui_ImplWin32_GetBackendData() +{ + return ImGui::GetCurrentContext() ? (ImGui_ImplWin32_Data*)ImGui::GetIO().BackendPlatformUserData : NULL; +} + +// Functions +bool ImGui_ImplWin32_Init(void* hwnd) +{ + ImGuiIO& io = ImGui::GetIO(); + IM_ASSERT(io.BackendPlatformUserData == NULL && "Already initialized a platform backend!"); + + INT64 perf_frequency, perf_counter; + if (!::QueryPerformanceFrequency((LARGE_INTEGER*)&perf_frequency)) + return false; + if (!::QueryPerformanceCounter((LARGE_INTEGER*)&perf_counter)) + return false; + + // Setup backend capabilities flags + ImGui_ImplWin32_Data* bd = IM_NEW(ImGui_ImplWin32_Data)(); + io.BackendPlatformUserData = (void*)bd; + io.BackendPlatformName = "imgui_impl_win32"; + io.BackendFlags |= ImGuiBackendFlags_HasMouseCursors; // We can honor GetMouseCursor() values (optional) + io.BackendFlags |= ImGuiBackendFlags_HasSetMousePos; // We can honor io.WantSetMousePos requests (optional, rarely used) + + bd->hWnd = (HWND)hwnd; + bd->WantUpdateHasGamepad = true; + bd->TicksPerSecond = perf_frequency; + bd->Time = perf_counter; + bd->LastMouseCursor = ImGuiMouseCursor_COUNT; + + io.ImeWindowHandle = hwnd; + + // Keyboard mapping. Dear ImGui will use those indices to peek into the io.KeysDown[] array that we will update during the application lifetime. + io.KeyMap[ImGuiKey_Tab] = VK_TAB; + io.KeyMap[ImGuiKey_LeftArrow] = VK_LEFT; + io.KeyMap[ImGuiKey_RightArrow] = VK_RIGHT; + io.KeyMap[ImGuiKey_UpArrow] = VK_UP; + io.KeyMap[ImGuiKey_DownArrow] = VK_DOWN; + io.KeyMap[ImGuiKey_PageUp] = VK_PRIOR; + io.KeyMap[ImGuiKey_PageDown] = VK_NEXT; + io.KeyMap[ImGuiKey_Home] = VK_HOME; + io.KeyMap[ImGuiKey_End] = VK_END; + io.KeyMap[ImGuiKey_Insert] = VK_INSERT; + io.KeyMap[ImGuiKey_Delete] = VK_DELETE; + io.KeyMap[ImGuiKey_Backspace] = VK_BACK; + io.KeyMap[ImGuiKey_Space] = VK_SPACE; + io.KeyMap[ImGuiKey_Enter] = VK_RETURN; + io.KeyMap[ImGuiKey_Escape] = VK_ESCAPE; + io.KeyMap[ImGuiKey_KeyPadEnter] = VK_RETURN; + io.KeyMap[ImGuiKey_A] = 'A'; + io.KeyMap[ImGuiKey_C] = 'C'; + io.KeyMap[ImGuiKey_V] = 'V'; + io.KeyMap[ImGuiKey_X] = 'X'; + io.KeyMap[ImGuiKey_Y] = 'Y'; + io.KeyMap[ImGuiKey_Z] = 'Z'; + + // Dynamically load XInput library +#ifndef IMGUI_IMPL_WIN32_DISABLE_GAMEPAD + const char* xinput_dll_names[] = + { + "xinput1_4.dll", // Windows 8+ + "xinput1_3.dll", // DirectX SDK + "xinput9_1_0.dll", // Windows Vista, Windows 7 + "xinput1_2.dll", // DirectX SDK + "xinput1_1.dll" // DirectX SDK + }; + for (int n = 0; n < IM_ARRAYSIZE(xinput_dll_names); n++) + if (HMODULE dll = ::LoadLibraryA(xinput_dll_names[n])) + { + bd->XInputDLL = dll; + bd->XInputGetCapabilities = (PFN_XInputGetCapabilities)::GetProcAddress(dll, "XInputGetCapabilities"); + bd->XInputGetState = (PFN_XInputGetState)::GetProcAddress(dll, "XInputGetState"); + break; + } +#endif // IMGUI_IMPL_WIN32_DISABLE_GAMEPAD + + return true; +} + +void ImGui_ImplWin32_Shutdown() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplWin32_Data* bd = ImGui_ImplWin32_GetBackendData(); + + // Unload XInput library +#ifndef IMGUI_IMPL_WIN32_DISABLE_GAMEPAD + if (bd->XInputDLL) + ::FreeLibrary(bd->XInputDLL); +#endif // IMGUI_IMPL_WIN32_DISABLE_GAMEPAD + + io.BackendPlatformName = NULL; + io.BackendPlatformUserData = NULL; + IM_DELETE(bd); +} + +static bool ImGui_ImplWin32_UpdateMouseCursor() +{ + ImGuiIO& io = ImGui::GetIO(); + if (io.ConfigFlags & ImGuiConfigFlags_NoMouseCursorChange) + return false; + + ImGuiMouseCursor imgui_cursor = ImGui::GetMouseCursor(); + if (imgui_cursor == ImGuiMouseCursor_None || io.MouseDrawCursor) + { + // Hide OS mouse cursor if imgui is drawing it or if it wants no cursor + ::SetCursor(NULL); + } + else + { + // Show OS mouse cursor + LPTSTR win32_cursor = IDC_ARROW; + switch (imgui_cursor) + { + case ImGuiMouseCursor_Arrow: win32_cursor = IDC_ARROW; break; + case ImGuiMouseCursor_TextInput: win32_cursor = IDC_IBEAM; break; + case ImGuiMouseCursor_ResizeAll: win32_cursor = IDC_SIZEALL; break; + case ImGuiMouseCursor_ResizeEW: win32_cursor = IDC_SIZEWE; break; + case ImGuiMouseCursor_ResizeNS: win32_cursor = IDC_SIZENS; break; + case ImGuiMouseCursor_ResizeNESW: win32_cursor = IDC_SIZENESW; break; + case ImGuiMouseCursor_ResizeNWSE: win32_cursor = IDC_SIZENWSE; break; + case ImGuiMouseCursor_Hand: win32_cursor = IDC_HAND; break; + case ImGuiMouseCursor_NotAllowed: win32_cursor = IDC_NO; break; + } + ::SetCursor(::LoadCursor(NULL, win32_cursor)); + } + return true; +} + +static void ImGui_ImplWin32_UpdateMousePos() +{ + ImGui_ImplWin32_Data* bd = ImGui_ImplWin32_GetBackendData(); + ImGuiIO& io = ImGui::GetIO(); + IM_ASSERT(bd->hWnd != 0); + + const ImVec2 mouse_pos_prev = io.MousePos; + io.MousePos = ImVec2(-FLT_MAX, -FLT_MAX); + + // Obtain focused and hovered window. We forward mouse input when focused or when hovered (and no other window is capturing) + HWND focused_window = ::GetForegroundWindow(); + HWND hovered_window = bd->MouseHwnd; + HWND mouse_window = NULL; + if (hovered_window && (hovered_window == bd->hWnd || ::IsChild(hovered_window, bd->hWnd))) + mouse_window = hovered_window; + else if (focused_window && (focused_window == bd->hWnd || ::IsChild(focused_window, bd->hWnd))) + mouse_window = focused_window; + if (mouse_window == NULL) + return; + + // Set OS mouse position from Dear ImGui if requested (rarely used, only when ImGuiConfigFlags_NavEnableSetMousePos is enabled by user) + if (io.WantSetMousePos) + { + POINT pos = { (int)mouse_pos_prev.x, (int)mouse_pos_prev.y }; + if (::ClientToScreen(bd->hWnd, &pos)) + ::SetCursorPos(pos.x, pos.y); + } + + // Set Dear ImGui mouse position from OS position + POINT pos; + if (::GetCursorPos(&pos) && ::ScreenToClient(mouse_window, &pos)) + io.MousePos = ImVec2((float)pos.x, (float)pos.y); +} + +// Gamepad navigation mapping +static void ImGui_ImplWin32_UpdateGamepads() +{ +#ifndef IMGUI_IMPL_WIN32_DISABLE_GAMEPAD + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplWin32_Data* bd = ImGui_ImplWin32_GetBackendData(); + memset(io.NavInputs, 0, sizeof(io.NavInputs)); + if ((io.ConfigFlags & ImGuiConfigFlags_NavEnableGamepad) == 0) + return; + + // Calling XInputGetState() every frame on disconnected gamepads is unfortunately too slow. + // Instead we refresh gamepad availability by calling XInputGetCapabilities() _only_ after receiving WM_DEVICECHANGE. + if (bd->WantUpdateHasGamepad) + { + XINPUT_CAPABILITIES caps; + bd->HasGamepad = bd->XInputGetCapabilities ? (bd->XInputGetCapabilities(0, XINPUT_FLAG_GAMEPAD, &caps) == ERROR_SUCCESS) : false; + bd->WantUpdateHasGamepad = false; + } + + io.BackendFlags &= ~ImGuiBackendFlags_HasGamepad; + XINPUT_STATE xinput_state; + if (bd->HasGamepad && bd->XInputGetState && bd->XInputGetState(0, &xinput_state) == ERROR_SUCCESS) + { + const XINPUT_GAMEPAD& gamepad = xinput_state.Gamepad; + io.BackendFlags |= ImGuiBackendFlags_HasGamepad; + + #define MAP_BUTTON(NAV_NO, BUTTON_ENUM) { io.NavInputs[NAV_NO] = (gamepad.wButtons & BUTTON_ENUM) ? 1.0f : 0.0f; } + #define MAP_ANALOG(NAV_NO, VALUE, V0, V1) { float vn = (float)(VALUE - V0) / (float)(V1 - V0); if (vn > 1.0f) vn = 1.0f; if (vn > 0.0f && io.NavInputs[NAV_NO] < vn) io.NavInputs[NAV_NO] = vn; } + MAP_BUTTON(ImGuiNavInput_Activate, XINPUT_GAMEPAD_A); // Cross / A + MAP_BUTTON(ImGuiNavInput_Cancel, XINPUT_GAMEPAD_B); // Circle / B + MAP_BUTTON(ImGuiNavInput_Menu, XINPUT_GAMEPAD_X); // Square / X + MAP_BUTTON(ImGuiNavInput_Input, XINPUT_GAMEPAD_Y); // Triangle / Y + MAP_BUTTON(ImGuiNavInput_DpadLeft, XINPUT_GAMEPAD_DPAD_LEFT); // D-Pad Left + MAP_BUTTON(ImGuiNavInput_DpadRight, XINPUT_GAMEPAD_DPAD_RIGHT); // D-Pad Right + MAP_BUTTON(ImGuiNavInput_DpadUp, XINPUT_GAMEPAD_DPAD_UP); // D-Pad Up + MAP_BUTTON(ImGuiNavInput_DpadDown, XINPUT_GAMEPAD_DPAD_DOWN); // D-Pad Down + MAP_BUTTON(ImGuiNavInput_FocusPrev, XINPUT_GAMEPAD_LEFT_SHOULDER); // L1 / LB + MAP_BUTTON(ImGuiNavInput_FocusNext, XINPUT_GAMEPAD_RIGHT_SHOULDER); // R1 / RB + MAP_BUTTON(ImGuiNavInput_TweakSlow, XINPUT_GAMEPAD_LEFT_SHOULDER); // L1 / LB + MAP_BUTTON(ImGuiNavInput_TweakFast, XINPUT_GAMEPAD_RIGHT_SHOULDER); // R1 / RB + MAP_ANALOG(ImGuiNavInput_LStickLeft, gamepad.sThumbLX, -XINPUT_GAMEPAD_LEFT_THUMB_DEADZONE, -32768); + MAP_ANALOG(ImGuiNavInput_LStickRight, gamepad.sThumbLX, +XINPUT_GAMEPAD_LEFT_THUMB_DEADZONE, +32767); + MAP_ANALOG(ImGuiNavInput_LStickUp, gamepad.sThumbLY, +XINPUT_GAMEPAD_LEFT_THUMB_DEADZONE, +32767); + MAP_ANALOG(ImGuiNavInput_LStickDown, gamepad.sThumbLY, -XINPUT_GAMEPAD_LEFT_THUMB_DEADZONE, -32767); + #undef MAP_BUTTON + #undef MAP_ANALOG + } +#endif // #ifndef IMGUI_IMPL_WIN32_DISABLE_GAMEPAD +} + +void ImGui_ImplWin32_NewFrame() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplWin32_Data* bd = ImGui_ImplWin32_GetBackendData(); + IM_ASSERT(bd != NULL && "Did you call ImGui_ImplWin32_Init()?"); + + // Setup display size (every frame to accommodate for window resizing) + RECT rect = { 0, 0, 0, 0 }; + ::GetClientRect(bd->hWnd, &rect); + io.DisplaySize = ImVec2((float)(rect.right - rect.left), (float)(rect.bottom - rect.top)); + + // Setup time step + INT64 current_time = 0; + ::QueryPerformanceCounter((LARGE_INTEGER*)¤t_time); + io.DeltaTime = (float)(current_time - bd->Time) / bd->TicksPerSecond; + bd->Time = current_time; + + // Update OS mouse position + ImGui_ImplWin32_UpdateMousePos(); + + // Update OS mouse cursor with the cursor requested by imgui + ImGuiMouseCursor mouse_cursor = io.MouseDrawCursor ? ImGuiMouseCursor_None : ImGui::GetMouseCursor(); + if (bd->LastMouseCursor != mouse_cursor) + { + bd->LastMouseCursor = mouse_cursor; + ImGui_ImplWin32_UpdateMouseCursor(); + } + + // Update game controllers (if enabled and available) + ImGui_ImplWin32_UpdateGamepads(); +} + +// Allow compilation with old Windows SDK. MinGW doesn't have default _WIN32_WINNT/WINVER versions. +#ifndef WM_MOUSEHWHEEL +#define WM_MOUSEHWHEEL 0x020E +#endif +#ifndef DBT_DEVNODES_CHANGED +#define DBT_DEVNODES_CHANGED 0x0007 +#endif + +// Win32 message handler (process Win32 mouse/keyboard inputs, etc.) +// Call from your application's message handler. +// When implementing your own backend, you can read the io.WantCaptureMouse, io.WantCaptureKeyboard flags to tell if Dear ImGui wants to use your inputs. +// - When io.WantCaptureMouse is true, do not dispatch mouse input data to your main application. +// - When io.WantCaptureKeyboard is true, do not dispatch keyboard input data to your main application. +// Generally you may always pass all inputs to Dear ImGui, and hide them from your application based on those two flags. +// PS: In this Win32 handler, we use the capture API (GetCapture/SetCapture/ReleaseCapture) to be able to read mouse coordinates when dragging mouse outside of our window bounds. +// PS: We treat DBLCLK messages as regular mouse down messages, so this code will work on windows classes that have the CS_DBLCLKS flag set. Our own example app code doesn't set this flag. +#if 0 +// Copy this line into your .cpp file to forward declare the function. +extern IMGUI_IMPL_API LRESULT ImGui_ImplWin32_WndProcHandler(HWND hWnd, UINT msg, WPARAM wParam, LPARAM lParam); +#endif +IMGUI_IMPL_API LRESULT ImGui_ImplWin32_WndProcHandler(HWND hwnd, UINT msg, WPARAM wParam, LPARAM lParam) +{ + if (ImGui::GetCurrentContext() == NULL) + return 0; + + ImGuiIO& io = ImGui::GetIO(); + ImGui_ImplWin32_Data* bd = ImGui_ImplWin32_GetBackendData(); + + switch (msg) + { + case WM_MOUSEMOVE: + // We need to call TrackMouseEvent in order to receive WM_MOUSELEAVE events + bd->MouseHwnd = hwnd; + if (!bd->MouseTracked) + { + TRACKMOUSEEVENT tme = { sizeof(tme), TME_LEAVE, hwnd, 0 }; + ::TrackMouseEvent(&tme); + bd->MouseTracked = true; + } + break; + case WM_MOUSELEAVE: + if (bd->MouseHwnd == hwnd) + bd->MouseHwnd = NULL; + bd->MouseTracked = false; + break; + case WM_LBUTTONDOWN: case WM_LBUTTONDBLCLK: + case WM_RBUTTONDOWN: case WM_RBUTTONDBLCLK: + case WM_MBUTTONDOWN: case WM_MBUTTONDBLCLK: + case WM_XBUTTONDOWN: case WM_XBUTTONDBLCLK: + { + int button = 0; + if (msg == WM_LBUTTONDOWN || msg == WM_LBUTTONDBLCLK) { button = 0; } + if (msg == WM_RBUTTONDOWN || msg == WM_RBUTTONDBLCLK) { button = 1; } + if (msg == WM_MBUTTONDOWN || msg == WM_MBUTTONDBLCLK) { button = 2; } + if (msg == WM_XBUTTONDOWN || msg == WM_XBUTTONDBLCLK) { button = (GET_XBUTTON_WPARAM(wParam) == XBUTTON1) ? 3 : 4; } + if (!ImGui::IsAnyMouseDown() && ::GetCapture() == NULL) + ::SetCapture(hwnd); + io.MouseDown[button] = true; + return 0; + } + case WM_LBUTTONUP: + case WM_RBUTTONUP: + case WM_MBUTTONUP: + case WM_XBUTTONUP: + { + int button = 0; + if (msg == WM_LBUTTONUP) { button = 0; } + if (msg == WM_RBUTTONUP) { button = 1; } + if (msg == WM_MBUTTONUP) { button = 2; } + if (msg == WM_XBUTTONUP) { button = (GET_XBUTTON_WPARAM(wParam) == XBUTTON1) ? 3 : 4; } + io.MouseDown[button] = false; + if (!ImGui::IsAnyMouseDown() && ::GetCapture() == hwnd) + ::ReleaseCapture(); + return 0; + } + case WM_MOUSEWHEEL: + io.MouseWheel += (float)GET_WHEEL_DELTA_WPARAM(wParam) / (float)WHEEL_DELTA; + return 0; + case WM_MOUSEHWHEEL: + io.MouseWheelH += (float)GET_WHEEL_DELTA_WPARAM(wParam) / (float)WHEEL_DELTA; + return 0; + case WM_KEYDOWN: + case WM_KEYUP: + case WM_SYSKEYDOWN: + case WM_SYSKEYUP: + { + bool down = (msg == WM_KEYDOWN || msg == WM_SYSKEYDOWN); + if (wParam < 256) + io.KeysDown[wParam] = down; + if (wParam == VK_CONTROL) + io.KeyCtrl = down; + if (wParam == VK_SHIFT) + io.KeyShift = down; + if (wParam == VK_MENU) + io.KeyAlt = down; + return 0; + } + case WM_SETFOCUS: + case WM_KILLFOCUS: + io.AddFocusEvent(msg == WM_SETFOCUS); + return 0; + case WM_CHAR: + // You can also use ToAscii()+GetKeyboardState() to retrieve characters. + if (wParam > 0 && wParam < 0x10000) + io.AddInputCharacterUTF16((unsigned short)wParam); + return 0; + case WM_SETCURSOR: + if (LOWORD(lParam) == HTCLIENT && ImGui_ImplWin32_UpdateMouseCursor()) + return 1; + return 0; + case WM_DEVICECHANGE: + if ((UINT)wParam == DBT_DEVNODES_CHANGED) + bd->WantUpdateHasGamepad = true; + return 0; + } + return 0; +} + + +//-------------------------------------------------------------------------------------------------------- +// DPI-related helpers (optional) +//-------------------------------------------------------------------------------------------------------- +// - Use to enable DPI awareness without having to create an application manifest. +// - Your own app may already do this via a manifest or explicit calls. This is mostly useful for our examples/ apps. +// - In theory we could call simple functions from Windows SDK such as SetProcessDPIAware(), SetProcessDpiAwareness(), etc. +// but most of the functions provided by Microsoft require Windows 8.1/10+ SDK at compile time and Windows 8/10+ at runtime, +// neither we want to require the user to have. So we dynamically select and load those functions to avoid dependencies. +//--------------------------------------------------------------------------------------------------------- +// This is the scheme successfully used by GLFW (from which we borrowed some of the code) and other apps aiming to be highly portable. +// ImGui_ImplWin32_EnableDpiAwareness() is just a helper called by main.cpp, we don't call it automatically. +// If you are trying to implement your own backend for your own engine, you may ignore that noise. +//--------------------------------------------------------------------------------------------------------- + +// Perform our own check with RtlVerifyVersionInfo() instead of using functions from as they +// require a manifest to be functional for checks above 8.1. See https://github.com/ocornut/imgui/issues/4200 +static BOOL _IsWindowsVersionOrGreater(WORD major, WORD minor, WORD) +{ + typedef LONG(WINAPI* PFN_RtlVerifyVersionInfo)(OSVERSIONINFOEXW*, ULONG, ULONGLONG); + static PFN_RtlVerifyVersionInfo RtlVerifyVersionInfoFn = NULL; + if (RtlVerifyVersionInfoFn == NULL) + if (HMODULE ntdllModule = ::GetModuleHandleA("ntdll.dll")) + RtlVerifyVersionInfoFn = (PFN_RtlVerifyVersionInfo)GetProcAddress(ntdllModule, "RtlVerifyVersionInfo"); + if (RtlVerifyVersionInfoFn == NULL) + return FALSE; + + RTL_OSVERSIONINFOEXW versionInfo = { }; + ULONGLONG conditionMask = 0; + versionInfo.dwOSVersionInfoSize = sizeof(RTL_OSVERSIONINFOEXW); + versionInfo.dwMajorVersion = major; + versionInfo.dwMinorVersion = minor; + VER_SET_CONDITION(conditionMask, VER_MAJORVERSION, VER_GREATER_EQUAL); + VER_SET_CONDITION(conditionMask, VER_MINORVERSION, VER_GREATER_EQUAL); + return (RtlVerifyVersionInfoFn(&versionInfo, VER_MAJORVERSION | VER_MINORVERSION, conditionMask) == 0) ? TRUE : FALSE; +} + +#define _IsWindowsVistaOrGreater() _IsWindowsVersionOrGreater(HIBYTE(0x0600), LOBYTE(0x0600), 0) // _WIN32_WINNT_VISTA +#define _IsWindows8OrGreater() _IsWindowsVersionOrGreater(HIBYTE(0x0602), LOBYTE(0x0602), 0) // _WIN32_WINNT_WIN8 +#define _IsWindows8Point1OrGreater() _IsWindowsVersionOrGreater(HIBYTE(0x0603), LOBYTE(0x0603), 0) // _WIN32_WINNT_WINBLUE +#define _IsWindows10OrGreater() _IsWindowsVersionOrGreater(HIBYTE(0x0A00), LOBYTE(0x0A00), 0) // _WIN32_WINNT_WINTHRESHOLD / _WIN32_WINNT_WIN10 + +#ifndef DPI_ENUMS_DECLARED +typedef enum { PROCESS_DPI_UNAWARE = 0, PROCESS_SYSTEM_DPI_AWARE = 1, PROCESS_PER_MONITOR_DPI_AWARE = 2 } PROCESS_DPI_AWARENESS; +typedef enum { MDT_EFFECTIVE_DPI = 0, MDT_ANGULAR_DPI = 1, MDT_RAW_DPI = 2, MDT_DEFAULT = MDT_EFFECTIVE_DPI } MONITOR_DPI_TYPE; +#endif +#ifndef _DPI_AWARENESS_CONTEXTS_ +DECLARE_HANDLE(DPI_AWARENESS_CONTEXT); +#define DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE (DPI_AWARENESS_CONTEXT)-3 +#endif +#ifndef DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE_V2 +#define DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE_V2 (DPI_AWARENESS_CONTEXT)-4 +#endif +typedef HRESULT(WINAPI* PFN_SetProcessDpiAwareness)(PROCESS_DPI_AWARENESS); // Shcore.lib + dll, Windows 8.1+ +typedef HRESULT(WINAPI* PFN_GetDpiForMonitor)(HMONITOR, MONITOR_DPI_TYPE, UINT*, UINT*); // Shcore.lib + dll, Windows 8.1+ +typedef DPI_AWARENESS_CONTEXT(WINAPI* PFN_SetThreadDpiAwarenessContext)(DPI_AWARENESS_CONTEXT); // User32.lib + dll, Windows 10 v1607+ (Creators Update) + +// Helper function to enable DPI awareness without setting up a manifest +void ImGui_ImplWin32_EnableDpiAwareness() +{ + if (_IsWindows10OrGreater()) + { + static HINSTANCE user32_dll = ::LoadLibraryA("user32.dll"); // Reference counted per-process + if (PFN_SetThreadDpiAwarenessContext SetThreadDpiAwarenessContextFn = (PFN_SetThreadDpiAwarenessContext)::GetProcAddress(user32_dll, "SetThreadDpiAwarenessContext")) + { + SetThreadDpiAwarenessContextFn(DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE_V2); + return; + } + } + if (_IsWindows8Point1OrGreater()) + { + static HINSTANCE shcore_dll = ::LoadLibraryA("shcore.dll"); // Reference counted per-process + if (PFN_SetProcessDpiAwareness SetProcessDpiAwarenessFn = (PFN_SetProcessDpiAwareness)::GetProcAddress(shcore_dll, "SetProcessDpiAwareness")) + { + SetProcessDpiAwarenessFn(PROCESS_PER_MONITOR_DPI_AWARE); + return; + } + } +#if _WIN32_WINNT >= 0x0600 + ::SetProcessDPIAware(); +#endif +} + +#if defined(_MSC_VER) && !defined(NOGDI) +#pragma comment(lib, "gdi32") // Link with gdi32.lib for GetDeviceCaps(). MinGW will require linking with '-lgdi32' +#endif + +float ImGui_ImplWin32_GetDpiScaleForMonitor(void* monitor) +{ + UINT xdpi = 96, ydpi = 96; + if (_IsWindows8Point1OrGreater()) + { + static HINSTANCE shcore_dll = ::LoadLibraryA("shcore.dll"); // Reference counted per-process + static PFN_GetDpiForMonitor GetDpiForMonitorFn = NULL; + if (GetDpiForMonitorFn == NULL && shcore_dll != NULL) + GetDpiForMonitorFn = (PFN_GetDpiForMonitor)::GetProcAddress(shcore_dll, "GetDpiForMonitor"); + if (GetDpiForMonitorFn != NULL) + { + GetDpiForMonitorFn((HMONITOR)monitor, MDT_EFFECTIVE_DPI, &xdpi, &ydpi); + IM_ASSERT(xdpi == ydpi); // Please contact me if you hit this assert! + return xdpi / 96.0f; + } + } +#ifndef NOGDI + const HDC dc = ::GetDC(NULL); + xdpi = ::GetDeviceCaps(dc, LOGPIXELSX); + ydpi = ::GetDeviceCaps(dc, LOGPIXELSY); + IM_ASSERT(xdpi == ydpi); // Please contact me if you hit this assert! + ::ReleaseDC(NULL, dc); +#endif + return xdpi / 96.0f; +} + +float ImGui_ImplWin32_GetDpiScaleForHwnd(void* hwnd) +{ + HMONITOR monitor = ::MonitorFromWindow((HWND)hwnd, MONITOR_DEFAULTTONEAREST); + return ImGui_ImplWin32_GetDpiScaleForMonitor(monitor); +} + +//--------------------------------------------------------------------------------------------------------- +// Transparency related helpers (optional) +//-------------------------------------------------------------------------------------------------------- + +#if defined(_MSC_VER) +#pragma comment(lib, "dwmapi") // Link with dwmapi.lib. MinGW will require linking with '-ldwmapi' +#endif + +// [experimental] +// Borrowed from GLFW's function updateFramebufferTransparency() in src/win32_window.c +// (the Dwm* functions are Vista era functions but we are borrowing logic from GLFW) +void ImGui_ImplWin32_EnableAlphaCompositing(void* hwnd) +{ + if (!_IsWindowsVistaOrGreater()) + return; + + BOOL composition; + if (FAILED(::DwmIsCompositionEnabled(&composition)) || !composition) + return; + + BOOL opaque; + DWORD color; + if (_IsWindows8OrGreater() || (SUCCEEDED(::DwmGetColorizationColor(&color, &opaque)) && !opaque)) + { + HRGN region = ::CreateRectRgn(0, 0, -1, -1); + DWM_BLURBEHIND bb = {}; + bb.dwFlags = DWM_BB_ENABLE | DWM_BB_BLURREGION; + bb.hRgnBlur = region; + bb.fEnable = TRUE; + ::DwmEnableBlurBehindWindow((HWND)hwnd, &bb); + ::DeleteObject(region); + } + else + { + DWM_BLURBEHIND bb = {}; + bb.dwFlags = DWM_BB_ENABLE; + ::DwmEnableBlurBehindWindow((HWND)hwnd, &bb); + } +} + +//--------------------------------------------------------------------------------------------------------- diff --git a/source/editor/imgui/backends/imgui_impl_win32.h b/source/editor/imgui/backends/imgui_impl_win32.h new file mode 100644 index 0000000..768fe16 --- /dev/null +++ b/source/editor/imgui/backends/imgui_impl_win32.h @@ -0,0 +1,42 @@ +// dear imgui: Platform Backend for Windows (standard windows API for 32 and 64 bits applications) +// This needs to be used along with a Renderer (e.g. DirectX11, OpenGL3, Vulkan..) + +// Implemented features: +// [X] Platform: Clipboard support (for Win32 this is actually part of core dear imgui) +// [X] Platform: Mouse cursor shape and visibility. Disable with 'io.ConfigFlags |= ImGuiConfigFlags_NoMouseCursorChange'. +// [X] Platform: Keyboard arrays indexed using VK_* Virtual Key Codes, e.g. ImGui::IsKeyPressed(VK_SPACE). +// [X] Platform: Gamepad support. Enabled with 'io.ConfigFlags |= ImGuiConfigFlags_NavEnableGamepad'. + +// You can use unmodified imgui_impl_* files in your project. See examples/ folder for examples of using this. +// Prefer including the entire imgui/ repository into your project (either as a copy or as a submodule), and only build the backends you need. +// If you are new to Dear ImGui, read documentation from the docs/ folder + read the top of imgui.cpp. +// Read online: https://github.com/ocornut/imgui/tree/master/docs + +#pragma once +#include "imgui.h" // IMGUI_IMPL_API + +IMGUI_IMPL_API bool ImGui_ImplWin32_Init(void* hwnd); +IMGUI_IMPL_API void ImGui_ImplWin32_Shutdown(); +IMGUI_IMPL_API void ImGui_ImplWin32_NewFrame(); + +// Win32 message handler your application need to call. +// - Intentionally commented out in a '#if 0' block to avoid dragging dependencies on from this helper. +// - You should COPY the line below into your .cpp code to forward declare the function and then you can call it. +#if 0 +extern IMGUI_IMPL_API LRESULT ImGui_ImplWin32_WndProcHandler(HWND hWnd, UINT msg, WPARAM wParam, LPARAM lParam); +#endif + +// DPI-related helpers (optional) +// - Use to enable DPI awareness without having to create an application manifest. +// - Your own app may already do this via a manifest or explicit calls. This is mostly useful for our examples/ apps. +// - In theory we could call simple functions from Windows SDK such as SetProcessDPIAware(), SetProcessDpiAwareness(), etc. +// but most of the functions provided by Microsoft require Windows 8.1/10+ SDK at compile time and Windows 8/10+ at runtime, +// neither we want to require the user to have. So we dynamically select and load those functions to avoid dependencies. +IMGUI_IMPL_API void ImGui_ImplWin32_EnableDpiAwareness(); +IMGUI_IMPL_API float ImGui_ImplWin32_GetDpiScaleForHwnd(void* hwnd); // HWND hwnd +IMGUI_IMPL_API float ImGui_ImplWin32_GetDpiScaleForMonitor(void* monitor); // HMONITOR monitor + +// Transparency related helpers (optional) [experimental] +// - Use to enable alpha compositing transparency with the desktop. +// - Use together with e.g. clearing your framebuffer with zero-alpha. +IMGUI_IMPL_API void ImGui_ImplWin32_EnableAlphaCompositing(void* hwnd); // HWND hwnd diff --git a/source/editor/imgui/backends/vulkan/generate_spv.sh b/source/editor/imgui/backends/vulkan/generate_spv.sh new file mode 100755 index 0000000..948ef77 --- /dev/null +++ b/source/editor/imgui/backends/vulkan/generate_spv.sh @@ -0,0 +1,6 @@ +#!/bin/bash +## -V: create SPIR-V binary +## -x: save binary output as text-based 32-bit hexadecimal numbers +## -o: output file +glslangValidator -V -x -o glsl_shader.frag.u32 glsl_shader.frag +glslangValidator -V -x -o glsl_shader.vert.u32 glsl_shader.vert diff --git a/source/editor/imgui/backends/vulkan/glsl_shader.frag b/source/editor/imgui/backends/vulkan/glsl_shader.frag new file mode 100644 index 0000000..ce7e6f7 --- /dev/null +++ b/source/editor/imgui/backends/vulkan/glsl_shader.frag @@ -0,0 +1,14 @@ +#version 450 core +layout(location = 0) out vec4 fColor; + +layout(set=0, binding=0) uniform sampler2D sTexture; + +layout(location = 0) in struct { + vec4 Color; + vec2 UV; +} In; + +void main() +{ + fColor = In.Color * texture(sTexture, In.UV.st); +} diff --git a/source/editor/imgui/backends/vulkan/glsl_shader.vert b/source/editor/imgui/backends/vulkan/glsl_shader.vert new file mode 100644 index 0000000..9425365 --- /dev/null +++ b/source/editor/imgui/backends/vulkan/glsl_shader.vert @@ -0,0 +1,25 @@ +#version 450 core +layout(location = 0) in vec2 aPos; +layout(location = 1) in vec2 aUV; +layout(location = 2) in vec4 aColor; + +layout(push_constant) uniform uPushConstant { + vec2 uScale; + vec2 uTranslate; +} pc; + +out gl_PerVertex { + vec4 gl_Position; +}; + +layout(location = 0) out struct { + vec4 Color; + vec2 UV; +} Out; + +void main() +{ + Out.Color = aColor; + Out.UV = aUV; + gl_Position = vec4(aPos * pc.uScale + pc.uTranslate, 0, 1); +} diff --git a/source/editor/imgui/imconfig.h b/source/editor/imgui/imconfig.h new file mode 100644 index 0000000..a0c86ca --- /dev/null +++ b/source/editor/imgui/imconfig.h @@ -0,0 +1,123 @@ +//----------------------------------------------------------------------------- +// COMPILE-TIME OPTIONS FOR DEAR IMGUI +// Runtime options (clipboard callbacks, enabling various features, etc.) can generally be set via the ImGuiIO structure. +// You can use ImGui::SetAllocatorFunctions() before calling ImGui::CreateContext() to rewire memory allocation functions. +//----------------------------------------------------------------------------- +// A) You may edit imconfig.h (and not overwrite it when updating Dear ImGui, or maintain a patch/rebased branch with your modifications to it) +// B) or '#define IMGUI_USER_CONFIG "my_imgui_config.h"' in your project and then add directives in your own file without touching this template. +//----------------------------------------------------------------------------- +// You need to make sure that configuration settings are defined consistently _everywhere_ Dear ImGui is used, which include the imgui*.cpp +// files but also _any_ of your code that uses Dear ImGui. This is because some compile-time options have an affect on data structures. +// Defining those options in imconfig.h will ensure every compilation unit gets to see the same data structure layouts. +// Call IMGUI_CHECKVERSION() from your .cpp files to verify that the data structures your files are using are matching the ones imgui.cpp is using. +//----------------------------------------------------------------------------- + +#pragma once + +//---- Define assertion handler. Defaults to calling assert(). +// If your macro uses multiple statements, make sure is enclosed in a 'do { .. } while (0)' block so it can be used as a single statement. +//#define IM_ASSERT(_EXPR) MyAssert(_EXPR) +//#define IM_ASSERT(_EXPR) ((void)(_EXPR)) // Disable asserts + +//---- Define attributes of all API symbols declarations, e.g. for DLL under Windows +// Using Dear ImGui via a shared library is not recommended, because of function call overhead and because we don't guarantee backward nor forward ABI compatibility. +// DLL users: heaps and globals are not shared across DLL boundaries! You will need to call SetCurrentContext() + SetAllocatorFunctions() +// for each static/DLL boundary you are calling from. Read "Context and Memory Allocators" section of imgui.cpp for more details. +//#define IMGUI_API __declspec( dllexport ) +//#define IMGUI_API __declspec( dllimport ) + +//---- Don't define obsolete functions/enums/behaviors. Consider enabling from time to time after updating to avoid using soon-to-be obsolete function/names. +//#define IMGUI_DISABLE_OBSOLETE_FUNCTIONS + +//---- Disable all of Dear ImGui or don't implement standard windows. +// It is very strongly recommended to NOT disable the demo windows during development. Please read comments in imgui_demo.cpp. +//#define IMGUI_DISABLE // Disable everything: all headers and source files will be empty. +//#define IMGUI_DISABLE_DEMO_WINDOWS // Disable demo windows: ShowDemoWindow()/ShowStyleEditor() will be empty. Not recommended. +//#define IMGUI_DISABLE_METRICS_WINDOW // Disable metrics/debugger window: ShowMetricsWindow() will be empty. + +//---- Don't implement some functions to reduce linkage requirements. +//#define IMGUI_DISABLE_WIN32_DEFAULT_CLIPBOARD_FUNCTIONS // [Win32] Don't implement default clipboard handler. Won't use and link with OpenClipboard/GetClipboardData/CloseClipboard etc. (user32.lib/.a, kernel32.lib/.a) +//#define IMGUI_ENABLE_WIN32_DEFAULT_IME_FUNCTIONS // [Win32] [Default with Visual Studio] Implement default IME handler (require imm32.lib/.a, auto-link for Visual Studio, -limm32 on command-line for MinGW) +//#define IMGUI_DISABLE_WIN32_DEFAULT_IME_FUNCTIONS // [Win32] [Default with non-Visual Studio compilers] Don't implement default IME handler (won't require imm32.lib/.a) +//#define IMGUI_DISABLE_WIN32_FUNCTIONS // [Win32] Won't use and link with any Win32 function (clipboard, ime). +//#define IMGUI_ENABLE_OSX_DEFAULT_CLIPBOARD_FUNCTIONS // [OSX] Implement default OSX clipboard handler (need to link with '-framework ApplicationServices', this is why this is not the default). +//#define IMGUI_DISABLE_DEFAULT_FORMAT_FUNCTIONS // Don't implement ImFormatString/ImFormatStringV so you can implement them yourself (e.g. if you don't want to link with vsnprintf) +//#define IMGUI_DISABLE_DEFAULT_MATH_FUNCTIONS // Don't implement ImFabs/ImSqrt/ImPow/ImFmod/ImCos/ImSin/ImAcos/ImAtan2 so you can implement them yourself. +//#define IMGUI_DISABLE_FILE_FUNCTIONS // Don't implement ImFileOpen/ImFileClose/ImFileRead/ImFileWrite and ImFileHandle at all (replace them with dummies) +//#define IMGUI_DISABLE_DEFAULT_FILE_FUNCTIONS // Don't implement ImFileOpen/ImFileClose/ImFileRead/ImFileWrite and ImFileHandle so you can implement them yourself if you don't want to link with fopen/fclose/fread/fwrite. This will also disable the LogToTTY() function. +//#define IMGUI_DISABLE_DEFAULT_ALLOCATORS // Don't implement default allocators calling malloc()/free() to avoid linking with them. You will need to call ImGui::SetAllocatorFunctions(). +//#define IMGUI_DISABLE_SSE // Disable use of SSE intrinsics even if available + +//---- Include imgui_user.h at the end of imgui.h as a convenience +//#define IMGUI_INCLUDE_IMGUI_USER_H + +//---- Pack colors to BGRA8 instead of RGBA8 (to avoid converting from one to another) +//#define IMGUI_USE_BGRA_PACKED_COLOR + +//---- Use 32-bit for ImWchar (default is 16-bit) to support unicode planes 1-16. (e.g. point beyond 0xFFFF like emoticons, dingbats, symbols, shapes, ancient languages, etc...) +//#define IMGUI_USE_WCHAR32 + +//---- Avoid multiple STB libraries implementations, or redefine path/filenames to prioritize another version +// By default the embedded implementations are declared static and not available outside of Dear ImGui sources files. +//#define IMGUI_STB_TRUETYPE_FILENAME "my_folder/stb_truetype.h" +//#define IMGUI_STB_RECT_PACK_FILENAME "my_folder/stb_rect_pack.h" +//#define IMGUI_DISABLE_STB_TRUETYPE_IMPLEMENTATION +//#define IMGUI_DISABLE_STB_RECT_PACK_IMPLEMENTATION + +//---- Use stb_printf's faster implementation of vsnprintf instead of the one from libc (unless IMGUI_DISABLE_DEFAULT_FORMAT_FUNCTIONS is defined) +// Requires 'stb_sprintf.h' to be available in the include path. Compatibility checks of arguments and formats done by clang and GCC will be disabled in order to support the extra formats provided by STB sprintf. +// #define IMGUI_USE_STB_SPRINTF + +//---- Use FreeType to build and rasterize the font atlas (instead of stb_truetype which is embedded by default in Dear ImGui) +// Requires FreeType headers to be available in the include path. Requires program to be compiled with 'misc/freetype/imgui_freetype.cpp' (in this repository) + the FreeType library (not provided). +// On Windows you may use vcpkg with 'vcpkg install freetype --triplet=x64-windows' + 'vcpkg integrate install'. +//#define IMGUI_ENABLE_FREETYPE + +//---- Use stb_truetype to build and rasterize the font atlas (default) +// The only purpose of this define is if you want force compilation of the stb_truetype backend ALONG with the FreeType backend. +//#define IMGUI_ENABLE_STB_TRUETYPE + +//---- Define constructor and implicit cast operators to convert back<>forth between your math types and ImVec2/ImVec4. +// This will be inlined as part of ImVec2 and ImVec4 class declarations. +/* +#define IM_VEC2_CLASS_EXTRA \ + ImVec2(const MyVec2& f) { x = f.x; y = f.y; } \ + operator MyVec2() const { return MyVec2(x,y); } + +#define IM_VEC4_CLASS_EXTRA \ + ImVec4(const MyVec4& f) { x = f.x; y = f.y; z = f.z; w = f.w; } \ + operator MyVec4() const { return MyVec4(x,y,z,w); } +*/ + +//---- Use 32-bit vertex indices (default is 16-bit) is one way to allow large meshes with more than 64K vertices. +// Your renderer backend will need to support it (most example renderer backends support both 16/32-bit indices). +// Another way to allow large meshes while keeping 16-bit indices is to handle ImDrawCmd::VtxOffset in your renderer. +// Read about ImGuiBackendFlags_RendererHasVtxOffset for details. +//#define ImDrawIdx unsigned int + +//---- Override ImDrawCallback signature (will need to modify renderer backends accordingly) +//struct ImDrawList; +//struct ImDrawCmd; +//typedef void (*MyImDrawCallback)(const ImDrawList* draw_list, const ImDrawCmd* cmd, void* my_renderer_user_data); +//#define ImDrawCallback MyImDrawCallback + +//---- Debug Tools: Macro to break in Debugger +// (use 'Metrics->Tools->Item Picker' to pick widgets with the mouse and break into them for easy debugging.) +//#define IM_DEBUG_BREAK IM_ASSERT(0) +//#define IM_DEBUG_BREAK __debugbreak() + +//---- Debug Tools: Have the Item Picker break in the ItemAdd() function instead of ItemHoverable(), +// (which comes earlier in the code, will catch a few extra items, allow picking items other than Hovered one.) +// This adds a small runtime cost which is why it is not enabled by default. +//#define IMGUI_DEBUG_TOOL_ITEM_PICKER_EX + +//---- Debug Tools: Enable slower asserts +//#define IMGUI_DEBUG_PARANOID + +//---- Tip: You can add extra functions within the ImGui:: namespace, here or in your own headers files. +/* +namespace ImGui +{ + void MyFunction(const char* name, const MyMatrix44& v); +} +*/ diff --git a/source/editor/imgui/imgui.cpp b/source/editor/imgui/imgui.cpp new file mode 100644 index 0000000..0a72737 --- /dev/null +++ b/source/editor/imgui/imgui.cpp @@ -0,0 +1,11936 @@ +// dear imgui, v1.85 WIP +// (main code and documentation) + +// Help: +// - Read FAQ at http://dearimgui.org/faq +// - Newcomers, read 'Programmer guide' below for notes on how to setup Dear ImGui in your codebase. +// - Call and read ImGui::ShowDemoWindow() in imgui_demo.cpp. All applications in examples/ are doing that. +// Read imgui.cpp for details, links and comments. + +// Resources: +// - FAQ http://dearimgui.org/faq +// - Homepage & latest https://github.com/ocornut/imgui +// - Releases & changelog https://github.com/ocornut/imgui/releases +// - Gallery https://github.com/ocornut/imgui/issues/4451 (please post your screenshots/video there!) +// - Wiki https://github.com/ocornut/imgui/wiki (lots of good stuff there) +// - Glossary https://github.com/ocornut/imgui/wiki/Glossary +// - Issues & support https://github.com/ocornut/imgui/issues + +// Getting Started? +// - For first-time users having issues compiling/linking/running or issues loading fonts: +// please post in https://github.com/ocornut/imgui/discussions if you cannot find a solution in resources above. + +// Developed by Omar Cornut and every direct or indirect contributors to the GitHub. +// See LICENSE.txt for copyright and licensing details (standard MIT License). +// This library is free but needs your support to sustain development and maintenance. +// Businesses: you can support continued development via invoiced technical support, maintenance and sponsoring contracts. Please reach out to "contact AT dearimgui.com". +// Individuals: you can support continued development via donations. See docs/README or web page. + +// It is recommended that you don't modify imgui.cpp! It will become difficult for you to update the library. +// Note that 'ImGui::' being a namespace, you can add functions into the namespace from your own source files, without +// modifying imgui.h or imgui.cpp. You may include imgui_internal.h to access internal data structures, but it doesn't +// come with any guarantee of forward compatibility. Discussing your changes on the GitHub Issue Tracker may lead you +// to a better solution or official support for them. + +/* + +Index of this file: + +DOCUMENTATION + +- MISSION STATEMENT +- END-USER GUIDE +- PROGRAMMER GUIDE + - READ FIRST + - HOW TO UPDATE TO A NEWER VERSION OF DEAR IMGUI + - GETTING STARTED WITH INTEGRATING DEAR IMGUI IN YOUR CODE/ENGINE + - HOW A SIMPLE APPLICATION MAY LOOK LIKE + - HOW A SIMPLE RENDERING FUNCTION MAY LOOK LIKE + - USING GAMEPAD/KEYBOARD NAVIGATION CONTROLS +- API BREAKING CHANGES (read me when you update!) +- FREQUENTLY ASKED QUESTIONS (FAQ) + - Read all answers online: https://www.dearimgui.org/faq, or in docs/FAQ.md (with a Markdown viewer) + +CODE +(search for "[SECTION]" in the code to find them) + +// [SECTION] INCLUDES +// [SECTION] FORWARD DECLARATIONS +// [SECTION] CONTEXT AND MEMORY ALLOCATORS +// [SECTION] USER FACING STRUCTURES (ImGuiStyle, ImGuiIO) +// [SECTION] MISC HELPERS/UTILITIES (Geometry functions) +// [SECTION] MISC HELPERS/UTILITIES (String, Format, Hash functions) +// [SECTION] MISC HELPERS/UTILITIES (File functions) +// [SECTION] MISC HELPERS/UTILITIES (ImText* functions) +// [SECTION] MISC HELPERS/UTILITIES (Color functions) +// [SECTION] ImGuiStorage +// [SECTION] ImGuiTextFilter +// [SECTION] ImGuiTextBuffer +// [SECTION] ImGuiListClipper +// [SECTION] STYLING +// [SECTION] RENDER HELPERS +// [SECTION] MAIN CODE (most of the code! lots of stuff, needs tidying up!) +// [SECTION] ERROR CHECKING +// [SECTION] LAYOUT +// [SECTION] SCROLLING +// [SECTION] TOOLTIPS +// [SECTION] POPUPS +// [SECTION] KEYBOARD/GAMEPAD NAVIGATION +// [SECTION] DRAG AND DROP +// [SECTION] LOGGING/CAPTURING +// [SECTION] SETTINGS +// [SECTION] VIEWPORTS +// [SECTION] PLATFORM DEPENDENT HELPERS +// [SECTION] METRICS/DEBUGGER WINDOW + +*/ + +//----------------------------------------------------------------------------- +// DOCUMENTATION +//----------------------------------------------------------------------------- + +/* + + MISSION STATEMENT + ================= + + - Easy to use to create code-driven and data-driven tools. + - Easy to use to create ad hoc short-lived tools and long-lived, more elaborate tools. + - Easy to hack and improve. + - Minimize setup and maintenance. + - Minimize state storage on user side. + - Portable, minimize dependencies, run on target (consoles, phones, etc.). + - Efficient runtime and memory consumption. + + Designed for developers and content-creators, not the typical end-user! Some of the current weaknesses includes: + + - Doesn't look fancy, doesn't animate. + - Limited layout features, intricate layouts are typically crafted in code. + + + END-USER GUIDE + ============== + + - Double-click on title bar to collapse window. + - Click upper right corner to close a window, available when 'bool* p_open' is passed to ImGui::Begin(). + - Click and drag on lower right corner to resize window (double-click to auto fit window to its contents). + - Click and drag on any empty space to move window. + - TAB/SHIFT+TAB to cycle through keyboard editable fields. + - CTRL+Click on a slider or drag box to input value as text. + - Use mouse wheel to scroll. + - Text editor: + - Hold SHIFT or use mouse to select text. + - CTRL+Left/Right to word jump. + - CTRL+Shift+Left/Right to select words. + - CTRL+A our Double-Click to select all. + - CTRL+X,CTRL+C,CTRL+V to use OS clipboard/ + - CTRL+Z,CTRL+Y to undo/redo. + - ESCAPE to revert text to its original value. + - You can apply arithmetic operators +,*,/ on numerical values. Use +- to subtract (because - would set a negative value!) + - Controls are automatically adjusted for OSX to match standard OSX text editing operations. + - General Keyboard controls: enable with ImGuiConfigFlags_NavEnableKeyboard. + - General Gamepad controls: enable with ImGuiConfigFlags_NavEnableGamepad. See suggested mappings in imgui.h ImGuiNavInput_ + download PNG/PSD at http://dearimgui.org/controls_sheets + + + PROGRAMMER GUIDE + ================ + + READ FIRST + ---------- + - Remember to check the wonderful Wiki (https://github.com/ocornut/imgui/wiki) + - Your code creates the UI, if your code doesn't run the UI is gone! The UI can be highly dynamic, there are no construction or + destruction steps, less superfluous data retention on your side, less state duplication, less state synchronization, fewer bugs. + - Call and read ImGui::ShowDemoWindow() for demo code demonstrating most features. + - The library is designed to be built from sources. Avoid pre-compiled binaries and packaged versions. See imconfig.h to configure your build. + - Dear ImGui is an implementation of the IMGUI paradigm (immediate-mode graphical user interface, a term coined by Casey Muratori). + You can learn about IMGUI principles at http://www.johno.se/book/imgui.html, http://mollyrocket.com/861 & more links in Wiki. + - Dear ImGui is a "single pass" rasterizing implementation of the IMGUI paradigm, aimed at ease of use and high-performances. + For every application frame, your UI code will be called only once. This is in contrast to e.g. Unity's implementation of an IMGUI, + where the UI code is called multiple times ("multiple passes") from a single entry point. There are pros and cons to both approaches. + - Our origin is on the top-left. In axis aligned bounding boxes, Min = top-left, Max = bottom-right. + - This codebase is also optimized to yield decent performances with typical "Debug" builds settings. + - Please make sure you have asserts enabled (IM_ASSERT redirects to assert() by default, but can be redirected). + If you get an assert, read the messages and comments around the assert. + - C++: this is a very C-ish codebase: we don't rely on C++11, we don't include any C++ headers, and ImGui:: is a namespace. + - C++: ImVec2/ImVec4 do not expose math operators by default, because it is expected that you use your own math types. + See FAQ "How can I use my own math types instead of ImVec2/ImVec4?" for details about setting up imconfig.h for that. + However, imgui_internal.h can optionally export math operators for ImVec2/ImVec4, which we use in this codebase. + - C++: pay attention that ImVector<> manipulates plain-old-data and does not honor construction/destruction (avoid using it in your code!). + + + HOW TO UPDATE TO A NEWER VERSION OF DEAR IMGUI + ---------------------------------------------- + - Overwrite all the sources files except for imconfig.h (if you have modified your copy of imconfig.h) + - Or maintain your own branch where you have imconfig.h modified as a top-most commit which you can regularly rebase over "master". + - You can also use '#define IMGUI_USER_CONFIG "my_config_file.h" to redirect configuration to your own file. + - Read the "API BREAKING CHANGES" section (below). This is where we list occasional API breaking changes. + If a function/type has been renamed / or marked obsolete, try to fix the name in your code before it is permanently removed + from the public API. If you have a problem with a missing function/symbols, search for its name in the code, there will + likely be a comment about it. Please report any issue to the GitHub page! + - To find out usage of old API, you can add '#define IMGUI_DISABLE_OBSOLETE_FUNCTIONS' in your configuration file. + - Try to keep your copy of Dear ImGui reasonably up to date. + + + GETTING STARTED WITH INTEGRATING DEAR IMGUI IN YOUR CODE/ENGINE + --------------------------------------------------------------- + - Run and study the examples and demo in imgui_demo.cpp to get acquainted with the library. + - In the majority of cases you should be able to use unmodified backends files available in the backends/ folder. + - Add the Dear ImGui source files + selected backend source files to your projects or using your preferred build system. + It is recommended you build and statically link the .cpp files as part of your project and NOT as a shared library (DLL). + - You can later customize the imconfig.h file to tweak some compile-time behavior, such as integrating Dear ImGui types with your own maths types. + - When using Dear ImGui, your programming IDE is your friend: follow the declaration of variables, functions and types to find comments about them. + - Dear ImGui never touches or knows about your GPU state. The only function that knows about GPU is the draw function that you provide. + Effectively it means you can create widgets at any time in your code, regardless of considerations of being in "update" vs "render" + phases of your own application. All rendering information is stored into command-lists that you will retrieve after calling ImGui::Render(). + - Refer to the backends and demo applications in the examples/ folder for instruction on how to setup your code. + - If you are running over a standard OS with a common graphics API, you should be able to use unmodified imgui_impl_*** files from the examples/ folder. + + + HOW A SIMPLE APPLICATION MAY LOOK LIKE + -------------------------------------- + EXHIBIT 1: USING THE EXAMPLE BACKENDS (= imgui_impl_XXX.cpp files from the backends/ folder). + The sub-folders in examples/ contain examples applications following this structure. + + // Application init: create a dear imgui context, setup some options, load fonts + ImGui::CreateContext(); + ImGuiIO& io = ImGui::GetIO(); + // TODO: Set optional io.ConfigFlags values, e.g. 'io.ConfigFlags |= ImGuiConfigFlags_NavEnableKeyboard' to enable keyboard controls. + // TODO: Fill optional fields of the io structure later. + // TODO: Load TTF/OTF fonts if you don't want to use the default font. + + // Initialize helper Platform and Renderer backends (here we are using imgui_impl_win32.cpp and imgui_impl_dx11.cpp) + ImGui_ImplWin32_Init(hwnd); + ImGui_ImplDX11_Init(g_pd3dDevice, g_pd3dDeviceContext); + + // Application main loop + while (true) + { + // Feed inputs to dear imgui, start new frame + ImGui_ImplDX11_NewFrame(); + ImGui_ImplWin32_NewFrame(); + ImGui::NewFrame(); + + // Any application code here + ImGui::Text("Hello, world!"); + + // Render dear imgui into screen + ImGui::Render(); + ImGui_ImplDX11_RenderDrawData(ImGui::GetDrawData()); + g_pSwapChain->Present(1, 0); + } + + // Shutdown + ImGui_ImplDX11_Shutdown(); + ImGui_ImplWin32_Shutdown(); + ImGui::DestroyContext(); + + EXHIBIT 2: IMPLEMENTING CUSTOM BACKEND / CUSTOM ENGINE + + // Application init: create a dear imgui context, setup some options, load fonts + ImGui::CreateContext(); + ImGuiIO& io = ImGui::GetIO(); + // TODO: Set optional io.ConfigFlags values, e.g. 'io.ConfigFlags |= ImGuiConfigFlags_NavEnableKeyboard' to enable keyboard controls. + // TODO: Fill optional fields of the io structure later. + // TODO: Load TTF/OTF fonts if you don't want to use the default font. + + // Build and load the texture atlas into a texture + // (In the examples/ app this is usually done within the ImGui_ImplXXX_Init() function from one of the demo Renderer) + int width, height; + unsigned char* pixels = NULL; + io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height); + + // At this point you've got the texture data and you need to upload that to your graphic system: + // After we have created the texture, store its pointer/identifier (_in whichever format your engine uses_) in 'io.Fonts->TexID'. + // This will be passed back to your via the renderer. Basically ImTextureID == void*. Read FAQ for details about ImTextureID. + MyTexture* texture = MyEngine::CreateTextureFromMemoryPixels(pixels, width, height, TEXTURE_TYPE_RGBA32) + io.Fonts->SetTexID((void*)texture); + + // Application main loop + while (true) + { + // Setup low-level inputs, e.g. on Win32: calling GetKeyboardState(), or write to those fields from your Windows message handlers, etc. + // (In the examples/ app this is usually done within the ImGui_ImplXXX_NewFrame() function from one of the demo Platform Backends) + io.DeltaTime = 1.0f/60.0f; // set the time elapsed since the previous frame (in seconds) + io.DisplaySize.x = 1920.0f; // set the current display width + io.DisplaySize.y = 1280.0f; // set the current display height here + io.MousePos = my_mouse_pos; // set the mouse position + io.MouseDown[0] = my_mouse_buttons[0]; // set the mouse button states + io.MouseDown[1] = my_mouse_buttons[1]; + + // Call NewFrame(), after this point you can use ImGui::* functions anytime + // (So you want to try calling NewFrame() as early as you can in your main loop to be able to use Dear ImGui everywhere) + ImGui::NewFrame(); + + // Most of your application code here + ImGui::Text("Hello, world!"); + MyGameUpdate(); // may use any Dear ImGui functions, e.g. ImGui::Begin("My window"); ImGui::Text("Hello, world!"); ImGui::End(); + MyGameRender(); // may use any Dear ImGui functions as well! + + // Render dear imgui, swap buffers + // (You want to try calling EndFrame/Render as late as you can, to be able to use Dear ImGui in your own game rendering code) + ImGui::EndFrame(); + ImGui::Render(); + ImDrawData* draw_data = ImGui::GetDrawData(); + MyImGuiRenderFunction(draw_data); + SwapBuffers(); + } + + // Shutdown + ImGui::DestroyContext(); + + To decide whether to dispatch mouse/keyboard inputs to Dear ImGui to the rest of your application, + you should read the 'io.WantCaptureMouse', 'io.WantCaptureKeyboard' and 'io.WantTextInput' flags! + Please read the FAQ and example applications for details about this! + + + HOW A SIMPLE RENDERING FUNCTION MAY LOOK LIKE + --------------------------------------------- + The backends in impl_impl_XXX.cpp files contain many working implementations of a rendering function. + + void void MyImGuiRenderFunction(ImDrawData* draw_data) + { + // TODO: Setup render state: alpha-blending enabled, no face culling, no depth testing, scissor enabled + // TODO: Setup viewport covering draw_data->DisplayPos to draw_data->DisplayPos + draw_data->DisplaySize + // TODO: Setup orthographic projection matrix cover draw_data->DisplayPos to draw_data->DisplayPos + draw_data->DisplaySize + // TODO: Setup shader: vertex { float2 pos, float2 uv, u32 color }, fragment shader sample color from 1 texture, multiply by vertex color. + for (int n = 0; n < draw_data->CmdListsCount; n++) + { + const ImDrawList* cmd_list = draw_data->CmdLists[n]; + const ImDrawVert* vtx_buffer = cmd_list->VtxBuffer.Data; // vertex buffer generated by Dear ImGui + const ImDrawIdx* idx_buffer = cmd_list->IdxBuffer.Data; // index buffer generated by Dear ImGui + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + const ImDrawCmd* pcmd = &cmd_list->CmdBuffer[cmd_i]; + if (pcmd->UserCallback) + { + pcmd->UserCallback(cmd_list, pcmd); + } + else + { + // The texture for the draw call is specified by pcmd->GetTexID(). + // The vast majority of draw calls will use the Dear ImGui texture atlas, which value you have set yourself during initialization. + MyEngineBindTexture((MyTexture*)pcmd->GetTexID()); + + // We are using scissoring to clip some objects. All low-level graphics API should support it. + // - If your engine doesn't support scissoring yet, you may ignore this at first. You will get some small glitches + // (some elements visible outside their bounds) but you can fix that once everything else works! + // - Clipping coordinates are provided in imgui coordinates space: + // - For a given viewport, draw_data->DisplayPos == viewport->Pos and draw_data->DisplaySize == viewport->Size + // - In a single viewport application, draw_data->DisplayPos == (0,0) and draw_data->DisplaySize == io.DisplaySize, but always use GetMainViewport()->Pos/Size instead of hardcoding those values. + // - In the interest of supporting multi-viewport applications (see 'docking' branch on github), + // always subtract draw_data->DisplayPos from clipping bounds to convert them to your viewport space. + // - Note that pcmd->ClipRect contains Min+Max bounds. Some graphics API may use Min+Max, other may use Min+Size (size being Max-Min) + ImVec2 pos = draw_data->DisplayPos; + MyEngineScissor((int)(pcmd->ClipRect.x - pos.x), (int)(pcmd->ClipRect.y - pos.y), (int)(pcmd->ClipRect.z - pos.x), (int)(pcmd->ClipRect.w - pos.y)); + + // Render 'pcmd->ElemCount/3' indexed triangles. + // By default the indices ImDrawIdx are 16-bit, you can change them to 32-bit in imconfig.h if your engine doesn't support 16-bit indices. + MyEngineDrawIndexedTriangles(pcmd->ElemCount, sizeof(ImDrawIdx) == 2 ? GL_UNSIGNED_SHORT : GL_UNSIGNED_INT, idx_buffer, vtx_buffer); + } + idx_buffer += pcmd->ElemCount; + } + } + } + + + USING GAMEPAD/KEYBOARD NAVIGATION CONTROLS + ------------------------------------------ + - The gamepad/keyboard navigation is fairly functional and keeps being improved. + - Gamepad support is particularly useful to use Dear ImGui on a console system (e.g. PS4, Switch, XB1) without a mouse! + - You can ask questions and report issues at https://github.com/ocornut/imgui/issues/787 + - The initial focus was to support game controllers, but keyboard is becoming increasingly and decently usable. + - Keyboard: + - Set io.ConfigFlags |= ImGuiConfigFlags_NavEnableKeyboard to enable. + NewFrame() will automatically fill io.NavInputs[] based on your io.KeysDown[] + io.KeyMap[] arrays. + - When keyboard navigation is active (io.NavActive + ImGuiConfigFlags_NavEnableKeyboard), the io.WantCaptureKeyboard flag + will be set. For more advanced uses, you may want to read from: + - io.NavActive: true when a window is focused and it doesn't have the ImGuiWindowFlags_NoNavInputs flag set. + - io.NavVisible: true when the navigation cursor is visible (and usually goes false when mouse is used). + - or query focus information with e.g. IsWindowFocused(ImGuiFocusedFlags_AnyWindow), IsItemFocused() etc. functions. + Please reach out if you think the game vs navigation input sharing could be improved. + - Gamepad: + - Set io.ConfigFlags |= ImGuiConfigFlags_NavEnableGamepad to enable. + - Backend: Set io.BackendFlags |= ImGuiBackendFlags_HasGamepad + fill the io.NavInputs[] fields before calling NewFrame(). + Note that io.NavInputs[] is cleared by EndFrame(). + - See 'enum ImGuiNavInput_' in imgui.h for a description of inputs. For each entry of io.NavInputs[], set the following values: + 0.0f= not held. 1.0f= fully held. Pass intermediate 0.0f..1.0f values for analog triggers/sticks. + - We use a simple >0.0f test for activation testing, and won't attempt to test for a dead-zone. + Your code will probably need to transform your raw inputs (such as e.g. remapping your 0.2..0.9 raw input range to 0.0..1.0 imgui range, etc.). + - You can download PNG/PSD files depicting the gamepad controls for common controllers at: http://dearimgui.org/controls_sheets + - If you need to share inputs between your game and the imgui parts, the easiest approach is to go all-or-nothing, with a buttons combo + to toggle the target. Please reach out if you think the game vs navigation input sharing could be improved. + - Mouse: + - PS4 users: Consider emulating a mouse cursor with DualShock4 touch pad or a spare analog stick as a mouse-emulation fallback. + - Consoles/Tablet/Phone users: Consider using a Synergy 1.x server (on your PC) + uSynergy.c (on your console/tablet/phone app) to share your PC mouse/keyboard. + - On a TV/console system where readability may be lower or mouse inputs may be awkward, you may want to set the ImGuiConfigFlags_NavEnableSetMousePos flag. + Enabling ImGuiConfigFlags_NavEnableSetMousePos + ImGuiBackendFlags_HasSetMousePos instructs dear imgui to move your mouse cursor along with navigation movements. + When enabled, the NewFrame() function may alter 'io.MousePos' and set 'io.WantSetMousePos' to notify you that it wants the mouse cursor to be moved. + When that happens your backend NEEDS to move the OS or underlying mouse cursor on the next frame. Some of the backends in examples/ do that. + (If you set the NavEnableSetMousePos flag but don't honor 'io.WantSetMousePos' properly, imgui will misbehave as it will see your mouse moving back and forth!) + (In a setup when you may not have easy control over the mouse cursor, e.g. uSynergy.c doesn't expose moving remote mouse cursor, you may want + to set a boolean to ignore your other external mouse positions until the external source is moved again.) + + + API BREAKING CHANGES + ==================== + + Occasionally introducing changes that are breaking the API. We try to make the breakage minor and easy to fix. + Below is a change-log of API breaking changes only. If you are using one of the functions listed, expect to have to fix some code. + When you are not sure about an old symbol or function name, try using the Search/Find function of your IDE to look for comments or references in all imgui files. + You can read releases logs https://github.com/ocornut/imgui/releases for more details. + + - 2021/08/23 (1.85) - removed GetWindowContentRegionWidth() function. keep inline redirection helper. can use 'GetWindowContentRegionMax().x - GetWindowContentRegionMin().x' instead. + - 2021/07/26 (1.84) - commented out redirecting functions/enums names that were marked obsolete in 1.67 and 1.69 (March 2019): + - ImGui::GetOverlayDrawList() -> use ImGui::GetForegroundDrawList() + - ImFont::GlyphRangesBuilder -> use ImFontGlyphRangesBuilder + - 2021/05/19 (1.83) - backends: obsoleted direct access to ImDrawCmd::TextureId in favor of calling ImDrawCmd::GetTexID(). + - if you are using official backends from the source tree: you have nothing to do. + - if you have copied old backend code or using your own: change access to draw_cmd->TextureId to draw_cmd->GetTexID(). + - 2021/03/12 (1.82) - upgraded ImDrawList::AddRect(), AddRectFilled(), PathRect() to use ImDrawFlags instead of ImDrawCornersFlags. + - ImDrawCornerFlags_TopLeft -> use ImDrawFlags_RoundCornersTopLeft + - ImDrawCornerFlags_BotRight -> use ImDrawFlags_RoundCornersBottomRight + - ImDrawCornerFlags_None -> use ImDrawFlags_RoundCornersNone etc. + flags now sanely defaults to 0 instead of 0x0F, consistent with all other flags in the API. + breaking: the default with rounding > 0.0f is now "round all corners" vs old implicit "round no corners": + - rounding == 0.0f + flags == 0 --> meant no rounding --> unchanged (common use) + - rounding > 0.0f + flags != 0 --> meant rounding --> unchanged (common use) + - rounding == 0.0f + flags != 0 --> meant no rounding --> unchanged (unlikely use) + - rounding > 0.0f + flags == 0 --> meant no rounding --> BREAKING (unlikely use): will now round all corners --> use ImDrawFlags_RoundCornersNone or rounding == 0.0f. + this ONLY matters for hard coded use of 0 + rounding > 0.0f. Use of named ImDrawFlags_RoundCornersNone (new) or ImDrawCornerFlags_None (old) are ok. + the old ImDrawCornersFlags used awkward default values of ~0 or 0xF (4 lower bits set) to signify "round all corners" and we sometimes encouraged using them as shortcuts. + legacy path still support use of hard coded ~0 or any value from 0x1 or 0xF. They will behave the same with legacy paths enabled (will assert otherwise). + - 2021/03/11 (1.82) - removed redirecting functions/enums names that were marked obsolete in 1.66 (September 2018): + - ImGui::SetScrollHere() -> use ImGui::SetScrollHereY() + - 2021/03/11 (1.82) - clarified that ImDrawList::PathArcTo(), ImDrawList::PathArcToFast() won't render with radius < 0.0f. Previously it sorts of accidentally worked but would generally lead to counter-clockwise paths and have an effect on anti-aliasing. + - 2021/03/10 (1.82) - upgraded ImDrawList::AddPolyline() and PathStroke() "bool closed" parameter to "ImDrawFlags flags". The matching ImDrawFlags_Closed value is guaranteed to always stay == 1 in the future. + - 2021/02/22 (1.82) - (*undone in 1.84*) win32+mingw: Re-enabled IME functions by default even under MinGW. In July 2016, issue #738 had me incorrectly disable those default functions for MinGW. MinGW users should: either link with -limm32, either set their imconfig file with '#define IMGUI_DISABLE_WIN32_DEFAULT_IME_FUNCTIONS'. + - 2021/02/17 (1.82) - renamed rarely used style.CircleSegmentMaxError (old default = 1.60f) to style.CircleTessellationMaxError (new default = 0.30f) as the meaning of the value changed. + - 2021/02/03 (1.81) - renamed ListBoxHeader(const char* label, ImVec2 size) to BeginListBox(). Kept inline redirection function (will obsolete). + - removed ListBoxHeader(const char* label, int items_count, int height_in_items = -1) in favor of specifying size. Kept inline redirection function (will obsolete). + - renamed ListBoxFooter() to EndListBox(). Kept inline redirection function (will obsolete). + - 2021/01/26 (1.81) - removed ImGuiFreeType::BuildFontAtlas(). Kept inline redirection function. Prefer using '#define IMGUI_ENABLE_FREETYPE', but there's a runtime selection path available too. The shared extra flags parameters (very rarely used) are now stored in ImFontAtlas::FontBuilderFlags. + - renamed ImFontConfig::RasterizerFlags (used by FreeType) to ImFontConfig::FontBuilderFlags. + - renamed ImGuiFreeType::XXX flags to ImGuiFreeTypeBuilderFlags_XXX for consistency with other API. + - 2020/10/12 (1.80) - removed redirecting functions/enums that were marked obsolete in 1.63 (August 2018): + - ImGui::IsItemDeactivatedAfterChange() -> use ImGui::IsItemDeactivatedAfterEdit(). + - ImGuiCol_ModalWindowDarkening -> use ImGuiCol_ModalWindowDimBg + - ImGuiInputTextCallback -> use ImGuiTextEditCallback + - ImGuiInputTextCallbackData -> use ImGuiTextEditCallbackData + - 2020/12/21 (1.80) - renamed ImDrawList::AddBezierCurve() to AddBezierCubic(), and PathBezierCurveTo() to PathBezierCubicCurveTo(). Kept inline redirection function (will obsolete). + - 2020/12/04 (1.80) - added imgui_tables.cpp file! Manually constructed project files will need the new file added! + - 2020/11/18 (1.80) - renamed undocumented/internals ImGuiColumnsFlags_* to ImGuiOldColumnFlags_* in prevision of incoming Tables API. + - 2020/11/03 (1.80) - renamed io.ConfigWindowsMemoryCompactTimer to io.ConfigMemoryCompactTimer as the feature will apply to other data structures + - 2020/10/14 (1.80) - backends: moved all backends files (imgui_impl_XXXX.cpp, imgui_impl_XXXX.h) from examples/ to backends/. + - 2020/10/12 (1.80) - removed redirecting functions/enums that were marked obsolete in 1.60 (April 2018): + - io.RenderDrawListsFn pointer -> use ImGui::GetDrawData() value and call the render function of your backend + - ImGui::IsAnyWindowFocused() -> use ImGui::IsWindowFocused(ImGuiFocusedFlags_AnyWindow) + - ImGui::IsAnyWindowHovered() -> use ImGui::IsWindowHovered(ImGuiHoveredFlags_AnyWindow) + - ImGuiStyleVar_Count_ -> use ImGuiStyleVar_COUNT + - ImGuiMouseCursor_Count_ -> use ImGuiMouseCursor_COUNT + - removed redirecting functions names that were marked obsolete in 1.61 (May 2018): + - InputFloat (... int decimal_precision ...) -> use InputFloat (... const char* format ...) with format = "%.Xf" where X is your value for decimal_precision. + - same for InputFloat2()/InputFloat3()/InputFloat4() variants taking a `int decimal_precision` parameter. + - 2020/10/05 (1.79) - removed ImGuiListClipper: Renamed constructor parameters which created an ambiguous alternative to using the ImGuiListClipper::Begin() function, with misleading edge cases (note: imgui_memory_editor <0.40 from imgui_club/ used this old clipper API. Update your copy if needed). + - 2020/09/25 (1.79) - renamed ImGuiSliderFlags_ClampOnInput to ImGuiSliderFlags_AlwaysClamp. Kept redirection enum (will obsolete sooner because previous name was added recently). + - 2020/09/25 (1.79) - renamed style.TabMinWidthForUnselectedCloseButton to style.TabMinWidthForCloseButton. + - 2020/09/21 (1.79) - renamed OpenPopupContextItem() back to OpenPopupOnItemClick(), reverting the change from 1.77. For varieties of reason this is more self-explanatory. + - 2020/09/21 (1.79) - removed return value from OpenPopupOnItemClick() - returned true on mouse release on an item - because it is inconsistent with other popup APIs and makes others misleading. It's also and unnecessary: you can use IsWindowAppearing() after BeginPopup() for a similar result. + - 2020/09/17 (1.79) - removed ImFont::DisplayOffset in favor of ImFontConfig::GlyphOffset. DisplayOffset was applied after scaling and not very meaningful/useful outside of being needed by the default ProggyClean font. If you scaled this value after calling AddFontDefault(), this is now done automatically. It was also getting in the way of better font scaling, so let's get rid of it now! + - 2020/08/17 (1.78) - obsoleted use of the trailing 'float power=1.0f' parameter for DragFloat(), DragFloat2(), DragFloat3(), DragFloat4(), DragFloatRange2(), DragScalar(), DragScalarN(), SliderFloat(), SliderFloat2(), SliderFloat3(), SliderFloat4(), SliderScalar(), SliderScalarN(), VSliderFloat() and VSliderScalar(). + replaced the 'float power=1.0f' argument with integer-based flags defaulting to 0 (as with all our flags). + worked out a backward-compatibility scheme so hopefully most C++ codebase should not be affected. in short, when calling those functions: + - if you omitted the 'power' parameter (likely!), you are not affected. + - if you set the 'power' parameter to 1.0f (same as previous default value): 1/ your compiler may warn on float>int conversion, 2/ everything else will work. 3/ you can replace the 1.0f value with 0 to fix the warning, and be technically correct. + - if you set the 'power' parameter to >1.0f (to enable non-linear editing): 1/ your compiler may warn on float>int conversion, 2/ code will assert at runtime, 3/ in case asserts are disabled, the code will not crash and enable the _Logarithmic flag. 4/ you can replace the >1.0f value with ImGuiSliderFlags_Logarithmic to fix the warning/assert and get a _similar_ effect as previous uses of power >1.0f. + see https://github.com/ocornut/imgui/issues/3361 for all details. + kept inline redirection functions (will obsolete) apart for: DragFloatRange2(), VSliderFloat(), VSliderScalar(). For those three the 'float power=1.0f' version was removed directly as they were most unlikely ever used. + for shared code, you can version check at compile-time with `#if IMGUI_VERSION_NUM >= 17704`. + - obsoleted use of v_min > v_max in DragInt, DragFloat, DragScalar to lock edits (introduced in 1.73, was not demoed nor documented very), will be replaced by a more generic ReadOnly feature. You may use the ImGuiSliderFlags_ReadOnly internal flag in the meantime. + - 2020/06/23 (1.77) - removed BeginPopupContextWindow(const char*, int mouse_button, bool also_over_items) in favor of BeginPopupContextWindow(const char*, ImGuiPopupFlags flags) with ImGuiPopupFlags_NoOverItems. + - 2020/06/15 (1.77) - renamed OpenPopupOnItemClick() to OpenPopupContextItem(). Kept inline redirection function (will obsolete). [NOTE: THIS WAS REVERTED IN 1.79] + - 2020/06/15 (1.77) - removed CalcItemRectClosestPoint() entry point which was made obsolete and asserting in December 2017. + - 2020/04/23 (1.77) - removed unnecessary ID (first arg) of ImFontAtlas::AddCustomRectRegular(). + - 2020/01/22 (1.75) - ImDrawList::AddCircle()/AddCircleFilled() functions don't accept negative radius any more. + - 2019/12/17 (1.75) - [undid this change in 1.76] made Columns() limited to 64 columns by asserting above that limit. While the current code technically supports it, future code may not so we're putting the restriction ahead. + - 2019/12/13 (1.75) - [imgui_internal.h] changed ImRect() default constructor initializes all fields to 0.0f instead of (FLT_MAX,FLT_MAX,-FLT_MAX,-FLT_MAX). If you used ImRect::Add() to create bounding boxes by adding multiple points into it, you may need to fix your initial value. + - 2019/12/08 (1.75) - removed redirecting functions/enums that were marked obsolete in 1.53 (December 2017): + - ShowTestWindow() -> use ShowDemoWindow() + - IsRootWindowFocused() -> use IsWindowFocused(ImGuiFocusedFlags_RootWindow) + - IsRootWindowOrAnyChildFocused() -> use IsWindowFocused(ImGuiFocusedFlags_RootAndChildWindows) + - SetNextWindowContentWidth(w) -> use SetNextWindowContentSize(ImVec2(w, 0.0f) + - GetItemsLineHeightWithSpacing() -> use GetFrameHeightWithSpacing() + - ImGuiCol_ChildWindowBg -> use ImGuiCol_ChildBg + - ImGuiStyleVar_ChildWindowRounding -> use ImGuiStyleVar_ChildRounding + - ImGuiTreeNodeFlags_AllowOverlapMode -> use ImGuiTreeNodeFlags_AllowItemOverlap + - IMGUI_DISABLE_TEST_WINDOWS -> use IMGUI_DISABLE_DEMO_WINDOWS + - 2019/12/08 (1.75) - obsoleted calling ImDrawList::PrimReserve() with a negative count (which was vaguely documented and rarely if ever used). Instead, we added an explicit PrimUnreserve() API. + - 2019/12/06 (1.75) - removed implicit default parameter to IsMouseDragging(int button = 0) to be consistent with other mouse functions (none of the other functions have it). + - 2019/11/21 (1.74) - ImFontAtlas::AddCustomRectRegular() now requires an ID larger than 0x110000 (instead of 0x10000) to conform with supporting Unicode planes 1-16 in a future update. ID below 0x110000 will now assert. + - 2019/11/19 (1.74) - renamed IMGUI_DISABLE_FORMAT_STRING_FUNCTIONS to IMGUI_DISABLE_DEFAULT_FORMAT_FUNCTIONS for consistency. + - 2019/11/19 (1.74) - renamed IMGUI_DISABLE_MATH_FUNCTIONS to IMGUI_DISABLE_DEFAULT_MATH_FUNCTIONS for consistency. + - 2019/10/22 (1.74) - removed redirecting functions/enums that were marked obsolete in 1.52 (October 2017): + - Begin() [old 5 args version] -> use Begin() [3 args], use SetNextWindowSize() SetNextWindowBgAlpha() if needed + - IsRootWindowOrAnyChildHovered() -> use IsWindowHovered(ImGuiHoveredFlags_RootAndChildWindows) + - AlignFirstTextHeightToWidgets() -> use AlignTextToFramePadding() + - SetNextWindowPosCenter() -> use SetNextWindowPos() with a pivot of (0.5f, 0.5f) + - ImFont::Glyph -> use ImFontGlyph + - 2019/10/14 (1.74) - inputs: Fixed a miscalculation in the keyboard/mouse "typematic" repeat delay/rate calculation, used by keys and e.g. repeating mouse buttons as well as the GetKeyPressedAmount() function. + if you were using a non-default value for io.KeyRepeatRate (previous default was 0.250), you can add +io.KeyRepeatDelay to it to compensate for the fix. + The function was triggering on: 0.0 and (delay+rate*N) where (N>=1). Fixed formula responds to (N>=0). Effectively it made io.KeyRepeatRate behave like it was set to (io.KeyRepeatRate + io.KeyRepeatDelay). + If you never altered io.KeyRepeatRate nor used GetKeyPressedAmount() this won't affect you. + - 2019/07/15 (1.72) - removed TreeAdvanceToLabelPos() which is rarely used and only does SetCursorPosX(GetCursorPosX() + GetTreeNodeToLabelSpacing()). Kept redirection function (will obsolete). + - 2019/07/12 (1.72) - renamed ImFontAtlas::CustomRect to ImFontAtlasCustomRect. Kept redirection typedef (will obsolete). + - 2019/06/14 (1.72) - removed redirecting functions/enums names that were marked obsolete in 1.51 (June 2017): ImGuiCol_Column*, ImGuiSetCond_*, IsItemHoveredRect(), IsPosHoveringAnyWindow(), IsMouseHoveringAnyWindow(), IsMouseHoveringWindow(), IMGUI_ONCE_UPON_A_FRAME. Grep this log for details and new names, or see how they were implemented until 1.71. + - 2019/06/07 (1.71) - rendering of child window outer decorations (bg color, border, scrollbars) is now performed as part of the parent window. If you have + overlapping child windows in a same parent, and relied on their relative z-order to be mapped to their submission order, this will affect your rendering. + This optimization is disabled if the parent window has no visual output, because it appears to be the most common situation leading to the creation of overlapping child windows. + Please reach out if you are affected. + - 2019/05/13 (1.71) - renamed SetNextTreeNodeOpen() to SetNextItemOpen(). Kept inline redirection function (will obsolete). + - 2019/05/11 (1.71) - changed io.AddInputCharacter(unsigned short c) signature to io.AddInputCharacter(unsigned int c). + - 2019/04/29 (1.70) - improved ImDrawList thick strokes (>1.0f) preserving correct thickness up to 90 degrees angles (e.g. rectangles). If you have custom rendering using thick lines, they will appear thicker now. + - 2019/04/29 (1.70) - removed GetContentRegionAvailWidth(), use GetContentRegionAvail().x instead. Kept inline redirection function (will obsolete). + - 2019/03/04 (1.69) - renamed GetOverlayDrawList() to GetForegroundDrawList(). Kept redirection function (will obsolete). + - 2019/02/26 (1.69) - renamed ImGuiColorEditFlags_RGB/ImGuiColorEditFlags_HSV/ImGuiColorEditFlags_HEX to ImGuiColorEditFlags_DisplayRGB/ImGuiColorEditFlags_DisplayHSV/ImGuiColorEditFlags_DisplayHex. Kept redirection enums (will obsolete). + - 2019/02/14 (1.68) - made it illegal/assert when io.DisplayTime == 0.0f (with an exception for the first frame). If for some reason your time step calculation gives you a zero value, replace it with an arbitrarily small value! + - 2019/02/01 (1.68) - removed io.DisplayVisibleMin/DisplayVisibleMax (which were marked obsolete and removed from viewport/docking branch already). + - 2019/01/06 (1.67) - renamed io.InputCharacters[], marked internal as was always intended. Please don't access directly, and use AddInputCharacter() instead! + - 2019/01/06 (1.67) - renamed ImFontAtlas::GlyphRangesBuilder to ImFontGlyphRangesBuilder. Kept redirection typedef (will obsolete). + - 2018/12/20 (1.67) - made it illegal to call Begin("") with an empty string. This somehow half-worked before but had various undesirable side-effects. + - 2018/12/10 (1.67) - renamed io.ConfigResizeWindowsFromEdges to io.ConfigWindowsResizeFromEdges as we are doing a large pass on configuration flags. + - 2018/10/12 (1.66) - renamed misc/stl/imgui_stl.* to misc/cpp/imgui_stdlib.* in prevision for other C++ helper files. + - 2018/09/28 (1.66) - renamed SetScrollHere() to SetScrollHereY(). Kept redirection function (will obsolete). + - 2018/09/06 (1.65) - renamed stb_truetype.h to imstb_truetype.h, stb_textedit.h to imstb_textedit.h, and stb_rect_pack.h to imstb_rectpack.h. + If you were conveniently using the imgui copy of those STB headers in your project you will have to update your include paths. + - 2018/09/05 (1.65) - renamed io.OptCursorBlink/io.ConfigCursorBlink to io.ConfigInputTextCursorBlink. (#1427) + - 2018/08/31 (1.64) - added imgui_widgets.cpp file, extracted and moved widgets code out of imgui.cpp into imgui_widgets.cpp. Re-ordered some of the code remaining in imgui.cpp. + NONE OF THE FUNCTIONS HAVE CHANGED. THE CODE IS SEMANTICALLY 100% IDENTICAL, BUT _EVERY_ FUNCTION HAS BEEN MOVED. + Because of this, any local modifications to imgui.cpp will likely conflict when you update. Read docs/CHANGELOG.txt for suggestions. + - 2018/08/22 (1.63) - renamed IsItemDeactivatedAfterChange() to IsItemDeactivatedAfterEdit() for consistency with new IsItemEdited() API. Kept redirection function (will obsolete soonish as IsItemDeactivatedAfterChange() is very recent). + - 2018/08/21 (1.63) - renamed ImGuiTextEditCallback to ImGuiInputTextCallback, ImGuiTextEditCallbackData to ImGuiInputTextCallbackData for consistency. Kept redirection types (will obsolete). + - 2018/08/21 (1.63) - removed ImGuiInputTextCallbackData::ReadOnly since it is a duplication of (ImGuiInputTextCallbackData::Flags & ImGuiInputTextFlags_ReadOnly). + - 2018/08/01 (1.63) - removed per-window ImGuiWindowFlags_ResizeFromAnySide beta flag in favor of a global io.ConfigResizeWindowsFromEdges [update 1.67 renamed to ConfigWindowsResizeFromEdges] to enable the feature. + - 2018/08/01 (1.63) - renamed io.OptCursorBlink to io.ConfigCursorBlink [-> io.ConfigInputTextCursorBlink in 1.65], io.OptMacOSXBehaviors to ConfigMacOSXBehaviors for consistency. + - 2018/07/22 (1.63) - changed ImGui::GetTime() return value from float to double to avoid accumulating floating point imprecisions over time. + - 2018/07/08 (1.63) - style: renamed ImGuiCol_ModalWindowDarkening to ImGuiCol_ModalWindowDimBg for consistency with other features. Kept redirection enum (will obsolete). + - 2018/06/08 (1.62) - examples: the imgui_impl_XXX files have been split to separate platform (Win32, GLFW, SDL2, etc.) from renderer (DX11, OpenGL, Vulkan, etc.). + old backends will still work as is, however prefer using the separated backends as they will be updated to support multi-viewports. + when adopting new backends follow the main.cpp code of your preferred examples/ folder to know which functions to call. + in particular, note that old backends called ImGui::NewFrame() at the end of their ImGui_ImplXXXX_NewFrame() function. + - 2018/06/06 (1.62) - renamed GetGlyphRangesChinese() to GetGlyphRangesChineseFull() to distinguish other variants and discourage using the full set. + - 2018/06/06 (1.62) - TreeNodeEx()/TreeNodeBehavior(): the ImGuiTreeNodeFlags_CollapsingHeader helper now include the ImGuiTreeNodeFlags_NoTreePushOnOpen flag. See Changelog for details. + - 2018/05/03 (1.61) - DragInt(): the default compile-time format string has been changed from "%.0f" to "%d", as we are not using integers internally any more. + If you used DragInt() with custom format strings, make sure you change them to use %d or an integer-compatible format. + To honor backward-compatibility, the DragInt() code will currently parse and modify format strings to replace %*f with %d, giving time to users to upgrade their code. + If you have IMGUI_DISABLE_OBSOLETE_FUNCTIONS enabled, the code will instead assert! You may run a reg-exp search on your codebase for e.g. "DragInt.*%f" to help you find them. + - 2018/04/28 (1.61) - obsoleted InputFloat() functions taking an optional "int decimal_precision" in favor of an equivalent and more flexible "const char* format", + consistent with other functions. Kept redirection functions (will obsolete). + - 2018/04/09 (1.61) - IM_DELETE() helper function added in 1.60 doesn't clear the input _pointer_ reference, more consistent with expectation and allows passing r-value. + - 2018/03/20 (1.60) - renamed io.WantMoveMouse to io.WantSetMousePos for consistency and ease of understanding (was added in 1.52, _not_ used by core and only honored by some backend ahead of merging the Nav branch). + - 2018/03/12 (1.60) - removed ImGuiCol_CloseButton, ImGuiCol_CloseButtonActive, ImGuiCol_CloseButtonHovered as the closing cross uses regular button colors now. + - 2018/03/08 (1.60) - changed ImFont::DisplayOffset.y to default to 0 instead of +1. Fixed rounding of Ascent/Descent to match TrueType renderer. If you were adding or subtracting to ImFont::DisplayOffset check if your fonts are correctly aligned vertically. + - 2018/03/03 (1.60) - renamed ImGuiStyleVar_Count_ to ImGuiStyleVar_COUNT and ImGuiMouseCursor_Count_ to ImGuiMouseCursor_COUNT for consistency with other public enums. + - 2018/02/18 (1.60) - BeginDragDropSource(): temporarily removed the optional mouse_button=0 parameter because it is not really usable in many situations at the moment. + - 2018/02/16 (1.60) - obsoleted the io.RenderDrawListsFn callback, you can call your graphics engine render function after ImGui::Render(). Use ImGui::GetDrawData() to retrieve the ImDrawData* to display. + - 2018/02/07 (1.60) - reorganized context handling to be more explicit, + - YOU NOW NEED TO CALL ImGui::CreateContext() AT THE BEGINNING OF YOUR APP, AND CALL ImGui::DestroyContext() AT THE END. + - removed Shutdown() function, as DestroyContext() serve this purpose. + - you may pass a ImFontAtlas* pointer to CreateContext() to share a font atlas between contexts. Otherwise CreateContext() will create its own font atlas instance. + - removed allocator parameters from CreateContext(), they are now setup with SetAllocatorFunctions(), and shared by all contexts. + - removed the default global context and font atlas instance, which were confusing for users of DLL reloading and users of multiple contexts. + - 2018/01/31 (1.60) - moved sample TTF files from extra_fonts/ to misc/fonts/. If you loaded files directly from the imgui repo you may need to update your paths. + - 2018/01/11 (1.60) - obsoleted IsAnyWindowHovered() in favor of IsWindowHovered(ImGuiHoveredFlags_AnyWindow). Kept redirection function (will obsolete). + - 2018/01/11 (1.60) - obsoleted IsAnyWindowFocused() in favor of IsWindowFocused(ImGuiFocusedFlags_AnyWindow). Kept redirection function (will obsolete). + - 2018/01/03 (1.60) - renamed ImGuiSizeConstraintCallback to ImGuiSizeCallback, ImGuiSizeConstraintCallbackData to ImGuiSizeCallbackData. + - 2017/12/29 (1.60) - removed CalcItemRectClosestPoint() which was weird and not really used by anyone except demo code. If you need it it's easy to replicate on your side. + - 2017/12/24 (1.53) - renamed the emblematic ShowTestWindow() function to ShowDemoWindow(). Kept redirection function (will obsolete). + - 2017/12/21 (1.53) - ImDrawList: renamed style.AntiAliasedShapes to style.AntiAliasedFill for consistency and as a way to explicitly break code that manipulate those flag at runtime. You can now manipulate ImDrawList::Flags + - 2017/12/21 (1.53) - ImDrawList: removed 'bool anti_aliased = true' final parameter of ImDrawList::AddPolyline() and ImDrawList::AddConvexPolyFilled(). Prefer manipulating ImDrawList::Flags if you need to toggle them during the frame. + - 2017/12/14 (1.53) - using the ImGuiWindowFlags_NoScrollWithMouse flag on a child window forwards the mouse wheel event to the parent window, unless either ImGuiWindowFlags_NoInputs or ImGuiWindowFlags_NoScrollbar are also set. + - 2017/12/13 (1.53) - renamed GetItemsLineHeightWithSpacing() to GetFrameHeightWithSpacing(). Kept redirection function (will obsolete). + - 2017/12/13 (1.53) - obsoleted IsRootWindowFocused() in favor of using IsWindowFocused(ImGuiFocusedFlags_RootWindow). Kept redirection function (will obsolete). + - obsoleted IsRootWindowOrAnyChildFocused() in favor of using IsWindowFocused(ImGuiFocusedFlags_RootAndChildWindows). Kept redirection function (will obsolete). + - 2017/12/12 (1.53) - renamed ImGuiTreeNodeFlags_AllowOverlapMode to ImGuiTreeNodeFlags_AllowItemOverlap. Kept redirection enum (will obsolete). + - 2017/12/10 (1.53) - removed SetNextWindowContentWidth(), prefer using SetNextWindowContentSize(). Kept redirection function (will obsolete). + - 2017/11/27 (1.53) - renamed ImGuiTextBuffer::append() helper to appendf(), appendv() to appendfv(). If you copied the 'Log' demo in your code, it uses appendv() so that needs to be renamed. + - 2017/11/18 (1.53) - Style, Begin: removed ImGuiWindowFlags_ShowBorders window flag. Borders are now fully set up in the ImGuiStyle structure (see e.g. style.FrameBorderSize, style.WindowBorderSize). Use ImGui::ShowStyleEditor() to look them up. + Please note that the style system will keep evolving (hopefully stabilizing in Q1 2018), and so custom styles will probably subtly break over time. It is recommended you use the StyleColorsClassic(), StyleColorsDark(), StyleColorsLight() functions. + - 2017/11/18 (1.53) - Style: removed ImGuiCol_ComboBg in favor of combo boxes using ImGuiCol_PopupBg for consistency. + - 2017/11/18 (1.53) - Style: renamed ImGuiCol_ChildWindowBg to ImGuiCol_ChildBg. + - 2017/11/18 (1.53) - Style: renamed style.ChildWindowRounding to style.ChildRounding, ImGuiStyleVar_ChildWindowRounding to ImGuiStyleVar_ChildRounding. + - 2017/11/02 (1.53) - obsoleted IsRootWindowOrAnyChildHovered() in favor of using IsWindowHovered(ImGuiHoveredFlags_RootAndChildWindows); + - 2017/10/24 (1.52) - renamed IMGUI_DISABLE_WIN32_DEFAULT_CLIPBOARD_FUNCS/IMGUI_DISABLE_WIN32_DEFAULT_IME_FUNCS to IMGUI_DISABLE_WIN32_DEFAULT_CLIPBOARD_FUNCTIONS/IMGUI_DISABLE_WIN32_DEFAULT_IME_FUNCTIONS for consistency. + - 2017/10/20 (1.52) - changed IsWindowHovered() default parameters behavior to return false if an item is active in another window (e.g. click-dragging item from another window to this window). You can use the newly introduced IsWindowHovered() flags to requests this specific behavior if you need it. + - 2017/10/20 (1.52) - marked IsItemHoveredRect()/IsMouseHoveringWindow() as obsolete, in favor of using the newly introduced flags for IsItemHovered() and IsWindowHovered(). See https://github.com/ocornut/imgui/issues/1382 for details. + removed the IsItemRectHovered()/IsWindowRectHovered() names introduced in 1.51 since they were merely more consistent names for the two functions we are now obsoleting. + IsItemHoveredRect() --> IsItemHovered(ImGuiHoveredFlags_RectOnly) + IsMouseHoveringAnyWindow() --> IsWindowHovered(ImGuiHoveredFlags_AnyWindow) + IsMouseHoveringWindow() --> IsWindowHovered(ImGuiHoveredFlags_AllowWhenBlockedByPopup | ImGuiHoveredFlags_AllowWhenBlockedByActiveItem) [weird, old behavior] + - 2017/10/17 (1.52) - marked the old 5-parameters version of Begin() as obsolete (still available). Use SetNextWindowSize()+Begin() instead! + - 2017/10/11 (1.52) - renamed AlignFirstTextHeightToWidgets() to AlignTextToFramePadding(). Kept inline redirection function (will obsolete). + - 2017/09/26 (1.52) - renamed ImFont::Glyph to ImFontGlyph. Kept redirection typedef (will obsolete). + - 2017/09/25 (1.52) - removed SetNextWindowPosCenter() because SetNextWindowPos() now has the optional pivot information to do the same and more. Kept redirection function (will obsolete). + - 2017/08/25 (1.52) - io.MousePos needs to be set to ImVec2(-FLT_MAX,-FLT_MAX) when mouse is unavailable/missing. Previously ImVec2(-1,-1) was enough but we now accept negative mouse coordinates. In your backend if you need to support unavailable mouse, make sure to replace "io.MousePos = ImVec2(-1,-1)" with "io.MousePos = ImVec2(-FLT_MAX,-FLT_MAX)". + - 2017/08/22 (1.51) - renamed IsItemHoveredRect() to IsItemRectHovered(). Kept inline redirection function (will obsolete). -> (1.52) use IsItemHovered(ImGuiHoveredFlags_RectOnly)! + - renamed IsMouseHoveringAnyWindow() to IsAnyWindowHovered() for consistency. Kept inline redirection function (will obsolete). + - renamed IsMouseHoveringWindow() to IsWindowRectHovered() for consistency. Kept inline redirection function (will obsolete). + - 2017/08/20 (1.51) - renamed GetStyleColName() to GetStyleColorName() for consistency. + - 2017/08/20 (1.51) - added PushStyleColor(ImGuiCol idx, ImU32 col) overload, which _might_ cause an "ambiguous call" compilation error if you are using ImColor() with implicit cast. Cast to ImU32 or ImVec4 explicily to fix. + - 2017/08/15 (1.51) - marked the weird IMGUI_ONCE_UPON_A_FRAME helper macro as obsolete. prefer using the more explicit ImGuiOnceUponAFrame type. + - 2017/08/15 (1.51) - changed parameter order for BeginPopupContextWindow() from (const char*,int buttons,bool also_over_items) to (const char*,int buttons,bool also_over_items). Note that most calls relied on default parameters completely. + - 2017/08/13 (1.51) - renamed ImGuiCol_Column to ImGuiCol_Separator, ImGuiCol_ColumnHovered to ImGuiCol_SeparatorHovered, ImGuiCol_ColumnActive to ImGuiCol_SeparatorActive. Kept redirection enums (will obsolete). + - 2017/08/11 (1.51) - renamed ImGuiSetCond_Always to ImGuiCond_Always, ImGuiSetCond_Once to ImGuiCond_Once, ImGuiSetCond_FirstUseEver to ImGuiCond_FirstUseEver, ImGuiSetCond_Appearing to ImGuiCond_Appearing. Kept redirection enums (will obsolete). + - 2017/08/09 (1.51) - removed ValueColor() helpers, they are equivalent to calling Text(label) + SameLine() + ColorButton(). + - 2017/08/08 (1.51) - removed ColorEditMode() and ImGuiColorEditMode in favor of ImGuiColorEditFlags and parameters to the various Color*() functions. The SetColorEditOptions() allows to initialize default but the user can still change them with right-click context menu. + - changed prototype of 'ColorEdit4(const char* label, float col[4], bool show_alpha = true)' to 'ColorEdit4(const char* label, float col[4], ImGuiColorEditFlags flags = 0)', where passing flags = 0x01 is a safe no-op (hello dodgy backward compatibility!). - check and run the demo window, under "Color/Picker Widgets", to understand the various new options. + - changed prototype of rarely used 'ColorButton(ImVec4 col, bool small_height = false, bool outline_border = true)' to 'ColorButton(const char* desc_id, ImVec4 col, ImGuiColorEditFlags flags = 0, ImVec2 size = ImVec2(0, 0))' + - 2017/07/20 (1.51) - removed IsPosHoveringAnyWindow(ImVec2), which was partly broken and misleading. ASSERT + redirect user to io.WantCaptureMouse + - 2017/05/26 (1.50) - removed ImFontConfig::MergeGlyphCenterV in favor of a more multipurpose ImFontConfig::GlyphOffset. + - 2017/05/01 (1.50) - renamed ImDrawList::PathFill() (rarely used directly) to ImDrawList::PathFillConvex() for clarity. + - 2016/11/06 (1.50) - BeginChild(const char*) now applies the stack id to the provided label, consistently with other functions as it should always have been. It shouldn't affect you unless (extremely unlikely) you were appending multiple times to a same child from different locations of the stack id. If that's the case, generate an id with GetID() and use it instead of passing string to BeginChild(). + - 2016/10/15 (1.50) - avoid 'void* user_data' parameter to io.SetClipboardTextFn/io.GetClipboardTextFn pointers. We pass io.ClipboardUserData to it. + - 2016/09/25 (1.50) - style.WindowTitleAlign is now a ImVec2 (ImGuiAlign enum was removed). set to (0.5f,0.5f) for horizontal+vertical centering, (0.0f,0.0f) for upper-left, etc. + - 2016/07/30 (1.50) - SameLine(x) with x>0.0f is now relative to left of column/group if any, and not always to left of window. This was sort of always the intent and hopefully, breakage should be minimal. + - 2016/05/12 (1.49) - title bar (using ImGuiCol_TitleBg/ImGuiCol_TitleBgActive colors) isn't rendered over a window background (ImGuiCol_WindowBg color) anymore. + If your TitleBg/TitleBgActive alpha was 1.0f or you are using the default theme it will not affect you, otherwise if <1.0f you need to tweak your custom theme to readjust for the fact that we don't draw a WindowBg background behind the title bar. + This helper function will convert an old TitleBg/TitleBgActive color into a new one with the same visual output, given the OLD color and the OLD WindowBg color: + ImVec4 ConvertTitleBgCol(const ImVec4& win_bg_col, const ImVec4& title_bg_col) { float new_a = 1.0f - ((1.0f - win_bg_col.w) * (1.0f - title_bg_col.w)), k = title_bg_col.w / new_a; return ImVec4((win_bg_col.x * win_bg_col.w + title_bg_col.x) * k, (win_bg_col.y * win_bg_col.w + title_bg_col.y) * k, (win_bg_col.z * win_bg_col.w + title_bg_col.z) * k, new_a); } + If this is confusing, pick the RGB value from title bar from an old screenshot and apply this as TitleBg/TitleBgActive. Or you may just create TitleBgActive from a tweaked TitleBg color. + - 2016/05/07 (1.49) - removed confusing set of GetInternalState(), GetInternalStateSize(), SetInternalState() functions. Now using CreateContext(), DestroyContext(), GetCurrentContext(), SetCurrentContext(). + - 2016/05/02 (1.49) - renamed SetNextTreeNodeOpened() to SetNextTreeNodeOpen(), no redirection. + - 2016/05/01 (1.49) - obsoleted old signature of CollapsingHeader(const char* label, const char* str_id = NULL, bool display_frame = true, bool default_open = false) as extra parameters were badly designed and rarely used. You can replace the "default_open = true" flag in new API with CollapsingHeader(label, ImGuiTreeNodeFlags_DefaultOpen). + - 2016/04/26 (1.49) - changed ImDrawList::PushClipRect(ImVec4 rect) to ImDrawList::PushClipRect(Imvec2 min,ImVec2 max,bool intersect_with_current_clip_rect=false). Note that higher-level ImGui::PushClipRect() is preferable because it will clip at logic/widget level, whereas ImDrawList::PushClipRect() only affect your renderer. + - 2016/04/03 (1.48) - removed style.WindowFillAlphaDefault setting which was redundant. Bake default BG alpha inside style.Colors[ImGuiCol_WindowBg] and all other Bg color values. (ref GitHub issue #337). + - 2016/04/03 (1.48) - renamed ImGuiCol_TooltipBg to ImGuiCol_PopupBg, used by popups/menus and tooltips. popups/menus were previously using ImGuiCol_WindowBg. (ref github issue #337) + - 2016/03/21 (1.48) - renamed GetWindowFont() to GetFont(), GetWindowFontSize() to GetFontSize(). Kept inline redirection function (will obsolete). + - 2016/03/02 (1.48) - InputText() completion/history/always callbacks: if you modify the text buffer manually (without using DeleteChars()/InsertChars() helper) you need to maintain the BufTextLen field. added an assert. + - 2016/01/23 (1.48) - fixed not honoring exact width passed to PushItemWidth(), previously it would add extra FramePadding.x*2 over that width. if you had manual pixel-perfect alignment in place it might affect you. + - 2015/12/27 (1.48) - fixed ImDrawList::AddRect() which used to render a rectangle 1 px too large on each axis. + - 2015/12/04 (1.47) - renamed Color() helpers to ValueColor() - dangerously named, rarely used and probably to be made obsolete. + - 2015/08/29 (1.45) - with the addition of horizontal scrollbar we made various fixes to inconsistencies with dealing with cursor position. + GetCursorPos()/SetCursorPos() functions now include the scrolled amount. It shouldn't affect the majority of users, but take note that SetCursorPosX(100.0f) puts you at +100 from the starting x position which may include scrolling, not at +100 from the window left side. + GetContentRegionMax()/GetWindowContentRegionMin()/GetWindowContentRegionMax() functions allow include the scrolled amount. Typically those were used in cases where no scrolling would happen so it may not be a problem, but watch out! + - 2015/08/29 (1.45) - renamed style.ScrollbarWidth to style.ScrollbarSize + - 2015/08/05 (1.44) - split imgui.cpp into extra files: imgui_demo.cpp imgui_draw.cpp imgui_internal.h that you need to add to your project. + - 2015/07/18 (1.44) - fixed angles in ImDrawList::PathArcTo(), PathArcToFast() (introduced in 1.43) being off by an extra PI for no justifiable reason + - 2015/07/14 (1.43) - add new ImFontAtlas::AddFont() API. For the old AddFont***, moved the 'font_no' parameter of ImFontAtlas::AddFont** functions to the ImFontConfig structure. + you need to render your textured triangles with bilinear filtering to benefit from sub-pixel positioning of text. + - 2015/07/08 (1.43) - switched rendering data to use indexed rendering. this is saving a fair amount of CPU/GPU and enables us to get anti-aliasing for a marginal cost. + this necessary change will break your rendering function! the fix should be very easy. sorry for that :( + - if you are using a vanilla copy of one of the imgui_impl_XXX.cpp provided in the example, you just need to update your copy and you can ignore the rest. + - the signature of the io.RenderDrawListsFn handler has changed! + old: ImGui_XXXX_RenderDrawLists(ImDrawList** const cmd_lists, int cmd_lists_count) + new: ImGui_XXXX_RenderDrawLists(ImDrawData* draw_data). + parameters: 'cmd_lists' becomes 'draw_data->CmdLists', 'cmd_lists_count' becomes 'draw_data->CmdListsCount' + ImDrawList: 'commands' becomes 'CmdBuffer', 'vtx_buffer' becomes 'VtxBuffer', 'IdxBuffer' is new. + ImDrawCmd: 'vtx_count' becomes 'ElemCount', 'clip_rect' becomes 'ClipRect', 'user_callback' becomes 'UserCallback', 'texture_id' becomes 'TextureId'. + - each ImDrawList now contains both a vertex buffer and an index buffer. For each command, render ElemCount/3 triangles using indices from the index buffer. + - if you REALLY cannot render indexed primitives, you can call the draw_data->DeIndexAllBuffers() method to de-index the buffers. This is slow and a waste of CPU/GPU. Prefer using indexed rendering! + - refer to code in the examples/ folder or ask on the GitHub if you are unsure of how to upgrade. please upgrade! + - 2015/07/10 (1.43) - changed SameLine() parameters from int to float. + - 2015/07/02 (1.42) - renamed SetScrollPosHere() to SetScrollFromCursorPos(). Kept inline redirection function (will obsolete). + - 2015/07/02 (1.42) - renamed GetScrollPosY() to GetScrollY(). Necessary to reduce confusion along with other scrolling functions, because positions (e.g. cursor position) are not equivalent to scrolling amount. + - 2015/06/14 (1.41) - changed ImageButton() default bg_col parameter from (0,0,0,1) (black) to (0,0,0,0) (transparent) - makes a difference when texture have transparence + - 2015/06/14 (1.41) - changed Selectable() API from (label, selected, size) to (label, selected, flags, size). Size override should have been rarely used. Sorry! + - 2015/05/31 (1.40) - renamed GetWindowCollapsed() to IsWindowCollapsed() for consistency. Kept inline redirection function (will obsolete). + - 2015/05/31 (1.40) - renamed IsRectClipped() to IsRectVisible() for consistency. Note that return value is opposite! Kept inline redirection function (will obsolete). + - 2015/05/27 (1.40) - removed the third 'repeat_if_held' parameter from Button() - sorry! it was rarely used and inconsistent. Use PushButtonRepeat(true) / PopButtonRepeat() to enable repeat on desired buttons. + - 2015/05/11 (1.40) - changed BeginPopup() API, takes a string identifier instead of a bool. ImGui needs to manage the open/closed state of popups. Call OpenPopup() to actually set the "open" state of a popup. BeginPopup() returns true if the popup is opened. + - 2015/05/03 (1.40) - removed style.AutoFitPadding, using style.WindowPadding makes more sense (the default values were already the same). + - 2015/04/13 (1.38) - renamed IsClipped() to IsRectClipped(). Kept inline redirection function until 1.50. + - 2015/04/09 (1.38) - renamed ImDrawList::AddArc() to ImDrawList::AddArcFast() for compatibility with future API + - 2015/04/03 (1.38) - removed ImGuiCol_CheckHovered, ImGuiCol_CheckActive, replaced with the more general ImGuiCol_FrameBgHovered, ImGuiCol_FrameBgActive. + - 2014/04/03 (1.38) - removed support for passing -FLT_MAX..+FLT_MAX as the range for a SliderFloat(). Use DragFloat() or Inputfloat() instead. + - 2015/03/17 (1.36) - renamed GetItemBoxMin()/GetItemBoxMax()/IsMouseHoveringBox() to GetItemRectMin()/GetItemRectMax()/IsMouseHoveringRect(). Kept inline redirection function until 1.50. + - 2015/03/15 (1.36) - renamed style.TreeNodeSpacing to style.IndentSpacing, ImGuiStyleVar_TreeNodeSpacing to ImGuiStyleVar_IndentSpacing + - 2015/03/13 (1.36) - renamed GetWindowIsFocused() to IsWindowFocused(). Kept inline redirection function until 1.50. + - 2015/03/08 (1.35) - renamed style.ScrollBarWidth to style.ScrollbarWidth (casing) + - 2015/02/27 (1.34) - renamed OpenNextNode(bool) to SetNextTreeNodeOpened(bool, ImGuiSetCond). Kept inline redirection function until 1.50. + - 2015/02/27 (1.34) - renamed ImGuiSetCondition_*** to ImGuiSetCond_***, and _FirstUseThisSession becomes _Once. + - 2015/02/11 (1.32) - changed text input callback ImGuiTextEditCallback return type from void-->int. reserved for future use, return 0 for now. + - 2015/02/10 (1.32) - renamed GetItemWidth() to CalcItemWidth() to clarify its evolving behavior + - 2015/02/08 (1.31) - renamed GetTextLineSpacing() to GetTextLineHeightWithSpacing() + - 2015/02/01 (1.31) - removed IO.MemReallocFn (unused) + - 2015/01/19 (1.30) - renamed ImGuiStorage::GetIntPtr()/GetFloatPtr() to GetIntRef()/GetIntRef() because Ptr was conflicting with actual pointer storage functions. + - 2015/01/11 (1.30) - big font/image API change! now loads TTF file. allow for multiple fonts. no need for a PNG loader. + - 2015/01/11 (1.30) - removed GetDefaultFontData(). uses io.Fonts->GetTextureData*() API to retrieve uncompressed pixels. + - old: const void* png_data; unsigned int png_size; ImGui::GetDefaultFontData(NULL, NULL, &png_data, &png_size); [..Upload texture to GPU..]; + - new: unsigned char* pixels; int width, height; io.Fonts->GetTexDataAsRGBA32(&pixels, &width, &height); [..Upload texture to GPU..]; io.Fonts->SetTexID(YourTexIdentifier); + you now have more flexibility to load multiple TTF fonts and manage the texture buffer for internal needs. It is now recommended that you sample the font texture with bilinear interpolation. + - 2015/01/11 (1.30) - added texture identifier in ImDrawCmd passed to your render function (we can now render images). make sure to call io.Fonts->SetTexID() + - 2015/01/11 (1.30) - removed IO.PixelCenterOffset (unnecessary, can be handled in user projection matrix) + - 2015/01/11 (1.30) - removed ImGui::IsItemFocused() in favor of ImGui::IsItemActive() which handles all widgets + - 2014/12/10 (1.18) - removed SetNewWindowDefaultPos() in favor of new generic API SetNextWindowPos(pos, ImGuiSetCondition_FirstUseEver) + - 2014/11/28 (1.17) - moved IO.Font*** options to inside the IO.Font-> structure (FontYOffset, FontTexUvForWhite, FontBaseScale, FontFallbackGlyph) + - 2014/11/26 (1.17) - reworked syntax of IMGUI_ONCE_UPON_A_FRAME helper macro to increase compiler compatibility + - 2014/11/07 (1.15) - renamed IsHovered() to IsItemHovered() + - 2014/10/02 (1.14) - renamed IMGUI_INCLUDE_IMGUI_USER_CPP to IMGUI_INCLUDE_IMGUI_USER_INL and imgui_user.cpp to imgui_user.inl (more IDE friendly) + - 2014/09/25 (1.13) - removed 'text_end' parameter from IO.SetClipboardTextFn (the string is now always zero-terminated for simplicity) + - 2014/09/24 (1.12) - renamed SetFontScale() to SetWindowFontScale() + - 2014/09/24 (1.12) - moved IM_MALLOC/IM_REALLOC/IM_FREE preprocessor defines to IO.MemAllocFn/IO.MemReallocFn/IO.MemFreeFn + - 2014/08/30 (1.09) - removed IO.FontHeight (now computed automatically) + - 2014/08/30 (1.09) - moved IMGUI_FONT_TEX_UV_FOR_WHITE preprocessor define to IO.FontTexUvForWhite + - 2014/08/28 (1.09) - changed the behavior of IO.PixelCenterOffset following various rendering fixes + + + FREQUENTLY ASKED QUESTIONS (FAQ) + ================================ + + Read all answers online: + https://www.dearimgui.org/faq or https://github.com/ocornut/imgui/blob/master/docs/FAQ.md (same url) + Read all answers locally (with a text editor or ideally a Markdown viewer): + docs/FAQ.md + Some answers are copied down here to facilitate searching in code. + + Q&A: Basics + =========== + + Q: Where is the documentation? + A: This library is poorly documented at the moment and expects the user to be acquainted with C/C++. + - Run the examples/ and explore them. + - See demo code in imgui_demo.cpp and particularly the ImGui::ShowDemoWindow() function. + - The demo covers most features of Dear ImGui, so you can read the code and see its output. + - See documentation and comments at the top of imgui.cpp + effectively imgui.h. + - Dozens of standalone example applications using e.g. OpenGL/DirectX are provided in the + examples/ folder to explain how to integrate Dear ImGui with your own engine/application. + - The Wiki (https://github.com/ocornut/imgui/wiki) has many resources and links. + - The Glossary (https://github.com/ocornut/imgui/wiki/Glossary) page also may be useful. + - Your programming IDE is your friend, find the type or function declaration to find comments + associated with it. + + Q: What is this library called? + Q: Which version should I get? + >> This library is called "Dear ImGui", please don't call it "ImGui" :) + >> See https://www.dearimgui.org/faq for details. + + Q&A: Integration + ================ + + Q: How to get started? + A: Read 'PROGRAMMER GUIDE' above. Read examples/README.txt. + + Q: How can I tell whether to dispatch mouse/keyboard to Dear ImGui or my application? + A: You should read the 'io.WantCaptureMouse', 'io.WantCaptureKeyboard' and 'io.WantTextInput' flags! + >> See https://www.dearimgui.org/faq for a fully detailed answer. You really want to read this. + + Q. How can I enable keyboard controls? + Q: How can I use this without a mouse, without a keyboard or without a screen? (gamepad, input share, remote display) + Q: I integrated Dear ImGui in my engine and little squares are showing instead of text... + Q: I integrated Dear ImGui in my engine and some elements are clipping or disappearing when I move windows around... + Q: I integrated Dear ImGui in my engine and some elements are displaying outside their expected windows boundaries... + >> See https://www.dearimgui.org/faq + + Q&A: Usage + ---------- + + Q: Why is my widget not reacting when I click on it? + Q: How can I have widgets with an empty label? + Q: How can I have multiple widgets with the same label? + Q: How can I display an image? What is ImTextureID, how does it works? + Q: How can I use my own math types instead of ImVec2/ImVec4? + Q: How can I interact with standard C++ types (such as std::string and std::vector)? + Q: How can I display custom shapes? (using low-level ImDrawList API) + >> See https://www.dearimgui.org/faq + + Q&A: Fonts, Text + ================ + + Q: How should I handle DPI in my application? + Q: How can I load a different font than the default? + Q: How can I easily use icons in my application? + Q: How can I load multiple fonts? + Q: How can I display and input non-Latin characters such as Chinese, Japanese, Korean, Cyrillic? + >> See https://www.dearimgui.org/faq and https://github.com/ocornut/imgui/edit/master/docs/FONTS.md + + Q&A: Concerns + ============= + + Q: Who uses Dear ImGui? + Q: Can you create elaborate/serious tools with Dear ImGui? + Q: Can you reskin the look of Dear ImGui? + Q: Why using C++ (as opposed to C)? + >> See https://www.dearimgui.org/faq + + Q&A: Community + ============== + + Q: How can I help? + A: - Businesses: please reach out to "contact AT dearimgui.com" if you work in a place using Dear ImGui! + We can discuss ways for your company to fund development via invoiced technical support, maintenance or sponsoring contacts. + This is among the most useful thing you can do for Dear ImGui. With increased funding, we can hire more people working on this project. + - Individuals: you can support continued development via PayPal donations. See README. + - If you are experienced with Dear ImGui and C++, look at the GitHub issues, look at the Wiki, read docs/TODO.txt + and see how you want to help and can help! + - Disclose your usage of Dear ImGui via a dev blog post, a tweet, a screenshot, a mention somewhere etc. + You may post screenshot or links in the gallery threads. Visuals are ideal as they inspire other programmers. + But even without visuals, disclosing your use of dear imgui helps the library grow credibility, and help other teams and programmers with taking decisions. + - If you have issues or if you need to hack into the library, even if you don't expect any support it is useful that you share your issues (on GitHub or privately). + +*/ + +//------------------------------------------------------------------------- +// [SECTION] INCLUDES +//------------------------------------------------------------------------- + +#if defined(_MSC_VER) && !defined(_CRT_SECURE_NO_WARNINGS) +#define _CRT_SECURE_NO_WARNINGS +#endif + +#include "imgui.h" +#ifndef IMGUI_DISABLE + +#ifndef IMGUI_DEFINE_MATH_OPERATORS +#define IMGUI_DEFINE_MATH_OPERATORS +#endif +#include "imgui_internal.h" + +// System includes +#include // toupper +#include // vsnprintf, sscanf, printf +#if defined(_MSC_VER) && _MSC_VER <= 1500 // MSVC 2008 or earlier +#include // intptr_t +#else +#include // intptr_t +#endif + +// [Windows] On non-Visual Studio compilers, we default to IMGUI_DISABLE_WIN32_DEFAULT_IME_FUNCTIONS unless explicitly enabled +#if defined(_WIN32) && !defined(_MSC_VER) && !defined(IMGUI_ENABLE_WIN32_DEFAULT_IME_FUNCTIONS) && !defined(IMGUI_DISABLE_WIN32_DEFAULT_IME_FUNCTIONS) +#define IMGUI_DISABLE_WIN32_DEFAULT_IME_FUNCTIONS +#endif + +// [Windows] OS specific includes (optional) +#if defined(_WIN32) && defined(IMGUI_DISABLE_DEFAULT_FILE_FUNCTIONS) && defined(IMGUI_DISABLE_WIN32_DEFAULT_CLIPBOARD_FUNCTIONS) && defined(IMGUI_DISABLE_WIN32_DEFAULT_IME_FUNCTIONS) && !defined(IMGUI_DISABLE_WIN32_FUNCTIONS) +#define IMGUI_DISABLE_WIN32_FUNCTIONS +#endif +#if defined(_WIN32) && !defined(IMGUI_DISABLE_WIN32_FUNCTIONS) +#ifndef WIN32_LEAN_AND_MEAN +#define WIN32_LEAN_AND_MEAN +#endif +#ifndef NOMINMAX +#define NOMINMAX +#endif +#ifndef __MINGW32__ +#include // _wfopen, OpenClipboard +#else +#include +#endif +#if defined(WINAPI_FAMILY) && (WINAPI_FAMILY == WINAPI_FAMILY_APP) // UWP doesn't have all Win32 functions +#define IMGUI_DISABLE_WIN32_DEFAULT_CLIPBOARD_FUNCTIONS +#define IMGUI_DISABLE_WIN32_DEFAULT_IME_FUNCTIONS +#endif +#endif + +// [Apple] OS specific includes +#if defined(__APPLE__) +#include +#endif + +// Visual Studio warnings +#ifdef _MSC_VER +#pragma warning (disable: 4127) // condition expression is constant +#pragma warning (disable: 4996) // 'This function or variable may be unsafe': strcpy, strdup, sprintf, vsnprintf, sscanf, fopen +#if defined(_MSC_VER) && _MSC_VER >= 1922 // MSVC 2019 16.2 or later +#pragma warning (disable: 5054) // operator '|': deprecated between enumerations of different types +#endif +#pragma warning (disable: 26451) // [Static Analyzer] Arithmetic overflow : Using operator 'xxx' on a 4 byte value and then casting the result to a 8 byte value. Cast the value to the wider type before calling operator 'xxx' to avoid overflow(io.2). +#pragma warning (disable: 26495) // [Static Analyzer] Variable 'XXX' is uninitialized. Always initialize a member variable (type.6). +#pragma warning (disable: 26812) // [Static Analyzer] The enum type 'xxx' is unscoped. Prefer 'enum class' over 'enum' (Enum.3). +#endif + +// Clang/GCC warnings with -Weverything +#if defined(__clang__) +#if __has_warning("-Wunknown-warning-option") +#pragma clang diagnostic ignored "-Wunknown-warning-option" // warning: unknown warning group 'xxx' // not all warnings are known by all Clang versions and they tend to be rename-happy.. so ignoring warnings triggers new warnings on some configuration. Great! +#endif +#pragma clang diagnostic ignored "-Wunknown-pragmas" // warning: unknown warning group 'xxx' +#pragma clang diagnostic ignored "-Wold-style-cast" // warning: use of old-style cast // yes, they are more terse. +#pragma clang diagnostic ignored "-Wfloat-equal" // warning: comparing floating point with == or != is unsafe // storing and comparing against same constants (typically 0.0f) is ok. +#pragma clang diagnostic ignored "-Wformat-nonliteral" // warning: format string is not a string literal // passing non-literal to vsnformat(). yes, user passing incorrect format strings can crash the code. +#pragma clang diagnostic ignored "-Wexit-time-destructors" // warning: declaration requires an exit-time destructor // exit-time destruction order is undefined. if MemFree() leads to users code that has been disabled before exit it might cause problems. ImGui coding style welcomes static/globals. +#pragma clang diagnostic ignored "-Wglobal-constructors" // warning: declaration requires a global destructor // similar to above, not sure what the exact difference is. +#pragma clang diagnostic ignored "-Wsign-conversion" // warning: implicit conversion changes signedness +#pragma clang diagnostic ignored "-Wformat-pedantic" // warning: format specifies type 'void *' but the argument has type 'xxxx *' // unreasonable, would lead to casting every %p arg to void*. probably enabled by -pedantic. +#pragma clang diagnostic ignored "-Wint-to-void-pointer-cast" // warning: cast to 'void *' from smaller integer type 'int' +#pragma clang diagnostic ignored "-Wzero-as-null-pointer-constant" // warning: zero as null pointer constant // some standard header variations use #define NULL 0 +#pragma clang diagnostic ignored "-Wdouble-promotion" // warning: implicit conversion from 'float' to 'double' when passing argument to function // using printf() is a misery with this as C++ va_arg ellipsis changes float to double. +#pragma clang diagnostic ignored "-Wimplicit-int-float-conversion" // warning: implicit conversion from 'xxx' to 'float' may lose precision +#elif defined(__GNUC__) +// We disable -Wpragmas because GCC doesn't provide an has_warning equivalent and some forks/patches may not following the warning/version association. +#pragma GCC diagnostic ignored "-Wpragmas" // warning: unknown option after '#pragma GCC diagnostic' kind +#pragma GCC diagnostic ignored "-Wunused-function" // warning: 'xxxx' defined but not used +#pragma GCC diagnostic ignored "-Wint-to-pointer-cast" // warning: cast to pointer from integer of different size +#pragma GCC diagnostic ignored "-Wformat" // warning: format '%p' expects argument of type 'void*', but argument 6 has type 'ImGuiWindow*' +#pragma GCC diagnostic ignored "-Wdouble-promotion" // warning: implicit conversion from 'float' to 'double' when passing argument to function +#pragma GCC diagnostic ignored "-Wconversion" // warning: conversion to 'xxxx' from 'xxxx' may alter its value +#pragma GCC diagnostic ignored "-Wformat-nonliteral" // warning: format not a string literal, format string not checked +#pragma GCC diagnostic ignored "-Wstrict-overflow" // warning: assuming signed overflow does not occur when assuming that (X - c) > X is always false +#pragma GCC diagnostic ignored "-Wclass-memaccess" // [__GNUC__ >= 8] warning: 'memset/memcpy' clearing/writing an object of type 'xxxx' with no trivial copy-assignment; use assignment or value-initialization instead +#endif + +// Debug options +#define IMGUI_DEBUG_NAV_SCORING 0 // Display navigation scoring preview when hovering items. Display last moving direction matches when holding CTRL +#define IMGUI_DEBUG_NAV_RECTS 0 // Display the reference navigation rectangle for each window +#define IMGUI_DEBUG_INI_SETTINGS 0 // Save additional comments in .ini file (particularly helps for Docking, but makes saving slower) + +// When using CTRL+TAB (or Gamepad Square+L/R) we delay the visual a little in order to reduce visual noise doing a fast switch. +static const float NAV_WINDOWING_HIGHLIGHT_DELAY = 0.20f; // Time before the highlight and screen dimming starts fading in +static const float NAV_WINDOWING_LIST_APPEAR_DELAY = 0.15f; // Time before the window list starts to appear + +// Window resizing from edges (when io.ConfigWindowsResizeFromEdges = true and ImGuiBackendFlags_HasMouseCursors is set in io.BackendFlags by backend) +static const float WINDOWS_HOVER_PADDING = 4.0f; // Extend outside window for hovering/resizing (maxxed with TouchPadding) and inside windows for borders. Affect FindHoveredWindow(). +static const float WINDOWS_RESIZE_FROM_EDGES_FEEDBACK_TIMER = 0.04f; // Reduce visual noise by only highlighting the border after a certain time. +static const float WINDOWS_MOUSE_WHEEL_SCROLL_LOCK_TIMER = 2.00f; // Lock scrolled window (so it doesn't pick child windows that are scrolling through) for a certain time, unless mouse moved. + +//------------------------------------------------------------------------- +// [SECTION] FORWARD DECLARATIONS +//------------------------------------------------------------------------- + +static void SetCurrentWindow(ImGuiWindow* window); +static void FindHoveredWindow(); +static ImGuiWindow* CreateNewWindow(const char* name, ImGuiWindowFlags flags); +static ImVec2 CalcNextScrollFromScrollTargetAndClamp(ImGuiWindow* window); + +static void AddDrawListToDrawData(ImVector* out_list, ImDrawList* draw_list); +static void AddWindowToSortBuffer(ImVector* out_sorted_windows, ImGuiWindow* window); + +// Settings +static void WindowSettingsHandler_ClearAll(ImGuiContext*, ImGuiSettingsHandler*); +static void* WindowSettingsHandler_ReadOpen(ImGuiContext*, ImGuiSettingsHandler*, const char* name); +static void WindowSettingsHandler_ReadLine(ImGuiContext*, ImGuiSettingsHandler*, void* entry, const char* line); +static void WindowSettingsHandler_ApplyAll(ImGuiContext*, ImGuiSettingsHandler*); +static void WindowSettingsHandler_WriteAll(ImGuiContext*, ImGuiSettingsHandler*, ImGuiTextBuffer* buf); + +// Platform Dependents default implementation for IO functions +static const char* GetClipboardTextFn_DefaultImpl(void* user_data); +static void SetClipboardTextFn_DefaultImpl(void* user_data, const char* text); +static void ImeSetInputScreenPosFn_DefaultImpl(int x, int y); + +namespace ImGui +{ +// Navigation +static void NavUpdate(); +static void NavUpdateWindowing(); +static void NavUpdateWindowingOverlay(); +static void NavUpdateCancelRequest(); +static void NavUpdateCreateMoveRequest(); +static float NavUpdatePageUpPageDown(); +static inline void NavUpdateAnyRequestFlag(); +static void NavEndFrame(); +static bool NavScoreItem(ImGuiNavItemData* result); +static void NavApplyItemToResult(ImGuiNavItemData* result); +static void NavProcessItem(); +static ImVec2 NavCalcPreferredRefPos(); +static void NavSaveLastChildNavWindowIntoParent(ImGuiWindow* nav_window); +static ImGuiWindow* NavRestoreLastChildNavWindow(ImGuiWindow* window); +static void NavRestoreLayer(ImGuiNavLayer layer); +static int FindWindowFocusIndex(ImGuiWindow* window); + +// Error Checking +static void ErrorCheckNewFrameSanityChecks(); +static void ErrorCheckEndFrameSanityChecks(); + +// Misc +static void UpdateSettings(); +static void UpdateMouseInputs(); +static void UpdateMouseWheel(); +static void UpdateTabFocus(); +static void UpdateDebugToolItemPicker(); +static bool UpdateWindowManualResize(ImGuiWindow* window, const ImVec2& size_auto_fit, int* border_held, int resize_grip_count, ImU32 resize_grip_col[4], const ImRect& visibility_rect); +static void RenderWindowOuterBorders(ImGuiWindow* window); +static void RenderWindowDecorations(ImGuiWindow* window, const ImRect& title_bar_rect, bool title_bar_is_highlight, int resize_grip_count, const ImU32 resize_grip_col[4], float resize_grip_draw_size); +static void RenderWindowTitleBarContents(ImGuiWindow* window, const ImRect& title_bar_rect, const char* name, bool* p_open); + +// Viewports +static void UpdateViewportsNewFrame(); + +} + +//----------------------------------------------------------------------------- +// [SECTION] CONTEXT AND MEMORY ALLOCATORS +//----------------------------------------------------------------------------- + +// DLL users: +// - Heaps and globals are not shared across DLL boundaries! +// - You will need to call SetCurrentContext() + SetAllocatorFunctions() for each static/DLL boundary you are calling from. +// - Same applies for hot-reloading mechanisms that are reliant on reloading DLL (note that many hot-reloading mechanisms work without DLL). +// - Using Dear ImGui via a shared library is not recommended, because of function call overhead and because we don't guarantee backward nor forward ABI compatibility. +// - Confused? In a debugger: add GImGui to your watch window and notice how its value changes depending on your current location (which DLL boundary you are in). + +// Current context pointer. Implicitly used by all Dear ImGui functions. Always assumed to be != NULL. +// - ImGui::CreateContext() will automatically set this pointer if it is NULL. +// Change to a different context by calling ImGui::SetCurrentContext(). +// - Important: Dear ImGui functions are not thread-safe because of this pointer. +// If you want thread-safety to allow N threads to access N different contexts: +// - Change this variable to use thread local storage so each thread can refer to a different context, in your imconfig.h: +// struct ImGuiContext; +// extern thread_local ImGuiContext* MyImGuiTLS; +// #define GImGui MyImGuiTLS +// And then define MyImGuiTLS in one of your cpp files. Note that thread_local is a C++11 keyword, earlier C++ uses compiler-specific keyword. +// - Future development aims to make this context pointer explicit to all calls. Also read https://github.com/ocornut/imgui/issues/586 +// - If you need a finite number of contexts, you may compile and use multiple instances of the ImGui code from a different namespace. +// - DLL users: read comments above. +#ifndef GImGui +ImGuiContext* GImGui = NULL; +#endif + +// Memory Allocator functions. Use SetAllocatorFunctions() to change them. +// - You probably don't want to modify that mid-program, and if you use global/static e.g. ImVector<> instances you may need to keep them accessible during program destruction. +// - DLL users: read comments above. +#ifndef IMGUI_DISABLE_DEFAULT_ALLOCATORS +static void* MallocWrapper(size_t size, void* user_data) { IM_UNUSED(user_data); return malloc(size); } +static void FreeWrapper(void* ptr, void* user_data) { IM_UNUSED(user_data); free(ptr); } +#else +static void* MallocWrapper(size_t size, void* user_data) { IM_UNUSED(user_data); IM_UNUSED(size); IM_ASSERT(0); return NULL; } +static void FreeWrapper(void* ptr, void* user_data) { IM_UNUSED(user_data); IM_UNUSED(ptr); IM_ASSERT(0); } +#endif +static ImGuiMemAllocFunc GImAllocatorAllocFunc = MallocWrapper; +static ImGuiMemFreeFunc GImAllocatorFreeFunc = FreeWrapper; +static void* GImAllocatorUserData = NULL; + +//----------------------------------------------------------------------------- +// [SECTION] USER FACING STRUCTURES (ImGuiStyle, ImGuiIO) +//----------------------------------------------------------------------------- + +ImGuiStyle::ImGuiStyle() +{ + Alpha = 1.0f; // Global alpha applies to everything in Dear ImGui. + DisabledAlpha = 0.60f; // Additional alpha multiplier applied by BeginDisabled(). Multiply over current value of Alpha. + WindowPadding = ImVec2(8,8); // Padding within a window + WindowRounding = 0.0f; // Radius of window corners rounding. Set to 0.0f to have rectangular windows. Large values tend to lead to variety of artifacts and are not recommended. + WindowBorderSize = 1.0f; // Thickness of border around windows. Generally set to 0.0f or 1.0f. Other values not well tested. + WindowMinSize = ImVec2(32,32); // Minimum window size + WindowTitleAlign = ImVec2(0.0f,0.5f);// Alignment for title bar text + WindowMenuButtonPosition= ImGuiDir_Left; // Position of the collapsing/docking button in the title bar (left/right). Defaults to ImGuiDir_Left. + ChildRounding = 0.0f; // Radius of child window corners rounding. Set to 0.0f to have rectangular child windows + ChildBorderSize = 1.0f; // Thickness of border around child windows. Generally set to 0.0f or 1.0f. Other values not well tested. + PopupRounding = 0.0f; // Radius of popup window corners rounding. Set to 0.0f to have rectangular child windows + PopupBorderSize = 1.0f; // Thickness of border around popup or tooltip windows. Generally set to 0.0f or 1.0f. Other values not well tested. + FramePadding = ImVec2(4,3); // Padding within a framed rectangle (used by most widgets) + FrameRounding = 0.0f; // Radius of frame corners rounding. Set to 0.0f to have rectangular frames (used by most widgets). + FrameBorderSize = 0.0f; // Thickness of border around frames. Generally set to 0.0f or 1.0f. Other values not well tested. + ItemSpacing = ImVec2(8,4); // Horizontal and vertical spacing between widgets/lines + ItemInnerSpacing = ImVec2(4,4); // Horizontal and vertical spacing between within elements of a composed widget (e.g. a slider and its label) + CellPadding = ImVec2(4,2); // Padding within a table cell + TouchExtraPadding = ImVec2(0,0); // Expand reactive bounding box for touch-based system where touch position is not accurate enough. Unfortunately we don't sort widgets so priority on overlap will always be given to the first widget. So don't grow this too much! + IndentSpacing = 21.0f; // Horizontal spacing when e.g. entering a tree node. Generally == (FontSize + FramePadding.x*2). + ColumnsMinSpacing = 6.0f; // Minimum horizontal spacing between two columns. Preferably > (FramePadding.x + 1). + ScrollbarSize = 14.0f; // Width of the vertical scrollbar, Height of the horizontal scrollbar + ScrollbarRounding = 9.0f; // Radius of grab corners rounding for scrollbar + GrabMinSize = 10.0f; // Minimum width/height of a grab box for slider/scrollbar + GrabRounding = 0.0f; // Radius of grabs corners rounding. Set to 0.0f to have rectangular slider grabs. + LogSliderDeadzone = 4.0f; // The size in pixels of the dead-zone around zero on logarithmic sliders that cross zero. + TabRounding = 4.0f; // Radius of upper corners of a tab. Set to 0.0f to have rectangular tabs. + TabBorderSize = 0.0f; // Thickness of border around tabs. + TabMinWidthForCloseButton = 0.0f; // Minimum width for close button to appears on an unselected tab when hovered. Set to 0.0f to always show when hovering, set to FLT_MAX to never show close button unless selected. + ColorButtonPosition = ImGuiDir_Right; // Side of the color button in the ColorEdit4 widget (left/right). Defaults to ImGuiDir_Right. + ButtonTextAlign = ImVec2(0.5f,0.5f);// Alignment of button text when button is larger than text. + SelectableTextAlign = ImVec2(0.0f,0.0f);// Alignment of selectable text. Defaults to (0.0f, 0.0f) (top-left aligned). It's generally important to keep this left-aligned if you want to lay multiple items on a same line. + DisplayWindowPadding = ImVec2(19,19); // Window position are clamped to be visible within the display area or monitors by at least this amount. Only applies to regular windows. + DisplaySafeAreaPadding = ImVec2(3,3); // If you cannot see the edge of your screen (e.g. on a TV) increase the safe area padding. Covers popups/tooltips as well regular windows. + MouseCursorScale = 1.0f; // Scale software rendered mouse cursor (when io.MouseDrawCursor is enabled). May be removed later. + AntiAliasedLines = true; // Enable anti-aliased lines/borders. Disable if you are really tight on CPU/GPU. + AntiAliasedLinesUseTex = true; // Enable anti-aliased lines/borders using textures where possible. Require backend to render with bilinear filtering. + AntiAliasedFill = true; // Enable anti-aliased filled shapes (rounded rectangles, circles, etc.). + CurveTessellationTol = 1.25f; // Tessellation tolerance when using PathBezierCurveTo() without a specific number of segments. Decrease for highly tessellated curves (higher quality, more polygons), increase to reduce quality. + CircleTessellationMaxError = 0.30f; // Maximum error (in pixels) allowed when using AddCircle()/AddCircleFilled() or drawing rounded corner rectangles with no explicit segment count specified. Decrease for higher quality but more geometry. + + // Default theme + ImGui::StyleColorsDark(this); +} + +// To scale your entire UI (e.g. if you want your app to use High DPI or generally be DPI aware) you may use this helper function. Scaling the fonts is done separately and is up to you. +// Important: This operation is lossy because we round all sizes to integer. If you need to change your scale multiples, call this over a freshly initialized ImGuiStyle structure rather than scaling multiple times. +void ImGuiStyle::ScaleAllSizes(float scale_factor) +{ + WindowPadding = ImFloor(WindowPadding * scale_factor); + WindowRounding = ImFloor(WindowRounding * scale_factor); + WindowMinSize = ImFloor(WindowMinSize * scale_factor); + ChildRounding = ImFloor(ChildRounding * scale_factor); + PopupRounding = ImFloor(PopupRounding * scale_factor); + FramePadding = ImFloor(FramePadding * scale_factor); + FrameRounding = ImFloor(FrameRounding * scale_factor); + ItemSpacing = ImFloor(ItemSpacing * scale_factor); + ItemInnerSpacing = ImFloor(ItemInnerSpacing * scale_factor); + CellPadding = ImFloor(CellPadding * scale_factor); + TouchExtraPadding = ImFloor(TouchExtraPadding * scale_factor); + IndentSpacing = ImFloor(IndentSpacing * scale_factor); + ColumnsMinSpacing = ImFloor(ColumnsMinSpacing * scale_factor); + ScrollbarSize = ImFloor(ScrollbarSize * scale_factor); + ScrollbarRounding = ImFloor(ScrollbarRounding * scale_factor); + GrabMinSize = ImFloor(GrabMinSize * scale_factor); + GrabRounding = ImFloor(GrabRounding * scale_factor); + LogSliderDeadzone = ImFloor(LogSliderDeadzone * scale_factor); + TabRounding = ImFloor(TabRounding * scale_factor); + TabMinWidthForCloseButton = (TabMinWidthForCloseButton != FLT_MAX) ? ImFloor(TabMinWidthForCloseButton * scale_factor) : FLT_MAX; + DisplayWindowPadding = ImFloor(DisplayWindowPadding * scale_factor); + DisplaySafeAreaPadding = ImFloor(DisplaySafeAreaPadding * scale_factor); + MouseCursorScale = ImFloor(MouseCursorScale * scale_factor); +} + +ImGuiIO::ImGuiIO() +{ + // Most fields are initialized with zero + memset(this, 0, sizeof(*this)); + IM_ASSERT(IM_ARRAYSIZE(ImGuiIO::MouseDown) == ImGuiMouseButton_COUNT && IM_ARRAYSIZE(ImGuiIO::MouseClicked) == ImGuiMouseButton_COUNT); // Our pre-C++11 IM_STATIC_ASSERT() macros triggers warning on modern compilers so we don't use it here. + + // Settings + ConfigFlags = ImGuiConfigFlags_None; + BackendFlags = ImGuiBackendFlags_None; + DisplaySize = ImVec2(-1.0f, -1.0f); + DeltaTime = 1.0f / 60.0f; + IniSavingRate = 5.0f; + IniFilename = "imgui.ini"; // Important: "imgui.ini" is relative to current working dir, most apps will want to lock this to an absolute path (e.g. same path as executables). + LogFilename = "imgui_log.txt"; + MouseDoubleClickTime = 0.30f; + MouseDoubleClickMaxDist = 6.0f; + for (int i = 0; i < ImGuiKey_COUNT; i++) + KeyMap[i] = -1; + KeyRepeatDelay = 0.275f; + KeyRepeatRate = 0.050f; + UserData = NULL; + + Fonts = NULL; + FontGlobalScale = 1.0f; + FontDefault = NULL; + FontAllowUserScaling = false; + DisplayFramebufferScale = ImVec2(1.0f, 1.0f); + + // Miscellaneous options + MouseDrawCursor = false; +#ifdef __APPLE__ + ConfigMacOSXBehaviors = true; // Set Mac OS X style defaults based on __APPLE__ compile time flag +#else + ConfigMacOSXBehaviors = false; +#endif + ConfigInputTextCursorBlink = true; + ConfigWindowsResizeFromEdges = true; + ConfigWindowsMoveFromTitleBarOnly = false; + ConfigMemoryCompactTimer = 60.0f; + + // Platform Functions + BackendPlatformName = BackendRendererName = NULL; + BackendPlatformUserData = BackendRendererUserData = BackendLanguageUserData = NULL; + GetClipboardTextFn = GetClipboardTextFn_DefaultImpl; // Platform dependent default implementations + SetClipboardTextFn = SetClipboardTextFn_DefaultImpl; + ClipboardUserData = NULL; + ImeSetInputScreenPosFn = ImeSetInputScreenPosFn_DefaultImpl; + ImeWindowHandle = NULL; + + // Input (NB: we already have memset zero the entire structure!) + MousePos = ImVec2(-FLT_MAX, -FLT_MAX); + MousePosPrev = ImVec2(-FLT_MAX, -FLT_MAX); + MouseDragThreshold = 6.0f; + for (int i = 0; i < IM_ARRAYSIZE(MouseDownDuration); i++) MouseDownDuration[i] = MouseDownDurationPrev[i] = -1.0f; + for (int i = 0; i < IM_ARRAYSIZE(KeysDownDuration); i++) KeysDownDuration[i] = KeysDownDurationPrev[i] = -1.0f; + for (int i = 0; i < IM_ARRAYSIZE(NavInputsDownDuration); i++) NavInputsDownDuration[i] = -1.0f; +} + +// Pass in translated ASCII characters for text input. +// - with glfw you can get those from the callback set in glfwSetCharCallback() +// - on Windows you can get those using ToAscii+keyboard state, or via the WM_CHAR message +void ImGuiIO::AddInputCharacter(unsigned int c) +{ + if (c != 0) + InputQueueCharacters.push_back(c <= IM_UNICODE_CODEPOINT_MAX ? (ImWchar)c : IM_UNICODE_CODEPOINT_INVALID); +} + +// UTF16 strings use surrogate pairs to encode codepoints >= 0x10000, so +// we should save the high surrogate. +void ImGuiIO::AddInputCharacterUTF16(ImWchar16 c) +{ + if (c == 0 && InputQueueSurrogate == 0) + return; + + if ((c & 0xFC00) == 0xD800) // High surrogate, must save + { + if (InputQueueSurrogate != 0) + InputQueueCharacters.push_back(IM_UNICODE_CODEPOINT_INVALID); + InputQueueSurrogate = c; + return; + } + + ImWchar cp = c; + if (InputQueueSurrogate != 0) + { + if ((c & 0xFC00) != 0xDC00) // Invalid low surrogate + { + InputQueueCharacters.push_back(IM_UNICODE_CODEPOINT_INVALID); + } + else + { +#if IM_UNICODE_CODEPOINT_MAX == 0xFFFF + cp = IM_UNICODE_CODEPOINT_INVALID; // Codepoint will not fit in ImWchar +#else + cp = (ImWchar)(((InputQueueSurrogate - 0xD800) << 10) + (c - 0xDC00) + 0x10000); +#endif + } + + InputQueueSurrogate = 0; + } + InputQueueCharacters.push_back(cp); +} + +void ImGuiIO::AddInputCharactersUTF8(const char* utf8_chars) +{ + while (*utf8_chars != 0) + { + unsigned int c = 0; + utf8_chars += ImTextCharFromUtf8(&c, utf8_chars, NULL); + if (c != 0) + InputQueueCharacters.push_back((ImWchar)c); + } +} + +void ImGuiIO::ClearInputCharacters() +{ + InputQueueCharacters.resize(0); +} + +void ImGuiIO::AddFocusEvent(bool focused) +{ + if (focused) + return; + + // Clear buttons state when focus is lost + // (this is useful so e.g. releasing Alt after focus loss on Alt-Tab doesn't trigger the Alt menu toggle) + memset(KeysDown, 0, sizeof(KeysDown)); + for (int n = 0; n < IM_ARRAYSIZE(KeysDownDuration); n++) + KeysDownDuration[n] = KeysDownDurationPrev[n] = -1.0f; + KeyCtrl = KeyShift = KeyAlt = KeySuper = false; + KeyMods = KeyModsPrev = ImGuiKeyModFlags_None; + for (int n = 0; n < IM_ARRAYSIZE(NavInputsDownDuration); n++) + NavInputsDownDuration[n] = NavInputsDownDurationPrev[n] = -1.0f; +} + +//----------------------------------------------------------------------------- +// [SECTION] MISC HELPERS/UTILITIES (Geometry functions) +//----------------------------------------------------------------------------- + +ImVec2 ImBezierCubicClosestPoint(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, const ImVec2& p, int num_segments) +{ + IM_ASSERT(num_segments > 0); // Use ImBezierCubicClosestPointCasteljau() + ImVec2 p_last = p1; + ImVec2 p_closest; + float p_closest_dist2 = FLT_MAX; + float t_step = 1.0f / (float)num_segments; + for (int i_step = 1; i_step <= num_segments; i_step++) + { + ImVec2 p_current = ImBezierCubicCalc(p1, p2, p3, p4, t_step * i_step); + ImVec2 p_line = ImLineClosestPoint(p_last, p_current, p); + float dist2 = ImLengthSqr(p - p_line); + if (dist2 < p_closest_dist2) + { + p_closest = p_line; + p_closest_dist2 = dist2; + } + p_last = p_current; + } + return p_closest; +} + +// Closely mimics PathBezierToCasteljau() in imgui_draw.cpp +static void ImBezierCubicClosestPointCasteljauStep(const ImVec2& p, ImVec2& p_closest, ImVec2& p_last, float& p_closest_dist2, float x1, float y1, float x2, float y2, float x3, float y3, float x4, float y4, float tess_tol, int level) +{ + float dx = x4 - x1; + float dy = y4 - y1; + float d2 = ((x2 - x4) * dy - (y2 - y4) * dx); + float d3 = ((x3 - x4) * dy - (y3 - y4) * dx); + d2 = (d2 >= 0) ? d2 : -d2; + d3 = (d3 >= 0) ? d3 : -d3; + if ((d2 + d3) * (d2 + d3) < tess_tol * (dx * dx + dy * dy)) + { + ImVec2 p_current(x4, y4); + ImVec2 p_line = ImLineClosestPoint(p_last, p_current, p); + float dist2 = ImLengthSqr(p - p_line); + if (dist2 < p_closest_dist2) + { + p_closest = p_line; + p_closest_dist2 = dist2; + } + p_last = p_current; + } + else if (level < 10) + { + float x12 = (x1 + x2)*0.5f, y12 = (y1 + y2)*0.5f; + float x23 = (x2 + x3)*0.5f, y23 = (y2 + y3)*0.5f; + float x34 = (x3 + x4)*0.5f, y34 = (y3 + y4)*0.5f; + float x123 = (x12 + x23)*0.5f, y123 = (y12 + y23)*0.5f; + float x234 = (x23 + x34)*0.5f, y234 = (y23 + y34)*0.5f; + float x1234 = (x123 + x234)*0.5f, y1234 = (y123 + y234)*0.5f; + ImBezierCubicClosestPointCasteljauStep(p, p_closest, p_last, p_closest_dist2, x1, y1, x12, y12, x123, y123, x1234, y1234, tess_tol, level + 1); + ImBezierCubicClosestPointCasteljauStep(p, p_closest, p_last, p_closest_dist2, x1234, y1234, x234, y234, x34, y34, x4, y4, tess_tol, level + 1); + } +} + +// tess_tol is generally the same value you would find in ImGui::GetStyle().CurveTessellationTol +// Because those ImXXX functions are lower-level than ImGui:: we cannot access this value automatically. +ImVec2 ImBezierCubicClosestPointCasteljau(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, const ImVec2& p, float tess_tol) +{ + IM_ASSERT(tess_tol > 0.0f); + ImVec2 p_last = p1; + ImVec2 p_closest; + float p_closest_dist2 = FLT_MAX; + ImBezierCubicClosestPointCasteljauStep(p, p_closest, p_last, p_closest_dist2, p1.x, p1.y, p2.x, p2.y, p3.x, p3.y, p4.x, p4.y, tess_tol, 0); + return p_closest; +} + +ImVec2 ImLineClosestPoint(const ImVec2& a, const ImVec2& b, const ImVec2& p) +{ + ImVec2 ap = p - a; + ImVec2 ab_dir = b - a; + float dot = ap.x * ab_dir.x + ap.y * ab_dir.y; + if (dot < 0.0f) + return a; + float ab_len_sqr = ab_dir.x * ab_dir.x + ab_dir.y * ab_dir.y; + if (dot > ab_len_sqr) + return b; + return a + ab_dir * dot / ab_len_sqr; +} + +bool ImTriangleContainsPoint(const ImVec2& a, const ImVec2& b, const ImVec2& c, const ImVec2& p) +{ + bool b1 = ((p.x - b.x) * (a.y - b.y) - (p.y - b.y) * (a.x - b.x)) < 0.0f; + bool b2 = ((p.x - c.x) * (b.y - c.y) - (p.y - c.y) * (b.x - c.x)) < 0.0f; + bool b3 = ((p.x - a.x) * (c.y - a.y) - (p.y - a.y) * (c.x - a.x)) < 0.0f; + return ((b1 == b2) && (b2 == b3)); +} + +void ImTriangleBarycentricCoords(const ImVec2& a, const ImVec2& b, const ImVec2& c, const ImVec2& p, float& out_u, float& out_v, float& out_w) +{ + ImVec2 v0 = b - a; + ImVec2 v1 = c - a; + ImVec2 v2 = p - a; + const float denom = v0.x * v1.y - v1.x * v0.y; + out_v = (v2.x * v1.y - v1.x * v2.y) / denom; + out_w = (v0.x * v2.y - v2.x * v0.y) / denom; + out_u = 1.0f - out_v - out_w; +} + +ImVec2 ImTriangleClosestPoint(const ImVec2& a, const ImVec2& b, const ImVec2& c, const ImVec2& p) +{ + ImVec2 proj_ab = ImLineClosestPoint(a, b, p); + ImVec2 proj_bc = ImLineClosestPoint(b, c, p); + ImVec2 proj_ca = ImLineClosestPoint(c, a, p); + float dist2_ab = ImLengthSqr(p - proj_ab); + float dist2_bc = ImLengthSqr(p - proj_bc); + float dist2_ca = ImLengthSqr(p - proj_ca); + float m = ImMin(dist2_ab, ImMin(dist2_bc, dist2_ca)); + if (m == dist2_ab) + return proj_ab; + if (m == dist2_bc) + return proj_bc; + return proj_ca; +} + +//----------------------------------------------------------------------------- +// [SECTION] MISC HELPERS/UTILITIES (String, Format, Hash functions) +//----------------------------------------------------------------------------- + +// Consider using _stricmp/_strnicmp under Windows or strcasecmp/strncasecmp. We don't actually use either ImStricmp/ImStrnicmp in the codebase any more. +int ImStricmp(const char* str1, const char* str2) +{ + int d; + while ((d = toupper(*str2) - toupper(*str1)) == 0 && *str1) { str1++; str2++; } + return d; +} + +int ImStrnicmp(const char* str1, const char* str2, size_t count) +{ + int d = 0; + while (count > 0 && (d = toupper(*str2) - toupper(*str1)) == 0 && *str1) { str1++; str2++; count--; } + return d; +} + +void ImStrncpy(char* dst, const char* src, size_t count) +{ + if (count < 1) + return; + if (count > 1) + strncpy(dst, src, count - 1); + dst[count - 1] = 0; +} + +char* ImStrdup(const char* str) +{ + size_t len = strlen(str); + void* buf = IM_ALLOC(len + 1); + return (char*)memcpy(buf, (const void*)str, len + 1); +} + +char* ImStrdupcpy(char* dst, size_t* p_dst_size, const char* src) +{ + size_t dst_buf_size = p_dst_size ? *p_dst_size : strlen(dst) + 1; + size_t src_size = strlen(src) + 1; + if (dst_buf_size < src_size) + { + IM_FREE(dst); + dst = (char*)IM_ALLOC(src_size); + if (p_dst_size) + *p_dst_size = src_size; + } + return (char*)memcpy(dst, (const void*)src, src_size); +} + +const char* ImStrchrRange(const char* str, const char* str_end, char c) +{ + const char* p = (const char*)memchr(str, (int)c, str_end - str); + return p; +} + +int ImStrlenW(const ImWchar* str) +{ + //return (int)wcslen((const wchar_t*)str); // FIXME-OPT: Could use this when wchar_t are 16-bit + int n = 0; + while (*str++) n++; + return n; +} + +// Find end-of-line. Return pointer will point to either first \n, either str_end. +const char* ImStreolRange(const char* str, const char* str_end) +{ + const char* p = (const char*)memchr(str, '\n', str_end - str); + return p ? p : str_end; +} + +const ImWchar* ImStrbolW(const ImWchar* buf_mid_line, const ImWchar* buf_begin) // find beginning-of-line +{ + while (buf_mid_line > buf_begin && buf_mid_line[-1] != '\n') + buf_mid_line--; + return buf_mid_line; +} + +const char* ImStristr(const char* haystack, const char* haystack_end, const char* needle, const char* needle_end) +{ + if (!needle_end) + needle_end = needle + strlen(needle); + + const char un0 = (char)toupper(*needle); + while ((!haystack_end && *haystack) || (haystack_end && haystack < haystack_end)) + { + if (toupper(*haystack) == un0) + { + const char* b = needle + 1; + for (const char* a = haystack + 1; b < needle_end; a++, b++) + if (toupper(*a) != toupper(*b)) + break; + if (b == needle_end) + return haystack; + } + haystack++; + } + return NULL; +} + +// Trim str by offsetting contents when there's leading data + writing a \0 at the trailing position. We use this in situation where the cost is negligible. +void ImStrTrimBlanks(char* buf) +{ + char* p = buf; + while (p[0] == ' ' || p[0] == '\t') // Leading blanks + p++; + char* p_start = p; + while (*p != 0) // Find end of string + p++; + while (p > p_start && (p[-1] == ' ' || p[-1] == '\t')) // Trailing blanks + p--; + if (p_start != buf) // Copy memory if we had leading blanks + memmove(buf, p_start, p - p_start); + buf[p - p_start] = 0; // Zero terminate +} + +const char* ImStrSkipBlank(const char* str) +{ + while (str[0] == ' ' || str[0] == '\t') + str++; + return str; +} + +// A) MSVC version appears to return -1 on overflow, whereas glibc appears to return total count (which may be >= buf_size). +// Ideally we would test for only one of those limits at runtime depending on the behavior the vsnprintf(), but trying to deduct it at compile time sounds like a pandora can of worm. +// B) When buf==NULL vsnprintf() will return the output size. +#ifndef IMGUI_DISABLE_DEFAULT_FORMAT_FUNCTIONS + +// We support stb_sprintf which is much faster (see: https://github.com/nothings/stb/blob/master/stb_sprintf.h) +// You may set IMGUI_USE_STB_SPRINTF to use our default wrapper, or set IMGUI_DISABLE_DEFAULT_FORMAT_FUNCTIONS +// and setup the wrapper yourself. (FIXME-OPT: Some of our high-level operations such as ImGuiTextBuffer::appendfv() are +// designed using two-passes worst case, which probably could be improved using the stbsp_vsprintfcb() function.) +#ifdef IMGUI_USE_STB_SPRINTF +#define STB_SPRINTF_IMPLEMENTATION +#include "stb_sprintf.h" +#endif + +#if defined(_MSC_VER) && !defined(vsnprintf) +#define vsnprintf _vsnprintf +#endif + +int ImFormatString(char* buf, size_t buf_size, const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); +#ifdef IMGUI_USE_STB_SPRINTF + int w = stbsp_vsnprintf(buf, (int)buf_size, fmt, args); +#else + int w = vsnprintf(buf, buf_size, fmt, args); +#endif + va_end(args); + if (buf == NULL) + return w; + if (w == -1 || w >= (int)buf_size) + w = (int)buf_size - 1; + buf[w] = 0; + return w; +} + +int ImFormatStringV(char* buf, size_t buf_size, const char* fmt, va_list args) +{ +#ifdef IMGUI_USE_STB_SPRINTF + int w = stbsp_vsnprintf(buf, (int)buf_size, fmt, args); +#else + int w = vsnprintf(buf, buf_size, fmt, args); +#endif + if (buf == NULL) + return w; + if (w == -1 || w >= (int)buf_size) + w = (int)buf_size - 1; + buf[w] = 0; + return w; +} +#endif // #ifdef IMGUI_DISABLE_DEFAULT_FORMAT_FUNCTIONS + +// CRC32 needs a 1KB lookup table (not cache friendly) +// Although the code to generate the table is simple and shorter than the table itself, using a const table allows us to easily: +// - avoid an unnecessary branch/memory tap, - keep the ImHashXXX functions usable by static constructors, - make it thread-safe. +static const ImU32 GCrc32LookupTable[256] = +{ + 0x00000000,0x77073096,0xEE0E612C,0x990951BA,0x076DC419,0x706AF48F,0xE963A535,0x9E6495A3,0x0EDB8832,0x79DCB8A4,0xE0D5E91E,0x97D2D988,0x09B64C2B,0x7EB17CBD,0xE7B82D07,0x90BF1D91, + 0x1DB71064,0x6AB020F2,0xF3B97148,0x84BE41DE,0x1ADAD47D,0x6DDDE4EB,0xF4D4B551,0x83D385C7,0x136C9856,0x646BA8C0,0xFD62F97A,0x8A65C9EC,0x14015C4F,0x63066CD9,0xFA0F3D63,0x8D080DF5, + 0x3B6E20C8,0x4C69105E,0xD56041E4,0xA2677172,0x3C03E4D1,0x4B04D447,0xD20D85FD,0xA50AB56B,0x35B5A8FA,0x42B2986C,0xDBBBC9D6,0xACBCF940,0x32D86CE3,0x45DF5C75,0xDCD60DCF,0xABD13D59, + 0x26D930AC,0x51DE003A,0xC8D75180,0xBFD06116,0x21B4F4B5,0x56B3C423,0xCFBA9599,0xB8BDA50F,0x2802B89E,0x5F058808,0xC60CD9B2,0xB10BE924,0x2F6F7C87,0x58684C11,0xC1611DAB,0xB6662D3D, + 0x76DC4190,0x01DB7106,0x98D220BC,0xEFD5102A,0x71B18589,0x06B6B51F,0x9FBFE4A5,0xE8B8D433,0x7807C9A2,0x0F00F934,0x9609A88E,0xE10E9818,0x7F6A0DBB,0x086D3D2D,0x91646C97,0xE6635C01, + 0x6B6B51F4,0x1C6C6162,0x856530D8,0xF262004E,0x6C0695ED,0x1B01A57B,0x8208F4C1,0xF50FC457,0x65B0D9C6,0x12B7E950,0x8BBEB8EA,0xFCB9887C,0x62DD1DDF,0x15DA2D49,0x8CD37CF3,0xFBD44C65, + 0x4DB26158,0x3AB551CE,0xA3BC0074,0xD4BB30E2,0x4ADFA541,0x3DD895D7,0xA4D1C46D,0xD3D6F4FB,0x4369E96A,0x346ED9FC,0xAD678846,0xDA60B8D0,0x44042D73,0x33031DE5,0xAA0A4C5F,0xDD0D7CC9, + 0x5005713C,0x270241AA,0xBE0B1010,0xC90C2086,0x5768B525,0x206F85B3,0xB966D409,0xCE61E49F,0x5EDEF90E,0x29D9C998,0xB0D09822,0xC7D7A8B4,0x59B33D17,0x2EB40D81,0xB7BD5C3B,0xC0BA6CAD, + 0xEDB88320,0x9ABFB3B6,0x03B6E20C,0x74B1D29A,0xEAD54739,0x9DD277AF,0x04DB2615,0x73DC1683,0xE3630B12,0x94643B84,0x0D6D6A3E,0x7A6A5AA8,0xE40ECF0B,0x9309FF9D,0x0A00AE27,0x7D079EB1, + 0xF00F9344,0x8708A3D2,0x1E01F268,0x6906C2FE,0xF762575D,0x806567CB,0x196C3671,0x6E6B06E7,0xFED41B76,0x89D32BE0,0x10DA7A5A,0x67DD4ACC,0xF9B9DF6F,0x8EBEEFF9,0x17B7BE43,0x60B08ED5, + 0xD6D6A3E8,0xA1D1937E,0x38D8C2C4,0x4FDFF252,0xD1BB67F1,0xA6BC5767,0x3FB506DD,0x48B2364B,0xD80D2BDA,0xAF0A1B4C,0x36034AF6,0x41047A60,0xDF60EFC3,0xA867DF55,0x316E8EEF,0x4669BE79, + 0xCB61B38C,0xBC66831A,0x256FD2A0,0x5268E236,0xCC0C7795,0xBB0B4703,0x220216B9,0x5505262F,0xC5BA3BBE,0xB2BD0B28,0x2BB45A92,0x5CB36A04,0xC2D7FFA7,0xB5D0CF31,0x2CD99E8B,0x5BDEAE1D, + 0x9B64C2B0,0xEC63F226,0x756AA39C,0x026D930A,0x9C0906A9,0xEB0E363F,0x72076785,0x05005713,0x95BF4A82,0xE2B87A14,0x7BB12BAE,0x0CB61B38,0x92D28E9B,0xE5D5BE0D,0x7CDCEFB7,0x0BDBDF21, + 0x86D3D2D4,0xF1D4E242,0x68DDB3F8,0x1FDA836E,0x81BE16CD,0xF6B9265B,0x6FB077E1,0x18B74777,0x88085AE6,0xFF0F6A70,0x66063BCA,0x11010B5C,0x8F659EFF,0xF862AE69,0x616BFFD3,0x166CCF45, + 0xA00AE278,0xD70DD2EE,0x4E048354,0x3903B3C2,0xA7672661,0xD06016F7,0x4969474D,0x3E6E77DB,0xAED16A4A,0xD9D65ADC,0x40DF0B66,0x37D83BF0,0xA9BCAE53,0xDEBB9EC5,0x47B2CF7F,0x30B5FFE9, + 0xBDBDF21C,0xCABAC28A,0x53B39330,0x24B4A3A6,0xBAD03605,0xCDD70693,0x54DE5729,0x23D967BF,0xB3667A2E,0xC4614AB8,0x5D681B02,0x2A6F2B94,0xB40BBE37,0xC30C8EA1,0x5A05DF1B,0x2D02EF8D, +}; + +// Known size hash +// It is ok to call ImHashData on a string with known length but the ### operator won't be supported. +// FIXME-OPT: Replace with e.g. FNV1a hash? CRC32 pretty much randomly access 1KB. Need to do proper measurements. +ImGuiID ImHashData(const void* data_p, size_t data_size, ImU32 seed) +{ + ImU32 crc = ~seed; + const unsigned char* data = (const unsigned char*)data_p; + const ImU32* crc32_lut = GCrc32LookupTable; + while (data_size-- != 0) + crc = (crc >> 8) ^ crc32_lut[(crc & 0xFF) ^ *data++]; + return ~crc; +} + +// Zero-terminated string hash, with support for ### to reset back to seed value +// We support a syntax of "label###id" where only "###id" is included in the hash, and only "label" gets displayed. +// Because this syntax is rarely used we are optimizing for the common case. +// - If we reach ### in the string we discard the hash so far and reset to the seed. +// - We don't do 'current += 2; continue;' after handling ### to keep the code smaller/faster (measured ~10% diff in Debug build) +// FIXME-OPT: Replace with e.g. FNV1a hash? CRC32 pretty much randomly access 1KB. Need to do proper measurements. +ImGuiID ImHashStr(const char* data_p, size_t data_size, ImU32 seed) +{ + seed = ~seed; + ImU32 crc = seed; + const unsigned char* data = (const unsigned char*)data_p; + const ImU32* crc32_lut = GCrc32LookupTable; + if (data_size != 0) + { + while (data_size-- != 0) + { + unsigned char c = *data++; + if (c == '#' && data_size >= 2 && data[0] == '#' && data[1] == '#') + crc = seed; + crc = (crc >> 8) ^ crc32_lut[(crc & 0xFF) ^ c]; + } + } + else + { + while (unsigned char c = *data++) + { + if (c == '#' && data[0] == '#' && data[1] == '#') + crc = seed; + crc = (crc >> 8) ^ crc32_lut[(crc & 0xFF) ^ c]; + } + } + return ~crc; +} + +//----------------------------------------------------------------------------- +// [SECTION] MISC HELPERS/UTILITIES (File functions) +//----------------------------------------------------------------------------- + +// Default file functions +#ifndef IMGUI_DISABLE_DEFAULT_FILE_FUNCTIONS + +ImFileHandle ImFileOpen(const char* filename, const char* mode) +{ +#if defined(_WIN32) && !defined(IMGUI_DISABLE_WIN32_FUNCTIONS) && !defined(__CYGWIN__) && !defined(__GNUC__) + // We need a fopen() wrapper because MSVC/Windows fopen doesn't handle UTF-8 filenames. + // Previously we used ImTextCountCharsFromUtf8/ImTextStrFromUtf8 here but we now need to support ImWchar16 and ImWchar32! + const int filename_wsize = ::MultiByteToWideChar(CP_UTF8, 0, filename, -1, NULL, 0); + const int mode_wsize = ::MultiByteToWideChar(CP_UTF8, 0, mode, -1, NULL, 0); + ImVector buf; + buf.resize(filename_wsize + mode_wsize); + ::MultiByteToWideChar(CP_UTF8, 0, filename, -1, (wchar_t*)&buf[0], filename_wsize); + ::MultiByteToWideChar(CP_UTF8, 0, mode, -1, (wchar_t*)&buf[filename_wsize], mode_wsize); + return ::_wfopen((const wchar_t*)&buf[0], (const wchar_t*)&buf[filename_wsize]); +#else + return fopen(filename, mode); +#endif +} + +// We should in theory be using fseeko()/ftello() with off_t and _fseeki64()/_ftelli64() with __int64, waiting for the PR that does that in a very portable pre-C++11 zero-warnings way. +bool ImFileClose(ImFileHandle f) { return fclose(f) == 0; } +ImU64 ImFileGetSize(ImFileHandle f) { long off = 0, sz = 0; return ((off = ftell(f)) != -1 && !fseek(f, 0, SEEK_END) && (sz = ftell(f)) != -1 && !fseek(f, off, SEEK_SET)) ? (ImU64)sz : (ImU64)-1; } +ImU64 ImFileRead(void* data, ImU64 sz, ImU64 count, ImFileHandle f) { return fread(data, (size_t)sz, (size_t)count, f); } +ImU64 ImFileWrite(const void* data, ImU64 sz, ImU64 count, ImFileHandle f) { return fwrite(data, (size_t)sz, (size_t)count, f); } +#endif // #ifndef IMGUI_DISABLE_DEFAULT_FILE_FUNCTIONS + +// Helper: Load file content into memory +// Memory allocated with IM_ALLOC(), must be freed by user using IM_FREE() == ImGui::MemFree() +// This can't really be used with "rt" because fseek size won't match read size. +void* ImFileLoadToMemory(const char* filename, const char* mode, size_t* out_file_size, int padding_bytes) +{ + IM_ASSERT(filename && mode); + if (out_file_size) + *out_file_size = 0; + + ImFileHandle f; + if ((f = ImFileOpen(filename, mode)) == NULL) + return NULL; + + size_t file_size = (size_t)ImFileGetSize(f); + if (file_size == (size_t)-1) + { + ImFileClose(f); + return NULL; + } + + void* file_data = IM_ALLOC(file_size + padding_bytes); + if (file_data == NULL) + { + ImFileClose(f); + return NULL; + } + if (ImFileRead(file_data, 1, file_size, f) != file_size) + { + ImFileClose(f); + IM_FREE(file_data); + return NULL; + } + if (padding_bytes > 0) + memset((void*)(((char*)file_data) + file_size), 0, (size_t)padding_bytes); + + ImFileClose(f); + if (out_file_size) + *out_file_size = file_size; + + return file_data; +} + +//----------------------------------------------------------------------------- +// [SECTION] MISC HELPERS/UTILITIES (ImText* functions) +//----------------------------------------------------------------------------- + +// Convert UTF-8 to 32-bit character, process single character input. +// A nearly-branchless UTF-8 decoder, based on work of Christopher Wellons (https://github.com/skeeto/branchless-utf8). +// We handle UTF-8 decoding error by skipping forward. +int ImTextCharFromUtf8(unsigned int* out_char, const char* in_text, const char* in_text_end) +{ + static const char lengths[32] = { 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 2, 2, 2, 2, 3, 3, 4, 0 }; + static const int masks[] = { 0x00, 0x7f, 0x1f, 0x0f, 0x07 }; + static const uint32_t mins[] = { 0x400000, 0, 0x80, 0x800, 0x10000 }; + static const int shiftc[] = { 0, 18, 12, 6, 0 }; + static const int shifte[] = { 0, 6, 4, 2, 0 }; + int len = lengths[*(const unsigned char*)in_text >> 3]; + int wanted = len + !len; + + if (in_text_end == NULL) + in_text_end = in_text + wanted; // Max length, nulls will be taken into account. + + // Copy at most 'len' bytes, stop copying at 0 or past in_text_end. Branch predictor does a good job here, + // so it is fast even with excessive branching. + unsigned char s[4]; + s[0] = in_text + 0 < in_text_end ? in_text[0] : 0; + s[1] = in_text + 1 < in_text_end ? in_text[1] : 0; + s[2] = in_text + 2 < in_text_end ? in_text[2] : 0; + s[3] = in_text + 3 < in_text_end ? in_text[3] : 0; + + // Assume a four-byte character and load four bytes. Unused bits are shifted out. + *out_char = (uint32_t)(s[0] & masks[len]) << 18; + *out_char |= (uint32_t)(s[1] & 0x3f) << 12; + *out_char |= (uint32_t)(s[2] & 0x3f) << 6; + *out_char |= (uint32_t)(s[3] & 0x3f) << 0; + *out_char >>= shiftc[len]; + + // Accumulate the various error conditions. + int e = 0; + e = (*out_char < mins[len]) << 6; // non-canonical encoding + e |= ((*out_char >> 11) == 0x1b) << 7; // surrogate half? + e |= (*out_char > IM_UNICODE_CODEPOINT_MAX) << 8; // out of range? + e |= (s[1] & 0xc0) >> 2; + e |= (s[2] & 0xc0) >> 4; + e |= (s[3] ) >> 6; + e ^= 0x2a; // top two bits of each tail byte correct? + e >>= shifte[len]; + + if (e) + { + // No bytes are consumed when *in_text == 0 || in_text == in_text_end. + // One byte is consumed in case of invalid first byte of in_text. + // All available bytes (at most `len` bytes) are consumed on incomplete/invalid second to last bytes. + // Invalid or incomplete input may consume less bytes than wanted, therefore every byte has to be inspected in s. + wanted = ImMin(wanted, !!s[0] + !!s[1] + !!s[2] + !!s[3]); + *out_char = IM_UNICODE_CODEPOINT_INVALID; + } + + return wanted; +} + +int ImTextStrFromUtf8(ImWchar* buf, int buf_size, const char* in_text, const char* in_text_end, const char** in_text_remaining) +{ + ImWchar* buf_out = buf; + ImWchar* buf_end = buf + buf_size; + while (buf_out < buf_end - 1 && (!in_text_end || in_text < in_text_end) && *in_text) + { + unsigned int c; + in_text += ImTextCharFromUtf8(&c, in_text, in_text_end); + if (c == 0) + break; + *buf_out++ = (ImWchar)c; + } + *buf_out = 0; + if (in_text_remaining) + *in_text_remaining = in_text; + return (int)(buf_out - buf); +} + +int ImTextCountCharsFromUtf8(const char* in_text, const char* in_text_end) +{ + int char_count = 0; + while ((!in_text_end || in_text < in_text_end) && *in_text) + { + unsigned int c; + in_text += ImTextCharFromUtf8(&c, in_text, in_text_end); + if (c == 0) + break; + char_count++; + } + return char_count; +} + +// Based on stb_to_utf8() from github.com/nothings/stb/ +static inline int ImTextCharToUtf8_inline(char* buf, int buf_size, unsigned int c) +{ + if (c < 0x80) + { + buf[0] = (char)c; + return 1; + } + if (c < 0x800) + { + if (buf_size < 2) return 0; + buf[0] = (char)(0xc0 + (c >> 6)); + buf[1] = (char)(0x80 + (c & 0x3f)); + return 2; + } + if (c < 0x10000) + { + if (buf_size < 3) return 0; + buf[0] = (char)(0xe0 + (c >> 12)); + buf[1] = (char)(0x80 + ((c >> 6) & 0x3f)); + buf[2] = (char)(0x80 + ((c ) & 0x3f)); + return 3; + } + if (c <= 0x10FFFF) + { + if (buf_size < 4) return 0; + buf[0] = (char)(0xf0 + (c >> 18)); + buf[1] = (char)(0x80 + ((c >> 12) & 0x3f)); + buf[2] = (char)(0x80 + ((c >> 6) & 0x3f)); + buf[3] = (char)(0x80 + ((c ) & 0x3f)); + return 4; + } + // Invalid code point, the max unicode is 0x10FFFF + return 0; +} + +const char* ImTextCharToUtf8(char out_buf[5], unsigned int c) +{ + int count = ImTextCharToUtf8_inline(out_buf, 5, c); + out_buf[count] = 0; + return out_buf; +} + +// Not optimal but we very rarely use this function. +int ImTextCountUtf8BytesFromChar(const char* in_text, const char* in_text_end) +{ + unsigned int unused = 0; + return ImTextCharFromUtf8(&unused, in_text, in_text_end); +} + +static inline int ImTextCountUtf8BytesFromChar(unsigned int c) +{ + if (c < 0x80) return 1; + if (c < 0x800) return 2; + if (c < 0x10000) return 3; + if (c <= 0x10FFFF) return 4; + return 3; +} + +int ImTextStrToUtf8(char* out_buf, int out_buf_size, const ImWchar* in_text, const ImWchar* in_text_end) +{ + char* buf_p = out_buf; + const char* buf_end = out_buf + out_buf_size; + while (buf_p < buf_end - 1 && (!in_text_end || in_text < in_text_end) && *in_text) + { + unsigned int c = (unsigned int)(*in_text++); + if (c < 0x80) + *buf_p++ = (char)c; + else + buf_p += ImTextCharToUtf8_inline(buf_p, (int)(buf_end - buf_p - 1), c); + } + *buf_p = 0; + return (int)(buf_p - out_buf); +} + +int ImTextCountUtf8BytesFromStr(const ImWchar* in_text, const ImWchar* in_text_end) +{ + int bytes_count = 0; + while ((!in_text_end || in_text < in_text_end) && *in_text) + { + unsigned int c = (unsigned int)(*in_text++); + if (c < 0x80) + bytes_count++; + else + bytes_count += ImTextCountUtf8BytesFromChar(c); + } + return bytes_count; +} + +//----------------------------------------------------------------------------- +// [SECTION] MISC HELPERS/UTILITIES (Color functions) +// Note: The Convert functions are early design which are not consistent with other API. +//----------------------------------------------------------------------------- + +IMGUI_API ImU32 ImAlphaBlendColors(ImU32 col_a, ImU32 col_b) +{ + float t = ((col_b >> IM_COL32_A_SHIFT) & 0xFF) / 255.f; + int r = ImLerp((int)(col_a >> IM_COL32_R_SHIFT) & 0xFF, (int)(col_b >> IM_COL32_R_SHIFT) & 0xFF, t); + int g = ImLerp((int)(col_a >> IM_COL32_G_SHIFT) & 0xFF, (int)(col_b >> IM_COL32_G_SHIFT) & 0xFF, t); + int b = ImLerp((int)(col_a >> IM_COL32_B_SHIFT) & 0xFF, (int)(col_b >> IM_COL32_B_SHIFT) & 0xFF, t); + return IM_COL32(r, g, b, 0xFF); +} + +ImVec4 ImGui::ColorConvertU32ToFloat4(ImU32 in) +{ + float s = 1.0f / 255.0f; + return ImVec4( + ((in >> IM_COL32_R_SHIFT) & 0xFF) * s, + ((in >> IM_COL32_G_SHIFT) & 0xFF) * s, + ((in >> IM_COL32_B_SHIFT) & 0xFF) * s, + ((in >> IM_COL32_A_SHIFT) & 0xFF) * s); +} + +ImU32 ImGui::ColorConvertFloat4ToU32(const ImVec4& in) +{ + ImU32 out; + out = ((ImU32)IM_F32_TO_INT8_SAT(in.x)) << IM_COL32_R_SHIFT; + out |= ((ImU32)IM_F32_TO_INT8_SAT(in.y)) << IM_COL32_G_SHIFT; + out |= ((ImU32)IM_F32_TO_INT8_SAT(in.z)) << IM_COL32_B_SHIFT; + out |= ((ImU32)IM_F32_TO_INT8_SAT(in.w)) << IM_COL32_A_SHIFT; + return out; +} + +// Convert rgb floats ([0-1],[0-1],[0-1]) to hsv floats ([0-1],[0-1],[0-1]), from Foley & van Dam p592 +// Optimized http://lolengine.net/blog/2013/01/13/fast-rgb-to-hsv +void ImGui::ColorConvertRGBtoHSV(float r, float g, float b, float& out_h, float& out_s, float& out_v) +{ + float K = 0.f; + if (g < b) + { + ImSwap(g, b); + K = -1.f; + } + if (r < g) + { + ImSwap(r, g); + K = -2.f / 6.f - K; + } + + const float chroma = r - (g < b ? g : b); + out_h = ImFabs(K + (g - b) / (6.f * chroma + 1e-20f)); + out_s = chroma / (r + 1e-20f); + out_v = r; +} + +// Convert hsv floats ([0-1],[0-1],[0-1]) to rgb floats ([0-1],[0-1],[0-1]), from Foley & van Dam p593 +// also http://en.wikipedia.org/wiki/HSL_and_HSV +void ImGui::ColorConvertHSVtoRGB(float h, float s, float v, float& out_r, float& out_g, float& out_b) +{ + if (s == 0.0f) + { + // gray + out_r = out_g = out_b = v; + return; + } + + h = ImFmod(h, 1.0f) / (60.0f / 360.0f); + int i = (int)h; + float f = h - (float)i; + float p = v * (1.0f - s); + float q = v * (1.0f - s * f); + float t = v * (1.0f - s * (1.0f - f)); + + switch (i) + { + case 0: out_r = v; out_g = t; out_b = p; break; + case 1: out_r = q; out_g = v; out_b = p; break; + case 2: out_r = p; out_g = v; out_b = t; break; + case 3: out_r = p; out_g = q; out_b = v; break; + case 4: out_r = t; out_g = p; out_b = v; break; + case 5: default: out_r = v; out_g = p; out_b = q; break; + } +} + +//----------------------------------------------------------------------------- +// [SECTION] ImGuiStorage +// Helper: Key->value storage +//----------------------------------------------------------------------------- + +// std::lower_bound but without the bullshit +static ImGuiStorage::ImGuiStoragePair* LowerBound(ImVector& data, ImGuiID key) +{ + ImGuiStorage::ImGuiStoragePair* first = data.Data; + ImGuiStorage::ImGuiStoragePair* last = data.Data + data.Size; + size_t count = (size_t)(last - first); + while (count > 0) + { + size_t count2 = count >> 1; + ImGuiStorage::ImGuiStoragePair* mid = first + count2; + if (mid->key < key) + { + first = ++mid; + count -= count2 + 1; + } + else + { + count = count2; + } + } + return first; +} + +// For quicker full rebuild of a storage (instead of an incremental one), you may add all your contents and then sort once. +void ImGuiStorage::BuildSortByKey() +{ + struct StaticFunc + { + static int IMGUI_CDECL PairCompareByID(const void* lhs, const void* rhs) + { + // We can't just do a subtraction because qsort uses signed integers and subtracting our ID doesn't play well with that. + if (((const ImGuiStoragePair*)lhs)->key > ((const ImGuiStoragePair*)rhs)->key) return +1; + if (((const ImGuiStoragePair*)lhs)->key < ((const ImGuiStoragePair*)rhs)->key) return -1; + return 0; + } + }; + if (Data.Size > 1) + ImQsort(Data.Data, (size_t)Data.Size, sizeof(ImGuiStoragePair), StaticFunc::PairCompareByID); +} + +int ImGuiStorage::GetInt(ImGuiID key, int default_val) const +{ + ImGuiStoragePair* it = LowerBound(const_cast&>(Data), key); + if (it == Data.end() || it->key != key) + return default_val; + return it->val_i; +} + +bool ImGuiStorage::GetBool(ImGuiID key, bool default_val) const +{ + return GetInt(key, default_val ? 1 : 0) != 0; +} + +float ImGuiStorage::GetFloat(ImGuiID key, float default_val) const +{ + ImGuiStoragePair* it = LowerBound(const_cast&>(Data), key); + if (it == Data.end() || it->key != key) + return default_val; + return it->val_f; +} + +void* ImGuiStorage::GetVoidPtr(ImGuiID key) const +{ + ImGuiStoragePair* it = LowerBound(const_cast&>(Data), key); + if (it == Data.end() || it->key != key) + return NULL; + return it->val_p; +} + +// References are only valid until a new value is added to the storage. Calling a Set***() function or a Get***Ref() function invalidates the pointer. +int* ImGuiStorage::GetIntRef(ImGuiID key, int default_val) +{ + ImGuiStoragePair* it = LowerBound(Data, key); + if (it == Data.end() || it->key != key) + it = Data.insert(it, ImGuiStoragePair(key, default_val)); + return &it->val_i; +} + +bool* ImGuiStorage::GetBoolRef(ImGuiID key, bool default_val) +{ + return (bool*)GetIntRef(key, default_val ? 1 : 0); +} + +float* ImGuiStorage::GetFloatRef(ImGuiID key, float default_val) +{ + ImGuiStoragePair* it = LowerBound(Data, key); + if (it == Data.end() || it->key != key) + it = Data.insert(it, ImGuiStoragePair(key, default_val)); + return &it->val_f; +} + +void** ImGuiStorage::GetVoidPtrRef(ImGuiID key, void* default_val) +{ + ImGuiStoragePair* it = LowerBound(Data, key); + if (it == Data.end() || it->key != key) + it = Data.insert(it, ImGuiStoragePair(key, default_val)); + return &it->val_p; +} + +// FIXME-OPT: Need a way to reuse the result of lower_bound when doing GetInt()/SetInt() - not too bad because it only happens on explicit interaction (maximum one a frame) +void ImGuiStorage::SetInt(ImGuiID key, int val) +{ + ImGuiStoragePair* it = LowerBound(Data, key); + if (it == Data.end() || it->key != key) + { + Data.insert(it, ImGuiStoragePair(key, val)); + return; + } + it->val_i = val; +} + +void ImGuiStorage::SetBool(ImGuiID key, bool val) +{ + SetInt(key, val ? 1 : 0); +} + +void ImGuiStorage::SetFloat(ImGuiID key, float val) +{ + ImGuiStoragePair* it = LowerBound(Data, key); + if (it == Data.end() || it->key != key) + { + Data.insert(it, ImGuiStoragePair(key, val)); + return; + } + it->val_f = val; +} + +void ImGuiStorage::SetVoidPtr(ImGuiID key, void* val) +{ + ImGuiStoragePair* it = LowerBound(Data, key); + if (it == Data.end() || it->key != key) + { + Data.insert(it, ImGuiStoragePair(key, val)); + return; + } + it->val_p = val; +} + +void ImGuiStorage::SetAllInt(int v) +{ + for (int i = 0; i < Data.Size; i++) + Data[i].val_i = v; +} + +//----------------------------------------------------------------------------- +// [SECTION] ImGuiTextFilter +//----------------------------------------------------------------------------- + +// Helper: Parse and apply text filters. In format "aaaaa[,bbbb][,ccccc]" +ImGuiTextFilter::ImGuiTextFilter(const char* default_filter) +{ + if (default_filter) + { + ImStrncpy(InputBuf, default_filter, IM_ARRAYSIZE(InputBuf)); + Build(); + } + else + { + InputBuf[0] = 0; + CountGrep = 0; + } +} + +bool ImGuiTextFilter::Draw(const char* label, float width) +{ + if (width != 0.0f) + ImGui::SetNextItemWidth(width); + bool value_changed = ImGui::InputText(label, InputBuf, IM_ARRAYSIZE(InputBuf)); + if (value_changed) + Build(); + return value_changed; +} + +void ImGuiTextFilter::ImGuiTextRange::split(char separator, ImVector* out) const +{ + out->resize(0); + const char* wb = b; + const char* we = wb; + while (we < e) + { + if (*we == separator) + { + out->push_back(ImGuiTextRange(wb, we)); + wb = we + 1; + } + we++; + } + if (wb != we) + out->push_back(ImGuiTextRange(wb, we)); +} + +void ImGuiTextFilter::Build() +{ + Filters.resize(0); + ImGuiTextRange input_range(InputBuf, InputBuf + strlen(InputBuf)); + input_range.split(',', &Filters); + + CountGrep = 0; + for (int i = 0; i != Filters.Size; i++) + { + ImGuiTextRange& f = Filters[i]; + while (f.b < f.e && ImCharIsBlankA(f.b[0])) + f.b++; + while (f.e > f.b && ImCharIsBlankA(f.e[-1])) + f.e--; + if (f.empty()) + continue; + if (Filters[i].b[0] != '-') + CountGrep += 1; + } +} + +bool ImGuiTextFilter::PassFilter(const char* text, const char* text_end) const +{ + if (Filters.empty()) + return true; + + if (text == NULL) + text = ""; + + for (int i = 0; i != Filters.Size; i++) + { + const ImGuiTextRange& f = Filters[i]; + if (f.empty()) + continue; + if (f.b[0] == '-') + { + // Subtract + if (ImStristr(text, text_end, f.b + 1, f.e) != NULL) + return false; + } + else + { + // Grep + if (ImStristr(text, text_end, f.b, f.e) != NULL) + return true; + } + } + + // Implicit * grep + if (CountGrep == 0) + return true; + + return false; +} + +//----------------------------------------------------------------------------- +// [SECTION] ImGuiTextBuffer +//----------------------------------------------------------------------------- + +// On some platform vsnprintf() takes va_list by reference and modifies it. +// va_copy is the 'correct' way to copy a va_list but Visual Studio prior to 2013 doesn't have it. +#ifndef va_copy +#if defined(__GNUC__) || defined(__clang__) +#define va_copy(dest, src) __builtin_va_copy(dest, src) +#else +#define va_copy(dest, src) (dest = src) +#endif +#endif + +char ImGuiTextBuffer::EmptyString[1] = { 0 }; + +void ImGuiTextBuffer::append(const char* str, const char* str_end) +{ + int len = str_end ? (int)(str_end - str) : (int)strlen(str); + + // Add zero-terminator the first time + const int write_off = (Buf.Size != 0) ? Buf.Size : 1; + const int needed_sz = write_off + len; + if (write_off + len >= Buf.Capacity) + { + int new_capacity = Buf.Capacity * 2; + Buf.reserve(needed_sz > new_capacity ? needed_sz : new_capacity); + } + + Buf.resize(needed_sz); + memcpy(&Buf[write_off - 1], str, (size_t)len); + Buf[write_off - 1 + len] = 0; +} + +void ImGuiTextBuffer::appendf(const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); + appendfv(fmt, args); + va_end(args); +} + +// Helper: Text buffer for logging/accumulating text +void ImGuiTextBuffer::appendfv(const char* fmt, va_list args) +{ + va_list args_copy; + va_copy(args_copy, args); + + int len = ImFormatStringV(NULL, 0, fmt, args); // FIXME-OPT: could do a first pass write attempt, likely successful on first pass. + if (len <= 0) + { + va_end(args_copy); + return; + } + + // Add zero-terminator the first time + const int write_off = (Buf.Size != 0) ? Buf.Size : 1; + const int needed_sz = write_off + len; + if (write_off + len >= Buf.Capacity) + { + int new_capacity = Buf.Capacity * 2; + Buf.reserve(needed_sz > new_capacity ? needed_sz : new_capacity); + } + + Buf.resize(needed_sz); + ImFormatStringV(&Buf[write_off - 1], (size_t)len + 1, fmt, args_copy); + va_end(args_copy); +} + +//----------------------------------------------------------------------------- +// [SECTION] ImGuiListClipper +// This is currently not as flexible/powerful as it should be and really confusing/spaghetti, mostly because we changed +// the API mid-way through development and support two ways to using the clipper, needs some rework (see TODO) +//----------------------------------------------------------------------------- + +// FIXME-TABLE: This prevents us from using ImGuiListClipper _inside_ a table cell. +// The problem we have is that without a Begin/End scheme for rows using the clipper is ambiguous. +static bool GetSkipItemForListClipping() +{ + ImGuiContext& g = *GImGui; + return (g.CurrentTable ? g.CurrentTable->HostSkipItems : g.CurrentWindow->SkipItems); +} + +// Helper to calculate coarse clipping of large list of evenly sized items. +// NB: Prefer using the ImGuiListClipper higher-level helper if you can! Read comments and instructions there on how those use this sort of pattern. +// NB: 'items_count' is only used to clamp the result, if you don't know your count you can use INT_MAX +void ImGui::CalcListClipping(int items_count, float items_height, int* out_items_display_start, int* out_items_display_end) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (g.LogEnabled) + { + // If logging is active, do not perform any clipping + *out_items_display_start = 0; + *out_items_display_end = items_count; + return; + } + if (GetSkipItemForListClipping()) + { + *out_items_display_start = *out_items_display_end = 0; + return; + } + + // We create the union of the ClipRect and the scoring rect which at worst should be 1 page away from ClipRect + ImRect unclipped_rect = window->ClipRect; + if (g.NavMoveScoringItems) + unclipped_rect.Add(g.NavScoringRect); + if (g.NavJustMovedToId && window->NavLastIds[0] == g.NavJustMovedToId) + unclipped_rect.Add(ImRect(window->Pos + window->NavRectRel[0].Min, window->Pos + window->NavRectRel[0].Max)); // Could store and use NavJustMovedToRectRel + + const ImVec2 pos = window->DC.CursorPos; + int start = (int)((unclipped_rect.Min.y - pos.y) / items_height); + int end = (int)((unclipped_rect.Max.y - pos.y) / items_height); + + // When performing a navigation request, ensure we have one item extra in the direction we are moving to + if (g.NavMoveScoringItems && g.NavMoveClipDir == ImGuiDir_Up) + start--; + if (g.NavMoveScoringItems && g.NavMoveClipDir == ImGuiDir_Down) + end++; + + start = ImClamp(start, 0, items_count); + end = ImClamp(end + 1, start, items_count); + *out_items_display_start = start; + *out_items_display_end = end; +} + +static void SetCursorPosYAndSetupForPrevLine(float pos_y, float line_height) +{ + // Set cursor position and a few other things so that SetScrollHereY() and Columns() can work when seeking cursor. + // FIXME: It is problematic that we have to do that here, because custom/equivalent end-user code would stumble on the same issue. + // The clipper should probably have a 4th step to display the last item in a regular manner. + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + float off_y = pos_y - window->DC.CursorPos.y; + window->DC.CursorPos.y = pos_y; + window->DC.CursorMaxPos.y = ImMax(window->DC.CursorMaxPos.y, pos_y); + window->DC.CursorPosPrevLine.y = window->DC.CursorPos.y - line_height; // Setting those fields so that SetScrollHereY() can properly function after the end of our clipper usage. + window->DC.PrevLineSize.y = (line_height - g.Style.ItemSpacing.y); // If we end up needing more accurate data (to e.g. use SameLine) we may as well make the clipper have a fourth step to let user process and display the last item in their list. + if (ImGuiOldColumns* columns = window->DC.CurrentColumns) + columns->LineMinY = window->DC.CursorPos.y; // Setting this so that cell Y position are set properly + if (ImGuiTable* table = g.CurrentTable) + { + if (table->IsInsideRow) + ImGui::TableEndRow(table); + table->RowPosY2 = window->DC.CursorPos.y; + const int row_increase = (int)((off_y / line_height) + 0.5f); + //table->CurrentRow += row_increase; // Can't do without fixing TableEndRow() + table->RowBgColorCounter += row_increase; + } +} + +ImGuiListClipper::ImGuiListClipper() +{ + memset(this, 0, sizeof(*this)); + ItemsCount = -1; +} + +ImGuiListClipper::~ImGuiListClipper() +{ + IM_ASSERT(ItemsCount == -1 && "Forgot to call End(), or to Step() until false?"); +} + +// Use case A: Begin() called from constructor with items_height<0, then called again from Step() in StepNo 1 +// Use case B: Begin() called from constructor with items_height>0 +// FIXME-LEGACY: Ideally we should remove the Begin/End functions but they are part of the legacy API we still support. This is why some of the code in Step() calling Begin() and reassign some fields, spaghetti style. +void ImGuiListClipper::Begin(int items_count, float items_height) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + if (ImGuiTable* table = g.CurrentTable) + if (table->IsInsideRow) + ImGui::TableEndRow(table); + + StartPosY = window->DC.CursorPos.y; + ItemsHeight = items_height; + ItemsCount = items_count; + ItemsFrozen = 0; + StepNo = 0; + DisplayStart = -1; + DisplayEnd = 0; +} + +void ImGuiListClipper::End() +{ + if (ItemsCount < 0) // Already ended + return; + + // In theory here we should assert that ImGui::GetCursorPosY() == StartPosY + DisplayEnd * ItemsHeight, but it feels saner to just seek at the end and not assert/crash the user. + if (ItemsCount < INT_MAX && DisplayStart >= 0) + SetCursorPosYAndSetupForPrevLine(StartPosY + (ItemsCount - ItemsFrozen) * ItemsHeight, ItemsHeight); + ItemsCount = -1; + StepNo = 3; +} + +bool ImGuiListClipper::Step() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + ImGuiTable* table = g.CurrentTable; + if (table && table->IsInsideRow) + ImGui::TableEndRow(table); + + // No items + if (ItemsCount == 0 || GetSkipItemForListClipping()) + { + End(); + return false; + } + + // Step 0: Let you process the first element (regardless of it being visible or not, so we can measure the element height) + if (StepNo == 0) + { + // While we are in frozen row state, keep displaying items one by one, unclipped + // FIXME: Could be stored as a table-agnostic state. + if (table != NULL && !table->IsUnfrozenRows) + { + DisplayStart = ItemsFrozen; + DisplayEnd = ItemsFrozen + 1; + ItemsFrozen++; + return true; + } + + StartPosY = window->DC.CursorPos.y; + if (ItemsHeight <= 0.0f) + { + // Submit the first item so we can measure its height (generally it is 0..1) + DisplayStart = ItemsFrozen; + DisplayEnd = ItemsFrozen + 1; + StepNo = 1; + return true; + } + + // Already has item height (given by user in Begin): skip to calculating step + DisplayStart = DisplayEnd; + StepNo = 2; + } + + // Step 1: the clipper infer height from first element + if (StepNo == 1) + { + IM_ASSERT(ItemsHeight <= 0.0f); + if (table) + { + const float pos_y1 = table->RowPosY1; // Using this instead of StartPosY to handle clipper straddling the frozen row + const float pos_y2 = table->RowPosY2; // Using this instead of CursorPos.y to take account of tallest cell. + ItemsHeight = pos_y2 - pos_y1; + window->DC.CursorPos.y = pos_y2; + } + else + { + ItemsHeight = window->DC.CursorPos.y - StartPosY; + } + IM_ASSERT(ItemsHeight > 0.0f && "Unable to calculate item height! First item hasn't moved the cursor vertically!"); + StepNo = 2; + } + + // Reached end of list + if (DisplayEnd >= ItemsCount) + { + End(); + return false; + } + + // Step 2: calculate the actual range of elements to display, and position the cursor before the first element + if (StepNo == 2) + { + IM_ASSERT(ItemsHeight > 0.0f); + + int already_submitted = DisplayEnd; + ImGui::CalcListClipping(ItemsCount - already_submitted, ItemsHeight, &DisplayStart, &DisplayEnd); + DisplayStart += already_submitted; + DisplayEnd += already_submitted; + + // Seek cursor + if (DisplayStart > already_submitted) + SetCursorPosYAndSetupForPrevLine(StartPosY + (DisplayStart - ItemsFrozen) * ItemsHeight, ItemsHeight); + + StepNo = 3; + return true; + } + + // Step 3: the clipper validate that we have reached the expected Y position (corresponding to element DisplayEnd), + // Advance the cursor to the end of the list and then returns 'false' to end the loop. + if (StepNo == 3) + { + // Seek cursor + if (ItemsCount < INT_MAX) + SetCursorPosYAndSetupForPrevLine(StartPosY + (ItemsCount - ItemsFrozen) * ItemsHeight, ItemsHeight); // advance cursor + ItemsCount = -1; + return false; + } + + IM_ASSERT(0); + return false; +} + +//----------------------------------------------------------------------------- +// [SECTION] STYLING +//----------------------------------------------------------------------------- + +ImGuiStyle& ImGui::GetStyle() +{ + IM_ASSERT(GImGui != NULL && "No current context. Did you call ImGui::CreateContext() and ImGui::SetCurrentContext() ?"); + return GImGui->Style; +} + +ImU32 ImGui::GetColorU32(ImGuiCol idx, float alpha_mul) +{ + ImGuiStyle& style = GImGui->Style; + ImVec4 c = style.Colors[idx]; + c.w *= style.Alpha * alpha_mul; + return ColorConvertFloat4ToU32(c); +} + +ImU32 ImGui::GetColorU32(const ImVec4& col) +{ + ImGuiStyle& style = GImGui->Style; + ImVec4 c = col; + c.w *= style.Alpha; + return ColorConvertFloat4ToU32(c); +} + +const ImVec4& ImGui::GetStyleColorVec4(ImGuiCol idx) +{ + ImGuiStyle& style = GImGui->Style; + return style.Colors[idx]; +} + +ImU32 ImGui::GetColorU32(ImU32 col) +{ + ImGuiStyle& style = GImGui->Style; + if (style.Alpha >= 1.0f) + return col; + ImU32 a = (col & IM_COL32_A_MASK) >> IM_COL32_A_SHIFT; + a = (ImU32)(a * style.Alpha); // We don't need to clamp 0..255 because Style.Alpha is in 0..1 range. + return (col & ~IM_COL32_A_MASK) | (a << IM_COL32_A_SHIFT); +} + +// FIXME: This may incur a round-trip (if the end user got their data from a float4) but eventually we aim to store the in-flight colors as ImU32 +void ImGui::PushStyleColor(ImGuiCol idx, ImU32 col) +{ + ImGuiContext& g = *GImGui; + ImGuiColorMod backup; + backup.Col = idx; + backup.BackupValue = g.Style.Colors[idx]; + g.ColorStack.push_back(backup); + g.Style.Colors[idx] = ColorConvertU32ToFloat4(col); +} + +void ImGui::PushStyleColor(ImGuiCol idx, const ImVec4& col) +{ + ImGuiContext& g = *GImGui; + ImGuiColorMod backup; + backup.Col = idx; + backup.BackupValue = g.Style.Colors[idx]; + g.ColorStack.push_back(backup); + g.Style.Colors[idx] = col; +} + +void ImGui::PopStyleColor(int count) +{ + ImGuiContext& g = *GImGui; + while (count > 0) + { + ImGuiColorMod& backup = g.ColorStack.back(); + g.Style.Colors[backup.Col] = backup.BackupValue; + g.ColorStack.pop_back(); + count--; + } +} + +struct ImGuiStyleVarInfo +{ + ImGuiDataType Type; + ImU32 Count; + ImU32 Offset; + void* GetVarPtr(ImGuiStyle* style) const { return (void*)((unsigned char*)style + Offset); } +}; + +static const ImGuiStyleVarInfo GStyleVarInfo[] = +{ + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, Alpha) }, // ImGuiStyleVar_Alpha + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, DisabledAlpha) }, // ImGuiStyleVar_DisabledAlpha + { ImGuiDataType_Float, 2, (ImU32)IM_OFFSETOF(ImGuiStyle, WindowPadding) }, // ImGuiStyleVar_WindowPadding + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, WindowRounding) }, // ImGuiStyleVar_WindowRounding + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, WindowBorderSize) }, // ImGuiStyleVar_WindowBorderSize + { ImGuiDataType_Float, 2, (ImU32)IM_OFFSETOF(ImGuiStyle, WindowMinSize) }, // ImGuiStyleVar_WindowMinSize + { ImGuiDataType_Float, 2, (ImU32)IM_OFFSETOF(ImGuiStyle, WindowTitleAlign) }, // ImGuiStyleVar_WindowTitleAlign + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, ChildRounding) }, // ImGuiStyleVar_ChildRounding + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, ChildBorderSize) }, // ImGuiStyleVar_ChildBorderSize + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, PopupRounding) }, // ImGuiStyleVar_PopupRounding + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, PopupBorderSize) }, // ImGuiStyleVar_PopupBorderSize + { ImGuiDataType_Float, 2, (ImU32)IM_OFFSETOF(ImGuiStyle, FramePadding) }, // ImGuiStyleVar_FramePadding + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, FrameRounding) }, // ImGuiStyleVar_FrameRounding + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, FrameBorderSize) }, // ImGuiStyleVar_FrameBorderSize + { ImGuiDataType_Float, 2, (ImU32)IM_OFFSETOF(ImGuiStyle, ItemSpacing) }, // ImGuiStyleVar_ItemSpacing + { ImGuiDataType_Float, 2, (ImU32)IM_OFFSETOF(ImGuiStyle, ItemInnerSpacing) }, // ImGuiStyleVar_ItemInnerSpacing + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, IndentSpacing) }, // ImGuiStyleVar_IndentSpacing + { ImGuiDataType_Float, 2, (ImU32)IM_OFFSETOF(ImGuiStyle, CellPadding) }, // ImGuiStyleVar_CellPadding + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, ScrollbarSize) }, // ImGuiStyleVar_ScrollbarSize + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, ScrollbarRounding) }, // ImGuiStyleVar_ScrollbarRounding + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, GrabMinSize) }, // ImGuiStyleVar_GrabMinSize + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, GrabRounding) }, // ImGuiStyleVar_GrabRounding + { ImGuiDataType_Float, 1, (ImU32)IM_OFFSETOF(ImGuiStyle, TabRounding) }, // ImGuiStyleVar_TabRounding + { ImGuiDataType_Float, 2, (ImU32)IM_OFFSETOF(ImGuiStyle, ButtonTextAlign) }, // ImGuiStyleVar_ButtonTextAlign + { ImGuiDataType_Float, 2, (ImU32)IM_OFFSETOF(ImGuiStyle, SelectableTextAlign) }, // ImGuiStyleVar_SelectableTextAlign +}; + +static const ImGuiStyleVarInfo* GetStyleVarInfo(ImGuiStyleVar idx) +{ + IM_ASSERT(idx >= 0 && idx < ImGuiStyleVar_COUNT); + IM_ASSERT(IM_ARRAYSIZE(GStyleVarInfo) == ImGuiStyleVar_COUNT); + return &GStyleVarInfo[idx]; +} + +void ImGui::PushStyleVar(ImGuiStyleVar idx, float val) +{ + const ImGuiStyleVarInfo* var_info = GetStyleVarInfo(idx); + if (var_info->Type == ImGuiDataType_Float && var_info->Count == 1) + { + ImGuiContext& g = *GImGui; + float* pvar = (float*)var_info->GetVarPtr(&g.Style); + g.StyleVarStack.push_back(ImGuiStyleMod(idx, *pvar)); + *pvar = val; + return; + } + IM_ASSERT(0 && "Called PushStyleVar() float variant but variable is not a float!"); +} + +void ImGui::PushStyleVar(ImGuiStyleVar idx, const ImVec2& val) +{ + const ImGuiStyleVarInfo* var_info = GetStyleVarInfo(idx); + if (var_info->Type == ImGuiDataType_Float && var_info->Count == 2) + { + ImGuiContext& g = *GImGui; + ImVec2* pvar = (ImVec2*)var_info->GetVarPtr(&g.Style); + g.StyleVarStack.push_back(ImGuiStyleMod(idx, *pvar)); + *pvar = val; + return; + } + IM_ASSERT(0 && "Called PushStyleVar() ImVec2 variant but variable is not a ImVec2!"); +} + +void ImGui::PopStyleVar(int count) +{ + ImGuiContext& g = *GImGui; + while (count > 0) + { + // We avoid a generic memcpy(data, &backup.Backup.., GDataTypeSize[info->Type] * info->Count), the overhead in Debug is not worth it. + ImGuiStyleMod& backup = g.StyleVarStack.back(); + const ImGuiStyleVarInfo* info = GetStyleVarInfo(backup.VarIdx); + void* data = info->GetVarPtr(&g.Style); + if (info->Type == ImGuiDataType_Float && info->Count == 1) { ((float*)data)[0] = backup.BackupFloat[0]; } + else if (info->Type == ImGuiDataType_Float && info->Count == 2) { ((float*)data)[0] = backup.BackupFloat[0]; ((float*)data)[1] = backup.BackupFloat[1]; } + g.StyleVarStack.pop_back(); + count--; + } +} + +const char* ImGui::GetStyleColorName(ImGuiCol idx) +{ + // Create switch-case from enum with regexp: ImGuiCol_{.*}, --> case ImGuiCol_\1: return "\1"; + switch (idx) + { + case ImGuiCol_Text: return "Text"; + case ImGuiCol_TextDisabled: return "TextDisabled"; + case ImGuiCol_WindowBg: return "WindowBg"; + case ImGuiCol_ChildBg: return "ChildBg"; + case ImGuiCol_PopupBg: return "PopupBg"; + case ImGuiCol_Border: return "Border"; + case ImGuiCol_BorderShadow: return "BorderShadow"; + case ImGuiCol_FrameBg: return "FrameBg"; + case ImGuiCol_FrameBgHovered: return "FrameBgHovered"; + case ImGuiCol_FrameBgActive: return "FrameBgActive"; + case ImGuiCol_TitleBg: return "TitleBg"; + case ImGuiCol_TitleBgActive: return "TitleBgActive"; + case ImGuiCol_TitleBgCollapsed: return "TitleBgCollapsed"; + case ImGuiCol_MenuBarBg: return "MenuBarBg"; + case ImGuiCol_ScrollbarBg: return "ScrollbarBg"; + case ImGuiCol_ScrollbarGrab: return "ScrollbarGrab"; + case ImGuiCol_ScrollbarGrabHovered: return "ScrollbarGrabHovered"; + case ImGuiCol_ScrollbarGrabActive: return "ScrollbarGrabActive"; + case ImGuiCol_CheckMark: return "CheckMark"; + case ImGuiCol_SliderGrab: return "SliderGrab"; + case ImGuiCol_SliderGrabActive: return "SliderGrabActive"; + case ImGuiCol_Button: return "Button"; + case ImGuiCol_ButtonHovered: return "ButtonHovered"; + case ImGuiCol_ButtonActive: return "ButtonActive"; + case ImGuiCol_Header: return "Header"; + case ImGuiCol_HeaderHovered: return "HeaderHovered"; + case ImGuiCol_HeaderActive: return "HeaderActive"; + case ImGuiCol_Separator: return "Separator"; + case ImGuiCol_SeparatorHovered: return "SeparatorHovered"; + case ImGuiCol_SeparatorActive: return "SeparatorActive"; + case ImGuiCol_ResizeGrip: return "ResizeGrip"; + case ImGuiCol_ResizeGripHovered: return "ResizeGripHovered"; + case ImGuiCol_ResizeGripActive: return "ResizeGripActive"; + case ImGuiCol_Tab: return "Tab"; + case ImGuiCol_TabHovered: return "TabHovered"; + case ImGuiCol_TabActive: return "TabActive"; + case ImGuiCol_TabUnfocused: return "TabUnfocused"; + case ImGuiCol_TabUnfocusedActive: return "TabUnfocusedActive"; + case ImGuiCol_PlotLines: return "PlotLines"; + case ImGuiCol_PlotLinesHovered: return "PlotLinesHovered"; + case ImGuiCol_PlotHistogram: return "PlotHistogram"; + case ImGuiCol_PlotHistogramHovered: return "PlotHistogramHovered"; + case ImGuiCol_TableHeaderBg: return "TableHeaderBg"; + case ImGuiCol_TableBorderStrong: return "TableBorderStrong"; + case ImGuiCol_TableBorderLight: return "TableBorderLight"; + case ImGuiCol_TableRowBg: return "TableRowBg"; + case ImGuiCol_TableRowBgAlt: return "TableRowBgAlt"; + case ImGuiCol_TextSelectedBg: return "TextSelectedBg"; + case ImGuiCol_DragDropTarget: return "DragDropTarget"; + case ImGuiCol_NavHighlight: return "NavHighlight"; + case ImGuiCol_NavWindowingHighlight: return "NavWindowingHighlight"; + case ImGuiCol_NavWindowingDimBg: return "NavWindowingDimBg"; + case ImGuiCol_ModalWindowDimBg: return "ModalWindowDimBg"; + } + IM_ASSERT(0); + return "Unknown"; +} + + +//----------------------------------------------------------------------------- +// [SECTION] RENDER HELPERS +// Some of those (internal) functions are currently quite a legacy mess - their signature and behavior will change, +// we need a nicer separation between low-level functions and high-level functions relying on the ImGui context. +// Also see imgui_draw.cpp for some more which have been reworked to not rely on ImGui:: context. +//----------------------------------------------------------------------------- + +const char* ImGui::FindRenderedTextEnd(const char* text, const char* text_end) +{ + const char* text_display_end = text; + if (!text_end) + text_end = (const char*)-1; + + while (text_display_end < text_end && *text_display_end != '\0' && (text_display_end[0] != '#' || text_display_end[1] != '#')) + text_display_end++; + return text_display_end; +} + +// Internal ImGui functions to render text +// RenderText***() functions calls ImDrawList::AddText() calls ImBitmapFont::RenderText() +void ImGui::RenderText(ImVec2 pos, const char* text, const char* text_end, bool hide_text_after_hash) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + // Hide anything after a '##' string + const char* text_display_end; + if (hide_text_after_hash) + { + text_display_end = FindRenderedTextEnd(text, text_end); + } + else + { + if (!text_end) + text_end = text + strlen(text); // FIXME-OPT + text_display_end = text_end; + } + + if (text != text_display_end) + { + window->DrawList->AddText(g.Font, g.FontSize, pos, GetColorU32(ImGuiCol_Text), text, text_display_end); + if (g.LogEnabled) + LogRenderedText(&pos, text, text_display_end); + } +} + +void ImGui::RenderTextWrapped(ImVec2 pos, const char* text, const char* text_end, float wrap_width) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + if (!text_end) + text_end = text + strlen(text); // FIXME-OPT + + if (text != text_end) + { + window->DrawList->AddText(g.Font, g.FontSize, pos, GetColorU32(ImGuiCol_Text), text, text_end, wrap_width); + if (g.LogEnabled) + LogRenderedText(&pos, text, text_end); + } +} + +// Default clip_rect uses (pos_min,pos_max) +// Handle clipping on CPU immediately (vs typically let the GPU clip the triangles that are overlapping the clipping rectangle edges) +void ImGui::RenderTextClippedEx(ImDrawList* draw_list, const ImVec2& pos_min, const ImVec2& pos_max, const char* text, const char* text_display_end, const ImVec2* text_size_if_known, const ImVec2& align, const ImRect* clip_rect) +{ + // Perform CPU side clipping for single clipped element to avoid using scissor state + ImVec2 pos = pos_min; + const ImVec2 text_size = text_size_if_known ? *text_size_if_known : CalcTextSize(text, text_display_end, false, 0.0f); + + const ImVec2* clip_min = clip_rect ? &clip_rect->Min : &pos_min; + const ImVec2* clip_max = clip_rect ? &clip_rect->Max : &pos_max; + bool need_clipping = (pos.x + text_size.x >= clip_max->x) || (pos.y + text_size.y >= clip_max->y); + if (clip_rect) // If we had no explicit clipping rectangle then pos==clip_min + need_clipping |= (pos.x < clip_min->x) || (pos.y < clip_min->y); + + // Align whole block. We should defer that to the better rendering function when we'll have support for individual line alignment. + if (align.x > 0.0f) pos.x = ImMax(pos.x, pos.x + (pos_max.x - pos.x - text_size.x) * align.x); + if (align.y > 0.0f) pos.y = ImMax(pos.y, pos.y + (pos_max.y - pos.y - text_size.y) * align.y); + + // Render + if (need_clipping) + { + ImVec4 fine_clip_rect(clip_min->x, clip_min->y, clip_max->x, clip_max->y); + draw_list->AddText(NULL, 0.0f, pos, GetColorU32(ImGuiCol_Text), text, text_display_end, 0.0f, &fine_clip_rect); + } + else + { + draw_list->AddText(NULL, 0.0f, pos, GetColorU32(ImGuiCol_Text), text, text_display_end, 0.0f, NULL); + } +} + +void ImGui::RenderTextClipped(const ImVec2& pos_min, const ImVec2& pos_max, const char* text, const char* text_end, const ImVec2* text_size_if_known, const ImVec2& align, const ImRect* clip_rect) +{ + // Hide anything after a '##' string + const char* text_display_end = FindRenderedTextEnd(text, text_end); + const int text_len = (int)(text_display_end - text); + if (text_len == 0) + return; + + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + RenderTextClippedEx(window->DrawList, pos_min, pos_max, text, text_display_end, text_size_if_known, align, clip_rect); + if (g.LogEnabled) + LogRenderedText(&pos_min, text, text_display_end); +} + + +// Another overly complex function until we reorganize everything into a nice all-in-one helper. +// This is made more complex because we have dissociated the layout rectangle (pos_min..pos_max) which define _where_ the ellipsis is, from actual clipping of text and limit of the ellipsis display. +// This is because in the context of tabs we selectively hide part of the text when the Close Button appears, but we don't want the ellipsis to move. +void ImGui::RenderTextEllipsis(ImDrawList* draw_list, const ImVec2& pos_min, const ImVec2& pos_max, float clip_max_x, float ellipsis_max_x, const char* text, const char* text_end_full, const ImVec2* text_size_if_known) +{ + ImGuiContext& g = *GImGui; + if (text_end_full == NULL) + text_end_full = FindRenderedTextEnd(text); + const ImVec2 text_size = text_size_if_known ? *text_size_if_known : CalcTextSize(text, text_end_full, false, 0.0f); + + //draw_list->AddLine(ImVec2(pos_max.x, pos_min.y - 4), ImVec2(pos_max.x, pos_max.y + 4), IM_COL32(0, 0, 255, 255)); + //draw_list->AddLine(ImVec2(ellipsis_max_x, pos_min.y-2), ImVec2(ellipsis_max_x, pos_max.y+2), IM_COL32(0, 255, 0, 255)); + //draw_list->AddLine(ImVec2(clip_max_x, pos_min.y), ImVec2(clip_max_x, pos_max.y), IM_COL32(255, 0, 0, 255)); + // FIXME: We could technically remove (last_glyph->AdvanceX - last_glyph->X1) from text_size.x here and save a few pixels. + if (text_size.x > pos_max.x - pos_min.x) + { + // Hello wo... + // | | | + // min max ellipsis_max + // <-> this is generally some padding value + + const ImFont* font = draw_list->_Data->Font; + const float font_size = draw_list->_Data->FontSize; + const char* text_end_ellipsis = NULL; + + ImWchar ellipsis_char = font->EllipsisChar; + int ellipsis_char_count = 1; + if (ellipsis_char == (ImWchar)-1) + { + ellipsis_char = font->DotChar; + ellipsis_char_count = 3; + } + const ImFontGlyph* glyph = font->FindGlyph(ellipsis_char); + + float ellipsis_glyph_width = glyph->X1; // Width of the glyph with no padding on either side + float ellipsis_total_width = ellipsis_glyph_width; // Full width of entire ellipsis + + if (ellipsis_char_count > 1) + { + // Full ellipsis size without free spacing after it. + const float spacing_between_dots = 1.0f * (draw_list->_Data->FontSize / font->FontSize); + ellipsis_glyph_width = glyph->X1 - glyph->X0 + spacing_between_dots; + ellipsis_total_width = ellipsis_glyph_width * (float)ellipsis_char_count - spacing_between_dots; + } + + // We can now claim the space between pos_max.x and ellipsis_max.x + const float text_avail_width = ImMax((ImMax(pos_max.x, ellipsis_max_x) - ellipsis_total_width) - pos_min.x, 1.0f); + float text_size_clipped_x = font->CalcTextSizeA(font_size, text_avail_width, 0.0f, text, text_end_full, &text_end_ellipsis).x; + if (text == text_end_ellipsis && text_end_ellipsis < text_end_full) + { + // Always display at least 1 character if there's no room for character + ellipsis + text_end_ellipsis = text + ImTextCountUtf8BytesFromChar(text, text_end_full); + text_size_clipped_x = font->CalcTextSizeA(font_size, FLT_MAX, 0.0f, text, text_end_ellipsis).x; + } + while (text_end_ellipsis > text && ImCharIsBlankA(text_end_ellipsis[-1])) + { + // Trim trailing space before ellipsis (FIXME: Supporting non-ascii blanks would be nice, for this we need a function to backtrack in UTF-8 text) + text_end_ellipsis--; + text_size_clipped_x -= font->CalcTextSizeA(font_size, FLT_MAX, 0.0f, text_end_ellipsis, text_end_ellipsis + 1).x; // Ascii blanks are always 1 byte + } + + // Render text, render ellipsis + RenderTextClippedEx(draw_list, pos_min, ImVec2(clip_max_x, pos_max.y), text, text_end_ellipsis, &text_size, ImVec2(0.0f, 0.0f)); + float ellipsis_x = pos_min.x + text_size_clipped_x; + if (ellipsis_x + ellipsis_total_width <= ellipsis_max_x) + for (int i = 0; i < ellipsis_char_count; i++) + { + font->RenderChar(draw_list, font_size, ImVec2(ellipsis_x, pos_min.y), GetColorU32(ImGuiCol_Text), ellipsis_char); + ellipsis_x += ellipsis_glyph_width; + } + } + else + { + RenderTextClippedEx(draw_list, pos_min, ImVec2(clip_max_x, pos_max.y), text, text_end_full, &text_size, ImVec2(0.0f, 0.0f)); + } + + if (g.LogEnabled) + LogRenderedText(&pos_min, text, text_end_full); +} + +// Render a rectangle shaped with optional rounding and borders +void ImGui::RenderFrame(ImVec2 p_min, ImVec2 p_max, ImU32 fill_col, bool border, float rounding) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + window->DrawList->AddRectFilled(p_min, p_max, fill_col, rounding); + const float border_size = g.Style.FrameBorderSize; + if (border && border_size > 0.0f) + { + window->DrawList->AddRect(p_min + ImVec2(1, 1), p_max + ImVec2(1, 1), GetColorU32(ImGuiCol_BorderShadow), rounding, 0, border_size); + window->DrawList->AddRect(p_min, p_max, GetColorU32(ImGuiCol_Border), rounding, 0, border_size); + } +} + +void ImGui::RenderFrameBorder(ImVec2 p_min, ImVec2 p_max, float rounding) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + const float border_size = g.Style.FrameBorderSize; + if (border_size > 0.0f) + { + window->DrawList->AddRect(p_min + ImVec2(1, 1), p_max + ImVec2(1, 1), GetColorU32(ImGuiCol_BorderShadow), rounding, 0, border_size); + window->DrawList->AddRect(p_min, p_max, GetColorU32(ImGuiCol_Border), rounding, 0, border_size); + } +} + +void ImGui::RenderNavHighlight(const ImRect& bb, ImGuiID id, ImGuiNavHighlightFlags flags) +{ + ImGuiContext& g = *GImGui; + if (id != g.NavId) + return; + if (g.NavDisableHighlight && !(flags & ImGuiNavHighlightFlags_AlwaysDraw)) + return; + ImGuiWindow* window = g.CurrentWindow; + if (window->DC.NavHideHighlightOneFrame) + return; + + float rounding = (flags & ImGuiNavHighlightFlags_NoRounding) ? 0.0f : g.Style.FrameRounding; + ImRect display_rect = bb; + display_rect.ClipWith(window->ClipRect); + if (flags & ImGuiNavHighlightFlags_TypeDefault) + { + const float THICKNESS = 2.0f; + const float DISTANCE = 3.0f + THICKNESS * 0.5f; + display_rect.Expand(ImVec2(DISTANCE, DISTANCE)); + bool fully_visible = window->ClipRect.Contains(display_rect); + if (!fully_visible) + window->DrawList->PushClipRect(display_rect.Min, display_rect.Max); + window->DrawList->AddRect(display_rect.Min + ImVec2(THICKNESS * 0.5f, THICKNESS * 0.5f), display_rect.Max - ImVec2(THICKNESS * 0.5f, THICKNESS * 0.5f), GetColorU32(ImGuiCol_NavHighlight), rounding, 0, THICKNESS); + if (!fully_visible) + window->DrawList->PopClipRect(); + } + if (flags & ImGuiNavHighlightFlags_TypeThin) + { + window->DrawList->AddRect(display_rect.Min, display_rect.Max, GetColorU32(ImGuiCol_NavHighlight), rounding, 0, 1.0f); + } +} + +//----------------------------------------------------------------------------- +// [SECTION] MAIN CODE (most of the code! lots of stuff, needs tidying up!) +//----------------------------------------------------------------------------- + +// ImGuiWindow is mostly a dumb struct. It merely has a constructor and a few helper methods +ImGuiWindow::ImGuiWindow(ImGuiContext* context, const char* name) : DrawListInst(NULL) +{ + memset(this, 0, sizeof(*this)); + Name = ImStrdup(name); + NameBufLen = (int)strlen(name) + 1; + ID = ImHashStr(name); + IDStack.push_back(ID); + MoveId = GetID("#MOVE"); + ScrollTarget = ImVec2(FLT_MAX, FLT_MAX); + ScrollTargetCenterRatio = ImVec2(0.5f, 0.5f); + AutoFitFramesX = AutoFitFramesY = -1; + AutoPosLastDirection = ImGuiDir_None; + SetWindowPosAllowFlags = SetWindowSizeAllowFlags = SetWindowCollapsedAllowFlags = ImGuiCond_Always | ImGuiCond_Once | ImGuiCond_FirstUseEver | ImGuiCond_Appearing; + SetWindowPosVal = SetWindowPosPivot = ImVec2(FLT_MAX, FLT_MAX); + LastFrameActive = -1; + LastTimeActive = -1.0f; + FontWindowScale = 1.0f; + SettingsOffset = -1; + DrawList = &DrawListInst; + DrawList->_Data = &context->DrawListSharedData; + DrawList->_OwnerName = Name; +} + +ImGuiWindow::~ImGuiWindow() +{ + IM_ASSERT(DrawList == &DrawListInst); + IM_DELETE(Name); + ColumnsStorage.clear_destruct(); +} + +ImGuiID ImGuiWindow::GetID(const char* str, const char* str_end) +{ + ImGuiID seed = IDStack.back(); + ImGuiID id = ImHashStr(str, str_end ? (str_end - str) : 0, seed); + ImGui::KeepAliveID(id); +#ifdef IMGUI_ENABLE_TEST_ENGINE + ImGuiContext& g = *GImGui; + IMGUI_TEST_ENGINE_ID_INFO2(id, ImGuiDataType_String, str, str_end); +#endif + return id; +} + +ImGuiID ImGuiWindow::GetID(const void* ptr) +{ + ImGuiID seed = IDStack.back(); + ImGuiID id = ImHashData(&ptr, sizeof(void*), seed); + ImGui::KeepAliveID(id); +#ifdef IMGUI_ENABLE_TEST_ENGINE + ImGuiContext& g = *GImGui; + IMGUI_TEST_ENGINE_ID_INFO(id, ImGuiDataType_Pointer, ptr); +#endif + return id; +} + +ImGuiID ImGuiWindow::GetID(int n) +{ + ImGuiID seed = IDStack.back(); + ImGuiID id = ImHashData(&n, sizeof(n), seed); + ImGui::KeepAliveID(id); +#ifdef IMGUI_ENABLE_TEST_ENGINE + ImGuiContext& g = *GImGui; + IMGUI_TEST_ENGINE_ID_INFO(id, ImGuiDataType_S32, (intptr_t)n); +#endif + return id; +} + +ImGuiID ImGuiWindow::GetIDNoKeepAlive(const char* str, const char* str_end) +{ + ImGuiID seed = IDStack.back(); + ImGuiID id = ImHashStr(str, str_end ? (str_end - str) : 0, seed); +#ifdef IMGUI_ENABLE_TEST_ENGINE + ImGuiContext& g = *GImGui; + IMGUI_TEST_ENGINE_ID_INFO2(id, ImGuiDataType_String, str, str_end); +#endif + return id; +} + +ImGuiID ImGuiWindow::GetIDNoKeepAlive(const void* ptr) +{ + ImGuiID seed = IDStack.back(); + ImGuiID id = ImHashData(&ptr, sizeof(void*), seed); +#ifdef IMGUI_ENABLE_TEST_ENGINE + ImGuiContext& g = *GImGui; + IMGUI_TEST_ENGINE_ID_INFO(id, ImGuiDataType_Pointer, ptr); +#endif + return id; +} + +ImGuiID ImGuiWindow::GetIDNoKeepAlive(int n) +{ + ImGuiID seed = IDStack.back(); + ImGuiID id = ImHashData(&n, sizeof(n), seed); +#ifdef IMGUI_ENABLE_TEST_ENGINE + ImGuiContext& g = *GImGui; + IMGUI_TEST_ENGINE_ID_INFO(id, ImGuiDataType_S32, (intptr_t)n); +#endif + return id; +} + +// This is only used in rare/specific situations to manufacture an ID out of nowhere. +ImGuiID ImGuiWindow::GetIDFromRectangle(const ImRect& r_abs) +{ + ImGuiID seed = IDStack.back(); + const int r_rel[4] = { (int)(r_abs.Min.x - Pos.x), (int)(r_abs.Min.y - Pos.y), (int)(r_abs.Max.x - Pos.x), (int)(r_abs.Max.y - Pos.y) }; + ImGuiID id = ImHashData(&r_rel, sizeof(r_rel), seed); + ImGui::KeepAliveID(id); + return id; +} + +static void SetCurrentWindow(ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + g.CurrentWindow = window; + g.CurrentTable = window && window->DC.CurrentTableIdx != -1 ? g.Tables.GetByIndex(window->DC.CurrentTableIdx) : NULL; + if (window) + g.FontSize = g.DrawListSharedData.FontSize = window->CalcFontSize(); +} + +void ImGui::GcCompactTransientMiscBuffers() +{ + ImGuiContext& g = *GImGui; + g.ItemFlagsStack.clear(); + g.GroupStack.clear(); + TableGcCompactSettings(); +} + +// Free up/compact internal window buffers, we can use this when a window becomes unused. +// Not freed: +// - ImGuiWindow, ImGuiWindowSettings, Name, StateStorage, ColumnsStorage (may hold useful data) +// This should have no noticeable visual effect. When the window reappear however, expect new allocation/buffer growth/copy cost. +void ImGui::GcCompactTransientWindowBuffers(ImGuiWindow* window) +{ + window->MemoryCompacted = true; + window->MemoryDrawListIdxCapacity = window->DrawList->IdxBuffer.Capacity; + window->MemoryDrawListVtxCapacity = window->DrawList->VtxBuffer.Capacity; + window->IDStack.clear(); + window->DrawList->_ClearFreeMemory(); + window->DC.ChildWindows.clear(); + window->DC.ItemWidthStack.clear(); + window->DC.TextWrapPosStack.clear(); +} + +void ImGui::GcAwakeTransientWindowBuffers(ImGuiWindow* window) +{ + // We stored capacity of the ImDrawList buffer to reduce growth-caused allocation/copy when awakening. + // The other buffers tends to amortize much faster. + window->MemoryCompacted = false; + window->DrawList->IdxBuffer.reserve(window->MemoryDrawListIdxCapacity); + window->DrawList->VtxBuffer.reserve(window->MemoryDrawListVtxCapacity); + window->MemoryDrawListIdxCapacity = window->MemoryDrawListVtxCapacity = 0; +} + +void ImGui::SetActiveID(ImGuiID id, ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + g.ActiveIdIsJustActivated = (g.ActiveId != id); + if (g.ActiveIdIsJustActivated) + { + g.ActiveIdTimer = 0.0f; + g.ActiveIdHasBeenPressedBefore = false; + g.ActiveIdHasBeenEditedBefore = false; + g.ActiveIdMouseButton = -1; + if (id != 0) + { + g.LastActiveId = id; + g.LastActiveIdTimer = 0.0f; + } + } + g.ActiveId = id; + g.ActiveIdAllowOverlap = false; + g.ActiveIdNoClearOnFocusLoss = false; + g.ActiveIdWindow = window; + g.ActiveIdHasBeenEditedThisFrame = false; + if (id) + { + g.ActiveIdIsAlive = id; + g.ActiveIdSource = (g.NavActivateId == id || g.NavActivateInputId == id || g.NavJustTabbedId == id || g.NavJustMovedToId == id) ? ImGuiInputSource_Nav : ImGuiInputSource_Mouse; + } + + // Clear declaration of inputs claimed by the widget + // (Please note that this is WIP and not all keys/inputs are thoroughly declared by all widgets yet) + g.ActiveIdUsingMouseWheel = false; + g.ActiveIdUsingNavDirMask = 0x00; + g.ActiveIdUsingNavInputMask = 0x00; + g.ActiveIdUsingKeyInputMask = 0x00; +} + +void ImGui::ClearActiveID() +{ + SetActiveID(0, NULL); // g.ActiveId = 0; +} + +void ImGui::SetHoveredID(ImGuiID id) +{ + ImGuiContext& g = *GImGui; + g.HoveredId = id; + g.HoveredIdAllowOverlap = false; + g.HoveredIdUsingMouseWheel = false; + if (id != 0 && g.HoveredIdPreviousFrame != id) + g.HoveredIdTimer = g.HoveredIdNotActiveTimer = 0.0f; +} + +ImGuiID ImGui::GetHoveredID() +{ + ImGuiContext& g = *GImGui; + return g.HoveredId ? g.HoveredId : g.HoveredIdPreviousFrame; +} + +void ImGui::KeepAliveID(ImGuiID id) +{ + ImGuiContext& g = *GImGui; + if (g.ActiveId == id) + g.ActiveIdIsAlive = id; + if (g.ActiveIdPreviousFrame == id) + g.ActiveIdPreviousFrameIsAlive = true; +} + +void ImGui::MarkItemEdited(ImGuiID id) +{ + // This marking is solely to be able to provide info for IsItemDeactivatedAfterEdit(). + // ActiveId might have been released by the time we call this (as in the typical press/release button behavior) but still need need to fill the data. + ImGuiContext& g = *GImGui; + IM_ASSERT(g.ActiveId == id || g.ActiveId == 0 || g.DragDropActive); + IM_UNUSED(id); // Avoid unused variable warnings when asserts are compiled out. + //IM_ASSERT(g.CurrentWindow->DC.LastItemId == id); + g.ActiveIdHasBeenEditedThisFrame = true; + g.ActiveIdHasBeenEditedBefore = true; + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_Edited; +} + +static inline bool IsWindowContentHoverable(ImGuiWindow* window, ImGuiHoveredFlags flags) +{ + // An active popup disable hovering on other windows (apart from its own children) + // FIXME-OPT: This could be cached/stored within the window. + ImGuiContext& g = *GImGui; + if (g.NavWindow) + if (ImGuiWindow* focused_root_window = g.NavWindow->RootWindow) + if (focused_root_window->WasActive && focused_root_window != window->RootWindow) + { + // For the purpose of those flags we differentiate "standard popup" from "modal popup" + // NB: The order of those two tests is important because Modal windows are also Popups. + if (focused_root_window->Flags & ImGuiWindowFlags_Modal) + return false; + if ((focused_root_window->Flags & ImGuiWindowFlags_Popup) && !(flags & ImGuiHoveredFlags_AllowWhenBlockedByPopup)) + return false; + } + return true; +} + +// This is roughly matching the behavior of internal-facing ItemHoverable() +// - we allow hovering to be true when ActiveId==window->MoveID, so that clicking on non-interactive items such as a Text() item still returns true with IsItemHovered() +// - this should work even for non-interactive items that have no ID, so we cannot use LastItemId +bool ImGui::IsItemHovered(ImGuiHoveredFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (g.NavDisableMouseHover && !g.NavDisableHighlight) + { + if ((g.LastItemData.InFlags & ImGuiItemFlags_Disabled) && !(flags & ImGuiHoveredFlags_AllowWhenDisabled)) + return false; + return IsItemFocused(); + } + + // Test for bounding box overlap, as updated as ItemAdd() + ImGuiItemStatusFlags status_flags = g.LastItemData.StatusFlags; + if (!(status_flags & ImGuiItemStatusFlags_HoveredRect)) + return false; + IM_ASSERT((flags & (ImGuiHoveredFlags_RootWindow | ImGuiHoveredFlags_ChildWindows)) == 0); // Flags not supported by this function + + // Test if we are hovering the right window (our window could be behind another window) + // [2021/03/02] Reworked / reverted the revert, finally. Note we want e.g. BeginGroup/ItemAdd/EndGroup to work as well. (#3851) + // [2017/10/16] Reverted commit 344d48be3 and testing RootWindow instead. I believe it is correct to NOT test for RootWindow but this leaves us unable + // to use IsItemHovered() after EndChild() itself. Until a solution is found I believe reverting to the test from 2017/09/27 is safe since this was + // the test that has been running for a long while. + if (g.HoveredWindow != window && (status_flags & ImGuiItemStatusFlags_HoveredWindow) == 0) + if ((flags & ImGuiHoveredFlags_AllowWhenOverlapped) == 0) + return false; + + // Test if another item is active (e.g. being dragged) + if ((flags & ImGuiHoveredFlags_AllowWhenBlockedByActiveItem) == 0) + if (g.ActiveId != 0 && g.ActiveId != g.LastItemData.ID && !g.ActiveIdAllowOverlap && g.ActiveId != window->MoveId) + return false; + + // Test if interactions on this window are blocked by an active popup or modal. + // The ImGuiHoveredFlags_AllowWhenBlockedByPopup flag will be tested here. + if (!IsWindowContentHoverable(window, flags)) + return false; + + // Test if the item is disabled + if ((g.LastItemData.InFlags & ImGuiItemFlags_Disabled) && !(flags & ImGuiHoveredFlags_AllowWhenDisabled)) + return false; + + // Special handling for calling after Begin() which represent the title bar or tab. + // When the window is collapsed (SkipItems==true) that last item will never be overwritten so we need to detect the case. + if (g.LastItemData.ID == window->MoveId && window->WriteAccessed) + return false; + return true; +} + +// Internal facing ItemHoverable() used when submitting widgets. Differs slightly from IsItemHovered(). +bool ImGui::ItemHoverable(const ImRect& bb, ImGuiID id) +{ + ImGuiContext& g = *GImGui; + if (g.HoveredId != 0 && g.HoveredId != id && !g.HoveredIdAllowOverlap) + return false; + + ImGuiWindow* window = g.CurrentWindow; + if (g.HoveredWindow != window) + return false; + if (g.ActiveId != 0 && g.ActiveId != id && !g.ActiveIdAllowOverlap) + return false; + if (!IsMouseHoveringRect(bb.Min, bb.Max)) + return false; + if (g.NavDisableMouseHover) + return false; + if (!IsWindowContentHoverable(window, ImGuiHoveredFlags_None)) + { + g.HoveredIdDisabled = true; + return false; + } + + // We exceptionally allow this function to be called with id==0 to allow using it for easy high-level + // hover test in widgets code. We could also decide to split this function is two. + if (id != 0) + SetHoveredID(id); + + // When disabled we'll return false but still set HoveredId + ImGuiItemFlags item_flags = (g.LastItemData.ID == id ? g.LastItemData.InFlags : g.CurrentItemFlags); + if (item_flags & ImGuiItemFlags_Disabled) + { + // Release active id if turning disabled + if (g.ActiveId == id) + ClearActiveID(); + g.HoveredIdDisabled = true; + return false; + } + + if (id != 0) + { + // [DEBUG] Item Picker tool! + // We perform the check here because SetHoveredID() is not frequently called (1~ time a frame), making + // the cost of this tool near-zero. We can get slightly better call-stack and support picking non-hovered + // items if we perform the test in ItemAdd(), but that would incur a small runtime cost. + // #define IMGUI_DEBUG_TOOL_ITEM_PICKER_EX in imconfig.h if you want this check to also be performed in ItemAdd(). + if (g.DebugItemPickerActive && g.HoveredIdPreviousFrame == id) + GetForegroundDrawList()->AddRect(bb.Min, bb.Max, IM_COL32(255, 255, 0, 255)); + if (g.DebugItemPickerBreakId == id) + IM_DEBUG_BREAK(); + } + + return true; +} + +bool ImGui::IsClippedEx(const ImRect& bb, ImGuiID id) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (!bb.Overlaps(window->ClipRect)) + if (id == 0 || (id != g.ActiveId && id != g.NavId)) + if (!g.LogEnabled) + return true; + return false; +} + +// Called by ItemAdd() +// Process TAB/Shift+TAB. Be mindful that this function may _clear_ the ActiveID when tabbing out. +// [WIP] This will eventually be refactored and moved into NavProcessItem() +void ImGui::ItemInputable(ImGuiWindow* window, ImGuiID id) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(id != 0 && id == g.LastItemData.ID); + + // Increment counters + // FIXME: ImGuiItemFlags_Disabled should disable more. + const bool is_tab_stop = (g.LastItemData.InFlags & (ImGuiItemFlags_NoTabStop | ImGuiItemFlags_Disabled)) == 0; + window->DC.FocusCounterRegular++; + if (is_tab_stop) + { + window->DC.FocusCounterTabStop++; + if (g.NavId == id) + g.NavIdTabCounter = window->DC.FocusCounterTabStop; + } + + // Process TAB/Shift-TAB to tab *OUT* of the currently focused item. + // (Note that we can always TAB out of a widget that doesn't allow tabbing in) + if (g.ActiveId == id && g.TabFocusPressed && !IsActiveIdUsingKey(ImGuiKey_Tab) && g.TabFocusRequestNextWindow == NULL) + { + g.TabFocusRequestNextWindow = window; + g.TabFocusRequestNextCounterTabStop = window->DC.FocusCounterTabStop + (g.IO.KeyShift ? (is_tab_stop ? -1 : 0) : +1); // Modulo on index will be applied at the end of frame once we've got the total counter of items. + } + + // Handle focus requests + if (g.TabFocusRequestCurrWindow == window) + { + if (window->DC.FocusCounterRegular == g.TabFocusRequestCurrCounterRegular) + { + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_FocusedByCode; + return; + } + if (is_tab_stop && window->DC.FocusCounterTabStop == g.TabFocusRequestCurrCounterTabStop) + { + g.NavJustTabbedId = id; // FIXME-NAV: aim to eventually set in NavUpdate() once we finish the refactor + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_FocusedByTabbing; + return; + } + + // If another item is about to be focused, we clear our own active id + if (g.ActiveId == id) + ClearActiveID(); + } +} + +float ImGui::CalcWrapWidthForPos(const ImVec2& pos, float wrap_pos_x) +{ + if (wrap_pos_x < 0.0f) + return 0.0f; + + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (wrap_pos_x == 0.0f) + { + // We could decide to setup a default wrapping max point for auto-resizing windows, + // or have auto-wrap (with unspecified wrapping pos) behave as a ContentSize extending function? + //if (window->Hidden && (window->Flags & ImGuiWindowFlags_AlwaysAutoResize)) + // wrap_pos_x = ImMax(window->WorkRect.Min.x + g.FontSize * 10.0f, window->WorkRect.Max.x); + //else + wrap_pos_x = window->WorkRect.Max.x; + } + else if (wrap_pos_x > 0.0f) + { + wrap_pos_x += window->Pos.x - window->Scroll.x; // wrap_pos_x is provided is window local space + } + + return ImMax(wrap_pos_x - pos.x, 1.0f); +} + +// IM_ALLOC() == ImGui::MemAlloc() +void* ImGui::MemAlloc(size_t size) +{ + if (ImGuiContext* ctx = GImGui) + ctx->IO.MetricsActiveAllocations++; + return (*GImAllocatorAllocFunc)(size, GImAllocatorUserData); +} + +// IM_FREE() == ImGui::MemFree() +void ImGui::MemFree(void* ptr) +{ + if (ptr) + if (ImGuiContext* ctx = GImGui) + ctx->IO.MetricsActiveAllocations--; + return (*GImAllocatorFreeFunc)(ptr, GImAllocatorUserData); +} + +const char* ImGui::GetClipboardText() +{ + ImGuiContext& g = *GImGui; + return g.IO.GetClipboardTextFn ? g.IO.GetClipboardTextFn(g.IO.ClipboardUserData) : ""; +} + +void ImGui::SetClipboardText(const char* text) +{ + ImGuiContext& g = *GImGui; + if (g.IO.SetClipboardTextFn) + g.IO.SetClipboardTextFn(g.IO.ClipboardUserData, text); +} + +const char* ImGui::GetVersion() +{ + return IMGUI_VERSION; +} + +// Internal state access - if you want to share Dear ImGui state between modules (e.g. DLL) or allocate it yourself +// Note that we still point to some static data and members (such as GFontAtlas), so the state instance you end up using will point to the static data within its module +ImGuiContext* ImGui::GetCurrentContext() +{ + return GImGui; +} + +void ImGui::SetCurrentContext(ImGuiContext* ctx) +{ +#ifdef IMGUI_SET_CURRENT_CONTEXT_FUNC + IMGUI_SET_CURRENT_CONTEXT_FUNC(ctx); // For custom thread-based hackery you may want to have control over this. +#else + GImGui = ctx; +#endif +} + +void ImGui::SetAllocatorFunctions(ImGuiMemAllocFunc alloc_func, ImGuiMemFreeFunc free_func, void* user_data) +{ + GImAllocatorAllocFunc = alloc_func; + GImAllocatorFreeFunc = free_func; + GImAllocatorUserData = user_data; +} + +// This is provided to facilitate copying allocators from one static/DLL boundary to another (e.g. retrieve default allocator of your executable address space) +void ImGui::GetAllocatorFunctions(ImGuiMemAllocFunc* p_alloc_func, ImGuiMemFreeFunc* p_free_func, void** p_user_data) +{ + *p_alloc_func = GImAllocatorAllocFunc; + *p_free_func = GImAllocatorFreeFunc; + *p_user_data = GImAllocatorUserData; +} + +ImGuiContext* ImGui::CreateContext(ImFontAtlas* shared_font_atlas) +{ + ImGuiContext* ctx = IM_NEW(ImGuiContext)(shared_font_atlas); + if (GImGui == NULL) + SetCurrentContext(ctx); + Initialize(ctx); + return ctx; +} + +void ImGui::DestroyContext(ImGuiContext* ctx) +{ + if (ctx == NULL) + ctx = GImGui; + Shutdown(ctx); + if (GImGui == ctx) + SetCurrentContext(NULL); + IM_DELETE(ctx); +} + +// No specific ordering/dependency support, will see as needed +ImGuiID ImGui::AddContextHook(ImGuiContext* ctx, const ImGuiContextHook* hook) +{ + ImGuiContext& g = *ctx; + IM_ASSERT(hook->Callback != NULL && hook->HookId == 0 && hook->Type != ImGuiContextHookType_PendingRemoval_); + g.Hooks.push_back(*hook); + g.Hooks.back().HookId = ++g.HookIdNext; + return g.HookIdNext; +} + +// Deferred removal, avoiding issue with changing vector while iterating it +void ImGui::RemoveContextHook(ImGuiContext* ctx, ImGuiID hook_id) +{ + ImGuiContext& g = *ctx; + IM_ASSERT(hook_id != 0); + for (int n = 0; n < g.Hooks.Size; n++) + if (g.Hooks[n].HookId == hook_id) + g.Hooks[n].Type = ImGuiContextHookType_PendingRemoval_; +} + +// Call context hooks (used by e.g. test engine) +// We assume a small number of hooks so all stored in same array +void ImGui::CallContextHooks(ImGuiContext* ctx, ImGuiContextHookType hook_type) +{ + ImGuiContext& g = *ctx; + for (int n = 0; n < g.Hooks.Size; n++) + if (g.Hooks[n].Type == hook_type) + g.Hooks[n].Callback(&g, &g.Hooks[n]); +} + +ImGuiIO& ImGui::GetIO() +{ + IM_ASSERT(GImGui != NULL && "No current context. Did you call ImGui::CreateContext() and ImGui::SetCurrentContext() ?"); + return GImGui->IO; +} + +// Pass this to your backend rendering function! Valid after Render() and until the next call to NewFrame() +ImDrawData* ImGui::GetDrawData() +{ + ImGuiContext& g = *GImGui; + ImGuiViewportP* viewport = g.Viewports[0]; + return viewport->DrawDataP.Valid ? &viewport->DrawDataP : NULL; +} + +double ImGui::GetTime() +{ + return GImGui->Time; +} + +int ImGui::GetFrameCount() +{ + return GImGui->FrameCount; +} + +static ImDrawList* GetViewportDrawList(ImGuiViewportP* viewport, size_t drawlist_no, const char* drawlist_name) +{ + // Create the draw list on demand, because they are not frequently used for all viewports + ImGuiContext& g = *GImGui; + IM_ASSERT(drawlist_no < IM_ARRAYSIZE(viewport->DrawLists)); + ImDrawList* draw_list = viewport->DrawLists[drawlist_no]; + if (draw_list == NULL) + { + draw_list = IM_NEW(ImDrawList)(&g.DrawListSharedData); + draw_list->_OwnerName = drawlist_name; + viewport->DrawLists[drawlist_no] = draw_list; + } + + // Our ImDrawList system requires that there is always a command + if (viewport->DrawListsLastFrame[drawlist_no] != g.FrameCount) + { + draw_list->_ResetForNewFrame(); + draw_list->PushTextureID(g.IO.Fonts->TexID); + draw_list->PushClipRect(viewport->Pos, viewport->Pos + viewport->Size, false); + viewport->DrawListsLastFrame[drawlist_no] = g.FrameCount; + } + return draw_list; +} + +ImDrawList* ImGui::GetBackgroundDrawList(ImGuiViewport* viewport) +{ + return GetViewportDrawList((ImGuiViewportP*)viewport, 0, "##Background"); +} + +ImDrawList* ImGui::GetBackgroundDrawList() +{ + ImGuiContext& g = *GImGui; + return GetBackgroundDrawList(g.Viewports[0]); +} + +ImDrawList* ImGui::GetForegroundDrawList(ImGuiViewport* viewport) +{ + return GetViewportDrawList((ImGuiViewportP*)viewport, 1, "##Foreground"); +} + +ImDrawList* ImGui::GetForegroundDrawList() +{ + ImGuiContext& g = *GImGui; + return GetForegroundDrawList(g.Viewports[0]); +} + +ImDrawListSharedData* ImGui::GetDrawListSharedData() +{ + return &GImGui->DrawListSharedData; +} + +void ImGui::StartMouseMovingWindow(ImGuiWindow* window) +{ + // Set ActiveId even if the _NoMove flag is set. Without it, dragging away from a window with _NoMove would activate hover on other windows. + // We _also_ call this when clicking in a window empty space when io.ConfigWindowsMoveFromTitleBarOnly is set, but clear g.MovingWindow afterward. + // This is because we want ActiveId to be set even when the window is not permitted to move. + ImGuiContext& g = *GImGui; + FocusWindow(window); + SetActiveID(window->MoveId, window); + g.NavDisableHighlight = true; + g.ActiveIdClickOffset = g.IO.MouseClickedPos[0] - window->RootWindow->Pos; + g.ActiveIdNoClearOnFocusLoss = true; + SetActiveIdUsingNavAndKeys(); + + bool can_move_window = true; + if ((window->Flags & ImGuiWindowFlags_NoMove) || (window->RootWindow->Flags & ImGuiWindowFlags_NoMove)) + can_move_window = false; + if (can_move_window) + g.MovingWindow = window; +} + +// Handle mouse moving window +// Note: moving window with the navigation keys (Square + d-pad / CTRL+TAB + Arrows) are processed in NavUpdateWindowing() +// FIXME: We don't have strong guarantee that g.MovingWindow stay synched with g.ActiveId == g.MovingWindow->MoveId. +// This is currently enforced by the fact that BeginDragDropSource() is setting all g.ActiveIdUsingXXXX flags to inhibit navigation inputs, +// but if we should more thoroughly test cases where g.ActiveId or g.MovingWindow gets changed and not the other. +void ImGui::UpdateMouseMovingWindowNewFrame() +{ + ImGuiContext& g = *GImGui; + if (g.MovingWindow != NULL) + { + // We actually want to move the root window. g.MovingWindow == window we clicked on (could be a child window). + // We track it to preserve Focus and so that generally ActiveIdWindow == MovingWindow and ActiveId == MovingWindow->MoveId for consistency. + KeepAliveID(g.ActiveId); + IM_ASSERT(g.MovingWindow && g.MovingWindow->RootWindow); + ImGuiWindow* moving_window = g.MovingWindow->RootWindow; + if (g.IO.MouseDown[0] && IsMousePosValid(&g.IO.MousePos)) + { + ImVec2 pos = g.IO.MousePos - g.ActiveIdClickOffset; + if (moving_window->Pos.x != pos.x || moving_window->Pos.y != pos.y) + { + MarkIniSettingsDirty(moving_window); + SetWindowPos(moving_window, pos, ImGuiCond_Always); + } + FocusWindow(g.MovingWindow); + } + else + { + g.MovingWindow = NULL; + ClearActiveID(); + } + } + else + { + // When clicking/dragging from a window that has the _NoMove flag, we still set the ActiveId in order to prevent hovering others. + if (g.ActiveIdWindow && g.ActiveIdWindow->MoveId == g.ActiveId) + { + KeepAliveID(g.ActiveId); + if (!g.IO.MouseDown[0]) + ClearActiveID(); + } + } +} + +// Initiate moving window when clicking on empty space or title bar. +// Handle left-click and right-click focus. +void ImGui::UpdateMouseMovingWindowEndFrame() +{ + ImGuiContext& g = *GImGui; + if (g.ActiveId != 0 || g.HoveredId != 0) + return; + + // Unless we just made a window/popup appear + if (g.NavWindow && g.NavWindow->Appearing) + return; + + // Click on empty space to focus window and start moving + // (after we're done with all our widgets) + if (g.IO.MouseClicked[0]) + { + // Handle the edge case of a popup being closed while clicking in its empty space. + // If we try to focus it, FocusWindow() > ClosePopupsOverWindow() will accidentally close any parent popups because they are not linked together any more. + ImGuiWindow* root_window = g.HoveredWindow ? g.HoveredWindow->RootWindow : NULL; + const bool is_closed_popup = root_window && (root_window->Flags & ImGuiWindowFlags_Popup) && !IsPopupOpen(root_window->PopupId, ImGuiPopupFlags_AnyPopupLevel); + + if (root_window != NULL && !is_closed_popup) + { + StartMouseMovingWindow(g.HoveredWindow); //-V595 + + // Cancel moving if clicked outside of title bar + if (g.IO.ConfigWindowsMoveFromTitleBarOnly && !(root_window->Flags & ImGuiWindowFlags_NoTitleBar)) + if (!root_window->TitleBarRect().Contains(g.IO.MouseClickedPos[0])) + g.MovingWindow = NULL; + + // Cancel moving if clicked over an item which was disabled or inhibited by popups (note that we know HoveredId == 0 already) + if (g.HoveredIdDisabled) + g.MovingWindow = NULL; + } + else if (root_window == NULL && g.NavWindow != NULL && GetTopMostPopupModal() == NULL) + { + // Clicking on void disable focus + FocusWindow(NULL); + } + } + + // With right mouse button we close popups without changing focus based on where the mouse is aimed + // Instead, focus will be restored to the window under the bottom-most closed popup. + // (The left mouse button path calls FocusWindow on the hovered window, which will lead NewFrame->ClosePopupsOverWindow to trigger) + if (g.IO.MouseClicked[1]) + { + // Find the top-most window between HoveredWindow and the top-most Modal Window. + // This is where we can trim the popup stack. + ImGuiWindow* modal = GetTopMostPopupModal(); + bool hovered_window_above_modal = g.HoveredWindow && IsWindowAbove(g.HoveredWindow, modal); + ClosePopupsOverWindow(hovered_window_above_modal ? g.HoveredWindow : modal, true); + } +} + +static bool IsWindowActiveAndVisible(ImGuiWindow* window) +{ + return (window->Active) && (!window->Hidden); +} + +static void ImGui::UpdateMouseInputs() +{ + ImGuiContext& g = *GImGui; + + // Round mouse position to avoid spreading non-rounded position (e.g. UpdateManualResize doesn't support them well) + if (IsMousePosValid(&g.IO.MousePos)) + g.IO.MousePos = g.MouseLastValidPos = ImFloor(g.IO.MousePos); + + // If mouse just appeared or disappeared (usually denoted by -FLT_MAX components) we cancel out movement in MouseDelta + if (IsMousePosValid(&g.IO.MousePos) && IsMousePosValid(&g.IO.MousePosPrev)) + g.IO.MouseDelta = g.IO.MousePos - g.IO.MousePosPrev; + else + g.IO.MouseDelta = ImVec2(0.0f, 0.0f); + + // If mouse moved we re-enable mouse hovering in case it was disabled by gamepad/keyboard. In theory should use a >0.0f threshold but would need to reset in everywhere we set this to true. + if (g.IO.MouseDelta.x != 0.0f || g.IO.MouseDelta.y != 0.0f) + g.NavDisableMouseHover = false; + + g.IO.MousePosPrev = g.IO.MousePos; + for (int i = 0; i < IM_ARRAYSIZE(g.IO.MouseDown); i++) + { + g.IO.MouseClicked[i] = g.IO.MouseDown[i] && g.IO.MouseDownDuration[i] < 0.0f; + g.IO.MouseReleased[i] = !g.IO.MouseDown[i] && g.IO.MouseDownDuration[i] >= 0.0f; + g.IO.MouseDownDurationPrev[i] = g.IO.MouseDownDuration[i]; + g.IO.MouseDownDuration[i] = g.IO.MouseDown[i] ? (g.IO.MouseDownDuration[i] < 0.0f ? 0.0f : g.IO.MouseDownDuration[i] + g.IO.DeltaTime) : -1.0f; + g.IO.MouseDoubleClicked[i] = false; + if (g.IO.MouseClicked[i]) + { + if ((float)(g.Time - g.IO.MouseClickedTime[i]) < g.IO.MouseDoubleClickTime) + { + ImVec2 delta_from_click_pos = IsMousePosValid(&g.IO.MousePos) ? (g.IO.MousePos - g.IO.MouseClickedPos[i]) : ImVec2(0.0f, 0.0f); + if (ImLengthSqr(delta_from_click_pos) < g.IO.MouseDoubleClickMaxDist * g.IO.MouseDoubleClickMaxDist) + g.IO.MouseDoubleClicked[i] = true; + g.IO.MouseClickedTime[i] = -g.IO.MouseDoubleClickTime * 2.0f; // Mark as "old enough" so the third click isn't turned into a double-click + } + else + { + g.IO.MouseClickedTime[i] = g.Time; + } + g.IO.MouseClickedPos[i] = g.IO.MousePos; + g.IO.MouseDownWasDoubleClick[i] = g.IO.MouseDoubleClicked[i]; + g.IO.MouseDragMaxDistanceAbs[i] = ImVec2(0.0f, 0.0f); + g.IO.MouseDragMaxDistanceSqr[i] = 0.0f; + } + else if (g.IO.MouseDown[i]) + { + // Maintain the maximum distance we reaching from the initial click position, which is used with dragging threshold + ImVec2 delta_from_click_pos = IsMousePosValid(&g.IO.MousePos) ? (g.IO.MousePos - g.IO.MouseClickedPos[i]) : ImVec2(0.0f, 0.0f); + g.IO.MouseDragMaxDistanceSqr[i] = ImMax(g.IO.MouseDragMaxDistanceSqr[i], ImLengthSqr(delta_from_click_pos)); + g.IO.MouseDragMaxDistanceAbs[i].x = ImMax(g.IO.MouseDragMaxDistanceAbs[i].x, delta_from_click_pos.x < 0.0f ? -delta_from_click_pos.x : delta_from_click_pos.x); + g.IO.MouseDragMaxDistanceAbs[i].y = ImMax(g.IO.MouseDragMaxDistanceAbs[i].y, delta_from_click_pos.y < 0.0f ? -delta_from_click_pos.y : delta_from_click_pos.y); + } + if (!g.IO.MouseDown[i] && !g.IO.MouseReleased[i]) + g.IO.MouseDownWasDoubleClick[i] = false; + if (g.IO.MouseClicked[i]) // Clicking any mouse button reactivate mouse hovering which may have been deactivated by gamepad/keyboard navigation + g.NavDisableMouseHover = false; + } +} + +static void StartLockWheelingWindow(ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + if (g.WheelingWindow == window) + return; + g.WheelingWindow = window; + g.WheelingWindowRefMousePos = g.IO.MousePos; + g.WheelingWindowTimer = WINDOWS_MOUSE_WHEEL_SCROLL_LOCK_TIMER; +} + +void ImGui::UpdateMouseWheel() +{ + ImGuiContext& g = *GImGui; + + // Reset the locked window if we move the mouse or after the timer elapses + if (g.WheelingWindow != NULL) + { + g.WheelingWindowTimer -= g.IO.DeltaTime; + if (IsMousePosValid() && ImLengthSqr(g.IO.MousePos - g.WheelingWindowRefMousePos) > g.IO.MouseDragThreshold * g.IO.MouseDragThreshold) + g.WheelingWindowTimer = 0.0f; + if (g.WheelingWindowTimer <= 0.0f) + { + g.WheelingWindow = NULL; + g.WheelingWindowTimer = 0.0f; + } + } + + if (g.IO.MouseWheel == 0.0f && g.IO.MouseWheelH == 0.0f) + return; + + if ((g.ActiveId != 0 && g.ActiveIdUsingMouseWheel) || (g.HoveredIdPreviousFrame != 0 && g.HoveredIdPreviousFrameUsingMouseWheel)) + return; + + ImGuiWindow* window = g.WheelingWindow ? g.WheelingWindow : g.HoveredWindow; + if (!window || window->Collapsed) + return; + + // Zoom / Scale window + // FIXME-OBSOLETE: This is an old feature, it still works but pretty much nobody is using it and may be best redesigned. + if (g.IO.MouseWheel != 0.0f && g.IO.KeyCtrl && g.IO.FontAllowUserScaling) + { + StartLockWheelingWindow(window); + const float new_font_scale = ImClamp(window->FontWindowScale + g.IO.MouseWheel * 0.10f, 0.50f, 2.50f); + const float scale = new_font_scale / window->FontWindowScale; + window->FontWindowScale = new_font_scale; + if (window == window->RootWindow) + { + const ImVec2 offset = window->Size * (1.0f - scale) * (g.IO.MousePos - window->Pos) / window->Size; + SetWindowPos(window, window->Pos + offset, 0); + window->Size = ImFloor(window->Size * scale); + window->SizeFull = ImFloor(window->SizeFull * scale); + } + return; + } + + // Mouse wheel scrolling + // If a child window has the ImGuiWindowFlags_NoScrollWithMouse flag, we give a chance to scroll its parent + if (g.IO.KeyCtrl) + return; + + // As a standard behavior holding SHIFT while using Vertical Mouse Wheel triggers Horizontal scroll instead + // (we avoid doing it on OSX as it the OS input layer handles this already) + const bool swap_axis = g.IO.KeyShift && !g.IO.ConfigMacOSXBehaviors; + const float wheel_y = swap_axis ? 0.0f : g.IO.MouseWheel; + const float wheel_x = swap_axis ? g.IO.MouseWheel : g.IO.MouseWheelH; + + // Vertical Mouse Wheel scrolling + if (wheel_y != 0.0f) + { + StartLockWheelingWindow(window); + while ((window->Flags & ImGuiWindowFlags_ChildWindow) && ((window->ScrollMax.y == 0.0f) || ((window->Flags & ImGuiWindowFlags_NoScrollWithMouse) && !(window->Flags & ImGuiWindowFlags_NoMouseInputs)))) + window = window->ParentWindow; + if (!(window->Flags & ImGuiWindowFlags_NoScrollWithMouse) && !(window->Flags & ImGuiWindowFlags_NoMouseInputs)) + { + float max_step = window->InnerRect.GetHeight() * 0.67f; + float scroll_step = ImFloor(ImMin(5 * window->CalcFontSize(), max_step)); + SetScrollY(window, window->Scroll.y - wheel_y * scroll_step); + } + } + + // Horizontal Mouse Wheel scrolling, or Vertical Mouse Wheel w/ Shift held + if (wheel_x != 0.0f) + { + StartLockWheelingWindow(window); + while ((window->Flags & ImGuiWindowFlags_ChildWindow) && ((window->ScrollMax.x == 0.0f) || ((window->Flags & ImGuiWindowFlags_NoScrollWithMouse) && !(window->Flags & ImGuiWindowFlags_NoMouseInputs)))) + window = window->ParentWindow; + if (!(window->Flags & ImGuiWindowFlags_NoScrollWithMouse) && !(window->Flags & ImGuiWindowFlags_NoMouseInputs)) + { + float max_step = window->InnerRect.GetWidth() * 0.67f; + float scroll_step = ImFloor(ImMin(2 * window->CalcFontSize(), max_step)); + SetScrollX(window, window->Scroll.x - wheel_x * scroll_step); + } + } +} + +void ImGui::UpdateTabFocus() +{ + ImGuiContext& g = *GImGui; + + // Pressing TAB activate widget focus + g.TabFocusPressed = (g.NavWindow && g.NavWindow->Active && !(g.NavWindow->Flags & ImGuiWindowFlags_NoNavInputs) && !g.IO.KeyCtrl && IsKeyPressedMap(ImGuiKey_Tab)); + if (g.ActiveId == 0 && g.TabFocusPressed) + { + // - This path is only taken when no widget are active/tabbed-into yet. + // Subsequent tabbing will be processed by FocusableItemRegister() + // - Note that SetKeyboardFocusHere() sets the Next fields mid-frame. To be consistent we also + // manipulate the Next fields here even though they will be turned into Curr fields below. + g.TabFocusRequestNextWindow = g.NavWindow; + g.TabFocusRequestNextCounterRegular = INT_MAX; + if (g.NavId != 0 && g.NavIdTabCounter != INT_MAX) + g.TabFocusRequestNextCounterTabStop = g.NavIdTabCounter + (g.IO.KeyShift ? -1 : 0); + else + g.TabFocusRequestNextCounterTabStop = g.IO.KeyShift ? -1 : 0; + } + + // Turn queued focus request into current one + g.TabFocusRequestCurrWindow = NULL; + g.TabFocusRequestCurrCounterRegular = g.TabFocusRequestCurrCounterTabStop = INT_MAX; + if (g.TabFocusRequestNextWindow != NULL) + { + ImGuiWindow* window = g.TabFocusRequestNextWindow; + g.TabFocusRequestCurrWindow = window; + if (g.TabFocusRequestNextCounterRegular != INT_MAX && window->DC.FocusCounterRegular != -1) + g.TabFocusRequestCurrCounterRegular = ImModPositive(g.TabFocusRequestNextCounterRegular, window->DC.FocusCounterRegular + 1); + if (g.TabFocusRequestNextCounterTabStop != INT_MAX && window->DC.FocusCounterTabStop != -1) + g.TabFocusRequestCurrCounterTabStop = ImModPositive(g.TabFocusRequestNextCounterTabStop, window->DC.FocusCounterTabStop + 1); + g.TabFocusRequestNextWindow = NULL; + g.TabFocusRequestNextCounterRegular = g.TabFocusRequestNextCounterTabStop = INT_MAX; + } + + g.NavIdTabCounter = INT_MAX; +} + +// The reason this is exposed in imgui_internal.h is: on touch-based system that don't have hovering, we want to dispatch inputs to the right target (imgui vs imgui+app) +void ImGui::UpdateHoveredWindowAndCaptureFlags() +{ + ImGuiContext& g = *GImGui; + ImGuiIO& io = g.IO; + g.WindowsHoverPadding = ImMax(g.Style.TouchExtraPadding, ImVec2(WINDOWS_HOVER_PADDING, WINDOWS_HOVER_PADDING)); + + // Find the window hovered by mouse: + // - Child windows can extend beyond the limit of their parent so we need to derive HoveredRootWindow from HoveredWindow. + // - When moving a window we can skip the search, which also conveniently bypasses the fact that window->WindowRectClipped is lagging as this point of the frame. + // - We also support the moved window toggling the NoInputs flag after moving has started in order to be able to detect windows below it, which is useful for e.g. docking mechanisms. + bool clear_hovered_windows = false; + FindHoveredWindow(); + + // Modal windows prevents mouse from hovering behind them. + ImGuiWindow* modal_window = GetTopMostPopupModal(); + if (modal_window && g.HoveredWindow && !IsWindowChildOf(g.HoveredWindow->RootWindow, modal_window)) + clear_hovered_windows = true; + + // Disabled mouse? + if (io.ConfigFlags & ImGuiConfigFlags_NoMouse) + clear_hovered_windows = true; + + // We track click ownership. When clicked outside of a window the click is owned by the application and + // won't report hovering nor request capture even while dragging over our windows afterward. + const bool has_open_popup = (g.OpenPopupStack.Size > 0); + const bool has_open_modal = (modal_window != NULL); + int mouse_earliest_down = -1; + bool mouse_any_down = false; + for (int i = 0; i < IM_ARRAYSIZE(io.MouseDown); i++) + { + if (io.MouseClicked[i]) + { + io.MouseDownOwned[i] = (g.HoveredWindow != NULL) || has_open_popup; + io.MouseDownOwnedUnlessPopupClose[i] = (g.HoveredWindow != NULL) || has_open_modal; + } + mouse_any_down |= io.MouseDown[i]; + if (io.MouseDown[i]) + if (mouse_earliest_down == -1 || io.MouseClickedTime[i] < io.MouseClickedTime[mouse_earliest_down]) + mouse_earliest_down = i; + } + const bool mouse_avail = (mouse_earliest_down == -1) || io.MouseDownOwned[mouse_earliest_down]; + const bool mouse_avail_unless_popup_close = (mouse_earliest_down == -1) || io.MouseDownOwnedUnlessPopupClose[mouse_earliest_down]; + + // If mouse was first clicked outside of ImGui bounds we also cancel out hovering. + // FIXME: For patterns of drag and drop across OS windows, we may need to rework/remove this test (first committed 311c0ca9 on 2015/02) + const bool mouse_dragging_extern_payload = g.DragDropActive && (g.DragDropSourceFlags & ImGuiDragDropFlags_SourceExtern) != 0; + if (!mouse_avail && !mouse_dragging_extern_payload) + clear_hovered_windows = true; + + if (clear_hovered_windows) + g.HoveredWindow = g.HoveredWindowUnderMovingWindow = NULL; + + // Update io.WantCaptureMouse for the user application (true = dispatch mouse info to Dear ImGui only, false = dispatch mouse to Dear ImGui + underlying app) + // Update io.WantCaptureMouseAllowPopupClose (experimental) to give a chance for app to react to popup closure with a drag + if (g.WantCaptureMouseNextFrame != -1) + { + io.WantCaptureMouse = io.WantCaptureMouseUnlessPopupClose = (g.WantCaptureMouseNextFrame != 0); + } + else + { + io.WantCaptureMouse = (mouse_avail && (g.HoveredWindow != NULL || mouse_any_down)) || has_open_popup; + io.WantCaptureMouseUnlessPopupClose = (mouse_avail_unless_popup_close && (g.HoveredWindow != NULL || mouse_any_down)) || has_open_modal; + } + + // Update io.WantCaptureKeyboard for the user application (true = dispatch keyboard info to Dear ImGui only, false = dispatch keyboard info to Dear ImGui + underlying app) + if (g.WantCaptureKeyboardNextFrame != -1) + io.WantCaptureKeyboard = (g.WantCaptureKeyboardNextFrame != 0); + else + io.WantCaptureKeyboard = (g.ActiveId != 0) || (modal_window != NULL); + if (io.NavActive && (io.ConfigFlags & ImGuiConfigFlags_NavEnableKeyboard) && !(io.ConfigFlags & ImGuiConfigFlags_NavNoCaptureKeyboard)) + io.WantCaptureKeyboard = true; + + // Update io.WantTextInput flag, this is to allow systems without a keyboard (e.g. mobile, hand-held) to show a software keyboard if possible + io.WantTextInput = (g.WantTextInputNextFrame != -1) ? (g.WantTextInputNextFrame != 0) : false; +} + +ImGuiKeyModFlags ImGui::GetMergedKeyModFlags() +{ + ImGuiContext& g = *GImGui; + ImGuiKeyModFlags key_mod_flags = ImGuiKeyModFlags_None; + if (g.IO.KeyCtrl) { key_mod_flags |= ImGuiKeyModFlags_Ctrl; } + if (g.IO.KeyShift) { key_mod_flags |= ImGuiKeyModFlags_Shift; } + if (g.IO.KeyAlt) { key_mod_flags |= ImGuiKeyModFlags_Alt; } + if (g.IO.KeySuper) { key_mod_flags |= ImGuiKeyModFlags_Super; } + return key_mod_flags; +} + +void ImGui::NewFrame() +{ + IM_ASSERT(GImGui != NULL && "No current context. Did you call ImGui::CreateContext() and ImGui::SetCurrentContext() ?"); + ImGuiContext& g = *GImGui; + + // Remove pending delete hooks before frame start. + // This deferred removal avoid issues of removal while iterating the hook vector + for (int n = g.Hooks.Size - 1; n >= 0; n--) + if (g.Hooks[n].Type == ImGuiContextHookType_PendingRemoval_) + g.Hooks.erase(&g.Hooks[n]); + + CallContextHooks(&g, ImGuiContextHookType_NewFramePre); + + // Check and assert for various common IO and Configuration mistakes + ErrorCheckNewFrameSanityChecks(); + + // Load settings on first frame, save settings when modified (after a delay) + UpdateSettings(); + + g.Time += g.IO.DeltaTime; + g.WithinFrameScope = true; + g.FrameCount += 1; + g.TooltipOverrideCount = 0; + g.WindowsActiveCount = 0; + g.MenusIdSubmittedThisFrame.resize(0); + + // Calculate frame-rate for the user, as a purely luxurious feature + g.FramerateSecPerFrameAccum += g.IO.DeltaTime - g.FramerateSecPerFrame[g.FramerateSecPerFrameIdx]; + g.FramerateSecPerFrame[g.FramerateSecPerFrameIdx] = g.IO.DeltaTime; + g.FramerateSecPerFrameIdx = (g.FramerateSecPerFrameIdx + 1) % IM_ARRAYSIZE(g.FramerateSecPerFrame); + g.FramerateSecPerFrameCount = ImMin(g.FramerateSecPerFrameCount + 1, IM_ARRAYSIZE(g.FramerateSecPerFrame)); + g.IO.Framerate = (g.FramerateSecPerFrameAccum > 0.0f) ? (1.0f / (g.FramerateSecPerFrameAccum / (float)g.FramerateSecPerFrameCount)) : FLT_MAX; + + UpdateViewportsNewFrame(); + + // Setup current font and draw list shared data + g.IO.Fonts->Locked = true; + SetCurrentFont(GetDefaultFont()); + IM_ASSERT(g.Font->IsLoaded()); + ImRect virtual_space(FLT_MAX, FLT_MAX, -FLT_MAX, -FLT_MAX); + for (int n = 0; n < g.Viewports.Size; n++) + virtual_space.Add(g.Viewports[n]->GetMainRect()); + g.DrawListSharedData.ClipRectFullscreen = virtual_space.ToVec4(); + g.DrawListSharedData.CurveTessellationTol = g.Style.CurveTessellationTol; + g.DrawListSharedData.SetCircleTessellationMaxError(g.Style.CircleTessellationMaxError); + g.DrawListSharedData.InitialFlags = ImDrawListFlags_None; + if (g.Style.AntiAliasedLines) + g.DrawListSharedData.InitialFlags |= ImDrawListFlags_AntiAliasedLines; + if (g.Style.AntiAliasedLinesUseTex && !(g.Font->ContainerAtlas->Flags & ImFontAtlasFlags_NoBakedLines)) + g.DrawListSharedData.InitialFlags |= ImDrawListFlags_AntiAliasedLinesUseTex; + if (g.Style.AntiAliasedFill) + g.DrawListSharedData.InitialFlags |= ImDrawListFlags_AntiAliasedFill; + if (g.IO.BackendFlags & ImGuiBackendFlags_RendererHasVtxOffset) + g.DrawListSharedData.InitialFlags |= ImDrawListFlags_AllowVtxOffset; + + // Mark rendering data as invalid to prevent user who may have a handle on it to use it. + for (int n = 0; n < g.Viewports.Size; n++) + { + ImGuiViewportP* viewport = g.Viewports[n]; + viewport->DrawDataP.Clear(); + } + + // Drag and drop keep the source ID alive so even if the source disappear our state is consistent + if (g.DragDropActive && g.DragDropPayload.SourceId == g.ActiveId) + KeepAliveID(g.DragDropPayload.SourceId); + + // Update HoveredId data + if (!g.HoveredIdPreviousFrame) + g.HoveredIdTimer = 0.0f; + if (!g.HoveredIdPreviousFrame || (g.HoveredId && g.ActiveId == g.HoveredId)) + g.HoveredIdNotActiveTimer = 0.0f; + if (g.HoveredId) + g.HoveredIdTimer += g.IO.DeltaTime; + if (g.HoveredId && g.ActiveId != g.HoveredId) + g.HoveredIdNotActiveTimer += g.IO.DeltaTime; + g.HoveredIdPreviousFrame = g.HoveredId; + g.HoveredIdPreviousFrameUsingMouseWheel = g.HoveredIdUsingMouseWheel; + g.HoveredId = 0; + g.HoveredIdAllowOverlap = false; + g.HoveredIdUsingMouseWheel = false; + g.HoveredIdDisabled = false; + + // Update ActiveId data (clear reference to active widget if the widget isn't alive anymore) + if (g.ActiveIdIsAlive != g.ActiveId && g.ActiveIdPreviousFrame == g.ActiveId && g.ActiveId != 0) + ClearActiveID(); + if (g.ActiveId) + g.ActiveIdTimer += g.IO.DeltaTime; + g.LastActiveIdTimer += g.IO.DeltaTime; + g.ActiveIdPreviousFrame = g.ActiveId; + g.ActiveIdPreviousFrameWindow = g.ActiveIdWindow; + g.ActiveIdPreviousFrameHasBeenEditedBefore = g.ActiveIdHasBeenEditedBefore; + g.ActiveIdIsAlive = 0; + g.ActiveIdHasBeenEditedThisFrame = false; + g.ActiveIdPreviousFrameIsAlive = false; + g.ActiveIdIsJustActivated = false; + if (g.TempInputId != 0 && g.ActiveId != g.TempInputId) + g.TempInputId = 0; + if (g.ActiveId == 0) + { + g.ActiveIdUsingNavDirMask = 0x00; + g.ActiveIdUsingNavInputMask = 0x00; + g.ActiveIdUsingKeyInputMask = 0x00; + } + + // Drag and drop + g.DragDropAcceptIdPrev = g.DragDropAcceptIdCurr; + g.DragDropAcceptIdCurr = 0; + g.DragDropAcceptIdCurrRectSurface = FLT_MAX; + g.DragDropWithinSource = false; + g.DragDropWithinTarget = false; + g.DragDropHoldJustPressedId = 0; + + // Update keyboard input state + // Synchronize io.KeyMods with individual modifiers io.KeyXXX bools + g.IO.KeyMods = GetMergedKeyModFlags(); + memcpy(g.IO.KeysDownDurationPrev, g.IO.KeysDownDuration, sizeof(g.IO.KeysDownDuration)); + for (int i = 0; i < IM_ARRAYSIZE(g.IO.KeysDown); i++) + g.IO.KeysDownDuration[i] = g.IO.KeysDown[i] ? (g.IO.KeysDownDuration[i] < 0.0f ? 0.0f : g.IO.KeysDownDuration[i] + g.IO.DeltaTime) : -1.0f; + + // Update gamepad/keyboard navigation + NavUpdate(); + + // Update mouse input state + UpdateMouseInputs(); + + // Find hovered window + // (needs to be before UpdateMouseMovingWindowNewFrame so we fill g.HoveredWindowUnderMovingWindow on the mouse release frame) + UpdateHoveredWindowAndCaptureFlags(); + + // Handle user moving window with mouse (at the beginning of the frame to avoid input lag or sheering) + UpdateMouseMovingWindowNewFrame(); + + // Background darkening/whitening + if (GetTopMostPopupModal() != NULL || (g.NavWindowingTarget != NULL && g.NavWindowingHighlightAlpha > 0.0f)) + g.DimBgRatio = ImMin(g.DimBgRatio + g.IO.DeltaTime * 6.0f, 1.0f); + else + g.DimBgRatio = ImMax(g.DimBgRatio - g.IO.DeltaTime * 10.0f, 0.0f); + + g.MouseCursor = ImGuiMouseCursor_Arrow; + g.WantCaptureMouseNextFrame = g.WantCaptureKeyboardNextFrame = g.WantTextInputNextFrame = -1; + g.PlatformImePos = ImVec2(1.0f, 1.0f); // OS Input Method Editor showing on top-left of our window by default + + // Mouse wheel scrolling, scale + UpdateMouseWheel(); + + // Update legacy TAB focus + UpdateTabFocus(); + + // Mark all windows as not visible and compact unused memory. + IM_ASSERT(g.WindowsFocusOrder.Size <= g.Windows.Size); + const float memory_compact_start_time = (g.GcCompactAll || g.IO.ConfigMemoryCompactTimer < 0.0f) ? FLT_MAX : (float)g.Time - g.IO.ConfigMemoryCompactTimer; + for (int i = 0; i != g.Windows.Size; i++) + { + ImGuiWindow* window = g.Windows[i]; + window->WasActive = window->Active; + window->BeginCount = 0; + window->Active = false; + window->WriteAccessed = false; + + // Garbage collect transient buffers of recently unused windows + if (!window->WasActive && !window->MemoryCompacted && window->LastTimeActive < memory_compact_start_time) + GcCompactTransientWindowBuffers(window); + } + + // Garbage collect transient buffers of recently unused tables + for (int i = 0; i < g.TablesLastTimeActive.Size; i++) + if (g.TablesLastTimeActive[i] >= 0.0f && g.TablesLastTimeActive[i] < memory_compact_start_time) + TableGcCompactTransientBuffers(g.Tables.GetByIndex(i)); + for (int i = 0; i < g.TablesTempDataStack.Size; i++) + if (g.TablesTempDataStack[i].LastTimeActive >= 0.0f && g.TablesTempDataStack[i].LastTimeActive < memory_compact_start_time) + TableGcCompactTransientBuffers(&g.TablesTempDataStack[i]); + if (g.GcCompactAll) + GcCompactTransientMiscBuffers(); + g.GcCompactAll = false; + + // Closing the focused window restore focus to the first active root window in descending z-order + if (g.NavWindow && !g.NavWindow->WasActive) + FocusTopMostWindowUnderOne(NULL, NULL); + + // No window should be open at the beginning of the frame. + // But in order to allow the user to call NewFrame() multiple times without calling Render(), we are doing an explicit clear. + g.CurrentWindowStack.resize(0); + g.BeginPopupStack.resize(0); + g.ItemFlagsStack.resize(0); + g.ItemFlagsStack.push_back(ImGuiItemFlags_None); + g.GroupStack.resize(0); + + // [DEBUG] Item picker tool - start with DebugStartItemPicker() - useful to visually select an item and break into its call-stack. + UpdateDebugToolItemPicker(); + + // Create implicit/fallback window - which we will only render it if the user has added something to it. + // We don't use "Debug" to avoid colliding with user trying to create a "Debug" window with custom flags. + // This fallback is particularly important as it avoid ImGui:: calls from crashing. + g.WithinFrameScopeWithImplicitWindow = true; + SetNextWindowSize(ImVec2(400, 400), ImGuiCond_FirstUseEver); + Begin("Debug##Default"); + IM_ASSERT(g.CurrentWindow->IsFallbackWindow == true); + + CallContextHooks(&g, ImGuiContextHookType_NewFramePost); +} + +// [DEBUG] Item picker tool - start with DebugStartItemPicker() - useful to visually select an item and break into its call-stack. +void ImGui::UpdateDebugToolItemPicker() +{ + ImGuiContext& g = *GImGui; + g.DebugItemPickerBreakId = 0; + if (g.DebugItemPickerActive) + { + const ImGuiID hovered_id = g.HoveredIdPreviousFrame; + SetMouseCursor(ImGuiMouseCursor_Hand); + if (IsKeyPressedMap(ImGuiKey_Escape)) + g.DebugItemPickerActive = false; + if (IsMouseClicked(0) && hovered_id) + { + g.DebugItemPickerBreakId = hovered_id; + g.DebugItemPickerActive = false; + } + SetNextWindowBgAlpha(0.60f); + BeginTooltip(); + Text("HoveredId: 0x%08X", hovered_id); + Text("Press ESC to abort picking."); + TextColored(GetStyleColorVec4(hovered_id ? ImGuiCol_Text : ImGuiCol_TextDisabled), "Click to break in debugger!"); + EndTooltip(); + } +} + +void ImGui::Initialize(ImGuiContext* context) +{ + ImGuiContext& g = *context; + IM_ASSERT(!g.Initialized && !g.SettingsLoaded); + + // Add .ini handle for ImGuiWindow type + { + ImGuiSettingsHandler ini_handler; + ini_handler.TypeName = "Window"; + ini_handler.TypeHash = ImHashStr("Window"); + ini_handler.ClearAllFn = WindowSettingsHandler_ClearAll; + ini_handler.ReadOpenFn = WindowSettingsHandler_ReadOpen; + ini_handler.ReadLineFn = WindowSettingsHandler_ReadLine; + ini_handler.ApplyAllFn = WindowSettingsHandler_ApplyAll; + ini_handler.WriteAllFn = WindowSettingsHandler_WriteAll; + g.SettingsHandlers.push_back(ini_handler); + } + + // Add .ini handle for ImGuiTable type + TableSettingsInstallHandler(context); + + // Create default viewport + ImGuiViewportP* viewport = IM_NEW(ImGuiViewportP)(); + g.Viewports.push_back(viewport); + +#ifdef IMGUI_HAS_DOCK +#endif + + g.Initialized = true; +} + +// This function is merely here to free heap allocations. +void ImGui::Shutdown(ImGuiContext* context) +{ + // The fonts atlas can be used prior to calling NewFrame(), so we clear it even if g.Initialized is FALSE (which would happen if we never called NewFrame) + ImGuiContext& g = *context; + if (g.IO.Fonts && g.FontAtlasOwnedByContext) + { + g.IO.Fonts->Locked = false; + IM_DELETE(g.IO.Fonts); + } + g.IO.Fonts = NULL; + + // Cleanup of other data are conditional on actually having initialized Dear ImGui. + if (!g.Initialized) + return; + + // Save settings (unless we haven't attempted to load them: CreateContext/DestroyContext without a call to NewFrame shouldn't save an empty file) + if (g.SettingsLoaded && g.IO.IniFilename != NULL) + { + ImGuiContext* backup_context = GImGui; + SetCurrentContext(&g); + SaveIniSettingsToDisk(g.IO.IniFilename); + SetCurrentContext(backup_context); + } + + CallContextHooks(&g, ImGuiContextHookType_Shutdown); + + // Clear everything else + g.Windows.clear_delete(); + g.WindowsFocusOrder.clear(); + g.WindowsTempSortBuffer.clear(); + g.CurrentWindow = NULL; + g.CurrentWindowStack.clear(); + g.WindowsById.Clear(); + g.NavWindow = NULL; + g.HoveredWindow = g.HoveredWindowUnderMovingWindow = NULL; + g.ActiveIdWindow = g.ActiveIdPreviousFrameWindow = NULL; + g.MovingWindow = NULL; + g.ColorStack.clear(); + g.StyleVarStack.clear(); + g.FontStack.clear(); + g.OpenPopupStack.clear(); + g.BeginPopupStack.clear(); + + g.Viewports.clear_delete(); + + g.TabBars.Clear(); + g.CurrentTabBarStack.clear(); + g.ShrinkWidthBuffer.clear(); + + g.Tables.Clear(); + g.TablesTempDataStack.clear_destruct(); + g.DrawChannelsTempMergeBuffer.clear(); + + g.ClipboardHandlerData.clear(); + g.MenusIdSubmittedThisFrame.clear(); + g.InputTextState.ClearFreeMemory(); + + g.SettingsWindows.clear(); + g.SettingsHandlers.clear(); + + if (g.LogFile) + { +#ifndef IMGUI_DISABLE_TTY_FUNCTIONS + if (g.LogFile != stdout) +#endif + ImFileClose(g.LogFile); + g.LogFile = NULL; + } + g.LogBuffer.clear(); + + g.Initialized = false; +} + +// FIXME: Add a more explicit sort order in the window structure. +static int IMGUI_CDECL ChildWindowComparer(const void* lhs, const void* rhs) +{ + const ImGuiWindow* const a = *(const ImGuiWindow* const *)lhs; + const ImGuiWindow* const b = *(const ImGuiWindow* const *)rhs; + if (int d = (a->Flags & ImGuiWindowFlags_Popup) - (b->Flags & ImGuiWindowFlags_Popup)) + return d; + if (int d = (a->Flags & ImGuiWindowFlags_Tooltip) - (b->Flags & ImGuiWindowFlags_Tooltip)) + return d; + return (a->BeginOrderWithinParent - b->BeginOrderWithinParent); +} + +static void AddWindowToSortBuffer(ImVector* out_sorted_windows, ImGuiWindow* window) +{ + out_sorted_windows->push_back(window); + if (window->Active) + { + int count = window->DC.ChildWindows.Size; + if (count > 1) + ImQsort(window->DC.ChildWindows.Data, (size_t)count, sizeof(ImGuiWindow*), ChildWindowComparer); + for (int i = 0; i < count; i++) + { + ImGuiWindow* child = window->DC.ChildWindows[i]; + if (child->Active) + AddWindowToSortBuffer(out_sorted_windows, child); + } + } +} + +static void AddDrawListToDrawData(ImVector* out_list, ImDrawList* draw_list) +{ + // Remove trailing command if unused. + // Technically we could return directly instead of popping, but this make things looks neat in Metrics/Debugger window as well. + draw_list->_PopUnusedDrawCmd(); + if (draw_list->CmdBuffer.Size == 0) + return; + + // Draw list sanity check. Detect mismatch between PrimReserve() calls and incrementing _VtxCurrentIdx, _VtxWritePtr etc. + // May trigger for you if you are using PrimXXX functions incorrectly. + IM_ASSERT(draw_list->VtxBuffer.Size == 0 || draw_list->_VtxWritePtr == draw_list->VtxBuffer.Data + draw_list->VtxBuffer.Size); + IM_ASSERT(draw_list->IdxBuffer.Size == 0 || draw_list->_IdxWritePtr == draw_list->IdxBuffer.Data + draw_list->IdxBuffer.Size); + if (!(draw_list->Flags & ImDrawListFlags_AllowVtxOffset)) + IM_ASSERT((int)draw_list->_VtxCurrentIdx == draw_list->VtxBuffer.Size); + + // Check that draw_list doesn't use more vertices than indexable (default ImDrawIdx = unsigned short = 2 bytes = 64K vertices per ImDrawList = per window) + // If this assert triggers because you are drawing lots of stuff manually: + // - First, make sure you are coarse clipping yourself and not trying to draw many things outside visible bounds. + // Be mindful that the ImDrawList API doesn't filter vertices. Use the Metrics/Debugger window to inspect draw list contents. + // - If you want large meshes with more than 64K vertices, you can either: + // (A) Handle the ImDrawCmd::VtxOffset value in your renderer backend, and set 'io.BackendFlags |= ImGuiBackendFlags_RendererHasVtxOffset'. + // Most example backends already support this from 1.71. Pre-1.71 backends won't. + // Some graphics API such as GL ES 1/2 don't have a way to offset the starting vertex so it is not supported for them. + // (B) Or handle 32-bit indices in your renderer backend, and uncomment '#define ImDrawIdx unsigned int' line in imconfig.h. + // Most example backends already support this. For example, the OpenGL example code detect index size at compile-time: + // glDrawElements(GL_TRIANGLES, (GLsizei)pcmd->ElemCount, sizeof(ImDrawIdx) == 2 ? GL_UNSIGNED_SHORT : GL_UNSIGNED_INT, idx_buffer_offset); + // Your own engine or render API may use different parameters or function calls to specify index sizes. + // 2 and 4 bytes indices are generally supported by most graphics API. + // - If for some reason neither of those solutions works for you, a workaround is to call BeginChild()/EndChild() before reaching + // the 64K limit to split your draw commands in multiple draw lists. + if (sizeof(ImDrawIdx) == 2) + IM_ASSERT(draw_list->_VtxCurrentIdx < (1 << 16) && "Too many vertices in ImDrawList using 16-bit indices. Read comment above"); + + out_list->push_back(draw_list); +} + +static void AddWindowToDrawData(ImGuiWindow* window, int layer) +{ + ImGuiContext& g = *GImGui; + ImGuiViewportP* viewport = g.Viewports[0]; + g.IO.MetricsRenderWindows++; + AddDrawListToDrawData(&viewport->DrawDataBuilder.Layers[layer], window->DrawList); + for (int i = 0; i < window->DC.ChildWindows.Size; i++) + { + ImGuiWindow* child = window->DC.ChildWindows[i]; + if (IsWindowActiveAndVisible(child)) // Clipped children may have been marked not active + AddWindowToDrawData(child, layer); + } +} + +// Layer is locked for the root window, however child windows may use a different viewport (e.g. extruding menu) +static void AddRootWindowToDrawData(ImGuiWindow* window) +{ + int layer = (window->Flags & ImGuiWindowFlags_Tooltip) ? 1 : 0; + AddWindowToDrawData(window, layer); +} + +void ImDrawDataBuilder::FlattenIntoSingleLayer() +{ + int n = Layers[0].Size; + int size = n; + for (int i = 1; i < IM_ARRAYSIZE(Layers); i++) + size += Layers[i].Size; + Layers[0].resize(size); + for (int layer_n = 1; layer_n < IM_ARRAYSIZE(Layers); layer_n++) + { + ImVector& layer = Layers[layer_n]; + if (layer.empty()) + continue; + memcpy(&Layers[0][n], &layer[0], layer.Size * sizeof(ImDrawList*)); + n += layer.Size; + layer.resize(0); + } +} + +static void SetupViewportDrawData(ImGuiViewportP* viewport, ImVector* draw_lists) +{ + ImGuiIO& io = ImGui::GetIO(); + ImDrawData* draw_data = &viewport->DrawDataP; + draw_data->Valid = true; + draw_data->CmdLists = (draw_lists->Size > 0) ? draw_lists->Data : NULL; + draw_data->CmdListsCount = draw_lists->Size; + draw_data->TotalVtxCount = draw_data->TotalIdxCount = 0; + draw_data->DisplayPos = viewport->Pos; + draw_data->DisplaySize = viewport->Size; + draw_data->FramebufferScale = io.DisplayFramebufferScale; + for (int n = 0; n < draw_lists->Size; n++) + { + draw_data->TotalVtxCount += draw_lists->Data[n]->VtxBuffer.Size; + draw_data->TotalIdxCount += draw_lists->Data[n]->IdxBuffer.Size; + } +} + +// Push a clipping rectangle for both ImGui logic (hit-testing etc.) and low-level ImDrawList rendering. +// - When using this function it is sane to ensure that float are perfectly rounded to integer values, +// so that e.g. (int)(max.x-min.x) in user's render produce correct result. +// - If the code here changes, may need to update code of functions like NextColumn() and PushColumnClipRect(): +// some frequently called functions which to modify both channels and clipping simultaneously tend to use the +// more specialized SetWindowClipRectBeforeSetChannel() to avoid extraneous updates of underlying ImDrawCmds. +void ImGui::PushClipRect(const ImVec2& clip_rect_min, const ImVec2& clip_rect_max, bool intersect_with_current_clip_rect) +{ + ImGuiWindow* window = GetCurrentWindow(); + window->DrawList->PushClipRect(clip_rect_min, clip_rect_max, intersect_with_current_clip_rect); + window->ClipRect = window->DrawList->_ClipRectStack.back(); +} + +void ImGui::PopClipRect() +{ + ImGuiWindow* window = GetCurrentWindow(); + window->DrawList->PopClipRect(); + window->ClipRect = window->DrawList->_ClipRectStack.back(); +} + +// This is normally called by Render(). You may want to call it directly if you want to avoid calling Render() but the gain will be very minimal. +void ImGui::EndFrame() +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.Initialized); + + // Don't process EndFrame() multiple times. + if (g.FrameCountEnded == g.FrameCount) + return; + IM_ASSERT(g.WithinFrameScope && "Forgot to call ImGui::NewFrame()?"); + + CallContextHooks(&g, ImGuiContextHookType_EndFramePre); + + ErrorCheckEndFrameSanityChecks(); + + // Notify OS when our Input Method Editor cursor has moved (e.g. CJK inputs using Microsoft IME) + if (g.IO.ImeSetInputScreenPosFn && (g.PlatformImeLastPos.x == FLT_MAX || ImLengthSqr(g.PlatformImeLastPos - g.PlatformImePos) > 0.0001f)) + { + g.IO.ImeSetInputScreenPosFn((int)g.PlatformImePos.x, (int)g.PlatformImePos.y); + g.PlatformImeLastPos = g.PlatformImePos; + } + + // Hide implicit/fallback "Debug" window if it hasn't been used + g.WithinFrameScopeWithImplicitWindow = false; + if (g.CurrentWindow && !g.CurrentWindow->WriteAccessed) + g.CurrentWindow->Active = false; + End(); + + // Update navigation: CTRL+Tab, wrap-around requests + NavEndFrame(); + + // Drag and Drop: Elapse payload (if delivered, or if source stops being submitted) + if (g.DragDropActive) + { + bool is_delivered = g.DragDropPayload.Delivery; + bool is_elapsed = (g.DragDropPayload.DataFrameCount + 1 < g.FrameCount) && ((g.DragDropSourceFlags & ImGuiDragDropFlags_SourceAutoExpirePayload) || !IsMouseDown(g.DragDropMouseButton)); + if (is_delivered || is_elapsed) + ClearDragDrop(); + } + + // Drag and Drop: Fallback for source tooltip. This is not ideal but better than nothing. + if (g.DragDropActive && g.DragDropSourceFrameCount < g.FrameCount && !(g.DragDropSourceFlags & ImGuiDragDropFlags_SourceNoPreviewTooltip)) + { + g.DragDropWithinSource = true; + SetTooltip("..."); + g.DragDropWithinSource = false; + } + + // End frame + g.WithinFrameScope = false; + g.FrameCountEnded = g.FrameCount; + + // Initiate moving window + handle left-click and right-click focus + UpdateMouseMovingWindowEndFrame(); + + // Sort the window list so that all child windows are after their parent + // We cannot do that on FocusWindow() because children may not exist yet + g.WindowsTempSortBuffer.resize(0); + g.WindowsTempSortBuffer.reserve(g.Windows.Size); + for (int i = 0; i != g.Windows.Size; i++) + { + ImGuiWindow* window = g.Windows[i]; + if (window->Active && (window->Flags & ImGuiWindowFlags_ChildWindow)) // if a child is active its parent will add it + continue; + AddWindowToSortBuffer(&g.WindowsTempSortBuffer, window); + } + + // This usually assert if there is a mismatch between the ImGuiWindowFlags_ChildWindow / ParentWindow values and DC.ChildWindows[] in parents, aka we've done something wrong. + IM_ASSERT(g.Windows.Size == g.WindowsTempSortBuffer.Size); + g.Windows.swap(g.WindowsTempSortBuffer); + g.IO.MetricsActiveWindows = g.WindowsActiveCount; + + // Unlock font atlas + g.IO.Fonts->Locked = false; + + // Clear Input data for next frame + g.IO.MouseWheel = g.IO.MouseWheelH = 0.0f; + g.IO.InputQueueCharacters.resize(0); + g.IO.KeyModsPrev = g.IO.KeyMods; // doing it here is better than in NewFrame() as we'll tolerate backend writing to KeyMods. If we want to firmly disallow it we should detect it. + memset(g.IO.NavInputs, 0, sizeof(g.IO.NavInputs)); + + CallContextHooks(&g, ImGuiContextHookType_EndFramePost); +} + +// Prepare the data for rendering so you can call GetDrawData() +// (As with anything within the ImGui:: namspace this doesn't touch your GPU or graphics API at all: +// it is the role of the ImGui_ImplXXXX_RenderDrawData() function provided by the renderer backend) +void ImGui::Render() +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.Initialized); + + if (g.FrameCountEnded != g.FrameCount) + EndFrame(); + g.FrameCountRendered = g.FrameCount; + g.IO.MetricsRenderWindows = 0; + + CallContextHooks(&g, ImGuiContextHookType_RenderPre); + + // Add background ImDrawList (for each active viewport) + for (int n = 0; n != g.Viewports.Size; n++) + { + ImGuiViewportP* viewport = g.Viewports[n]; + viewport->DrawDataBuilder.Clear(); + if (viewport->DrawLists[0] != NULL) + AddDrawListToDrawData(&viewport->DrawDataBuilder.Layers[0], GetBackgroundDrawList(viewport)); + } + + // Add ImDrawList to render + ImGuiWindow* windows_to_render_top_most[2]; + windows_to_render_top_most[0] = (g.NavWindowingTarget && !(g.NavWindowingTarget->Flags & ImGuiWindowFlags_NoBringToFrontOnFocus)) ? g.NavWindowingTarget->RootWindow : NULL; + windows_to_render_top_most[1] = (g.NavWindowingTarget ? g.NavWindowingListWindow : NULL); + for (int n = 0; n != g.Windows.Size; n++) + { + ImGuiWindow* window = g.Windows[n]; + IM_MSVC_WARNING_SUPPRESS(6011); // Static Analysis false positive "warning C6011: Dereferencing NULL pointer 'window'" + if (IsWindowActiveAndVisible(window) && (window->Flags & ImGuiWindowFlags_ChildWindow) == 0 && window != windows_to_render_top_most[0] && window != windows_to_render_top_most[1]) + AddRootWindowToDrawData(window); + } + for (int n = 0; n < IM_ARRAYSIZE(windows_to_render_top_most); n++) + if (windows_to_render_top_most[n] && IsWindowActiveAndVisible(windows_to_render_top_most[n])) // NavWindowingTarget is always temporarily displayed as the top-most window + AddRootWindowToDrawData(windows_to_render_top_most[n]); + + // Setup ImDrawData structures for end-user + g.IO.MetricsRenderVertices = g.IO.MetricsRenderIndices = 0; + for (int n = 0; n < g.Viewports.Size; n++) + { + ImGuiViewportP* viewport = g.Viewports[n]; + viewport->DrawDataBuilder.FlattenIntoSingleLayer(); + + // Draw software mouse cursor if requested by io.MouseDrawCursor flag + if (g.IO.MouseDrawCursor) + RenderMouseCursor(GetForegroundDrawList(viewport), g.IO.MousePos, g.Style.MouseCursorScale, g.MouseCursor, IM_COL32_WHITE, IM_COL32_BLACK, IM_COL32(0, 0, 0, 48)); + + // Add foreground ImDrawList (for each active viewport) + if (viewport->DrawLists[1] != NULL) + AddDrawListToDrawData(&viewport->DrawDataBuilder.Layers[0], GetForegroundDrawList(viewport)); + + SetupViewportDrawData(viewport, &viewport->DrawDataBuilder.Layers[0]); + ImDrawData* draw_data = &viewport->DrawDataP; + g.IO.MetricsRenderVertices += draw_data->TotalVtxCount; + g.IO.MetricsRenderIndices += draw_data->TotalIdxCount; + } + + CallContextHooks(&g, ImGuiContextHookType_RenderPost); +} + +// Calculate text size. Text can be multi-line. Optionally ignore text after a ## marker. +// CalcTextSize("") should return ImVec2(0.0f, g.FontSize) +ImVec2 ImGui::CalcTextSize(const char* text, const char* text_end, bool hide_text_after_double_hash, float wrap_width) +{ + ImGuiContext& g = *GImGui; + + const char* text_display_end; + if (hide_text_after_double_hash) + text_display_end = FindRenderedTextEnd(text, text_end); // Hide anything after a '##' string + else + text_display_end = text_end; + + ImFont* font = g.Font; + const float font_size = g.FontSize; + if (text == text_display_end) + return ImVec2(0.0f, font_size); + ImVec2 text_size = font->CalcTextSizeA(font_size, FLT_MAX, wrap_width, text, text_display_end, NULL); + + // Round + // FIXME: This has been here since Dec 2015 (7b0bf230) but down the line we want this out. + // FIXME: Investigate using ceilf or e.g. + // - https://git.musl-libc.org/cgit/musl/tree/src/math/ceilf.c + // - https://embarkstudios.github.io/rust-gpu/api/src/libm/math/ceilf.rs.html + text_size.x = IM_FLOOR(text_size.x + 0.99999f); + + return text_size; +} + +// Find window given position, search front-to-back +// FIXME: Note that we have an inconsequential lag here: OuterRectClipped is updated in Begin(), so windows moved programmatically +// with SetWindowPos() and not SetNextWindowPos() will have that rectangle lagging by a frame at the time FindHoveredWindow() is +// called, aka before the next Begin(). Moving window isn't affected. +static void FindHoveredWindow() +{ + ImGuiContext& g = *GImGui; + + ImGuiWindow* hovered_window = NULL; + ImGuiWindow* hovered_window_ignoring_moving_window = NULL; + if (g.MovingWindow && !(g.MovingWindow->Flags & ImGuiWindowFlags_NoMouseInputs)) + hovered_window = g.MovingWindow; + + ImVec2 padding_regular = g.Style.TouchExtraPadding; + ImVec2 padding_for_resize = g.IO.ConfigWindowsResizeFromEdges ? g.WindowsHoverPadding : padding_regular; + for (int i = g.Windows.Size - 1; i >= 0; i--) + { + ImGuiWindow* window = g.Windows[i]; + IM_MSVC_WARNING_SUPPRESS(28182); // [Static Analyzer] Dereferencing NULL pointer. + if (!window->Active || window->Hidden) + continue; + if (window->Flags & ImGuiWindowFlags_NoMouseInputs) + continue; + + // Using the clipped AABB, a child window will typically be clipped by its parent (not always) + ImRect bb(window->OuterRectClipped); + if (window->Flags & (ImGuiWindowFlags_ChildWindow | ImGuiWindowFlags_NoResize | ImGuiWindowFlags_AlwaysAutoResize)) + bb.Expand(padding_regular); + else + bb.Expand(padding_for_resize); + if (!bb.Contains(g.IO.MousePos)) + continue; + + // Support for one rectangular hole in any given window + // FIXME: Consider generalizing hit-testing override (with more generic data, callback, etc.) (#1512) + if (window->HitTestHoleSize.x != 0) + { + ImVec2 hole_pos(window->Pos.x + (float)window->HitTestHoleOffset.x, window->Pos.y + (float)window->HitTestHoleOffset.y); + ImVec2 hole_size((float)window->HitTestHoleSize.x, (float)window->HitTestHoleSize.y); + if (ImRect(hole_pos, hole_pos + hole_size).Contains(g.IO.MousePos)) + continue; + } + + if (hovered_window == NULL) + hovered_window = window; + IM_MSVC_WARNING_SUPPRESS(28182); // [Static Analyzer] Dereferencing NULL pointer. + if (hovered_window_ignoring_moving_window == NULL && (!g.MovingWindow || window->RootWindow != g.MovingWindow->RootWindow)) + hovered_window_ignoring_moving_window = window; + if (hovered_window && hovered_window_ignoring_moving_window) + break; + } + + g.HoveredWindow = hovered_window; + g.HoveredWindowUnderMovingWindow = hovered_window_ignoring_moving_window; +} + +// Test if mouse cursor is hovering given rectangle +// NB- Rectangle is clipped by our current clip setting +// NB- Expand the rectangle to be generous on imprecise inputs systems (g.Style.TouchExtraPadding) +bool ImGui::IsMouseHoveringRect(const ImVec2& r_min, const ImVec2& r_max, bool clip) +{ + ImGuiContext& g = *GImGui; + + // Clip + ImRect rect_clipped(r_min, r_max); + if (clip) + rect_clipped.ClipWith(g.CurrentWindow->ClipRect); + + // Expand for touch input + const ImRect rect_for_touch(rect_clipped.Min - g.Style.TouchExtraPadding, rect_clipped.Max + g.Style.TouchExtraPadding); + if (!rect_for_touch.Contains(g.IO.MousePos)) + return false; + return true; +} + +int ImGui::GetKeyIndex(ImGuiKey imgui_key) +{ + IM_ASSERT(imgui_key >= 0 && imgui_key < ImGuiKey_COUNT); + ImGuiContext& g = *GImGui; + return g.IO.KeyMap[imgui_key]; +} + +// Note that dear imgui doesn't know the semantic of each entry of io.KeysDown[]! +// Use your own indices/enums according to how your backend/engine stored them into io.KeysDown[]! +bool ImGui::IsKeyDown(int user_key_index) +{ + if (user_key_index < 0) + return false; + ImGuiContext& g = *GImGui; + IM_ASSERT(user_key_index >= 0 && user_key_index < IM_ARRAYSIZE(g.IO.KeysDown)); + return g.IO.KeysDown[user_key_index]; +} + +// t0 = previous time (e.g.: g.Time - g.IO.DeltaTime) +// t1 = current time (e.g.: g.Time) +// An event is triggered at: +// t = 0.0f t = repeat_delay, t = repeat_delay + repeat_rate*N +int ImGui::CalcTypematicRepeatAmount(float t0, float t1, float repeat_delay, float repeat_rate) +{ + if (t1 == 0.0f) + return 1; + if (t0 >= t1) + return 0; + if (repeat_rate <= 0.0f) + return (t0 < repeat_delay) && (t1 >= repeat_delay); + const int count_t0 = (t0 < repeat_delay) ? -1 : (int)((t0 - repeat_delay) / repeat_rate); + const int count_t1 = (t1 < repeat_delay) ? -1 : (int)((t1 - repeat_delay) / repeat_rate); + const int count = count_t1 - count_t0; + return count; +} + +int ImGui::GetKeyPressedAmount(int key_index, float repeat_delay, float repeat_rate) +{ + ImGuiContext& g = *GImGui; + if (key_index < 0) + return 0; + IM_ASSERT(key_index >= 0 && key_index < IM_ARRAYSIZE(g.IO.KeysDown)); + const float t = g.IO.KeysDownDuration[key_index]; + return CalcTypematicRepeatAmount(t - g.IO.DeltaTime, t, repeat_delay, repeat_rate); +} + +bool ImGui::IsKeyPressed(int user_key_index, bool repeat) +{ + ImGuiContext& g = *GImGui; + if (user_key_index < 0) + return false; + IM_ASSERT(user_key_index >= 0 && user_key_index < IM_ARRAYSIZE(g.IO.KeysDown)); + const float t = g.IO.KeysDownDuration[user_key_index]; + if (t == 0.0f) + return true; + if (repeat && t > g.IO.KeyRepeatDelay) + return GetKeyPressedAmount(user_key_index, g.IO.KeyRepeatDelay, g.IO.KeyRepeatRate) > 0; + return false; +} + +bool ImGui::IsKeyReleased(int user_key_index) +{ + ImGuiContext& g = *GImGui; + if (user_key_index < 0) return false; + IM_ASSERT(user_key_index >= 0 && user_key_index < IM_ARRAYSIZE(g.IO.KeysDown)); + return g.IO.KeysDownDurationPrev[user_key_index] >= 0.0f && !g.IO.KeysDown[user_key_index]; +} + +bool ImGui::IsMouseDown(ImGuiMouseButton button) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(button >= 0 && button < IM_ARRAYSIZE(g.IO.MouseDown)); + return g.IO.MouseDown[button]; +} + +bool ImGui::IsMouseClicked(ImGuiMouseButton button, bool repeat) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(button >= 0 && button < IM_ARRAYSIZE(g.IO.MouseDown)); + const float t = g.IO.MouseDownDuration[button]; + if (t == 0.0f) + return true; + + if (repeat && t > g.IO.KeyRepeatDelay) + { + // FIXME: 2019/05/03: Our old repeat code was wrong here and led to doubling the repeat rate, which made it an ok rate for repeat on mouse hold. + int amount = CalcTypematicRepeatAmount(t - g.IO.DeltaTime, t, g.IO.KeyRepeatDelay, g.IO.KeyRepeatRate * 0.50f); + if (amount > 0) + return true; + } + return false; +} + +bool ImGui::IsMouseReleased(ImGuiMouseButton button) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(button >= 0 && button < IM_ARRAYSIZE(g.IO.MouseDown)); + return g.IO.MouseReleased[button]; +} + +bool ImGui::IsMouseDoubleClicked(ImGuiMouseButton button) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(button >= 0 && button < IM_ARRAYSIZE(g.IO.MouseDown)); + return g.IO.MouseDoubleClicked[button]; +} + +// Return if a mouse click/drag went past the given threshold. Valid to call during the MouseReleased frame. +// [Internal] This doesn't test if the button is pressed +bool ImGui::IsMouseDragPastThreshold(ImGuiMouseButton button, float lock_threshold) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(button >= 0 && button < IM_ARRAYSIZE(g.IO.MouseDown)); + if (lock_threshold < 0.0f) + lock_threshold = g.IO.MouseDragThreshold; + return g.IO.MouseDragMaxDistanceSqr[button] >= lock_threshold * lock_threshold; +} + +bool ImGui::IsMouseDragging(ImGuiMouseButton button, float lock_threshold) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(button >= 0 && button < IM_ARRAYSIZE(g.IO.MouseDown)); + if (!g.IO.MouseDown[button]) + return false; + return IsMouseDragPastThreshold(button, lock_threshold); +} + +ImVec2 ImGui::GetMousePos() +{ + ImGuiContext& g = *GImGui; + return g.IO.MousePos; +} + +// NB: prefer to call right after BeginPopup(). At the time Selectable/MenuItem is activated, the popup is already closed! +ImVec2 ImGui::GetMousePosOnOpeningCurrentPopup() +{ + ImGuiContext& g = *GImGui; + if (g.BeginPopupStack.Size > 0) + return g.OpenPopupStack[g.BeginPopupStack.Size - 1].OpenMousePos; + return g.IO.MousePos; +} + +// We typically use ImVec2(-FLT_MAX,-FLT_MAX) to denote an invalid mouse position. +bool ImGui::IsMousePosValid(const ImVec2* mouse_pos) +{ + // The assert is only to silence a false-positive in XCode Static Analysis. + // Because GImGui is not dereferenced in every code path, the static analyzer assume that it may be NULL (which it doesn't for other functions). + IM_ASSERT(GImGui != NULL); + const float MOUSE_INVALID = -256000.0f; + ImVec2 p = mouse_pos ? *mouse_pos : GImGui->IO.MousePos; + return p.x >= MOUSE_INVALID && p.y >= MOUSE_INVALID; +} + +bool ImGui::IsAnyMouseDown() +{ + ImGuiContext& g = *GImGui; + for (int n = 0; n < IM_ARRAYSIZE(g.IO.MouseDown); n++) + if (g.IO.MouseDown[n]) + return true; + return false; +} + +// Return the delta from the initial clicking position while the mouse button is clicked or was just released. +// This is locked and return 0.0f until the mouse moves past a distance threshold at least once. +// NB: This is only valid if IsMousePosValid(). backends in theory should always keep mouse position valid when dragging even outside the client window. +ImVec2 ImGui::GetMouseDragDelta(ImGuiMouseButton button, float lock_threshold) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(button >= 0 && button < IM_ARRAYSIZE(g.IO.MouseDown)); + if (lock_threshold < 0.0f) + lock_threshold = g.IO.MouseDragThreshold; + if (g.IO.MouseDown[button] || g.IO.MouseReleased[button]) + if (g.IO.MouseDragMaxDistanceSqr[button] >= lock_threshold * lock_threshold) + if (IsMousePosValid(&g.IO.MousePos) && IsMousePosValid(&g.IO.MouseClickedPos[button])) + return g.IO.MousePos - g.IO.MouseClickedPos[button]; + return ImVec2(0.0f, 0.0f); +} + +void ImGui::ResetMouseDragDelta(ImGuiMouseButton button) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(button >= 0 && button < IM_ARRAYSIZE(g.IO.MouseDown)); + // NB: We don't need to reset g.IO.MouseDragMaxDistanceSqr + g.IO.MouseClickedPos[button] = g.IO.MousePos; +} + +ImGuiMouseCursor ImGui::GetMouseCursor() +{ + return GImGui->MouseCursor; +} + +void ImGui::SetMouseCursor(ImGuiMouseCursor cursor_type) +{ + GImGui->MouseCursor = cursor_type; +} + +void ImGui::CaptureKeyboardFromApp(bool capture) +{ + GImGui->WantCaptureKeyboardNextFrame = capture ? 1 : 0; +} + +void ImGui::CaptureMouseFromApp(bool capture) +{ + GImGui->WantCaptureMouseNextFrame = capture ? 1 : 0; +} + +bool ImGui::IsItemActive() +{ + ImGuiContext& g = *GImGui; + if (g.ActiveId) + return g.ActiveId == g.LastItemData.ID; + return false; +} + +bool ImGui::IsItemActivated() +{ + ImGuiContext& g = *GImGui; + if (g.ActiveId) + if (g.ActiveId == g.LastItemData.ID && g.ActiveIdPreviousFrame != g.LastItemData.ID) + return true; + return false; +} + +bool ImGui::IsItemDeactivated() +{ + ImGuiContext& g = *GImGui; + if (g.LastItemData.StatusFlags & ImGuiItemStatusFlags_HasDeactivated) + return (g.LastItemData.StatusFlags & ImGuiItemStatusFlags_Deactivated) != 0; + return (g.ActiveIdPreviousFrame == g.LastItemData.ID && g.ActiveIdPreviousFrame != 0 && g.ActiveId != g.LastItemData.ID); +} + +bool ImGui::IsItemDeactivatedAfterEdit() +{ + ImGuiContext& g = *GImGui; + return IsItemDeactivated() && (g.ActiveIdPreviousFrameHasBeenEditedBefore || (g.ActiveId == 0 && g.ActiveIdHasBeenEditedBefore)); +} + +// == GetItemID() == GetFocusID() +bool ImGui::IsItemFocused() +{ + ImGuiContext& g = *GImGui; + if (g.NavId != g.LastItemData.ID || g.NavId == 0) + return false; + return true; +} + +// Important: this can be useful but it is NOT equivalent to the behavior of e.g.Button()! +// Most widgets have specific reactions based on mouse-up/down state, mouse position etc. +bool ImGui::IsItemClicked(ImGuiMouseButton mouse_button) +{ + return IsMouseClicked(mouse_button) && IsItemHovered(ImGuiHoveredFlags_None); +} + +bool ImGui::IsItemToggledOpen() +{ + ImGuiContext& g = *GImGui; + return (g.LastItemData.StatusFlags & ImGuiItemStatusFlags_ToggledOpen) ? true : false; +} + +bool ImGui::IsItemToggledSelection() +{ + ImGuiContext& g = *GImGui; + return (g.LastItemData.StatusFlags & ImGuiItemStatusFlags_ToggledSelection) ? true : false; +} + +bool ImGui::IsAnyItemHovered() +{ + ImGuiContext& g = *GImGui; + return g.HoveredId != 0 || g.HoveredIdPreviousFrame != 0; +} + +bool ImGui::IsAnyItemActive() +{ + ImGuiContext& g = *GImGui; + return g.ActiveId != 0; +} + +bool ImGui::IsAnyItemFocused() +{ + ImGuiContext& g = *GImGui; + return g.NavId != 0 && !g.NavDisableHighlight; +} + +bool ImGui::IsItemVisible() +{ + ImGuiContext& g = *GImGui; + return g.CurrentWindow->ClipRect.Overlaps(g.LastItemData.Rect); +} + +bool ImGui::IsItemEdited() +{ + ImGuiContext& g = *GImGui; + return (g.LastItemData.StatusFlags & ImGuiItemStatusFlags_Edited) != 0; +} + +// Allow last item to be overlapped by a subsequent item. Both may be activated during the same frame before the later one takes priority. +// FIXME: Although this is exposed, its interaction and ideal idiom with using ImGuiButtonFlags_AllowItemOverlap flag are extremely confusing, need rework. +void ImGui::SetItemAllowOverlap() +{ + ImGuiContext& g = *GImGui; + ImGuiID id = g.LastItemData.ID; + if (g.HoveredId == id) + g.HoveredIdAllowOverlap = true; + if (g.ActiveId == id) + g.ActiveIdAllowOverlap = true; +} + +void ImGui::SetItemUsingMouseWheel() +{ + ImGuiContext& g = *GImGui; + ImGuiID id = g.LastItemData.ID; + if (g.HoveredId == id) + g.HoveredIdUsingMouseWheel = true; + if (g.ActiveId == id) + g.ActiveIdUsingMouseWheel = true; +} + +void ImGui::SetActiveIdUsingNavAndKeys() +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.ActiveId != 0); + g.ActiveIdUsingNavDirMask = ~(ImU32)0; + g.ActiveIdUsingNavInputMask = ~(ImU32)0; + g.ActiveIdUsingKeyInputMask = ~(ImU64)0; + NavMoveRequestCancel(); +} + +ImVec2 ImGui::GetItemRectMin() +{ + ImGuiContext& g = *GImGui; + return g.LastItemData.Rect.Min; +} + +ImVec2 ImGui::GetItemRectMax() +{ + ImGuiContext& g = *GImGui; + return g.LastItemData.Rect.Max; +} + +ImVec2 ImGui::GetItemRectSize() +{ + ImGuiContext& g = *GImGui; + return g.LastItemData.Rect.GetSize(); +} + +bool ImGui::BeginChildEx(const char* name, ImGuiID id, const ImVec2& size_arg, bool border, ImGuiWindowFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* parent_window = g.CurrentWindow; + + flags |= ImGuiWindowFlags_NoTitleBar | ImGuiWindowFlags_NoResize | ImGuiWindowFlags_NoSavedSettings | ImGuiWindowFlags_ChildWindow; + flags |= (parent_window->Flags & ImGuiWindowFlags_NoMove); // Inherit the NoMove flag + + // Size + const ImVec2 content_avail = GetContentRegionAvail(); + ImVec2 size = ImFloor(size_arg); + const int auto_fit_axises = ((size.x == 0.0f) ? (1 << ImGuiAxis_X) : 0x00) | ((size.y == 0.0f) ? (1 << ImGuiAxis_Y) : 0x00); + if (size.x <= 0.0f) + size.x = ImMax(content_avail.x + size.x, 4.0f); // Arbitrary minimum child size (0.0f causing too much issues) + if (size.y <= 0.0f) + size.y = ImMax(content_avail.y + size.y, 4.0f); + SetNextWindowSize(size); + + // Build up name. If you need to append to a same child from multiple location in the ID stack, use BeginChild(ImGuiID id) with a stable value. + if (name) + ImFormatString(g.TempBuffer, IM_ARRAYSIZE(g.TempBuffer), "%s/%s_%08X", parent_window->Name, name, id); + else + ImFormatString(g.TempBuffer, IM_ARRAYSIZE(g.TempBuffer), "%s/%08X", parent_window->Name, id); + + const float backup_border_size = g.Style.ChildBorderSize; + if (!border) + g.Style.ChildBorderSize = 0.0f; + bool ret = Begin(g.TempBuffer, NULL, flags); + g.Style.ChildBorderSize = backup_border_size; + + ImGuiWindow* child_window = g.CurrentWindow; + child_window->ChildId = id; + child_window->AutoFitChildAxises = (ImS8)auto_fit_axises; + + // Set the cursor to handle case where the user called SetNextWindowPos()+BeginChild() manually. + // While this is not really documented/defined, it seems that the expected thing to do. + if (child_window->BeginCount == 1) + parent_window->DC.CursorPos = child_window->Pos; + + // Process navigation-in immediately so NavInit can run on first frame + if (g.NavActivateId == id && !(flags & ImGuiWindowFlags_NavFlattened) && (child_window->DC.NavLayersActiveMask != 0 || child_window->DC.NavHasScroll)) + { + FocusWindow(child_window); + NavInitWindow(child_window, false); + SetActiveID(id + 1, child_window); // Steal ActiveId with another arbitrary id so that key-press won't activate child item + g.ActiveIdSource = ImGuiInputSource_Nav; + } + return ret; +} + +bool ImGui::BeginChild(const char* str_id, const ImVec2& size_arg, bool border, ImGuiWindowFlags extra_flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + return BeginChildEx(str_id, window->GetID(str_id), size_arg, border, extra_flags); +} + +bool ImGui::BeginChild(ImGuiID id, const ImVec2& size_arg, bool border, ImGuiWindowFlags extra_flags) +{ + IM_ASSERT(id != 0); + return BeginChildEx(NULL, id, size_arg, border, extra_flags); +} + +void ImGui::EndChild() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + IM_ASSERT(g.WithinEndChild == false); + IM_ASSERT(window->Flags & ImGuiWindowFlags_ChildWindow); // Mismatched BeginChild()/EndChild() calls + + g.WithinEndChild = true; + if (window->BeginCount > 1) + { + End(); + } + else + { + ImVec2 sz = window->Size; + if (window->AutoFitChildAxises & (1 << ImGuiAxis_X)) // Arbitrary minimum zero-ish child size of 4.0f causes less trouble than a 0.0f + sz.x = ImMax(4.0f, sz.x); + if (window->AutoFitChildAxises & (1 << ImGuiAxis_Y)) + sz.y = ImMax(4.0f, sz.y); + End(); + + ImGuiWindow* parent_window = g.CurrentWindow; + ImRect bb(parent_window->DC.CursorPos, parent_window->DC.CursorPos + sz); + ItemSize(sz); + if ((window->DC.NavLayersActiveMask != 0 || window->DC.NavHasScroll) && !(window->Flags & ImGuiWindowFlags_NavFlattened)) + { + ItemAdd(bb, window->ChildId); + RenderNavHighlight(bb, window->ChildId); + + // When browsing a window that has no activable items (scroll only) we keep a highlight on the child + if (window->DC.NavLayersActiveMask == 0 && window == g.NavWindow) + RenderNavHighlight(ImRect(bb.Min - ImVec2(2, 2), bb.Max + ImVec2(2, 2)), g.NavId, ImGuiNavHighlightFlags_TypeThin); + } + else + { + // Not navigable into + ItemAdd(bb, 0); + } + if (g.HoveredWindow == window) + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_HoveredWindow; + } + g.WithinEndChild = false; + g.LogLinePosY = -FLT_MAX; // To enforce a carriage return +} + +// Helper to create a child window / scrolling region that looks like a normal widget frame. +bool ImGui::BeginChildFrame(ImGuiID id, const ImVec2& size, ImGuiWindowFlags extra_flags) +{ + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + PushStyleColor(ImGuiCol_ChildBg, style.Colors[ImGuiCol_FrameBg]); + PushStyleVar(ImGuiStyleVar_ChildRounding, style.FrameRounding); + PushStyleVar(ImGuiStyleVar_ChildBorderSize, style.FrameBorderSize); + PushStyleVar(ImGuiStyleVar_WindowPadding, style.FramePadding); + bool ret = BeginChild(id, size, true, ImGuiWindowFlags_NoMove | ImGuiWindowFlags_AlwaysUseWindowPadding | extra_flags); + PopStyleVar(3); + PopStyleColor(); + return ret; +} + +void ImGui::EndChildFrame() +{ + EndChild(); +} + +static void SetWindowConditionAllowFlags(ImGuiWindow* window, ImGuiCond flags, bool enabled) +{ + window->SetWindowPosAllowFlags = enabled ? (window->SetWindowPosAllowFlags | flags) : (window->SetWindowPosAllowFlags & ~flags); + window->SetWindowSizeAllowFlags = enabled ? (window->SetWindowSizeAllowFlags | flags) : (window->SetWindowSizeAllowFlags & ~flags); + window->SetWindowCollapsedAllowFlags = enabled ? (window->SetWindowCollapsedAllowFlags | flags) : (window->SetWindowCollapsedAllowFlags & ~flags); +} + +ImGuiWindow* ImGui::FindWindowByID(ImGuiID id) +{ + ImGuiContext& g = *GImGui; + return (ImGuiWindow*)g.WindowsById.GetVoidPtr(id); +} + +ImGuiWindow* ImGui::FindWindowByName(const char* name) +{ + ImGuiID id = ImHashStr(name); + return FindWindowByID(id); +} + +static void ApplyWindowSettings(ImGuiWindow* window, ImGuiWindowSettings* settings) +{ + window->Pos = ImFloor(ImVec2(settings->Pos.x, settings->Pos.y)); + if (settings->Size.x > 0 && settings->Size.y > 0) + window->Size = window->SizeFull = ImFloor(ImVec2(settings->Size.x, settings->Size.y)); + window->Collapsed = settings->Collapsed; +} + +static ImGuiWindow* CreateNewWindow(const char* name, ImGuiWindowFlags flags) +{ + ImGuiContext& g = *GImGui; + //IMGUI_DEBUG_LOG("CreateNewWindow '%s', flags = 0x%08X\n", name, flags); + + // Create window the first time + ImGuiWindow* window = IM_NEW(ImGuiWindow)(&g, name); + window->Flags = flags; + g.WindowsById.SetVoidPtr(window->ID, window); + + // Default/arbitrary window position. Use SetNextWindowPos() with the appropriate condition flag to change the initial position of a window. + const ImGuiViewport* main_viewport = ImGui::GetMainViewport(); + window->Pos = main_viewport->Pos + ImVec2(60, 60); + + // User can disable loading and saving of settings. Tooltip and child windows also don't store settings. + if (!(flags & ImGuiWindowFlags_NoSavedSettings)) + if (ImGuiWindowSettings* settings = ImGui::FindWindowSettings(window->ID)) + { + // Retrieve settings from .ini file + window->SettingsOffset = g.SettingsWindows.offset_from_ptr(settings); + SetWindowConditionAllowFlags(window, ImGuiCond_FirstUseEver, false); + ApplyWindowSettings(window, settings); + } + window->DC.CursorStartPos = window->DC.CursorMaxPos = window->Pos; // So first call to CalcContentSize() doesn't return crazy values + + if ((flags & ImGuiWindowFlags_AlwaysAutoResize) != 0) + { + window->AutoFitFramesX = window->AutoFitFramesY = 2; + window->AutoFitOnlyGrows = false; + } + else + { + if (window->Size.x <= 0.0f) + window->AutoFitFramesX = 2; + if (window->Size.y <= 0.0f) + window->AutoFitFramesY = 2; + window->AutoFitOnlyGrows = (window->AutoFitFramesX > 0) || (window->AutoFitFramesY > 0); + } + + if (!(flags & ImGuiWindowFlags_ChildWindow)) + { + g.WindowsFocusOrder.push_back(window); + window->FocusOrder = (short)(g.WindowsFocusOrder.Size - 1); + } + + if (flags & ImGuiWindowFlags_NoBringToFrontOnFocus) + g.Windows.push_front(window); // Quite slow but rare and only once + else + g.Windows.push_back(window); + return window; +} + +static ImVec2 CalcWindowSizeAfterConstraint(ImGuiWindow* window, const ImVec2& size_desired) +{ + ImGuiContext& g = *GImGui; + ImVec2 new_size = size_desired; + if (g.NextWindowData.Flags & ImGuiNextWindowDataFlags_HasSizeConstraint) + { + // Using -1,-1 on either X/Y axis to preserve the current size. + ImRect cr = g.NextWindowData.SizeConstraintRect; + new_size.x = (cr.Min.x >= 0 && cr.Max.x >= 0) ? ImClamp(new_size.x, cr.Min.x, cr.Max.x) : window->SizeFull.x; + new_size.y = (cr.Min.y >= 0 && cr.Max.y >= 0) ? ImClamp(new_size.y, cr.Min.y, cr.Max.y) : window->SizeFull.y; + if (g.NextWindowData.SizeCallback) + { + ImGuiSizeCallbackData data; + data.UserData = g.NextWindowData.SizeCallbackUserData; + data.Pos = window->Pos; + data.CurrentSize = window->SizeFull; + data.DesiredSize = new_size; + g.NextWindowData.SizeCallback(&data); + new_size = data.DesiredSize; + } + new_size.x = IM_FLOOR(new_size.x); + new_size.y = IM_FLOOR(new_size.y); + } + + // Minimum size + if (!(window->Flags & (ImGuiWindowFlags_ChildWindow | ImGuiWindowFlags_AlwaysAutoResize))) + { + ImGuiWindow* window_for_height = window; + const float decoration_up_height = window_for_height->TitleBarHeight() + window_for_height->MenuBarHeight(); + new_size = ImMax(new_size, g.Style.WindowMinSize); + new_size.y = ImMax(new_size.y, decoration_up_height + ImMax(0.0f, g.Style.WindowRounding - 1.0f)); // Reduce artifacts with very small windows + } + return new_size; +} + +static void CalcWindowContentSizes(ImGuiWindow* window, ImVec2* content_size_current, ImVec2* content_size_ideal) +{ + bool preserve_old_content_sizes = false; + if (window->Collapsed && window->AutoFitFramesX <= 0 && window->AutoFitFramesY <= 0) + preserve_old_content_sizes = true; + else if (window->Hidden && window->HiddenFramesCannotSkipItems == 0 && window->HiddenFramesCanSkipItems > 0) + preserve_old_content_sizes = true; + if (preserve_old_content_sizes) + { + *content_size_current = window->ContentSize; + *content_size_ideal = window->ContentSizeIdeal; + return; + } + + content_size_current->x = (window->ContentSizeExplicit.x != 0.0f) ? window->ContentSizeExplicit.x : IM_FLOOR(window->DC.CursorMaxPos.x - window->DC.CursorStartPos.x); + content_size_current->y = (window->ContentSizeExplicit.y != 0.0f) ? window->ContentSizeExplicit.y : IM_FLOOR(window->DC.CursorMaxPos.y - window->DC.CursorStartPos.y); + content_size_ideal->x = (window->ContentSizeExplicit.x != 0.0f) ? window->ContentSizeExplicit.x : IM_FLOOR(ImMax(window->DC.CursorMaxPos.x, window->DC.IdealMaxPos.x) - window->DC.CursorStartPos.x); + content_size_ideal->y = (window->ContentSizeExplicit.y != 0.0f) ? window->ContentSizeExplicit.y : IM_FLOOR(ImMax(window->DC.CursorMaxPos.y, window->DC.IdealMaxPos.y) - window->DC.CursorStartPos.y); +} + +static ImVec2 CalcWindowAutoFitSize(ImGuiWindow* window, const ImVec2& size_contents) +{ + ImGuiContext& g = *GImGui; + ImGuiStyle& style = g.Style; + const float decoration_up_height = window->TitleBarHeight() + window->MenuBarHeight(); + ImVec2 size_pad = window->WindowPadding * 2.0f; + ImVec2 size_desired = size_contents + size_pad + ImVec2(0.0f, decoration_up_height); + if (window->Flags & ImGuiWindowFlags_Tooltip) + { + // Tooltip always resize + return size_desired; + } + else + { + // Maximum window size is determined by the viewport size or monitor size + const bool is_popup = (window->Flags & ImGuiWindowFlags_Popup) != 0; + const bool is_menu = (window->Flags & ImGuiWindowFlags_ChildMenu) != 0; + ImVec2 size_min = style.WindowMinSize; + if (is_popup || is_menu) // Popups and menus bypass style.WindowMinSize by default, but we give then a non-zero minimum size to facilitate understanding problematic cases (e.g. empty popups) + size_min = ImMin(size_min, ImVec2(4.0f, 4.0f)); + + // FIXME-VIEWPORT-WORKAREA: May want to use GetWorkSize() instead of Size depending on the type of windows? + ImVec2 avail_size = ImGui::GetMainViewport()->Size; + ImVec2 size_auto_fit = ImClamp(size_desired, size_min, ImMax(size_min, avail_size - style.DisplaySafeAreaPadding * 2.0f)); + + // When the window cannot fit all contents (either because of constraints, either because screen is too small), + // we are growing the size on the other axis to compensate for expected scrollbar. FIXME: Might turn bigger than ViewportSize-WindowPadding. + ImVec2 size_auto_fit_after_constraint = CalcWindowSizeAfterConstraint(window, size_auto_fit); + bool will_have_scrollbar_x = (size_auto_fit_after_constraint.x - size_pad.x - 0.0f < size_contents.x && !(window->Flags & ImGuiWindowFlags_NoScrollbar) && (window->Flags & ImGuiWindowFlags_HorizontalScrollbar)) || (window->Flags & ImGuiWindowFlags_AlwaysHorizontalScrollbar); + bool will_have_scrollbar_y = (size_auto_fit_after_constraint.y - size_pad.y - decoration_up_height < size_contents.y && !(window->Flags & ImGuiWindowFlags_NoScrollbar)) || (window->Flags & ImGuiWindowFlags_AlwaysVerticalScrollbar); + if (will_have_scrollbar_x) + size_auto_fit.y += style.ScrollbarSize; + if (will_have_scrollbar_y) + size_auto_fit.x += style.ScrollbarSize; + return size_auto_fit; + } +} + +ImVec2 ImGui::CalcWindowNextAutoFitSize(ImGuiWindow* window) +{ + ImVec2 size_contents_current; + ImVec2 size_contents_ideal; + CalcWindowContentSizes(window, &size_contents_current, &size_contents_ideal); + ImVec2 size_auto_fit = CalcWindowAutoFitSize(window, size_contents_ideal); + ImVec2 size_final = CalcWindowSizeAfterConstraint(window, size_auto_fit); + return size_final; +} + +static ImGuiCol GetWindowBgColorIdxFromFlags(ImGuiWindowFlags flags) +{ + if (flags & (ImGuiWindowFlags_Tooltip | ImGuiWindowFlags_Popup)) + return ImGuiCol_PopupBg; + if (flags & ImGuiWindowFlags_ChildWindow) + return ImGuiCol_ChildBg; + return ImGuiCol_WindowBg; +} + +static void CalcResizePosSizeFromAnyCorner(ImGuiWindow* window, const ImVec2& corner_target, const ImVec2& corner_norm, ImVec2* out_pos, ImVec2* out_size) +{ + ImVec2 pos_min = ImLerp(corner_target, window->Pos, corner_norm); // Expected window upper-left + ImVec2 pos_max = ImLerp(window->Pos + window->Size, corner_target, corner_norm); // Expected window lower-right + ImVec2 size_expected = pos_max - pos_min; + ImVec2 size_constrained = CalcWindowSizeAfterConstraint(window, size_expected); + *out_pos = pos_min; + if (corner_norm.x == 0.0f) + out_pos->x -= (size_constrained.x - size_expected.x); + if (corner_norm.y == 0.0f) + out_pos->y -= (size_constrained.y - size_expected.y); + *out_size = size_constrained; +} + +// Data for resizing from corner +struct ImGuiResizeGripDef +{ + ImVec2 CornerPosN; + ImVec2 InnerDir; + int AngleMin12, AngleMax12; +}; +static const ImGuiResizeGripDef resize_grip_def[4] = +{ + { ImVec2(1, 1), ImVec2(-1, -1), 0, 3 }, // Lower-right + { ImVec2(0, 1), ImVec2(+1, -1), 3, 6 }, // Lower-left + { ImVec2(0, 0), ImVec2(+1, +1), 6, 9 }, // Upper-left (Unused) + { ImVec2(1, 0), ImVec2(-1, +1), 9, 12 } // Upper-right (Unused) +}; + +// Data for resizing from borders +struct ImGuiResizeBorderDef +{ + ImVec2 InnerDir; + ImVec2 SegmentN1, SegmentN2; + float OuterAngle; +}; +static const ImGuiResizeBorderDef resize_border_def[4] = +{ + { ImVec2(+1, 0), ImVec2(0, 1), ImVec2(0, 0), IM_PI * 1.00f }, // Left + { ImVec2(-1, 0), ImVec2(1, 0), ImVec2(1, 1), IM_PI * 0.00f }, // Right + { ImVec2(0, +1), ImVec2(0, 0), ImVec2(1, 0), IM_PI * 1.50f }, // Up + { ImVec2(0, -1), ImVec2(1, 1), ImVec2(0, 1), IM_PI * 0.50f } // Down +}; + +static ImRect GetResizeBorderRect(ImGuiWindow* window, int border_n, float perp_padding, float thickness) +{ + ImRect rect = window->Rect(); + if (thickness == 0.0f) + rect.Max -= ImVec2(1, 1); + if (border_n == ImGuiDir_Left) { return ImRect(rect.Min.x - thickness, rect.Min.y + perp_padding, rect.Min.x + thickness, rect.Max.y - perp_padding); } + if (border_n == ImGuiDir_Right) { return ImRect(rect.Max.x - thickness, rect.Min.y + perp_padding, rect.Max.x + thickness, rect.Max.y - perp_padding); } + if (border_n == ImGuiDir_Up) { return ImRect(rect.Min.x + perp_padding, rect.Min.y - thickness, rect.Max.x - perp_padding, rect.Min.y + thickness); } + if (border_n == ImGuiDir_Down) { return ImRect(rect.Min.x + perp_padding, rect.Max.y - thickness, rect.Max.x - perp_padding, rect.Max.y + thickness); } + IM_ASSERT(0); + return ImRect(); +} + +// 0..3: corners (Lower-right, Lower-left, Unused, Unused) +ImGuiID ImGui::GetWindowResizeCornerID(ImGuiWindow* window, int n) +{ + IM_ASSERT(n >= 0 && n < 4); + ImGuiID id = window->ID; + id = ImHashStr("#RESIZE", 0, id); + id = ImHashData(&n, sizeof(int), id); + return id; +} + +// Borders (Left, Right, Up, Down) +ImGuiID ImGui::GetWindowResizeBorderID(ImGuiWindow* window, ImGuiDir dir) +{ + IM_ASSERT(dir >= 0 && dir < 4); + int n = (int)dir + 4; + ImGuiID id = window->ID; + id = ImHashStr("#RESIZE", 0, id); + id = ImHashData(&n, sizeof(int), id); + return id; +} + +// Handle resize for: Resize Grips, Borders, Gamepad +// Return true when using auto-fit (double click on resize grip) +static bool ImGui::UpdateWindowManualResize(ImGuiWindow* window, const ImVec2& size_auto_fit, int* border_held, int resize_grip_count, ImU32 resize_grip_col[4], const ImRect& visibility_rect) +{ + ImGuiContext& g = *GImGui; + ImGuiWindowFlags flags = window->Flags; + + if ((flags & ImGuiWindowFlags_NoResize) || (flags & ImGuiWindowFlags_AlwaysAutoResize) || window->AutoFitFramesX > 0 || window->AutoFitFramesY > 0) + return false; + if (window->WasActive == false) // Early out to avoid running this code for e.g. an hidden implicit/fallback Debug window. + return false; + + bool ret_auto_fit = false; + const int resize_border_count = g.IO.ConfigWindowsResizeFromEdges ? 4 : 0; + const float grip_draw_size = IM_FLOOR(ImMax(g.FontSize * 1.35f, window->WindowRounding + 1.0f + g.FontSize * 0.2f)); + const float grip_hover_inner_size = IM_FLOOR(grip_draw_size * 0.75f); + const float grip_hover_outer_size = g.IO.ConfigWindowsResizeFromEdges ? WINDOWS_HOVER_PADDING : 0.0f; + + ImVec2 pos_target(FLT_MAX, FLT_MAX); + ImVec2 size_target(FLT_MAX, FLT_MAX); + + // Resize grips and borders are on layer 1 + window->DC.NavLayerCurrent = ImGuiNavLayer_Menu; + + // Manual resize grips + PushID("#RESIZE"); + for (int resize_grip_n = 0; resize_grip_n < resize_grip_count; resize_grip_n++) + { + const ImGuiResizeGripDef& def = resize_grip_def[resize_grip_n]; + const ImVec2 corner = ImLerp(window->Pos, window->Pos + window->Size, def.CornerPosN); + + // Using the FlattenChilds button flag we make the resize button accessible even if we are hovering over a child window + bool hovered, held; + ImRect resize_rect(corner - def.InnerDir * grip_hover_outer_size, corner + def.InnerDir * grip_hover_inner_size); + if (resize_rect.Min.x > resize_rect.Max.x) ImSwap(resize_rect.Min.x, resize_rect.Max.x); + if (resize_rect.Min.y > resize_rect.Max.y) ImSwap(resize_rect.Min.y, resize_rect.Max.y); + ImGuiID resize_grip_id = window->GetID(resize_grip_n); // == GetWindowResizeCornerID() + ButtonBehavior(resize_rect, resize_grip_id, &hovered, &held, ImGuiButtonFlags_FlattenChildren | ImGuiButtonFlags_NoNavFocus); + //GetForegroundDrawList(window)->AddRect(resize_rect.Min, resize_rect.Max, IM_COL32(255, 255, 0, 255)); + if (hovered || held) + g.MouseCursor = (resize_grip_n & 1) ? ImGuiMouseCursor_ResizeNESW : ImGuiMouseCursor_ResizeNWSE; + + if (held && g.IO.MouseDoubleClicked[0] && resize_grip_n == 0) + { + // Manual auto-fit when double-clicking + size_target = CalcWindowSizeAfterConstraint(window, size_auto_fit); + ret_auto_fit = true; + ClearActiveID(); + } + else if (held) + { + // Resize from any of the four corners + // We don't use an incremental MouseDelta but rather compute an absolute target size based on mouse position + ImVec2 clamp_min = ImVec2(def.CornerPosN.x == 1.0f ? visibility_rect.Min.x : -FLT_MAX, def.CornerPosN.y == 1.0f ? visibility_rect.Min.y : -FLT_MAX); + ImVec2 clamp_max = ImVec2(def.CornerPosN.x == 0.0f ? visibility_rect.Max.x : +FLT_MAX, def.CornerPosN.y == 0.0f ? visibility_rect.Max.y : +FLT_MAX); + ImVec2 corner_target = g.IO.MousePos - g.ActiveIdClickOffset + ImLerp(def.InnerDir * grip_hover_outer_size, def.InnerDir * -grip_hover_inner_size, def.CornerPosN); // Corner of the window corresponding to our corner grip + corner_target = ImClamp(corner_target, clamp_min, clamp_max); + CalcResizePosSizeFromAnyCorner(window, corner_target, def.CornerPosN, &pos_target, &size_target); + } + + // Only lower-left grip is visible before hovering/activating + if (resize_grip_n == 0 || held || hovered) + resize_grip_col[resize_grip_n] = GetColorU32(held ? ImGuiCol_ResizeGripActive : hovered ? ImGuiCol_ResizeGripHovered : ImGuiCol_ResizeGrip); + } + for (int border_n = 0; border_n < resize_border_count; border_n++) + { + const ImGuiResizeBorderDef& def = resize_border_def[border_n]; + const ImGuiAxis axis = (border_n == ImGuiDir_Left || border_n == ImGuiDir_Right) ? ImGuiAxis_X : ImGuiAxis_Y; + + bool hovered, held; + ImRect border_rect = GetResizeBorderRect(window, border_n, grip_hover_inner_size, WINDOWS_HOVER_PADDING); + ImGuiID border_id = window->GetID(border_n + 4); // == GetWindowResizeBorderID() + ButtonBehavior(border_rect, border_id, &hovered, &held, ImGuiButtonFlags_FlattenChildren); + //GetForegroundDrawLists(window)->AddRect(border_rect.Min, border_rect.Max, IM_COL32(255, 255, 0, 255)); + if ((hovered && g.HoveredIdTimer > WINDOWS_RESIZE_FROM_EDGES_FEEDBACK_TIMER) || held) + { + g.MouseCursor = (axis == ImGuiAxis_X) ? ImGuiMouseCursor_ResizeEW : ImGuiMouseCursor_ResizeNS; + if (held) + *border_held = border_n; + } + if (held) + { + ImVec2 clamp_min(border_n == ImGuiDir_Right ? visibility_rect.Min.x : -FLT_MAX, border_n == ImGuiDir_Down ? visibility_rect.Min.y : -FLT_MAX); + ImVec2 clamp_max(border_n == ImGuiDir_Left ? visibility_rect.Max.x : +FLT_MAX, border_n == ImGuiDir_Up ? visibility_rect.Max.y : +FLT_MAX); + ImVec2 border_target = window->Pos; + border_target[axis] = g.IO.MousePos[axis] - g.ActiveIdClickOffset[axis] + WINDOWS_HOVER_PADDING; + border_target = ImClamp(border_target, clamp_min, clamp_max); + CalcResizePosSizeFromAnyCorner(window, border_target, ImMin(def.SegmentN1, def.SegmentN2), &pos_target, &size_target); + } + } + PopID(); + + // Restore nav layer + window->DC.NavLayerCurrent = ImGuiNavLayer_Main; + + // Navigation resize (keyboard/gamepad) + if (g.NavWindowingTarget && g.NavWindowingTarget->RootWindow == window) + { + ImVec2 nav_resize_delta; + if (g.NavInputSource == ImGuiInputSource_Keyboard && g.IO.KeyShift) + nav_resize_delta = GetNavInputAmount2d(ImGuiNavDirSourceFlags_Keyboard, ImGuiInputReadMode_Down); + if (g.NavInputSource == ImGuiInputSource_Gamepad) + nav_resize_delta = GetNavInputAmount2d(ImGuiNavDirSourceFlags_PadDPad, ImGuiInputReadMode_Down); + if (nav_resize_delta.x != 0.0f || nav_resize_delta.y != 0.0f) + { + const float NAV_RESIZE_SPEED = 600.0f; + nav_resize_delta *= ImFloor(NAV_RESIZE_SPEED * g.IO.DeltaTime * ImMin(g.IO.DisplayFramebufferScale.x, g.IO.DisplayFramebufferScale.y)); + nav_resize_delta = ImMax(nav_resize_delta, visibility_rect.Min - window->Pos - window->Size); + g.NavWindowingToggleLayer = false; + g.NavDisableMouseHover = true; + resize_grip_col[0] = GetColorU32(ImGuiCol_ResizeGripActive); + // FIXME-NAV: Should store and accumulate into a separate size buffer to handle sizing constraints properly, right now a constraint will make us stuck. + size_target = CalcWindowSizeAfterConstraint(window, window->SizeFull + nav_resize_delta); + } + } + + // Apply back modified position/size to window + if (size_target.x != FLT_MAX) + { + window->SizeFull = size_target; + MarkIniSettingsDirty(window); + } + if (pos_target.x != FLT_MAX) + { + window->Pos = ImFloor(pos_target); + MarkIniSettingsDirty(window); + } + + window->Size = window->SizeFull; + return ret_auto_fit; +} + +static inline void ClampWindowRect(ImGuiWindow* window, const ImRect& visibility_rect) +{ + ImGuiContext& g = *GImGui; + ImVec2 size_for_clamping = window->Size; + if (g.IO.ConfigWindowsMoveFromTitleBarOnly && !(window->Flags & ImGuiWindowFlags_NoTitleBar)) + size_for_clamping.y = window->TitleBarHeight(); + window->Pos = ImClamp(window->Pos, visibility_rect.Min - size_for_clamping, visibility_rect.Max); +} + +static void ImGui::RenderWindowOuterBorders(ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + float rounding = window->WindowRounding; + float border_size = window->WindowBorderSize; + if (border_size > 0.0f && !(window->Flags & ImGuiWindowFlags_NoBackground)) + window->DrawList->AddRect(window->Pos, window->Pos + window->Size, GetColorU32(ImGuiCol_Border), rounding, 0, border_size); + + int border_held = window->ResizeBorderHeld; + if (border_held != -1) + { + const ImGuiResizeBorderDef& def = resize_border_def[border_held]; + ImRect border_r = GetResizeBorderRect(window, border_held, rounding, 0.0f); + window->DrawList->PathArcTo(ImLerp(border_r.Min, border_r.Max, def.SegmentN1) + ImVec2(0.5f, 0.5f) + def.InnerDir * rounding, rounding, def.OuterAngle - IM_PI * 0.25f, def.OuterAngle); + window->DrawList->PathArcTo(ImLerp(border_r.Min, border_r.Max, def.SegmentN2) + ImVec2(0.5f, 0.5f) + def.InnerDir * rounding, rounding, def.OuterAngle, def.OuterAngle + IM_PI * 0.25f); + window->DrawList->PathStroke(GetColorU32(ImGuiCol_SeparatorActive), 0, ImMax(2.0f, border_size)); // Thicker than usual + } + if (g.Style.FrameBorderSize > 0 && !(window->Flags & ImGuiWindowFlags_NoTitleBar)) + { + float y = window->Pos.y + window->TitleBarHeight() - 1; + window->DrawList->AddLine(ImVec2(window->Pos.x + border_size, y), ImVec2(window->Pos.x + window->Size.x - border_size, y), GetColorU32(ImGuiCol_Border), g.Style.FrameBorderSize); + } +} + +// Draw background and borders +// Draw and handle scrollbars +void ImGui::RenderWindowDecorations(ImGuiWindow* window, const ImRect& title_bar_rect, bool title_bar_is_highlight, int resize_grip_count, const ImU32 resize_grip_col[4], float resize_grip_draw_size) +{ + ImGuiContext& g = *GImGui; + ImGuiStyle& style = g.Style; + ImGuiWindowFlags flags = window->Flags; + + // Ensure that ScrollBar doesn't read last frame's SkipItems + IM_ASSERT(window->BeginCount == 0); + window->SkipItems = false; + + // Draw window + handle manual resize + // As we highlight the title bar when want_focus is set, multiple reappearing windows will have have their title bar highlighted on their reappearing frame. + const float window_rounding = window->WindowRounding; + const float window_border_size = window->WindowBorderSize; + if (window->Collapsed) + { + // Title bar only + float backup_border_size = style.FrameBorderSize; + g.Style.FrameBorderSize = window->WindowBorderSize; + ImU32 title_bar_col = GetColorU32((title_bar_is_highlight && !g.NavDisableHighlight) ? ImGuiCol_TitleBgActive : ImGuiCol_TitleBgCollapsed); + RenderFrame(title_bar_rect.Min, title_bar_rect.Max, title_bar_col, true, window_rounding); + g.Style.FrameBorderSize = backup_border_size; + } + else + { + // Window background + if (!(flags & ImGuiWindowFlags_NoBackground)) + { + ImU32 bg_col = GetColorU32(GetWindowBgColorIdxFromFlags(flags)); + bool override_alpha = false; + float alpha = 1.0f; + if (g.NextWindowData.Flags & ImGuiNextWindowDataFlags_HasBgAlpha) + { + alpha = g.NextWindowData.BgAlphaVal; + override_alpha = true; + } + if (override_alpha) + bg_col = (bg_col & ~IM_COL32_A_MASK) | (IM_F32_TO_INT8_SAT(alpha) << IM_COL32_A_SHIFT); + window->DrawList->AddRectFilled(window->Pos + ImVec2(0, window->TitleBarHeight()), window->Pos + window->Size, bg_col, window_rounding, (flags & ImGuiWindowFlags_NoTitleBar) ? 0 : ImDrawFlags_RoundCornersBottom); + } + + // Title bar + if (!(flags & ImGuiWindowFlags_NoTitleBar)) + { + ImU32 title_bar_col = GetColorU32(title_bar_is_highlight ? ImGuiCol_TitleBgActive : ImGuiCol_TitleBg); + window->DrawList->AddRectFilled(title_bar_rect.Min, title_bar_rect.Max, title_bar_col, window_rounding, ImDrawFlags_RoundCornersTop); + } + + // Menu bar + if (flags & ImGuiWindowFlags_MenuBar) + { + ImRect menu_bar_rect = window->MenuBarRect(); + menu_bar_rect.ClipWith(window->Rect()); // Soft clipping, in particular child window don't have minimum size covering the menu bar so this is useful for them. + window->DrawList->AddRectFilled(menu_bar_rect.Min + ImVec2(window_border_size, 0), menu_bar_rect.Max - ImVec2(window_border_size, 0), GetColorU32(ImGuiCol_MenuBarBg), (flags & ImGuiWindowFlags_NoTitleBar) ? window_rounding : 0.0f, ImDrawFlags_RoundCornersTop); + if (style.FrameBorderSize > 0.0f && menu_bar_rect.Max.y < window->Pos.y + window->Size.y) + window->DrawList->AddLine(menu_bar_rect.GetBL(), menu_bar_rect.GetBR(), GetColorU32(ImGuiCol_Border), style.FrameBorderSize); + } + + // Scrollbars + if (window->ScrollbarX) + Scrollbar(ImGuiAxis_X); + if (window->ScrollbarY) + Scrollbar(ImGuiAxis_Y); + + // Render resize grips (after their input handling so we don't have a frame of latency) + if (!(flags & ImGuiWindowFlags_NoResize)) + { + for (int resize_grip_n = 0; resize_grip_n < resize_grip_count; resize_grip_n++) + { + const ImGuiResizeGripDef& grip = resize_grip_def[resize_grip_n]; + const ImVec2 corner = ImLerp(window->Pos, window->Pos + window->Size, grip.CornerPosN); + window->DrawList->PathLineTo(corner + grip.InnerDir * ((resize_grip_n & 1) ? ImVec2(window_border_size, resize_grip_draw_size) : ImVec2(resize_grip_draw_size, window_border_size))); + window->DrawList->PathLineTo(corner + grip.InnerDir * ((resize_grip_n & 1) ? ImVec2(resize_grip_draw_size, window_border_size) : ImVec2(window_border_size, resize_grip_draw_size))); + window->DrawList->PathArcToFast(ImVec2(corner.x + grip.InnerDir.x * (window_rounding + window_border_size), corner.y + grip.InnerDir.y * (window_rounding + window_border_size)), window_rounding, grip.AngleMin12, grip.AngleMax12); + window->DrawList->PathFillConvex(resize_grip_col[resize_grip_n]); + } + } + + // Borders + RenderWindowOuterBorders(window); + } +} + +// Render title text, collapse button, close button +void ImGui::RenderWindowTitleBarContents(ImGuiWindow* window, const ImRect& title_bar_rect, const char* name, bool* p_open) +{ + ImGuiContext& g = *GImGui; + ImGuiStyle& style = g.Style; + ImGuiWindowFlags flags = window->Flags; + + const bool has_close_button = (p_open != NULL); + const bool has_collapse_button = !(flags & ImGuiWindowFlags_NoCollapse) && (style.WindowMenuButtonPosition != ImGuiDir_None); + + // Close & Collapse button are on the Menu NavLayer and don't default focus (unless there's nothing else on that layer) + const ImGuiItemFlags item_flags_backup = g.CurrentItemFlags; + g.CurrentItemFlags |= ImGuiItemFlags_NoNavDefaultFocus; + window->DC.NavLayerCurrent = ImGuiNavLayer_Menu; + + // Layout buttons + // FIXME: Would be nice to generalize the subtleties expressed here into reusable code. + float pad_l = style.FramePadding.x; + float pad_r = style.FramePadding.x; + float button_sz = g.FontSize; + ImVec2 close_button_pos; + ImVec2 collapse_button_pos; + if (has_close_button) + { + pad_r += button_sz; + close_button_pos = ImVec2(title_bar_rect.Max.x - pad_r - style.FramePadding.x, title_bar_rect.Min.y); + } + if (has_collapse_button && style.WindowMenuButtonPosition == ImGuiDir_Right) + { + pad_r += button_sz; + collapse_button_pos = ImVec2(title_bar_rect.Max.x - pad_r - style.FramePadding.x, title_bar_rect.Min.y); + } + if (has_collapse_button && style.WindowMenuButtonPosition == ImGuiDir_Left) + { + collapse_button_pos = ImVec2(title_bar_rect.Min.x + pad_l - style.FramePadding.x, title_bar_rect.Min.y); + pad_l += button_sz; + } + + // Collapse button (submitting first so it gets priority when choosing a navigation init fallback) + if (has_collapse_button) + if (CollapseButton(window->GetID("#COLLAPSE"), collapse_button_pos)) + window->WantCollapseToggle = true; // Defer actual collapsing to next frame as we are too far in the Begin() function + + // Close button + if (has_close_button) + if (CloseButton(window->GetID("#CLOSE"), close_button_pos)) + *p_open = false; + + window->DC.NavLayerCurrent = ImGuiNavLayer_Main; + g.CurrentItemFlags = item_flags_backup; + + // Title bar text (with: horizontal alignment, avoiding collapse/close button, optional "unsaved document" marker) + // FIXME: Refactor text alignment facilities along with RenderText helpers, this is WAY too much messy code.. + const float marker_size_x = (flags & ImGuiWindowFlags_UnsavedDocument) ? button_sz * 0.80f : 0.0f; + const ImVec2 text_size = CalcTextSize(name, NULL, true) + ImVec2(marker_size_x, 0.0f); + + // As a nice touch we try to ensure that centered title text doesn't get affected by visibility of Close/Collapse button, + // while uncentered title text will still reach edges correctly. + if (pad_l > style.FramePadding.x) + pad_l += g.Style.ItemInnerSpacing.x; + if (pad_r > style.FramePadding.x) + pad_r += g.Style.ItemInnerSpacing.x; + if (style.WindowTitleAlign.x > 0.0f && style.WindowTitleAlign.x < 1.0f) + { + float centerness = ImSaturate(1.0f - ImFabs(style.WindowTitleAlign.x - 0.5f) * 2.0f); // 0.0f on either edges, 1.0f on center + float pad_extend = ImMin(ImMax(pad_l, pad_r), title_bar_rect.GetWidth() - pad_l - pad_r - text_size.x); + pad_l = ImMax(pad_l, pad_extend * centerness); + pad_r = ImMax(pad_r, pad_extend * centerness); + } + + ImRect layout_r(title_bar_rect.Min.x + pad_l, title_bar_rect.Min.y, title_bar_rect.Max.x - pad_r, title_bar_rect.Max.y); + ImRect clip_r(layout_r.Min.x, layout_r.Min.y, ImMin(layout_r.Max.x + g.Style.ItemInnerSpacing.x, title_bar_rect.Max.x), layout_r.Max.y); + if (flags & ImGuiWindowFlags_UnsavedDocument) + { + ImVec2 marker_pos; + marker_pos.x = ImClamp(layout_r.Min.x + (layout_r.GetWidth() - text_size.x) * style.WindowTitleAlign.x + text_size.x, layout_r.Min.x, layout_r.Max.x); + marker_pos.y = (layout_r.Min.y + layout_r.Max.y) * 0.5f; + if (marker_pos.x > layout_r.Min.x) + { + RenderBullet(window->DrawList, marker_pos, GetColorU32(ImGuiCol_Text)); + clip_r.Max.x = ImMin(clip_r.Max.x, marker_pos.x - (int)(marker_size_x * 0.5f)); + } + } + //if (g.IO.KeyShift) window->DrawList->AddRect(layout_r.Min, layout_r.Max, IM_COL32(255, 128, 0, 255)); // [DEBUG] + //if (g.IO.KeyCtrl) window->DrawList->AddRect(clip_r.Min, clip_r.Max, IM_COL32(255, 128, 0, 255)); // [DEBUG] + RenderTextClipped(layout_r.Min, layout_r.Max, name, NULL, &text_size, style.WindowTitleAlign, &clip_r); +} + +void ImGui::UpdateWindowParentAndRootLinks(ImGuiWindow* window, ImGuiWindowFlags flags, ImGuiWindow* parent_window) +{ + window->ParentWindow = parent_window; + window->RootWindow = window->RootWindowForTitleBarHighlight = window->RootWindowForNav = window; + if (parent_window && (flags & ImGuiWindowFlags_ChildWindow) && !(flags & ImGuiWindowFlags_Tooltip)) + window->RootWindow = parent_window->RootWindow; + if (parent_window && !(flags & ImGuiWindowFlags_Modal) && (flags & (ImGuiWindowFlags_ChildWindow | ImGuiWindowFlags_Popup))) + window->RootWindowForTitleBarHighlight = parent_window->RootWindowForTitleBarHighlight; + while (window->RootWindowForNav->Flags & ImGuiWindowFlags_NavFlattened) + { + IM_ASSERT(window->RootWindowForNav->ParentWindow != NULL); + window->RootWindowForNav = window->RootWindowForNav->ParentWindow; + } +} + +// Push a new Dear ImGui window to add widgets to. +// - A default window called "Debug" is automatically stacked at the beginning of every frame so you can use widgets without explicitly calling a Begin/End pair. +// - Begin/End can be called multiple times during the frame with the same window name to append content. +// - The window name is used as a unique identifier to preserve window information across frames (and save rudimentary information to the .ini file). +// You can use the "##" or "###" markers to use the same label with different id, or same id with different label. See documentation at the top of this file. +// - Return false when window is collapsed, so you can early out in your code. You always need to call ImGui::End() even if false is returned. +// - Passing 'bool* p_open' displays a Close button on the upper-right corner of the window, the pointed value will be set to false when the button is pressed. +bool ImGui::Begin(const char* name, bool* p_open, ImGuiWindowFlags flags) +{ + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + IM_ASSERT(name != NULL && name[0] != '\0'); // Window name required + IM_ASSERT(g.WithinFrameScope); // Forgot to call ImGui::NewFrame() + IM_ASSERT(g.FrameCountEnded != g.FrameCount); // Called ImGui::Render() or ImGui::EndFrame() and haven't called ImGui::NewFrame() again yet + + // Find or create + ImGuiWindow* window = FindWindowByName(name); + const bool window_just_created = (window == NULL); + if (window_just_created) + window = CreateNewWindow(name, flags); + + // Automatically disable manual moving/resizing when NoInputs is set + if ((flags & ImGuiWindowFlags_NoInputs) == ImGuiWindowFlags_NoInputs) + flags |= ImGuiWindowFlags_NoMove | ImGuiWindowFlags_NoResize; + + if (flags & ImGuiWindowFlags_NavFlattened) + IM_ASSERT(flags & ImGuiWindowFlags_ChildWindow); + + const int current_frame = g.FrameCount; + const bool first_begin_of_the_frame = (window->LastFrameActive != current_frame); + window->IsFallbackWindow = (g.CurrentWindowStack.Size == 0 && g.WithinFrameScopeWithImplicitWindow); + + // Update the Appearing flag + bool window_just_activated_by_user = (window->LastFrameActive < current_frame - 1); // Not using !WasActive because the implicit "Debug" window would always toggle off->on + if (flags & ImGuiWindowFlags_Popup) + { + ImGuiPopupData& popup_ref = g.OpenPopupStack[g.BeginPopupStack.Size]; + window_just_activated_by_user |= (window->PopupId != popup_ref.PopupId); // We recycle popups so treat window as activated if popup id changed + window_just_activated_by_user |= (window != popup_ref.Window); + } + window->Appearing = window_just_activated_by_user; + if (window->Appearing) + SetWindowConditionAllowFlags(window, ImGuiCond_Appearing, true); + + // Update Flags, LastFrameActive, BeginOrderXXX fields + if (first_begin_of_the_frame) + { + window->Flags = (ImGuiWindowFlags)flags; + window->LastFrameActive = current_frame; + window->LastTimeActive = (float)g.Time; + window->BeginOrderWithinParent = 0; + window->BeginOrderWithinContext = (short)(g.WindowsActiveCount++); + } + else + { + flags = window->Flags; + } + + // Parent window is latched only on the first call to Begin() of the frame, so further append-calls can be done from a different window stack + ImGuiWindow* parent_window_in_stack = g.CurrentWindowStack.empty() ? NULL : g.CurrentWindowStack.back().Window; + ImGuiWindow* parent_window = first_begin_of_the_frame ? ((flags & (ImGuiWindowFlags_ChildWindow | ImGuiWindowFlags_Popup)) ? parent_window_in_stack : NULL) : window->ParentWindow; + IM_ASSERT(parent_window != NULL || !(flags & ImGuiWindowFlags_ChildWindow)); + + // We allow window memory to be compacted so recreate the base stack when needed. + if (window->IDStack.Size == 0) + window->IDStack.push_back(window->ID); + + // Add to stack + // We intentionally set g.CurrentWindow to NULL to prevent usage until when the viewport is set, then will call SetCurrentWindow() + g.CurrentWindow = window; + ImGuiWindowStackData window_stack_data; + window_stack_data.Window = window; + window_stack_data.ParentLastItemDataBackup = g.LastItemData; + window_stack_data.StackSizesOnBegin.SetToCurrentState(); + g.CurrentWindowStack.push_back(window_stack_data); + g.CurrentWindow = NULL; + + if (flags & ImGuiWindowFlags_Popup) + { + ImGuiPopupData& popup_ref = g.OpenPopupStack[g.BeginPopupStack.Size]; + popup_ref.Window = window; + g.BeginPopupStack.push_back(popup_ref); + window->PopupId = popup_ref.PopupId; + } + + // Update ->RootWindow and others pointers (before any possible call to FocusWindow) + if (first_begin_of_the_frame) + UpdateWindowParentAndRootLinks(window, flags, parent_window); + + // Process SetNextWindow***() calls + // (FIXME: Consider splitting the HasXXX flags into X/Y components + bool window_pos_set_by_api = false; + bool window_size_x_set_by_api = false, window_size_y_set_by_api = false; + if (g.NextWindowData.Flags & ImGuiNextWindowDataFlags_HasPos) + { + window_pos_set_by_api = (window->SetWindowPosAllowFlags & g.NextWindowData.PosCond) != 0; + if (window_pos_set_by_api && ImLengthSqr(g.NextWindowData.PosPivotVal) > 0.00001f) + { + // May be processed on the next frame if this is our first frame and we are measuring size + // FIXME: Look into removing the branch so everything can go through this same code path for consistency. + window->SetWindowPosVal = g.NextWindowData.PosVal; + window->SetWindowPosPivot = g.NextWindowData.PosPivotVal; + window->SetWindowPosAllowFlags &= ~(ImGuiCond_Once | ImGuiCond_FirstUseEver | ImGuiCond_Appearing); + } + else + { + SetWindowPos(window, g.NextWindowData.PosVal, g.NextWindowData.PosCond); + } + } + if (g.NextWindowData.Flags & ImGuiNextWindowDataFlags_HasSize) + { + window_size_x_set_by_api = (window->SetWindowSizeAllowFlags & g.NextWindowData.SizeCond) != 0 && (g.NextWindowData.SizeVal.x > 0.0f); + window_size_y_set_by_api = (window->SetWindowSizeAllowFlags & g.NextWindowData.SizeCond) != 0 && (g.NextWindowData.SizeVal.y > 0.0f); + SetWindowSize(window, g.NextWindowData.SizeVal, g.NextWindowData.SizeCond); + } + if (g.NextWindowData.Flags & ImGuiNextWindowDataFlags_HasScroll) + { + if (g.NextWindowData.ScrollVal.x >= 0.0f) + { + window->ScrollTarget.x = g.NextWindowData.ScrollVal.x; + window->ScrollTargetCenterRatio.x = 0.0f; + } + if (g.NextWindowData.ScrollVal.y >= 0.0f) + { + window->ScrollTarget.y = g.NextWindowData.ScrollVal.y; + window->ScrollTargetCenterRatio.y = 0.0f; + } + } + if (g.NextWindowData.Flags & ImGuiNextWindowDataFlags_HasContentSize) + window->ContentSizeExplicit = g.NextWindowData.ContentSizeVal; + else if (first_begin_of_the_frame) + window->ContentSizeExplicit = ImVec2(0.0f, 0.0f); + if (g.NextWindowData.Flags & ImGuiNextWindowDataFlags_HasCollapsed) + SetWindowCollapsed(window, g.NextWindowData.CollapsedVal, g.NextWindowData.CollapsedCond); + if (g.NextWindowData.Flags & ImGuiNextWindowDataFlags_HasFocus) + FocusWindow(window); + if (window->Appearing) + SetWindowConditionAllowFlags(window, ImGuiCond_Appearing, false); + + // When reusing window again multiple times a frame, just append content (don't need to setup again) + if (first_begin_of_the_frame) + { + // Initialize + const bool window_is_child_tooltip = (flags & ImGuiWindowFlags_ChildWindow) && (flags & ImGuiWindowFlags_Tooltip); // FIXME-WIP: Undocumented behavior of Child+Tooltip for pinned tooltip (#1345) + window->Active = true; + window->HasCloseButton = (p_open != NULL); + window->ClipRect = ImVec4(-FLT_MAX, -FLT_MAX, +FLT_MAX, +FLT_MAX); + window->IDStack.resize(1); + window->DrawList->_ResetForNewFrame(); + window->DC.CurrentTableIdx = -1; + + // Restore buffer capacity when woken from a compacted state, to avoid + if (window->MemoryCompacted) + GcAwakeTransientWindowBuffers(window); + + // Update stored window name when it changes (which can _only_ happen with the "###" operator, so the ID would stay unchanged). + // The title bar always display the 'name' parameter, so we only update the string storage if it needs to be visible to the end-user elsewhere. + bool window_title_visible_elsewhere = false; + if (g.NavWindowingListWindow != NULL && (window->Flags & ImGuiWindowFlags_NoNavFocus) == 0) // Window titles visible when using CTRL+TAB + window_title_visible_elsewhere = true; + if (window_title_visible_elsewhere && !window_just_created && strcmp(name, window->Name) != 0) + { + size_t buf_len = (size_t)window->NameBufLen; + window->Name = ImStrdupcpy(window->Name, &buf_len, name); + window->NameBufLen = (int)buf_len; + } + + // UPDATE CONTENTS SIZE, UPDATE HIDDEN STATUS + + // Update contents size from last frame for auto-fitting (or use explicit size) + const bool window_just_appearing_after_hidden_for_resize = (window->HiddenFramesCannotSkipItems > 0); + CalcWindowContentSizes(window, &window->ContentSize, &window->ContentSizeIdeal); + if (window->HiddenFramesCanSkipItems > 0) + window->HiddenFramesCanSkipItems--; + if (window->HiddenFramesCannotSkipItems > 0) + window->HiddenFramesCannotSkipItems--; + if (window->HiddenFramesForRenderOnly > 0) + window->HiddenFramesForRenderOnly--; + + // Hide new windows for one frame until they calculate their size + if (window_just_created && (!window_size_x_set_by_api || !window_size_y_set_by_api)) + window->HiddenFramesCannotSkipItems = 1; + + // Hide popup/tooltip window when re-opening while we measure size (because we recycle the windows) + // We reset Size/ContentSize for reappearing popups/tooltips early in this function, so further code won't be tempted to use the old size. + if (window_just_activated_by_user && (flags & (ImGuiWindowFlags_Popup | ImGuiWindowFlags_Tooltip)) != 0) + { + window->HiddenFramesCannotSkipItems = 1; + if (flags & ImGuiWindowFlags_AlwaysAutoResize) + { + if (!window_size_x_set_by_api) + window->Size.x = window->SizeFull.x = 0.f; + if (!window_size_y_set_by_api) + window->Size.y = window->SizeFull.y = 0.f; + window->ContentSize = window->ContentSizeIdeal = ImVec2(0.f, 0.f); + } + } + + // SELECT VIEWPORT + // FIXME-VIEWPORT: In the docking/viewport branch, this is the point where we select the current viewport (which may affect the style) + SetCurrentWindow(window); + + // LOCK BORDER SIZE AND PADDING FOR THE FRAME (so that altering them doesn't cause inconsistencies) + + if (flags & ImGuiWindowFlags_ChildWindow) + window->WindowBorderSize = style.ChildBorderSize; + else + window->WindowBorderSize = ((flags & (ImGuiWindowFlags_Popup | ImGuiWindowFlags_Tooltip)) && !(flags & ImGuiWindowFlags_Modal)) ? style.PopupBorderSize : style.WindowBorderSize; + window->WindowPadding = style.WindowPadding; + if ((flags & ImGuiWindowFlags_ChildWindow) && !(flags & (ImGuiWindowFlags_AlwaysUseWindowPadding | ImGuiWindowFlags_Popup)) && window->WindowBorderSize == 0.0f) + window->WindowPadding = ImVec2(0.0f, (flags & ImGuiWindowFlags_MenuBar) ? style.WindowPadding.y : 0.0f); + + // Lock menu offset so size calculation can use it as menu-bar windows need a minimum size. + window->DC.MenuBarOffset.x = ImMax(ImMax(window->WindowPadding.x, style.ItemSpacing.x), g.NextWindowData.MenuBarOffsetMinVal.x); + window->DC.MenuBarOffset.y = g.NextWindowData.MenuBarOffsetMinVal.y; + + // Collapse window by double-clicking on title bar + // At this point we don't have a clipping rectangle setup yet, so we can use the title bar area for hit detection and drawing + if (!(flags & ImGuiWindowFlags_NoTitleBar) && !(flags & ImGuiWindowFlags_NoCollapse)) + { + // We don't use a regular button+id to test for double-click on title bar (mostly due to legacy reason, could be fixed), so verify that we don't have items over the title bar. + ImRect title_bar_rect = window->TitleBarRect(); + if (g.HoveredWindow == window && g.HoveredId == 0 && g.HoveredIdPreviousFrame == 0 && IsMouseHoveringRect(title_bar_rect.Min, title_bar_rect.Max) && g.IO.MouseDoubleClicked[0]) + window->WantCollapseToggle = true; + if (window->WantCollapseToggle) + { + window->Collapsed = !window->Collapsed; + MarkIniSettingsDirty(window); + } + } + else + { + window->Collapsed = false; + } + window->WantCollapseToggle = false; + + // SIZE + + // Calculate auto-fit size, handle automatic resize + const ImVec2 size_auto_fit = CalcWindowAutoFitSize(window, window->ContentSizeIdeal); + bool use_current_size_for_scrollbar_x = window_just_created; + bool use_current_size_for_scrollbar_y = window_just_created; + if ((flags & ImGuiWindowFlags_AlwaysAutoResize) && !window->Collapsed) + { + // Using SetNextWindowSize() overrides ImGuiWindowFlags_AlwaysAutoResize, so it can be used on tooltips/popups, etc. + if (!window_size_x_set_by_api) + { + window->SizeFull.x = size_auto_fit.x; + use_current_size_for_scrollbar_x = true; + } + if (!window_size_y_set_by_api) + { + window->SizeFull.y = size_auto_fit.y; + use_current_size_for_scrollbar_y = true; + } + } + else if (window->AutoFitFramesX > 0 || window->AutoFitFramesY > 0) + { + // Auto-fit may only grow window during the first few frames + // We still process initial auto-fit on collapsed windows to get a window width, but otherwise don't honor ImGuiWindowFlags_AlwaysAutoResize when collapsed. + if (!window_size_x_set_by_api && window->AutoFitFramesX > 0) + { + window->SizeFull.x = window->AutoFitOnlyGrows ? ImMax(window->SizeFull.x, size_auto_fit.x) : size_auto_fit.x; + use_current_size_for_scrollbar_x = true; + } + if (!window_size_y_set_by_api && window->AutoFitFramesY > 0) + { + window->SizeFull.y = window->AutoFitOnlyGrows ? ImMax(window->SizeFull.y, size_auto_fit.y) : size_auto_fit.y; + use_current_size_for_scrollbar_y = true; + } + if (!window->Collapsed) + MarkIniSettingsDirty(window); + } + + // Apply minimum/maximum window size constraints and final size + window->SizeFull = CalcWindowSizeAfterConstraint(window, window->SizeFull); + window->Size = window->Collapsed && !(flags & ImGuiWindowFlags_ChildWindow) ? window->TitleBarRect().GetSize() : window->SizeFull; + + // Decoration size + const float decoration_up_height = window->TitleBarHeight() + window->MenuBarHeight(); + + // POSITION + + // Popup latch its initial position, will position itself when it appears next frame + if (window_just_activated_by_user) + { + window->AutoPosLastDirection = ImGuiDir_None; + if ((flags & ImGuiWindowFlags_Popup) != 0 && !(flags & ImGuiWindowFlags_Modal) && !window_pos_set_by_api) // FIXME: BeginPopup() could use SetNextWindowPos() + window->Pos = g.BeginPopupStack.back().OpenPopupPos; + } + + // Position child window + if (flags & ImGuiWindowFlags_ChildWindow) + { + IM_ASSERT(parent_window && parent_window->Active); + window->BeginOrderWithinParent = (short)parent_window->DC.ChildWindows.Size; + parent_window->DC.ChildWindows.push_back(window); + if (!(flags & ImGuiWindowFlags_Popup) && !window_pos_set_by_api && !window_is_child_tooltip) + window->Pos = parent_window->DC.CursorPos; + } + + const bool window_pos_with_pivot = (window->SetWindowPosVal.x != FLT_MAX && window->HiddenFramesCannotSkipItems == 0); + if (window_pos_with_pivot) + SetWindowPos(window, window->SetWindowPosVal - window->Size * window->SetWindowPosPivot, 0); // Position given a pivot (e.g. for centering) + else if ((flags & ImGuiWindowFlags_ChildMenu) != 0) + window->Pos = FindBestWindowPosForPopup(window); + else if ((flags & ImGuiWindowFlags_Popup) != 0 && !window_pos_set_by_api && window_just_appearing_after_hidden_for_resize) + window->Pos = FindBestWindowPosForPopup(window); + else if ((flags & ImGuiWindowFlags_Tooltip) != 0 && !window_pos_set_by_api && !window_is_child_tooltip) + window->Pos = FindBestWindowPosForPopup(window); + + // Calculate the range of allowed position for that window (to be movable and visible past safe area padding) + // When clamping to stay visible, we will enforce that window->Pos stays inside of visibility_rect. + ImGuiViewportP* viewport = (ImGuiViewportP*)(void*)GetMainViewport(); + ImRect viewport_rect(viewport->GetMainRect()); + ImRect viewport_work_rect(viewport->GetWorkRect()); + ImVec2 visibility_padding = ImMax(style.DisplayWindowPadding, style.DisplaySafeAreaPadding); + ImRect visibility_rect(viewport_work_rect.Min + visibility_padding, viewport_work_rect.Max - visibility_padding); + + // Clamp position/size so window stays visible within its viewport or monitor + // Ignore zero-sized display explicitly to avoid losing positions if a window manager reports zero-sized window when initializing or minimizing. + if (!window_pos_set_by_api && !(flags & ImGuiWindowFlags_ChildWindow) && window->AutoFitFramesX <= 0 && window->AutoFitFramesY <= 0) + if (viewport_rect.GetWidth() > 0.0f && viewport_rect.GetHeight() > 0.0f) + ClampWindowRect(window, visibility_rect); + window->Pos = ImFloor(window->Pos); + + // Lock window rounding for the frame (so that altering them doesn't cause inconsistencies) + // Large values tend to lead to variety of artifacts and are not recommended. + window->WindowRounding = (flags & ImGuiWindowFlags_ChildWindow) ? style.ChildRounding : ((flags & ImGuiWindowFlags_Popup) && !(flags & ImGuiWindowFlags_Modal)) ? style.PopupRounding : style.WindowRounding; + + // For windows with title bar or menu bar, we clamp to FrameHeight(FontSize + FramePadding.y * 2.0f) to completely hide artifacts. + //if ((window->Flags & ImGuiWindowFlags_MenuBar) || !(window->Flags & ImGuiWindowFlags_NoTitleBar)) + // window->WindowRounding = ImMin(window->WindowRounding, g.FontSize + style.FramePadding.y * 2.0f); + + // Apply window focus (new and reactivated windows are moved to front) + bool want_focus = false; + if (window_just_activated_by_user && !(flags & ImGuiWindowFlags_NoFocusOnAppearing)) + { + if (flags & ImGuiWindowFlags_Popup) + want_focus = true; + else if ((flags & (ImGuiWindowFlags_ChildWindow | ImGuiWindowFlags_Tooltip)) == 0) + want_focus = true; + } + + // Handle manual resize: Resize Grips, Borders, Gamepad + int border_held = -1; + ImU32 resize_grip_col[4] = {}; + const int resize_grip_count = g.IO.ConfigWindowsResizeFromEdges ? 2 : 1; // Allow resize from lower-left if we have the mouse cursor feedback for it. + const float resize_grip_draw_size = IM_FLOOR(ImMax(g.FontSize * 1.10f, window->WindowRounding + 1.0f + g.FontSize * 0.2f)); + if (!window->Collapsed) + if (UpdateWindowManualResize(window, size_auto_fit, &border_held, resize_grip_count, &resize_grip_col[0], visibility_rect)) + use_current_size_for_scrollbar_x = use_current_size_for_scrollbar_y = true; + window->ResizeBorderHeld = (signed char)border_held; + + // SCROLLBAR VISIBILITY + + // Update scrollbar visibility (based on the Size that was effective during last frame or the auto-resized Size). + if (!window->Collapsed) + { + // When reading the current size we need to read it after size constraints have been applied. + // When we use InnerRect here we are intentionally reading last frame size, same for ScrollbarSizes values before we set them again. + ImVec2 avail_size_from_current_frame = ImVec2(window->SizeFull.x, window->SizeFull.y - decoration_up_height); + ImVec2 avail_size_from_last_frame = window->InnerRect.GetSize() + window->ScrollbarSizes; + ImVec2 needed_size_from_last_frame = window_just_created ? ImVec2(0, 0) : window->ContentSize + window->WindowPadding * 2.0f; + float size_x_for_scrollbars = use_current_size_for_scrollbar_x ? avail_size_from_current_frame.x : avail_size_from_last_frame.x; + float size_y_for_scrollbars = use_current_size_for_scrollbar_y ? avail_size_from_current_frame.y : avail_size_from_last_frame.y; + //bool scrollbar_y_from_last_frame = window->ScrollbarY; // FIXME: May want to use that in the ScrollbarX expression? How many pros vs cons? + window->ScrollbarY = (flags & ImGuiWindowFlags_AlwaysVerticalScrollbar) || ((needed_size_from_last_frame.y > size_y_for_scrollbars) && !(flags & ImGuiWindowFlags_NoScrollbar)); + window->ScrollbarX = (flags & ImGuiWindowFlags_AlwaysHorizontalScrollbar) || ((needed_size_from_last_frame.x > size_x_for_scrollbars - (window->ScrollbarY ? style.ScrollbarSize : 0.0f)) && !(flags & ImGuiWindowFlags_NoScrollbar) && (flags & ImGuiWindowFlags_HorizontalScrollbar)); + if (window->ScrollbarX && !window->ScrollbarY) + window->ScrollbarY = (needed_size_from_last_frame.y > size_y_for_scrollbars) && !(flags & ImGuiWindowFlags_NoScrollbar); + window->ScrollbarSizes = ImVec2(window->ScrollbarY ? style.ScrollbarSize : 0.0f, window->ScrollbarX ? style.ScrollbarSize : 0.0f); + } + + // UPDATE RECTANGLES (1- THOSE NOT AFFECTED BY SCROLLING) + // Update various regions. Variables they depends on should be set above in this function. + // We set this up after processing the resize grip so that our rectangles doesn't lag by a frame. + + // Outer rectangle + // Not affected by window border size. Used by: + // - FindHoveredWindow() (w/ extra padding when border resize is enabled) + // - Begin() initial clipping rect for drawing window background and borders. + // - Begin() clipping whole child + const ImRect host_rect = ((flags & ImGuiWindowFlags_ChildWindow) && !(flags & ImGuiWindowFlags_Popup) && !window_is_child_tooltip) ? parent_window->ClipRect : viewport_rect; + const ImRect outer_rect = window->Rect(); + const ImRect title_bar_rect = window->TitleBarRect(); + window->OuterRectClipped = outer_rect; + window->OuterRectClipped.ClipWith(host_rect); + + // Inner rectangle + // Not affected by window border size. Used by: + // - InnerClipRect + // - ScrollToBringRectIntoView() + // - NavUpdatePageUpPageDown() + // - Scrollbar() + window->InnerRect.Min.x = window->Pos.x; + window->InnerRect.Min.y = window->Pos.y + decoration_up_height; + window->InnerRect.Max.x = window->Pos.x + window->Size.x - window->ScrollbarSizes.x; + window->InnerRect.Max.y = window->Pos.y + window->Size.y - window->ScrollbarSizes.y; + + // Inner clipping rectangle. + // Will extend a little bit outside the normal work region. + // This is to allow e.g. Selectable or CollapsingHeader or some separators to cover that space. + // Force round operator last to ensure that e.g. (int)(max.x-min.x) in user's render code produce correct result. + // Note that if our window is collapsed we will end up with an inverted (~null) clipping rectangle which is the correct behavior. + // Affected by window/frame border size. Used by: + // - Begin() initial clip rect + float top_border_size = (((flags & ImGuiWindowFlags_MenuBar) || !(flags & ImGuiWindowFlags_NoTitleBar)) ? style.FrameBorderSize : window->WindowBorderSize); + window->InnerClipRect.Min.x = ImFloor(0.5f + window->InnerRect.Min.x + ImMax(ImFloor(window->WindowPadding.x * 0.5f), window->WindowBorderSize)); + window->InnerClipRect.Min.y = ImFloor(0.5f + window->InnerRect.Min.y + top_border_size); + window->InnerClipRect.Max.x = ImFloor(0.5f + window->InnerRect.Max.x - ImMax(ImFloor(window->WindowPadding.x * 0.5f), window->WindowBorderSize)); + window->InnerClipRect.Max.y = ImFloor(0.5f + window->InnerRect.Max.y - window->WindowBorderSize); + window->InnerClipRect.ClipWithFull(host_rect); + + // Default item width. Make it proportional to window size if window manually resizes + if (window->Size.x > 0.0f && !(flags & ImGuiWindowFlags_Tooltip) && !(flags & ImGuiWindowFlags_AlwaysAutoResize)) + window->ItemWidthDefault = ImFloor(window->Size.x * 0.65f); + else + window->ItemWidthDefault = ImFloor(g.FontSize * 16.0f); + + // SCROLLING + + // Lock down maximum scrolling + // The value of ScrollMax are ahead from ScrollbarX/ScrollbarY which is intentionally using InnerRect from previous rect in order to accommodate + // for right/bottom aligned items without creating a scrollbar. + window->ScrollMax.x = ImMax(0.0f, window->ContentSize.x + window->WindowPadding.x * 2.0f - window->InnerRect.GetWidth()); + window->ScrollMax.y = ImMax(0.0f, window->ContentSize.y + window->WindowPadding.y * 2.0f - window->InnerRect.GetHeight()); + + // Apply scrolling + window->Scroll = CalcNextScrollFromScrollTargetAndClamp(window); + window->ScrollTarget = ImVec2(FLT_MAX, FLT_MAX); + + // DRAWING + + // Setup draw list and outer clipping rectangle + IM_ASSERT(window->DrawList->CmdBuffer.Size == 1 && window->DrawList->CmdBuffer[0].ElemCount == 0); + window->DrawList->PushTextureID(g.Font->ContainerAtlas->TexID); + PushClipRect(host_rect.Min, host_rect.Max, false); + + // Draw modal window background (darkens what is behind them, all viewports) + const bool dim_bg_for_modal = (flags & ImGuiWindowFlags_Modal) && window == GetTopMostPopupModal() && window->HiddenFramesCannotSkipItems <= 0; + const bool dim_bg_for_window_list = g.NavWindowingTargetAnim && (window == g.NavWindowingTargetAnim->RootWindow); + if (dim_bg_for_modal || dim_bg_for_window_list) + { + const ImU32 dim_bg_col = GetColorU32(dim_bg_for_modal ? ImGuiCol_ModalWindowDimBg : ImGuiCol_NavWindowingDimBg, g.DimBgRatio); + window->DrawList->AddRectFilled(viewport_rect.Min, viewport_rect.Max, dim_bg_col); + } + + // Draw navigation selection/windowing rectangle background + if (dim_bg_for_window_list && window == g.NavWindowingTargetAnim) + { + ImRect bb = window->Rect(); + bb.Expand(g.FontSize); + if (!bb.Contains(viewport_rect)) // Avoid drawing if the window covers all the viewport anyway + window->DrawList->AddRectFilled(bb.Min, bb.Max, GetColorU32(ImGuiCol_NavWindowingHighlight, g.NavWindowingHighlightAlpha * 0.25f), g.Style.WindowRounding); + } + + // Child windows can render their decoration (bg color, border, scrollbars, etc.) within their parent to save a draw call (since 1.71) + // When using overlapping child windows, this will break the assumption that child z-order is mapped to submission order. + // FIXME: User code may rely on explicit sorting of overlapping child window and would need to disable this somehow. Please get in contact if you are affected (github #4493) + { + bool render_decorations_in_parent = false; + if ((flags & ImGuiWindowFlags_ChildWindow) && !(flags & ImGuiWindowFlags_Popup) && !window_is_child_tooltip) + { + // - We test overlap with the previous child window only (testing all would end up being O(log N) not a good investment here) + // - We disable this when the parent window has zero vertices, which is a common pattern leading to laying out multiple overlapping childs + ImGuiWindow* previous_child = parent_window->DC.ChildWindows.Size >= 2 ? parent_window->DC.ChildWindows[parent_window->DC.ChildWindows.Size - 2] : NULL; + bool previous_child_overlapping = previous_child ? previous_child->Rect().Overlaps(window->Rect()) : false; + bool parent_is_empty = parent_window->DrawList->VtxBuffer.Size > 0; + if (window->DrawList->CmdBuffer.back().ElemCount == 0 && parent_is_empty && !previous_child_overlapping) + render_decorations_in_parent = true; + } + if (render_decorations_in_parent) + window->DrawList = parent_window->DrawList; + + // Handle title bar, scrollbar, resize grips and resize borders + const ImGuiWindow* window_to_highlight = g.NavWindowingTarget ? g.NavWindowingTarget : g.NavWindow; + const bool title_bar_is_highlight = want_focus || (window_to_highlight && window->RootWindowForTitleBarHighlight == window_to_highlight->RootWindowForTitleBarHighlight); + RenderWindowDecorations(window, title_bar_rect, title_bar_is_highlight, resize_grip_count, resize_grip_col, resize_grip_draw_size); + + if (render_decorations_in_parent) + window->DrawList = &window->DrawListInst; + } + + // Draw navigation selection/windowing rectangle border + if (g.NavWindowingTargetAnim == window) + { + float rounding = ImMax(window->WindowRounding, g.Style.WindowRounding); + ImRect bb = window->Rect(); + bb.Expand(g.FontSize); + if (bb.Contains(viewport_rect)) // If a window fits the entire viewport, adjust its highlight inward + { + bb.Expand(-g.FontSize - 1.0f); + rounding = window->WindowRounding; + } + window->DrawList->AddRect(bb.Min, bb.Max, GetColorU32(ImGuiCol_NavWindowingHighlight, g.NavWindowingHighlightAlpha), rounding, 0, 3.0f); + } + + // UPDATE RECTANGLES (2- THOSE AFFECTED BY SCROLLING) + + // Work rectangle. + // Affected by window padding and border size. Used by: + // - Columns() for right-most edge + // - TreeNode(), CollapsingHeader() for right-most edge + // - BeginTabBar() for right-most edge + const bool allow_scrollbar_x = !(flags & ImGuiWindowFlags_NoScrollbar) && (flags & ImGuiWindowFlags_HorizontalScrollbar); + const bool allow_scrollbar_y = !(flags & ImGuiWindowFlags_NoScrollbar); + const float work_rect_size_x = (window->ContentSizeExplicit.x != 0.0f ? window->ContentSizeExplicit.x : ImMax(allow_scrollbar_x ? window->ContentSize.x : 0.0f, window->Size.x - window->WindowPadding.x * 2.0f - window->ScrollbarSizes.x)); + const float work_rect_size_y = (window->ContentSizeExplicit.y != 0.0f ? window->ContentSizeExplicit.y : ImMax(allow_scrollbar_y ? window->ContentSize.y : 0.0f, window->Size.y - window->WindowPadding.y * 2.0f - decoration_up_height - window->ScrollbarSizes.y)); + window->WorkRect.Min.x = ImFloor(window->InnerRect.Min.x - window->Scroll.x + ImMax(window->WindowPadding.x, window->WindowBorderSize)); + window->WorkRect.Min.y = ImFloor(window->InnerRect.Min.y - window->Scroll.y + ImMax(window->WindowPadding.y, window->WindowBorderSize)); + window->WorkRect.Max.x = window->WorkRect.Min.x + work_rect_size_x; + window->WorkRect.Max.y = window->WorkRect.Min.y + work_rect_size_y; + window->ParentWorkRect = window->WorkRect; + + // [LEGACY] Content Region + // FIXME-OBSOLETE: window->ContentRegionRect.Max is currently very misleading / partly faulty, but some BeginChild() patterns relies on it. + // Used by: + // - Mouse wheel scrolling + many other things + window->ContentRegionRect.Min.x = window->Pos.x - window->Scroll.x + window->WindowPadding.x; + window->ContentRegionRect.Min.y = window->Pos.y - window->Scroll.y + window->WindowPadding.y + decoration_up_height; + window->ContentRegionRect.Max.x = window->ContentRegionRect.Min.x + (window->ContentSizeExplicit.x != 0.0f ? window->ContentSizeExplicit.x : (window->Size.x - window->WindowPadding.x * 2.0f - window->ScrollbarSizes.x)); + window->ContentRegionRect.Max.y = window->ContentRegionRect.Min.y + (window->ContentSizeExplicit.y != 0.0f ? window->ContentSizeExplicit.y : (window->Size.y - window->WindowPadding.y * 2.0f - decoration_up_height - window->ScrollbarSizes.y)); + + // Setup drawing context + // (NB: That term "drawing context / DC" lost its meaning a long time ago. Initially was meant to hold transient data only. Nowadays difference between window-> and window->DC-> is dubious.) + window->DC.Indent.x = 0.0f + window->WindowPadding.x - window->Scroll.x; + window->DC.GroupOffset.x = 0.0f; + window->DC.ColumnsOffset.x = 0.0f; + window->DC.CursorStartPos = window->Pos + ImVec2(window->DC.Indent.x + window->DC.ColumnsOffset.x, decoration_up_height + window->WindowPadding.y - window->Scroll.y); + window->DC.CursorPos = window->DC.CursorStartPos; + window->DC.CursorPosPrevLine = window->DC.CursorPos; + window->DC.CursorMaxPos = window->DC.CursorStartPos; + window->DC.IdealMaxPos = window->DC.CursorStartPos; + window->DC.CurrLineSize = window->DC.PrevLineSize = ImVec2(0.0f, 0.0f); + window->DC.CurrLineTextBaseOffset = window->DC.PrevLineTextBaseOffset = 0.0f; + + window->DC.NavLayerCurrent = ImGuiNavLayer_Main; + window->DC.NavLayersActiveMask = window->DC.NavLayersActiveMaskNext; + window->DC.NavLayersActiveMaskNext = 0x00; + window->DC.NavHideHighlightOneFrame = false; + window->DC.NavHasScroll = (window->ScrollMax.y > 0.0f); + + window->DC.MenuBarAppending = false; + window->DC.MenuColumns.Update(style.ItemSpacing.x, window_just_activated_by_user); + window->DC.TreeDepth = 0; + window->DC.TreeJumpToParentOnPopMask = 0x00; + window->DC.ChildWindows.resize(0); + window->DC.StateStorage = &window->StateStorage; + window->DC.CurrentColumns = NULL; + window->DC.LayoutType = ImGuiLayoutType_Vertical; + window->DC.ParentLayoutType = parent_window ? parent_window->DC.LayoutType : ImGuiLayoutType_Vertical; + window->DC.FocusCounterRegular = window->DC.FocusCounterTabStop = -1; + + window->DC.ItemWidth = window->ItemWidthDefault; + window->DC.TextWrapPos = -1.0f; // disabled + window->DC.ItemWidthStack.resize(0); + window->DC.TextWrapPosStack.resize(0); + + if (window->AutoFitFramesX > 0) + window->AutoFitFramesX--; + if (window->AutoFitFramesY > 0) + window->AutoFitFramesY--; + + // Apply focus (we need to call FocusWindow() AFTER setting DC.CursorStartPos so our initial navigation reference rectangle can start around there) + if (want_focus) + { + FocusWindow(window); + NavInitWindow(window, false); // <-- this is in the way for us to be able to defer and sort reappearing FocusWindow() calls + } + + // Title bar + if (!(flags & ImGuiWindowFlags_NoTitleBar)) + RenderWindowTitleBarContents(window, ImRect(title_bar_rect.Min.x + window->WindowBorderSize, title_bar_rect.Min.y, title_bar_rect.Max.x - window->WindowBorderSize, title_bar_rect.Max.y), name, p_open); + + // Clear hit test shape every frame + window->HitTestHoleSize.x = window->HitTestHoleSize.y = 0; + + // Pressing CTRL+C while holding on a window copy its content to the clipboard + // This works but 1. doesn't handle multiple Begin/End pairs, 2. recursing into another Begin/End pair - so we need to work that out and add better logging scope. + // Maybe we can support CTRL+C on every element? + /* + //if (g.NavWindow == window && g.ActiveId == 0) + if (g.ActiveId == window->MoveId) + if (g.IO.KeyCtrl && IsKeyPressedMap(ImGuiKey_C)) + LogToClipboard(); + */ + + // We fill last item data based on Title Bar/Tab, in order for IsItemHovered() and IsItemActive() to be usable after Begin(). + // This is useful to allow creating context menus on title bar only, etc. + g.LastItemData.ID = window->MoveId; + g.LastItemData.InFlags = g.CurrentItemFlags; + g.LastItemData.StatusFlags = IsMouseHoveringRect(title_bar_rect.Min, title_bar_rect.Max, false) ? ImGuiItemStatusFlags_HoveredRect : 0; + g.LastItemData.Rect = title_bar_rect; + +#ifdef IMGUI_ENABLE_TEST_ENGINE + if (!(window->Flags & ImGuiWindowFlags_NoTitleBar)) + IMGUI_TEST_ENGINE_ITEM_ADD(g.LastItemData.Rect, g.LastItemData.ID); +#endif + } + else + { + // Append + SetCurrentWindow(window); + } + + // Pull/inherit current state + window->DC.NavFocusScopeIdCurrent = (flags & ImGuiWindowFlags_ChildWindow) ? parent_window->DC.NavFocusScopeIdCurrent : window->GetID("#FOCUSSCOPE"); // Inherit from parent only // -V595 + + PushClipRect(window->InnerClipRect.Min, window->InnerClipRect.Max, true); + + // Clear 'accessed' flag last thing (After PushClipRect which will set the flag. We want the flag to stay false when the default "Debug" window is unused) + window->WriteAccessed = false; + window->BeginCount++; + g.NextWindowData.ClearFlags(); + + // Update visibility + if (first_begin_of_the_frame) + { + if (flags & ImGuiWindowFlags_ChildWindow) + { + // Child window can be out of sight and have "negative" clip windows. + // Mark them as collapsed so commands are skipped earlier (we can't manually collapse them because they have no title bar). + IM_ASSERT((flags & ImGuiWindowFlags_NoTitleBar) != 0); + if (!(flags & ImGuiWindowFlags_AlwaysAutoResize) && window->AutoFitFramesX <= 0 && window->AutoFitFramesY <= 0) // FIXME: Doesn't make sense for ChildWindow?? + if (!g.LogEnabled) + if (window->OuterRectClipped.Min.x >= window->OuterRectClipped.Max.x || window->OuterRectClipped.Min.y >= window->OuterRectClipped.Max.y) + window->HiddenFramesCanSkipItems = 1; + + // Hide along with parent or if parent is collapsed + if (parent_window && (parent_window->Collapsed || parent_window->HiddenFramesCanSkipItems > 0)) + window->HiddenFramesCanSkipItems = 1; + if (parent_window && (parent_window->Collapsed || parent_window->HiddenFramesCannotSkipItems > 0)) + window->HiddenFramesCannotSkipItems = 1; + } + + // Don't render if style alpha is 0.0 at the time of Begin(). This is arbitrary and inconsistent but has been there for a long while (may remove at some point) + if (style.Alpha <= 0.0f) + window->HiddenFramesCanSkipItems = 1; + + // Update the Hidden flag + window->Hidden = (window->HiddenFramesCanSkipItems > 0) || (window->HiddenFramesCannotSkipItems > 0) || (window->HiddenFramesForRenderOnly > 0); + + // Disable inputs for requested number of frames + if (window->DisableInputsFrames > 0) + { + window->DisableInputsFrames--; + window->Flags |= ImGuiWindowFlags_NoInputs; + } + + // Update the SkipItems flag, used to early out of all items functions (no layout required) + bool skip_items = false; + if (window->Collapsed || !window->Active || window->Hidden) + if (window->AutoFitFramesX <= 0 && window->AutoFitFramesY <= 0 && window->HiddenFramesCannotSkipItems <= 0) + skip_items = true; + window->SkipItems = skip_items; + } + + return !window->SkipItems; +} + +void ImGui::End() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + // Error checking: verify that user hasn't called End() too many times! + if (g.CurrentWindowStack.Size <= 1 && g.WithinFrameScopeWithImplicitWindow) + { + IM_ASSERT_USER_ERROR(g.CurrentWindowStack.Size > 1, "Calling End() too many times!"); + return; + } + IM_ASSERT(g.CurrentWindowStack.Size > 0); + + // Error checking: verify that user doesn't directly call End() on a child window. + if (window->Flags & ImGuiWindowFlags_ChildWindow) + IM_ASSERT_USER_ERROR(g.WithinEndChild, "Must call EndChild() and not End()!"); + + // Close anything that is open + if (window->DC.CurrentColumns) + EndColumns(); + PopClipRect(); // Inner window clip rectangle + + // Stop logging + if (!(window->Flags & ImGuiWindowFlags_ChildWindow)) // FIXME: add more options for scope of logging + LogFinish(); + + // Pop from window stack + g.LastItemData = g.CurrentWindowStack.back().ParentLastItemDataBackup; + if (window->Flags & ImGuiWindowFlags_Popup) + g.BeginPopupStack.pop_back(); + g.CurrentWindowStack.back().StackSizesOnBegin.CompareWithCurrentState(); + g.CurrentWindowStack.pop_back(); + SetCurrentWindow(g.CurrentWindowStack.Size == 0 ? NULL : g.CurrentWindowStack.back().Window); +} + +void ImGui::BringWindowToFocusFront(ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(window == window->RootWindow); + + const int cur_order = window->FocusOrder; + IM_ASSERT(g.WindowsFocusOrder[cur_order] == window); + if (g.WindowsFocusOrder.back() == window) + return; + + const int new_order = g.WindowsFocusOrder.Size - 1; + for (int n = cur_order; n < new_order; n++) + { + g.WindowsFocusOrder[n] = g.WindowsFocusOrder[n + 1]; + g.WindowsFocusOrder[n]->FocusOrder--; + IM_ASSERT(g.WindowsFocusOrder[n]->FocusOrder == n); + } + g.WindowsFocusOrder[new_order] = window; + window->FocusOrder = (short)new_order; +} + +void ImGui::BringWindowToDisplayFront(ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* current_front_window = g.Windows.back(); + if (current_front_window == window || current_front_window->RootWindow == window) // Cheap early out (could be better) + return; + for (int i = g.Windows.Size - 2; i >= 0; i--) // We can ignore the top-most window + if (g.Windows[i] == window) + { + memmove(&g.Windows[i], &g.Windows[i + 1], (size_t)(g.Windows.Size - i - 1) * sizeof(ImGuiWindow*)); + g.Windows[g.Windows.Size - 1] = window; + break; + } +} + +void ImGui::BringWindowToDisplayBack(ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + if (g.Windows[0] == window) + return; + for (int i = 0; i < g.Windows.Size; i++) + if (g.Windows[i] == window) + { + memmove(&g.Windows[1], &g.Windows[0], (size_t)i * sizeof(ImGuiWindow*)); + g.Windows[0] = window; + break; + } +} + +// Moving window to front of display and set focus (which happens to be back of our sorted list) +void ImGui::FocusWindow(ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + + if (g.NavWindow != window) + { + g.NavWindow = window; + if (window && g.NavDisableMouseHover) + g.NavMousePosDirty = true; + g.NavId = window ? window->NavLastIds[0] : 0; // Restore NavId + g.NavFocusScopeId = 0; + g.NavIdIsAlive = false; + g.NavLayer = ImGuiNavLayer_Main; + g.NavInitRequest = g.NavMoveSubmitted = g.NavMoveScoringItems = false; + NavUpdateAnyRequestFlag(); + //IMGUI_DEBUG_LOG("FocusWindow(\"%s\")\n", window ? window->Name : NULL); + } + + // Close popups if any + ClosePopupsOverWindow(window, false); + + // Move the root window to the top of the pile + IM_ASSERT(window == NULL || window->RootWindow != NULL); + ImGuiWindow* focus_front_window = window ? window->RootWindow : NULL; // NB: In docking branch this is window->RootWindowDockStop + ImGuiWindow* display_front_window = window ? window->RootWindow : NULL; + + // Steal active widgets. Some of the cases it triggers includes: + // - Focus a window while an InputText in another window is active, if focus happens before the old InputText can run. + // - When using Nav to activate menu items (due to timing of activating on press->new window appears->losing ActiveId) + if (g.ActiveId != 0 && g.ActiveIdWindow && g.ActiveIdWindow->RootWindow != focus_front_window) + if (!g.ActiveIdNoClearOnFocusLoss) + ClearActiveID(); + + // Passing NULL allow to disable keyboard focus + if (!window) + return; + + // Bring to front + BringWindowToFocusFront(focus_front_window); + if (((window->Flags | display_front_window->Flags) & ImGuiWindowFlags_NoBringToFrontOnFocus) == 0) + BringWindowToDisplayFront(display_front_window); +} + +void ImGui::FocusTopMostWindowUnderOne(ImGuiWindow* under_this_window, ImGuiWindow* ignore_window) +{ + ImGuiContext& g = *GImGui; + + const int start_idx = ((under_this_window != NULL) ? FindWindowFocusIndex(under_this_window) : g.WindowsFocusOrder.Size) - 1; + for (int i = start_idx; i >= 0; i--) + { + // We may later decide to test for different NoXXXInputs based on the active navigation input (mouse vs nav) but that may feel more confusing to the user. + ImGuiWindow* window = g.WindowsFocusOrder[i]; + IM_ASSERT(window == window->RootWindow); + if (window != ignore_window && window->WasActive) + if ((window->Flags & (ImGuiWindowFlags_NoMouseInputs | ImGuiWindowFlags_NoNavInputs)) != (ImGuiWindowFlags_NoMouseInputs | ImGuiWindowFlags_NoNavInputs)) + { + ImGuiWindow* focus_window = NavRestoreLastChildNavWindow(window); + FocusWindow(focus_window); + return; + } + } + FocusWindow(NULL); +} + +// Important: this alone doesn't alter current ImDrawList state. This is called by PushFont/PopFont only. +void ImGui::SetCurrentFont(ImFont* font) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(font && font->IsLoaded()); // Font Atlas not created. Did you call io.Fonts->GetTexDataAsRGBA32 / GetTexDataAsAlpha8 ? + IM_ASSERT(font->Scale > 0.0f); + g.Font = font; + g.FontBaseSize = ImMax(1.0f, g.IO.FontGlobalScale * g.Font->FontSize * g.Font->Scale); + g.FontSize = g.CurrentWindow ? g.CurrentWindow->CalcFontSize() : 0.0f; + + ImFontAtlas* atlas = g.Font->ContainerAtlas; + g.DrawListSharedData.TexUvWhitePixel = atlas->TexUvWhitePixel; + g.DrawListSharedData.TexUvLines = atlas->TexUvLines; + g.DrawListSharedData.Font = g.Font; + g.DrawListSharedData.FontSize = g.FontSize; +} + +void ImGui::PushFont(ImFont* font) +{ + ImGuiContext& g = *GImGui; + if (!font) + font = GetDefaultFont(); + SetCurrentFont(font); + g.FontStack.push_back(font); + g.CurrentWindow->DrawList->PushTextureID(font->ContainerAtlas->TexID); +} + +void ImGui::PopFont() +{ + ImGuiContext& g = *GImGui; + g.CurrentWindow->DrawList->PopTextureID(); + g.FontStack.pop_back(); + SetCurrentFont(g.FontStack.empty() ? GetDefaultFont() : g.FontStack.back()); +} + +void ImGui::PushItemFlag(ImGuiItemFlags option, bool enabled) +{ + ImGuiContext& g = *GImGui; + ImGuiItemFlags item_flags = g.CurrentItemFlags; + IM_ASSERT(item_flags == g.ItemFlagsStack.back()); + if (enabled) + item_flags |= option; + else + item_flags &= ~option; + g.CurrentItemFlags = item_flags; + g.ItemFlagsStack.push_back(item_flags); +} + +void ImGui::PopItemFlag() +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.ItemFlagsStack.Size > 1); // Too many calls to PopItemFlag() - we always leave a 0 at the bottom of the stack. + g.ItemFlagsStack.pop_back(); + g.CurrentItemFlags = g.ItemFlagsStack.back(); +} + +// BeginDisabled()/EndDisabled() +// - Those can be nested but it cannot be used to enable an already disabled section (a single BeginDisabled(true) in the stack is enough to keep everything disabled) +// - Visually this is currently altering alpha, but it is expected that in a future styling system this would work differently. +// - Feedback welcome at https://github.com/ocornut/imgui/issues/211 +// - BeginDisabled(false) essentially does nothing useful but is provided to facilitate use of boolean expressions. If you can avoid calling BeginDisabled(False)/EndDisabled() best to avoid it. +// - Optimized shortcuts instead of PushStyleVar() + PushItemFlag() +void ImGui::BeginDisabled(bool disabled) +{ + ImGuiContext& g = *GImGui; + bool was_disabled = (g.CurrentItemFlags & ImGuiItemFlags_Disabled) != 0; + if (!was_disabled && disabled) + { + g.DisabledAlphaBackup = g.Style.Alpha; + g.Style.Alpha *= g.Style.DisabledAlpha; // PushStyleVar(ImGuiStyleVar_Alpha, g.Style.Alpha * g.Style.DisabledAlpha); + } + if (was_disabled || disabled) + g.CurrentItemFlags |= ImGuiItemFlags_Disabled; + g.ItemFlagsStack.push_back(g.CurrentItemFlags); + g.DisabledStackSize++; +} + +void ImGui::EndDisabled() +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.DisabledStackSize > 0); + g.DisabledStackSize--; + bool was_disabled = (g.CurrentItemFlags & ImGuiItemFlags_Disabled) != 0; + //PopItemFlag(); + g.ItemFlagsStack.pop_back(); + g.CurrentItemFlags = g.ItemFlagsStack.back(); + if (was_disabled && (g.CurrentItemFlags & ImGuiItemFlags_Disabled) == 0) + g.Style.Alpha = g.DisabledAlphaBackup; //PopStyleVar(); +} + +// FIXME: Look into renaming this once we have settled the new Focus/Activation/TabStop system. +void ImGui::PushAllowKeyboardFocus(bool allow_keyboard_focus) +{ + PushItemFlag(ImGuiItemFlags_NoTabStop, !allow_keyboard_focus); +} + +void ImGui::PopAllowKeyboardFocus() +{ + PopItemFlag(); +} + +void ImGui::PushButtonRepeat(bool repeat) +{ + PushItemFlag(ImGuiItemFlags_ButtonRepeat, repeat); +} + +void ImGui::PopButtonRepeat() +{ + PopItemFlag(); +} + +void ImGui::PushTextWrapPos(float wrap_pos_x) +{ + ImGuiWindow* window = GetCurrentWindow(); + window->DC.TextWrapPosStack.push_back(window->DC.TextWrapPos); + window->DC.TextWrapPos = wrap_pos_x; +} + +void ImGui::PopTextWrapPos() +{ + ImGuiWindow* window = GetCurrentWindow(); + window->DC.TextWrapPos = window->DC.TextWrapPosStack.back(); + window->DC.TextWrapPosStack.pop_back(); +} + +bool ImGui::IsWindowChildOf(ImGuiWindow* window, ImGuiWindow* potential_parent) +{ + if (window->RootWindow == potential_parent) + return true; + while (window != NULL) + { + if (window == potential_parent) + return true; + window = window->ParentWindow; + } + return false; +} + +bool ImGui::IsWindowAbove(ImGuiWindow* potential_above, ImGuiWindow* potential_below) +{ + ImGuiContext& g = *GImGui; + for (int i = g.Windows.Size - 1; i >= 0; i--) + { + ImGuiWindow* candidate_window = g.Windows[i]; + if (candidate_window == potential_above) + return true; + if (candidate_window == potential_below) + return false; + } + return false; +} + +bool ImGui::IsWindowHovered(ImGuiHoveredFlags flags) +{ + IM_ASSERT((flags & ImGuiHoveredFlags_AllowWhenOverlapped) == 0); // Flags not supported by this function + ImGuiContext& g = *GImGui; + ImGuiWindow* ref_window = g.HoveredWindow; + ImGuiWindow* cur_window = g.CurrentWindow; + if (ref_window == NULL) + return false; + + if ((flags & ImGuiHoveredFlags_AnyWindow) == 0) + { + IM_ASSERT(cur_window); // Not inside a Begin()/End() + + if (flags & ImGuiHoveredFlags_RootWindow) + cur_window = cur_window->RootWindow; + + bool result; + if (flags & ImGuiHoveredFlags_ChildWindows) + result = IsWindowChildOf(ref_window, cur_window); + else + result = (ref_window == cur_window); + if (!result) + return false; + } + + if (!IsWindowContentHoverable(ref_window, flags)) + return false; + if (!(flags & ImGuiHoveredFlags_AllowWhenBlockedByActiveItem)) + if (g.ActiveId != 0 && !g.ActiveIdAllowOverlap && g.ActiveId != ref_window->MoveId) + return false; + return true; +} + +bool ImGui::IsWindowFocused(ImGuiFocusedFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* ref_window = g.NavWindow; + ImGuiWindow* cur_window = g.CurrentWindow; + + if (ref_window == NULL) + return false; + if (flags & ImGuiFocusedFlags_AnyWindow) + return true; + IM_ASSERT(cur_window); // Not inside a Begin()/End() + + if (flags & ImGuiHoveredFlags_RootWindow) + cur_window = cur_window->RootWindow; + + if (flags & ImGuiHoveredFlags_ChildWindows) + return IsWindowChildOf(ref_window, cur_window); + else + return (ref_window == cur_window); +} + +// Can we focus this window with CTRL+TAB (or PadMenu + PadFocusPrev/PadFocusNext) +// Note that NoNavFocus makes the window not reachable with CTRL+TAB but it can still be focused with mouse or programmatically. +// If you want a window to never be focused, you may use the e.g. NoInputs flag. +bool ImGui::IsWindowNavFocusable(ImGuiWindow* window) +{ + return window->WasActive && window == window->RootWindow && !(window->Flags & ImGuiWindowFlags_NoNavFocus); +} + +float ImGui::GetWindowWidth() +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->Size.x; +} + +float ImGui::GetWindowHeight() +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->Size.y; +} + +ImVec2 ImGui::GetWindowPos() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + return window->Pos; +} + +void ImGui::SetWindowPos(ImGuiWindow* window, const ImVec2& pos, ImGuiCond cond) +{ + // Test condition (NB: bit 0 is always true) and clear flags for next time + if (cond && (window->SetWindowPosAllowFlags & cond) == 0) + return; + + IM_ASSERT(cond == 0 || ImIsPowerOfTwo(cond)); // Make sure the user doesn't attempt to combine multiple condition flags. + window->SetWindowPosAllowFlags &= ~(ImGuiCond_Once | ImGuiCond_FirstUseEver | ImGuiCond_Appearing); + window->SetWindowPosVal = ImVec2(FLT_MAX, FLT_MAX); + + // Set + const ImVec2 old_pos = window->Pos; + window->Pos = ImFloor(pos); + ImVec2 offset = window->Pos - old_pos; + window->DC.CursorPos += offset; // As we happen to move the window while it is being appended to (which is a bad idea - will smear) let's at least offset the cursor + window->DC.CursorMaxPos += offset; // And more importantly we need to offset CursorMaxPos/CursorStartPos this so ContentSize calculation doesn't get affected. + window->DC.IdealMaxPos += offset; + window->DC.CursorStartPos += offset; +} + +void ImGui::SetWindowPos(const ImVec2& pos, ImGuiCond cond) +{ + ImGuiWindow* window = GetCurrentWindowRead(); + SetWindowPos(window, pos, cond); +} + +void ImGui::SetWindowPos(const char* name, const ImVec2& pos, ImGuiCond cond) +{ + if (ImGuiWindow* window = FindWindowByName(name)) + SetWindowPos(window, pos, cond); +} + +ImVec2 ImGui::GetWindowSize() +{ + ImGuiWindow* window = GetCurrentWindowRead(); + return window->Size; +} + +void ImGui::SetWindowSize(ImGuiWindow* window, const ImVec2& size, ImGuiCond cond) +{ + // Test condition (NB: bit 0 is always true) and clear flags for next time + if (cond && (window->SetWindowSizeAllowFlags & cond) == 0) + return; + + IM_ASSERT(cond == 0 || ImIsPowerOfTwo(cond)); // Make sure the user doesn't attempt to combine multiple condition flags. + window->SetWindowSizeAllowFlags &= ~(ImGuiCond_Once | ImGuiCond_FirstUseEver | ImGuiCond_Appearing); + + // Set + if (size.x > 0.0f) + { + window->AutoFitFramesX = 0; + window->SizeFull.x = IM_FLOOR(size.x); + } + else + { + window->AutoFitFramesX = 2; + window->AutoFitOnlyGrows = false; + } + if (size.y > 0.0f) + { + window->AutoFitFramesY = 0; + window->SizeFull.y = IM_FLOOR(size.y); + } + else + { + window->AutoFitFramesY = 2; + window->AutoFitOnlyGrows = false; + } +} + +void ImGui::SetWindowSize(const ImVec2& size, ImGuiCond cond) +{ + SetWindowSize(GImGui->CurrentWindow, size, cond); +} + +void ImGui::SetWindowSize(const char* name, const ImVec2& size, ImGuiCond cond) +{ + if (ImGuiWindow* window = FindWindowByName(name)) + SetWindowSize(window, size, cond); +} + +void ImGui::SetWindowCollapsed(ImGuiWindow* window, bool collapsed, ImGuiCond cond) +{ + // Test condition (NB: bit 0 is always true) and clear flags for next time + if (cond && (window->SetWindowCollapsedAllowFlags & cond) == 0) + return; + window->SetWindowCollapsedAllowFlags &= ~(ImGuiCond_Once | ImGuiCond_FirstUseEver | ImGuiCond_Appearing); + + // Set + window->Collapsed = collapsed; +} + +void ImGui::SetWindowHitTestHole(ImGuiWindow* window, const ImVec2& pos, const ImVec2& size) +{ + IM_ASSERT(window->HitTestHoleSize.x == 0); // We don't support multiple holes/hit test filters + window->HitTestHoleSize = ImVec2ih(size); + window->HitTestHoleOffset = ImVec2ih(pos - window->Pos); +} + +void ImGui::SetWindowCollapsed(bool collapsed, ImGuiCond cond) +{ + SetWindowCollapsed(GImGui->CurrentWindow, collapsed, cond); +} + +bool ImGui::IsWindowCollapsed() +{ + ImGuiWindow* window = GetCurrentWindowRead(); + return window->Collapsed; +} + +bool ImGui::IsWindowAppearing() +{ + ImGuiWindow* window = GetCurrentWindowRead(); + return window->Appearing; +} + +void ImGui::SetWindowCollapsed(const char* name, bool collapsed, ImGuiCond cond) +{ + if (ImGuiWindow* window = FindWindowByName(name)) + SetWindowCollapsed(window, collapsed, cond); +} + +void ImGui::SetWindowFocus() +{ + FocusWindow(GImGui->CurrentWindow); +} + +void ImGui::SetWindowFocus(const char* name) +{ + if (name) + { + if (ImGuiWindow* window = FindWindowByName(name)) + FocusWindow(window); + } + else + { + FocusWindow(NULL); + } +} + +void ImGui::SetNextWindowPos(const ImVec2& pos, ImGuiCond cond, const ImVec2& pivot) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(cond == 0 || ImIsPowerOfTwo(cond)); // Make sure the user doesn't attempt to combine multiple condition flags. + g.NextWindowData.Flags |= ImGuiNextWindowDataFlags_HasPos; + g.NextWindowData.PosVal = pos; + g.NextWindowData.PosPivotVal = pivot; + g.NextWindowData.PosCond = cond ? cond : ImGuiCond_Always; +} + +void ImGui::SetNextWindowSize(const ImVec2& size, ImGuiCond cond) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(cond == 0 || ImIsPowerOfTwo(cond)); // Make sure the user doesn't attempt to combine multiple condition flags. + g.NextWindowData.Flags |= ImGuiNextWindowDataFlags_HasSize; + g.NextWindowData.SizeVal = size; + g.NextWindowData.SizeCond = cond ? cond : ImGuiCond_Always; +} + +void ImGui::SetNextWindowSizeConstraints(const ImVec2& size_min, const ImVec2& size_max, ImGuiSizeCallback custom_callback, void* custom_callback_user_data) +{ + ImGuiContext& g = *GImGui; + g.NextWindowData.Flags |= ImGuiNextWindowDataFlags_HasSizeConstraint; + g.NextWindowData.SizeConstraintRect = ImRect(size_min, size_max); + g.NextWindowData.SizeCallback = custom_callback; + g.NextWindowData.SizeCallbackUserData = custom_callback_user_data; +} + +// Content size = inner scrollable rectangle, padded with WindowPadding. +// SetNextWindowContentSize(ImVec2(100,100) + ImGuiWindowFlags_AlwaysAutoResize will always allow submitting a 100x100 item. +void ImGui::SetNextWindowContentSize(const ImVec2& size) +{ + ImGuiContext& g = *GImGui; + g.NextWindowData.Flags |= ImGuiNextWindowDataFlags_HasContentSize; + g.NextWindowData.ContentSizeVal = ImFloor(size); +} + +void ImGui::SetNextWindowScroll(const ImVec2& scroll) +{ + ImGuiContext& g = *GImGui; + g.NextWindowData.Flags |= ImGuiNextWindowDataFlags_HasScroll; + g.NextWindowData.ScrollVal = scroll; +} + +void ImGui::SetNextWindowCollapsed(bool collapsed, ImGuiCond cond) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(cond == 0 || ImIsPowerOfTwo(cond)); // Make sure the user doesn't attempt to combine multiple condition flags. + g.NextWindowData.Flags |= ImGuiNextWindowDataFlags_HasCollapsed; + g.NextWindowData.CollapsedVal = collapsed; + g.NextWindowData.CollapsedCond = cond ? cond : ImGuiCond_Always; +} + +void ImGui::SetNextWindowFocus() +{ + ImGuiContext& g = *GImGui; + g.NextWindowData.Flags |= ImGuiNextWindowDataFlags_HasFocus; +} + +void ImGui::SetNextWindowBgAlpha(float alpha) +{ + ImGuiContext& g = *GImGui; + g.NextWindowData.Flags |= ImGuiNextWindowDataFlags_HasBgAlpha; + g.NextWindowData.BgAlphaVal = alpha; +} + +ImDrawList* ImGui::GetWindowDrawList() +{ + ImGuiWindow* window = GetCurrentWindow(); + return window->DrawList; +} + +ImFont* ImGui::GetFont() +{ + return GImGui->Font; +} + +float ImGui::GetFontSize() +{ + return GImGui->FontSize; +} + +ImVec2 ImGui::GetFontTexUvWhitePixel() +{ + return GImGui->DrawListSharedData.TexUvWhitePixel; +} + +void ImGui::SetWindowFontScale(float scale) +{ + IM_ASSERT(scale > 0.0f); + ImGuiContext& g = *GImGui; + ImGuiWindow* window = GetCurrentWindow(); + window->FontWindowScale = scale; + g.FontSize = g.DrawListSharedData.FontSize = window->CalcFontSize(); +} + +void ImGui::ActivateItem(ImGuiID id) +{ + ImGuiContext& g = *GImGui; + g.NavNextActivateId = id; + g.NavNextActivateFlags = ImGuiActivateFlags_None; +} + +void ImGui::PushFocusScope(ImGuiID id) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + g.FocusScopeStack.push_back(window->DC.NavFocusScopeIdCurrent); + window->DC.NavFocusScopeIdCurrent = id; +} + +void ImGui::PopFocusScope() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + IM_ASSERT(g.FocusScopeStack.Size > 0); // Too many PopFocusScope() ? + window->DC.NavFocusScopeIdCurrent = g.FocusScopeStack.back(); + g.FocusScopeStack.pop_back(); +} + +void ImGui::SetKeyboardFocusHere(int offset) +{ + IM_ASSERT(offset >= -1); // -1 is allowed but not below + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + g.TabFocusRequestNextWindow = window; + g.TabFocusRequestNextCounterRegular = window->DC.FocusCounterRegular + 1 + offset; + g.TabFocusRequestNextCounterTabStop = INT_MAX; +} + +void ImGui::SetItemDefaultFocus() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (!window->Appearing) + return; + if (g.NavWindow == window->RootWindowForNav && (g.NavInitRequest || g.NavInitResultId != 0) && g.NavLayer == window->DC.NavLayerCurrent) + { + g.NavInitRequest = false; + g.NavInitResultId = g.LastItemData.ID; + g.NavInitResultRectRel = ImRect(g.LastItemData.Rect.Min - window->Pos, g.LastItemData.Rect.Max - window->Pos); + NavUpdateAnyRequestFlag(); + if (!IsItemVisible()) + SetScrollHereY(); + } +} + +void ImGui::SetStateStorage(ImGuiStorage* tree) +{ + ImGuiWindow* window = GImGui->CurrentWindow; + window->DC.StateStorage = tree ? tree : &window->StateStorage; +} + +ImGuiStorage* ImGui::GetStateStorage() +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->DC.StateStorage; +} + +void ImGui::PushID(const char* str_id) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImGuiID id = window->GetIDNoKeepAlive(str_id); + window->IDStack.push_back(id); +} + +void ImGui::PushID(const char* str_id_begin, const char* str_id_end) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImGuiID id = window->GetIDNoKeepAlive(str_id_begin, str_id_end); + window->IDStack.push_back(id); +} + +void ImGui::PushID(const void* ptr_id) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImGuiID id = window->GetIDNoKeepAlive(ptr_id); + window->IDStack.push_back(id); +} + +void ImGui::PushID(int int_id) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImGuiID id = window->GetIDNoKeepAlive(int_id); + window->IDStack.push_back(id); +} + +// Push a given id value ignoring the ID stack as a seed. +void ImGui::PushOverrideID(ImGuiID id) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + window->IDStack.push_back(id); +} + +// Helper to avoid a common series of PushOverrideID -> GetID() -> PopID() call +// (note that when using this pattern, TestEngine's "Stack Tool" will tend to not display the intermediate stack level. +// for that to work we would need to do PushOverrideID() -> ItemAdd() -> PopID() which would alter widget code a little more) +ImGuiID ImGui::GetIDWithSeed(const char* str, const char* str_end, ImGuiID seed) +{ + ImGuiID id = ImHashStr(str, str_end ? (str_end - str) : 0, seed); + ImGui::KeepAliveID(id); +#ifdef IMGUI_ENABLE_TEST_ENGINE + ImGuiContext& g = *GImGui; + IMGUI_TEST_ENGINE_ID_INFO2(id, ImGuiDataType_String, str, str_end); +#endif + return id; +} + +void ImGui::PopID() +{ + ImGuiWindow* window = GImGui->CurrentWindow; + IM_ASSERT(window->IDStack.Size > 1); // Too many PopID(), or could be popping in a wrong/different window? + window->IDStack.pop_back(); +} + +ImGuiID ImGui::GetID(const char* str_id) +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->GetID(str_id); +} + +ImGuiID ImGui::GetID(const char* str_id_begin, const char* str_id_end) +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->GetID(str_id_begin, str_id_end); +} + +ImGuiID ImGui::GetID(const void* ptr_id) +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->GetID(ptr_id); +} + +bool ImGui::IsRectVisible(const ImVec2& size) +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->ClipRect.Overlaps(ImRect(window->DC.CursorPos, window->DC.CursorPos + size)); +} + +bool ImGui::IsRectVisible(const ImVec2& rect_min, const ImVec2& rect_max) +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->ClipRect.Overlaps(ImRect(rect_min, rect_max)); +} + + +//----------------------------------------------------------------------------- +// [SECTION] ERROR CHECKING +//----------------------------------------------------------------------------- + +// Helper function to verify ABI compatibility between caller code and compiled version of Dear ImGui. +// Verify that the type sizes are matching between the calling file's compilation unit and imgui.cpp's compilation unit +// If the user has inconsistent compilation settings, imgui configuration #define, packing pragma, etc. your user code +// may see different structures than what imgui.cpp sees, which is problematic. +// We usually require settings to be in imconfig.h to make sure that they are accessible to all compilation units involved with Dear ImGui. +bool ImGui::DebugCheckVersionAndDataLayout(const char* version, size_t sz_io, size_t sz_style, size_t sz_vec2, size_t sz_vec4, size_t sz_vert, size_t sz_idx) +{ + bool error = false; + if (strcmp(version, IMGUI_VERSION) != 0) { error = true; IM_ASSERT(strcmp(version, IMGUI_VERSION) == 0 && "Mismatched version string!"); } + if (sz_io != sizeof(ImGuiIO)) { error = true; IM_ASSERT(sz_io == sizeof(ImGuiIO) && "Mismatched struct layout!"); } + if (sz_style != sizeof(ImGuiStyle)) { error = true; IM_ASSERT(sz_style == sizeof(ImGuiStyle) && "Mismatched struct layout!"); } + if (sz_vec2 != sizeof(ImVec2)) { error = true; IM_ASSERT(sz_vec2 == sizeof(ImVec2) && "Mismatched struct layout!"); } + if (sz_vec4 != sizeof(ImVec4)) { error = true; IM_ASSERT(sz_vec4 == sizeof(ImVec4) && "Mismatched struct layout!"); } + if (sz_vert != sizeof(ImDrawVert)) { error = true; IM_ASSERT(sz_vert == sizeof(ImDrawVert) && "Mismatched struct layout!"); } + if (sz_idx != sizeof(ImDrawIdx)) { error = true; IM_ASSERT(sz_idx == sizeof(ImDrawIdx) && "Mismatched struct layout!"); } + return !error; +} + +static void ImGui::ErrorCheckNewFrameSanityChecks() +{ + ImGuiContext& g = *GImGui; + + // Check user IM_ASSERT macro + // (IF YOU GET A WARNING OR COMPILE ERROR HERE: it means your assert macro is incorrectly defined! + // If your macro uses multiple statements, it NEEDS to be surrounded by a 'do { ... } while (0)' block. + // This is a common C/C++ idiom to allow multiple statements macros to be used in control flow blocks.) + // #define IM_ASSERT(EXPR) if (SomeCode(EXPR)) SomeMoreCode(); // Wrong! + // #define IM_ASSERT(EXPR) do { if (SomeCode(EXPR)) SomeMoreCode(); } while (0) // Correct! + if (true) IM_ASSERT(1); else IM_ASSERT(0); + + // Check user data + // (We pass an error message in the assert expression to make it visible to programmers who are not using a debugger, as most assert handlers display their argument) + IM_ASSERT(g.Initialized); + IM_ASSERT((g.IO.DeltaTime > 0.0f || g.FrameCount == 0) && "Need a positive DeltaTime!"); + IM_ASSERT((g.FrameCount == 0 || g.FrameCountEnded == g.FrameCount) && "Forgot to call Render() or EndFrame() at the end of the previous frame?"); + IM_ASSERT(g.IO.DisplaySize.x >= 0.0f && g.IO.DisplaySize.y >= 0.0f && "Invalid DisplaySize value!"); + IM_ASSERT(g.IO.Fonts->IsBuilt() && "Font Atlas not built! Make sure you called ImGui_ImplXXXX_NewFrame() function for renderer backend, which should call io.Fonts->GetTexDataAsRGBA32() / GetTexDataAsAlpha8()"); + IM_ASSERT(g.Style.CurveTessellationTol > 0.0f && "Invalid style setting!"); + IM_ASSERT(g.Style.CircleTessellationMaxError > 0.0f && "Invalid style setting!"); + IM_ASSERT(g.Style.Alpha >= 0.0f && g.Style.Alpha <= 1.0f && "Invalid style setting!"); // Allows us to avoid a few clamps in color computations + IM_ASSERT(g.Style.WindowMinSize.x >= 1.0f && g.Style.WindowMinSize.y >= 1.0f && "Invalid style setting."); + IM_ASSERT(g.Style.WindowMenuButtonPosition == ImGuiDir_None || g.Style.WindowMenuButtonPosition == ImGuiDir_Left || g.Style.WindowMenuButtonPosition == ImGuiDir_Right); + for (int n = 0; n < ImGuiKey_COUNT; n++) + IM_ASSERT(g.IO.KeyMap[n] >= -1 && g.IO.KeyMap[n] < IM_ARRAYSIZE(g.IO.KeysDown) && "io.KeyMap[] contains an out of bound value (need to be 0..512, or -1 for unmapped key)"); + + // Check: required key mapping (we intentionally do NOT check all keys to not pressure user into setting up everything, but Space is required and was only added in 1.60 WIP) + if (g.IO.ConfigFlags & ImGuiConfigFlags_NavEnableKeyboard) + IM_ASSERT(g.IO.KeyMap[ImGuiKey_Space] != -1 && "ImGuiKey_Space is not mapped, required for keyboard navigation."); + + // Check: the io.ConfigWindowsResizeFromEdges option requires backend to honor mouse cursor changes and set the ImGuiBackendFlags_HasMouseCursors flag accordingly. + if (g.IO.ConfigWindowsResizeFromEdges && !(g.IO.BackendFlags & ImGuiBackendFlags_HasMouseCursors)) + g.IO.ConfigWindowsResizeFromEdges = false; +} + +static void ImGui::ErrorCheckEndFrameSanityChecks() +{ + ImGuiContext& g = *GImGui; + + // Verify that io.KeyXXX fields haven't been tampered with. Key mods should not be modified between NewFrame() and EndFrame() + // One possible reason leading to this assert is that your backends update inputs _AFTER_ NewFrame(). + // It is known that when some modal native windows called mid-frame takes focus away, some backends such as GLFW will + // send key release events mid-frame. This would normally trigger this assertion and lead to sheared inputs. + // We silently accommodate for this case by ignoring/ the case where all io.KeyXXX modifiers were released (aka key_mod_flags == 0), + // while still correctly asserting on mid-frame key press events. + const ImGuiKeyModFlags key_mod_flags = GetMergedKeyModFlags(); + IM_ASSERT((key_mod_flags == 0 || g.IO.KeyMods == key_mod_flags) && "Mismatching io.KeyCtrl/io.KeyShift/io.KeyAlt/io.KeySuper vs io.KeyMods"); + IM_UNUSED(key_mod_flags); + + // Recover from errors + //ErrorCheckEndFrameRecover(); + + // Report when there is a mismatch of Begin/BeginChild vs End/EndChild calls. Important: Remember that the Begin/BeginChild API requires you + // to always call End/EndChild even if Begin/BeginChild returns false! (this is unfortunately inconsistent with most other Begin* API). + if (g.CurrentWindowStack.Size != 1) + { + if (g.CurrentWindowStack.Size > 1) + { + IM_ASSERT_USER_ERROR(g.CurrentWindowStack.Size == 1, "Mismatched Begin/BeginChild vs End/EndChild calls: did you forget to call End/EndChild?"); + while (g.CurrentWindowStack.Size > 1) + End(); + } + else + { + IM_ASSERT_USER_ERROR(g.CurrentWindowStack.Size == 1, "Mismatched Begin/BeginChild vs End/EndChild calls: did you call End/EndChild too much?"); + } + } + + IM_ASSERT_USER_ERROR(g.GroupStack.Size == 0, "Missing EndGroup call!"); +} + +// Experimental recovery from incorrect usage of BeginXXX/EndXXX/PushXXX/PopXXX calls. +// Must be called during or before EndFrame(). +// This is generally flawed as we are not necessarily End/Popping things in the right order. +// FIXME: Can't recover from inside BeginTabItem/EndTabItem yet. +// FIXME: Can't recover from interleaved BeginTabBar/Begin +void ImGui::ErrorCheckEndFrameRecover(ImGuiErrorLogCallback log_callback, void* user_data) +{ + // PVS-Studio V1044 is "Loop break conditions do not depend on the number of iterations" + ImGuiContext& g = *GImGui; + while (g.CurrentWindowStack.Size > 0) //-V1044 + { + ErrorCheckEndWindowRecover(log_callback, user_data); + ImGuiWindow* window = g.CurrentWindow; + if (g.CurrentWindowStack.Size == 1) + { + IM_ASSERT(window->IsFallbackWindow); + break; + } + IM_ASSERT(window == g.CurrentWindow); + if (window->Flags & ImGuiWindowFlags_ChildWindow) + { + if (log_callback) log_callback(user_data, "Recovered from missing EndChild() for '%s'", window->Name); + EndChild(); + } + else + { + if (log_callback) log_callback(user_data, "Recovered from missing End() for '%s'", window->Name); + End(); + } + } +} + +// Must be called before End()/EndChild() +void ImGui::ErrorCheckEndWindowRecover(ImGuiErrorLogCallback log_callback, void* user_data) +{ + ImGuiContext& g = *GImGui; + while (g.CurrentTable && (g.CurrentTable->OuterWindow == g.CurrentWindow || g.CurrentTable->InnerWindow == g.CurrentWindow)) + { + if (log_callback) log_callback(user_data, "Recovered from missing EndTable() in '%s'", g.CurrentTable->OuterWindow->Name); + EndTable(); + } + + ImGuiWindow* window = g.CurrentWindow; + ImGuiStackSizes* stack_sizes = &g.CurrentWindowStack.back().StackSizesOnBegin; + IM_ASSERT(window != NULL); + while (g.CurrentTabBar != NULL) //-V1044 + { + if (log_callback) log_callback(user_data, "Recovered from missing EndTabBar() in '%s'", window->Name); + EndTabBar(); + } + while (window->DC.TreeDepth > 0) + { + if (log_callback) log_callback(user_data, "Recovered from missing TreePop() in '%s'", window->Name); + TreePop(); + } + while (g.GroupStack.Size > stack_sizes->SizeOfGroupStack) //-V1044 + { + if (log_callback) log_callback(user_data, "Recovered from missing EndGroup() in '%s'", window->Name); + EndGroup(); + } + while (window->IDStack.Size > 1) + { + if (log_callback) log_callback(user_data, "Recovered from missing PopID() in '%s'", window->Name); + PopID(); + } + while (g.DisabledStackSize > stack_sizes->SizeOfDisabledStack) //-V1044 + { + if (log_callback) log_callback(user_data, "Recovered from missing EndDisabled() in '%s'", window->Name); + EndDisabled(); + } + while (g.ColorStack.Size > stack_sizes->SizeOfColorStack) + { + if (log_callback) log_callback(user_data, "Recovered from missing PopStyleColor() in '%s' for ImGuiCol_%s", window->Name, GetStyleColorName(g.ColorStack.back().Col)); + PopStyleColor(); + } + while (g.ItemFlagsStack.Size > stack_sizes->SizeOfItemFlagsStack) //-V1044 + { + if (log_callback) log_callback(user_data, "Recovered from missing PopItemFlag() in '%s'", window->Name); + PopItemFlag(); + } + while (g.StyleVarStack.Size > stack_sizes->SizeOfStyleVarStack) //-V1044 + { + if (log_callback) log_callback(user_data, "Recovered from missing PopStyleVar() in '%s'", window->Name); + PopStyleVar(); + } + while (g.FocusScopeStack.Size > stack_sizes->SizeOfFocusScopeStack) //-V1044 + { + if (log_callback) log_callback(user_data, "Recovered from missing PopFocusScope() in '%s'", window->Name); + PopFocusScope(); + } +} + +// Save current stack sizes for later compare +void ImGuiStackSizes::SetToCurrentState() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + SizeOfIDStack = (short)window->IDStack.Size; + SizeOfColorStack = (short)g.ColorStack.Size; + SizeOfStyleVarStack = (short)g.StyleVarStack.Size; + SizeOfFontStack = (short)g.FontStack.Size; + SizeOfFocusScopeStack = (short)g.FocusScopeStack.Size; + SizeOfGroupStack = (short)g.GroupStack.Size; + SizeOfItemFlagsStack = (short)g.ItemFlagsStack.Size; + SizeOfBeginPopupStack = (short)g.BeginPopupStack.Size; + SizeOfDisabledStack = (short)g.DisabledStackSize; +} + +// Compare to detect usage errors +void ImGuiStackSizes::CompareWithCurrentState() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + IM_UNUSED(window); + + // Window stacks + // NOT checking: DC.ItemWidth, DC.TextWrapPos (per window) to allow user to conveniently push once and not pop (they are cleared on Begin) + IM_ASSERT(SizeOfIDStack == window->IDStack.Size && "PushID/PopID or TreeNode/TreePop Mismatch!"); + + // Global stacks + // For color, style and font stacks there is an incentive to use Push/Begin/Pop/.../End patterns, so we relax our checks a little to allow them. + IM_ASSERT(SizeOfGroupStack == g.GroupStack.Size && "BeginGroup/EndGroup Mismatch!"); + IM_ASSERT(SizeOfBeginPopupStack == g.BeginPopupStack.Size && "BeginPopup/EndPopup or BeginMenu/EndMenu Mismatch!"); + IM_ASSERT(SizeOfDisabledStack == g.DisabledStackSize && "BeginDisabled/EndDisabled Mismatch!"); + IM_ASSERT(SizeOfItemFlagsStack >= g.ItemFlagsStack.Size && "PushItemFlag/PopItemFlag Mismatch!"); + IM_ASSERT(SizeOfColorStack >= g.ColorStack.Size && "PushStyleColor/PopStyleColor Mismatch!"); + IM_ASSERT(SizeOfStyleVarStack >= g.StyleVarStack.Size && "PushStyleVar/PopStyleVar Mismatch!"); + IM_ASSERT(SizeOfFontStack >= g.FontStack.Size && "PushFont/PopFont Mismatch!"); + IM_ASSERT(SizeOfFocusScopeStack == g.FocusScopeStack.Size && "PushFocusScope/PopFocusScope Mismatch!"); +} + + +//----------------------------------------------------------------------------- +// [SECTION] LAYOUT +//----------------------------------------------------------------------------- +// - ItemSize() +// - ItemAdd() +// - SameLine() +// - GetCursorScreenPos() +// - SetCursorScreenPos() +// - GetCursorPos(), GetCursorPosX(), GetCursorPosY() +// - SetCursorPos(), SetCursorPosX(), SetCursorPosY() +// - GetCursorStartPos() +// - Indent() +// - Unindent() +// - SetNextItemWidth() +// - PushItemWidth() +// - PushMultiItemsWidths() +// - PopItemWidth() +// - CalcItemWidth() +// - CalcItemSize() +// - GetTextLineHeight() +// - GetTextLineHeightWithSpacing() +// - GetFrameHeight() +// - GetFrameHeightWithSpacing() +// - GetContentRegionMax() +// - GetContentRegionMaxAbs() [Internal] +// - GetContentRegionAvail(), +// - GetWindowContentRegionMin(), GetWindowContentRegionMax() +// - BeginGroup() +// - EndGroup() +// Also see in imgui_widgets: tab bars, columns. +//----------------------------------------------------------------------------- + +// Advance cursor given item size for layout. +// Register minimum needed size so it can extend the bounding box used for auto-fit calculation. +// See comments in ItemAdd() about how/why the size provided to ItemSize() vs ItemAdd() may often different. +void ImGui::ItemSize(const ImVec2& size, float text_baseline_y) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return; + + // We increase the height in this function to accommodate for baseline offset. + // In theory we should be offsetting the starting position (window->DC.CursorPos), that will be the topic of a larger refactor, + // but since ItemSize() is not yet an API that moves the cursor (to handle e.g. wrapping) enlarging the height has the same effect. + const float offset_to_match_baseline_y = (text_baseline_y >= 0) ? ImMax(0.0f, window->DC.CurrLineTextBaseOffset - text_baseline_y) : 0.0f; + const float line_height = ImMax(window->DC.CurrLineSize.y, size.y + offset_to_match_baseline_y); + + // Always align ourselves on pixel boundaries + //if (g.IO.KeyAlt) window->DrawList->AddRect(window->DC.CursorPos, window->DC.CursorPos + ImVec2(size.x, line_height), IM_COL32(255,0,0,200)); // [DEBUG] + window->DC.CursorPosPrevLine.x = window->DC.CursorPos.x + size.x; + window->DC.CursorPosPrevLine.y = window->DC.CursorPos.y; + window->DC.CursorPos.x = IM_FLOOR(window->Pos.x + window->DC.Indent.x + window->DC.ColumnsOffset.x); // Next line + window->DC.CursorPos.y = IM_FLOOR(window->DC.CursorPos.y + line_height + g.Style.ItemSpacing.y); // Next line + window->DC.CursorMaxPos.x = ImMax(window->DC.CursorMaxPos.x, window->DC.CursorPosPrevLine.x); + window->DC.CursorMaxPos.y = ImMax(window->DC.CursorMaxPos.y, window->DC.CursorPos.y - g.Style.ItemSpacing.y); + //if (g.IO.KeyAlt) window->DrawList->AddCircle(window->DC.CursorMaxPos, 3.0f, IM_COL32(255,0,0,255), 4); // [DEBUG] + + window->DC.PrevLineSize.y = line_height; + window->DC.CurrLineSize.y = 0.0f; + window->DC.PrevLineTextBaseOffset = ImMax(window->DC.CurrLineTextBaseOffset, text_baseline_y); + window->DC.CurrLineTextBaseOffset = 0.0f; + + // Horizontal layout mode + if (window->DC.LayoutType == ImGuiLayoutType_Horizontal) + SameLine(); +} + +void ImGui::ItemSize(const ImRect& bb, float text_baseline_y) +{ + ItemSize(bb.GetSize(), text_baseline_y); +} + +// Declare item bounding box for clipping and interaction. +// Note that the size can be different than the one provided to ItemSize(). Typically, widgets that spread over available surface +// declare their minimum size requirement to ItemSize() and provide a larger region to ItemAdd() which is used drawing/interaction. +bool ImGui::ItemAdd(const ImRect& bb, ImGuiID id, const ImRect* nav_bb_arg, ImGuiItemFlags extra_flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + // Set item data + // (DisplayRect is left untouched, made valid when ImGuiItemStatusFlags_HasDisplayRect is set) + g.LastItemData.ID = id; + g.LastItemData.Rect = bb; + g.LastItemData.NavRect = nav_bb_arg ? *nav_bb_arg : bb; + g.LastItemData.InFlags = g.CurrentItemFlags | extra_flags; + g.LastItemData.StatusFlags = ImGuiItemStatusFlags_None; + + // Directional navigation processing + if (id != 0) + { + // Runs prior to clipping early-out + // (a) So that NavInitRequest can be honored, for newly opened windows to select a default widget + // (b) So that we can scroll up/down past clipped items. This adds a small O(N) cost to regular navigation requests + // unfortunately, but it is still limited to one window. It may not scale very well for windows with ten of + // thousands of item, but at least NavMoveRequest is only set on user interaction, aka maximum once a frame. + // We could early out with "if (is_clipped && !g.NavInitRequest) return false;" but when we wouldn't be able + // to reach unclipped widgets. This would work if user had explicit scrolling control (e.g. mapped on a stick). + // We intentionally don't check if g.NavWindow != NULL because g.NavAnyRequest should only be set when it is non null. + // If we crash on a NULL g.NavWindow we need to fix the bug elsewhere. + window->DC.NavLayersActiveMaskNext |= (1 << window->DC.NavLayerCurrent); + if (g.NavId == id || g.NavAnyRequest) + if (g.NavWindow->RootWindowForNav == window->RootWindowForNav) + if (window == g.NavWindow || ((window->Flags | g.NavWindow->Flags) & ImGuiWindowFlags_NavFlattened)) + NavProcessItem(); + + // [DEBUG] Item Picker tool, when enabling the "extended" version we perform the check in ItemAdd() +#ifdef IMGUI_DEBUG_TOOL_ITEM_PICKER_EX + if (id == g.DebugItemPickerBreakId) + { + IM_DEBUG_BREAK(); + g.DebugItemPickerBreakId = 0; + } +#endif + } + g.NextItemData.Flags = ImGuiNextItemDataFlags_None; + +#ifdef IMGUI_ENABLE_TEST_ENGINE + if (id != 0) + IMGUI_TEST_ENGINE_ITEM_ADD(nav_bb_arg ? *nav_bb_arg : bb, id); +#endif + + // Clipping test + const bool is_clipped = IsClippedEx(bb, id); + if (is_clipped) + return false; + //if (g.IO.KeyAlt) window->DrawList->AddRect(bb.Min, bb.Max, IM_COL32(255,255,0,120)); // [DEBUG] + + // [WIP] Tab stop handling (previously was using internal FocusableItemRegister() api) + // FIXME-NAV: We would now want to move this before the clipping test, but this would require being able to scroll and currently this would mean an extra frame. (#4079, #343) + if (extra_flags & ImGuiItemFlags_Inputable) + ItemInputable(window, id); + + // We need to calculate this now to take account of the current clipping rectangle (as items like Selectable may change them) + if (IsMouseHoveringRect(bb.Min, bb.Max)) + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_HoveredRect; + return true; +} + +// Gets back to previous line and continue with horizontal layout +// offset_from_start_x == 0 : follow right after previous item +// offset_from_start_x != 0 : align to specified x position (relative to window/group left) +// spacing_w < 0 : use default spacing if pos_x == 0, no spacing if pos_x != 0 +// spacing_w >= 0 : enforce spacing amount +void ImGui::SameLine(float offset_from_start_x, float spacing_w) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + + ImGuiContext& g = *GImGui; + if (offset_from_start_x != 0.0f) + { + if (spacing_w < 0.0f) spacing_w = 0.0f; + window->DC.CursorPos.x = window->Pos.x - window->Scroll.x + offset_from_start_x + spacing_w + window->DC.GroupOffset.x + window->DC.ColumnsOffset.x; + window->DC.CursorPos.y = window->DC.CursorPosPrevLine.y; + } + else + { + if (spacing_w < 0.0f) spacing_w = g.Style.ItemSpacing.x; + window->DC.CursorPos.x = window->DC.CursorPosPrevLine.x + spacing_w; + window->DC.CursorPos.y = window->DC.CursorPosPrevLine.y; + } + window->DC.CurrLineSize = window->DC.PrevLineSize; + window->DC.CurrLineTextBaseOffset = window->DC.PrevLineTextBaseOffset; +} + +ImVec2 ImGui::GetCursorScreenPos() +{ + ImGuiWindow* window = GetCurrentWindowRead(); + return window->DC.CursorPos; +} + +void ImGui::SetCursorScreenPos(const ImVec2& pos) +{ + ImGuiWindow* window = GetCurrentWindow(); + window->DC.CursorPos = pos; + window->DC.CursorMaxPos = ImMax(window->DC.CursorMaxPos, window->DC.CursorPos); +} + +// User generally sees positions in window coordinates. Internally we store CursorPos in absolute screen coordinates because it is more convenient. +// Conversion happens as we pass the value to user, but it makes our naming convention confusing because GetCursorPos() == (DC.CursorPos - window.Pos). May want to rename 'DC.CursorPos'. +ImVec2 ImGui::GetCursorPos() +{ + ImGuiWindow* window = GetCurrentWindowRead(); + return window->DC.CursorPos - window->Pos + window->Scroll; +} + +float ImGui::GetCursorPosX() +{ + ImGuiWindow* window = GetCurrentWindowRead(); + return window->DC.CursorPos.x - window->Pos.x + window->Scroll.x; +} + +float ImGui::GetCursorPosY() +{ + ImGuiWindow* window = GetCurrentWindowRead(); + return window->DC.CursorPos.y - window->Pos.y + window->Scroll.y; +} + +void ImGui::SetCursorPos(const ImVec2& local_pos) +{ + ImGuiWindow* window = GetCurrentWindow(); + window->DC.CursorPos = window->Pos - window->Scroll + local_pos; + window->DC.CursorMaxPos = ImMax(window->DC.CursorMaxPos, window->DC.CursorPos); +} + +void ImGui::SetCursorPosX(float x) +{ + ImGuiWindow* window = GetCurrentWindow(); + window->DC.CursorPos.x = window->Pos.x - window->Scroll.x + x; + window->DC.CursorMaxPos.x = ImMax(window->DC.CursorMaxPos.x, window->DC.CursorPos.x); +} + +void ImGui::SetCursorPosY(float y) +{ + ImGuiWindow* window = GetCurrentWindow(); + window->DC.CursorPos.y = window->Pos.y - window->Scroll.y + y; + window->DC.CursorMaxPos.y = ImMax(window->DC.CursorMaxPos.y, window->DC.CursorPos.y); +} + +ImVec2 ImGui::GetCursorStartPos() +{ + ImGuiWindow* window = GetCurrentWindowRead(); + return window->DC.CursorStartPos - window->Pos; +} + +void ImGui::Indent(float indent_w) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = GetCurrentWindow(); + window->DC.Indent.x += (indent_w != 0.0f) ? indent_w : g.Style.IndentSpacing; + window->DC.CursorPos.x = window->Pos.x + window->DC.Indent.x + window->DC.ColumnsOffset.x; +} + +void ImGui::Unindent(float indent_w) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = GetCurrentWindow(); + window->DC.Indent.x -= (indent_w != 0.0f) ? indent_w : g.Style.IndentSpacing; + window->DC.CursorPos.x = window->Pos.x + window->DC.Indent.x + window->DC.ColumnsOffset.x; +} + +// Affect large frame+labels widgets only. +void ImGui::SetNextItemWidth(float item_width) +{ + ImGuiContext& g = *GImGui; + g.NextItemData.Flags |= ImGuiNextItemDataFlags_HasWidth; + g.NextItemData.Width = item_width; +} + +// FIXME: Remove the == 0.0f behavior? +void ImGui::PushItemWidth(float item_width) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + window->DC.ItemWidthStack.push_back(window->DC.ItemWidth); // Backup current width + window->DC.ItemWidth = (item_width == 0.0f ? window->ItemWidthDefault : item_width); + g.NextItemData.Flags &= ~ImGuiNextItemDataFlags_HasWidth; +} + +void ImGui::PushMultiItemsWidths(int components, float w_full) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + const ImGuiStyle& style = g.Style; + const float w_item_one = ImMax(1.0f, IM_FLOOR((w_full - (style.ItemInnerSpacing.x) * (components - 1)) / (float)components)); + const float w_item_last = ImMax(1.0f, IM_FLOOR(w_full - (w_item_one + style.ItemInnerSpacing.x) * (components - 1))); + window->DC.ItemWidthStack.push_back(window->DC.ItemWidth); // Backup current width + window->DC.ItemWidthStack.push_back(w_item_last); + for (int i = 0; i < components - 2; i++) + window->DC.ItemWidthStack.push_back(w_item_one); + window->DC.ItemWidth = (components == 1) ? w_item_last : w_item_one; + g.NextItemData.Flags &= ~ImGuiNextItemDataFlags_HasWidth; +} + +void ImGui::PopItemWidth() +{ + ImGuiWindow* window = GetCurrentWindow(); + window->DC.ItemWidth = window->DC.ItemWidthStack.back(); + window->DC.ItemWidthStack.pop_back(); +} + +// Calculate default item width given value passed to PushItemWidth() or SetNextItemWidth(). +// The SetNextItemWidth() data is generally cleared/consumed by ItemAdd() or NextItemData.ClearFlags() +float ImGui::CalcItemWidth() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + float w; + if (g.NextItemData.Flags & ImGuiNextItemDataFlags_HasWidth) + w = g.NextItemData.Width; + else + w = window->DC.ItemWidth; + if (w < 0.0f) + { + float region_max_x = GetContentRegionMaxAbs().x; + w = ImMax(1.0f, region_max_x - window->DC.CursorPos.x + w); + } + w = IM_FLOOR(w); + return w; +} + +// [Internal] Calculate full item size given user provided 'size' parameter and default width/height. Default width is often == CalcItemWidth(). +// Those two functions CalcItemWidth vs CalcItemSize are awkwardly named because they are not fully symmetrical. +// Note that only CalcItemWidth() is publicly exposed. +// The 4.0f here may be changed to match CalcItemWidth() and/or BeginChild() (right now we have a mismatch which is harmless but undesirable) +ImVec2 ImGui::CalcItemSize(ImVec2 size, float default_w, float default_h) +{ + ImGuiWindow* window = GImGui->CurrentWindow; + + ImVec2 region_max; + if (size.x < 0.0f || size.y < 0.0f) + region_max = GetContentRegionMaxAbs(); + + if (size.x == 0.0f) + size.x = default_w; + else if (size.x < 0.0f) + size.x = ImMax(4.0f, region_max.x - window->DC.CursorPos.x + size.x); + + if (size.y == 0.0f) + size.y = default_h; + else if (size.y < 0.0f) + size.y = ImMax(4.0f, region_max.y - window->DC.CursorPos.y + size.y); + + return size; +} + +float ImGui::GetTextLineHeight() +{ + ImGuiContext& g = *GImGui; + return g.FontSize; +} + +float ImGui::GetTextLineHeightWithSpacing() +{ + ImGuiContext& g = *GImGui; + return g.FontSize + g.Style.ItemSpacing.y; +} + +float ImGui::GetFrameHeight() +{ + ImGuiContext& g = *GImGui; + return g.FontSize + g.Style.FramePadding.y * 2.0f; +} + +float ImGui::GetFrameHeightWithSpacing() +{ + ImGuiContext& g = *GImGui; + return g.FontSize + g.Style.FramePadding.y * 2.0f + g.Style.ItemSpacing.y; +} + +// FIXME: All the Contents Region function are messy or misleading. WE WILL AIM TO OBSOLETE ALL OF THEM WITH A NEW "WORK RECT" API. Thanks for your patience! + +// FIXME: This is in window space (not screen space!). +ImVec2 ImGui::GetContentRegionMax() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImVec2 mx = window->ContentRegionRect.Max - window->Pos; + if (window->DC.CurrentColumns || g.CurrentTable) + mx.x = window->WorkRect.Max.x - window->Pos.x; + return mx; +} + +// [Internal] Absolute coordinate. Saner. This is not exposed until we finishing refactoring work rect features. +ImVec2 ImGui::GetContentRegionMaxAbs() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImVec2 mx = window->ContentRegionRect.Max; + if (window->DC.CurrentColumns || g.CurrentTable) + mx.x = window->WorkRect.Max.x; + return mx; +} + +ImVec2 ImGui::GetContentRegionAvail() +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return GetContentRegionMaxAbs() - window->DC.CursorPos; +} + +// In window space (not screen space!) +ImVec2 ImGui::GetWindowContentRegionMin() +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->ContentRegionRect.Min - window->Pos; +} + +ImVec2 ImGui::GetWindowContentRegionMax() +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->ContentRegionRect.Max - window->Pos; +} + +// Lock horizontal starting position + capture group bounding box into one "item" (so you can use IsItemHovered() or layout primitives such as SameLine() on whole group, etc.) +// Groups are currently a mishmash of functionalities which should perhaps be clarified and separated. +// FIXME-OPT: Could we safely early out on ->SkipItems? +void ImGui::BeginGroup() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + g.GroupStack.resize(g.GroupStack.Size + 1); + ImGuiGroupData& group_data = g.GroupStack.back(); + group_data.WindowID = window->ID; + group_data.BackupCursorPos = window->DC.CursorPos; + group_data.BackupCursorMaxPos = window->DC.CursorMaxPos; + group_data.BackupIndent = window->DC.Indent; + group_data.BackupGroupOffset = window->DC.GroupOffset; + group_data.BackupCurrLineSize = window->DC.CurrLineSize; + group_data.BackupCurrLineTextBaseOffset = window->DC.CurrLineTextBaseOffset; + group_data.BackupActiveIdIsAlive = g.ActiveIdIsAlive; + group_data.BackupHoveredIdIsAlive = g.HoveredId != 0; + group_data.BackupActiveIdPreviousFrameIsAlive = g.ActiveIdPreviousFrameIsAlive; + group_data.EmitItem = true; + + window->DC.GroupOffset.x = window->DC.CursorPos.x - window->Pos.x - window->DC.ColumnsOffset.x; + window->DC.Indent = window->DC.GroupOffset; + window->DC.CursorMaxPos = window->DC.CursorPos; + window->DC.CurrLineSize = ImVec2(0.0f, 0.0f); + if (g.LogEnabled) + g.LogLinePosY = -FLT_MAX; // To enforce a carriage return +} + +void ImGui::EndGroup() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + IM_ASSERT(g.GroupStack.Size > 0); // Mismatched BeginGroup()/EndGroup() calls + + ImGuiGroupData& group_data = g.GroupStack.back(); + IM_ASSERT(group_data.WindowID == window->ID); // EndGroup() in wrong window? + + ImRect group_bb(group_data.BackupCursorPos, ImMax(window->DC.CursorMaxPos, group_data.BackupCursorPos)); + + window->DC.CursorPos = group_data.BackupCursorPos; + window->DC.CursorMaxPos = ImMax(group_data.BackupCursorMaxPos, window->DC.CursorMaxPos); + window->DC.Indent = group_data.BackupIndent; + window->DC.GroupOffset = group_data.BackupGroupOffset; + window->DC.CurrLineSize = group_data.BackupCurrLineSize; + window->DC.CurrLineTextBaseOffset = group_data.BackupCurrLineTextBaseOffset; + if (g.LogEnabled) + g.LogLinePosY = -FLT_MAX; // To enforce a carriage return + + if (!group_data.EmitItem) + { + g.GroupStack.pop_back(); + return; + } + + window->DC.CurrLineTextBaseOffset = ImMax(window->DC.PrevLineTextBaseOffset, group_data.BackupCurrLineTextBaseOffset); // FIXME: Incorrect, we should grab the base offset from the *first line* of the group but it is hard to obtain now. + ItemSize(group_bb.GetSize()); + ItemAdd(group_bb, 0); + + // If the current ActiveId was declared within the boundary of our group, we copy it to LastItemId so IsItemActive(), IsItemDeactivated() etc. will be functional on the entire group. + // It would be be neater if we replaced window.DC.LastItemId by e.g. 'bool LastItemIsActive', but would put a little more burden on individual widgets. + // Also if you grep for LastItemId you'll notice it is only used in that context. + // (The two tests not the same because ActiveIdIsAlive is an ID itself, in order to be able to handle ActiveId being overwritten during the frame.) + const bool group_contains_curr_active_id = (group_data.BackupActiveIdIsAlive != g.ActiveId) && (g.ActiveIdIsAlive == g.ActiveId) && g.ActiveId; + const bool group_contains_prev_active_id = (group_data.BackupActiveIdPreviousFrameIsAlive == false) && (g.ActiveIdPreviousFrameIsAlive == true); + if (group_contains_curr_active_id) + g.LastItemData.ID = g.ActiveId; + else if (group_contains_prev_active_id) + g.LastItemData.ID = g.ActiveIdPreviousFrame; + g.LastItemData.Rect = group_bb; + + // Forward Hovered flag + const bool group_contains_curr_hovered_id = (group_data.BackupHoveredIdIsAlive == false) && g.HoveredId != 0; + if (group_contains_curr_hovered_id) + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_HoveredWindow; + + // Forward Edited flag + if (group_contains_curr_active_id && g.ActiveIdHasBeenEditedThisFrame) + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_Edited; + + // Forward Deactivated flag + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_HasDeactivated; + if (group_contains_prev_active_id && g.ActiveId != g.ActiveIdPreviousFrame) + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_Deactivated; + + g.GroupStack.pop_back(); + //window->DrawList->AddRect(group_bb.Min, group_bb.Max, IM_COL32(255,0,255,255)); // [Debug] +} + + +//----------------------------------------------------------------------------- +// [SECTION] SCROLLING +//----------------------------------------------------------------------------- + +// Helper to snap on edges when aiming at an item very close to the edge, +// So the difference between WindowPadding and ItemSpacing will be in the visible area after scrolling. +// When we refactor the scrolling API this may be configurable with a flag? +// Note that the effect for this won't be visible on X axis with default Style settings as WindowPadding.x == ItemSpacing.x by default. +static float CalcScrollEdgeSnap(float target, float snap_min, float snap_max, float snap_threshold, float center_ratio) +{ + if (target <= snap_min + snap_threshold) + return ImLerp(snap_min, target, center_ratio); + if (target >= snap_max - snap_threshold) + return ImLerp(target, snap_max, center_ratio); + return target; +} + +static ImVec2 CalcNextScrollFromScrollTargetAndClamp(ImGuiWindow* window) +{ + ImVec2 scroll = window->Scroll; + if (window->ScrollTarget.x < FLT_MAX) + { + float decoration_total_width = window->ScrollbarSizes.x; + float center_x_ratio = window->ScrollTargetCenterRatio.x; + float scroll_target_x = window->ScrollTarget.x; + if (window->ScrollTargetEdgeSnapDist.x > 0.0f) + { + float snap_x_min = 0.0f; + float snap_x_max = window->ScrollMax.x + window->SizeFull.x - decoration_total_width; + scroll_target_x = CalcScrollEdgeSnap(scroll_target_x, snap_x_min, snap_x_max, window->ScrollTargetEdgeSnapDist.x, center_x_ratio); + } + scroll.x = scroll_target_x - center_x_ratio * (window->SizeFull.x - decoration_total_width); + } + if (window->ScrollTarget.y < FLT_MAX) + { + float decoration_total_height = window->TitleBarHeight() + window->MenuBarHeight() + window->ScrollbarSizes.y; + float center_y_ratio = window->ScrollTargetCenterRatio.y; + float scroll_target_y = window->ScrollTarget.y; + if (window->ScrollTargetEdgeSnapDist.y > 0.0f) + { + float snap_y_min = 0.0f; + float snap_y_max = window->ScrollMax.y + window->SizeFull.y - decoration_total_height; + scroll_target_y = CalcScrollEdgeSnap(scroll_target_y, snap_y_min, snap_y_max, window->ScrollTargetEdgeSnapDist.y, center_y_ratio); + } + scroll.y = scroll_target_y - center_y_ratio * (window->SizeFull.y - decoration_total_height); + } + scroll.x = IM_FLOOR(ImMax(scroll.x, 0.0f)); + scroll.y = IM_FLOOR(ImMax(scroll.y, 0.0f)); + if (!window->Collapsed && !window->SkipItems) + { + scroll.x = ImMin(scroll.x, window->ScrollMax.x); + scroll.y = ImMin(scroll.y, window->ScrollMax.y); + } + return scroll; +} + +// Scroll to keep newly navigated item fully into view +ImVec2 ImGui::ScrollToBringRectIntoView(ImGuiWindow* window, const ImRect& item_rect) +{ + ImGuiContext& g = *GImGui; + ImRect window_rect(window->InnerRect.Min - ImVec2(1, 1), window->InnerRect.Max + ImVec2(1, 1)); + //GetForegroundDrawList(window)->AddRect(window_rect.Min, window_rect.Max, IM_COL32_WHITE); // [DEBUG] + + ImVec2 delta_scroll; + if (!window_rect.Contains(item_rect)) + { + if (window->ScrollbarX && item_rect.Min.x < window_rect.Min.x) + SetScrollFromPosX(window, item_rect.Min.x - window->Pos.x - g.Style.ItemSpacing.x, 0.0f); + else if (window->ScrollbarX && item_rect.Max.x >= window_rect.Max.x) + SetScrollFromPosX(window, item_rect.Max.x - window->Pos.x + g.Style.ItemSpacing.x, 1.0f); + if (item_rect.Min.y < window_rect.Min.y) + SetScrollFromPosY(window, item_rect.Min.y - window->Pos.y - g.Style.ItemSpacing.y, 0.0f); + else if (item_rect.Max.y >= window_rect.Max.y) + SetScrollFromPosY(window, item_rect.Max.y - window->Pos.y + g.Style.ItemSpacing.y, 1.0f); + + ImVec2 next_scroll = CalcNextScrollFromScrollTargetAndClamp(window); + delta_scroll = next_scroll - window->Scroll; + } + + // Also scroll parent window to keep us into view if necessary + if (window->Flags & ImGuiWindowFlags_ChildWindow) + delta_scroll += ScrollToBringRectIntoView(window->ParentWindow, ImRect(item_rect.Min - delta_scroll, item_rect.Max - delta_scroll)); + + return delta_scroll; +} + +float ImGui::GetScrollX() +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->Scroll.x; +} + +float ImGui::GetScrollY() +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->Scroll.y; +} + +float ImGui::GetScrollMaxX() +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->ScrollMax.x; +} + +float ImGui::GetScrollMaxY() +{ + ImGuiWindow* window = GImGui->CurrentWindow; + return window->ScrollMax.y; +} + +void ImGui::SetScrollX(ImGuiWindow* window, float scroll_x) +{ + window->ScrollTarget.x = scroll_x; + window->ScrollTargetCenterRatio.x = 0.0f; + window->ScrollTargetEdgeSnapDist.x = 0.0f; +} + +void ImGui::SetScrollY(ImGuiWindow* window, float scroll_y) +{ + window->ScrollTarget.y = scroll_y; + window->ScrollTargetCenterRatio.y = 0.0f; + window->ScrollTargetEdgeSnapDist.y = 0.0f; +} + +void ImGui::SetScrollX(float scroll_x) +{ + ImGuiContext& g = *GImGui; + SetScrollX(g.CurrentWindow, scroll_x); +} + +void ImGui::SetScrollY(float scroll_y) +{ + ImGuiContext& g = *GImGui; + SetScrollY(g.CurrentWindow, scroll_y); +} + +// Note that a local position will vary depending on initial scroll value, +// This is a little bit confusing so bear with us: +// - local_pos = (absolution_pos - window->Pos) +// - So local_x/local_y are 0.0f for a position at the upper-left corner of a window, +// and generally local_x/local_y are >(padding+decoration) && <(size-padding-decoration) when in the visible area. +// - They mostly exists because of legacy API. +// Following the rules above, when trying to work with scrolling code, consider that: +// - SetScrollFromPosY(0.0f) == SetScrollY(0.0f + scroll.y) == has no effect! +// - SetScrollFromPosY(-scroll.y) == SetScrollY(-scroll.y + scroll.y) == SetScrollY(0.0f) == reset scroll. Of course writing SetScrollY(0.0f) directly then makes more sense +// We store a target position so centering and clamping can occur on the next frame when we are guaranteed to have a known window size +void ImGui::SetScrollFromPosX(ImGuiWindow* window, float local_x, float center_x_ratio) +{ + IM_ASSERT(center_x_ratio >= 0.0f && center_x_ratio <= 1.0f); + window->ScrollTarget.x = IM_FLOOR(local_x + window->Scroll.x); // Convert local position to scroll offset + window->ScrollTargetCenterRatio.x = center_x_ratio; + window->ScrollTargetEdgeSnapDist.x = 0.0f; +} + +void ImGui::SetScrollFromPosY(ImGuiWindow* window, float local_y, float center_y_ratio) +{ + IM_ASSERT(center_y_ratio >= 0.0f && center_y_ratio <= 1.0f); + const float decoration_up_height = window->TitleBarHeight() + window->MenuBarHeight(); // FIXME: Would be nice to have a more standardized access to our scrollable/client rect; + local_y -= decoration_up_height; + window->ScrollTarget.y = IM_FLOOR(local_y + window->Scroll.y); // Convert local position to scroll offset + window->ScrollTargetCenterRatio.y = center_y_ratio; + window->ScrollTargetEdgeSnapDist.y = 0.0f; +} + +void ImGui::SetScrollFromPosX(float local_x, float center_x_ratio) +{ + ImGuiContext& g = *GImGui; + SetScrollFromPosX(g.CurrentWindow, local_x, center_x_ratio); +} + +void ImGui::SetScrollFromPosY(float local_y, float center_y_ratio) +{ + ImGuiContext& g = *GImGui; + SetScrollFromPosY(g.CurrentWindow, local_y, center_y_ratio); +} + +// center_x_ratio: 0.0f left of last item, 0.5f horizontal center of last item, 1.0f right of last item. +void ImGui::SetScrollHereX(float center_x_ratio) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + float spacing_x = ImMax(window->WindowPadding.x, g.Style.ItemSpacing.x); + float target_pos_x = ImLerp(g.LastItemData.Rect.Min.x - spacing_x, g.LastItemData.Rect.Max.x + spacing_x, center_x_ratio); + SetScrollFromPosX(window, target_pos_x - window->Pos.x, center_x_ratio); // Convert from absolute to local pos + + // Tweak: snap on edges when aiming at an item very close to the edge + window->ScrollTargetEdgeSnapDist.x = ImMax(0.0f, window->WindowPadding.x - spacing_x); +} + +// center_y_ratio: 0.0f top of last item, 0.5f vertical center of last item, 1.0f bottom of last item. +void ImGui::SetScrollHereY(float center_y_ratio) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + float spacing_y = ImMax(window->WindowPadding.y, g.Style.ItemSpacing.y); + float target_pos_y = ImLerp(window->DC.CursorPosPrevLine.y - spacing_y, window->DC.CursorPosPrevLine.y + window->DC.PrevLineSize.y + spacing_y, center_y_ratio); + SetScrollFromPosY(window, target_pos_y - window->Pos.y, center_y_ratio); // Convert from absolute to local pos + + // Tweak: snap on edges when aiming at an item very close to the edge + window->ScrollTargetEdgeSnapDist.y = ImMax(0.0f, window->WindowPadding.y - spacing_y); +} + +//----------------------------------------------------------------------------- +// [SECTION] TOOLTIPS +//----------------------------------------------------------------------------- + +void ImGui::BeginTooltip() +{ + BeginTooltipEx(ImGuiWindowFlags_None, ImGuiTooltipFlags_None); +} + +void ImGui::BeginTooltipEx(ImGuiWindowFlags extra_flags, ImGuiTooltipFlags tooltip_flags) +{ + ImGuiContext& g = *GImGui; + + if (g.DragDropWithinSource || g.DragDropWithinTarget) + { + // The default tooltip position is a little offset to give space to see the context menu (it's also clamped within the current viewport/monitor) + // In the context of a dragging tooltip we try to reduce that offset and we enforce following the cursor. + // Whatever we do we want to call SetNextWindowPos() to enforce a tooltip position and disable clipping the tooltip without our display area, like regular tooltip do. + //ImVec2 tooltip_pos = g.IO.MousePos - g.ActiveIdClickOffset - g.Style.WindowPadding; + ImVec2 tooltip_pos = g.IO.MousePos + ImVec2(16 * g.Style.MouseCursorScale, 8 * g.Style.MouseCursorScale); + SetNextWindowPos(tooltip_pos); + SetNextWindowBgAlpha(g.Style.Colors[ImGuiCol_PopupBg].w * 0.60f); + //PushStyleVar(ImGuiStyleVar_Alpha, g.Style.Alpha * 0.60f); // This would be nice but e.g ColorButton with checkboard has issue with transparent colors :( + tooltip_flags |= ImGuiTooltipFlags_OverridePreviousTooltip; + } + + char window_name[16]; + ImFormatString(window_name, IM_ARRAYSIZE(window_name), "##Tooltip_%02d", g.TooltipOverrideCount); + if (tooltip_flags & ImGuiTooltipFlags_OverridePreviousTooltip) + if (ImGuiWindow* window = FindWindowByName(window_name)) + if (window->Active) + { + // Hide previous tooltip from being displayed. We can't easily "reset" the content of a window so we create a new one. + window->Hidden = true; + window->HiddenFramesCanSkipItems = 1; // FIXME: This may not be necessary? + ImFormatString(window_name, IM_ARRAYSIZE(window_name), "##Tooltip_%02d", ++g.TooltipOverrideCount); + } + ImGuiWindowFlags flags = ImGuiWindowFlags_Tooltip | ImGuiWindowFlags_NoInputs | ImGuiWindowFlags_NoTitleBar | ImGuiWindowFlags_NoMove | ImGuiWindowFlags_NoResize | ImGuiWindowFlags_NoSavedSettings | ImGuiWindowFlags_AlwaysAutoResize; + Begin(window_name, NULL, flags | extra_flags); +} + +void ImGui::EndTooltip() +{ + IM_ASSERT(GetCurrentWindowRead()->Flags & ImGuiWindowFlags_Tooltip); // Mismatched BeginTooltip()/EndTooltip() calls + End(); +} + +void ImGui::SetTooltipV(const char* fmt, va_list args) +{ + BeginTooltipEx(0, ImGuiTooltipFlags_OverridePreviousTooltip); + TextV(fmt, args); + EndTooltip(); +} + +void ImGui::SetTooltip(const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); + SetTooltipV(fmt, args); + va_end(args); +} + +//----------------------------------------------------------------------------- +// [SECTION] POPUPS +//----------------------------------------------------------------------------- + +// Supported flags: ImGuiPopupFlags_AnyPopupId, ImGuiPopupFlags_AnyPopupLevel +bool ImGui::IsPopupOpen(ImGuiID id, ImGuiPopupFlags popup_flags) +{ + ImGuiContext& g = *GImGui; + if (popup_flags & ImGuiPopupFlags_AnyPopupId) + { + // Return true if any popup is open at the current BeginPopup() level of the popup stack + // This may be used to e.g. test for another popups already opened to handle popups priorities at the same level. + IM_ASSERT(id == 0); + if (popup_flags & ImGuiPopupFlags_AnyPopupLevel) + return g.OpenPopupStack.Size > 0; + else + return g.OpenPopupStack.Size > g.BeginPopupStack.Size; + } + else + { + if (popup_flags & ImGuiPopupFlags_AnyPopupLevel) + { + // Return true if the popup is open anywhere in the popup stack + for (int n = 0; n < g.OpenPopupStack.Size; n++) + if (g.OpenPopupStack[n].PopupId == id) + return true; + return false; + } + else + { + // Return true if the popup is open at the current BeginPopup() level of the popup stack (this is the most-common query) + return g.OpenPopupStack.Size > g.BeginPopupStack.Size && g.OpenPopupStack[g.BeginPopupStack.Size].PopupId == id; + } + } +} + +bool ImGui::IsPopupOpen(const char* str_id, ImGuiPopupFlags popup_flags) +{ + ImGuiContext& g = *GImGui; + ImGuiID id = (popup_flags & ImGuiPopupFlags_AnyPopupId) ? 0 : g.CurrentWindow->GetID(str_id); + if ((popup_flags & ImGuiPopupFlags_AnyPopupLevel) && id != 0) + IM_ASSERT(0 && "Cannot use IsPopupOpen() with a string id and ImGuiPopupFlags_AnyPopupLevel."); // But non-string version is legal and used internally + return IsPopupOpen(id, popup_flags); +} + +ImGuiWindow* ImGui::GetTopMostPopupModal() +{ + ImGuiContext& g = *GImGui; + for (int n = g.OpenPopupStack.Size - 1; n >= 0; n--) + if (ImGuiWindow* popup = g.OpenPopupStack.Data[n].Window) + if (popup->Flags & ImGuiWindowFlags_Modal) + return popup; + return NULL; +} + +void ImGui::OpenPopup(const char* str_id, ImGuiPopupFlags popup_flags) +{ + ImGuiContext& g = *GImGui; + OpenPopupEx(g.CurrentWindow->GetID(str_id), popup_flags); +} + +void ImGui::OpenPopup(ImGuiID id, ImGuiPopupFlags popup_flags) +{ + OpenPopupEx(id, popup_flags); +} + +// Mark popup as open (toggle toward open state). +// Popups are closed when user click outside, or activate a pressable item, or CloseCurrentPopup() is called within a BeginPopup()/EndPopup() block. +// Popup identifiers are relative to the current ID-stack (so OpenPopup and BeginPopup needs to be at the same level). +// One open popup per level of the popup hierarchy (NB: when assigning we reset the Window member of ImGuiPopupRef to NULL) +void ImGui::OpenPopupEx(ImGuiID id, ImGuiPopupFlags popup_flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* parent_window = g.CurrentWindow; + const int current_stack_size = g.BeginPopupStack.Size; + + if (popup_flags & ImGuiPopupFlags_NoOpenOverExistingPopup) + if (IsPopupOpen(0u, ImGuiPopupFlags_AnyPopupId)) + return; + + ImGuiPopupData popup_ref; // Tagged as new ref as Window will be set back to NULL if we write this into OpenPopupStack. + popup_ref.PopupId = id; + popup_ref.Window = NULL; + popup_ref.SourceWindow = g.NavWindow; + popup_ref.OpenFrameCount = g.FrameCount; + popup_ref.OpenParentId = parent_window->IDStack.back(); + popup_ref.OpenPopupPos = NavCalcPreferredRefPos(); + popup_ref.OpenMousePos = IsMousePosValid(&g.IO.MousePos) ? g.IO.MousePos : popup_ref.OpenPopupPos; + + IMGUI_DEBUG_LOG_POPUP("OpenPopupEx(0x%08X)\n", id); + if (g.OpenPopupStack.Size < current_stack_size + 1) + { + g.OpenPopupStack.push_back(popup_ref); + } + else + { + // Gently handle the user mistakenly calling OpenPopup() every frame. It is a programming mistake! However, if we were to run the regular code path, the ui + // would become completely unusable because the popup will always be in hidden-while-calculating-size state _while_ claiming focus. Which would be a very confusing + // situation for the programmer. Instead, we silently allow the popup to proceed, it will keep reappearing and the programming error will be more obvious to understand. + if (g.OpenPopupStack[current_stack_size].PopupId == id && g.OpenPopupStack[current_stack_size].OpenFrameCount == g.FrameCount - 1) + { + g.OpenPopupStack[current_stack_size].OpenFrameCount = popup_ref.OpenFrameCount; + } + else + { + // Close child popups if any, then flag popup for open/reopen + ClosePopupToLevel(current_stack_size, false); + g.OpenPopupStack.push_back(popup_ref); + } + + // When reopening a popup we first refocus its parent, otherwise if its parent is itself a popup it would get closed by ClosePopupsOverWindow(). + // This is equivalent to what ClosePopupToLevel() does. + //if (g.OpenPopupStack[current_stack_size].PopupId == id) + // FocusWindow(parent_window); + } +} + +// When popups are stacked, clicking on a lower level popups puts focus back to it and close popups above it. +// This function closes any popups that are over 'ref_window'. +void ImGui::ClosePopupsOverWindow(ImGuiWindow* ref_window, bool restore_focus_to_window_under_popup) +{ + ImGuiContext& g = *GImGui; + if (g.OpenPopupStack.Size == 0) + return; + + // Don't close our own child popup windows. + int popup_count_to_keep = 0; + if (ref_window) + { + // Find the highest popup which is a descendant of the reference window (generally reference window = NavWindow) + for (; popup_count_to_keep < g.OpenPopupStack.Size; popup_count_to_keep++) + { + ImGuiPopupData& popup = g.OpenPopupStack[popup_count_to_keep]; + if (!popup.Window) + continue; + IM_ASSERT((popup.Window->Flags & ImGuiWindowFlags_Popup) != 0); + if (popup.Window->Flags & ImGuiWindowFlags_ChildWindow) + continue; + + // Trim the stack unless the popup is a direct parent of the reference window (the reference window is often the NavWindow) + // - With this stack of window, clicking/focusing Popup1 will close Popup2 and Popup3: + // Window -> Popup1 -> Popup2 -> Popup3 + // - Each popups may contain child windows, which is why we compare ->RootWindow! + // Window -> Popup1 -> Popup1_Child -> Popup2 -> Popup2_Child + bool ref_window_is_descendent_of_popup = false; + for (int n = popup_count_to_keep; n < g.OpenPopupStack.Size; n++) + if (ImGuiWindow* popup_window = g.OpenPopupStack[n].Window) + if (popup_window->RootWindow == ref_window->RootWindow) + { + ref_window_is_descendent_of_popup = true; + break; + } + if (!ref_window_is_descendent_of_popup) + break; + } + } + if (popup_count_to_keep < g.OpenPopupStack.Size) // This test is not required but it allows to set a convenient breakpoint on the statement below + { + IMGUI_DEBUG_LOG_POPUP("ClosePopupsOverWindow(\"%s\") -> ClosePopupToLevel(%d)\n", ref_window->Name, popup_count_to_keep); + ClosePopupToLevel(popup_count_to_keep, restore_focus_to_window_under_popup); + } +} + +void ImGui::ClosePopupToLevel(int remaining, bool restore_focus_to_window_under_popup) +{ + ImGuiContext& g = *GImGui; + IMGUI_DEBUG_LOG_POPUP("ClosePopupToLevel(%d), restore_focus_to_window_under_popup=%d\n", remaining, restore_focus_to_window_under_popup); + IM_ASSERT(remaining >= 0 && remaining < g.OpenPopupStack.Size); + + // Trim open popup stack + ImGuiWindow* focus_window = g.OpenPopupStack[remaining].SourceWindow; + ImGuiWindow* popup_window = g.OpenPopupStack[remaining].Window; + g.OpenPopupStack.resize(remaining); + + if (restore_focus_to_window_under_popup) + { + if (focus_window && !focus_window->WasActive && popup_window) + { + // Fallback + FocusTopMostWindowUnderOne(popup_window, NULL); + } + else + { + if (g.NavLayer == ImGuiNavLayer_Main && focus_window) + focus_window = NavRestoreLastChildNavWindow(focus_window); + FocusWindow(focus_window); + } + } +} + +// Close the popup we have begin-ed into. +void ImGui::CloseCurrentPopup() +{ + ImGuiContext& g = *GImGui; + int popup_idx = g.BeginPopupStack.Size - 1; + if (popup_idx < 0 || popup_idx >= g.OpenPopupStack.Size || g.BeginPopupStack[popup_idx].PopupId != g.OpenPopupStack[popup_idx].PopupId) + return; + + // Closing a menu closes its top-most parent popup (unless a modal) + while (popup_idx > 0) + { + ImGuiWindow* popup_window = g.OpenPopupStack[popup_idx].Window; + ImGuiWindow* parent_popup_window = g.OpenPopupStack[popup_idx - 1].Window; + bool close_parent = false; + if (popup_window && (popup_window->Flags & ImGuiWindowFlags_ChildMenu)) + if (parent_popup_window == NULL || !(parent_popup_window->Flags & ImGuiWindowFlags_Modal)) + close_parent = true; + if (!close_parent) + break; + popup_idx--; + } + IMGUI_DEBUG_LOG_POPUP("CloseCurrentPopup %d -> %d\n", g.BeginPopupStack.Size - 1, popup_idx); + ClosePopupToLevel(popup_idx, true); + + // A common pattern is to close a popup when selecting a menu item/selectable that will open another window. + // To improve this usage pattern, we avoid nav highlight for a single frame in the parent window. + // Similarly, we could avoid mouse hover highlight in this window but it is less visually problematic. + if (ImGuiWindow* window = g.NavWindow) + window->DC.NavHideHighlightOneFrame = true; +} + +// Attention! BeginPopup() adds default flags which BeginPopupEx()! +bool ImGui::BeginPopupEx(ImGuiID id, ImGuiWindowFlags flags) +{ + ImGuiContext& g = *GImGui; + if (!IsPopupOpen(id, ImGuiPopupFlags_None)) + { + g.NextWindowData.ClearFlags(); // We behave like Begin() and need to consume those values + return false; + } + + char name[20]; + if (flags & ImGuiWindowFlags_ChildMenu) + ImFormatString(name, IM_ARRAYSIZE(name), "##Menu_%02d", g.BeginPopupStack.Size); // Recycle windows based on depth + else + ImFormatString(name, IM_ARRAYSIZE(name), "##Popup_%08x", id); // Not recycling, so we can close/open during the same frame + + flags |= ImGuiWindowFlags_Popup; + bool is_open = Begin(name, NULL, flags); + if (!is_open) // NB: Begin can return false when the popup is completely clipped (e.g. zero size display) + EndPopup(); + + return is_open; +} + +bool ImGui::BeginPopup(const char* str_id, ImGuiWindowFlags flags) +{ + ImGuiContext& g = *GImGui; + if (g.OpenPopupStack.Size <= g.BeginPopupStack.Size) // Early out for performance + { + g.NextWindowData.ClearFlags(); // We behave like Begin() and need to consume those values + return false; + } + flags |= ImGuiWindowFlags_AlwaysAutoResize | ImGuiWindowFlags_NoTitleBar | ImGuiWindowFlags_NoSavedSettings; + return BeginPopupEx(g.CurrentWindow->GetID(str_id), flags); +} + +// If 'p_open' is specified for a modal popup window, the popup will have a regular close button which will close the popup. +// Note that popup visibility status is owned by Dear ImGui (and manipulated with e.g. OpenPopup) so the actual value of *p_open is meaningless here. +bool ImGui::BeginPopupModal(const char* name, bool* p_open, ImGuiWindowFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + const ImGuiID id = window->GetID(name); + if (!IsPopupOpen(id, ImGuiPopupFlags_None)) + { + g.NextWindowData.ClearFlags(); // We behave like Begin() and need to consume those values + return false; + } + + // Center modal windows by default for increased visibility + // (this won't really last as settings will kick in, and is mostly for backward compatibility. user may do the same themselves) + // FIXME: Should test for (PosCond & window->SetWindowPosAllowFlags) with the upcoming window. + if ((g.NextWindowData.Flags & ImGuiNextWindowDataFlags_HasPos) == 0) + { + const ImGuiViewport* viewport = GetMainViewport(); + SetNextWindowPos(viewport->GetCenter(), ImGuiCond_FirstUseEver, ImVec2(0.5f, 0.5f)); + } + + flags |= ImGuiWindowFlags_Popup | ImGuiWindowFlags_Modal | ImGuiWindowFlags_NoCollapse; + const bool is_open = Begin(name, p_open, flags); + if (!is_open || (p_open && !*p_open)) // NB: is_open can be 'false' when the popup is completely clipped (e.g. zero size display) + { + EndPopup(); + if (is_open) + ClosePopupToLevel(g.BeginPopupStack.Size, true); + return false; + } + return is_open; +} + +void ImGui::EndPopup() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + IM_ASSERT(window->Flags & ImGuiWindowFlags_Popup); // Mismatched BeginPopup()/EndPopup() calls + IM_ASSERT(g.BeginPopupStack.Size > 0); + + // Make all menus and popups wrap around for now, may need to expose that policy (e.g. focus scope could include wrap/loop policy flags used by new move requests) + if (g.NavWindow == window) + NavMoveRequestTryWrapping(window, ImGuiNavMoveFlags_LoopY); + + // Child-popups don't need to be laid out + IM_ASSERT(g.WithinEndChild == false); + if (window->Flags & ImGuiWindowFlags_ChildWindow) + g.WithinEndChild = true; + End(); + g.WithinEndChild = false; +} + +// Helper to open a popup if mouse button is released over the item +// - This is essentially the same as BeginPopupContextItem() but without the trailing BeginPopup() +void ImGui::OpenPopupOnItemClick(const char* str_id, ImGuiPopupFlags popup_flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + int mouse_button = (popup_flags & ImGuiPopupFlags_MouseButtonMask_); + if (IsMouseReleased(mouse_button) && IsItemHovered(ImGuiHoveredFlags_AllowWhenBlockedByPopup)) + { + ImGuiID id = str_id ? window->GetID(str_id) : g.LastItemData.ID; // If user hasn't passed an ID, we can use the LastItemID. Using LastItemID as a Popup ID won't conflict! + IM_ASSERT(id != 0); // You cannot pass a NULL str_id if the last item has no identifier (e.g. a Text() item) + OpenPopupEx(id, popup_flags); + } +} + +// This is a helper to handle the simplest case of associating one named popup to one given widget. +// - To create a popup associated to the last item, you generally want to pass a NULL value to str_id. +// - To create a popup with a specific identifier, pass it in str_id. +// - This is useful when using using BeginPopupContextItem() on an item which doesn't have an identifier, e.g. a Text() call. +// - This is useful when multiple code locations may want to manipulate/open the same popup, given an explicit id. +// - You may want to handle the whole on user side if you have specific needs (e.g. tweaking IsItemHovered() parameters). +// This is essentially the same as: +// id = str_id ? GetID(str_id) : GetItemID(); +// OpenPopupOnItemClick(str_id); +// return BeginPopup(id); +// Which is essentially the same as: +// id = str_id ? GetID(str_id) : GetItemID(); +// if (IsItemHovered() && IsMouseReleased(ImGuiMouseButton_Right)) +// OpenPopup(id); +// return BeginPopup(id); +// The main difference being that this is tweaked to avoid computing the ID twice. +bool ImGui::BeginPopupContextItem(const char* str_id, ImGuiPopupFlags popup_flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return false; + ImGuiID id = str_id ? window->GetID(str_id) : g.LastItemData.ID; // If user hasn't passed an ID, we can use the LastItemID. Using LastItemID as a Popup ID won't conflict! + IM_ASSERT(id != 0); // You cannot pass a NULL str_id if the last item has no identifier (e.g. a Text() item) + int mouse_button = (popup_flags & ImGuiPopupFlags_MouseButtonMask_); + if (IsMouseReleased(mouse_button) && IsItemHovered(ImGuiHoveredFlags_AllowWhenBlockedByPopup)) + OpenPopupEx(id, popup_flags); + return BeginPopupEx(id, ImGuiWindowFlags_AlwaysAutoResize | ImGuiWindowFlags_NoTitleBar | ImGuiWindowFlags_NoSavedSettings); +} + +bool ImGui::BeginPopupContextWindow(const char* str_id, ImGuiPopupFlags popup_flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (!str_id) + str_id = "window_context"; + ImGuiID id = window->GetID(str_id); + int mouse_button = (popup_flags & ImGuiPopupFlags_MouseButtonMask_); + if (IsMouseReleased(mouse_button) && IsWindowHovered(ImGuiHoveredFlags_AllowWhenBlockedByPopup)) + if (!(popup_flags & ImGuiPopupFlags_NoOpenOverItems) || !IsAnyItemHovered()) + OpenPopupEx(id, popup_flags); + return BeginPopupEx(id, ImGuiWindowFlags_AlwaysAutoResize | ImGuiWindowFlags_NoTitleBar | ImGuiWindowFlags_NoSavedSettings); +} + +bool ImGui::BeginPopupContextVoid(const char* str_id, ImGuiPopupFlags popup_flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (!str_id) + str_id = "void_context"; + ImGuiID id = window->GetID(str_id); + int mouse_button = (popup_flags & ImGuiPopupFlags_MouseButtonMask_); + if (IsMouseReleased(mouse_button) && !IsWindowHovered(ImGuiHoveredFlags_AnyWindow)) + if (GetTopMostPopupModal() == NULL) + OpenPopupEx(id, popup_flags); + return BeginPopupEx(id, ImGuiWindowFlags_AlwaysAutoResize | ImGuiWindowFlags_NoTitleBar | ImGuiWindowFlags_NoSavedSettings); +} + +// r_avoid = the rectangle to avoid (e.g. for tooltip it is a rectangle around the mouse cursor which we want to avoid. for popups it's a small point around the cursor.) +// r_outer = the visible area rectangle, minus safe area padding. If our popup size won't fit because of safe area padding we ignore it. +// (r_outer is usually equivalent to the viewport rectangle minus padding, but when multi-viewports are enabled and monitor +// information are available, it may represent the entire platform monitor from the frame of reference of the current viewport. +// this allows us to have tooltips/popups displayed out of the parent viewport.) +ImVec2 ImGui::FindBestWindowPosForPopupEx(const ImVec2& ref_pos, const ImVec2& size, ImGuiDir* last_dir, const ImRect& r_outer, const ImRect& r_avoid, ImGuiPopupPositionPolicy policy) +{ + ImVec2 base_pos_clamped = ImClamp(ref_pos, r_outer.Min, r_outer.Max - size); + //GetForegroundDrawList()->AddRect(r_avoid.Min, r_avoid.Max, IM_COL32(255,0,0,255)); + //GetForegroundDrawList()->AddRect(r_outer.Min, r_outer.Max, IM_COL32(0,255,0,255)); + + // Combo Box policy (we want a connecting edge) + if (policy == ImGuiPopupPositionPolicy_ComboBox) + { + const ImGuiDir dir_prefered_order[ImGuiDir_COUNT] = { ImGuiDir_Down, ImGuiDir_Right, ImGuiDir_Left, ImGuiDir_Up }; + for (int n = (*last_dir != ImGuiDir_None) ? -1 : 0; n < ImGuiDir_COUNT; n++) + { + const ImGuiDir dir = (n == -1) ? *last_dir : dir_prefered_order[n]; + if (n != -1 && dir == *last_dir) // Already tried this direction? + continue; + ImVec2 pos; + if (dir == ImGuiDir_Down) pos = ImVec2(r_avoid.Min.x, r_avoid.Max.y); // Below, Toward Right (default) + if (dir == ImGuiDir_Right) pos = ImVec2(r_avoid.Min.x, r_avoid.Min.y - size.y); // Above, Toward Right + if (dir == ImGuiDir_Left) pos = ImVec2(r_avoid.Max.x - size.x, r_avoid.Max.y); // Below, Toward Left + if (dir == ImGuiDir_Up) pos = ImVec2(r_avoid.Max.x - size.x, r_avoid.Min.y - size.y); // Above, Toward Left + if (!r_outer.Contains(ImRect(pos, pos + size))) + continue; + *last_dir = dir; + return pos; + } + } + + // Tooltip and Default popup policy + // (Always first try the direction we used on the last frame, if any) + if (policy == ImGuiPopupPositionPolicy_Tooltip || policy == ImGuiPopupPositionPolicy_Default) + { + const ImGuiDir dir_prefered_order[ImGuiDir_COUNT] = { ImGuiDir_Right, ImGuiDir_Down, ImGuiDir_Up, ImGuiDir_Left }; + for (int n = (*last_dir != ImGuiDir_None) ? -1 : 0; n < ImGuiDir_COUNT; n++) + { + const ImGuiDir dir = (n == -1) ? *last_dir : dir_prefered_order[n]; + if (n != -1 && dir == *last_dir) // Already tried this direction? + continue; + + const float avail_w = (dir == ImGuiDir_Left ? r_avoid.Min.x : r_outer.Max.x) - (dir == ImGuiDir_Right ? r_avoid.Max.x : r_outer.Min.x); + const float avail_h = (dir == ImGuiDir_Up ? r_avoid.Min.y : r_outer.Max.y) - (dir == ImGuiDir_Down ? r_avoid.Max.y : r_outer.Min.y); + + // If there not enough room on one axis, there's no point in positioning on a side on this axis (e.g. when not enough width, use a top/bottom position to maximize available width) + if (avail_w < size.x && (dir == ImGuiDir_Left || dir == ImGuiDir_Right)) + continue; + if (avail_h < size.y && (dir == ImGuiDir_Up || dir == ImGuiDir_Down)) + continue; + + ImVec2 pos; + pos.x = (dir == ImGuiDir_Left) ? r_avoid.Min.x - size.x : (dir == ImGuiDir_Right) ? r_avoid.Max.x : base_pos_clamped.x; + pos.y = (dir == ImGuiDir_Up) ? r_avoid.Min.y - size.y : (dir == ImGuiDir_Down) ? r_avoid.Max.y : base_pos_clamped.y; + + // Clamp top-left corner of popup + pos.x = ImMax(pos.x, r_outer.Min.x); + pos.y = ImMax(pos.y, r_outer.Min.y); + + *last_dir = dir; + return pos; + } + } + + // Fallback when not enough room: + *last_dir = ImGuiDir_None; + + // For tooltip we prefer avoiding the cursor at all cost even if it means that part of the tooltip won't be visible. + if (policy == ImGuiPopupPositionPolicy_Tooltip) + return ref_pos + ImVec2(2, 2); + + // Otherwise try to keep within display + ImVec2 pos = ref_pos; + pos.x = ImMax(ImMin(pos.x + size.x, r_outer.Max.x) - size.x, r_outer.Min.x); + pos.y = ImMax(ImMin(pos.y + size.y, r_outer.Max.y) - size.y, r_outer.Min.y); + return pos; +} + +// Note that this is used for popups, which can overlap the non work-area of individual viewports. +ImRect ImGui::GetPopupAllowedExtentRect(ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + IM_UNUSED(window); + ImRect r_screen = ((ImGuiViewportP*)(void*)GetMainViewport())->GetMainRect(); + ImVec2 padding = g.Style.DisplaySafeAreaPadding; + r_screen.Expand(ImVec2((r_screen.GetWidth() > padding.x * 2) ? -padding.x : 0.0f, (r_screen.GetHeight() > padding.y * 2) ? -padding.y : 0.0f)); + return r_screen; +} + +ImVec2 ImGui::FindBestWindowPosForPopup(ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + + ImRect r_outer = GetPopupAllowedExtentRect(window); + if (window->Flags & ImGuiWindowFlags_ChildMenu) + { + // Child menus typically request _any_ position within the parent menu item, and then we move the new menu outside the parent bounds. + // This is how we end up with child menus appearing (most-commonly) on the right of the parent menu. + IM_ASSERT(g.CurrentWindow == window); + ImGuiWindow* parent_window = g.CurrentWindowStack[g.CurrentWindowStack.Size - 2].Window; + float horizontal_overlap = g.Style.ItemInnerSpacing.x; // We want some overlap to convey the relative depth of each menu (currently the amount of overlap is hard-coded to style.ItemSpacing.x). + ImRect r_avoid; + if (parent_window->DC.MenuBarAppending) + r_avoid = ImRect(-FLT_MAX, parent_window->ClipRect.Min.y, FLT_MAX, parent_window->ClipRect.Max.y); // Avoid parent menu-bar. If we wanted multi-line menu-bar, we may instead want to have the calling window setup e.g. a NextWindowData.PosConstraintAvoidRect field + else + r_avoid = ImRect(parent_window->Pos.x + horizontal_overlap, -FLT_MAX, parent_window->Pos.x + parent_window->Size.x - horizontal_overlap - parent_window->ScrollbarSizes.x, FLT_MAX); + return FindBestWindowPosForPopupEx(window->Pos, window->Size, &window->AutoPosLastDirection, r_outer, r_avoid, ImGuiPopupPositionPolicy_Default); + } + if (window->Flags & ImGuiWindowFlags_Popup) + { + ImRect r_avoid = ImRect(window->Pos.x - 1, window->Pos.y - 1, window->Pos.x + 1, window->Pos.y + 1); + return FindBestWindowPosForPopupEx(window->Pos, window->Size, &window->AutoPosLastDirection, r_outer, r_avoid, ImGuiPopupPositionPolicy_Default); + } + if (window->Flags & ImGuiWindowFlags_Tooltip) + { + // Position tooltip (always follows mouse) + float sc = g.Style.MouseCursorScale; + ImVec2 ref_pos = NavCalcPreferredRefPos(); + ImRect r_avoid; + if (!g.NavDisableHighlight && g.NavDisableMouseHover && !(g.IO.ConfigFlags & ImGuiConfigFlags_NavEnableSetMousePos)) + r_avoid = ImRect(ref_pos.x - 16, ref_pos.y - 8, ref_pos.x + 16, ref_pos.y + 8); + else + r_avoid = ImRect(ref_pos.x - 16, ref_pos.y - 8, ref_pos.x + 24 * sc, ref_pos.y + 24 * sc); // FIXME: Hard-coded based on mouse cursor shape expectation. Exact dimension not very important. + return FindBestWindowPosForPopupEx(ref_pos, window->Size, &window->AutoPosLastDirection, r_outer, r_avoid, ImGuiPopupPositionPolicy_Tooltip); + } + IM_ASSERT(0); + return window->Pos; +} + +//----------------------------------------------------------------------------- +// [SECTION] KEYBOARD/GAMEPAD NAVIGATION +//----------------------------------------------------------------------------- + +// FIXME-NAV: The existence of SetNavID vs SetFocusID properly needs to be clarified/reworked. +// In our terminology those should be interchangeable. Those two functions are merely a legacy artifact, so at minimum naming should be clarified. +void ImGui::SetNavID(ImGuiID id, ImGuiNavLayer nav_layer, ImGuiID focus_scope_id, const ImRect& rect_rel) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.NavWindow != NULL); + IM_ASSERT(nav_layer == ImGuiNavLayer_Main || nav_layer == ImGuiNavLayer_Menu); + g.NavId = id; + g.NavLayer = nav_layer; + g.NavFocusScopeId = focus_scope_id; + g.NavWindow->NavLastIds[nav_layer] = id; + g.NavWindow->NavRectRel[nav_layer] = rect_rel; + //g.NavDisableHighlight = false; + //g.NavDisableMouseHover = g.NavMousePosDirty = true; +} + +void ImGui::SetFocusID(ImGuiID id, ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(id != 0); + + // Assume that SetFocusID() is called in the context where its window->DC.NavLayerCurrent and window->DC.NavFocusScopeIdCurrent are valid. + // Note that window may be != g.CurrentWindow (e.g. SetFocusID call in InputTextEx for multi-line text) + const ImGuiNavLayer nav_layer = window->DC.NavLayerCurrent; + if (g.NavWindow != window) + g.NavInitRequest = false; + g.NavWindow = window; + g.NavId = id; + g.NavLayer = nav_layer; + g.NavFocusScopeId = window->DC.NavFocusScopeIdCurrent; + window->NavLastIds[nav_layer] = id; + if (g.LastItemData.ID == id) + window->NavRectRel[nav_layer] = ImRect(g.LastItemData.NavRect.Min - window->Pos, g.LastItemData.NavRect.Max - window->Pos); + + if (g.ActiveIdSource == ImGuiInputSource_Nav) + g.NavDisableMouseHover = true; + else + g.NavDisableHighlight = true; +} + +ImGuiDir ImGetDirQuadrantFromDelta(float dx, float dy) +{ + if (ImFabs(dx) > ImFabs(dy)) + return (dx > 0.0f) ? ImGuiDir_Right : ImGuiDir_Left; + return (dy > 0.0f) ? ImGuiDir_Down : ImGuiDir_Up; +} + +static float inline NavScoreItemDistInterval(float a0, float a1, float b0, float b1) +{ + if (a1 < b0) + return a1 - b0; + if (b1 < a0) + return a0 - b1; + return 0.0f; +} + +static void inline NavClampRectToVisibleAreaForMoveDir(ImGuiDir move_dir, ImRect& r, const ImRect& clip_rect) +{ + if (move_dir == ImGuiDir_Left || move_dir == ImGuiDir_Right) + { + r.Min.y = ImClamp(r.Min.y, clip_rect.Min.y, clip_rect.Max.y); + r.Max.y = ImClamp(r.Max.y, clip_rect.Min.y, clip_rect.Max.y); + } + else // FIXME: PageUp/PageDown are leaving move_dir == None + { + r.Min.x = ImClamp(r.Min.x, clip_rect.Min.x, clip_rect.Max.x); + r.Max.x = ImClamp(r.Max.x, clip_rect.Min.x, clip_rect.Max.x); + } +} + +// Scoring function for gamepad/keyboard directional navigation. Based on https://gist.github.com/rygorous/6981057 +static bool ImGui::NavScoreItem(ImGuiNavItemData* result) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (g.NavLayer != window->DC.NavLayerCurrent) + return false; + + // FIXME: Those are not good variables names + ImRect cand = g.LastItemData.NavRect; // Current item nav rectangle + const ImRect curr = g.NavScoringRect; // Current modified source rect (NB: we've applied Max.x = Min.x in NavUpdate() to inhibit the effect of having varied item width) + g.NavScoringDebugCount++; + + // When entering through a NavFlattened border, we consider child window items as fully clipped for scoring + if (window->ParentWindow == g.NavWindow) + { + IM_ASSERT((window->Flags | g.NavWindow->Flags) & ImGuiWindowFlags_NavFlattened); + if (!window->ClipRect.Overlaps(cand)) + return false; + cand.ClipWithFull(window->ClipRect); // This allows the scored item to not overlap other candidates in the parent window + } + + // We perform scoring on items bounding box clipped by the current clipping rectangle on the other axis (clipping on our movement axis would give us equal scores for all clipped items) + // For example, this ensure that items in one column are not reached when moving vertically from items in another column. + NavClampRectToVisibleAreaForMoveDir(g.NavMoveClipDir, cand, window->ClipRect); + + // Compute distance between boxes + // FIXME-NAV: Introducing biases for vertical navigation, needs to be removed. + float dbx = NavScoreItemDistInterval(cand.Min.x, cand.Max.x, curr.Min.x, curr.Max.x); + float dby = NavScoreItemDistInterval(ImLerp(cand.Min.y, cand.Max.y, 0.2f), ImLerp(cand.Min.y, cand.Max.y, 0.8f), ImLerp(curr.Min.y, curr.Max.y, 0.2f), ImLerp(curr.Min.y, curr.Max.y, 0.8f)); // Scale down on Y to keep using box-distance for vertically touching items + if (dby != 0.0f && dbx != 0.0f) + dbx = (dbx / 1000.0f) + ((dbx > 0.0f) ? +1.0f : -1.0f); + float dist_box = ImFabs(dbx) + ImFabs(dby); + + // Compute distance between centers (this is off by a factor of 2, but we only compare center distances with each other so it doesn't matter) + float dcx = (cand.Min.x + cand.Max.x) - (curr.Min.x + curr.Max.x); + float dcy = (cand.Min.y + cand.Max.y) - (curr.Min.y + curr.Max.y); + float dist_center = ImFabs(dcx) + ImFabs(dcy); // L1 metric (need this for our connectedness guarantee) + + // Determine which quadrant of 'curr' our candidate item 'cand' lies in based on distance + ImGuiDir quadrant; + float dax = 0.0f, day = 0.0f, dist_axial = 0.0f; + if (dbx != 0.0f || dby != 0.0f) + { + // For non-overlapping boxes, use distance between boxes + dax = dbx; + day = dby; + dist_axial = dist_box; + quadrant = ImGetDirQuadrantFromDelta(dbx, dby); + } + else if (dcx != 0.0f || dcy != 0.0f) + { + // For overlapping boxes with different centers, use distance between centers + dax = dcx; + day = dcy; + dist_axial = dist_center; + quadrant = ImGetDirQuadrantFromDelta(dcx, dcy); + } + else + { + // Degenerate case: two overlapping buttons with same center, break ties arbitrarily (note that LastItemId here is really the _previous_ item order, but it doesn't matter) + quadrant = (g.LastItemData.ID < g.NavId) ? ImGuiDir_Left : ImGuiDir_Right; + } + +#if IMGUI_DEBUG_NAV_SCORING + char buf[128]; + if (IsMouseHoveringRect(cand.Min, cand.Max)) + { + ImFormatString(buf, IM_ARRAYSIZE(buf), "dbox (%.2f,%.2f->%.4f)\ndcen (%.2f,%.2f->%.4f)\nd (%.2f,%.2f->%.4f)\nnav %c, quadrant %c", dbx, dby, dist_box, dcx, dcy, dist_center, dax, day, dist_axial, "WENS"[g.NavMoveDir], "WENS"[quadrant]); + ImDrawList* draw_list = GetForegroundDrawList(window); + draw_list->AddRect(curr.Min, curr.Max, IM_COL32(255,200,0,100)); + draw_list->AddRect(cand.Min, cand.Max, IM_COL32(255,255,0,200)); + draw_list->AddRectFilled(cand.Max - ImVec2(4, 4), cand.Max + CalcTextSize(buf) + ImVec2(4, 4), IM_COL32(40,0,0,150)); + draw_list->AddText(cand.Max, ~0U, buf); + } + else if (g.IO.KeyCtrl) // Hold to preview score in matching quadrant. Press C to rotate. + { + if (quadrant == g.NavMoveDir) + { + ImFormatString(buf, IM_ARRAYSIZE(buf), "%.0f/%.0f", dist_box, dist_center); + ImDrawList* draw_list = GetForegroundDrawList(window); + draw_list->AddRectFilled(cand.Min, cand.Max, IM_COL32(255, 0, 0, 200)); + draw_list->AddText(cand.Min, IM_COL32(255, 255, 255, 255), buf); + } + } +#endif + + // Is it in the quadrant we're interesting in moving to? + bool new_best = false; + const ImGuiDir move_dir = g.NavMoveDir; + if (quadrant == move_dir) + { + // Does it beat the current best candidate? + if (dist_box < result->DistBox) + { + result->DistBox = dist_box; + result->DistCenter = dist_center; + return true; + } + if (dist_box == result->DistBox) + { + // Try using distance between center points to break ties + if (dist_center < result->DistCenter) + { + result->DistCenter = dist_center; + new_best = true; + } + else if (dist_center == result->DistCenter) + { + // Still tied! we need to be extra-careful to make sure everything gets linked properly. We consistently break ties by symbolically moving "later" items + // (with higher index) to the right/downwards by an infinitesimal amount since we the current "best" button already (so it must have a lower index), + // this is fairly easy. This rule ensures that all buttons with dx==dy==0 will end up being linked in order of appearance along the x axis. + if (((move_dir == ImGuiDir_Up || move_dir == ImGuiDir_Down) ? dby : dbx) < 0.0f) // moving bj to the right/down decreases distance + new_best = true; + } + } + } + + // Axial check: if 'curr' has no link at all in some direction and 'cand' lies roughly in that direction, add a tentative link. This will only be kept if no "real" matches + // are found, so it only augments the graph produced by the above method using extra links. (important, since it doesn't guarantee strong connectedness) + // This is just to avoid buttons having no links in a particular direction when there's a suitable neighbor. you get good graphs without this too. + // 2017/09/29: FIXME: This now currently only enabled inside menu bars, ideally we'd disable it everywhere. Menus in particular need to catch failure. For general navigation it feels awkward. + // Disabling it may lead to disconnected graphs when nodes are very spaced out on different axis. Perhaps consider offering this as an option? + if (result->DistBox == FLT_MAX && dist_axial < result->DistAxial) // Check axial match + if (g.NavLayer == ImGuiNavLayer_Menu && !(g.NavWindow->Flags & ImGuiWindowFlags_ChildMenu)) + if ((move_dir == ImGuiDir_Left && dax < 0.0f) || (move_dir == ImGuiDir_Right && dax > 0.0f) || (move_dir == ImGuiDir_Up && day < 0.0f) || (move_dir == ImGuiDir_Down && day > 0.0f)) + { + result->DistAxial = dist_axial; + new_best = true; + } + + return new_best; +} + +static void ImGui::NavApplyItemToResult(ImGuiNavItemData* result) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + result->Window = window; + result->ID = g.LastItemData.ID; + result->FocusScopeId = window->DC.NavFocusScopeIdCurrent; + result->RectRel = ImRect(g.LastItemData.NavRect.Min - window->Pos, g.LastItemData.NavRect.Max - window->Pos); +} + +// We get there when either NavId == id, or when g.NavAnyRequest is set (which is updated by NavUpdateAnyRequestFlag above) +// This is called after LastItemData is set. +static void ImGui::NavProcessItem() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + const ImGuiID id = g.LastItemData.ID; + const ImRect nav_bb = g.LastItemData.NavRect; + const ImGuiItemFlags item_flags = g.LastItemData.InFlags; + + // Process Init Request + if (g.NavInitRequest && g.NavLayer == window->DC.NavLayerCurrent) + { + // Even if 'ImGuiItemFlags_NoNavDefaultFocus' is on (typically collapse/close button) we record the first ResultId so they can be used as a fallback + const bool candidate_for_nav_default_focus = (item_flags & (ImGuiItemFlags_NoNavDefaultFocus | ImGuiItemFlags_Disabled)) == 0; + if (candidate_for_nav_default_focus || g.NavInitResultId == 0) + { + g.NavInitResultId = id; + g.NavInitResultRectRel = ImRect(nav_bb.Min - window->Pos, nav_bb.Max - window->Pos); + } + if (candidate_for_nav_default_focus) + { + g.NavInitRequest = false; // Found a match, clear request + NavUpdateAnyRequestFlag(); + } + } + + // Process Move Request (scoring for navigation) + // FIXME-NAV: Consider policy for double scoring (scoring from NavScoringRect + scoring from a rect wrapped according to current wrapping policy) + if (g.NavMoveScoringItems) + { + if ((g.NavId != id || (g.NavMoveFlags & ImGuiNavMoveFlags_AllowCurrentNavId)) && !(item_flags & (ImGuiItemFlags_Disabled | ImGuiItemFlags_NoNav))) + { + ImGuiNavItemData* result = (window == g.NavWindow) ? &g.NavMoveResultLocal : &g.NavMoveResultOther; + if (NavScoreItem(result)) + NavApplyItemToResult(result); + + // Features like PageUp/PageDown need to maintain a separate score for the visible set of items. + const float VISIBLE_RATIO = 0.70f; + if ((g.NavMoveFlags & ImGuiNavMoveFlags_AlsoScoreVisibleSet) && window->ClipRect.Overlaps(nav_bb)) + if (ImClamp(nav_bb.Max.y, window->ClipRect.Min.y, window->ClipRect.Max.y) - ImClamp(nav_bb.Min.y, window->ClipRect.Min.y, window->ClipRect.Max.y) >= (nav_bb.Max.y - nav_bb.Min.y) * VISIBLE_RATIO) + if (NavScoreItem(&g.NavMoveResultLocalVisible)) + NavApplyItemToResult(&g.NavMoveResultLocalVisible); + } + } + + // Update window-relative bounding box of navigated item + if (g.NavId == id) + { + g.NavWindow = window; // Always refresh g.NavWindow, because some operations such as FocusItem() don't have a window. + g.NavLayer = window->DC.NavLayerCurrent; + g.NavFocusScopeId = window->DC.NavFocusScopeIdCurrent; + g.NavIdIsAlive = true; + window->NavRectRel[window->DC.NavLayerCurrent] = ImRect(nav_bb.Min - window->Pos, nav_bb.Max - window->Pos); // Store item bounding box (relative to window position) + } +} + +bool ImGui::NavMoveRequestButNoResultYet() +{ + ImGuiContext& g = *GImGui; + return g.NavMoveScoringItems && g.NavMoveResultLocal.ID == 0 && g.NavMoveResultOther.ID == 0; +} + +// FIXME: ScoringRect is not set +void ImGui::NavMoveRequestSubmit(ImGuiDir move_dir, ImGuiDir clip_dir, ImGuiNavMoveFlags move_flags) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.NavWindow != NULL); + g.NavMoveSubmitted = g.NavMoveScoringItems = true; + g.NavMoveDir = move_dir; + g.NavMoveDirForDebug = move_dir; + g.NavMoveClipDir = clip_dir; + g.NavMoveFlags = move_flags; + g.NavMoveForwardToNextFrame = false; + g.NavMoveKeyMods = g.IO.KeyMods; + g.NavMoveResultLocal.Clear(); + g.NavMoveResultLocalVisible.Clear(); + g.NavMoveResultOther.Clear(); + NavUpdateAnyRequestFlag(); +} + +void ImGui::NavMoveRequestCancel() +{ + ImGuiContext& g = *GImGui; + g.NavMoveSubmitted = g.NavMoveScoringItems = false; + NavUpdateAnyRequestFlag(); +} + +// Forward will reuse the move request again on the next frame (generally with modifications done to it) +void ImGui::NavMoveRequestForward(ImGuiDir move_dir, ImGuiDir clip_dir, ImGuiNavMoveFlags move_flags) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.NavMoveForwardToNextFrame == false); + NavMoveRequestCancel(); + g.NavMoveForwardToNextFrame = true; + g.NavMoveDir = move_dir; + g.NavMoveClipDir = clip_dir; + g.NavMoveFlags = move_flags | ImGuiNavMoveFlags_Forwarded; +} + +// Navigation wrap-around logic is delayed to the end of the frame because this operation is only valid after entire +// popup is assembled and in case of appended popups it is not clear which EndPopup() call is final. +void ImGui::NavMoveRequestTryWrapping(ImGuiWindow* window, ImGuiNavMoveFlags wrap_flags) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(wrap_flags != 0); // Call with _WrapX, _WrapY, _LoopX, _LoopY + // In theory we should test for NavMoveRequestButNoResultYet() but there's no point doing it, NavEndFrame() will do the same test + if (g.NavWindow == window && g.NavMoveScoringItems && g.NavLayer == ImGuiNavLayer_Main) + g.NavMoveFlags |= wrap_flags; +} + +// FIXME: This could be replaced by updating a frame number in each window when (window == NavWindow) and (NavLayer == 0). +// This way we could find the last focused window among our children. It would be much less confusing this way? +static void ImGui::NavSaveLastChildNavWindowIntoParent(ImGuiWindow* nav_window) +{ + ImGuiWindow* parent = nav_window; + while (parent && parent->RootWindow != parent && (parent->Flags & (ImGuiWindowFlags_Popup | ImGuiWindowFlags_ChildMenu)) == 0) + parent = parent->ParentWindow; + if (parent && parent != nav_window) + parent->NavLastChildNavWindow = nav_window; +} + +// Restore the last focused child. +// Call when we are expected to land on the Main Layer (0) after FocusWindow() +static ImGuiWindow* ImGui::NavRestoreLastChildNavWindow(ImGuiWindow* window) +{ + if (window->NavLastChildNavWindow && window->NavLastChildNavWindow->WasActive) + return window->NavLastChildNavWindow; + return window; +} + +void ImGui::NavRestoreLayer(ImGuiNavLayer layer) +{ + ImGuiContext& g = *GImGui; + if (layer == ImGuiNavLayer_Main) + g.NavWindow = NavRestoreLastChildNavWindow(g.NavWindow); + ImGuiWindow* window = g.NavWindow; + if (window->NavLastIds[layer] != 0) + { + SetNavID(window->NavLastIds[layer], layer, 0, window->NavRectRel[layer]); + } + else + { + g.NavLayer = layer; + NavInitWindow(window, true); + } + g.NavDisableHighlight = false; + g.NavDisableMouseHover = g.NavMousePosDirty = true; +} + +static inline void ImGui::NavUpdateAnyRequestFlag() +{ + ImGuiContext& g = *GImGui; + g.NavAnyRequest = g.NavMoveScoringItems || g.NavInitRequest || (IMGUI_DEBUG_NAV_SCORING && g.NavWindow != NULL); + if (g.NavAnyRequest) + IM_ASSERT(g.NavWindow != NULL); +} + +// This needs to be called before we submit any widget (aka in or before Begin) +void ImGui::NavInitWindow(ImGuiWindow* window, bool force_reinit) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(window == g.NavWindow); + + if (window->Flags & ImGuiWindowFlags_NoNavInputs) + { + g.NavId = g.NavFocusScopeId = 0; + return; + } + + bool init_for_nav = false; + if (window == window->RootWindow || (window->Flags & ImGuiWindowFlags_Popup) || (window->NavLastIds[0] == 0) || force_reinit) + init_for_nav = true; + IMGUI_DEBUG_LOG_NAV("[nav] NavInitRequest: from NavInitWindow(), init_for_nav=%d, window=\"%s\", layer=%d\n", init_for_nav, window->Name, g.NavLayer); + if (init_for_nav) + { + SetNavID(0, g.NavLayer, 0, ImRect()); + g.NavInitRequest = true; + g.NavInitRequestFromMove = false; + g.NavInitResultId = 0; + g.NavInitResultRectRel = ImRect(); + NavUpdateAnyRequestFlag(); + } + else + { + g.NavId = window->NavLastIds[0]; + g.NavFocusScopeId = 0; + } +} + +static ImVec2 ImGui::NavCalcPreferredRefPos() +{ + ImGuiContext& g = *GImGui; + if (g.NavDisableHighlight || !g.NavDisableMouseHover || !g.NavWindow) + { + // Mouse (we need a fallback in case the mouse becomes invalid after being used) + if (IsMousePosValid(&g.IO.MousePos)) + return g.IO.MousePos; + return g.MouseLastValidPos; + } + else + { + // When navigation is active and mouse is disabled, decide on an arbitrary position around the bottom left of the currently navigated item. + const ImRect& rect_rel = g.NavWindow->NavRectRel[g.NavLayer]; + ImVec2 pos = g.NavWindow->Pos + ImVec2(rect_rel.Min.x + ImMin(g.Style.FramePadding.x * 4, rect_rel.GetWidth()), rect_rel.Max.y - ImMin(g.Style.FramePadding.y, rect_rel.GetHeight())); + ImGuiViewport* viewport = GetMainViewport(); + return ImFloor(ImClamp(pos, viewport->Pos, viewport->Pos + viewport->Size)); // ImFloor() is important because non-integer mouse position application in backend might be lossy and result in undesirable non-zero delta. + } +} + +float ImGui::GetNavInputAmount(ImGuiNavInput n, ImGuiInputReadMode mode) +{ + ImGuiContext& g = *GImGui; + if (mode == ImGuiInputReadMode_Down) + return g.IO.NavInputs[n]; // Instant, read analog input (0.0f..1.0f, as provided by user) + + const float t = g.IO.NavInputsDownDuration[n]; + if (t < 0.0f && mode == ImGuiInputReadMode_Released) // Return 1.0f when just released, no repeat, ignore analog input. + return (g.IO.NavInputsDownDurationPrev[n] >= 0.0f ? 1.0f : 0.0f); + if (t < 0.0f) + return 0.0f; + if (mode == ImGuiInputReadMode_Pressed) // Return 1.0f when just pressed, no repeat, ignore analog input. + return (t == 0.0f) ? 1.0f : 0.0f; + if (mode == ImGuiInputReadMode_Repeat) + return (float)CalcTypematicRepeatAmount(t - g.IO.DeltaTime, t, g.IO.KeyRepeatDelay * 0.72f, g.IO.KeyRepeatRate * 0.80f); + if (mode == ImGuiInputReadMode_RepeatSlow) + return (float)CalcTypematicRepeatAmount(t - g.IO.DeltaTime, t, g.IO.KeyRepeatDelay * 1.25f, g.IO.KeyRepeatRate * 2.00f); + if (mode == ImGuiInputReadMode_RepeatFast) + return (float)CalcTypematicRepeatAmount(t - g.IO.DeltaTime, t, g.IO.KeyRepeatDelay * 0.72f, g.IO.KeyRepeatRate * 0.30f); + return 0.0f; +} + +ImVec2 ImGui::GetNavInputAmount2d(ImGuiNavDirSourceFlags dir_sources, ImGuiInputReadMode mode, float slow_factor, float fast_factor) +{ + ImVec2 delta(0.0f, 0.0f); + if (dir_sources & ImGuiNavDirSourceFlags_Keyboard) + delta += ImVec2(GetNavInputAmount(ImGuiNavInput_KeyRight_, mode) - GetNavInputAmount(ImGuiNavInput_KeyLeft_, mode), GetNavInputAmount(ImGuiNavInput_KeyDown_, mode) - GetNavInputAmount(ImGuiNavInput_KeyUp_, mode)); + if (dir_sources & ImGuiNavDirSourceFlags_PadDPad) + delta += ImVec2(GetNavInputAmount(ImGuiNavInput_DpadRight, mode) - GetNavInputAmount(ImGuiNavInput_DpadLeft, mode), GetNavInputAmount(ImGuiNavInput_DpadDown, mode) - GetNavInputAmount(ImGuiNavInput_DpadUp, mode)); + if (dir_sources & ImGuiNavDirSourceFlags_PadLStick) + delta += ImVec2(GetNavInputAmount(ImGuiNavInput_LStickRight, mode) - GetNavInputAmount(ImGuiNavInput_LStickLeft, mode), GetNavInputAmount(ImGuiNavInput_LStickDown, mode) - GetNavInputAmount(ImGuiNavInput_LStickUp, mode)); + if (slow_factor != 0.0f && IsNavInputDown(ImGuiNavInput_TweakSlow)) + delta *= slow_factor; + if (fast_factor != 0.0f && IsNavInputDown(ImGuiNavInput_TweakFast)) + delta *= fast_factor; + return delta; +} + +static void ImGui::NavUpdate() +{ + ImGuiContext& g = *GImGui; + ImGuiIO& io = g.IO; + + io.WantSetMousePos = false; + //if (g.NavScoringDebugCount > 0) IMGUI_DEBUG_LOG("NavScoringDebugCount %d for '%s' layer %d (Init:%d, Move:%d)\n", g.NavScoringDebugCount, g.NavWindow ? g.NavWindow->Name : "NULL", g.NavLayer, g.NavInitRequest || g.NavInitResultId != 0, g.NavMoveRequest); + + // Set input source as Gamepad when buttons are pressed (as some features differs when used with Gamepad vs Keyboard) + // (do it before we map Keyboard input!) + const bool nav_keyboard_active = (io.ConfigFlags & ImGuiConfigFlags_NavEnableKeyboard) != 0; + const bool nav_gamepad_active = (io.ConfigFlags & ImGuiConfigFlags_NavEnableGamepad) != 0 && (io.BackendFlags & ImGuiBackendFlags_HasGamepad) != 0; + if (nav_gamepad_active && g.NavInputSource != ImGuiInputSource_Gamepad) + { + if (io.NavInputs[ImGuiNavInput_Activate] > 0.0f || io.NavInputs[ImGuiNavInput_Input] > 0.0f || io.NavInputs[ImGuiNavInput_Cancel] > 0.0f || io.NavInputs[ImGuiNavInput_Menu] > 0.0f + || io.NavInputs[ImGuiNavInput_DpadLeft] > 0.0f || io.NavInputs[ImGuiNavInput_DpadRight] > 0.0f || io.NavInputs[ImGuiNavInput_DpadUp] > 0.0f || io.NavInputs[ImGuiNavInput_DpadDown] > 0.0f) + g.NavInputSource = ImGuiInputSource_Gamepad; + } + + // Update Keyboard->Nav inputs mapping + if (nav_keyboard_active) + { + #define NAV_MAP_KEY(_KEY, _NAV_INPUT) do { if (IsKeyDown(io.KeyMap[_KEY])) { io.NavInputs[_NAV_INPUT] = 1.0f; g.NavInputSource = ImGuiInputSource_Keyboard; } } while (0) + NAV_MAP_KEY(ImGuiKey_Space, ImGuiNavInput_Activate ); + NAV_MAP_KEY(ImGuiKey_Enter, ImGuiNavInput_Input ); + NAV_MAP_KEY(ImGuiKey_Escape, ImGuiNavInput_Cancel ); + NAV_MAP_KEY(ImGuiKey_LeftArrow, ImGuiNavInput_KeyLeft_ ); + NAV_MAP_KEY(ImGuiKey_RightArrow,ImGuiNavInput_KeyRight_); + NAV_MAP_KEY(ImGuiKey_UpArrow, ImGuiNavInput_KeyUp_ ); + NAV_MAP_KEY(ImGuiKey_DownArrow, ImGuiNavInput_KeyDown_ ); + if (io.KeyCtrl) + io.NavInputs[ImGuiNavInput_TweakSlow] = 1.0f; + if (io.KeyShift) + io.NavInputs[ImGuiNavInput_TweakFast] = 1.0f; + #undef NAV_MAP_KEY + } + memcpy(io.NavInputsDownDurationPrev, io.NavInputsDownDuration, sizeof(io.NavInputsDownDuration)); + for (int i = 0; i < IM_ARRAYSIZE(io.NavInputs); i++) + io.NavInputsDownDuration[i] = (io.NavInputs[i] > 0.0f) ? (io.NavInputsDownDuration[i] < 0.0f ? 0.0f : io.NavInputsDownDuration[i] + io.DeltaTime) : -1.0f; + + // Process navigation init request (select first/default focus) + if (g.NavInitResultId != 0) + NavInitRequestApplyResult(); + g.NavInitRequest = false; + g.NavInitRequestFromMove = false; + g.NavInitResultId = 0; + g.NavJustMovedToId = 0; + + // Process navigation move request + if (g.NavMoveSubmitted) + NavMoveRequestApplyResult(); + g.NavMoveSubmitted = g.NavMoveScoringItems = false; + + // Apply application mouse position movement, after we had a chance to process move request result. + if (g.NavMousePosDirty && g.NavIdIsAlive) + { + // Set mouse position given our knowledge of the navigated item position from last frame + if ((io.ConfigFlags & ImGuiConfigFlags_NavEnableSetMousePos) && (io.BackendFlags & ImGuiBackendFlags_HasSetMousePos)) + if (!g.NavDisableHighlight && g.NavDisableMouseHover && g.NavWindow) + { + io.MousePos = io.MousePosPrev = NavCalcPreferredRefPos(); + io.WantSetMousePos = true; + //IMGUI_DEBUG_LOG("SetMousePos: (%.1f,%.1f)\n", io.MousePos.x, io.MousePos.y); + } + g.NavMousePosDirty = false; + } + g.NavIdIsAlive = false; + g.NavJustTabbedId = 0; + IM_ASSERT(g.NavLayer == 0 || g.NavLayer == 1); + + // Store our return window (for returning from Menu Layer to Main Layer) and clear it as soon as we step back in our own Layer 0 + if (g.NavWindow) + NavSaveLastChildNavWindowIntoParent(g.NavWindow); + if (g.NavWindow && g.NavWindow->NavLastChildNavWindow != NULL && g.NavLayer == ImGuiNavLayer_Main) + g.NavWindow->NavLastChildNavWindow = NULL; + + // Update CTRL+TAB and Windowing features (hold Square to move/resize/etc.) + NavUpdateWindowing(); + + // Set output flags for user application + io.NavActive = (nav_keyboard_active || nav_gamepad_active) && g.NavWindow && !(g.NavWindow->Flags & ImGuiWindowFlags_NoNavInputs); + io.NavVisible = (io.NavActive && g.NavId != 0 && !g.NavDisableHighlight) || (g.NavWindowingTarget != NULL); + + // Process NavCancel input (to close a popup, get back to parent, clear focus) + NavUpdateCancelRequest(); + + // Process manual activation request + g.NavActivateId = g.NavActivateDownId = g.NavActivatePressedId = g.NavActivateInputId = 0; + g.NavActivateFlags = ImGuiActivateFlags_None; + if (g.NavId != 0 && !g.NavDisableHighlight && !g.NavWindowingTarget && g.NavWindow && !(g.NavWindow->Flags & ImGuiWindowFlags_NoNavInputs)) + { + bool activate_down = IsNavInputDown(ImGuiNavInput_Activate); + bool input_down = IsNavInputDown(ImGuiNavInput_Input); + bool activate_pressed = activate_down && IsNavInputTest(ImGuiNavInput_Activate, ImGuiInputReadMode_Pressed); + bool input_pressed = input_down && IsNavInputTest(ImGuiNavInput_Input, ImGuiInputReadMode_Pressed); + if (g.ActiveId == 0 && activate_pressed) + { + g.NavActivateId = g.NavId; + g.NavActivateFlags = ImGuiActivateFlags_PreferTweak; + } + if ((g.ActiveId == 0 || g.ActiveId == g.NavId) && input_pressed) + { + g.NavActivateInputId = g.NavId; + g.NavActivateFlags = ImGuiActivateFlags_PreferInput; + } + if ((g.ActiveId == 0 || g.ActiveId == g.NavId) && activate_down) + g.NavActivateDownId = g.NavId; + if ((g.ActiveId == 0 || g.ActiveId == g.NavId) && activate_pressed) + g.NavActivatePressedId = g.NavId; + } + if (g.NavWindow && (g.NavWindow->Flags & ImGuiWindowFlags_NoNavInputs)) + g.NavDisableHighlight = true; + if (g.NavActivateId != 0) + IM_ASSERT(g.NavActivateDownId == g.NavActivateId); + + // Process programmatic activation request + // FIXME-NAV: Those should eventually be queued (unlike focus they don't cancel each others) + if (g.NavNextActivateId != 0) + { + if (g.NavNextActivateFlags & ImGuiActivateFlags_PreferInput) + g.NavActivateInputId = g.NavNextActivateId; + else + g.NavActivateId = g.NavActivateDownId = g.NavActivatePressedId = g.NavNextActivateId; + g.NavActivateFlags = g.NavNextActivateFlags; + } + g.NavNextActivateId = 0; + + // Process move requests + NavUpdateCreateMoveRequest(); + NavUpdateAnyRequestFlag(); + + // Scrolling + if (g.NavWindow && !(g.NavWindow->Flags & ImGuiWindowFlags_NoNavInputs) && !g.NavWindowingTarget) + { + // *Fallback* manual-scroll with Nav directional keys when window has no navigable item + ImGuiWindow* window = g.NavWindow; + const float scroll_speed = IM_ROUND(window->CalcFontSize() * 100 * io.DeltaTime); // We need round the scrolling speed because sub-pixel scroll isn't reliably supported. + const ImGuiDir move_dir = g.NavMoveDir; + if (window->DC.NavLayersActiveMask == 0x00 && window->DC.NavHasScroll && move_dir != ImGuiDir_None) + { + if (move_dir == ImGuiDir_Left || move_dir == ImGuiDir_Right) + SetScrollX(window, ImFloor(window->Scroll.x + ((move_dir == ImGuiDir_Left) ? -1.0f : +1.0f) * scroll_speed)); + if (move_dir == ImGuiDir_Up || move_dir == ImGuiDir_Down) + SetScrollY(window, ImFloor(window->Scroll.y + ((move_dir == ImGuiDir_Up) ? -1.0f : +1.0f) * scroll_speed)); + } + + // *Normal* Manual scroll with NavScrollXXX keys + // Next movement request will clamp the NavId reference rectangle to the visible area, so navigation will resume within those bounds. + ImVec2 scroll_dir = GetNavInputAmount2d(ImGuiNavDirSourceFlags_PadLStick, ImGuiInputReadMode_Down, 1.0f / 10.0f, 10.0f); + if (scroll_dir.x != 0.0f && window->ScrollbarX) + SetScrollX(window, ImFloor(window->Scroll.x + scroll_dir.x * scroll_speed)); + if (scroll_dir.y != 0.0f) + SetScrollY(window, ImFloor(window->Scroll.y + scroll_dir.y * scroll_speed)); + } + + // Always prioritize mouse highlight if navigation is disabled + if (!nav_keyboard_active && !nav_gamepad_active) + { + g.NavDisableHighlight = true; + g.NavDisableMouseHover = g.NavMousePosDirty = false; + } + + // [DEBUG] + g.NavScoringDebugCount = 0; +#if IMGUI_DEBUG_NAV_RECTS + if (g.NavWindow) + { + ImDrawList* draw_list = GetForegroundDrawList(g.NavWindow); + if (1) { for (int layer = 0; layer < 2; layer++) draw_list->AddRect(g.NavWindow->Pos + g.NavWindow->NavRectRel[layer].Min, g.NavWindow->Pos + g.NavWindow->NavRectRel[layer].Max, IM_COL32(255,200,0,255)); } // [DEBUG] + if (1) { ImU32 col = (!g.NavWindow->Hidden) ? IM_COL32(255,0,255,255) : IM_COL32(255,0,0,255); ImVec2 p = NavCalcPreferredRefPos(); char buf[32]; ImFormatString(buf, 32, "%d", g.NavLayer); draw_list->AddCircleFilled(p, 3.0f, col); draw_list->AddText(NULL, 13.0f, p + ImVec2(8,-4), col, buf); } + } +#endif +} + +void ImGui::NavInitRequestApplyResult() +{ + // In very rare cases g.NavWindow may be null (e.g. clearing focus after requesting an init request, which does happen when releasing Alt while clicking on void) + ImGuiContext& g = *GImGui; + if (!g.NavWindow) + return; + + // Apply result from previous navigation init request (will typically select the first item, unless SetItemDefaultFocus() has been called) + // FIXME-NAV: On _NavFlattened windows, g.NavWindow will only be updated during subsequent frame. Not a problem currently. + IMGUI_DEBUG_LOG_NAV("[nav] NavInitRequest: result NavID 0x%08X in Layer %d Window \"%s\"\n", g.NavInitResultId, g.NavLayer, g.NavWindow->Name); + SetNavID(g.NavInitResultId, g.NavLayer, 0, g.NavInitResultRectRel); + g.NavIdIsAlive = true; // Mark as alive from previous frame as we got a result + if (g.NavInitRequestFromMove) + { + g.NavDisableHighlight = false; + g.NavDisableMouseHover = g.NavMousePosDirty = true; + } +} + +void ImGui::NavUpdateCreateMoveRequest() +{ + ImGuiContext& g = *GImGui; + ImGuiIO& io = g.IO; + ImGuiWindow* window = g.NavWindow; + + if (g.NavMoveForwardToNextFrame && window != NULL) + { + // Forwarding previous request (which has been modified, e.g. wrap around menus rewrite the requests with a starting rectangle at the other side of the window) + // (preserve most state, which were already set by the NavMoveRequestForward() function) + IM_ASSERT(g.NavMoveDir != ImGuiDir_None && g.NavMoveClipDir != ImGuiDir_None); + IM_ASSERT(g.NavMoveFlags & ImGuiNavMoveFlags_Forwarded); + IMGUI_DEBUG_LOG_NAV("[nav] NavMoveRequestForward %d\n", g.NavMoveDir); + } + else + { + // Initiate directional inputs request + g.NavMoveDir = ImGuiDir_None; + g.NavMoveFlags = ImGuiNavMoveFlags_None; + if (window && !g.NavWindowingTarget && !(window->Flags & ImGuiWindowFlags_NoNavInputs)) + { + const ImGuiInputReadMode read_mode = ImGuiInputReadMode_Repeat; + if (!IsActiveIdUsingNavDir(ImGuiDir_Left) && (IsNavInputTest(ImGuiNavInput_DpadLeft, read_mode) || IsNavInputTest(ImGuiNavInput_KeyLeft_, read_mode))) { g.NavMoveDir = ImGuiDir_Left; } + if (!IsActiveIdUsingNavDir(ImGuiDir_Right) && (IsNavInputTest(ImGuiNavInput_DpadRight, read_mode) || IsNavInputTest(ImGuiNavInput_KeyRight_, read_mode))) { g.NavMoveDir = ImGuiDir_Right; } + if (!IsActiveIdUsingNavDir(ImGuiDir_Up) && (IsNavInputTest(ImGuiNavInput_DpadUp, read_mode) || IsNavInputTest(ImGuiNavInput_KeyUp_, read_mode))) { g.NavMoveDir = ImGuiDir_Up; } + if (!IsActiveIdUsingNavDir(ImGuiDir_Down) && (IsNavInputTest(ImGuiNavInput_DpadDown, read_mode) || IsNavInputTest(ImGuiNavInput_KeyDown_, read_mode))) { g.NavMoveDir = ImGuiDir_Down; } + } + g.NavMoveClipDir = g.NavMoveDir; + } + + // Update PageUp/PageDown/Home/End scroll + // FIXME-NAV: Consider enabling those keys even without the master ImGuiConfigFlags_NavEnableKeyboard flag? + const bool nav_keyboard_active = (io.ConfigFlags & ImGuiConfigFlags_NavEnableKeyboard) != 0; + float scoring_rect_offset_y = 0.0f; + if (window && g.NavMoveDir == ImGuiDir_None && nav_keyboard_active) + scoring_rect_offset_y = NavUpdatePageUpPageDown(); + + // [DEBUG] Always send a request +#if IMGUI_DEBUG_NAV_SCORING + if (io.KeyCtrl && IsKeyPressedMap(ImGuiKey_C)) + g.NavMoveDirForDebug = (ImGuiDir)((g.NavMoveDirForDebug + 1) & 3); + if (io.KeyCtrl && g.NavMoveDir == ImGuiDir_None) + { + g.NavMoveDir = g.NavMoveDirForDebug; + g.NavMoveFlags |= ImGuiNavMoveFlags_DebugNoResult; + } +#endif + + // Submit + g.NavMoveForwardToNextFrame = false; + if (g.NavMoveDir != ImGuiDir_None) + NavMoveRequestSubmit(g.NavMoveDir, g.NavMoveClipDir, g.NavMoveFlags); + + // Moving with no reference triggers a init request (will be used as a fallback if the direction fails to find a match) + if (g.NavMoveSubmitted && g.NavId == 0) + { + IMGUI_DEBUG_LOG_NAV("[nav] NavInitRequest: from move, window \"%s\", layer=%d\n", g.NavWindow->Name, g.NavLayer); + g.NavInitRequest = g.NavInitRequestFromMove = true; + g.NavInitResultId = 0; + g.NavDisableHighlight = false; + } + + // When using gamepad, we project the reference nav bounding box into window visible area. + // This is to allow resuming navigation inside the visible area after doing a large amount of scrolling, since with gamepad every movements are relative + // (can't focus a visible object like we can with the mouse). + if (g.NavMoveSubmitted && g.NavInputSource == ImGuiInputSource_Gamepad && g.NavLayer == ImGuiNavLayer_Main && window != NULL) + { + ImRect window_rect_rel(window->InnerRect.Min - window->Pos - ImVec2(1, 1), window->InnerRect.Max - window->Pos + ImVec2(1, 1)); + if (!window_rect_rel.Contains(window->NavRectRel[g.NavLayer])) + { + IMGUI_DEBUG_LOG_NAV("[nav] NavMoveRequest: clamp NavRectRel\n"); + float pad = window->CalcFontSize() * 0.5f; + window_rect_rel.Expand(ImVec2(-ImMin(window_rect_rel.GetWidth(), pad), -ImMin(window_rect_rel.GetHeight(), pad))); // Terrible approximation for the intent of starting navigation from first fully visible item + window->NavRectRel[g.NavLayer].ClipWithFull(window_rect_rel); + g.NavId = g.NavFocusScopeId = 0; + } + } + + // For scoring we use a single segment on the left side our current item bounding box (not touching the edge to avoid box overlap with zero-spaced items) + ImRect scoring_rect; + if (window != NULL) + { + ImRect nav_rect_rel = !window->NavRectRel[g.NavLayer].IsInverted() ? window->NavRectRel[g.NavLayer] : ImRect(0, 0, 0, 0); + scoring_rect = ImRect(window->Pos + nav_rect_rel.Min, window->Pos + nav_rect_rel.Max); + scoring_rect.TranslateY(scoring_rect_offset_y); + scoring_rect.Min.x = ImMin(scoring_rect.Min.x + 1.0f, scoring_rect.Max.x); + scoring_rect.Max.x = scoring_rect.Min.x; + IM_ASSERT(!scoring_rect.IsInverted()); // Ensure if we have a finite, non-inverted bounding box here will allows us to remove extraneous ImFabs() calls in NavScoreItem(). + //GetForegroundDrawList()->AddRect(scoring_rect.Min, scoring_rect.Max, IM_COL32(255,200,0,255)); // [DEBUG] + } + g.NavScoringRect = scoring_rect; +} + +// Apply result from previous frame navigation directional move request. Always called from NavUpdate() +void ImGui::NavMoveRequestApplyResult() +{ + ImGuiContext& g = *GImGui; +#if IMGUI_DEBUG_NAV_SCORING + if (g.NavMoveFlags & ImGuiNavMoveFlags_DebugNoResult) // [DEBUG] Scoring all items in NavWindow at all times + return; +#endif + + // Select which result to use + ImGuiNavItemData* result = (g.NavMoveResultLocal.ID != 0) ? &g.NavMoveResultLocal : (g.NavMoveResultOther.ID != 0) ? &g.NavMoveResultOther : NULL; + + // In a situation when there is no results but NavId != 0, re-enable the Navigation highlight (because g.NavId is not considered as a possible result) + if (result == NULL) + { + if (g.NavId != 0) + { + g.NavDisableHighlight = false; + g.NavDisableMouseHover = true; + } + return; + } + + // PageUp/PageDown behavior first jumps to the bottom/top mostly visible item, _otherwise_ use the result from the previous/next page. + if (g.NavMoveFlags & ImGuiNavMoveFlags_AlsoScoreVisibleSet) + if (g.NavMoveResultLocalVisible.ID != 0 && g.NavMoveResultLocalVisible.ID != g.NavId) + result = &g.NavMoveResultLocalVisible; + + // Maybe entering a flattened child from the outside? In this case solve the tie using the regular scoring rules. + if (result != &g.NavMoveResultOther && g.NavMoveResultOther.ID != 0 && g.NavMoveResultOther.Window->ParentWindow == g.NavWindow) + if ((g.NavMoveResultOther.DistBox < result->DistBox) || (g.NavMoveResultOther.DistBox == result->DistBox && g.NavMoveResultOther.DistCenter < result->DistCenter)) + result = &g.NavMoveResultOther; + IM_ASSERT(g.NavWindow && result->Window); + + // Scroll to keep newly navigated item fully into view. + if (g.NavLayer == ImGuiNavLayer_Main) + { + ImVec2 delta_scroll; + if (g.NavMoveFlags & ImGuiNavMoveFlags_ScrollToEdge) + { + float scroll_target = (g.NavMoveDir == ImGuiDir_Up) ? result->Window->ScrollMax.y : 0.0f; + delta_scroll.y = result->Window->Scroll.y - scroll_target; + SetScrollY(result->Window, scroll_target); + } + else + { + ImRect rect_abs = ImRect(result->RectRel.Min + result->Window->Pos, result->RectRel.Max + result->Window->Pos); + delta_scroll = ScrollToBringRectIntoView(result->Window, rect_abs); + } + + // Offset our result position so mouse position can be applied immediately after in NavUpdate() + result->RectRel.TranslateX(-delta_scroll.x); + result->RectRel.TranslateY(-delta_scroll.y); + } + + ClearActiveID(); + g.NavWindow = result->Window; + if (g.NavId != result->ID) + { + // Don't set NavJustMovedToId if just landed on the same spot (which may happen with ImGuiNavMoveFlags_AllowCurrentNavId) + g.NavJustMovedToId = result->ID; + g.NavJustMovedToFocusScopeId = result->FocusScopeId; + g.NavJustMovedToKeyMods = g.NavMoveKeyMods; + } + + // Focus + IMGUI_DEBUG_LOG_NAV("[nav] NavMoveRequest: result NavID 0x%08X in Layer %d Window \"%s\"\n", result->ID, g.NavLayer, g.NavWindow->Name); + SetNavID(result->ID, g.NavLayer, result->FocusScopeId, result->RectRel); + + // Enable nav highlight + g.NavDisableHighlight = false; + g.NavDisableMouseHover = g.NavMousePosDirty = true; +} + +// Process NavCancel input (to close a popup, get back to parent, clear focus) +// FIXME: In order to support e.g. Escape to clear a selection we'll need: +// - either to store the equivalent of ActiveIdUsingKeyInputMask for a FocusScope and test for it. +// - either to move most/all of those tests to the epilogue/end functions of the scope they are dealing with (e.g. exit child window in EndChild()) or in EndFrame(), to allow an earlier intercept +static void ImGui::NavUpdateCancelRequest() +{ + ImGuiContext& g = *GImGui; + if (!IsNavInputTest(ImGuiNavInput_Cancel, ImGuiInputReadMode_Pressed)) + return; + + IMGUI_DEBUG_LOG_NAV("[nav] ImGuiNavInput_Cancel\n"); + if (g.ActiveId != 0) + { + if (!IsActiveIdUsingNavInput(ImGuiNavInput_Cancel)) + ClearActiveID(); + } + else if (g.NavLayer != ImGuiNavLayer_Main) + { + // Leave the "menu" layer + NavRestoreLayer(ImGuiNavLayer_Main); + } + else if (g.NavWindow && g.NavWindow != g.NavWindow->RootWindow && !(g.NavWindow->Flags & ImGuiWindowFlags_Popup) && g.NavWindow->ParentWindow) + { + // Exit child window + ImGuiWindow* child_window = g.NavWindow; + ImGuiWindow* parent_window = g.NavWindow->ParentWindow; + IM_ASSERT(child_window->ChildId != 0); + ImRect child_rect = child_window->Rect(); + FocusWindow(parent_window); + SetNavID(child_window->ChildId, ImGuiNavLayer_Main, 0, ImRect(child_rect.Min - parent_window->Pos, child_rect.Max - parent_window->Pos)); + } + else if (g.OpenPopupStack.Size > 0) + { + // Close open popup/menu + if (!(g.OpenPopupStack.back().Window->Flags & ImGuiWindowFlags_Modal)) + ClosePopupToLevel(g.OpenPopupStack.Size - 1, true); + } + else + { + // Clear NavLastId for popups but keep it for regular child window so we can leave one and come back where we were + if (g.NavWindow && ((g.NavWindow->Flags & ImGuiWindowFlags_Popup) || !(g.NavWindow->Flags & ImGuiWindowFlags_ChildWindow))) + g.NavWindow->NavLastIds[0] = 0; + g.NavId = g.NavFocusScopeId = 0; + } +} + +// Handle PageUp/PageDown/Home/End keys +// Called from NavUpdateCreateMoveRequest() which will use our output to create a move request +// FIXME-NAV: This doesn't work properly with NavFlattened siblings as we use NavWindow rectangle for reference +// FIXME-NAV: how to get Home/End to aim at the beginning/end of a 2D grid? +static float ImGui::NavUpdatePageUpPageDown() +{ + ImGuiContext& g = *GImGui; + ImGuiIO& io = g.IO; + + ImGuiWindow* window = g.NavWindow; + if ((window->Flags & ImGuiWindowFlags_NoNavInputs) || g.NavWindowingTarget != NULL || g.NavLayer != ImGuiNavLayer_Main) + return 0.0f; + + const bool page_up_held = IsKeyDown(io.KeyMap[ImGuiKey_PageUp]) && !IsActiveIdUsingKey(ImGuiKey_PageUp); + const bool page_down_held = IsKeyDown(io.KeyMap[ImGuiKey_PageDown]) && !IsActiveIdUsingKey(ImGuiKey_PageDown); + const bool home_pressed = IsKeyPressed(io.KeyMap[ImGuiKey_Home]) && !IsActiveIdUsingKey(ImGuiKey_Home); + const bool end_pressed = IsKeyPressed(io.KeyMap[ImGuiKey_End]) && !IsActiveIdUsingKey(ImGuiKey_End); + if (page_up_held == page_down_held && home_pressed == end_pressed) // Proceed if either (not both) are pressed, otherwise early out + return 0.0f; + + if (window->DC.NavLayersActiveMask == 0x00 && window->DC.NavHasScroll) + { + // Fallback manual-scroll when window has no navigable item + if (IsKeyPressed(io.KeyMap[ImGuiKey_PageUp], true)) + SetScrollY(window, window->Scroll.y - window->InnerRect.GetHeight()); + else if (IsKeyPressed(io.KeyMap[ImGuiKey_PageDown], true)) + SetScrollY(window, window->Scroll.y + window->InnerRect.GetHeight()); + else if (home_pressed) + SetScrollY(window, 0.0f); + else if (end_pressed) + SetScrollY(window, window->ScrollMax.y); + } + else + { + ImRect& nav_rect_rel = window->NavRectRel[g.NavLayer]; + const float page_offset_y = ImMax(0.0f, window->InnerRect.GetHeight() - window->CalcFontSize() * 1.0f + nav_rect_rel.GetHeight()); + float nav_scoring_rect_offset_y = 0.0f; + if (IsKeyPressed(io.KeyMap[ImGuiKey_PageUp], true)) + { + nav_scoring_rect_offset_y = -page_offset_y; + g.NavMoveDir = ImGuiDir_Down; // Because our scoring rect is offset up, we request the down direction (so we can always land on the last item) + g.NavMoveClipDir = ImGuiDir_Up; + g.NavMoveFlags = ImGuiNavMoveFlags_AllowCurrentNavId | ImGuiNavMoveFlags_AlsoScoreVisibleSet; + } + else if (IsKeyPressed(io.KeyMap[ImGuiKey_PageDown], true)) + { + nav_scoring_rect_offset_y = +page_offset_y; + g.NavMoveDir = ImGuiDir_Up; // Because our scoring rect is offset down, we request the up direction (so we can always land on the last item) + g.NavMoveClipDir = ImGuiDir_Down; + g.NavMoveFlags = ImGuiNavMoveFlags_AllowCurrentNavId | ImGuiNavMoveFlags_AlsoScoreVisibleSet; + } + else if (home_pressed) + { + // FIXME-NAV: handling of Home/End is assuming that the top/bottom most item will be visible with Scroll.y == 0/ScrollMax.y + // Scrolling will be handled via the ImGuiNavMoveFlags_ScrollToEdge flag, we don't scroll immediately to avoid scrolling happening before nav result. + // Preserve current horizontal position if we have any. + nav_rect_rel.Min.y = nav_rect_rel.Max.y = -window->Scroll.y; + if (nav_rect_rel.IsInverted()) + nav_rect_rel.Min.x = nav_rect_rel.Max.x = 0.0f; + g.NavMoveDir = ImGuiDir_Down; + g.NavMoveFlags = ImGuiNavMoveFlags_AllowCurrentNavId | ImGuiNavMoveFlags_ScrollToEdge; + // FIXME-NAV: MoveClipDir left to _None, intentional? + } + else if (end_pressed) + { + nav_rect_rel.Min.y = nav_rect_rel.Max.y = window->ScrollMax.y + window->SizeFull.y - window->Scroll.y; + if (nav_rect_rel.IsInverted()) + nav_rect_rel.Min.x = nav_rect_rel.Max.x = 0.0f; + g.NavMoveDir = ImGuiDir_Up; + g.NavMoveFlags = ImGuiNavMoveFlags_AllowCurrentNavId | ImGuiNavMoveFlags_ScrollToEdge; + // FIXME-NAV: MoveClipDir left to _None, intentional? + } + return nav_scoring_rect_offset_y; + } + return 0.0f; +} + +static void ImGui::NavEndFrame() +{ + ImGuiContext& g = *GImGui; + + // Show CTRL+TAB list window + if (g.NavWindowingTarget != NULL) + NavUpdateWindowingOverlay(); + + // Perform wrap-around in menus + // FIXME-NAV: Wrap (not Loop) support could be handled by the scoring function and then WrapX would function without an extra frame. + ImGuiWindow* window = g.NavWindow; + const ImGuiNavMoveFlags move_flags = g.NavMoveFlags; + const ImGuiNavMoveFlags wanted_flags = ImGuiNavMoveFlags_WrapX | ImGuiNavMoveFlags_LoopX | ImGuiNavMoveFlags_WrapY | ImGuiNavMoveFlags_LoopY; + if (window && NavMoveRequestButNoResultYet() && (g.NavMoveFlags & wanted_flags) && (g.NavMoveFlags & ImGuiNavMoveFlags_Forwarded) == 0) + { + bool do_forward = false; + ImRect bb_rel = window->NavRectRel[g.NavLayer]; + ImGuiDir clip_dir = g.NavMoveDir; + if (g.NavMoveDir == ImGuiDir_Left && (move_flags & (ImGuiNavMoveFlags_WrapX | ImGuiNavMoveFlags_LoopX))) + { + bb_rel.Min.x = bb_rel.Max.x = + ImMax(window->SizeFull.x, window->ContentSize.x + window->WindowPadding.x * 2.0f) - window->Scroll.x; + if (move_flags & ImGuiNavMoveFlags_WrapX) + { + bb_rel.TranslateY(-bb_rel.GetHeight()); + clip_dir = ImGuiDir_Up; + } + do_forward = true; + } + if (g.NavMoveDir == ImGuiDir_Right && (move_flags & (ImGuiNavMoveFlags_WrapX | ImGuiNavMoveFlags_LoopX))) + { + bb_rel.Min.x = bb_rel.Max.x = -window->Scroll.x; + if (move_flags & ImGuiNavMoveFlags_WrapX) + { + bb_rel.TranslateY(+bb_rel.GetHeight()); + clip_dir = ImGuiDir_Down; + } + do_forward = true; + } + if (g.NavMoveDir == ImGuiDir_Up && (move_flags & (ImGuiNavMoveFlags_WrapY | ImGuiNavMoveFlags_LoopY))) + { + bb_rel.Min.y = bb_rel.Max.y = + ImMax(window->SizeFull.y, window->ContentSize.y + window->WindowPadding.y * 2.0f) - window->Scroll.y; + if (move_flags & ImGuiNavMoveFlags_WrapY) + { + bb_rel.TranslateX(-bb_rel.GetWidth()); + clip_dir = ImGuiDir_Left; + } + do_forward = true; + } + if (g.NavMoveDir == ImGuiDir_Down && (move_flags & (ImGuiNavMoveFlags_WrapY | ImGuiNavMoveFlags_LoopY))) + { + bb_rel.Min.y = bb_rel.Max.y = -window->Scroll.y; + if (move_flags & ImGuiNavMoveFlags_WrapY) + { + bb_rel.TranslateX(+bb_rel.GetWidth()); + clip_dir = ImGuiDir_Right; + } + do_forward = true; + } + if (do_forward) + { + window->NavRectRel[g.NavLayer] = bb_rel; + NavMoveRequestForward(g.NavMoveDir, clip_dir, move_flags); + } + } +} + +static int ImGui::FindWindowFocusIndex(ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + IM_UNUSED(g); + int order = window->FocusOrder; + IM_ASSERT(g.WindowsFocusOrder[order] == window); + return order; +} + +static ImGuiWindow* FindWindowNavFocusable(int i_start, int i_stop, int dir) // FIXME-OPT O(N) +{ + ImGuiContext& g = *GImGui; + for (int i = i_start; i >= 0 && i < g.WindowsFocusOrder.Size && i != i_stop; i += dir) + if (ImGui::IsWindowNavFocusable(g.WindowsFocusOrder[i])) + return g.WindowsFocusOrder[i]; + return NULL; +} + +static void NavUpdateWindowingHighlightWindow(int focus_change_dir) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.NavWindowingTarget); + if (g.NavWindowingTarget->Flags & ImGuiWindowFlags_Modal) + return; + + const int i_current = ImGui::FindWindowFocusIndex(g.NavWindowingTarget); + ImGuiWindow* window_target = FindWindowNavFocusable(i_current + focus_change_dir, -INT_MAX, focus_change_dir); + if (!window_target) + window_target = FindWindowNavFocusable((focus_change_dir < 0) ? (g.WindowsFocusOrder.Size - 1) : 0, i_current, focus_change_dir); + if (window_target) // Don't reset windowing target if there's a single window in the list + g.NavWindowingTarget = g.NavWindowingTargetAnim = window_target; + g.NavWindowingToggleLayer = false; +} + +// Windowing management mode +// Keyboard: CTRL+Tab (change focus/move/resize), Alt (toggle menu layer) +// Gamepad: Hold Menu/Square (change focus/move/resize), Tap Menu/Square (toggle menu layer) +static void ImGui::NavUpdateWindowing() +{ + ImGuiContext& g = *GImGui; + ImGuiIO& io = g.IO; + + ImGuiWindow* apply_focus_window = NULL; + bool apply_toggle_layer = false; + + ImGuiWindow* modal_window = GetTopMostPopupModal(); + bool allow_windowing = (modal_window == NULL); + if (!allow_windowing) + g.NavWindowingTarget = NULL; + + // Fade out + if (g.NavWindowingTargetAnim && g.NavWindowingTarget == NULL) + { + g.NavWindowingHighlightAlpha = ImMax(g.NavWindowingHighlightAlpha - io.DeltaTime * 10.0f, 0.0f); + if (g.DimBgRatio <= 0.0f && g.NavWindowingHighlightAlpha <= 0.0f) + g.NavWindowingTargetAnim = NULL; + } + + // Start CTRL-TAB or Square+L/R window selection + bool start_windowing_with_gamepad = allow_windowing && !g.NavWindowingTarget && IsNavInputTest(ImGuiNavInput_Menu, ImGuiInputReadMode_Pressed); + bool start_windowing_with_keyboard = allow_windowing && !g.NavWindowingTarget && io.KeyCtrl && IsKeyPressedMap(ImGuiKey_Tab) && (io.ConfigFlags & ImGuiConfigFlags_NavEnableKeyboard); + if (start_windowing_with_gamepad || start_windowing_with_keyboard) + if (ImGuiWindow* window = g.NavWindow ? g.NavWindow : FindWindowNavFocusable(g.WindowsFocusOrder.Size - 1, -INT_MAX, -1)) + { + g.NavWindowingTarget = g.NavWindowingTargetAnim = window->RootWindow; + g.NavWindowingTimer = g.NavWindowingHighlightAlpha = 0.0f; + g.NavWindowingToggleLayer = start_windowing_with_gamepad ? true : false; // Gamepad starts toggling layer + g.NavInputSource = start_windowing_with_keyboard ? ImGuiInputSource_Keyboard : ImGuiInputSource_Gamepad; + } + + // Gamepad update + g.NavWindowingTimer += io.DeltaTime; + if (g.NavWindowingTarget && g.NavInputSource == ImGuiInputSource_Gamepad) + { + // Highlight only appears after a brief time holding the button, so that a fast tap on PadMenu (to toggle NavLayer) doesn't add visual noise + g.NavWindowingHighlightAlpha = ImMax(g.NavWindowingHighlightAlpha, ImSaturate((g.NavWindowingTimer - NAV_WINDOWING_HIGHLIGHT_DELAY) / 0.05f)); + + // Select window to focus + const int focus_change_dir = (int)IsNavInputTest(ImGuiNavInput_FocusPrev, ImGuiInputReadMode_RepeatSlow) - (int)IsNavInputTest(ImGuiNavInput_FocusNext, ImGuiInputReadMode_RepeatSlow); + if (focus_change_dir != 0) + { + NavUpdateWindowingHighlightWindow(focus_change_dir); + g.NavWindowingHighlightAlpha = 1.0f; + } + + // Single press toggles NavLayer, long press with L/R apply actual focus on release (until then the window was merely rendered top-most) + if (!IsNavInputDown(ImGuiNavInput_Menu)) + { + g.NavWindowingToggleLayer &= (g.NavWindowingHighlightAlpha < 1.0f); // Once button was held long enough we don't consider it a tap-to-toggle-layer press anymore. + if (g.NavWindowingToggleLayer && g.NavWindow) + apply_toggle_layer = true; + else if (!g.NavWindowingToggleLayer) + apply_focus_window = g.NavWindowingTarget; + g.NavWindowingTarget = NULL; + } + } + + // Keyboard: Focus + if (g.NavWindowingTarget && g.NavInputSource == ImGuiInputSource_Keyboard) + { + // Visuals only appears after a brief time after pressing TAB the first time, so that a fast CTRL+TAB doesn't add visual noise + g.NavWindowingHighlightAlpha = ImMax(g.NavWindowingHighlightAlpha, ImSaturate((g.NavWindowingTimer - NAV_WINDOWING_HIGHLIGHT_DELAY) / 0.05f)); // 1.0f + if (IsKeyPressedMap(ImGuiKey_Tab, true)) + NavUpdateWindowingHighlightWindow(io.KeyShift ? +1 : -1); + if (!io.KeyCtrl) + apply_focus_window = g.NavWindowingTarget; + } + + // Keyboard: Press and Release ALT to toggle menu layer + // - Testing that only Alt is tested prevents Alt+Shift or AltGR from toggling menu layer. + // - AltGR is normally Alt+Ctrl but we can't reliably detect it (not all backends/systems/layout emit it as Alt+Ctrl). But even on keyboards without AltGR we don't want Alt+Ctrl to open menu anyway. + if (io.KeyMods == ImGuiKeyModFlags_Alt && (io.KeyModsPrev & ImGuiKeyModFlags_Alt) == 0) + { + g.NavWindowingToggleLayer = true; + g.NavInputSource = ImGuiInputSource_Keyboard; + } + if (g.NavWindowingToggleLayer && g.NavInputSource == ImGuiInputSource_Keyboard) + { + // We cancel toggling nav layer when any text has been typed (generally while holding Alt). (See #370) + // We cancel toggling nav layer when other modifiers are pressed. (See #4439) + if (io.InputQueueCharacters.Size > 0 || io.KeyCtrl || io.KeyShift || io.KeySuper) + g.NavWindowingToggleLayer = false; + + // Apply layer toggle on release + // Important: we don't assume that Alt was previously held in order to handle loss of focus when backend calls io.AddFocusEvent(false) + // Important: as before version <18314 we lacked an explicit IO event for focus gain/loss, we also compare mouse validity to detect old backends clearing mouse pos on focus loss. + if (!(io.KeyMods & ImGuiKeyModFlags_Alt) && (io.KeyModsPrev & ImGuiKeyModFlags_Alt) && g.NavWindowingToggleLayer) + if (g.ActiveId == 0 || g.ActiveIdAllowOverlap) + if (IsMousePosValid(&io.MousePos) == IsMousePosValid(&io.MousePosPrev)) + apply_toggle_layer = true; + if (!io.KeyAlt) + g.NavWindowingToggleLayer = false; + } + + // Move window + if (g.NavWindowingTarget && !(g.NavWindowingTarget->Flags & ImGuiWindowFlags_NoMove)) + { + ImVec2 move_delta; + if (g.NavInputSource == ImGuiInputSource_Keyboard && !io.KeyShift) + move_delta = GetNavInputAmount2d(ImGuiNavDirSourceFlags_Keyboard, ImGuiInputReadMode_Down); + if (g.NavInputSource == ImGuiInputSource_Gamepad) + move_delta = GetNavInputAmount2d(ImGuiNavDirSourceFlags_PadLStick, ImGuiInputReadMode_Down); + if (move_delta.x != 0.0f || move_delta.y != 0.0f) + { + const float NAV_MOVE_SPEED = 800.0f; + const float move_speed = ImFloor(NAV_MOVE_SPEED * io.DeltaTime * ImMin(io.DisplayFramebufferScale.x, io.DisplayFramebufferScale.y)); // FIXME: Doesn't handle variable framerate very well + ImGuiWindow* moving_window = g.NavWindowingTarget->RootWindow; + SetWindowPos(moving_window, moving_window->Pos + move_delta * move_speed, ImGuiCond_Always); + MarkIniSettingsDirty(moving_window); + g.NavDisableMouseHover = true; + } + } + + // Apply final focus + if (apply_focus_window && (g.NavWindow == NULL || apply_focus_window != g.NavWindow->RootWindow)) + { + ClearActiveID(); + g.NavDisableHighlight = false; + g.NavDisableMouseHover = true; + apply_focus_window = NavRestoreLastChildNavWindow(apply_focus_window); + ClosePopupsOverWindow(apply_focus_window, false); + FocusWindow(apply_focus_window); + if (apply_focus_window->NavLastIds[0] == 0) + NavInitWindow(apply_focus_window, false); + + // If the window has ONLY a menu layer (no main layer), select it directly + // Use NavLayersActiveMaskNext since windows didn't have a chance to be Begin()-ed on this frame, + // so CTRL+Tab where the keys are only held for 1 frame will be able to use correct layers mask since + // the target window as already been previewed once. + // FIXME-NAV: This should be done in NavInit.. or in FocusWindow... However in both of those cases, + // we won't have a guarantee that windows has been visible before and therefore NavLayersActiveMask* + // won't be valid. + if (apply_focus_window->DC.NavLayersActiveMaskNext == (1 << ImGuiNavLayer_Menu)) + g.NavLayer = ImGuiNavLayer_Menu; + } + if (apply_focus_window) + g.NavWindowingTarget = NULL; + + // Apply menu/layer toggle + if (apply_toggle_layer && g.NavWindow) + { + ClearActiveID(); + + // Move to parent menu if necessary + ImGuiWindow* new_nav_window = g.NavWindow; + while (new_nav_window->ParentWindow + && (new_nav_window->DC.NavLayersActiveMask & (1 << ImGuiNavLayer_Menu)) == 0 + && (new_nav_window->Flags & ImGuiWindowFlags_ChildWindow) != 0 + && (new_nav_window->Flags & (ImGuiWindowFlags_Popup | ImGuiWindowFlags_ChildMenu)) == 0) + new_nav_window = new_nav_window->ParentWindow; + if (new_nav_window != g.NavWindow) + { + ImGuiWindow* old_nav_window = g.NavWindow; + FocusWindow(new_nav_window); + new_nav_window->NavLastChildNavWindow = old_nav_window; + } + + // Toggle layer + const ImGuiNavLayer new_nav_layer = (g.NavWindow->DC.NavLayersActiveMask & (1 << ImGuiNavLayer_Menu)) ? (ImGuiNavLayer)((int)g.NavLayer ^ 1) : ImGuiNavLayer_Main; + if (new_nav_layer != g.NavLayer) + { + // Reinitialize navigation when entering menu bar with the Alt key (FIXME: could be a properly of the layer?) + if (new_nav_layer == ImGuiNavLayer_Menu) + g.NavWindow->NavLastIds[new_nav_layer] = 0; + NavRestoreLayer(new_nav_layer); + } + } +} + +// Window has already passed the IsWindowNavFocusable() +static const char* GetFallbackWindowNameForWindowingList(ImGuiWindow* window) +{ + if (window->Flags & ImGuiWindowFlags_Popup) + return "(Popup)"; + if ((window->Flags & ImGuiWindowFlags_MenuBar) && strcmp(window->Name, "##MainMenuBar") == 0) + return "(Main menu bar)"; + return "(Untitled)"; +} + +// Overlay displayed when using CTRL+TAB. Called by EndFrame(). +void ImGui::NavUpdateWindowingOverlay() +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.NavWindowingTarget != NULL); + + if (g.NavWindowingTimer < NAV_WINDOWING_LIST_APPEAR_DELAY) + return; + + if (g.NavWindowingListWindow == NULL) + g.NavWindowingListWindow = FindWindowByName("###NavWindowingList"); + const ImGuiViewport* viewport = GetMainViewport(); + SetNextWindowSizeConstraints(ImVec2(viewport->Size.x * 0.20f, viewport->Size.y * 0.20f), ImVec2(FLT_MAX, FLT_MAX)); + SetNextWindowPos(viewport->GetCenter(), ImGuiCond_Always, ImVec2(0.5f, 0.5f)); + PushStyleVar(ImGuiStyleVar_WindowPadding, g.Style.WindowPadding * 2.0f); + Begin("###NavWindowingList", NULL, ImGuiWindowFlags_NoTitleBar | ImGuiWindowFlags_NoFocusOnAppearing | ImGuiWindowFlags_NoResize | ImGuiWindowFlags_NoMove | ImGuiWindowFlags_NoInputs | ImGuiWindowFlags_AlwaysAutoResize | ImGuiWindowFlags_NoSavedSettings); + for (int n = g.WindowsFocusOrder.Size - 1; n >= 0; n--) + { + ImGuiWindow* window = g.WindowsFocusOrder[n]; + IM_ASSERT(window != NULL); // Fix static analyzers + if (!IsWindowNavFocusable(window)) + continue; + const char* label = window->Name; + if (label == FindRenderedTextEnd(label)) + label = GetFallbackWindowNameForWindowingList(window); + Selectable(label, g.NavWindowingTarget == window); + } + End(); + PopStyleVar(); +} + + +//----------------------------------------------------------------------------- +// [SECTION] DRAG AND DROP +//----------------------------------------------------------------------------- + +void ImGui::ClearDragDrop() +{ + ImGuiContext& g = *GImGui; + g.DragDropActive = false; + g.DragDropPayload.Clear(); + g.DragDropAcceptFlags = ImGuiDragDropFlags_None; + g.DragDropAcceptIdCurr = g.DragDropAcceptIdPrev = 0; + g.DragDropAcceptIdCurrRectSurface = FLT_MAX; + g.DragDropAcceptFrameCount = -1; + + g.DragDropPayloadBufHeap.clear(); + memset(&g.DragDropPayloadBufLocal, 0, sizeof(g.DragDropPayloadBufLocal)); +} + +// When this returns true you need to: a) call SetDragDropPayload() exactly once, b) you may render the payload visual/description, c) call EndDragDropSource() +// If the item has an identifier: +// - This assume/require the item to be activated (typically via ButtonBehavior). +// - Therefore if you want to use this with a mouse button other than left mouse button, it is up to the item itself to activate with another button. +// - We then pull and use the mouse button that was used to activate the item and use it to carry on the drag. +// If the item has no identifier: +// - Currently always assume left mouse button. +bool ImGui::BeginDragDropSource(ImGuiDragDropFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + // FIXME-DRAGDROP: While in the common-most "drag from non-zero active id" case we can tell the mouse button, + // in both SourceExtern and id==0 cases we may requires something else (explicit flags or some heuristic). + ImGuiMouseButton mouse_button = ImGuiMouseButton_Left; + + bool source_drag_active = false; + ImGuiID source_id = 0; + ImGuiID source_parent_id = 0; + if (!(flags & ImGuiDragDropFlags_SourceExtern)) + { + source_id = g.LastItemData.ID; + if (source_id != 0) + { + // Common path: items with ID + if (g.ActiveId != source_id) + return false; + if (g.ActiveIdMouseButton != -1) + mouse_button = g.ActiveIdMouseButton; + if (g.IO.MouseDown[mouse_button] == false || window->SkipItems) + return false; + g.ActiveIdAllowOverlap = false; + } + else + { + // Uncommon path: items without ID + if (g.IO.MouseDown[mouse_button] == false || window->SkipItems) + return false; + if ((g.LastItemData.StatusFlags & ImGuiItemStatusFlags_HoveredRect) == 0 && (g.ActiveId == 0 || g.ActiveIdWindow != window)) + return false; + + // If you want to use BeginDragDropSource() on an item with no unique identifier for interaction, such as Text() or Image(), you need to: + // A) Read the explanation below, B) Use the ImGuiDragDropFlags_SourceAllowNullID flag, C) Swallow your programmer pride. + if (!(flags & ImGuiDragDropFlags_SourceAllowNullID)) + { + IM_ASSERT(0); + return false; + } + + // Magic fallback (=somehow reprehensible) to handle items with no assigned ID, e.g. Text(), Image() + // We build a throwaway ID based on current ID stack + relative AABB of items in window. + // THE IDENTIFIER WON'T SURVIVE ANY REPOSITIONING OF THE WIDGET, so if your widget moves your dragging operation will be canceled. + // We don't need to maintain/call ClearActiveID() as releasing the button will early out this function and trigger !ActiveIdIsAlive. + // Rely on keeping other window->LastItemXXX fields intact. + source_id = g.LastItemData.ID = window->GetIDFromRectangle(g.LastItemData.Rect); + bool is_hovered = ItemHoverable(g.LastItemData.Rect, source_id); + if (is_hovered && g.IO.MouseClicked[mouse_button]) + { + SetActiveID(source_id, window); + FocusWindow(window); + } + if (g.ActiveId == source_id) // Allow the underlying widget to display/return hovered during the mouse release frame, else we would get a flicker. + g.ActiveIdAllowOverlap = is_hovered; + } + if (g.ActiveId != source_id) + return false; + source_parent_id = window->IDStack.back(); + source_drag_active = IsMouseDragging(mouse_button); + + // Disable navigation and key inputs while dragging + cancel existing request if any + SetActiveIdUsingNavAndKeys(); + } + else + { + window = NULL; + source_id = ImHashStr("#SourceExtern"); + source_drag_active = true; + } + + if (source_drag_active) + { + if (!g.DragDropActive) + { + IM_ASSERT(source_id != 0); + ClearDragDrop(); + ImGuiPayload& payload = g.DragDropPayload; + payload.SourceId = source_id; + payload.SourceParentId = source_parent_id; + g.DragDropActive = true; + g.DragDropSourceFlags = flags; + g.DragDropMouseButton = mouse_button; + if (payload.SourceId == g.ActiveId) + g.ActiveIdNoClearOnFocusLoss = true; + } + g.DragDropSourceFrameCount = g.FrameCount; + g.DragDropWithinSource = true; + + if (!(flags & ImGuiDragDropFlags_SourceNoPreviewTooltip)) + { + // Target can request the Source to not display its tooltip (we use a dedicated flag to make this request explicit) + // We unfortunately can't just modify the source flags and skip the call to BeginTooltip, as caller may be emitting contents. + BeginTooltip(); + if (g.DragDropAcceptIdPrev && (g.DragDropAcceptFlags & ImGuiDragDropFlags_AcceptNoPreviewTooltip)) + { + ImGuiWindow* tooltip_window = g.CurrentWindow; + tooltip_window->Hidden = tooltip_window->SkipItems = true; + tooltip_window->HiddenFramesCanSkipItems = 1; + } + } + + if (!(flags & ImGuiDragDropFlags_SourceNoDisableHover) && !(flags & ImGuiDragDropFlags_SourceExtern)) + g.LastItemData.StatusFlags &= ~ImGuiItemStatusFlags_HoveredRect; + + return true; + } + return false; +} + +void ImGui::EndDragDropSource() +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.DragDropActive); + IM_ASSERT(g.DragDropWithinSource && "Not after a BeginDragDropSource()?"); + + if (!(g.DragDropSourceFlags & ImGuiDragDropFlags_SourceNoPreviewTooltip)) + EndTooltip(); + + // Discard the drag if have not called SetDragDropPayload() + if (g.DragDropPayload.DataFrameCount == -1) + ClearDragDrop(); + g.DragDropWithinSource = false; +} + +// Use 'cond' to choose to submit payload on drag start or every frame +bool ImGui::SetDragDropPayload(const char* type, const void* data, size_t data_size, ImGuiCond cond) +{ + ImGuiContext& g = *GImGui; + ImGuiPayload& payload = g.DragDropPayload; + if (cond == 0) + cond = ImGuiCond_Always; + + IM_ASSERT(type != NULL); + IM_ASSERT(strlen(type) < IM_ARRAYSIZE(payload.DataType) && "Payload type can be at most 32 characters long"); + IM_ASSERT((data != NULL && data_size > 0) || (data == NULL && data_size == 0)); + IM_ASSERT(cond == ImGuiCond_Always || cond == ImGuiCond_Once); + IM_ASSERT(payload.SourceId != 0); // Not called between BeginDragDropSource() and EndDragDropSource() + + if (cond == ImGuiCond_Always || payload.DataFrameCount == -1) + { + // Copy payload + ImStrncpy(payload.DataType, type, IM_ARRAYSIZE(payload.DataType)); + g.DragDropPayloadBufHeap.resize(0); + if (data_size > sizeof(g.DragDropPayloadBufLocal)) + { + // Store in heap + g.DragDropPayloadBufHeap.resize((int)data_size); + payload.Data = g.DragDropPayloadBufHeap.Data; + memcpy(payload.Data, data, data_size); + } + else if (data_size > 0) + { + // Store locally + memset(&g.DragDropPayloadBufLocal, 0, sizeof(g.DragDropPayloadBufLocal)); + payload.Data = g.DragDropPayloadBufLocal; + memcpy(payload.Data, data, data_size); + } + else + { + payload.Data = NULL; + } + payload.DataSize = (int)data_size; + } + payload.DataFrameCount = g.FrameCount; + + return (g.DragDropAcceptFrameCount == g.FrameCount) || (g.DragDropAcceptFrameCount == g.FrameCount - 1); +} + +bool ImGui::BeginDragDropTargetCustom(const ImRect& bb, ImGuiID id) +{ + ImGuiContext& g = *GImGui; + if (!g.DragDropActive) + return false; + + ImGuiWindow* window = g.CurrentWindow; + ImGuiWindow* hovered_window = g.HoveredWindowUnderMovingWindow; + if (hovered_window == NULL || window->RootWindow != hovered_window->RootWindow) + return false; + IM_ASSERT(id != 0); + if (!IsMouseHoveringRect(bb.Min, bb.Max) || (id == g.DragDropPayload.SourceId)) + return false; + if (window->SkipItems) + return false; + + IM_ASSERT(g.DragDropWithinTarget == false); + g.DragDropTargetRect = bb; + g.DragDropTargetId = id; + g.DragDropWithinTarget = true; + return true; +} + +// We don't use BeginDragDropTargetCustom() and duplicate its code because: +// 1) we use LastItemRectHoveredRect which handles items that pushes a temporarily clip rectangle in their code. Calling BeginDragDropTargetCustom(LastItemRect) would not handle them. +// 2) and it's faster. as this code may be very frequently called, we want to early out as fast as we can. +// Also note how the HoveredWindow test is positioned differently in both functions (in both functions we optimize for the cheapest early out case) +bool ImGui::BeginDragDropTarget() +{ + ImGuiContext& g = *GImGui; + if (!g.DragDropActive) + return false; + + ImGuiWindow* window = g.CurrentWindow; + if (!(g.LastItemData.StatusFlags & ImGuiItemStatusFlags_HoveredRect)) + return false; + ImGuiWindow* hovered_window = g.HoveredWindowUnderMovingWindow; + if (hovered_window == NULL || window->RootWindow != hovered_window->RootWindow || window->SkipItems) + return false; + + const ImRect& display_rect = (g.LastItemData.StatusFlags & ImGuiItemStatusFlags_HasDisplayRect) ? g.LastItemData.DisplayRect : g.LastItemData.Rect; + ImGuiID id = g.LastItemData.ID; + if (id == 0) + id = window->GetIDFromRectangle(display_rect); + if (g.DragDropPayload.SourceId == id) + return false; + + IM_ASSERT(g.DragDropWithinTarget == false); + g.DragDropTargetRect = display_rect; + g.DragDropTargetId = id; + g.DragDropWithinTarget = true; + return true; +} + +bool ImGui::IsDragDropPayloadBeingAccepted() +{ + ImGuiContext& g = *GImGui; + return g.DragDropActive && g.DragDropAcceptIdPrev != 0; +} + +const ImGuiPayload* ImGui::AcceptDragDropPayload(const char* type, ImGuiDragDropFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImGuiPayload& payload = g.DragDropPayload; + IM_ASSERT(g.DragDropActive); // Not called between BeginDragDropTarget() and EndDragDropTarget() ? + IM_ASSERT(payload.DataFrameCount != -1); // Forgot to call EndDragDropTarget() ? + if (type != NULL && !payload.IsDataType(type)) + return NULL; + + // Accept smallest drag target bounding box, this allows us to nest drag targets conveniently without ordering constraints. + // NB: We currently accept NULL id as target. However, overlapping targets requires a unique ID to function! + const bool was_accepted_previously = (g.DragDropAcceptIdPrev == g.DragDropTargetId); + ImRect r = g.DragDropTargetRect; + float r_surface = r.GetWidth() * r.GetHeight(); + if (r_surface <= g.DragDropAcceptIdCurrRectSurface) + { + g.DragDropAcceptFlags = flags; + g.DragDropAcceptIdCurr = g.DragDropTargetId; + g.DragDropAcceptIdCurrRectSurface = r_surface; + } + + // Render default drop visuals + // FIXME-DRAGDROP: Settle on a proper default visuals for drop target. + payload.Preview = was_accepted_previously; + flags |= (g.DragDropSourceFlags & ImGuiDragDropFlags_AcceptNoDrawDefaultRect); // Source can also inhibit the preview (useful for external sources that lives for 1 frame) + if (!(flags & ImGuiDragDropFlags_AcceptNoDrawDefaultRect) && payload.Preview) + window->DrawList->AddRect(r.Min - ImVec2(3.5f,3.5f), r.Max + ImVec2(3.5f, 3.5f), GetColorU32(ImGuiCol_DragDropTarget), 0.0f, 0, 2.0f); + + g.DragDropAcceptFrameCount = g.FrameCount; + payload.Delivery = was_accepted_previously && !IsMouseDown(g.DragDropMouseButton); // For extern drag sources affecting os window focus, it's easier to just test !IsMouseDown() instead of IsMouseReleased() + if (!payload.Delivery && !(flags & ImGuiDragDropFlags_AcceptBeforeDelivery)) + return NULL; + + return &payload; +} + +const ImGuiPayload* ImGui::GetDragDropPayload() +{ + ImGuiContext& g = *GImGui; + return g.DragDropActive ? &g.DragDropPayload : NULL; +} + +// We don't really use/need this now, but added it for the sake of consistency and because we might need it later. +void ImGui::EndDragDropTarget() +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.DragDropActive); + IM_ASSERT(g.DragDropWithinTarget); + g.DragDropWithinTarget = false; +} + +//----------------------------------------------------------------------------- +// [SECTION] LOGGING/CAPTURING +//----------------------------------------------------------------------------- +// All text output from the interface can be captured into tty/file/clipboard. +// By default, tree nodes are automatically opened during logging. +//----------------------------------------------------------------------------- + +// Pass text data straight to log (without being displayed) +static inline void LogTextV(ImGuiContext& g, const char* fmt, va_list args) +{ + if (g.LogFile) + { + g.LogBuffer.Buf.resize(0); + g.LogBuffer.appendfv(fmt, args); + ImFileWrite(g.LogBuffer.c_str(), sizeof(char), (ImU64)g.LogBuffer.size(), g.LogFile); + } + else + { + g.LogBuffer.appendfv(fmt, args); + } +} + +void ImGui::LogText(const char* fmt, ...) +{ + ImGuiContext& g = *GImGui; + if (!g.LogEnabled) + return; + + va_list args; + va_start(args, fmt); + LogTextV(g, fmt, args); + va_end(args); +} + +void ImGui::LogTextV(const char* fmt, va_list args) +{ + ImGuiContext& g = *GImGui; + if (!g.LogEnabled) + return; + + LogTextV(g, fmt, args); +} + +// Internal version that takes a position to decide on newline placement and pad items according to their depth. +// We split text into individual lines to add current tree level padding +// FIXME: This code is a little complicated perhaps, considering simplifying the whole system. +void ImGui::LogRenderedText(const ImVec2* ref_pos, const char* text, const char* text_end) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + const char* prefix = g.LogNextPrefix; + const char* suffix = g.LogNextSuffix; + g.LogNextPrefix = g.LogNextSuffix = NULL; + + if (!text_end) + text_end = FindRenderedTextEnd(text, text_end); + + const bool log_new_line = ref_pos && (ref_pos->y > g.LogLinePosY + g.Style.FramePadding.y + 1); + if (ref_pos) + g.LogLinePosY = ref_pos->y; + if (log_new_line) + { + LogText(IM_NEWLINE); + g.LogLineFirstItem = true; + } + + if (prefix) + LogRenderedText(ref_pos, prefix, prefix + strlen(prefix)); // Calculate end ourself to ensure "##" are included here. + + // Re-adjust padding if we have popped out of our starting depth + if (g.LogDepthRef > window->DC.TreeDepth) + g.LogDepthRef = window->DC.TreeDepth; + const int tree_depth = (window->DC.TreeDepth - g.LogDepthRef); + + const char* text_remaining = text; + for (;;) + { + // Split the string. Each new line (after a '\n') is followed by indentation corresponding to the current depth of our log entry. + // We don't add a trailing \n yet to allow a subsequent item on the same line to be captured. + const char* line_start = text_remaining; + const char* line_end = ImStreolRange(line_start, text_end); + const bool is_last_line = (line_end == text_end); + if (line_start != line_end || !is_last_line) + { + const int line_length = (int)(line_end - line_start); + const int indentation = g.LogLineFirstItem ? tree_depth * 4 : 1; + LogText("%*s%.*s", indentation, "", line_length, line_start); + g.LogLineFirstItem = false; + if (*line_end == '\n') + { + LogText(IM_NEWLINE); + g.LogLineFirstItem = true; + } + } + if (is_last_line) + break; + text_remaining = line_end + 1; + } + + if (suffix) + LogRenderedText(ref_pos, suffix, suffix + strlen(suffix)); +} + +// Start logging/capturing text output +void ImGui::LogBegin(ImGuiLogType type, int auto_open_depth) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + IM_ASSERT(g.LogEnabled == false); + IM_ASSERT(g.LogFile == NULL); + IM_ASSERT(g.LogBuffer.empty()); + g.LogEnabled = true; + g.LogType = type; + g.LogNextPrefix = g.LogNextSuffix = NULL; + g.LogDepthRef = window->DC.TreeDepth; + g.LogDepthToExpand = ((auto_open_depth >= 0) ? auto_open_depth : g.LogDepthToExpandDefault); + g.LogLinePosY = FLT_MAX; + g.LogLineFirstItem = true; +} + +// Important: doesn't copy underlying data, use carefully (prefix/suffix must be in scope at the time of the next LogRenderedText) +void ImGui::LogSetNextTextDecoration(const char* prefix, const char* suffix) +{ + ImGuiContext& g = *GImGui; + g.LogNextPrefix = prefix; + g.LogNextSuffix = suffix; +} + +void ImGui::LogToTTY(int auto_open_depth) +{ + ImGuiContext& g = *GImGui; + if (g.LogEnabled) + return; + IM_UNUSED(auto_open_depth); +#ifndef IMGUI_DISABLE_TTY_FUNCTIONS + LogBegin(ImGuiLogType_TTY, auto_open_depth); + g.LogFile = stdout; +#endif +} + +// Start logging/capturing text output to given file +void ImGui::LogToFile(int auto_open_depth, const char* filename) +{ + ImGuiContext& g = *GImGui; + if (g.LogEnabled) + return; + + // FIXME: We could probably open the file in text mode "at", however note that clipboard/buffer logging will still + // be subject to outputting OS-incompatible carriage return if within strings the user doesn't use IM_NEWLINE. + // By opening the file in binary mode "ab" we have consistent output everywhere. + if (!filename) + filename = g.IO.LogFilename; + if (!filename || !filename[0]) + return; + ImFileHandle f = ImFileOpen(filename, "ab"); + if (!f) + { + IM_ASSERT(0); + return; + } + + LogBegin(ImGuiLogType_File, auto_open_depth); + g.LogFile = f; +} + +// Start logging/capturing text output to clipboard +void ImGui::LogToClipboard(int auto_open_depth) +{ + ImGuiContext& g = *GImGui; + if (g.LogEnabled) + return; + LogBegin(ImGuiLogType_Clipboard, auto_open_depth); +} + +void ImGui::LogToBuffer(int auto_open_depth) +{ + ImGuiContext& g = *GImGui; + if (g.LogEnabled) + return; + LogBegin(ImGuiLogType_Buffer, auto_open_depth); +} + +void ImGui::LogFinish() +{ + ImGuiContext& g = *GImGui; + if (!g.LogEnabled) + return; + + LogText(IM_NEWLINE); + switch (g.LogType) + { + case ImGuiLogType_TTY: +#ifndef IMGUI_DISABLE_TTY_FUNCTIONS + fflush(g.LogFile); +#endif + break; + case ImGuiLogType_File: + ImFileClose(g.LogFile); + break; + case ImGuiLogType_Buffer: + break; + case ImGuiLogType_Clipboard: + if (!g.LogBuffer.empty()) + SetClipboardText(g.LogBuffer.begin()); + break; + case ImGuiLogType_None: + IM_ASSERT(0); + break; + } + + g.LogEnabled = false; + g.LogType = ImGuiLogType_None; + g.LogFile = NULL; + g.LogBuffer.clear(); +} + +// Helper to display logging buttons +// FIXME-OBSOLETE: We should probably obsolete this and let the user have their own helper (this is one of the oldest function alive!) +void ImGui::LogButtons() +{ + ImGuiContext& g = *GImGui; + + PushID("LogButtons"); +#ifndef IMGUI_DISABLE_TTY_FUNCTIONS + const bool log_to_tty = Button("Log To TTY"); SameLine(); +#else + const bool log_to_tty = false; +#endif + const bool log_to_file = Button("Log To File"); SameLine(); + const bool log_to_clipboard = Button("Log To Clipboard"); SameLine(); + PushAllowKeyboardFocus(false); + SetNextItemWidth(80.0f); + SliderInt("Default Depth", &g.LogDepthToExpandDefault, 0, 9, NULL); + PopAllowKeyboardFocus(); + PopID(); + + // Start logging at the end of the function so that the buttons don't appear in the log + if (log_to_tty) + LogToTTY(); + if (log_to_file) + LogToFile(); + if (log_to_clipboard) + LogToClipboard(); +} + + +//----------------------------------------------------------------------------- +// [SECTION] SETTINGS +//----------------------------------------------------------------------------- +// - UpdateSettings() [Internal] +// - MarkIniSettingsDirty() [Internal] +// - CreateNewWindowSettings() [Internal] +// - FindWindowSettings() [Internal] +// - FindOrCreateWindowSettings() [Internal] +// - FindSettingsHandler() [Internal] +// - ClearIniSettings() [Internal] +// - LoadIniSettingsFromDisk() +// - LoadIniSettingsFromMemory() +// - SaveIniSettingsToDisk() +// - SaveIniSettingsToMemory() +// - WindowSettingsHandler_***() [Internal] +//----------------------------------------------------------------------------- + +// Called by NewFrame() +void ImGui::UpdateSettings() +{ + // Load settings on first frame (if not explicitly loaded manually before) + ImGuiContext& g = *GImGui; + if (!g.SettingsLoaded) + { + IM_ASSERT(g.SettingsWindows.empty()); + if (g.IO.IniFilename) + LoadIniSettingsFromDisk(g.IO.IniFilename); + g.SettingsLoaded = true; + } + + // Save settings (with a delay after the last modification, so we don't spam disk too much) + if (g.SettingsDirtyTimer > 0.0f) + { + g.SettingsDirtyTimer -= g.IO.DeltaTime; + if (g.SettingsDirtyTimer <= 0.0f) + { + if (g.IO.IniFilename != NULL) + SaveIniSettingsToDisk(g.IO.IniFilename); + else + g.IO.WantSaveIniSettings = true; // Let user know they can call SaveIniSettingsToMemory(). user will need to clear io.WantSaveIniSettings themselves. + g.SettingsDirtyTimer = 0.0f; + } + } +} + +void ImGui::MarkIniSettingsDirty() +{ + ImGuiContext& g = *GImGui; + if (g.SettingsDirtyTimer <= 0.0f) + g.SettingsDirtyTimer = g.IO.IniSavingRate; +} + +void ImGui::MarkIniSettingsDirty(ImGuiWindow* window) +{ + ImGuiContext& g = *GImGui; + if (!(window->Flags & ImGuiWindowFlags_NoSavedSettings)) + if (g.SettingsDirtyTimer <= 0.0f) + g.SettingsDirtyTimer = g.IO.IniSavingRate; +} + +ImGuiWindowSettings* ImGui::CreateNewWindowSettings(const char* name) +{ + ImGuiContext& g = *GImGui; + +#if !IMGUI_DEBUG_INI_SETTINGS + // Skip to the "###" marker if any. We don't skip past to match the behavior of GetID() + // Preserve the full string when IMGUI_DEBUG_INI_SETTINGS is set to make .ini inspection easier. + if (const char* p = strstr(name, "###")) + name = p; +#endif + const size_t name_len = strlen(name); + + // Allocate chunk + const size_t chunk_size = sizeof(ImGuiWindowSettings) + name_len + 1; + ImGuiWindowSettings* settings = g.SettingsWindows.alloc_chunk(chunk_size); + IM_PLACEMENT_NEW(settings) ImGuiWindowSettings(); + settings->ID = ImHashStr(name, name_len); + memcpy(settings->GetName(), name, name_len + 1); // Store with zero terminator + + return settings; +} + +ImGuiWindowSettings* ImGui::FindWindowSettings(ImGuiID id) +{ + ImGuiContext& g = *GImGui; + for (ImGuiWindowSettings* settings = g.SettingsWindows.begin(); settings != NULL; settings = g.SettingsWindows.next_chunk(settings)) + if (settings->ID == id) + return settings; + return NULL; +} + +ImGuiWindowSettings* ImGui::FindOrCreateWindowSettings(const char* name) +{ + if (ImGuiWindowSettings* settings = FindWindowSettings(ImHashStr(name))) + return settings; + return CreateNewWindowSettings(name); +} + +ImGuiSettingsHandler* ImGui::FindSettingsHandler(const char* type_name) +{ + ImGuiContext& g = *GImGui; + const ImGuiID type_hash = ImHashStr(type_name); + for (int handler_n = 0; handler_n < g.SettingsHandlers.Size; handler_n++) + if (g.SettingsHandlers[handler_n].TypeHash == type_hash) + return &g.SettingsHandlers[handler_n]; + return NULL; +} + +void ImGui::ClearIniSettings() +{ + ImGuiContext& g = *GImGui; + g.SettingsIniData.clear(); + for (int handler_n = 0; handler_n < g.SettingsHandlers.Size; handler_n++) + if (g.SettingsHandlers[handler_n].ClearAllFn) + g.SettingsHandlers[handler_n].ClearAllFn(&g, &g.SettingsHandlers[handler_n]); +} + +void ImGui::LoadIniSettingsFromDisk(const char* ini_filename) +{ + size_t file_data_size = 0; + char* file_data = (char*)ImFileLoadToMemory(ini_filename, "rb", &file_data_size); + if (!file_data) + return; + LoadIniSettingsFromMemory(file_data, (size_t)file_data_size); + IM_FREE(file_data); +} + +// Zero-tolerance, no error reporting, cheap .ini parsing +void ImGui::LoadIniSettingsFromMemory(const char* ini_data, size_t ini_size) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.Initialized); + //IM_ASSERT(!g.WithinFrameScope && "Cannot be called between NewFrame() and EndFrame()"); + //IM_ASSERT(g.SettingsLoaded == false && g.FrameCount == 0); + + // For user convenience, we allow passing a non zero-terminated string (hence the ini_size parameter). + // For our convenience and to make the code simpler, we'll also write zero-terminators within the buffer. So let's create a writable copy.. + if (ini_size == 0) + ini_size = strlen(ini_data); + g.SettingsIniData.Buf.resize((int)ini_size + 1); + char* const buf = g.SettingsIniData.Buf.Data; + char* const buf_end = buf + ini_size; + memcpy(buf, ini_data, ini_size); + buf_end[0] = 0; + + // Call pre-read handlers + // Some types will clear their data (e.g. dock information) some types will allow merge/override (window) + for (int handler_n = 0; handler_n < g.SettingsHandlers.Size; handler_n++) + if (g.SettingsHandlers[handler_n].ReadInitFn) + g.SettingsHandlers[handler_n].ReadInitFn(&g, &g.SettingsHandlers[handler_n]); + + void* entry_data = NULL; + ImGuiSettingsHandler* entry_handler = NULL; + + char* line_end = NULL; + for (char* line = buf; line < buf_end; line = line_end + 1) + { + // Skip new lines markers, then find end of the line + while (*line == '\n' || *line == '\r') + line++; + line_end = line; + while (line_end < buf_end && *line_end != '\n' && *line_end != '\r') + line_end++; + line_end[0] = 0; + if (line[0] == ';') + continue; + if (line[0] == '[' && line_end > line && line_end[-1] == ']') + { + // Parse "[Type][Name]". Note that 'Name' can itself contains [] characters, which is acceptable with the current format and parsing code. + line_end[-1] = 0; + const char* name_end = line_end - 1; + const char* type_start = line + 1; + char* type_end = (char*)(void*)ImStrchrRange(type_start, name_end, ']'); + const char* name_start = type_end ? ImStrchrRange(type_end + 1, name_end, '[') : NULL; + if (!type_end || !name_start) + continue; + *type_end = 0; // Overwrite first ']' + name_start++; // Skip second '[' + entry_handler = FindSettingsHandler(type_start); + entry_data = entry_handler ? entry_handler->ReadOpenFn(&g, entry_handler, name_start) : NULL; + } + else if (entry_handler != NULL && entry_data != NULL) + { + // Let type handler parse the line + entry_handler->ReadLineFn(&g, entry_handler, entry_data, line); + } + } + g.SettingsLoaded = true; + + // [DEBUG] Restore untouched copy so it can be browsed in Metrics (not strictly necessary) + memcpy(buf, ini_data, ini_size); + + // Call post-read handlers + for (int handler_n = 0; handler_n < g.SettingsHandlers.Size; handler_n++) + if (g.SettingsHandlers[handler_n].ApplyAllFn) + g.SettingsHandlers[handler_n].ApplyAllFn(&g, &g.SettingsHandlers[handler_n]); +} + +void ImGui::SaveIniSettingsToDisk(const char* ini_filename) +{ + ImGuiContext& g = *GImGui; + g.SettingsDirtyTimer = 0.0f; + if (!ini_filename) + return; + + size_t ini_data_size = 0; + const char* ini_data = SaveIniSettingsToMemory(&ini_data_size); + ImFileHandle f = ImFileOpen(ini_filename, "wt"); + if (!f) + return; + ImFileWrite(ini_data, sizeof(char), ini_data_size, f); + ImFileClose(f); +} + +// Call registered handlers (e.g. SettingsHandlerWindow_WriteAll() + custom handlers) to write their stuff into a text buffer +const char* ImGui::SaveIniSettingsToMemory(size_t* out_size) +{ + ImGuiContext& g = *GImGui; + g.SettingsDirtyTimer = 0.0f; + g.SettingsIniData.Buf.resize(0); + g.SettingsIniData.Buf.push_back(0); + for (int handler_n = 0; handler_n < g.SettingsHandlers.Size; handler_n++) + { + ImGuiSettingsHandler* handler = &g.SettingsHandlers[handler_n]; + handler->WriteAllFn(&g, handler, &g.SettingsIniData); + } + if (out_size) + *out_size = (size_t)g.SettingsIniData.size(); + return g.SettingsIniData.c_str(); +} + +static void WindowSettingsHandler_ClearAll(ImGuiContext* ctx, ImGuiSettingsHandler*) +{ + ImGuiContext& g = *ctx; + for (int i = 0; i != g.Windows.Size; i++) + g.Windows[i]->SettingsOffset = -1; + g.SettingsWindows.clear(); +} + +static void* WindowSettingsHandler_ReadOpen(ImGuiContext*, ImGuiSettingsHandler*, const char* name) +{ + ImGuiWindowSettings* settings = ImGui::FindOrCreateWindowSettings(name); + ImGuiID id = settings->ID; + *settings = ImGuiWindowSettings(); // Clear existing if recycling previous entry + settings->ID = id; + settings->WantApply = true; + return (void*)settings; +} + +static void WindowSettingsHandler_ReadLine(ImGuiContext*, ImGuiSettingsHandler*, void* entry, const char* line) +{ + ImGuiWindowSettings* settings = (ImGuiWindowSettings*)entry; + int x, y; + int i; + if (sscanf(line, "Pos=%i,%i", &x, &y) == 2) { settings->Pos = ImVec2ih((short)x, (short)y); } + else if (sscanf(line, "Size=%i,%i", &x, &y) == 2) { settings->Size = ImVec2ih((short)x, (short)y); } + else if (sscanf(line, "Collapsed=%d", &i) == 1) { settings->Collapsed = (i != 0); } +} + +// Apply to existing windows (if any) +static void WindowSettingsHandler_ApplyAll(ImGuiContext* ctx, ImGuiSettingsHandler*) +{ + ImGuiContext& g = *ctx; + for (ImGuiWindowSettings* settings = g.SettingsWindows.begin(); settings != NULL; settings = g.SettingsWindows.next_chunk(settings)) + if (settings->WantApply) + { + if (ImGuiWindow* window = ImGui::FindWindowByID(settings->ID)) + ApplyWindowSettings(window, settings); + settings->WantApply = false; + } +} + +static void WindowSettingsHandler_WriteAll(ImGuiContext* ctx, ImGuiSettingsHandler* handler, ImGuiTextBuffer* buf) +{ + // Gather data from windows that were active during this session + // (if a window wasn't opened in this session we preserve its settings) + ImGuiContext& g = *ctx; + for (int i = 0; i != g.Windows.Size; i++) + { + ImGuiWindow* window = g.Windows[i]; + if (window->Flags & ImGuiWindowFlags_NoSavedSettings) + continue; + + ImGuiWindowSettings* settings = (window->SettingsOffset != -1) ? g.SettingsWindows.ptr_from_offset(window->SettingsOffset) : ImGui::FindWindowSettings(window->ID); + if (!settings) + { + settings = ImGui::CreateNewWindowSettings(window->Name); + window->SettingsOffset = g.SettingsWindows.offset_from_ptr(settings); + } + IM_ASSERT(settings->ID == window->ID); + settings->Pos = ImVec2ih(window->Pos); + settings->Size = ImVec2ih(window->SizeFull); + + settings->Collapsed = window->Collapsed; + } + + // Write to text buffer + buf->reserve(buf->size() + g.SettingsWindows.size() * 6); // ballpark reserve + for (ImGuiWindowSettings* settings = g.SettingsWindows.begin(); settings != NULL; settings = g.SettingsWindows.next_chunk(settings)) + { + const char* settings_name = settings->GetName(); + buf->appendf("[%s][%s]\n", handler->TypeName, settings_name); + buf->appendf("Pos=%d,%d\n", settings->Pos.x, settings->Pos.y); + buf->appendf("Size=%d,%d\n", settings->Size.x, settings->Size.y); + buf->appendf("Collapsed=%d\n", settings->Collapsed); + buf->append("\n"); + } +} + + +//----------------------------------------------------------------------------- +// [SECTION] VIEWPORTS, PLATFORM WINDOWS +//----------------------------------------------------------------------------- +// - GetMainViewport() +// - UpdateViewportsNewFrame() [Internal] +// (this section is more complete in the 'docking' branch) +//----------------------------------------------------------------------------- + +ImGuiViewport* ImGui::GetMainViewport() +{ + ImGuiContext& g = *GImGui; + return g.Viewports[0]; +} + +// Update viewports and monitor infos +static void ImGui::UpdateViewportsNewFrame() +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(g.Viewports.Size == 1); + + // Update main viewport with current platform position. + // FIXME-VIEWPORT: Size is driven by backend/user code for backward-compatibility but we should aim to make this more consistent. + ImGuiViewportP* main_viewport = g.Viewports[0]; + main_viewport->Flags = ImGuiViewportFlags_IsPlatformWindow | ImGuiViewportFlags_OwnedByApp; + main_viewport->Pos = ImVec2(0.0f, 0.0f); + main_viewport->Size = g.IO.DisplaySize; + + for (int n = 0; n < g.Viewports.Size; n++) + { + ImGuiViewportP* viewport = g.Viewports[n]; + + // Lock down space taken by menu bars and status bars, reset the offset for fucntions like BeginMainMenuBar() to alter them again. + viewport->WorkOffsetMin = viewport->BuildWorkOffsetMin; + viewport->WorkOffsetMax = viewport->BuildWorkOffsetMax; + viewport->BuildWorkOffsetMin = viewport->BuildWorkOffsetMax = ImVec2(0.0f, 0.0f); + viewport->UpdateWorkRect(); + } +} + +//----------------------------------------------------------------------------- +// [SECTION] DOCKING +//----------------------------------------------------------------------------- + +// (this section is filled in the 'docking' branch) + + +//----------------------------------------------------------------------------- +// [SECTION] PLATFORM DEPENDENT HELPERS +//----------------------------------------------------------------------------- + +#if defined(_WIN32) && !defined(IMGUI_DISABLE_WIN32_FUNCTIONS) && !defined(IMGUI_DISABLE_WIN32_DEFAULT_CLIPBOARD_FUNCTIONS) + +#ifdef _MSC_VER +#pragma comment(lib, "user32") +#pragma comment(lib, "kernel32") +#endif + +// Win32 clipboard implementation +// We use g.ClipboardHandlerData for temporary storage to ensure it is freed on Shutdown() +static const char* GetClipboardTextFn_DefaultImpl(void*) +{ + ImGuiContext& g = *GImGui; + g.ClipboardHandlerData.clear(); + if (!::OpenClipboard(NULL)) + return NULL; + HANDLE wbuf_handle = ::GetClipboardData(CF_UNICODETEXT); + if (wbuf_handle == NULL) + { + ::CloseClipboard(); + return NULL; + } + if (const WCHAR* wbuf_global = (const WCHAR*)::GlobalLock(wbuf_handle)) + { + int buf_len = ::WideCharToMultiByte(CP_UTF8, 0, wbuf_global, -1, NULL, 0, NULL, NULL); + g.ClipboardHandlerData.resize(buf_len); + ::WideCharToMultiByte(CP_UTF8, 0, wbuf_global, -1, g.ClipboardHandlerData.Data, buf_len, NULL, NULL); + } + ::GlobalUnlock(wbuf_handle); + ::CloseClipboard(); + return g.ClipboardHandlerData.Data; +} + +static void SetClipboardTextFn_DefaultImpl(void*, const char* text) +{ + if (!::OpenClipboard(NULL)) + return; + const int wbuf_length = ::MultiByteToWideChar(CP_UTF8, 0, text, -1, NULL, 0); + HGLOBAL wbuf_handle = ::GlobalAlloc(GMEM_MOVEABLE, (SIZE_T)wbuf_length * sizeof(WCHAR)); + if (wbuf_handle == NULL) + { + ::CloseClipboard(); + return; + } + WCHAR* wbuf_global = (WCHAR*)::GlobalLock(wbuf_handle); + ::MultiByteToWideChar(CP_UTF8, 0, text, -1, wbuf_global, wbuf_length); + ::GlobalUnlock(wbuf_handle); + ::EmptyClipboard(); + if (::SetClipboardData(CF_UNICODETEXT, wbuf_handle) == NULL) + ::GlobalFree(wbuf_handle); + ::CloseClipboard(); +} + +#elif defined(__APPLE__) && TARGET_OS_OSX && defined(IMGUI_ENABLE_OSX_DEFAULT_CLIPBOARD_FUNCTIONS) + +#include // Use old API to avoid need for separate .mm file +static PasteboardRef main_clipboard = 0; + +// OSX clipboard implementation +// If you enable this you will need to add '-framework ApplicationServices' to your linker command-line! +static void SetClipboardTextFn_DefaultImpl(void*, const char* text) +{ + if (!main_clipboard) + PasteboardCreate(kPasteboardClipboard, &main_clipboard); + PasteboardClear(main_clipboard); + CFDataRef cf_data = CFDataCreate(kCFAllocatorDefault, (const UInt8*)text, strlen(text)); + if (cf_data) + { + PasteboardPutItemFlavor(main_clipboard, (PasteboardItemID)1, CFSTR("public.utf8-plain-text"), cf_data, 0); + CFRelease(cf_data); + } +} + +static const char* GetClipboardTextFn_DefaultImpl(void*) +{ + if (!main_clipboard) + PasteboardCreate(kPasteboardClipboard, &main_clipboard); + PasteboardSynchronize(main_clipboard); + + ItemCount item_count = 0; + PasteboardGetItemCount(main_clipboard, &item_count); + for (ItemCount i = 0; i < item_count; i++) + { + PasteboardItemID item_id = 0; + PasteboardGetItemIdentifier(main_clipboard, i + 1, &item_id); + CFArrayRef flavor_type_array = 0; + PasteboardCopyItemFlavors(main_clipboard, item_id, &flavor_type_array); + for (CFIndex j = 0, nj = CFArrayGetCount(flavor_type_array); j < nj; j++) + { + CFDataRef cf_data; + if (PasteboardCopyItemFlavorData(main_clipboard, item_id, CFSTR("public.utf8-plain-text"), &cf_data) == noErr) + { + ImGuiContext& g = *GImGui; + g.ClipboardHandlerData.clear(); + int length = (int)CFDataGetLength(cf_data); + g.ClipboardHandlerData.resize(length + 1); + CFDataGetBytes(cf_data, CFRangeMake(0, length), (UInt8*)g.ClipboardHandlerData.Data); + g.ClipboardHandlerData[length] = 0; + CFRelease(cf_data); + return g.ClipboardHandlerData.Data; + } + } + } + return NULL; +} + +#else + +// Local Dear ImGui-only clipboard implementation, if user hasn't defined better clipboard handlers. +static const char* GetClipboardTextFn_DefaultImpl(void*) +{ + ImGuiContext& g = *GImGui; + return g.ClipboardHandlerData.empty() ? NULL : g.ClipboardHandlerData.begin(); +} + +static void SetClipboardTextFn_DefaultImpl(void*, const char* text) +{ + ImGuiContext& g = *GImGui; + g.ClipboardHandlerData.clear(); + const char* text_end = text + strlen(text); + g.ClipboardHandlerData.resize((int)(text_end - text) + 1); + memcpy(&g.ClipboardHandlerData[0], text, (size_t)(text_end - text)); + g.ClipboardHandlerData[(int)(text_end - text)] = 0; +} + +#endif + +// Win32 API IME support (for Asian languages, etc.) +#if defined(_WIN32) && !defined(IMGUI_DISABLE_WIN32_FUNCTIONS) && !defined(IMGUI_DISABLE_WIN32_DEFAULT_IME_FUNCTIONS) + +#include +#ifdef _MSC_VER +#pragma comment(lib, "imm32") +#endif + +static void ImeSetInputScreenPosFn_DefaultImpl(int x, int y) +{ + // Notify OS Input Method Editor of text input position + ImGuiIO& io = ImGui::GetIO(); + if (HWND hwnd = (HWND)io.ImeWindowHandle) + if (HIMC himc = ::ImmGetContext(hwnd)) + { + COMPOSITIONFORM cf; + cf.ptCurrentPos.x = x; + cf.ptCurrentPos.y = y; + cf.dwStyle = CFS_FORCE_POSITION; + ::ImmSetCompositionWindow(himc, &cf); + ::ImmReleaseContext(hwnd, himc); + } +} + +#else + +static void ImeSetInputScreenPosFn_DefaultImpl(int, int) {} + +#endif + +//----------------------------------------------------------------------------- +// [SECTION] METRICS/DEBUGGER WINDOW +//----------------------------------------------------------------------------- +// - RenderViewportThumbnail() [Internal] +// - RenderViewportsThumbnails() [Internal] +// - MetricsHelpMarker() [Internal] +// - ShowMetricsWindow() +// - DebugNodeColumns() [Internal] +// - DebugNodeDrawList() [Internal] +// - DebugNodeDrawCmdShowMeshAndBoundingBox() [Internal] +// - DebugNodeStorage() [Internal] +// - DebugNodeTabBar() [Internal] +// - DebugNodeViewport() [Internal] +// - DebugNodeWindow() [Internal] +// - DebugNodeWindowSettings() [Internal] +// - DebugNodeWindowsList() [Internal] +//----------------------------------------------------------------------------- + +#ifndef IMGUI_DISABLE_METRICS_WINDOW + +void ImGui::DebugRenderViewportThumbnail(ImDrawList* draw_list, ImGuiViewportP* viewport, const ImRect& bb) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + ImVec2 scale = bb.GetSize() / viewport->Size; + ImVec2 off = bb.Min - viewport->Pos * scale; + float alpha_mul = 1.0f; + window->DrawList->AddRectFilled(bb.Min, bb.Max, GetColorU32(ImGuiCol_Border, alpha_mul * 0.40f)); + for (int i = 0; i != g.Windows.Size; i++) + { + ImGuiWindow* thumb_window = g.Windows[i]; + if (!thumb_window->WasActive || (thumb_window->Flags & ImGuiWindowFlags_ChildWindow)) + continue; + + ImRect thumb_r = thumb_window->Rect(); + ImRect title_r = thumb_window->TitleBarRect(); + thumb_r = ImRect(ImFloor(off + thumb_r.Min * scale), ImFloor(off + thumb_r.Max * scale)); + title_r = ImRect(ImFloor(off + title_r.Min * scale), ImFloor(off + ImVec2(title_r.Max.x, title_r.Min.y) * scale) + ImVec2(0,5)); // Exaggerate title bar height + thumb_r.ClipWithFull(bb); + title_r.ClipWithFull(bb); + const bool window_is_focused = (g.NavWindow && thumb_window->RootWindowForTitleBarHighlight == g.NavWindow->RootWindowForTitleBarHighlight); + window->DrawList->AddRectFilled(thumb_r.Min, thumb_r.Max, GetColorU32(ImGuiCol_WindowBg, alpha_mul)); + window->DrawList->AddRectFilled(title_r.Min, title_r.Max, GetColorU32(window_is_focused ? ImGuiCol_TitleBgActive : ImGuiCol_TitleBg, alpha_mul)); + window->DrawList->AddRect(thumb_r.Min, thumb_r.Max, GetColorU32(ImGuiCol_Border, alpha_mul)); + window->DrawList->AddText(g.Font, g.FontSize * 1.0f, title_r.Min, GetColorU32(ImGuiCol_Text, alpha_mul), thumb_window->Name, FindRenderedTextEnd(thumb_window->Name)); + } + draw_list->AddRect(bb.Min, bb.Max, GetColorU32(ImGuiCol_Border, alpha_mul)); +} + +static void RenderViewportsThumbnails() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + // We don't display full monitor bounds (we could, but it often looks awkward), instead we display just enough to cover all of our viewports. + float SCALE = 1.0f / 8.0f; + ImRect bb_full(FLT_MAX, FLT_MAX, -FLT_MAX, -FLT_MAX); + for (int n = 0; n < g.Viewports.Size; n++) + bb_full.Add(g.Viewports[n]->GetMainRect()); + ImVec2 p = window->DC.CursorPos; + ImVec2 off = p - bb_full.Min * SCALE; + for (int n = 0; n < g.Viewports.Size; n++) + { + ImGuiViewportP* viewport = g.Viewports[n]; + ImRect viewport_draw_bb(off + (viewport->Pos) * SCALE, off + (viewport->Pos + viewport->Size) * SCALE); + ImGui::DebugRenderViewportThumbnail(window->DrawList, viewport, viewport_draw_bb); + } + ImGui::Dummy(bb_full.GetSize() * SCALE); +} + +// Avoid naming collision with imgui_demo.cpp's HelpMarker() for unity builds. +static void MetricsHelpMarker(const char* desc) +{ + ImGui::TextDisabled("(?)"); + if (ImGui::IsItemHovered()) + { + ImGui::BeginTooltip(); + ImGui::PushTextWrapPos(ImGui::GetFontSize() * 35.0f); + ImGui::TextUnformatted(desc); + ImGui::PopTextWrapPos(); + ImGui::EndTooltip(); + } +} + +#ifndef IMGUI_DISABLE_DEMO_WINDOWS +namespace ImGui { void ShowFontAtlas(ImFontAtlas* atlas); } +#endif + +void ImGui::ShowMetricsWindow(bool* p_open) +{ + if (!Begin("Dear ImGui Metrics/Debugger", p_open)) + { + End(); + return; + } + + ImGuiContext& g = *GImGui; + ImGuiIO& io = g.IO; + ImGuiMetricsConfig* cfg = &g.DebugMetricsConfig; + + // Basic info + Text("Dear ImGui %s", GetVersion()); + Text("Application average %.3f ms/frame (%.1f FPS)", 1000.0f / io.Framerate, io.Framerate); + Text("%d vertices, %d indices (%d triangles)", io.MetricsRenderVertices, io.MetricsRenderIndices, io.MetricsRenderIndices / 3); + Text("%d active windows (%d visible)", io.MetricsActiveWindows, io.MetricsRenderWindows); + Text("%d active allocations", io.MetricsActiveAllocations); + //SameLine(); if (SmallButton("GC")) { g.GcCompactAll = true; } + + Separator(); + + // Debugging enums + enum { WRT_OuterRect, WRT_OuterRectClipped, WRT_InnerRect, WRT_InnerClipRect, WRT_WorkRect, WRT_Content, WRT_ContentIdeal, WRT_ContentRegionRect, WRT_Count }; // Windows Rect Type + const char* wrt_rects_names[WRT_Count] = { "OuterRect", "OuterRectClipped", "InnerRect", "InnerClipRect", "WorkRect", "Content", "ContentIdeal", "ContentRegionRect" }; + enum { TRT_OuterRect, TRT_InnerRect, TRT_WorkRect, TRT_HostClipRect, TRT_InnerClipRect, TRT_BackgroundClipRect, TRT_ColumnsRect, TRT_ColumnsWorkRect, TRT_ColumnsClipRect, TRT_ColumnsContentHeadersUsed, TRT_ColumnsContentHeadersIdeal, TRT_ColumnsContentFrozen, TRT_ColumnsContentUnfrozen, TRT_Count }; // Tables Rect Type + const char* trt_rects_names[TRT_Count] = { "OuterRect", "InnerRect", "WorkRect", "HostClipRect", "InnerClipRect", "BackgroundClipRect", "ColumnsRect", "ColumnsWorkRect", "ColumnsClipRect", "ColumnsContentHeadersUsed", "ColumnsContentHeadersIdeal", "ColumnsContentFrozen", "ColumnsContentUnfrozen" }; + if (cfg->ShowWindowsRectsType < 0) + cfg->ShowWindowsRectsType = WRT_WorkRect; + if (cfg->ShowTablesRectsType < 0) + cfg->ShowTablesRectsType = TRT_WorkRect; + + struct Funcs + { + static ImRect GetTableRect(ImGuiTable* table, int rect_type, int n) + { + if (rect_type == TRT_OuterRect) { return table->OuterRect; } + else if (rect_type == TRT_InnerRect) { return table->InnerRect; } + else if (rect_type == TRT_WorkRect) { return table->WorkRect; } + else if (rect_type == TRT_HostClipRect) { return table->HostClipRect; } + else if (rect_type == TRT_InnerClipRect) { return table->InnerClipRect; } + else if (rect_type == TRT_BackgroundClipRect) { return table->BgClipRect; } + else if (rect_type == TRT_ColumnsRect) { ImGuiTableColumn* c = &table->Columns[n]; return ImRect(c->MinX, table->InnerClipRect.Min.y, c->MaxX, table->InnerClipRect.Min.y + table->LastOuterHeight); } + else if (rect_type == TRT_ColumnsWorkRect) { ImGuiTableColumn* c = &table->Columns[n]; return ImRect(c->WorkMinX, table->WorkRect.Min.y, c->WorkMaxX, table->WorkRect.Max.y); } + else if (rect_type == TRT_ColumnsClipRect) { ImGuiTableColumn* c = &table->Columns[n]; return c->ClipRect; } + else if (rect_type == TRT_ColumnsContentHeadersUsed){ ImGuiTableColumn* c = &table->Columns[n]; return ImRect(c->WorkMinX, table->InnerClipRect.Min.y, c->ContentMaxXHeadersUsed, table->InnerClipRect.Min.y + table->LastFirstRowHeight); } // Note: y1/y2 not always accurate + else if (rect_type == TRT_ColumnsContentHeadersIdeal){ImGuiTableColumn* c = &table->Columns[n]; return ImRect(c->WorkMinX, table->InnerClipRect.Min.y, c->ContentMaxXHeadersIdeal, table->InnerClipRect.Min.y + table->LastFirstRowHeight); } + else if (rect_type == TRT_ColumnsContentFrozen) { ImGuiTableColumn* c = &table->Columns[n]; return ImRect(c->WorkMinX, table->InnerClipRect.Min.y, c->ContentMaxXFrozen, table->InnerClipRect.Min.y + table->LastFirstRowHeight); } + else if (rect_type == TRT_ColumnsContentUnfrozen) { ImGuiTableColumn* c = &table->Columns[n]; return ImRect(c->WorkMinX, table->InnerClipRect.Min.y + table->LastFirstRowHeight, c->ContentMaxXUnfrozen, table->InnerClipRect.Max.y); } + IM_ASSERT(0); + return ImRect(); + } + + static ImRect GetWindowRect(ImGuiWindow* window, int rect_type) + { + if (rect_type == WRT_OuterRect) { return window->Rect(); } + else if (rect_type == WRT_OuterRectClipped) { return window->OuterRectClipped; } + else if (rect_type == WRT_InnerRect) { return window->InnerRect; } + else if (rect_type == WRT_InnerClipRect) { return window->InnerClipRect; } + else if (rect_type == WRT_WorkRect) { return window->WorkRect; } + else if (rect_type == WRT_Content) { ImVec2 min = window->InnerRect.Min - window->Scroll + window->WindowPadding; return ImRect(min, min + window->ContentSize); } + else if (rect_type == WRT_ContentIdeal) { ImVec2 min = window->InnerRect.Min - window->Scroll + window->WindowPadding; return ImRect(min, min + window->ContentSizeIdeal); } + else if (rect_type == WRT_ContentRegionRect) { return window->ContentRegionRect; } + IM_ASSERT(0); + return ImRect(); + } + }; + + // Tools + if (TreeNode("Tools")) + { + // The Item Picker tool is super useful to visually select an item and break into the call-stack of where it was submitted. + if (Button("Item Picker..")) + DebugStartItemPicker(); + SameLine(); + MetricsHelpMarker("Will call the IM_DEBUG_BREAK() macro to break in debugger.\nWarning: If you don't have a debugger attached, this will probably crash."); + + Checkbox("Show windows begin order", &cfg->ShowWindowsBeginOrder); + Checkbox("Show windows rectangles", &cfg->ShowWindowsRects); + SameLine(); + SetNextItemWidth(GetFontSize() * 12); + cfg->ShowWindowsRects |= Combo("##show_windows_rect_type", &cfg->ShowWindowsRectsType, wrt_rects_names, WRT_Count, WRT_Count); + if (cfg->ShowWindowsRects && g.NavWindow != NULL) + { + BulletText("'%s':", g.NavWindow->Name); + Indent(); + for (int rect_n = 0; rect_n < WRT_Count; rect_n++) + { + ImRect r = Funcs::GetWindowRect(g.NavWindow, rect_n); + Text("(%6.1f,%6.1f) (%6.1f,%6.1f) Size (%6.1f,%6.1f) %s", r.Min.x, r.Min.y, r.Max.x, r.Max.y, r.GetWidth(), r.GetHeight(), wrt_rects_names[rect_n]); + } + Unindent(); + } + Checkbox("Show ImDrawCmd mesh when hovering", &cfg->ShowDrawCmdMesh); + Checkbox("Show ImDrawCmd bounding boxes when hovering", &cfg->ShowDrawCmdBoundingBoxes); + + Checkbox("Show tables rectangles", &cfg->ShowTablesRects); + SameLine(); + SetNextItemWidth(GetFontSize() * 12); + cfg->ShowTablesRects |= Combo("##show_table_rects_type", &cfg->ShowTablesRectsType, trt_rects_names, TRT_Count, TRT_Count); + if (cfg->ShowTablesRects && g.NavWindow != NULL) + { + for (int table_n = 0; table_n < g.Tables.GetMapSize(); table_n++) + { + ImGuiTable* table = g.Tables.TryGetMapData(table_n); + if (table == NULL || table->LastFrameActive < g.FrameCount - 1 || (table->OuterWindow != g.NavWindow && table->InnerWindow != g.NavWindow)) + continue; + + BulletText("Table 0x%08X (%d columns, in '%s')", table->ID, table->ColumnsCount, table->OuterWindow->Name); + if (IsItemHovered()) + GetForegroundDrawList()->AddRect(table->OuterRect.Min - ImVec2(1, 1), table->OuterRect.Max + ImVec2(1, 1), IM_COL32(255, 255, 0, 255), 0.0f, 0, 2.0f); + Indent(); + char buf[128]; + for (int rect_n = 0; rect_n < TRT_Count; rect_n++) + { + if (rect_n >= TRT_ColumnsRect) + { + if (rect_n != TRT_ColumnsRect && rect_n != TRT_ColumnsClipRect) + continue; + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + ImRect r = Funcs::GetTableRect(table, rect_n, column_n); + ImFormatString(buf, IM_ARRAYSIZE(buf), "(%6.1f,%6.1f) (%6.1f,%6.1f) Size (%6.1f,%6.1f) Col %d %s", r.Min.x, r.Min.y, r.Max.x, r.Max.y, r.GetWidth(), r.GetHeight(), column_n, trt_rects_names[rect_n]); + Selectable(buf); + if (IsItemHovered()) + GetForegroundDrawList()->AddRect(r.Min - ImVec2(1, 1), r.Max + ImVec2(1, 1), IM_COL32(255, 255, 0, 255), 0.0f, 0, 2.0f); + } + } + else + { + ImRect r = Funcs::GetTableRect(table, rect_n, -1); + ImFormatString(buf, IM_ARRAYSIZE(buf), "(%6.1f,%6.1f) (%6.1f,%6.1f) Size (%6.1f,%6.1f) %s", r.Min.x, r.Min.y, r.Max.x, r.Max.y, r.GetWidth(), r.GetHeight(), trt_rects_names[rect_n]); + Selectable(buf); + if (IsItemHovered()) + GetForegroundDrawList()->AddRect(r.Min - ImVec2(1, 1), r.Max + ImVec2(1, 1), IM_COL32(255, 255, 0, 255), 0.0f, 0, 2.0f); + } + } + Unindent(); + } + } + + TreePop(); + } + + // Windows + DebugNodeWindowsList(&g.Windows, "Windows"); + //DebugNodeWindowsList(&g.WindowsFocusOrder, "WindowsFocusOrder"); + + // DrawLists + int drawlist_count = 0; + for (int viewport_i = 0; viewport_i < g.Viewports.Size; viewport_i++) + drawlist_count += g.Viewports[viewport_i]->DrawDataBuilder.GetDrawListCount(); + if (TreeNode("DrawLists", "DrawLists (%d)", drawlist_count)) + { + for (int viewport_i = 0; viewport_i < g.Viewports.Size; viewport_i++) + { + ImGuiViewportP* viewport = g.Viewports[viewport_i]; + for (int layer_i = 0; layer_i < IM_ARRAYSIZE(viewport->DrawDataBuilder.Layers); layer_i++) + for (int draw_list_i = 0; draw_list_i < viewport->DrawDataBuilder.Layers[layer_i].Size; draw_list_i++) + DebugNodeDrawList(NULL, viewport->DrawDataBuilder.Layers[layer_i][draw_list_i], "DrawList"); + } + TreePop(); + } + + // Viewports + if (TreeNode("Viewports", "Viewports (%d)", g.Viewports.Size)) + { + Indent(GetTreeNodeToLabelSpacing()); + RenderViewportsThumbnails(); + Unindent(GetTreeNodeToLabelSpacing()); + for (int i = 0; i < g.Viewports.Size; i++) + DebugNodeViewport(g.Viewports[i]); + TreePop(); + } + + // Details for Popups + if (TreeNode("Popups", "Popups (%d)", g.OpenPopupStack.Size)) + { + for (int i = 0; i < g.OpenPopupStack.Size; i++) + { + ImGuiWindow* window = g.OpenPopupStack[i].Window; + BulletText("PopupID: %08x, Window: '%s'%s%s", g.OpenPopupStack[i].PopupId, window ? window->Name : "NULL", window && (window->Flags & ImGuiWindowFlags_ChildWindow) ? " ChildWindow" : "", window && (window->Flags & ImGuiWindowFlags_ChildMenu) ? " ChildMenu" : ""); + } + TreePop(); + } + + // Details for TabBars + if (TreeNode("TabBars", "Tab Bars (%d)", g.TabBars.GetAliveCount())) + { + for (int n = 0; n < g.TabBars.GetMapSize(); n++) + if (ImGuiTabBar* tab_bar = g.TabBars.TryGetMapData(n)) + { + PushID(tab_bar); + DebugNodeTabBar(tab_bar, "TabBar"); + PopID(); + } + TreePop(); + } + + // Details for Tables + if (TreeNode("Tables", "Tables (%d)", g.Tables.GetAliveCount())) + { + for (int n = 0; n < g.Tables.GetMapSize(); n++) + if (ImGuiTable* table = g.Tables.TryGetMapData(n)) + DebugNodeTable(table); + TreePop(); + } + + // Details for Fonts +#ifndef IMGUI_DISABLE_DEMO_WINDOWS + ImFontAtlas* atlas = g.IO.Fonts; + if (TreeNode("Fonts", "Fonts (%d)", atlas->Fonts.Size)) + { + ShowFontAtlas(atlas); + TreePop(); + } +#endif + + // Details for Docking +#ifdef IMGUI_HAS_DOCK + if (TreeNode("Docking")) + { + TreePop(); + } +#endif // #ifdef IMGUI_HAS_DOCK + + // Settings + if (TreeNode("Settings")) + { + if (SmallButton("Clear")) + ClearIniSettings(); + SameLine(); + if (SmallButton("Save to memory")) + SaveIniSettingsToMemory(); + SameLine(); + if (SmallButton("Save to disk")) + SaveIniSettingsToDisk(g.IO.IniFilename); + SameLine(); + if (g.IO.IniFilename) + Text("\"%s\"", g.IO.IniFilename); + else + TextUnformatted(""); + Text("SettingsDirtyTimer %.2f", g.SettingsDirtyTimer); + if (TreeNode("SettingsHandlers", "Settings handlers: (%d)", g.SettingsHandlers.Size)) + { + for (int n = 0; n < g.SettingsHandlers.Size; n++) + BulletText("%s", g.SettingsHandlers[n].TypeName); + TreePop(); + } + if (TreeNode("SettingsWindows", "Settings packed data: Windows: %d bytes", g.SettingsWindows.size())) + { + for (ImGuiWindowSettings* settings = g.SettingsWindows.begin(); settings != NULL; settings = g.SettingsWindows.next_chunk(settings)) + DebugNodeWindowSettings(settings); + TreePop(); + } + + if (TreeNode("SettingsTables", "Settings packed data: Tables: %d bytes", g.SettingsTables.size())) + { + for (ImGuiTableSettings* settings = g.SettingsTables.begin(); settings != NULL; settings = g.SettingsTables.next_chunk(settings)) + DebugNodeTableSettings(settings); + TreePop(); + } + +#ifdef IMGUI_HAS_DOCK +#endif // #ifdef IMGUI_HAS_DOCK + + if (TreeNode("SettingsIniData", "Settings unpacked data (.ini): %d bytes", g.SettingsIniData.size())) + { + InputTextMultiline("##Ini", (char*)(void*)g.SettingsIniData.c_str(), g.SettingsIniData.Buf.Size, ImVec2(-FLT_MIN, GetTextLineHeight() * 20), ImGuiInputTextFlags_ReadOnly); + TreePop(); + } + TreePop(); + } + + // Misc Details + if (TreeNode("Internal state")) + { + const char* input_source_names[] = { "None", "Mouse", "Keyboard", "Gamepad", "Nav", "Clipboard" }; IM_ASSERT(IM_ARRAYSIZE(input_source_names) == ImGuiInputSource_COUNT); + + Text("WINDOWING"); + Indent(); + Text("HoveredWindow: '%s'", g.HoveredWindow ? g.HoveredWindow->Name : "NULL"); + Text("HoveredWindow->Root: '%s'", g.HoveredWindow ? g.HoveredWindow->RootWindow->Name : "NULL"); + Text("HoveredWindowUnderMovingWindow: '%s'", g.HoveredWindowUnderMovingWindow ? g.HoveredWindowUnderMovingWindow->Name : "NULL"); + Text("MovingWindow: '%s'", g.MovingWindow ? g.MovingWindow->Name : "NULL"); + Unindent(); + + Text("ITEMS"); + Indent(); + Text("ActiveId: 0x%08X/0x%08X (%.2f sec), AllowOverlap: %d, Source: %s", g.ActiveId, g.ActiveIdPreviousFrame, g.ActiveIdTimer, g.ActiveIdAllowOverlap, input_source_names[g.ActiveIdSource]); + Text("ActiveIdWindow: '%s'", g.ActiveIdWindow ? g.ActiveIdWindow->Name : "NULL"); + Text("ActiveIdUsing: Wheel: %d, NavDirMask: %X, NavInputMask: %X, KeyInputMask: %llX", g.ActiveIdUsingMouseWheel, g.ActiveIdUsingNavDirMask, g.ActiveIdUsingNavInputMask, g.ActiveIdUsingKeyInputMask); + Text("HoveredId: 0x%08X (%.2f sec), AllowOverlap: %d", g.HoveredIdPreviousFrame, g.HoveredIdTimer, g.HoveredIdAllowOverlap); // Not displaying g.HoveredId as it is update mid-frame + Text("DragDrop: %d, SourceId = 0x%08X, Payload \"%s\" (%d bytes)", g.DragDropActive, g.DragDropPayload.SourceId, g.DragDropPayload.DataType, g.DragDropPayload.DataSize); + Unindent(); + + Text("NAV,FOCUS"); + Indent(); + Text("NavWindow: '%s'", g.NavWindow ? g.NavWindow->Name : "NULL"); + Text("NavId: 0x%08X, NavLayer: %d", g.NavId, g.NavLayer); + Text("NavInputSource: %s", input_source_names[g.NavInputSource]); + Text("NavActive: %d, NavVisible: %d", g.IO.NavActive, g.IO.NavVisible); + Text("NavActivateId/DownId/PressedId/InputId: %08X/%08X/%08X/%08X", g.NavActivateId, g.NavActivateDownId, g.NavActivatePressedId, g.NavActivateInputId); + Text("NavActivateFlags: %04X", g.NavActivateFlags); + Text("NavDisableHighlight: %d, NavDisableMouseHover: %d", g.NavDisableHighlight, g.NavDisableMouseHover); + Text("NavFocusScopeId = 0x%08X", g.NavFocusScopeId); + Text("NavWindowingTarget: '%s'", g.NavWindowingTarget ? g.NavWindowingTarget->Name : "NULL"); + Unindent(); + + TreePop(); + } + + // Overlay: Display windows Rectangles and Begin Order + if (cfg->ShowWindowsRects || cfg->ShowWindowsBeginOrder) + { + for (int n = 0; n < g.Windows.Size; n++) + { + ImGuiWindow* window = g.Windows[n]; + if (!window->WasActive) + continue; + ImDrawList* draw_list = GetForegroundDrawList(window); + if (cfg->ShowWindowsRects) + { + ImRect r = Funcs::GetWindowRect(window, cfg->ShowWindowsRectsType); + draw_list->AddRect(r.Min, r.Max, IM_COL32(255, 0, 128, 255)); + } + if (cfg->ShowWindowsBeginOrder && !(window->Flags & ImGuiWindowFlags_ChildWindow)) + { + char buf[32]; + ImFormatString(buf, IM_ARRAYSIZE(buf), "%d", window->BeginOrderWithinContext); + float font_size = GetFontSize(); + draw_list->AddRectFilled(window->Pos, window->Pos + ImVec2(font_size, font_size), IM_COL32(200, 100, 100, 255)); + draw_list->AddText(window->Pos, IM_COL32(255, 255, 255, 255), buf); + } + } + } + + // Overlay: Display Tables Rectangles + if (cfg->ShowTablesRects) + { + for (int table_n = 0; table_n < g.Tables.GetMapSize(); table_n++) + { + ImGuiTable* table = g.Tables.TryGetMapData(table_n); + if (table == NULL || table->LastFrameActive < g.FrameCount - 1) + continue; + ImDrawList* draw_list = GetForegroundDrawList(table->OuterWindow); + if (cfg->ShowTablesRectsType >= TRT_ColumnsRect) + { + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + ImRect r = Funcs::GetTableRect(table, cfg->ShowTablesRectsType, column_n); + ImU32 col = (table->HoveredColumnBody == column_n) ? IM_COL32(255, 255, 128, 255) : IM_COL32(255, 0, 128, 255); + float thickness = (table->HoveredColumnBody == column_n) ? 3.0f : 1.0f; + draw_list->AddRect(r.Min, r.Max, col, 0.0f, 0, thickness); + } + } + else + { + ImRect r = Funcs::GetTableRect(table, cfg->ShowTablesRectsType, -1); + draw_list->AddRect(r.Min, r.Max, IM_COL32(255, 0, 128, 255)); + } + } + } + +#ifdef IMGUI_HAS_DOCK + // Overlay: Display Docking info + if (show_docking_nodes && g.IO.KeyCtrl) + { + } +#endif // #ifdef IMGUI_HAS_DOCK + + End(); +} + +// [DEBUG] List fonts in a font atlas and display its texture +void ImGui::ShowFontAtlas(ImFontAtlas* atlas) +{ + for (int i = 0; i < atlas->Fonts.Size; i++) + { + ImFont* font = atlas->Fonts[i]; + PushID(font); + DebugNodeFont(font); + PopID(); + } + if (TreeNode("Atlas texture", "Atlas texture (%dx%d pixels)", atlas->TexWidth, atlas->TexHeight)) + { + ImVec4 tint_col = ImVec4(1.0f, 1.0f, 1.0f, 1.0f); + ImVec4 border_col = ImVec4(1.0f, 1.0f, 1.0f, 0.5f); + Image(atlas->TexID, ImVec2((float)atlas->TexWidth, (float)atlas->TexHeight), ImVec2(0.0f, 0.0f), ImVec2(1.0f, 1.0f), tint_col, border_col); + TreePop(); + } +} + +// [DEBUG] Display contents of Columns +void ImGui::DebugNodeColumns(ImGuiOldColumns* columns) +{ + if (!TreeNode((void*)(uintptr_t)columns->ID, "Columns Id: 0x%08X, Count: %d, Flags: 0x%04X", columns->ID, columns->Count, columns->Flags)) + return; + BulletText("Width: %.1f (MinX: %.1f, MaxX: %.1f)", columns->OffMaxX - columns->OffMinX, columns->OffMinX, columns->OffMaxX); + for (int column_n = 0; column_n < columns->Columns.Size; column_n++) + BulletText("Column %02d: OffsetNorm %.3f (= %.1f px)", column_n, columns->Columns[column_n].OffsetNorm, GetColumnOffsetFromNorm(columns, columns->Columns[column_n].OffsetNorm)); + TreePop(); +} + +// [DEBUG] Display contents of ImDrawList +void ImGui::DebugNodeDrawList(ImGuiWindow* window, const ImDrawList* draw_list, const char* label) +{ + ImGuiContext& g = *GImGui; + ImGuiMetricsConfig* cfg = &g.DebugMetricsConfig; + int cmd_count = draw_list->CmdBuffer.Size; + if (cmd_count > 0 && draw_list->CmdBuffer.back().ElemCount == 0 && draw_list->CmdBuffer.back().UserCallback == NULL) + cmd_count--; + bool node_open = TreeNode(draw_list, "%s: '%s' %d vtx, %d indices, %d cmds", label, draw_list->_OwnerName ? draw_list->_OwnerName : "", draw_list->VtxBuffer.Size, draw_list->IdxBuffer.Size, cmd_count); + if (draw_list == GetWindowDrawList()) + { + SameLine(); + TextColored(ImVec4(1.0f, 0.4f, 0.4f, 1.0f), "CURRENTLY APPENDING"); // Can't display stats for active draw list! (we don't have the data double-buffered) + if (node_open) + TreePop(); + return; + } + + ImDrawList* fg_draw_list = GetForegroundDrawList(window); // Render additional visuals into the top-most draw list + if (window && IsItemHovered()) + fg_draw_list->AddRect(window->Pos, window->Pos + window->Size, IM_COL32(255, 255, 0, 255)); + if (!node_open) + return; + + if (window && !window->WasActive) + TextDisabled("Warning: owning Window is inactive. This DrawList is not being rendered!"); + + for (const ImDrawCmd* pcmd = draw_list->CmdBuffer.Data; pcmd < draw_list->CmdBuffer.Data + cmd_count; pcmd++) + { + if (pcmd->UserCallback) + { + BulletText("Callback %p, user_data %p", pcmd->UserCallback, pcmd->UserCallbackData); + continue; + } + + char buf[300]; + ImFormatString(buf, IM_ARRAYSIZE(buf), "DrawCmd:%5d tris, Tex 0x%p, ClipRect (%4.0f,%4.0f)-(%4.0f,%4.0f)", + pcmd->ElemCount / 3, (void*)(intptr_t)pcmd->TextureId, + pcmd->ClipRect.x, pcmd->ClipRect.y, pcmd->ClipRect.z, pcmd->ClipRect.w); + bool pcmd_node_open = TreeNode((void*)(pcmd - draw_list->CmdBuffer.begin()), "%s", buf); + if (IsItemHovered() && (cfg->ShowDrawCmdMesh || cfg->ShowDrawCmdBoundingBoxes) && fg_draw_list) + DebugNodeDrawCmdShowMeshAndBoundingBox(fg_draw_list, draw_list, pcmd, cfg->ShowDrawCmdMesh, cfg->ShowDrawCmdBoundingBoxes); + if (!pcmd_node_open) + continue; + + // Calculate approximate coverage area (touched pixel count) + // This will be in pixels squared as long there's no post-scaling happening to the renderer output. + const ImDrawIdx* idx_buffer = (draw_list->IdxBuffer.Size > 0) ? draw_list->IdxBuffer.Data : NULL; + const ImDrawVert* vtx_buffer = draw_list->VtxBuffer.Data + pcmd->VtxOffset; + float total_area = 0.0f; + for (unsigned int idx_n = pcmd->IdxOffset; idx_n < pcmd->IdxOffset + pcmd->ElemCount; ) + { + ImVec2 triangle[3]; + for (int n = 0; n < 3; n++, idx_n++) + triangle[n] = vtx_buffer[idx_buffer ? idx_buffer[idx_n] : idx_n].pos; + total_area += ImTriangleArea(triangle[0], triangle[1], triangle[2]); + } + + // Display vertex information summary. Hover to get all triangles drawn in wire-frame + ImFormatString(buf, IM_ARRAYSIZE(buf), "Mesh: ElemCount: %d, VtxOffset: +%d, IdxOffset: +%d, Area: ~%0.f px", pcmd->ElemCount, pcmd->VtxOffset, pcmd->IdxOffset, total_area); + Selectable(buf); + if (IsItemHovered() && fg_draw_list) + DebugNodeDrawCmdShowMeshAndBoundingBox(fg_draw_list, draw_list, pcmd, true, false); + + // Display individual triangles/vertices. Hover on to get the corresponding triangle highlighted. + ImGuiListClipper clipper; + clipper.Begin(pcmd->ElemCount / 3); // Manually coarse clip our print out of individual vertices to save CPU, only items that may be visible. + while (clipper.Step()) + for (int prim = clipper.DisplayStart, idx_i = pcmd->IdxOffset + clipper.DisplayStart * 3; prim < clipper.DisplayEnd; prim++) + { + char* buf_p = buf, * buf_end = buf + IM_ARRAYSIZE(buf); + ImVec2 triangle[3]; + for (int n = 0; n < 3; n++, idx_i++) + { + const ImDrawVert& v = vtx_buffer[idx_buffer ? idx_buffer[idx_i] : idx_i]; + triangle[n] = v.pos; + buf_p += ImFormatString(buf_p, buf_end - buf_p, "%s %04d: pos (%8.2f,%8.2f), uv (%.6f,%.6f), col %08X\n", + (n == 0) ? "Vert:" : " ", idx_i, v.pos.x, v.pos.y, v.uv.x, v.uv.y, v.col); + } + + Selectable(buf, false); + if (fg_draw_list && IsItemHovered()) + { + ImDrawListFlags backup_flags = fg_draw_list->Flags; + fg_draw_list->Flags &= ~ImDrawListFlags_AntiAliasedLines; // Disable AA on triangle outlines is more readable for very large and thin triangles. + fg_draw_list->AddPolyline(triangle, 3, IM_COL32(255, 255, 0, 255), ImDrawFlags_Closed, 1.0f); + fg_draw_list->Flags = backup_flags; + } + } + TreePop(); + } + TreePop(); +} + +// [DEBUG] Display mesh/aabb of a ImDrawCmd +void ImGui::DebugNodeDrawCmdShowMeshAndBoundingBox(ImDrawList* out_draw_list, const ImDrawList* draw_list, const ImDrawCmd* draw_cmd, bool show_mesh, bool show_aabb) +{ + IM_ASSERT(show_mesh || show_aabb); + + // Draw wire-frame version of all triangles + ImRect clip_rect = draw_cmd->ClipRect; + ImRect vtxs_rect(FLT_MAX, FLT_MAX, -FLT_MAX, -FLT_MAX); + ImDrawListFlags backup_flags = out_draw_list->Flags; + out_draw_list->Flags &= ~ImDrawListFlags_AntiAliasedLines; // Disable AA on triangle outlines is more readable for very large and thin triangles. + for (unsigned int idx_n = draw_cmd->IdxOffset, idx_end = draw_cmd->IdxOffset + draw_cmd->ElemCount; idx_n < idx_end; ) + { + ImDrawIdx* idx_buffer = (draw_list->IdxBuffer.Size > 0) ? draw_list->IdxBuffer.Data : NULL; // We don't hold on those pointers past iterations as ->AddPolyline() may invalidate them if out_draw_list==draw_list + ImDrawVert* vtx_buffer = draw_list->VtxBuffer.Data + draw_cmd->VtxOffset; + + ImVec2 triangle[3]; + for (int n = 0; n < 3; n++, idx_n++) + vtxs_rect.Add((triangle[n] = vtx_buffer[idx_buffer ? idx_buffer[idx_n] : idx_n].pos)); + if (show_mesh) + out_draw_list->AddPolyline(triangle, 3, IM_COL32(255, 255, 0, 255), ImDrawFlags_Closed, 1.0f); // In yellow: mesh triangles + } + // Draw bounding boxes + if (show_aabb) + { + out_draw_list->AddRect(ImFloor(clip_rect.Min), ImFloor(clip_rect.Max), IM_COL32(255, 0, 255, 255)); // In pink: clipping rectangle submitted to GPU + out_draw_list->AddRect(ImFloor(vtxs_rect.Min), ImFloor(vtxs_rect.Max), IM_COL32(0, 255, 255, 255)); // In cyan: bounding box of triangles + } + out_draw_list->Flags = backup_flags; +} + +// [DEBUG] Display details for a single font, called by ShowStyleEditor(). +void ImGui::DebugNodeFont(ImFont* font) +{ + bool opened = TreeNode(font, "Font: \"%s\"\n%.2f px, %d glyphs, %d file(s)", + font->ConfigData ? font->ConfigData[0].Name : "", font->FontSize, font->Glyphs.Size, font->ConfigDataCount); + SameLine(); + if (SmallButton("Set as default")) + GetIO().FontDefault = font; + if (!opened) + return; + + // Display preview text + PushFont(font); + Text("The quick brown fox jumps over the lazy dog"); + PopFont(); + + // Display details + SetNextItemWidth(GetFontSize() * 8); + DragFloat("Font scale", &font->Scale, 0.005f, 0.3f, 2.0f, "%.1f"); + SameLine(); MetricsHelpMarker( + "Note than the default embedded font is NOT meant to be scaled.\n\n" + "Font are currently rendered into bitmaps at a given size at the time of building the atlas. " + "You may oversample them to get some flexibility with scaling. " + "You can also render at multiple sizes and select which one to use at runtime.\n\n" + "(Glimmer of hope: the atlas system will be rewritten in the future to make scaling more flexible.)"); + Text("Ascent: %f, Descent: %f, Height: %f", font->Ascent, font->Descent, font->Ascent - font->Descent); + char c_str[5]; + Text("Fallback character: '%s' (U+%04X)", ImTextCharToUtf8(c_str, font->FallbackChar), font->FallbackChar); + Text("Ellipsis character: '%s' (U+%04X)", ImTextCharToUtf8(c_str, font->EllipsisChar), font->EllipsisChar); + const int surface_sqrt = (int)ImSqrt((float)font->MetricsTotalSurface); + Text("Texture Area: about %d px ~%dx%d px", font->MetricsTotalSurface, surface_sqrt, surface_sqrt); + for (int config_i = 0; config_i < font->ConfigDataCount; config_i++) + if (font->ConfigData) + if (const ImFontConfig* cfg = &font->ConfigData[config_i]) + BulletText("Input %d: \'%s\', Oversample: (%d,%d), PixelSnapH: %d, Offset: (%.1f,%.1f)", + config_i, cfg->Name, cfg->OversampleH, cfg->OversampleV, cfg->PixelSnapH, cfg->GlyphOffset.x, cfg->GlyphOffset.y); + + // Display all glyphs of the fonts in separate pages of 256 characters + if (TreeNode("Glyphs", "Glyphs (%d)", font->Glyphs.Size)) + { + ImDrawList* draw_list = GetWindowDrawList(); + const ImU32 glyph_col = GetColorU32(ImGuiCol_Text); + const float cell_size = font->FontSize * 1; + const float cell_spacing = GetStyle().ItemSpacing.y; + for (unsigned int base = 0; base <= IM_UNICODE_CODEPOINT_MAX; base += 256) + { + // Skip ahead if a large bunch of glyphs are not present in the font (test in chunks of 4k) + // This is only a small optimization to reduce the number of iterations when IM_UNICODE_MAX_CODEPOINT + // is large // (if ImWchar==ImWchar32 we will do at least about 272 queries here) + if (!(base & 4095) && font->IsGlyphRangeUnused(base, base + 4095)) + { + base += 4096 - 256; + continue; + } + + int count = 0; + for (unsigned int n = 0; n < 256; n++) + if (font->FindGlyphNoFallback((ImWchar)(base + n))) + count++; + if (count <= 0) + continue; + if (!TreeNode((void*)(intptr_t)base, "U+%04X..U+%04X (%d %s)", base, base + 255, count, count > 1 ? "glyphs" : "glyph")) + continue; + + // Draw a 16x16 grid of glyphs + ImVec2 base_pos = GetCursorScreenPos(); + for (unsigned int n = 0; n < 256; n++) + { + // We use ImFont::RenderChar as a shortcut because we don't have UTF-8 conversion functions + // available here and thus cannot easily generate a zero-terminated UTF-8 encoded string. + ImVec2 cell_p1(base_pos.x + (n % 16) * (cell_size + cell_spacing), base_pos.y + (n / 16) * (cell_size + cell_spacing)); + ImVec2 cell_p2(cell_p1.x + cell_size, cell_p1.y + cell_size); + const ImFontGlyph* glyph = font->FindGlyphNoFallback((ImWchar)(base + n)); + draw_list->AddRect(cell_p1, cell_p2, glyph ? IM_COL32(255, 255, 255, 100) : IM_COL32(255, 255, 255, 50)); + if (glyph) + font->RenderChar(draw_list, cell_size, cell_p1, glyph_col, (ImWchar)(base + n)); + if (glyph && IsMouseHoveringRect(cell_p1, cell_p2)) + { + BeginTooltip(); + Text("Codepoint: U+%04X", base + n); + Separator(); + Text("Visible: %d", glyph->Visible); + Text("AdvanceX: %.1f", glyph->AdvanceX); + Text("Pos: (%.2f,%.2f)->(%.2f,%.2f)", glyph->X0, glyph->Y0, glyph->X1, glyph->Y1); + Text("UV: (%.3f,%.3f)->(%.3f,%.3f)", glyph->U0, glyph->V0, glyph->U1, glyph->V1); + EndTooltip(); + } + } + Dummy(ImVec2((cell_size + cell_spacing) * 16, (cell_size + cell_spacing) * 16)); + TreePop(); + } + TreePop(); + } + TreePop(); +} + +// [DEBUG] Display contents of ImGuiStorage +void ImGui::DebugNodeStorage(ImGuiStorage* storage, const char* label) +{ + if (!TreeNode(label, "%s: %d entries, %d bytes", label, storage->Data.Size, storage->Data.size_in_bytes())) + return; + for (int n = 0; n < storage->Data.Size; n++) + { + const ImGuiStorage::ImGuiStoragePair& p = storage->Data[n]; + BulletText("Key 0x%08X Value { i: %d }", p.key, p.val_i); // Important: we currently don't store a type, real value may not be integer. + } + TreePop(); +} + +// [DEBUG] Display contents of ImGuiTabBar +void ImGui::DebugNodeTabBar(ImGuiTabBar* tab_bar, const char* label) +{ + // Standalone tab bars (not associated to docking/windows functionality) currently hold no discernible strings. + char buf[256]; + char* p = buf; + const char* buf_end = buf + IM_ARRAYSIZE(buf); + const bool is_active = (tab_bar->PrevFrameVisible >= GetFrameCount() - 2); + p += ImFormatString(p, buf_end - p, "%s 0x%08X (%d tabs)%s", label, tab_bar->ID, tab_bar->Tabs.Size, is_active ? "" : " *Inactive*"); + p += ImFormatString(p, buf_end - p, " { "); + for (int tab_n = 0; tab_n < ImMin(tab_bar->Tabs.Size, 3); tab_n++) + { + ImGuiTabItem* tab = &tab_bar->Tabs[tab_n]; + p += ImFormatString(p, buf_end - p, "%s'%s'", + tab_n > 0 ? ", " : "", (tab->NameOffset != -1) ? tab_bar->GetTabName(tab) : "???"); + } + p += ImFormatString(p, buf_end - p, (tab_bar->Tabs.Size > 3) ? " ... }" : " } "); + if (!is_active) { PushStyleColor(ImGuiCol_Text, GetStyleColorVec4(ImGuiCol_TextDisabled)); } + bool open = TreeNode(label, "%s", buf); + if (!is_active) { PopStyleColor(); } + if (is_active && IsItemHovered()) + { + ImDrawList* draw_list = GetForegroundDrawList(); + draw_list->AddRect(tab_bar->BarRect.Min, tab_bar->BarRect.Max, IM_COL32(255, 255, 0, 255)); + draw_list->AddLine(ImVec2(tab_bar->ScrollingRectMinX, tab_bar->BarRect.Min.y), ImVec2(tab_bar->ScrollingRectMinX, tab_bar->BarRect.Max.y), IM_COL32(0, 255, 0, 255)); + draw_list->AddLine(ImVec2(tab_bar->ScrollingRectMaxX, tab_bar->BarRect.Min.y), ImVec2(tab_bar->ScrollingRectMaxX, tab_bar->BarRect.Max.y), IM_COL32(0, 255, 0, 255)); + } + if (open) + { + for (int tab_n = 0; tab_n < tab_bar->Tabs.Size; tab_n++) + { + const ImGuiTabItem* tab = &tab_bar->Tabs[tab_n]; + PushID(tab); + if (SmallButton("<")) { TabBarQueueReorder(tab_bar, tab, -1); } SameLine(0, 2); + if (SmallButton(">")) { TabBarQueueReorder(tab_bar, tab, +1); } SameLine(); + Text("%02d%c Tab 0x%08X '%s' Offset: %.1f, Width: %.1f/%.1f", + tab_n, (tab->ID == tab_bar->SelectedTabId) ? '*' : ' ', tab->ID, (tab->NameOffset != -1) ? tab_bar->GetTabName(tab) : "???", tab->Offset, tab->Width, tab->ContentWidth); + PopID(); + } + TreePop(); + } +} + +void ImGui::DebugNodeViewport(ImGuiViewportP* viewport) +{ + SetNextItemOpen(true, ImGuiCond_Once); + if (TreeNode("viewport0", "Viewport #%d", 0)) + { + ImGuiWindowFlags flags = viewport->Flags; + BulletText("Main Pos: (%.0f,%.0f), Size: (%.0f,%.0f)\nWorkArea Offset Left: %.0f Top: %.0f, Right: %.0f, Bottom: %.0f", + viewport->Pos.x, viewport->Pos.y, viewport->Size.x, viewport->Size.y, + viewport->WorkOffsetMin.x, viewport->WorkOffsetMin.y, viewport->WorkOffsetMax.x, viewport->WorkOffsetMax.y); + BulletText("Flags: 0x%04X =%s%s%s", viewport->Flags, + (flags & ImGuiViewportFlags_IsPlatformWindow) ? " IsPlatformWindow" : "", + (flags & ImGuiViewportFlags_IsPlatformMonitor) ? " IsPlatformMonitor" : "", + (flags & ImGuiViewportFlags_OwnedByApp) ? " OwnedByApp" : ""); + for (int layer_i = 0; layer_i < IM_ARRAYSIZE(viewport->DrawDataBuilder.Layers); layer_i++) + for (int draw_list_i = 0; draw_list_i < viewport->DrawDataBuilder.Layers[layer_i].Size; draw_list_i++) + DebugNodeDrawList(NULL, viewport->DrawDataBuilder.Layers[layer_i][draw_list_i], "DrawList"); + TreePop(); + } +} + +void ImGui::DebugNodeWindow(ImGuiWindow* window, const char* label) +{ + if (window == NULL) + { + BulletText("%s: NULL", label); + return; + } + + ImGuiContext& g = *GImGui; + const bool is_active = window->WasActive; + ImGuiTreeNodeFlags tree_node_flags = (window == g.NavWindow) ? ImGuiTreeNodeFlags_Selected : ImGuiTreeNodeFlags_None; + if (!is_active) { PushStyleColor(ImGuiCol_Text, GetStyleColorVec4(ImGuiCol_TextDisabled)); } + const bool open = TreeNodeEx(label, tree_node_flags, "%s '%s'%s", label, window->Name, is_active ? "" : " *Inactive*"); + if (!is_active) { PopStyleColor(); } + if (IsItemHovered() && is_active) + GetForegroundDrawList(window)->AddRect(window->Pos, window->Pos + window->Size, IM_COL32(255, 255, 0, 255)); + if (!open) + return; + + if (window->MemoryCompacted) + TextDisabled("Note: some memory buffers have been compacted/freed."); + + ImGuiWindowFlags flags = window->Flags; + DebugNodeDrawList(window, window->DrawList, "DrawList"); + BulletText("Pos: (%.1f,%.1f), Size: (%.1f,%.1f), ContentSize (%.1f,%.1f) Ideal (%.1f,%.1f)", window->Pos.x, window->Pos.y, window->Size.x, window->Size.y, window->ContentSize.x, window->ContentSize.y, window->ContentSizeIdeal.x, window->ContentSizeIdeal.y); + BulletText("Flags: 0x%08X (%s%s%s%s%s%s%s%s%s..)", flags, + (flags & ImGuiWindowFlags_ChildWindow) ? "Child " : "", (flags & ImGuiWindowFlags_Tooltip) ? "Tooltip " : "", (flags & ImGuiWindowFlags_Popup) ? "Popup " : "", + (flags & ImGuiWindowFlags_Modal) ? "Modal " : "", (flags & ImGuiWindowFlags_ChildMenu) ? "ChildMenu " : "", (flags & ImGuiWindowFlags_NoSavedSettings) ? "NoSavedSettings " : "", + (flags & ImGuiWindowFlags_NoMouseInputs)? "NoMouseInputs":"", (flags & ImGuiWindowFlags_NoNavInputs) ? "NoNavInputs" : "", (flags & ImGuiWindowFlags_AlwaysAutoResize) ? "AlwaysAutoResize" : ""); + BulletText("Scroll: (%.2f/%.2f,%.2f/%.2f) Scrollbar:%s%s", window->Scroll.x, window->ScrollMax.x, window->Scroll.y, window->ScrollMax.y, window->ScrollbarX ? "X" : "", window->ScrollbarY ? "Y" : ""); + BulletText("Active: %d/%d, WriteAccessed: %d, BeginOrderWithinContext: %d", window->Active, window->WasActive, window->WriteAccessed, (window->Active || window->WasActive) ? window->BeginOrderWithinContext : -1); + BulletText("Appearing: %d, Hidden: %d (CanSkip %d Cannot %d), SkipItems: %d", window->Appearing, window->Hidden, window->HiddenFramesCanSkipItems, window->HiddenFramesCannotSkipItems, window->SkipItems); + for (int layer = 0; layer < ImGuiNavLayer_COUNT; layer++) + { + ImRect r = window->NavRectRel[layer]; + if (r.Min.x >= r.Max.y && r.Min.y >= r.Max.y) + { + BulletText("NavLastIds[%d]: 0x%08X", layer, window->NavLastIds[layer]); + continue; + } + BulletText("NavLastIds[%d]: 0x%08X at +(%.1f,%.1f)(%.1f,%.1f)", layer, window->NavLastIds[layer], r.Min.x, r.Min.y, r.Max.x, r.Max.y); + if (IsItemHovered()) + GetForegroundDrawList(window)->AddRect(r.Min + window->Pos, r.Max + window->Pos, IM_COL32(255, 255, 0, 255)); + } + BulletText("NavLayersActiveMask: %X, NavLastChildNavWindow: %s", window->DC.NavLayersActiveMask, window->NavLastChildNavWindow ? window->NavLastChildNavWindow->Name : "NULL"); + if (window->RootWindow != window) { DebugNodeWindow(window->RootWindow, "RootWindow"); } + if (window->ParentWindow != NULL) { DebugNodeWindow(window->ParentWindow, "ParentWindow"); } + if (window->DC.ChildWindows.Size > 0) { DebugNodeWindowsList(&window->DC.ChildWindows, "ChildWindows"); } + if (window->ColumnsStorage.Size > 0 && TreeNode("Columns", "Columns sets (%d)", window->ColumnsStorage.Size)) + { + for (int n = 0; n < window->ColumnsStorage.Size; n++) + DebugNodeColumns(&window->ColumnsStorage[n]); + TreePop(); + } + DebugNodeStorage(&window->StateStorage, "Storage"); + TreePop(); +} + +void ImGui::DebugNodeWindowSettings(ImGuiWindowSettings* settings) +{ + Text("0x%08X \"%s\" Pos (%d,%d) Size (%d,%d) Collapsed=%d", + settings->ID, settings->GetName(), settings->Pos.x, settings->Pos.y, settings->Size.x, settings->Size.y, settings->Collapsed); +} + +void ImGui::DebugNodeWindowsList(ImVector* windows, const char* label) +{ + if (!TreeNode(label, "%s (%d)", label, windows->Size)) + return; + Text("(In front-to-back order:)"); + for (int i = windows->Size - 1; i >= 0; i--) // Iterate front to back + { + PushID((*windows)[i]); + DebugNodeWindow((*windows)[i], "Window"); + PopID(); + } + TreePop(); +} + +#else + +void ImGui::ShowMetricsWindow(bool*) {} +void ImGui::ShowFontAtlas(ImFontAtlas*) {} +void ImGui::DebugNodeColumns(ImGuiOldColumns*) {} +void ImGui::DebugNodeDrawList(ImGuiWindow*, const ImDrawList*, const char*) {} +void ImGui::DebugNodeDrawCmdShowMeshAndBoundingBox(ImDrawList*, const ImDrawList*, const ImDrawCmd*, bool, bool) {} +void ImGui::DebugNodeFont(ImFont*) {} +void ImGui::DebugNodeStorage(ImGuiStorage*, const char*) {} +void ImGui::DebugNodeTabBar(ImGuiTabBar*, const char*) {} +void ImGui::DebugNodeWindow(ImGuiWindow*, const char*) {} +void ImGui::DebugNodeWindowSettings(ImGuiWindowSettings*) {} +void ImGui::DebugNodeWindowsList(ImVector*, const char*) {} +void ImGui::DebugNodeViewport(ImGuiViewportP*) {} + +#endif + +//----------------------------------------------------------------------------- + +// Include imgui_user.inl at the end of imgui.cpp to access private data/functions that aren't exposed. +// Prefer just including imgui_internal.h from your code rather than using this define. If a declaration is missing from imgui_internal.h add it or request it on the github. +#ifdef IMGUI_INCLUDE_IMGUI_USER_INL +#include "imgui_user.inl" +#endif + +//----------------------------------------------------------------------------- + +#endif // #ifndef IMGUI_DISABLE diff --git a/source/editor/imgui/imgui.h b/source/editor/imgui/imgui.h new file mode 100644 index 0000000..3f107e4 --- /dev/null +++ b/source/editor/imgui/imgui.h @@ -0,0 +1,2906 @@ +// dear imgui, v1.85 WIP +// (headers) + +// Help: +// - Read FAQ at http://dearimgui.org/faq +// - Newcomers, read 'Programmer guide' in imgui.cpp for notes on how to setup Dear ImGui in your codebase. +// - Call and read ImGui::ShowDemoWindow() in imgui_demo.cpp. All applications in examples/ are doing that. +// Read imgui.cpp for details, links and comments. + +// Resources: +// - FAQ http://dearimgui.org/faq +// - Homepage & latest https://github.com/ocornut/imgui +// - Releases & changelog https://github.com/ocornut/imgui/releases +// - Gallery https://github.com/ocornut/imgui/issues/4451 (please post your screenshots/video there!) +// - Wiki https://github.com/ocornut/imgui/wiki (lots of good stuff there) +// - Glossary https://github.com/ocornut/imgui/wiki/Glossary +// - Issues & support https://github.com/ocornut/imgui/issues + +// Getting Started? +// - For first-time users having issues compiling/linking/running or issues loading fonts: +// please post in https://github.com/ocornut/imgui/discussions if you cannot find a solution in resources above. + +/* + +Index of this file: +// [SECTION] Header mess +// [SECTION] Forward declarations and basic types +// [SECTION] Dear ImGui end-user API functions +// [SECTION] Flags & Enumerations +// [SECTION] Helpers: Memory allocations macros, ImVector<> +// [SECTION] ImGuiStyle +// [SECTION] ImGuiIO +// [SECTION] Misc data structures (ImGuiInputTextCallbackData, ImGuiSizeCallbackData, ImGuiPayload, ImGuiTableSortSpecs, ImGuiTableColumnSortSpecs) +// [SECTION] Helpers (ImGuiOnceUponAFrame, ImGuiTextFilter, ImGuiTextBuffer, ImGuiStorage, ImGuiListClipper, ImColor) +// [SECTION] Drawing API (ImDrawCallback, ImDrawCmd, ImDrawIdx, ImDrawVert, ImDrawChannel, ImDrawListSplitter, ImDrawFlags, ImDrawListFlags, ImDrawList, ImDrawData) +// [SECTION] Font API (ImFontConfig, ImFontGlyph, ImFontGlyphRangesBuilder, ImFontAtlasFlags, ImFontAtlas, ImFont) +// [SECTION] Viewports (ImGuiViewportFlags, ImGuiViewport) +// [SECTION] Obsolete functions and types + +*/ + +#pragma once + +// Configuration file with compile-time options (edit imconfig.h or '#define IMGUI_USER_CONFIG "myfilename.h" from your build system') +#ifdef IMGUI_USER_CONFIG +#include IMGUI_USER_CONFIG +#endif +#if !defined(IMGUI_DISABLE_INCLUDE_IMCONFIG_H) || defined(IMGUI_INCLUDE_IMCONFIG_H) +#include "imconfig.h" +#endif + +#ifndef IMGUI_DISABLE + +//----------------------------------------------------------------------------- +// [SECTION] Header mess +//----------------------------------------------------------------------------- + +// Includes +#include // FLT_MIN, FLT_MAX +#include // va_list, va_start, va_end +#include // ptrdiff_t, NULL +#include // memset, memmove, memcpy, strlen, strchr, strcpy, strcmp + +// Version +// (Integer encoded as XYYZZ for use in #if preprocessor conditionals. Work in progress versions typically starts at XYY99 then bounce up to XYY00, XYY01 etc. when release tagging happens) +#define IMGUI_VERSION "1.85 WIP" +#define IMGUI_VERSION_NUM 18415 +#define IMGUI_CHECKVERSION() ImGui::DebugCheckVersionAndDataLayout(IMGUI_VERSION, sizeof(ImGuiIO), sizeof(ImGuiStyle), sizeof(ImVec2), sizeof(ImVec4), sizeof(ImDrawVert), sizeof(ImDrawIdx)) +#define IMGUI_HAS_TABLE + +// Define attributes of all API symbols declarations (e.g. for DLL under Windows) +// IMGUI_API is used for core imgui functions, IMGUI_IMPL_API is used for the default backends files (imgui_impl_xxx.h) +// Using dear imgui via a shared library is not recommended, because we don't guarantee backward nor forward ABI compatibility (also function call overhead, as dear imgui is a call-heavy API) +#ifndef IMGUI_API +#define IMGUI_API +#endif +#ifndef IMGUI_IMPL_API +#define IMGUI_IMPL_API IMGUI_API +#endif + +// Helper Macros +#ifndef IM_ASSERT +#include +#define IM_ASSERT(_EXPR) assert(_EXPR) // You can override the default assert handler by editing imconfig.h +#endif +#define IM_ARRAYSIZE(_ARR) ((int)(sizeof(_ARR) / sizeof(*(_ARR)))) // Size of a static C-style array. Don't use on pointers! +#define IM_UNUSED(_VAR) ((void)(_VAR)) // Used to silence "unused variable warnings". Often useful as asserts may be stripped out from final builds. +#if (__cplusplus >= 201100) || (defined(_MSVC_LANG) && _MSVC_LANG >= 201100) +#define IM_OFFSETOF(_TYPE,_MEMBER) offsetof(_TYPE, _MEMBER) // Offset of _MEMBER within _TYPE. Standardized as offsetof() in C++11 +#else +#define IM_OFFSETOF(_TYPE,_MEMBER) ((size_t)&(((_TYPE*)0)->_MEMBER)) // Offset of _MEMBER within _TYPE. Old style macro. +#endif + +// Helper Macros - IM_FMTARGS, IM_FMTLIST: Apply printf-style warnings to our formatting functions. +#if !defined(IMGUI_USE_STB_SPRINTF) && defined(__MINGW32__) +#define IM_FMTARGS(FMT) __attribute__((format(gnu_printf, FMT, FMT+1))) +#define IM_FMTLIST(FMT) __attribute__((format(gnu_printf, FMT, 0))) +#elif !defined(IMGUI_USE_STB_SPRINTF) && (defined(__clang__) || defined(__GNUC__)) +#define IM_FMTARGS(FMT) __attribute__((format(printf, FMT, FMT+1))) +#define IM_FMTLIST(FMT) __attribute__((format(printf, FMT, 0))) +#else +#define IM_FMTARGS(FMT) +#define IM_FMTLIST(FMT) +#endif + +// Disable some of MSVC most aggressive Debug runtime checks in function header/footer (used in some simple/low-level functions) +#if defined(_MSC_VER) && !defined(__clang__) && !defined(IMGUI_DEBUG_PARANOID) +#define IM_MSVC_RUNTIME_CHECKS_OFF __pragma(runtime_checks("",off)) __pragma(check_stack(off)) __pragma(strict_gs_check(push,off)) +#define IM_MSVC_RUNTIME_CHECKS_RESTORE __pragma(runtime_checks("",restore)) __pragma(check_stack()) __pragma(strict_gs_check(pop)) +#else +#define IM_MSVC_RUNTIME_CHECKS_OFF +#define IM_MSVC_RUNTIME_CHECKS_RESTORE +#endif + +// Warnings +#ifdef _MSC_VER +#pragma warning (push) +#pragma warning (disable: 26495) // [Static Analyzer] Variable 'XXX' is uninitialized. Always initialize a member variable (type.6). +#endif +#if defined(__clang__) +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wold-style-cast" +#if __has_warning("-Wzero-as-null-pointer-constant") +#pragma clang diagnostic ignored "-Wzero-as-null-pointer-constant" +#endif +#elif defined(__GNUC__) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wpragmas" // warning: unknown option after '#pragma GCC diagnostic' kind +#pragma GCC diagnostic ignored "-Wclass-memaccess" // [__GNUC__ >= 8] warning: 'memset/memcpy' clearing/writing an object of type 'xxxx' with no trivial copy-assignment; use assignment or value-initialization instead +#endif + +//----------------------------------------------------------------------------- +// [SECTION] Forward declarations and basic types +//----------------------------------------------------------------------------- + +// Forward declarations +struct ImDrawChannel; // Temporary storage to output draw commands out of order, used by ImDrawListSplitter and ImDrawList::ChannelsSplit() +struct ImDrawCmd; // A single draw command within a parent ImDrawList (generally maps to 1 GPU draw call, unless it is a callback) +struct ImDrawData; // All draw command lists required to render the frame + pos/size coordinates to use for the projection matrix. +struct ImDrawList; // A single draw command list (generally one per window, conceptually you may see this as a dynamic "mesh" builder) +struct ImDrawListSharedData; // Data shared among multiple draw lists (typically owned by parent ImGui context, but you may create one yourself) +struct ImDrawListSplitter; // Helper to split a draw list into different layers which can be drawn into out of order, then flattened back. +struct ImDrawVert; // A single vertex (pos + uv + col = 20 bytes by default. Override layout with IMGUI_OVERRIDE_DRAWVERT_STRUCT_LAYOUT) +struct ImFont; // Runtime data for a single font within a parent ImFontAtlas +struct ImFontAtlas; // Runtime data for multiple fonts, bake multiple fonts into a single texture, TTF/OTF font loader +struct ImFontBuilderIO; // Opaque interface to a font builder (stb_truetype or FreeType). +struct ImFontConfig; // Configuration data when adding a font or merging fonts +struct ImFontGlyph; // A single font glyph (code point + coordinates within in ImFontAtlas + offset) +struct ImFontGlyphRangesBuilder; // Helper to build glyph ranges from text/string data +struct ImColor; // Helper functions to create a color that can be converted to either u32 or float4 (*OBSOLETE* please avoid using) +struct ImGuiContext; // Dear ImGui context (opaque structure, unless including imgui_internal.h) +struct ImGuiIO; // Main configuration and I/O between your application and ImGui +struct ImGuiInputTextCallbackData; // Shared state of InputText() when using custom ImGuiInputTextCallback (rare/advanced use) +struct ImGuiListClipper; // Helper to manually clip large list of items +struct ImGuiOnceUponAFrame; // Helper for running a block of code not more than once a frame, used by IMGUI_ONCE_UPON_A_FRAME macro +struct ImGuiPayload; // User data payload for drag and drop operations +struct ImGuiSizeCallbackData; // Callback data when using SetNextWindowSizeConstraints() (rare/advanced use) +struct ImGuiStorage; // Helper for key->value storage +struct ImGuiStyle; // Runtime data for styling/colors +struct ImGuiTableSortSpecs; // Sorting specifications for a table (often handling sort specs for a single column, occasionally more) +struct ImGuiTableColumnSortSpecs; // Sorting specification for one column of a table +struct ImGuiTextBuffer; // Helper to hold and append into a text buffer (~string builder) +struct ImGuiTextFilter; // Helper to parse and apply text filters (e.g. "aaaaa[,bbbbb][,ccccc]") +struct ImGuiViewport; // A Platform Window (always only one in 'master' branch), in the future may represent Platform Monitor + +// Enums/Flags (declared as int for compatibility with old C++, to allow using as flags without overhead, and to not pollute the top of this file) +// - Tip: Use your programming IDE navigation facilities on the names in the _central column_ below to find the actual flags/enum lists! +// In Visual Studio IDE: CTRL+comma ("Edit.NavigateTo") can follow symbols in comments, whereas CTRL+F12 ("Edit.GoToImplementation") cannot. +// With Visual Assist installed: ALT+G ("VAssistX.GoToImplementation") can also follow symbols in comments. +typedef int ImGuiCol; // -> enum ImGuiCol_ // Enum: A color identifier for styling +typedef int ImGuiCond; // -> enum ImGuiCond_ // Enum: A condition for many Set*() functions +typedef int ImGuiDataType; // -> enum ImGuiDataType_ // Enum: A primary data type +typedef int ImGuiDir; // -> enum ImGuiDir_ // Enum: A cardinal direction +typedef int ImGuiKey; // -> enum ImGuiKey_ // Enum: A key identifier (ImGui-side enum) +typedef int ImGuiNavInput; // -> enum ImGuiNavInput_ // Enum: An input identifier for navigation +typedef int ImGuiMouseButton; // -> enum ImGuiMouseButton_ // Enum: A mouse button identifier (0=left, 1=right, 2=middle) +typedef int ImGuiMouseCursor; // -> enum ImGuiMouseCursor_ // Enum: A mouse cursor identifier +typedef int ImGuiSortDirection; // -> enum ImGuiSortDirection_ // Enum: A sorting direction (ascending or descending) +typedef int ImGuiStyleVar; // -> enum ImGuiStyleVar_ // Enum: A variable identifier for styling +typedef int ImGuiTableBgTarget; // -> enum ImGuiTableBgTarget_ // Enum: A color target for TableSetBgColor() +typedef int ImDrawFlags; // -> enum ImDrawFlags_ // Flags: for ImDrawList functions +typedef int ImDrawListFlags; // -> enum ImDrawListFlags_ // Flags: for ImDrawList instance +typedef int ImFontAtlasFlags; // -> enum ImFontAtlasFlags_ // Flags: for ImFontAtlas build +typedef int ImGuiBackendFlags; // -> enum ImGuiBackendFlags_ // Flags: for io.BackendFlags +typedef int ImGuiButtonFlags; // -> enum ImGuiButtonFlags_ // Flags: for InvisibleButton() +typedef int ImGuiColorEditFlags; // -> enum ImGuiColorEditFlags_ // Flags: for ColorEdit4(), ColorPicker4() etc. +typedef int ImGuiConfigFlags; // -> enum ImGuiConfigFlags_ // Flags: for io.ConfigFlags +typedef int ImGuiComboFlags; // -> enum ImGuiComboFlags_ // Flags: for BeginCombo() +typedef int ImGuiDragDropFlags; // -> enum ImGuiDragDropFlags_ // Flags: for BeginDragDropSource(), AcceptDragDropPayload() +typedef int ImGuiFocusedFlags; // -> enum ImGuiFocusedFlags_ // Flags: for IsWindowFocused() +typedef int ImGuiHoveredFlags; // -> enum ImGuiHoveredFlags_ // Flags: for IsItemHovered(), IsWindowHovered() etc. +typedef int ImGuiInputTextFlags; // -> enum ImGuiInputTextFlags_ // Flags: for InputText(), InputTextMultiline() +typedef int ImGuiKeyModFlags; // -> enum ImGuiKeyModFlags_ // Flags: for io.KeyMods (Ctrl/Shift/Alt/Super) +typedef int ImGuiPopupFlags; // -> enum ImGuiPopupFlags_ // Flags: for OpenPopup*(), BeginPopupContext*(), IsPopupOpen() +typedef int ImGuiSelectableFlags; // -> enum ImGuiSelectableFlags_ // Flags: for Selectable() +typedef int ImGuiSliderFlags; // -> enum ImGuiSliderFlags_ // Flags: for DragFloat(), DragInt(), SliderFloat(), SliderInt() etc. +typedef int ImGuiTabBarFlags; // -> enum ImGuiTabBarFlags_ // Flags: for BeginTabBar() +typedef int ImGuiTabItemFlags; // -> enum ImGuiTabItemFlags_ // Flags: for BeginTabItem() +typedef int ImGuiTableFlags; // -> enum ImGuiTableFlags_ // Flags: For BeginTable() +typedef int ImGuiTableColumnFlags; // -> enum ImGuiTableColumnFlags_// Flags: For TableSetupColumn() +typedef int ImGuiTableRowFlags; // -> enum ImGuiTableRowFlags_ // Flags: For TableNextRow() +typedef int ImGuiTreeNodeFlags; // -> enum ImGuiTreeNodeFlags_ // Flags: for TreeNode(), TreeNodeEx(), CollapsingHeader() +typedef int ImGuiViewportFlags; // -> enum ImGuiViewportFlags_ // Flags: for ImGuiViewport +typedef int ImGuiWindowFlags; // -> enum ImGuiWindowFlags_ // Flags: for Begin(), BeginChild() + +// ImTexture: user data for renderer backend to identify a texture [Compile-time configurable type] +// - To use something else than an opaque void* pointer: override with e.g. '#define ImTextureID MyTextureType*' in your imconfig.h file. +// - This can be whatever to you want it to be! read the FAQ about ImTextureID for details. +#ifndef ImTextureID +typedef void* ImTextureID; // Default: store a pointer or an integer fitting in a pointer (most renderer backends are ok with that) +#endif + +// ImDrawIdx: vertex index. [Compile-time configurable type] +// - To use 16-bit indices + allow large meshes: backend need to set 'io.BackendFlags |= ImGuiBackendFlags_RendererHasVtxOffset' and handle ImDrawCmd::VtxOffset (recommended). +// - To use 32-bit indices: override with '#define ImDrawIdx unsigned int' in your imconfig.h file. +#ifndef ImDrawIdx +typedef unsigned short ImDrawIdx; // Default: 16-bit (for maximum compatibility with renderer backends) +#endif + +// Scalar data types +typedef unsigned int ImGuiID;// A unique ID used by widgets (typically the result of hashing a stack of string) +typedef signed char ImS8; // 8-bit signed integer +typedef unsigned char ImU8; // 8-bit unsigned integer +typedef signed short ImS16; // 16-bit signed integer +typedef unsigned short ImU16; // 16-bit unsigned integer +typedef signed int ImS32; // 32-bit signed integer == int +typedef unsigned int ImU32; // 32-bit unsigned integer (often used to store packed colors) +#if defined(_MSC_VER) && !defined(__clang__) +typedef signed __int64 ImS64; // 64-bit signed integer (pre and post C++11 with Visual Studio) +typedef unsigned __int64 ImU64; // 64-bit unsigned integer (pre and post C++11 with Visual Studio) +#elif (defined(__clang__) || defined(__GNUC__)) && (__cplusplus < 201100) +#include +typedef int64_t ImS64; // 64-bit signed integer (pre C++11) +typedef uint64_t ImU64; // 64-bit unsigned integer (pre C++11) +#else +typedef signed long long ImS64; // 64-bit signed integer (post C++11) +typedef unsigned long long ImU64; // 64-bit unsigned integer (post C++11) +#endif + +// Character types +// (we generally use UTF-8 encoded string in the API. This is storage specifically for a decoded character used for keyboard input and display) +typedef unsigned short ImWchar16; // A single decoded U16 character/code point. We encode them as multi bytes UTF-8 when used in strings. +typedef unsigned int ImWchar32; // A single decoded U32 character/code point. We encode them as multi bytes UTF-8 when used in strings. +#ifdef IMGUI_USE_WCHAR32 // ImWchar [configurable type: override in imconfig.h with '#define IMGUI_USE_WCHAR32' to support Unicode planes 1-16] +typedef ImWchar32 ImWchar; +#else +typedef ImWchar16 ImWchar; +#endif + +// Callback and functions types +typedef int (*ImGuiInputTextCallback)(ImGuiInputTextCallbackData* data); // Callback function for ImGui::InputText() +typedef void (*ImGuiSizeCallback)(ImGuiSizeCallbackData* data); // Callback function for ImGui::SetNextWindowSizeConstraints() +typedef void* (*ImGuiMemAllocFunc)(size_t sz, void* user_data); // Function signature for ImGui::SetAllocatorFunctions() +typedef void (*ImGuiMemFreeFunc)(void* ptr, void* user_data); // Function signature for ImGui::SetAllocatorFunctions() + +// ImVec2: 2D vector used to store positions, sizes etc. [Compile-time configurable type] +// This is a frequently used type in the API. Consider using IM_VEC2_CLASS_EXTRA to create implicit cast from/to our preferred type. +IM_MSVC_RUNTIME_CHECKS_OFF +struct ImVec2 +{ + float x, y; + ImVec2() { x = y = 0.0f; } + ImVec2(float _x, float _y) { x = _x; y = _y; } + float operator[] (size_t idx) const { IM_ASSERT(idx <= 1); return (&x)[idx]; } // We very rarely use this [] operator, the assert overhead is fine. + float& operator[] (size_t idx) { IM_ASSERT(idx <= 1); return (&x)[idx]; } // We very rarely use this [] operator, the assert overhead is fine. +#ifdef IM_VEC2_CLASS_EXTRA + IM_VEC2_CLASS_EXTRA // Define additional constructors and implicit cast operators in imconfig.h to convert back and forth between your math types and ImVec2. +#endif +}; + +// ImVec4: 4D vector used to store clipping rectangles, colors etc. [Compile-time configurable type] +struct ImVec4 +{ + float x, y, z, w; + ImVec4() { x = y = z = w = 0.0f; } + ImVec4(float _x, float _y, float _z, float _w) { x = _x; y = _y; z = _z; w = _w; } +#ifdef IM_VEC4_CLASS_EXTRA + IM_VEC4_CLASS_EXTRA // Define additional constructors and implicit cast operators in imconfig.h to convert back and forth between your math types and ImVec4. +#endif +}; +IM_MSVC_RUNTIME_CHECKS_RESTORE + +//----------------------------------------------------------------------------- +// [SECTION] Dear ImGui end-user API functions +// (Note that ImGui:: being a namespace, you can add extra ImGui:: functions in your own separate file. Please don't modify imgui source files!) +//----------------------------------------------------------------------------- + +namespace ImGui +{ + // Context creation and access + // - Each context create its own ImFontAtlas by default. You may instance one yourself and pass it to CreateContext() to share a font atlas between contexts. + // - DLL users: heaps and globals are not shared across DLL boundaries! You will need to call SetCurrentContext() + SetAllocatorFunctions() + // for each static/DLL boundary you are calling from. Read "Context and Memory Allocators" section of imgui.cpp for details. + IMGUI_API ImGuiContext* CreateContext(ImFontAtlas* shared_font_atlas = NULL); + IMGUI_API void DestroyContext(ImGuiContext* ctx = NULL); // NULL = destroy current context + IMGUI_API ImGuiContext* GetCurrentContext(); + IMGUI_API void SetCurrentContext(ImGuiContext* ctx); + + // Main + IMGUI_API ImGuiIO& GetIO(); // access the IO structure (mouse/keyboard/gamepad inputs, time, various configuration options/flags) + IMGUI_API ImGuiStyle& GetStyle(); // access the Style structure (colors, sizes). Always use PushStyleCol(), PushStyleVar() to modify style mid-frame! + IMGUI_API void NewFrame(); // start a new Dear ImGui frame, you can submit any command from this point until Render()/EndFrame(). + IMGUI_API void EndFrame(); // ends the Dear ImGui frame. automatically called by Render(). If you don't need to render data (skipping rendering) you may call EndFrame() without Render()... but you'll have wasted CPU already! If you don't need to render, better to not create any windows and not call NewFrame() at all! + IMGUI_API void Render(); // ends the Dear ImGui frame, finalize the draw data. You can then get call GetDrawData(). + IMGUI_API ImDrawData* GetDrawData(); // valid after Render() and until the next call to NewFrame(). this is what you have to render. + + // Demo, Debug, Information + IMGUI_API void ShowDemoWindow(bool* p_open = NULL); // create Demo window. demonstrate most ImGui features. call this to learn about the library! try to make it always available in your application! + IMGUI_API void ShowMetricsWindow(bool* p_open = NULL); // create Metrics/Debugger window. display Dear ImGui internals: windows, draw commands, various internal state, etc. + IMGUI_API void ShowAboutWindow(bool* p_open = NULL); // create About window. display Dear ImGui version, credits and build/system information. + IMGUI_API void ShowStyleEditor(ImGuiStyle* ref = NULL); // add style editor block (not a window). you can pass in a reference ImGuiStyle structure to compare to, revert to and save to (else it uses the default style) + IMGUI_API bool ShowStyleSelector(const char* label); // add style selector block (not a window), essentially a combo listing the default styles. + IMGUI_API void ShowFontSelector(const char* label); // add font selector block (not a window), essentially a combo listing the loaded fonts. + IMGUI_API void ShowUserGuide(); // add basic help/info block (not a window): how to manipulate ImGui as a end-user (mouse/keyboard controls). + IMGUI_API const char* GetVersion(); // get the compiled version string e.g. "1.80 WIP" (essentially the value for IMGUI_VERSION from the compiled version of imgui.cpp) + + // Styles + IMGUI_API void StyleColorsDark(ImGuiStyle* dst = NULL); // new, recommended style (default) + IMGUI_API void StyleColorsLight(ImGuiStyle* dst = NULL); // best used with borders and a custom, thicker font + IMGUI_API void StyleColorsClassic(ImGuiStyle* dst = NULL); // classic imgui style + + // Windows + // - Begin() = push window to the stack and start appending to it. End() = pop window from the stack. + // - Passing 'bool* p_open != NULL' shows a window-closing widget in the upper-right corner of the window, + // which clicking will set the boolean to false when clicked. + // - You may append multiple times to the same window during the same frame by calling Begin()/End() pairs multiple times. + // Some information such as 'flags' or 'p_open' will only be considered by the first call to Begin(). + // - Begin() return false to indicate the window is collapsed or fully clipped, so you may early out and omit submitting + // anything to the window. Always call a matching End() for each Begin() call, regardless of its return value! + // [Important: due to legacy reason, this is inconsistent with most other functions such as BeginMenu/EndMenu, + // BeginPopup/EndPopup, etc. where the EndXXX call should only be called if the corresponding BeginXXX function + // returned true. Begin and BeginChild are the only odd ones out. Will be fixed in a future update.] + // - Note that the bottom of window stack always contains a window called "Debug". + IMGUI_API bool Begin(const char* name, bool* p_open = NULL, ImGuiWindowFlags flags = 0); + IMGUI_API void End(); + + // Child Windows + // - Use child windows to begin into a self-contained independent scrolling/clipping regions within a host window. Child windows can embed their own child. + // - For each independent axis of 'size': ==0.0f: use remaining host window size / >0.0f: fixed size / <0.0f: use remaining window size minus abs(size) / Each axis can use a different mode, e.g. ImVec2(0,400). + // - BeginChild() returns false to indicate the window is collapsed or fully clipped, so you may early out and omit submitting anything to the window. + // Always call a matching EndChild() for each BeginChild() call, regardless of its return value. + // [Important: due to legacy reason, this is inconsistent with most other functions such as BeginMenu/EndMenu, + // BeginPopup/EndPopup, etc. where the EndXXX call should only be called if the corresponding BeginXXX function + // returned true. Begin and BeginChild are the only odd ones out. Will be fixed in a future update.] + IMGUI_API bool BeginChild(const char* str_id, const ImVec2& size = ImVec2(0, 0), bool border = false, ImGuiWindowFlags flags = 0); + IMGUI_API bool BeginChild(ImGuiID id, const ImVec2& size = ImVec2(0, 0), bool border = false, ImGuiWindowFlags flags = 0); + IMGUI_API void EndChild(); + + // Windows Utilities + // - 'current window' = the window we are appending into while inside a Begin()/End() block. 'next window' = next window we will Begin() into. + IMGUI_API bool IsWindowAppearing(); + IMGUI_API bool IsWindowCollapsed(); + IMGUI_API bool IsWindowFocused(ImGuiFocusedFlags flags=0); // is current window focused? or its root/child, depending on flags. see flags for options. + IMGUI_API bool IsWindowHovered(ImGuiHoveredFlags flags=0); // is current window hovered (and typically: not blocked by a popup/modal)? see flags for options. NB: If you are trying to check whether your mouse should be dispatched to imgui or to your app, you should use the 'io.WantCaptureMouse' boolean for that! Please read the FAQ! + IMGUI_API ImDrawList* GetWindowDrawList(); // get draw list associated to the current window, to append your own drawing primitives + IMGUI_API ImVec2 GetWindowPos(); // get current window position in screen space (useful if you want to do your own drawing via the DrawList API) + IMGUI_API ImVec2 GetWindowSize(); // get current window size + IMGUI_API float GetWindowWidth(); // get current window width (shortcut for GetWindowSize().x) + IMGUI_API float GetWindowHeight(); // get current window height (shortcut for GetWindowSize().y) + + // Window manipulation + // - Prefer using SetNextXXX functions (before Begin) rather that SetXXX functions (after Begin). + IMGUI_API void SetNextWindowPos(const ImVec2& pos, ImGuiCond cond = 0, const ImVec2& pivot = ImVec2(0, 0)); // set next window position. call before Begin(). use pivot=(0.5f,0.5f) to center on given point, etc. + IMGUI_API void SetNextWindowSize(const ImVec2& size, ImGuiCond cond = 0); // set next window size. set axis to 0.0f to force an auto-fit on this axis. call before Begin() + IMGUI_API void SetNextWindowSizeConstraints(const ImVec2& size_min, const ImVec2& size_max, ImGuiSizeCallback custom_callback = NULL, void* custom_callback_data = NULL); // set next window size limits. use -1,-1 on either X/Y axis to preserve the current size. Sizes will be rounded down. Use callback to apply non-trivial programmatic constraints. + IMGUI_API void SetNextWindowContentSize(const ImVec2& size); // set next window content size (~ scrollable client area, which enforce the range of scrollbars). Not including window decorations (title bar, menu bar, etc.) nor WindowPadding. set an axis to 0.0f to leave it automatic. call before Begin() + IMGUI_API void SetNextWindowCollapsed(bool collapsed, ImGuiCond cond = 0); // set next window collapsed state. call before Begin() + IMGUI_API void SetNextWindowFocus(); // set next window to be focused / top-most. call before Begin() + IMGUI_API void SetNextWindowBgAlpha(float alpha); // set next window background color alpha. helper to easily override the Alpha component of ImGuiCol_WindowBg/ChildBg/PopupBg. you may also use ImGuiWindowFlags_NoBackground. + IMGUI_API void SetWindowPos(const ImVec2& pos, ImGuiCond cond = 0); // (not recommended) set current window position - call within Begin()/End(). prefer using SetNextWindowPos(), as this may incur tearing and side-effects. + IMGUI_API void SetWindowSize(const ImVec2& size, ImGuiCond cond = 0); // (not recommended) set current window size - call within Begin()/End(). set to ImVec2(0, 0) to force an auto-fit. prefer using SetNextWindowSize(), as this may incur tearing and minor side-effects. + IMGUI_API void SetWindowCollapsed(bool collapsed, ImGuiCond cond = 0); // (not recommended) set current window collapsed state. prefer using SetNextWindowCollapsed(). + IMGUI_API void SetWindowFocus(); // (not recommended) set current window to be focused / top-most. prefer using SetNextWindowFocus(). + IMGUI_API void SetWindowFontScale(float scale); // [OBSOLETE] set font scale. Adjust IO.FontGlobalScale if you want to scale all windows. This is an old API! For correct scaling, prefer to reload font + rebuild ImFontAtlas + call style.ScaleAllSizes(). + IMGUI_API void SetWindowPos(const char* name, const ImVec2& pos, ImGuiCond cond = 0); // set named window position. + IMGUI_API void SetWindowSize(const char* name, const ImVec2& size, ImGuiCond cond = 0); // set named window size. set axis to 0.0f to force an auto-fit on this axis. + IMGUI_API void SetWindowCollapsed(const char* name, bool collapsed, ImGuiCond cond = 0); // set named window collapsed state + IMGUI_API void SetWindowFocus(const char* name); // set named window to be focused / top-most. use NULL to remove focus. + + // Content region + // - Retrieve available space from a given point. GetContentRegionAvail() is frequently useful. + // - Those functions are bound to be redesigned (they are confusing, incomplete and the Min/Max return values are in local window coordinates which increases confusion) + IMGUI_API ImVec2 GetContentRegionAvail(); // == GetContentRegionMax() - GetCursorPos() + IMGUI_API ImVec2 GetContentRegionMax(); // current content boundaries (typically window boundaries including scrolling, or current column boundaries), in windows coordinates + IMGUI_API ImVec2 GetWindowContentRegionMin(); // content boundaries min for the full window (roughly (0,0)-Scroll), in window coordinates + IMGUI_API ImVec2 GetWindowContentRegionMax(); // content boundaries max for the full window (roughly (0,0)+Size-Scroll) where Size can be override with SetNextWindowContentSize(), in window coordinates + + // Windows Scrolling + IMGUI_API float GetScrollX(); // get scrolling amount [0 .. GetScrollMaxX()] + IMGUI_API float GetScrollY(); // get scrolling amount [0 .. GetScrollMaxY()] + IMGUI_API void SetScrollX(float scroll_x); // set scrolling amount [0 .. GetScrollMaxX()] + IMGUI_API void SetScrollY(float scroll_y); // set scrolling amount [0 .. GetScrollMaxY()] + IMGUI_API float GetScrollMaxX(); // get maximum scrolling amount ~~ ContentSize.x - WindowSize.x - DecorationsSize.x + IMGUI_API float GetScrollMaxY(); // get maximum scrolling amount ~~ ContentSize.y - WindowSize.y - DecorationsSize.y + IMGUI_API void SetScrollHereX(float center_x_ratio = 0.5f); // adjust scrolling amount to make current cursor position visible. center_x_ratio=0.0: left, 0.5: center, 1.0: right. When using to make a "default/current item" visible, consider using SetItemDefaultFocus() instead. + IMGUI_API void SetScrollHereY(float center_y_ratio = 0.5f); // adjust scrolling amount to make current cursor position visible. center_y_ratio=0.0: top, 0.5: center, 1.0: bottom. When using to make a "default/current item" visible, consider using SetItemDefaultFocus() instead. + IMGUI_API void SetScrollFromPosX(float local_x, float center_x_ratio = 0.5f); // adjust scrolling amount to make given position visible. Generally GetCursorStartPos() + offset to compute a valid position. + IMGUI_API void SetScrollFromPosY(float local_y, float center_y_ratio = 0.5f); // adjust scrolling amount to make given position visible. Generally GetCursorStartPos() + offset to compute a valid position. + + // Parameters stacks (shared) + IMGUI_API void PushFont(ImFont* font); // use NULL as a shortcut to push default font + IMGUI_API void PopFont(); + IMGUI_API void PushStyleColor(ImGuiCol idx, ImU32 col); // modify a style color. always use this if you modify the style after NewFrame(). + IMGUI_API void PushStyleColor(ImGuiCol idx, const ImVec4& col); + IMGUI_API void PopStyleColor(int count = 1); + IMGUI_API void PushStyleVar(ImGuiStyleVar idx, float val); // modify a style float variable. always use this if you modify the style after NewFrame(). + IMGUI_API void PushStyleVar(ImGuiStyleVar idx, const ImVec2& val); // modify a style ImVec2 variable. always use this if you modify the style after NewFrame(). + IMGUI_API void PopStyleVar(int count = 1); + IMGUI_API void PushAllowKeyboardFocus(bool allow_keyboard_focus); // == tab stop enable. Allow focusing using TAB/Shift-TAB, enabled by default but you can disable it for certain widgets + IMGUI_API void PopAllowKeyboardFocus(); + IMGUI_API void PushButtonRepeat(bool repeat); // in 'repeat' mode, Button*() functions return repeated true in a typematic manner (using io.KeyRepeatDelay/io.KeyRepeatRate setting). Note that you can call IsItemActive() after any Button() to tell if the button is held in the current frame. + IMGUI_API void PopButtonRepeat(); + + // Parameters stacks (current window) + IMGUI_API void PushItemWidth(float item_width); // push width of items for common large "item+label" widgets. >0.0f: width in pixels, <0.0f align xx pixels to the right of window (so -FLT_MIN always align width to the right side). + IMGUI_API void PopItemWidth(); + IMGUI_API void SetNextItemWidth(float item_width); // set width of the _next_ common large "item+label" widget. >0.0f: width in pixels, <0.0f align xx pixels to the right of window (so -FLT_MIN always align width to the right side) + IMGUI_API float CalcItemWidth(); // width of item given pushed settings and current cursor position. NOT necessarily the width of last item unlike most 'Item' functions. + IMGUI_API void PushTextWrapPos(float wrap_local_pos_x = 0.0f); // push word-wrapping position for Text*() commands. < 0.0f: no wrapping; 0.0f: wrap to end of window (or column); > 0.0f: wrap at 'wrap_pos_x' position in window local space + IMGUI_API void PopTextWrapPos(); + + // Style read access + // - Use the style editor (ShowStyleEditor() function) to interactively see what the colors are) + IMGUI_API ImFont* GetFont(); // get current font + IMGUI_API float GetFontSize(); // get current font size (= height in pixels) of current font with current scale applied + IMGUI_API ImVec2 GetFontTexUvWhitePixel(); // get UV coordinate for a while pixel, useful to draw custom shapes via the ImDrawList API + IMGUI_API ImU32 GetColorU32(ImGuiCol idx, float alpha_mul = 1.0f); // retrieve given style color with style alpha applied and optional extra alpha multiplier, packed as a 32-bit value suitable for ImDrawList + IMGUI_API ImU32 GetColorU32(const ImVec4& col); // retrieve given color with style alpha applied, packed as a 32-bit value suitable for ImDrawList + IMGUI_API ImU32 GetColorU32(ImU32 col); // retrieve given color with style alpha applied, packed as a 32-bit value suitable for ImDrawList + IMGUI_API const ImVec4& GetStyleColorVec4(ImGuiCol idx); // retrieve style color as stored in ImGuiStyle structure. use to feed back into PushStyleColor(), otherwise use GetColorU32() to get style color with style alpha baked in. + + // Cursor / Layout + // - By "cursor" we mean the current output position. + // - The typical widget behavior is to output themselves at the current cursor position, then move the cursor one line down. + // - You can call SameLine() between widgets to undo the last carriage return and output at the right of the preceding widget. + // - Attention! We currently have inconsistencies between window-local and absolute positions we will aim to fix with future API: + // Window-local coordinates: SameLine(), GetCursorPos(), SetCursorPos(), GetCursorStartPos(), GetContentRegionMax(), GetWindowContentRegion*(), PushTextWrapPos() + // Absolute coordinate: GetCursorScreenPos(), SetCursorScreenPos(), all ImDrawList:: functions. + IMGUI_API void Separator(); // separator, generally horizontal. inside a menu bar or in horizontal layout mode, this becomes a vertical separator. + IMGUI_API void SameLine(float offset_from_start_x=0.0f, float spacing=-1.0f); // call between widgets or groups to layout them horizontally. X position given in window coordinates. + IMGUI_API void NewLine(); // undo a SameLine() or force a new line when in an horizontal-layout context. + IMGUI_API void Spacing(); // add vertical spacing. + IMGUI_API void Dummy(const ImVec2& size); // add a dummy item of given size. unlike InvisibleButton(), Dummy() won't take the mouse click or be navigable into. + IMGUI_API void Indent(float indent_w = 0.0f); // move content position toward the right, by indent_w, or style.IndentSpacing if indent_w <= 0 + IMGUI_API void Unindent(float indent_w = 0.0f); // move content position back to the left, by indent_w, or style.IndentSpacing if indent_w <= 0 + IMGUI_API void BeginGroup(); // lock horizontal starting position + IMGUI_API void EndGroup(); // unlock horizontal starting position + capture the whole group bounding box into one "item" (so you can use IsItemHovered() or layout primitives such as SameLine() on whole group, etc.) + IMGUI_API ImVec2 GetCursorPos(); // cursor position in window coordinates (relative to window position) + IMGUI_API float GetCursorPosX(); // (some functions are using window-relative coordinates, such as: GetCursorPos, GetCursorStartPos, GetContentRegionMax, GetWindowContentRegion* etc. + IMGUI_API float GetCursorPosY(); // other functions such as GetCursorScreenPos or everything in ImDrawList:: + IMGUI_API void SetCursorPos(const ImVec2& local_pos); // are using the main, absolute coordinate system. + IMGUI_API void SetCursorPosX(float local_x); // GetWindowPos() + GetCursorPos() == GetCursorScreenPos() etc.) + IMGUI_API void SetCursorPosY(float local_y); // + IMGUI_API ImVec2 GetCursorStartPos(); // initial cursor position in window coordinates + IMGUI_API ImVec2 GetCursorScreenPos(); // cursor position in absolute coordinates (useful to work with ImDrawList API). generally top-left == GetMainViewport()->Pos == (0,0) in single viewport mode, and bottom-right == GetMainViewport()->Pos+Size == io.DisplaySize in single-viewport mode. + IMGUI_API void SetCursorScreenPos(const ImVec2& pos); // cursor position in absolute coordinates + IMGUI_API void AlignTextToFramePadding(); // vertically align upcoming text baseline to FramePadding.y so that it will align properly to regularly framed items (call if you have text on a line before a framed item) + IMGUI_API float GetTextLineHeight(); // ~ FontSize + IMGUI_API float GetTextLineHeightWithSpacing(); // ~ FontSize + style.ItemSpacing.y (distance in pixels between 2 consecutive lines of text) + IMGUI_API float GetFrameHeight(); // ~ FontSize + style.FramePadding.y * 2 + IMGUI_API float GetFrameHeightWithSpacing(); // ~ FontSize + style.FramePadding.y * 2 + style.ItemSpacing.y (distance in pixels between 2 consecutive lines of framed widgets) + + // ID stack/scopes + // Read the FAQ (docs/FAQ.md or http://dearimgui.org/faq) for more details about how ID are handled in dear imgui. + // - Those questions are answered and impacted by understanding of the ID stack system: + // - "Q: Why is my widget not reacting when I click on it?" + // - "Q: How can I have widgets with an empty label?" + // - "Q: How can I have multiple widgets with the same label?" + // - Short version: ID are hashes of the entire ID stack. If you are creating widgets in a loop you most likely + // want to push a unique identifier (e.g. object pointer, loop index) to uniquely differentiate them. + // - You can also use the "Label##foobar" syntax within widget label to distinguish them from each others. + // - In this header file we use the "label"/"name" terminology to denote a string that will be displayed + used as an ID, + // whereas "str_id" denote a string that is only used as an ID and not normally displayed. + IMGUI_API void PushID(const char* str_id); // push string into the ID stack (will hash string). + IMGUI_API void PushID(const char* str_id_begin, const char* str_id_end); // push string into the ID stack (will hash string). + IMGUI_API void PushID(const void* ptr_id); // push pointer into the ID stack (will hash pointer). + IMGUI_API void PushID(int int_id); // push integer into the ID stack (will hash integer). + IMGUI_API void PopID(); // pop from the ID stack. + IMGUI_API ImGuiID GetID(const char* str_id); // calculate unique ID (hash of whole ID stack + given parameter). e.g. if you want to query into ImGuiStorage yourself + IMGUI_API ImGuiID GetID(const char* str_id_begin, const char* str_id_end); + IMGUI_API ImGuiID GetID(const void* ptr_id); + + // Widgets: Text + IMGUI_API void TextUnformatted(const char* text, const char* text_end = NULL); // raw text without formatting. Roughly equivalent to Text("%s", text) but: A) doesn't require null terminated string if 'text_end' is specified, B) it's faster, no memory copy is done, no buffer size limits, recommended for long chunks of text. + IMGUI_API void Text(const char* fmt, ...) IM_FMTARGS(1); // formatted text + IMGUI_API void TextV(const char* fmt, va_list args) IM_FMTLIST(1); + IMGUI_API void TextColored(const ImVec4& col, const char* fmt, ...) IM_FMTARGS(2); // shortcut for PushStyleColor(ImGuiCol_Text, col); Text(fmt, ...); PopStyleColor(); + IMGUI_API void TextColoredV(const ImVec4& col, const char* fmt, va_list args) IM_FMTLIST(2); + IMGUI_API void TextDisabled(const char* fmt, ...) IM_FMTARGS(1); // shortcut for PushStyleColor(ImGuiCol_Text, style.Colors[ImGuiCol_TextDisabled]); Text(fmt, ...); PopStyleColor(); + IMGUI_API void TextDisabledV(const char* fmt, va_list args) IM_FMTLIST(1); + IMGUI_API void TextWrapped(const char* fmt, ...) IM_FMTARGS(1); // shortcut for PushTextWrapPos(0.0f); Text(fmt, ...); PopTextWrapPos();. Note that this won't work on an auto-resizing window if there's no other widgets to extend the window width, yoy may need to set a size using SetNextWindowSize(). + IMGUI_API void TextWrappedV(const char* fmt, va_list args) IM_FMTLIST(1); + IMGUI_API void LabelText(const char* label, const char* fmt, ...) IM_FMTARGS(2); // display text+label aligned the same way as value+label widgets + IMGUI_API void LabelTextV(const char* label, const char* fmt, va_list args) IM_FMTLIST(2); + IMGUI_API void BulletText(const char* fmt, ...) IM_FMTARGS(1); // shortcut for Bullet()+Text() + IMGUI_API void BulletTextV(const char* fmt, va_list args) IM_FMTLIST(1); + + // Widgets: Main + // - Most widgets return true when the value has been changed or when pressed/selected + // - You may also use one of the many IsItemXXX functions (e.g. IsItemActive, IsItemHovered, etc.) to query widget state. + IMGUI_API bool Button(const char* label, const ImVec2& size = ImVec2(0, 0)); // button + IMGUI_API bool SmallButton(const char* label); // button with FramePadding=(0,0) to easily embed within text + IMGUI_API bool InvisibleButton(const char* str_id, const ImVec2& size, ImGuiButtonFlags flags = 0); // flexible button behavior without the visuals, frequently useful to build custom behaviors using the public api (along with IsItemActive, IsItemHovered, etc.) + IMGUI_API bool ArrowButton(const char* str_id, ImGuiDir dir); // square button with an arrow shape + IMGUI_API void Image(ImTextureID user_texture_id, const ImVec2& size, const ImVec2& uv0 = ImVec2(0, 0), const ImVec2& uv1 = ImVec2(1,1), const ImVec4& tint_col = ImVec4(1,1,1,1), const ImVec4& border_col = ImVec4(0,0,0,0)); + IMGUI_API bool ImageButton(ImTextureID user_texture_id, const ImVec2& size, const ImVec2& uv0 = ImVec2(0, 0), const ImVec2& uv1 = ImVec2(1,1), int frame_padding = -1, const ImVec4& bg_col = ImVec4(0,0,0,0), const ImVec4& tint_col = ImVec4(1,1,1,1)); // <0 frame_padding uses default frame padding settings. 0 for no padding + IMGUI_API bool Checkbox(const char* label, bool* v); + IMGUI_API bool CheckboxFlags(const char* label, int* flags, int flags_value); + IMGUI_API bool CheckboxFlags(const char* label, unsigned int* flags, unsigned int flags_value); + IMGUI_API bool RadioButton(const char* label, bool active); // use with e.g. if (RadioButton("one", my_value==1)) { my_value = 1; } + IMGUI_API bool RadioButton(const char* label, int* v, int v_button); // shortcut to handle the above pattern when value is an integer + IMGUI_API void ProgressBar(float fraction, const ImVec2& size_arg = ImVec2(-FLT_MIN, 0), const char* overlay = NULL); + IMGUI_API void Bullet(); // draw a small circle + keep the cursor on the same line. advance cursor x position by GetTreeNodeToLabelSpacing(), same distance that TreeNode() uses + + // Widgets: Combo Box + // - The BeginCombo()/EndCombo() api allows you to manage your contents and selection state however you want it, by creating e.g. Selectable() items. + // - The old Combo() api are helpers over BeginCombo()/EndCombo() which are kept available for convenience purpose. This is analogous to how ListBox are created. + IMGUI_API bool BeginCombo(const char* label, const char* preview_value, ImGuiComboFlags flags = 0); + IMGUI_API void EndCombo(); // only call EndCombo() if BeginCombo() returns true! + IMGUI_API bool Combo(const char* label, int* current_item, const char* const items[], int items_count, int popup_max_height_in_items = -1); + IMGUI_API bool Combo(const char* label, int* current_item, const char* items_separated_by_zeros, int popup_max_height_in_items = -1); // Separate items with \0 within a string, end item-list with \0\0. e.g. "One\0Two\0Three\0" + IMGUI_API bool Combo(const char* label, int* current_item, bool(*items_getter)(void* data, int idx, const char** out_text), void* data, int items_count, int popup_max_height_in_items = -1); + + // Widgets: Drag Sliders + // - CTRL+Click on any drag box to turn them into an input box. Manually input values aren't clamped and can go off-bounds. + // - For all the Float2/Float3/Float4/Int2/Int3/Int4 versions of every functions, note that a 'float v[X]' function argument is the same as 'float* v', the array syntax is just a way to document the number of elements that are expected to be accessible. You can pass address of your first element out of a contiguous set, e.g. &myvector.x + // - Adjust format string to decorate the value with a prefix, a suffix, or adapt the editing and display precision e.g. "%.3f" -> 1.234; "%5.2f secs" -> 01.23 secs; "Biscuit: %.0f" -> Biscuit: 1; etc. + // - Format string may also be set to NULL or use the default format ("%f" or "%d"). + // - Speed are per-pixel of mouse movement (v_speed=0.2f: mouse needs to move by 5 pixels to increase value by 1). For gamepad/keyboard navigation, minimum speed is Max(v_speed, minimum_step_at_given_precision). + // - Use v_min < v_max to clamp edits to given limits. Note that CTRL+Click manual input can override those limits. + // - Use v_max = FLT_MAX / INT_MAX etc to avoid clamping to a maximum, same with v_min = -FLT_MAX / INT_MIN to avoid clamping to a minimum. + // - We use the same sets of flags for DragXXX() and SliderXXX() functions as the features are the same and it makes it easier to swap them. + // - Legacy: Pre-1.78 there are DragXXX() function signatures that takes a final `float power=1.0f' argument instead of the `ImGuiSliderFlags flags=0' argument. + // If you get a warning converting a float to ImGuiSliderFlags, read https://github.com/ocornut/imgui/issues/3361 + IMGUI_API bool DragFloat(const char* label, float* v, float v_speed = 1.0f, float v_min = 0.0f, float v_max = 0.0f, const char* format = "%.3f", ImGuiSliderFlags flags = 0); // If v_min >= v_max we have no bound + IMGUI_API bool DragFloat2(const char* label, float v[2], float v_speed = 1.0f, float v_min = 0.0f, float v_max = 0.0f, const char* format = "%.3f", ImGuiSliderFlags flags = 0); + IMGUI_API bool DragFloat3(const char* label, float v[3], float v_speed = 1.0f, float v_min = 0.0f, float v_max = 0.0f, const char* format = "%.3f", ImGuiSliderFlags flags = 0); + IMGUI_API bool DragFloat4(const char* label, float v[4], float v_speed = 1.0f, float v_min = 0.0f, float v_max = 0.0f, const char* format = "%.3f", ImGuiSliderFlags flags = 0); + IMGUI_API bool DragFloatRange2(const char* label, float* v_current_min, float* v_current_max, float v_speed = 1.0f, float v_min = 0.0f, float v_max = 0.0f, const char* format = "%.3f", const char* format_max = NULL, ImGuiSliderFlags flags = 0); + IMGUI_API bool DragInt(const char* label, int* v, float v_speed = 1.0f, int v_min = 0, int v_max = 0, const char* format = "%d", ImGuiSliderFlags flags = 0); // If v_min >= v_max we have no bound + IMGUI_API bool DragInt2(const char* label, int v[2], float v_speed = 1.0f, int v_min = 0, int v_max = 0, const char* format = "%d", ImGuiSliderFlags flags = 0); + IMGUI_API bool DragInt3(const char* label, int v[3], float v_speed = 1.0f, int v_min = 0, int v_max = 0, const char* format = "%d", ImGuiSliderFlags flags = 0); + IMGUI_API bool DragInt4(const char* label, int v[4], float v_speed = 1.0f, int v_min = 0, int v_max = 0, const char* format = "%d", ImGuiSliderFlags flags = 0); + IMGUI_API bool DragIntRange2(const char* label, int* v_current_min, int* v_current_max, float v_speed = 1.0f, int v_min = 0, int v_max = 0, const char* format = "%d", const char* format_max = NULL, ImGuiSliderFlags flags = 0); + IMGUI_API bool DragScalar(const char* label, ImGuiDataType data_type, void* p_data, float v_speed = 1.0f, const void* p_min = NULL, const void* p_max = NULL, const char* format = NULL, ImGuiSliderFlags flags = 0); + IMGUI_API bool DragScalarN(const char* label, ImGuiDataType data_type, void* p_data, int components, float v_speed = 1.0f, const void* p_min = NULL, const void* p_max = NULL, const char* format = NULL, ImGuiSliderFlags flags = 0); + + // Widgets: Regular Sliders + // - CTRL+Click on any slider to turn them into an input box. Manually input values aren't clamped and can go off-bounds. + // - Adjust format string to decorate the value with a prefix, a suffix, or adapt the editing and display precision e.g. "%.3f" -> 1.234; "%5.2f secs" -> 01.23 secs; "Biscuit: %.0f" -> Biscuit: 1; etc. + // - Format string may also be set to NULL or use the default format ("%f" or "%d"). + // - Legacy: Pre-1.78 there are SliderXXX() function signatures that takes a final `float power=1.0f' argument instead of the `ImGuiSliderFlags flags=0' argument. + // If you get a warning converting a float to ImGuiSliderFlags, read https://github.com/ocornut/imgui/issues/3361 + IMGUI_API bool SliderFloat(const char* label, float* v, float v_min, float v_max, const char* format = "%.3f", ImGuiSliderFlags flags = 0); // adjust format to decorate the value with a prefix or a suffix for in-slider labels or unit display. + IMGUI_API bool SliderFloat2(const char* label, float v[2], float v_min, float v_max, const char* format = "%.3f", ImGuiSliderFlags flags = 0); + IMGUI_API bool SliderFloat3(const char* label, float v[3], float v_min, float v_max, const char* format = "%.3f", ImGuiSliderFlags flags = 0); + IMGUI_API bool SliderFloat4(const char* label, float v[4], float v_min, float v_max, const char* format = "%.3f", ImGuiSliderFlags flags = 0); + IMGUI_API bool SliderAngle(const char* label, float* v_rad, float v_degrees_min = -360.0f, float v_degrees_max = +360.0f, const char* format = "%.0f deg", ImGuiSliderFlags flags = 0); + IMGUI_API bool SliderInt(const char* label, int* v, int v_min, int v_max, const char* format = "%d", ImGuiSliderFlags flags = 0); + IMGUI_API bool SliderInt2(const char* label, int v[2], int v_min, int v_max, const char* format = "%d", ImGuiSliderFlags flags = 0); + IMGUI_API bool SliderInt3(const char* label, int v[3], int v_min, int v_max, const char* format = "%d", ImGuiSliderFlags flags = 0); + IMGUI_API bool SliderInt4(const char* label, int v[4], int v_min, int v_max, const char* format = "%d", ImGuiSliderFlags flags = 0); + IMGUI_API bool SliderScalar(const char* label, ImGuiDataType data_type, void* p_data, const void* p_min, const void* p_max, const char* format = NULL, ImGuiSliderFlags flags = 0); + IMGUI_API bool SliderScalarN(const char* label, ImGuiDataType data_type, void* p_data, int components, const void* p_min, const void* p_max, const char* format = NULL, ImGuiSliderFlags flags = 0); + IMGUI_API bool VSliderFloat(const char* label, const ImVec2& size, float* v, float v_min, float v_max, const char* format = "%.3f", ImGuiSliderFlags flags = 0); + IMGUI_API bool VSliderInt(const char* label, const ImVec2& size, int* v, int v_min, int v_max, const char* format = "%d", ImGuiSliderFlags flags = 0); + IMGUI_API bool VSliderScalar(const char* label, const ImVec2& size, ImGuiDataType data_type, void* p_data, const void* p_min, const void* p_max, const char* format = NULL, ImGuiSliderFlags flags = 0); + + // Widgets: Input with Keyboard + // - If you want to use InputText() with std::string or any custom dynamic string type, see misc/cpp/imgui_stdlib.h and comments in imgui_demo.cpp. + // - Most of the ImGuiInputTextFlags flags are only useful for InputText() and not for InputFloatX, InputIntX, InputDouble etc. + IMGUI_API bool InputText(const char* label, char* buf, size_t buf_size, ImGuiInputTextFlags flags = 0, ImGuiInputTextCallback callback = NULL, void* user_data = NULL); + IMGUI_API bool InputTextMultiline(const char* label, char* buf, size_t buf_size, const ImVec2& size = ImVec2(0, 0), ImGuiInputTextFlags flags = 0, ImGuiInputTextCallback callback = NULL, void* user_data = NULL); + IMGUI_API bool InputTextWithHint(const char* label, const char* hint, char* buf, size_t buf_size, ImGuiInputTextFlags flags = 0, ImGuiInputTextCallback callback = NULL, void* user_data = NULL); + IMGUI_API bool InputFloat(const char* label, float* v, float step = 0.0f, float step_fast = 0.0f, const char* format = "%.3f", ImGuiInputTextFlags flags = 0); + IMGUI_API bool InputFloat2(const char* label, float v[2], const char* format = "%.3f", ImGuiInputTextFlags flags = 0); + IMGUI_API bool InputFloat3(const char* label, float v[3], const char* format = "%.3f", ImGuiInputTextFlags flags = 0); + IMGUI_API bool InputFloat4(const char* label, float v[4], const char* format = "%.3f", ImGuiInputTextFlags flags = 0); + IMGUI_API bool InputInt(const char* label, int* v, int step = 1, int step_fast = 100, ImGuiInputTextFlags flags = 0); + IMGUI_API bool InputInt2(const char* label, int v[2], ImGuiInputTextFlags flags = 0); + IMGUI_API bool InputInt3(const char* label, int v[3], ImGuiInputTextFlags flags = 0); + IMGUI_API bool InputInt4(const char* label, int v[4], ImGuiInputTextFlags flags = 0); + IMGUI_API bool InputDouble(const char* label, double* v, double step = 0.0, double step_fast = 0.0, const char* format = "%.6f", ImGuiInputTextFlags flags = 0); + IMGUI_API bool InputScalar(const char* label, ImGuiDataType data_type, void* p_data, const void* p_step = NULL, const void* p_step_fast = NULL, const char* format = NULL, ImGuiInputTextFlags flags = 0); + IMGUI_API bool InputScalarN(const char* label, ImGuiDataType data_type, void* p_data, int components, const void* p_step = NULL, const void* p_step_fast = NULL, const char* format = NULL, ImGuiInputTextFlags flags = 0); + + // Widgets: Color Editor/Picker (tip: the ColorEdit* functions have a little color square that can be left-clicked to open a picker, and right-clicked to open an option menu.) + // - Note that in C++ a 'float v[X]' function argument is the _same_ as 'float* v', the array syntax is just a way to document the number of elements that are expected to be accessible. + // - You can pass the address of a first float element out of a contiguous structure, e.g. &myvector.x + IMGUI_API bool ColorEdit3(const char* label, float col[3], ImGuiColorEditFlags flags = 0); + IMGUI_API bool ColorEdit4(const char* label, float col[4], ImGuiColorEditFlags flags = 0); + IMGUI_API bool ColorPicker3(const char* label, float col[3], ImGuiColorEditFlags flags = 0); + IMGUI_API bool ColorPicker4(const char* label, float col[4], ImGuiColorEditFlags flags = 0, const float* ref_col = NULL); + IMGUI_API bool ColorButton(const char* desc_id, const ImVec4& col, ImGuiColorEditFlags flags = 0, ImVec2 size = ImVec2(0, 0)); // display a color square/button, hover for details, return true when pressed. + IMGUI_API void SetColorEditOptions(ImGuiColorEditFlags flags); // initialize current options (generally on application startup) if you want to select a default format, picker type, etc. User will be able to change many settings, unless you pass the _NoOptions flag to your calls. + + // Widgets: Trees + // - TreeNode functions return true when the node is open, in which case you need to also call TreePop() when you are finished displaying the tree node contents. + IMGUI_API bool TreeNode(const char* label); + IMGUI_API bool TreeNode(const char* str_id, const char* fmt, ...) IM_FMTARGS(2); // helper variation to easily decorelate the id from the displayed string. Read the FAQ about why and how to use ID. to align arbitrary text at the same level as a TreeNode() you can use Bullet(). + IMGUI_API bool TreeNode(const void* ptr_id, const char* fmt, ...) IM_FMTARGS(2); // " + IMGUI_API bool TreeNodeV(const char* str_id, const char* fmt, va_list args) IM_FMTLIST(2); + IMGUI_API bool TreeNodeV(const void* ptr_id, const char* fmt, va_list args) IM_FMTLIST(2); + IMGUI_API bool TreeNodeEx(const char* label, ImGuiTreeNodeFlags flags = 0); + IMGUI_API bool TreeNodeEx(const char* str_id, ImGuiTreeNodeFlags flags, const char* fmt, ...) IM_FMTARGS(3); + IMGUI_API bool TreeNodeEx(const void* ptr_id, ImGuiTreeNodeFlags flags, const char* fmt, ...) IM_FMTARGS(3); + IMGUI_API bool TreeNodeExV(const char* str_id, ImGuiTreeNodeFlags flags, const char* fmt, va_list args) IM_FMTLIST(3); + IMGUI_API bool TreeNodeExV(const void* ptr_id, ImGuiTreeNodeFlags flags, const char* fmt, va_list args) IM_FMTLIST(3); + IMGUI_API void TreePush(const char* str_id); // ~ Indent()+PushId(). Already called by TreeNode() when returning true, but you can call TreePush/TreePop yourself if desired. + IMGUI_API void TreePush(const void* ptr_id = NULL); // " + IMGUI_API void TreePop(); // ~ Unindent()+PopId() + IMGUI_API float GetTreeNodeToLabelSpacing(); // horizontal distance preceding label when using TreeNode*() or Bullet() == (g.FontSize + style.FramePadding.x*2) for a regular unframed TreeNode + IMGUI_API bool CollapsingHeader(const char* label, ImGuiTreeNodeFlags flags = 0); // if returning 'true' the header is open. doesn't indent nor push on ID stack. user doesn't have to call TreePop(). + IMGUI_API bool CollapsingHeader(const char* label, bool* p_visible, ImGuiTreeNodeFlags flags = 0); // when 'p_visible != NULL': if '*p_visible==true' display an additional small close button on upper right of the header which will set the bool to false when clicked, if '*p_visible==false' don't display the header. + IMGUI_API void SetNextItemOpen(bool is_open, ImGuiCond cond = 0); // set next TreeNode/CollapsingHeader open state. + + // Widgets: Selectables + // - A selectable highlights when hovered, and can display another color when selected. + // - Neighbors selectable extend their highlight bounds in order to leave no gap between them. This is so a series of selected Selectable appear contiguous. + IMGUI_API bool Selectable(const char* label, bool selected = false, ImGuiSelectableFlags flags = 0, const ImVec2& size = ImVec2(0, 0)); // "bool selected" carry the selection state (read-only). Selectable() is clicked is returns true so you can modify your selection state. size.x==0.0: use remaining width, size.x>0.0: specify width. size.y==0.0: use label height, size.y>0.0: specify height + IMGUI_API bool Selectable(const char* label, bool* p_selected, ImGuiSelectableFlags flags = 0, const ImVec2& size = ImVec2(0, 0)); // "bool* p_selected" point to the selection state (read-write), as a convenient helper. + + // Widgets: List Boxes + // - This is essentially a thin wrapper to using BeginChild/EndChild with some stylistic changes. + // - The BeginListBox()/EndListBox() api allows you to manage your contents and selection state however you want it, by creating e.g. Selectable() or any items. + // - The simplified/old ListBox() api are helpers over BeginListBox()/EndListBox() which are kept available for convenience purpose. This is analoguous to how Combos are created. + // - Choose frame width: size.x > 0.0f: custom / size.x < 0.0f or -FLT_MIN: right-align / size.x = 0.0f (default): use current ItemWidth + // - Choose frame height: size.y > 0.0f: custom / size.y < 0.0f or -FLT_MIN: bottom-align / size.y = 0.0f (default): arbitrary default height which can fit ~7 items + IMGUI_API bool BeginListBox(const char* label, const ImVec2& size = ImVec2(0, 0)); // open a framed scrolling region + IMGUI_API void EndListBox(); // only call EndListBox() if BeginListBox() returned true! + IMGUI_API bool ListBox(const char* label, int* current_item, const char* const items[], int items_count, int height_in_items = -1); + IMGUI_API bool ListBox(const char* label, int* current_item, bool (*items_getter)(void* data, int idx, const char** out_text), void* data, int items_count, int height_in_items = -1); + + // Widgets: Data Plotting + // - Consider using ImPlot (https://github.com/epezent/implot) which is much better! + IMGUI_API void PlotLines(const char* label, const float* values, int values_count, int values_offset = 0, const char* overlay_text = NULL, float scale_min = FLT_MAX, float scale_max = FLT_MAX, ImVec2 graph_size = ImVec2(0, 0), int stride = sizeof(float)); + IMGUI_API void PlotLines(const char* label, float(*values_getter)(void* data, int idx), void* data, int values_count, int values_offset = 0, const char* overlay_text = NULL, float scale_min = FLT_MAX, float scale_max = FLT_MAX, ImVec2 graph_size = ImVec2(0, 0)); + IMGUI_API void PlotHistogram(const char* label, const float* values, int values_count, int values_offset = 0, const char* overlay_text = NULL, float scale_min = FLT_MAX, float scale_max = FLT_MAX, ImVec2 graph_size = ImVec2(0, 0), int stride = sizeof(float)); + IMGUI_API void PlotHistogram(const char* label, float(*values_getter)(void* data, int idx), void* data, int values_count, int values_offset = 0, const char* overlay_text = NULL, float scale_min = FLT_MAX, float scale_max = FLT_MAX, ImVec2 graph_size = ImVec2(0, 0)); + + // Widgets: Value() Helpers. + // - Those are merely shortcut to calling Text() with a format string. Output single value in "name: value" format (tip: freely declare more in your code to handle your types. you can add functions to the ImGui namespace) + IMGUI_API void Value(const char* prefix, bool b); + IMGUI_API void Value(const char* prefix, int v); + IMGUI_API void Value(const char* prefix, unsigned int v); + IMGUI_API void Value(const char* prefix, float v, const char* float_format = NULL); + + // Widgets: Menus + // - Use BeginMenuBar() on a window ImGuiWindowFlags_MenuBar to append to its menu bar. + // - Use BeginMainMenuBar() to create a menu bar at the top of the screen and append to it. + // - Use BeginMenu() to create a menu. You can call BeginMenu() multiple time with the same identifier to append more items to it. + // - Not that MenuItem() keyboardshortcuts are displayed as a convenience but _not processed_ by Dear ImGui at the moment. + IMGUI_API bool BeginMenuBar(); // append to menu-bar of current window (requires ImGuiWindowFlags_MenuBar flag set on parent window). + IMGUI_API void EndMenuBar(); // only call EndMenuBar() if BeginMenuBar() returns true! + IMGUI_API bool BeginMainMenuBar(); // create and append to a full screen menu-bar. + IMGUI_API void EndMainMenuBar(); // only call EndMainMenuBar() if BeginMainMenuBar() returns true! + IMGUI_API bool BeginMenu(const char* label, bool enabled = true); // create a sub-menu entry. only call EndMenu() if this returns true! + IMGUI_API void EndMenu(); // only call EndMenu() if BeginMenu() returns true! + IMGUI_API bool MenuItem(const char* label, const char* shortcut = NULL, bool selected = false, bool enabled = true); // return true when activated. + IMGUI_API bool MenuItem(const char* label, const char* shortcut, bool* p_selected, bool enabled = true); // return true when activated + toggle (*p_selected) if p_selected != NULL + + // Tooltips + // - Tooltip are windows following the mouse. They do not take focus away. + IMGUI_API void BeginTooltip(); // begin/append a tooltip window. to create full-featured tooltip (with any kind of items). + IMGUI_API void EndTooltip(); + IMGUI_API void SetTooltip(const char* fmt, ...) IM_FMTARGS(1); // set a text-only tooltip, typically use with ImGui::IsItemHovered(). override any previous call to SetTooltip(). + IMGUI_API void SetTooltipV(const char* fmt, va_list args) IM_FMTLIST(1); + + // Popups, Modals + // - They block normal mouse hovering detection (and therefore most mouse interactions) behind them. + // - If not modal: they can be closed by clicking anywhere outside them, or by pressing ESCAPE. + // - Their visibility state (~bool) is held internally instead of being held by the programmer as we are used to with regular Begin*() calls. + // - The 3 properties above are related: we need to retain popup visibility state in the library because popups may be closed as any time. + // - You can bypass the hovering restriction by using ImGuiHoveredFlags_AllowWhenBlockedByPopup when calling IsItemHovered() or IsWindowHovered(). + // - IMPORTANT: Popup identifiers are relative to the current ID stack, so OpenPopup and BeginPopup generally needs to be at the same level of the stack. + // This is sometimes leading to confusing mistakes. May rework this in the future. + + // Popups: begin/end functions + // - BeginPopup(): query popup state, if open start appending into the window. Call EndPopup() afterwards. ImGuiWindowFlags are forwarded to the window. + // - BeginPopupModal(): block every interactions behind the window, cannot be closed by user, add a dimming background, has a title bar. + IMGUI_API bool BeginPopup(const char* str_id, ImGuiWindowFlags flags = 0); // return true if the popup is open, and you can start outputting to it. + IMGUI_API bool BeginPopupModal(const char* name, bool* p_open = NULL, ImGuiWindowFlags flags = 0); // return true if the modal is open, and you can start outputting to it. + IMGUI_API void EndPopup(); // only call EndPopup() if BeginPopupXXX() returns true! + + // Popups: open/close functions + // - OpenPopup(): set popup state to open. ImGuiPopupFlags are available for opening options. + // - If not modal: they can be closed by clicking anywhere outside them, or by pressing ESCAPE. + // - CloseCurrentPopup(): use inside the BeginPopup()/EndPopup() scope to close manually. + // - CloseCurrentPopup() is called by default by Selectable()/MenuItem() when activated (FIXME: need some options). + // - Use ImGuiPopupFlags_NoOpenOverExistingPopup to avoid opening a popup if there's already one at the same level. This is equivalent to e.g. testing for !IsAnyPopupOpen() prior to OpenPopup(). + // - Use IsWindowAppearing() after BeginPopup() to tell if a window just opened. + IMGUI_API void OpenPopup(const char* str_id, ImGuiPopupFlags popup_flags = 0); // call to mark popup as open (don't call every frame!). + IMGUI_API void OpenPopup(ImGuiID id, ImGuiPopupFlags popup_flags = 0); // id overload to facilitate calling from nested stacks + IMGUI_API void OpenPopupOnItemClick(const char* str_id = NULL, ImGuiPopupFlags popup_flags = 1); // helper to open popup when clicked on last item. Default to ImGuiPopupFlags_MouseButtonRight == 1. (note: actually triggers on the mouse _released_ event to be consistent with popup behaviors) + IMGUI_API void CloseCurrentPopup(); // manually close the popup we have begin-ed into. + + // Popups: open+begin combined functions helpers + // - Helpers to do OpenPopup+BeginPopup where the Open action is triggered by e.g. hovering an item and right-clicking. + // - They are convenient to easily create context menus, hence the name. + // - IMPORTANT: Notice that BeginPopupContextXXX takes ImGuiPopupFlags just like OpenPopup() and unlike BeginPopup(). For full consistency, we may add ImGuiWindowFlags to the BeginPopupContextXXX functions in the future. + // - IMPORTANT: we exceptionally default their flags to 1 (== ImGuiPopupFlags_MouseButtonRight) for backward compatibility with older API taking 'int mouse_button = 1' parameter, so if you add other flags remember to re-add the ImGuiPopupFlags_MouseButtonRight. + IMGUI_API bool BeginPopupContextItem(const char* str_id = NULL, ImGuiPopupFlags popup_flags = 1); // open+begin popup when clicked on last item. Use str_id==NULL to associate the popup to previous item. If you want to use that on a non-interactive item such as Text() you need to pass in an explicit ID here. read comments in .cpp! + IMGUI_API bool BeginPopupContextWindow(const char* str_id = NULL, ImGuiPopupFlags popup_flags = 1);// open+begin popup when clicked on current window. + IMGUI_API bool BeginPopupContextVoid(const char* str_id = NULL, ImGuiPopupFlags popup_flags = 1); // open+begin popup when clicked in void (where there are no windows). + + // Popups: query functions + // - IsPopupOpen(): return true if the popup is open at the current BeginPopup() level of the popup stack. + // - IsPopupOpen() with ImGuiPopupFlags_AnyPopupId: return true if any popup is open at the current BeginPopup() level of the popup stack. + // - IsPopupOpen() with ImGuiPopupFlags_AnyPopupId + ImGuiPopupFlags_AnyPopupLevel: return true if any popup is open. + IMGUI_API bool IsPopupOpen(const char* str_id, ImGuiPopupFlags flags = 0); // return true if the popup is open. + + // Tables + // [BETA API] API may evolve slightly! If you use this, please update to the next version when it comes out! + // - Full-featured replacement for old Columns API. + // - See Demo->Tables for demo code. + // - See top of imgui_tables.cpp for general commentary. + // - See ImGuiTableFlags_ and ImGuiTableColumnFlags_ enums for a description of available flags. + // The typical call flow is: + // - 1. Call BeginTable(). + // - 2. Optionally call TableSetupColumn() to submit column name/flags/defaults. + // - 3. Optionally call TableSetupScrollFreeze() to request scroll freezing of columns/rows. + // - 4. Optionally call TableHeadersRow() to submit a header row. Names are pulled from TableSetupColumn() data. + // - 5. Populate contents: + // - In most situations you can use TableNextRow() + TableSetColumnIndex(N) to start appending into a column. + // - If you are using tables as a sort of grid, where every columns is holding the same type of contents, + // you may prefer using TableNextColumn() instead of TableNextRow() + TableSetColumnIndex(). + // TableNextColumn() will automatically wrap-around into the next row if needed. + // - IMPORTANT: Comparatively to the old Columns() API, we need to call TableNextColumn() for the first column! + // - Summary of possible call flow: + // -------------------------------------------------------------------------------------------------------- + // TableNextRow() -> TableSetColumnIndex(0) -> Text("Hello 0") -> TableSetColumnIndex(1) -> Text("Hello 1") // OK + // TableNextRow() -> TableNextColumn() -> Text("Hello 0") -> TableNextColumn() -> Text("Hello 1") // OK + // TableNextColumn() -> Text("Hello 0") -> TableNextColumn() -> Text("Hello 1") // OK: TableNextColumn() automatically gets to next row! + // TableNextRow() -> Text("Hello 0") // Not OK! Missing TableSetColumnIndex() or TableNextColumn()! Text will not appear! + // -------------------------------------------------------------------------------------------------------- + // - 5. Call EndTable() + IMGUI_API bool BeginTable(const char* str_id, int column, ImGuiTableFlags flags = 0, const ImVec2& outer_size = ImVec2(0.0f, 0.0f), float inner_width = 0.0f); + IMGUI_API void EndTable(); // only call EndTable() if BeginTable() returns true! + IMGUI_API void TableNextRow(ImGuiTableRowFlags row_flags = 0, float min_row_height = 0.0f); // append into the first cell of a new row. + IMGUI_API bool TableNextColumn(); // append into the next column (or first column of next row if currently in last column). Return true when column is visible. + IMGUI_API bool TableSetColumnIndex(int column_n); // append into the specified column. Return true when column is visible. + + // Tables: Headers & Columns declaration + // - Use TableSetupColumn() to specify label, resizing policy, default width/weight, id, various other flags etc. + // - Use TableHeadersRow() to create a header row and automatically submit a TableHeader() for each column. + // Headers are required to perform: reordering, sorting, and opening the context menu. + // The context menu can also be made available in columns body using ImGuiTableFlags_ContextMenuInBody. + // - You may manually submit headers using TableNextRow() + TableHeader() calls, but this is only useful in + // some advanced use cases (e.g. adding custom widgets in header row). + // - Use TableSetupScrollFreeze() to lock columns/rows so they stay visible when scrolled. + IMGUI_API void TableSetupColumn(const char* label, ImGuiTableColumnFlags flags = 0, float init_width_or_weight = 0.0f, ImGuiID user_id = 0); + IMGUI_API void TableSetupScrollFreeze(int cols, int rows); // lock columns/rows so they stay visible when scrolled. + IMGUI_API void TableHeadersRow(); // submit all headers cells based on data provided to TableSetupColumn() + submit context menu + IMGUI_API void TableHeader(const char* label); // submit one header cell manually (rarely used) + + // Tables: Sorting + // - Call TableGetSortSpecs() to retrieve latest sort specs for the table. NULL when not sorting. + // - When 'SpecsDirty == true' you should sort your data. It will be true when sorting specs have changed + // since last call, or the first time. Make sure to set 'SpecsDirty = false' after sorting, else you may + // wastefully sort your data every frame! + // - Lifetime: don't hold on this pointer over multiple frames or past any subsequent call to BeginTable(). + IMGUI_API ImGuiTableSortSpecs* TableGetSortSpecs(); // get latest sort specs for the table (NULL if not sorting). + + // Tables: Miscellaneous functions + // - Functions args 'int column_n' treat the default value of -1 as the same as passing the current column index. + IMGUI_API int TableGetColumnCount(); // return number of columns (value passed to BeginTable) + IMGUI_API int TableGetColumnIndex(); // return current column index. + IMGUI_API int TableGetRowIndex(); // return current row index. + IMGUI_API const char* TableGetColumnName(int column_n = -1); // return "" if column didn't have a name declared by TableSetupColumn(). Pass -1 to use current column. + IMGUI_API ImGuiTableColumnFlags TableGetColumnFlags(int column_n = -1); // return column flags so you can query their Enabled/Visible/Sorted/Hovered status flags. Pass -1 to use current column. + IMGUI_API void TableSetColumnEnabled(int column_n, bool v);// change user accessible enabled/disabled state of a column. Set to false to hide the column. User can use the context menu to change this themselves (right-click in headers, or right-click in columns body with ImGuiTableFlags_ContextMenuInBody) + IMGUI_API void TableSetBgColor(ImGuiTableBgTarget target, ImU32 color, int column_n = -1); // change the color of a cell, row, or column. See ImGuiTableBgTarget_ flags for details. + + // Legacy Columns API (prefer using Tables!) + // - You can also use SameLine(pos_x) to mimic simplified columns. + IMGUI_API void Columns(int count = 1, const char* id = NULL, bool border = true); + IMGUI_API void NextColumn(); // next column, defaults to current row or next row if the current row is finished + IMGUI_API int GetColumnIndex(); // get current column index + IMGUI_API float GetColumnWidth(int column_index = -1); // get column width (in pixels). pass -1 to use current column + IMGUI_API void SetColumnWidth(int column_index, float width); // set column width (in pixels). pass -1 to use current column + IMGUI_API float GetColumnOffset(int column_index = -1); // get position of column line (in pixels, from the left side of the contents region). pass -1 to use current column, otherwise 0..GetColumnsCount() inclusive. column 0 is typically 0.0f + IMGUI_API void SetColumnOffset(int column_index, float offset_x); // set position of column line (in pixels, from the left side of the contents region). pass -1 to use current column + IMGUI_API int GetColumnsCount(); + + // Tab Bars, Tabs + IMGUI_API bool BeginTabBar(const char* str_id, ImGuiTabBarFlags flags = 0); // create and append into a TabBar + IMGUI_API void EndTabBar(); // only call EndTabBar() if BeginTabBar() returns true! + IMGUI_API bool BeginTabItem(const char* label, bool* p_open = NULL, ImGuiTabItemFlags flags = 0); // create a Tab. Returns true if the Tab is selected. + IMGUI_API void EndTabItem(); // only call EndTabItem() if BeginTabItem() returns true! + IMGUI_API bool TabItemButton(const char* label, ImGuiTabItemFlags flags = 0); // create a Tab behaving like a button. return true when clicked. cannot be selected in the tab bar. + IMGUI_API void SetTabItemClosed(const char* tab_or_docked_window_label); // notify TabBar or Docking system of a closed tab/window ahead (useful to reduce visual flicker on reorderable tab bars). For tab-bar: call after BeginTabBar() and before Tab submissions. Otherwise call with a window name. + + // Logging/Capture + // - All text output from the interface can be captured into tty/file/clipboard. By default, tree nodes are automatically opened during logging. + IMGUI_API void LogToTTY(int auto_open_depth = -1); // start logging to tty (stdout) + IMGUI_API void LogToFile(int auto_open_depth = -1, const char* filename = NULL); // start logging to file + IMGUI_API void LogToClipboard(int auto_open_depth = -1); // start logging to OS clipboard + IMGUI_API void LogFinish(); // stop logging (close file, etc.) + IMGUI_API void LogButtons(); // helper to display buttons for logging to tty/file/clipboard + IMGUI_API void LogText(const char* fmt, ...) IM_FMTARGS(1); // pass text data straight to log (without being displayed) + IMGUI_API void LogTextV(const char* fmt, va_list args) IM_FMTLIST(1); + + // Drag and Drop + // - On source items, call BeginDragDropSource(), if it returns true also call SetDragDropPayload() + EndDragDropSource(). + // - On target candidates, call BeginDragDropTarget(), if it returns true also call AcceptDragDropPayload() + EndDragDropTarget(). + // - If you stop calling BeginDragDropSource() the payload is preserved however it won't have a preview tooltip (we currently display a fallback "..." tooltip, see #1725) + // - An item can be both drag source and drop target. + IMGUI_API bool BeginDragDropSource(ImGuiDragDropFlags flags = 0); // call after submitting an item which may be dragged. when this return true, you can call SetDragDropPayload() + EndDragDropSource() + IMGUI_API bool SetDragDropPayload(const char* type, const void* data, size_t sz, ImGuiCond cond = 0); // type is a user defined string of maximum 32 characters. Strings starting with '_' are reserved for dear imgui internal types. Data is copied and held by imgui. + IMGUI_API void EndDragDropSource(); // only call EndDragDropSource() if BeginDragDropSource() returns true! + IMGUI_API bool BeginDragDropTarget(); // call after submitting an item that may receive a payload. If this returns true, you can call AcceptDragDropPayload() + EndDragDropTarget() + IMGUI_API const ImGuiPayload* AcceptDragDropPayload(const char* type, ImGuiDragDropFlags flags = 0); // accept contents of a given type. If ImGuiDragDropFlags_AcceptBeforeDelivery is set you can peek into the payload before the mouse button is released. + IMGUI_API void EndDragDropTarget(); // only call EndDragDropTarget() if BeginDragDropTarget() returns true! + IMGUI_API const ImGuiPayload* GetDragDropPayload(); // peek directly into the current payload from anywhere. may return NULL. use ImGuiPayload::IsDataType() to test for the payload type. + + // Disabling [BETA API] + // - Disable all user interactions and dim items visuals (applying style.DisabledAlpha over current colors) + // - Those can be nested but it cannot be used to enable an already disabled section (a single BeginDisabled(true) in the stack is enough to keep everything disabled) + // - BeginDisabled(false) essentially does nothing useful but is provided to facilitate use of boolean expressions. If you can avoid calling BeginDisabled(False)/EndDisabled() best to avoid it. + IMGUI_API void BeginDisabled(bool disabled = true); + IMGUI_API void EndDisabled(); + + // Clipping + // - Mouse hovering is affected by ImGui::PushClipRect() calls, unlike direct calls to ImDrawList::PushClipRect() which are render only. + IMGUI_API void PushClipRect(const ImVec2& clip_rect_min, const ImVec2& clip_rect_max, bool intersect_with_current_clip_rect); + IMGUI_API void PopClipRect(); + + // Focus, Activation + // - Prefer using "SetItemDefaultFocus()" over "if (IsWindowAppearing()) SetScrollHereY()" when applicable to signify "this is the default item" + IMGUI_API void SetItemDefaultFocus(); // make last item the default focused item of a window. + IMGUI_API void SetKeyboardFocusHere(int offset = 0); // focus keyboard on the next widget. Use positive 'offset' to access sub components of a multiple component widget. Use -1 to access previous widget. + + // Item/Widgets Utilities and Query Functions + // - Most of the functions are referring to the previous Item that has been submitted. + // - See Demo Window under "Widgets->Querying Status" for an interactive visualization of most of those functions. + IMGUI_API bool IsItemHovered(ImGuiHoveredFlags flags = 0); // is the last item hovered? (and usable, aka not blocked by a popup, etc.). See ImGuiHoveredFlags for more options. + IMGUI_API bool IsItemActive(); // is the last item active? (e.g. button being held, text field being edited. This will continuously return true while holding mouse button on an item. Items that don't interact will always return false) + IMGUI_API bool IsItemFocused(); // is the last item focused for keyboard/gamepad navigation? + IMGUI_API bool IsItemClicked(ImGuiMouseButton mouse_button = 0); // is the last item hovered and mouse clicked on? (**) == IsMouseClicked(mouse_button) && IsItemHovered()Important. (**) this it NOT equivalent to the behavior of e.g. Button(). Read comments in function definition. + IMGUI_API bool IsItemVisible(); // is the last item visible? (items may be out of sight because of clipping/scrolling) + IMGUI_API bool IsItemEdited(); // did the last item modify its underlying value this frame? or was pressed? This is generally the same as the "bool" return value of many widgets. + IMGUI_API bool IsItemActivated(); // was the last item just made active (item was previously inactive). + IMGUI_API bool IsItemDeactivated(); // was the last item just made inactive (item was previously active). Useful for Undo/Redo patterns with widgets that requires continuous editing. + IMGUI_API bool IsItemDeactivatedAfterEdit(); // was the last item just made inactive and made a value change when it was active? (e.g. Slider/Drag moved). Useful for Undo/Redo patterns with widgets that requires continuous editing. Note that you may get false positives (some widgets such as Combo()/ListBox()/Selectable() will return true even when clicking an already selected item). + IMGUI_API bool IsItemToggledOpen(); // was the last item open state toggled? set by TreeNode(). + IMGUI_API bool IsAnyItemHovered(); // is any item hovered? + IMGUI_API bool IsAnyItemActive(); // is any item active? + IMGUI_API bool IsAnyItemFocused(); // is any item focused? + IMGUI_API ImVec2 GetItemRectMin(); // get upper-left bounding rectangle of the last item (screen space) + IMGUI_API ImVec2 GetItemRectMax(); // get lower-right bounding rectangle of the last item (screen space) + IMGUI_API ImVec2 GetItemRectSize(); // get size of last item + IMGUI_API void SetItemAllowOverlap(); // allow last item to be overlapped by a subsequent item. sometimes useful with invisible buttons, selectables, etc. to catch unused area. + + // Viewports + // - Currently represents the Platform Window created by the application which is hosting our Dear ImGui windows. + // - In 'docking' branch with multi-viewport enabled, we extend this concept to have multiple active viewports. + // - In the future we will extend this concept further to also represent Platform Monitor and support a "no main platform window" operation mode. + IMGUI_API ImGuiViewport* GetMainViewport(); // return primary/default viewport. This can never be NULL. + + // Miscellaneous Utilities + IMGUI_API bool IsRectVisible(const ImVec2& size); // test if rectangle (of given size, starting from cursor position) is visible / not clipped. + IMGUI_API bool IsRectVisible(const ImVec2& rect_min, const ImVec2& rect_max); // test if rectangle (in screen space) is visible / not clipped. to perform coarse clipping on user's side. + IMGUI_API double GetTime(); // get global imgui time. incremented by io.DeltaTime every frame. + IMGUI_API int GetFrameCount(); // get global imgui frame count. incremented by 1 every frame. + IMGUI_API ImDrawList* GetBackgroundDrawList(); // this draw list will be the first rendering one. Useful to quickly draw shapes/text behind dear imgui contents. + IMGUI_API ImDrawList* GetForegroundDrawList(); // this draw list will be the last rendered one. Useful to quickly draw shapes/text over dear imgui contents. + IMGUI_API ImDrawListSharedData* GetDrawListSharedData(); // you may use this when creating your own ImDrawList instances. + IMGUI_API const char* GetStyleColorName(ImGuiCol idx); // get a string corresponding to the enum value (for display, saving, etc.). + IMGUI_API void SetStateStorage(ImGuiStorage* storage); // replace current window storage with our own (if you want to manipulate it yourself, typically clear subsection of it) + IMGUI_API ImGuiStorage* GetStateStorage(); + IMGUI_API void CalcListClipping(int items_count, float items_height, int* out_items_display_start, int* out_items_display_end); // calculate coarse clipping for large list of evenly sized items. Prefer using the ImGuiListClipper higher-level helper if you can. + IMGUI_API bool BeginChildFrame(ImGuiID id, const ImVec2& size, ImGuiWindowFlags flags = 0); // helper to create a child window / scrolling region that looks like a normal widget frame + IMGUI_API void EndChildFrame(); // always call EndChildFrame() regardless of BeginChildFrame() return values (which indicates a collapsed/clipped window) + + // Text Utilities + IMGUI_API ImVec2 CalcTextSize(const char* text, const char* text_end = NULL, bool hide_text_after_double_hash = false, float wrap_width = -1.0f); + + // Color Utilities + IMGUI_API ImVec4 ColorConvertU32ToFloat4(ImU32 in); + IMGUI_API ImU32 ColorConvertFloat4ToU32(const ImVec4& in); + IMGUI_API void ColorConvertRGBtoHSV(float r, float g, float b, float& out_h, float& out_s, float& out_v); + IMGUI_API void ColorConvertHSVtoRGB(float h, float s, float v, float& out_r, float& out_g, float& out_b); + + // Inputs Utilities: Keyboard + // - For 'int user_key_index' you can use your own indices/enums according to how your backend/engine stored them in io.KeysDown[]. + // - We don't know the meaning of those value. You can use GetKeyIndex() to map a ImGuiKey_ value into the user index. + IMGUI_API int GetKeyIndex(ImGuiKey imgui_key); // map ImGuiKey_* values into user's key index. == io.KeyMap[key] + IMGUI_API bool IsKeyDown(int user_key_index); // is key being held. == io.KeysDown[user_key_index]. + IMGUI_API bool IsKeyPressed(int user_key_index, bool repeat = true); // was key pressed (went from !Down to Down)? if repeat=true, uses io.KeyRepeatDelay / KeyRepeatRate + IMGUI_API bool IsKeyReleased(int user_key_index); // was key released (went from Down to !Down)? + IMGUI_API int GetKeyPressedAmount(int key_index, float repeat_delay, float rate); // uses provided repeat rate/delay. return a count, most often 0 or 1 but might be >1 if RepeatRate is small enough that DeltaTime > RepeatRate + IMGUI_API void CaptureKeyboardFromApp(bool want_capture_keyboard_value = true); // attention: misleading name! manually override io.WantCaptureKeyboard flag next frame (said flag is entirely left for your application to handle). e.g. force capture keyboard when your widget is being hovered. This is equivalent to setting "io.WantCaptureKeyboard = want_capture_keyboard_value"; after the next NewFrame() call. + + // Inputs Utilities: Mouse + // - To refer to a mouse button, you may use named enums in your code e.g. ImGuiMouseButton_Left, ImGuiMouseButton_Right. + // - You can also use regular integer: it is forever guaranteed that 0=Left, 1=Right, 2=Middle. + // - Dragging operations are only reported after mouse has moved a certain distance away from the initial clicking position (see 'lock_threshold' and 'io.MouseDraggingThreshold') + IMGUI_API bool IsMouseDown(ImGuiMouseButton button); // is mouse button held? + IMGUI_API bool IsMouseClicked(ImGuiMouseButton button, bool repeat = false); // did mouse button clicked? (went from !Down to Down) + IMGUI_API bool IsMouseReleased(ImGuiMouseButton button); // did mouse button released? (went from Down to !Down) + IMGUI_API bool IsMouseDoubleClicked(ImGuiMouseButton button); // did mouse button double-clicked? (note that a double-click will also report IsMouseClicked() == true) + IMGUI_API bool IsMouseHoveringRect(const ImVec2& r_min, const ImVec2& r_max, bool clip = true);// is mouse hovering given bounding rect (in screen space). clipped by current clipping settings, but disregarding of other consideration of focus/window ordering/popup-block. + IMGUI_API bool IsMousePosValid(const ImVec2* mouse_pos = NULL); // by convention we use (-FLT_MAX,-FLT_MAX) to denote that there is no mouse available + IMGUI_API bool IsAnyMouseDown(); // is any mouse button held? + IMGUI_API ImVec2 GetMousePos(); // shortcut to ImGui::GetIO().MousePos provided by user, to be consistent with other calls + IMGUI_API ImVec2 GetMousePosOnOpeningCurrentPopup(); // retrieve mouse position at the time of opening popup we have BeginPopup() into (helper to avoid user backing that value themselves) + IMGUI_API bool IsMouseDragging(ImGuiMouseButton button, float lock_threshold = -1.0f); // is mouse dragging? (if lock_threshold < -1.0f, uses io.MouseDraggingThreshold) + IMGUI_API ImVec2 GetMouseDragDelta(ImGuiMouseButton button = 0, float lock_threshold = -1.0f); // return the delta from the initial clicking position while the mouse button is pressed or was just released. This is locked and return 0.0f until the mouse moves past a distance threshold at least once (if lock_threshold < -1.0f, uses io.MouseDraggingThreshold) + IMGUI_API void ResetMouseDragDelta(ImGuiMouseButton button = 0); // + IMGUI_API ImGuiMouseCursor GetMouseCursor(); // get desired cursor type, reset in ImGui::NewFrame(), this is updated during the frame. valid before Render(). If you use software rendering by setting io.MouseDrawCursor ImGui will render those for you + IMGUI_API void SetMouseCursor(ImGuiMouseCursor cursor_type); // set desired cursor type + IMGUI_API void CaptureMouseFromApp(bool want_capture_mouse_value = true); // attention: misleading name! manually override io.WantCaptureMouse flag next frame (said flag is entirely left for your application to handle). This is equivalent to setting "io.WantCaptureMouse = want_capture_mouse_value;" after the next NewFrame() call. + + // Clipboard Utilities + // - Also see the LogToClipboard() function to capture GUI into clipboard, or easily output text data to the clipboard. + IMGUI_API const char* GetClipboardText(); + IMGUI_API void SetClipboardText(const char* text); + + // Settings/.Ini Utilities + // - The disk functions are automatically called if io.IniFilename != NULL (default is "imgui.ini"). + // - Set io.IniFilename to NULL to load/save manually. Read io.WantSaveIniSettings description about handling .ini saving manually. + // - Important: default value "imgui.ini" is relative to current working dir! Most apps will want to lock this to an absolute path (e.g. same path as executables). + IMGUI_API void LoadIniSettingsFromDisk(const char* ini_filename); // call after CreateContext() and before the first call to NewFrame(). NewFrame() automatically calls LoadIniSettingsFromDisk(io.IniFilename). + IMGUI_API void LoadIniSettingsFromMemory(const char* ini_data, size_t ini_size=0); // call after CreateContext() and before the first call to NewFrame() to provide .ini data from your own data source. + IMGUI_API void SaveIniSettingsToDisk(const char* ini_filename); // this is automatically called (if io.IniFilename is not empty) a few seconds after any modification that should be reflected in the .ini file (and also by DestroyContext). + IMGUI_API const char* SaveIniSettingsToMemory(size_t* out_ini_size = NULL); // return a zero-terminated string with the .ini data which you can save by your own mean. call when io.WantSaveIniSettings is set, then save data by your own mean and clear io.WantSaveIniSettings. + + // Debug Utilities + // - This is used by the IMGUI_CHECKVERSION() macro. + IMGUI_API bool DebugCheckVersionAndDataLayout(const char* version_str, size_t sz_io, size_t sz_style, size_t sz_vec2, size_t sz_vec4, size_t sz_drawvert, size_t sz_drawidx); // This is called by IMGUI_CHECKVERSION() macro. + + // Memory Allocators + // - Those functions are not reliant on the current context. + // - DLL users: heaps and globals are not shared across DLL boundaries! You will need to call SetCurrentContext() + SetAllocatorFunctions() + // for each static/DLL boundary you are calling from. Read "Context and Memory Allocators" section of imgui.cpp for more details. + IMGUI_API void SetAllocatorFunctions(ImGuiMemAllocFunc alloc_func, ImGuiMemFreeFunc free_func, void* user_data = NULL); + IMGUI_API void GetAllocatorFunctions(ImGuiMemAllocFunc* p_alloc_func, ImGuiMemFreeFunc* p_free_func, void** p_user_data); + IMGUI_API void* MemAlloc(size_t size); + IMGUI_API void MemFree(void* ptr); + +} // namespace ImGui + +//----------------------------------------------------------------------------- +// [SECTION] Flags & Enumerations +//----------------------------------------------------------------------------- + +// Flags for ImGui::Begin() +enum ImGuiWindowFlags_ +{ + ImGuiWindowFlags_None = 0, + ImGuiWindowFlags_NoTitleBar = 1 << 0, // Disable title-bar + ImGuiWindowFlags_NoResize = 1 << 1, // Disable user resizing with the lower-right grip + ImGuiWindowFlags_NoMove = 1 << 2, // Disable user moving the window + ImGuiWindowFlags_NoScrollbar = 1 << 3, // Disable scrollbars (window can still scroll with mouse or programmatically) + ImGuiWindowFlags_NoScrollWithMouse = 1 << 4, // Disable user vertically scrolling with mouse wheel. On child window, mouse wheel will be forwarded to the parent unless NoScrollbar is also set. + ImGuiWindowFlags_NoCollapse = 1 << 5, // Disable user collapsing window by double-clicking on it + ImGuiWindowFlags_AlwaysAutoResize = 1 << 6, // Resize every window to its content every frame + ImGuiWindowFlags_NoBackground = 1 << 7, // Disable drawing background color (WindowBg, etc.) and outside border. Similar as using SetNextWindowBgAlpha(0.0f). + ImGuiWindowFlags_NoSavedSettings = 1 << 8, // Never load/save settings in .ini file + ImGuiWindowFlags_NoMouseInputs = 1 << 9, // Disable catching mouse, hovering test with pass through. + ImGuiWindowFlags_MenuBar = 1 << 10, // Has a menu-bar + ImGuiWindowFlags_HorizontalScrollbar = 1 << 11, // Allow horizontal scrollbar to appear (off by default). You may use SetNextWindowContentSize(ImVec2(width,0.0f)); prior to calling Begin() to specify width. Read code in imgui_demo in the "Horizontal Scrolling" section. + ImGuiWindowFlags_NoFocusOnAppearing = 1 << 12, // Disable taking focus when transitioning from hidden to visible state + ImGuiWindowFlags_NoBringToFrontOnFocus = 1 << 13, // Disable bringing window to front when taking focus (e.g. clicking on it or programmatically giving it focus) + ImGuiWindowFlags_AlwaysVerticalScrollbar= 1 << 14, // Always show vertical scrollbar (even if ContentSize.y < Size.y) + ImGuiWindowFlags_AlwaysHorizontalScrollbar=1<< 15, // Always show horizontal scrollbar (even if ContentSize.x < Size.x) + ImGuiWindowFlags_AlwaysUseWindowPadding = 1 << 16, // Ensure child windows without border uses style.WindowPadding (ignored by default for non-bordered child windows, because more convenient) + ImGuiWindowFlags_NoNavInputs = 1 << 18, // No gamepad/keyboard navigation within the window + ImGuiWindowFlags_NoNavFocus = 1 << 19, // No focusing toward this window with gamepad/keyboard navigation (e.g. skipped by CTRL+TAB) + ImGuiWindowFlags_UnsavedDocument = 1 << 20, // Display a dot next to the title. When used in a tab/docking context, tab is selected when clicking the X + closure is not assumed (will wait for user to stop submitting the tab). Otherwise closure is assumed when pressing the X, so if you keep submitting the tab may reappear at end of tab bar. + ImGuiWindowFlags_NoNav = ImGuiWindowFlags_NoNavInputs | ImGuiWindowFlags_NoNavFocus, + ImGuiWindowFlags_NoDecoration = ImGuiWindowFlags_NoTitleBar | ImGuiWindowFlags_NoResize | ImGuiWindowFlags_NoScrollbar | ImGuiWindowFlags_NoCollapse, + ImGuiWindowFlags_NoInputs = ImGuiWindowFlags_NoMouseInputs | ImGuiWindowFlags_NoNavInputs | ImGuiWindowFlags_NoNavFocus, + + // [Internal] + ImGuiWindowFlags_NavFlattened = 1 << 23, // [BETA] Allow gamepad/keyboard navigation to cross over parent border to this child (only use on child that have no scrolling!) + ImGuiWindowFlags_ChildWindow = 1 << 24, // Don't use! For internal use by BeginChild() + ImGuiWindowFlags_Tooltip = 1 << 25, // Don't use! For internal use by BeginTooltip() + ImGuiWindowFlags_Popup = 1 << 26, // Don't use! For internal use by BeginPopup() + ImGuiWindowFlags_Modal = 1 << 27, // Don't use! For internal use by BeginPopupModal() + ImGuiWindowFlags_ChildMenu = 1 << 28 // Don't use! For internal use by BeginMenu() + + // [Obsolete] + //ImGuiWindowFlags_ResizeFromAnySide = 1 << 17, // --> Set io.ConfigWindowsResizeFromEdges=true and make sure mouse cursors are supported by backend (io.BackendFlags & ImGuiBackendFlags_HasMouseCursors) +}; + +// Flags for ImGui::InputText() +enum ImGuiInputTextFlags_ +{ + ImGuiInputTextFlags_None = 0, + ImGuiInputTextFlags_CharsDecimal = 1 << 0, // Allow 0123456789.+-*/ + ImGuiInputTextFlags_CharsHexadecimal = 1 << 1, // Allow 0123456789ABCDEFabcdef + ImGuiInputTextFlags_CharsUppercase = 1 << 2, // Turn a..z into A..Z + ImGuiInputTextFlags_CharsNoBlank = 1 << 3, // Filter out spaces, tabs + ImGuiInputTextFlags_AutoSelectAll = 1 << 4, // Select entire text when first taking mouse focus + ImGuiInputTextFlags_EnterReturnsTrue = 1 << 5, // Return 'true' when Enter is pressed (as opposed to every time the value was modified). Consider looking at the IsItemDeactivatedAfterEdit() function. + ImGuiInputTextFlags_CallbackCompletion = 1 << 6, // Callback on pressing TAB (for completion handling) + ImGuiInputTextFlags_CallbackHistory = 1 << 7, // Callback on pressing Up/Down arrows (for history handling) + ImGuiInputTextFlags_CallbackAlways = 1 << 8, // Callback on each iteration. User code may query cursor position, modify text buffer. + ImGuiInputTextFlags_CallbackCharFilter = 1 << 9, // Callback on character inputs to replace or discard them. Modify 'EventChar' to replace or discard, or return 1 in callback to discard. + ImGuiInputTextFlags_AllowTabInput = 1 << 10, // Pressing TAB input a '\t' character into the text field + ImGuiInputTextFlags_CtrlEnterForNewLine = 1 << 11, // In multi-line mode, unfocus with Enter, add new line with Ctrl+Enter (default is opposite: unfocus with Ctrl+Enter, add line with Enter). + ImGuiInputTextFlags_NoHorizontalScroll = 1 << 12, // Disable following the cursor horizontally + ImGuiInputTextFlags_AlwaysOverwrite = 1 << 13, // Overwrite mode + ImGuiInputTextFlags_ReadOnly = 1 << 14, // Read-only mode + ImGuiInputTextFlags_Password = 1 << 15, // Password mode, display all characters as '*' + ImGuiInputTextFlags_NoUndoRedo = 1 << 16, // Disable undo/redo. Note that input text owns the text data while active, if you want to provide your own undo/redo stack you need e.g. to call ClearActiveID(). + ImGuiInputTextFlags_CharsScientific = 1 << 17, // Allow 0123456789.+-*/eE (Scientific notation input) + ImGuiInputTextFlags_CallbackResize = 1 << 18, // Callback on buffer capacity changes request (beyond 'buf_size' parameter value), allowing the string to grow. Notify when the string wants to be resized (for string types which hold a cache of their Size). You will be provided a new BufSize in the callback and NEED to honor it. (see misc/cpp/imgui_stdlib.h for an example of using this) + ImGuiInputTextFlags_CallbackEdit = 1 << 19 // Callback on any edit (note that InputText() already returns true on edit, the callback is useful mainly to manipulate the underlying buffer while focus is active) + + // Obsolete names (will be removed soon) +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + , ImGuiInputTextFlags_AlwaysInsertMode = ImGuiInputTextFlags_AlwaysOverwrite // [renamed in 1.82] name was not matching behavior +#endif +}; + +// Flags for ImGui::TreeNodeEx(), ImGui::CollapsingHeader*() +enum ImGuiTreeNodeFlags_ +{ + ImGuiTreeNodeFlags_None = 0, + ImGuiTreeNodeFlags_Selected = 1 << 0, // Draw as selected + ImGuiTreeNodeFlags_Framed = 1 << 1, // Draw frame with background (e.g. for CollapsingHeader) + ImGuiTreeNodeFlags_AllowItemOverlap = 1 << 2, // Hit testing to allow subsequent widgets to overlap this one + ImGuiTreeNodeFlags_NoTreePushOnOpen = 1 << 3, // Don't do a TreePush() when open (e.g. for CollapsingHeader) = no extra indent nor pushing on ID stack + ImGuiTreeNodeFlags_NoAutoOpenOnLog = 1 << 4, // Don't automatically and temporarily open node when Logging is active (by default logging will automatically open tree nodes) + ImGuiTreeNodeFlags_DefaultOpen = 1 << 5, // Default node to be open + ImGuiTreeNodeFlags_OpenOnDoubleClick = 1 << 6, // Need double-click to open node + ImGuiTreeNodeFlags_OpenOnArrow = 1 << 7, // Only open when clicking on the arrow part. If ImGuiTreeNodeFlags_OpenOnDoubleClick is also set, single-click arrow or double-click all box to open. + ImGuiTreeNodeFlags_Leaf = 1 << 8, // No collapsing, no arrow (use as a convenience for leaf nodes). + ImGuiTreeNodeFlags_Bullet = 1 << 9, // Display a bullet instead of arrow + ImGuiTreeNodeFlags_FramePadding = 1 << 10, // Use FramePadding (even for an unframed text node) to vertically align text baseline to regular widget height. Equivalent to calling AlignTextToFramePadding(). + ImGuiTreeNodeFlags_SpanAvailWidth = 1 << 11, // Extend hit box to the right-most edge, even if not framed. This is not the default in order to allow adding other items on the same line. In the future we may refactor the hit system to be front-to-back, allowing natural overlaps and then this can become the default. + ImGuiTreeNodeFlags_SpanFullWidth = 1 << 12, // Extend hit box to the left-most and right-most edges (bypass the indented area). + ImGuiTreeNodeFlags_NavLeftJumpsBackHere = 1 << 13, // (WIP) Nav: left direction may move to this TreeNode() from any of its child (items submitted between TreeNode and TreePop) + //ImGuiTreeNodeFlags_NoScrollOnOpen = 1 << 14, // FIXME: TODO: Disable automatic scroll on TreePop() if node got just open and contents is not visible + ImGuiTreeNodeFlags_CollapsingHeader = ImGuiTreeNodeFlags_Framed | ImGuiTreeNodeFlags_NoTreePushOnOpen | ImGuiTreeNodeFlags_NoAutoOpenOnLog +}; + +// Flags for OpenPopup*(), BeginPopupContext*(), IsPopupOpen() functions. +// - To be backward compatible with older API which took an 'int mouse_button = 1' argument, we need to treat +// small flags values as a mouse button index, so we encode the mouse button in the first few bits of the flags. +// It is therefore guaranteed to be legal to pass a mouse button index in ImGuiPopupFlags. +// - For the same reason, we exceptionally default the ImGuiPopupFlags argument of BeginPopupContextXXX functions to 1 instead of 0. +// IMPORTANT: because the default parameter is 1 (==ImGuiPopupFlags_MouseButtonRight), if you rely on the default parameter +// and want to another another flag, you need to pass in the ImGuiPopupFlags_MouseButtonRight flag. +// - Multiple buttons currently cannot be combined/or-ed in those functions (we could allow it later). +enum ImGuiPopupFlags_ +{ + ImGuiPopupFlags_None = 0, + ImGuiPopupFlags_MouseButtonLeft = 0, // For BeginPopupContext*(): open on Left Mouse release. Guaranteed to always be == 0 (same as ImGuiMouseButton_Left) + ImGuiPopupFlags_MouseButtonRight = 1, // For BeginPopupContext*(): open on Right Mouse release. Guaranteed to always be == 1 (same as ImGuiMouseButton_Right) + ImGuiPopupFlags_MouseButtonMiddle = 2, // For BeginPopupContext*(): open on Middle Mouse release. Guaranteed to always be == 2 (same as ImGuiMouseButton_Middle) + ImGuiPopupFlags_MouseButtonMask_ = 0x1F, + ImGuiPopupFlags_MouseButtonDefault_ = 1, + ImGuiPopupFlags_NoOpenOverExistingPopup = 1 << 5, // For OpenPopup*(), BeginPopupContext*(): don't open if there's already a popup at the same level of the popup stack + ImGuiPopupFlags_NoOpenOverItems = 1 << 6, // For BeginPopupContextWindow(): don't return true when hovering items, only when hovering empty space + ImGuiPopupFlags_AnyPopupId = 1 << 7, // For IsPopupOpen(): ignore the ImGuiID parameter and test for any popup. + ImGuiPopupFlags_AnyPopupLevel = 1 << 8, // For IsPopupOpen(): search/test at any level of the popup stack (default test in the current level) + ImGuiPopupFlags_AnyPopup = ImGuiPopupFlags_AnyPopupId | ImGuiPopupFlags_AnyPopupLevel +}; + +// Flags for ImGui::Selectable() +enum ImGuiSelectableFlags_ +{ + ImGuiSelectableFlags_None = 0, + ImGuiSelectableFlags_DontClosePopups = 1 << 0, // Clicking this don't close parent popup window + ImGuiSelectableFlags_SpanAllColumns = 1 << 1, // Selectable frame can span all columns (text will still fit in current column) + ImGuiSelectableFlags_AllowDoubleClick = 1 << 2, // Generate press events on double clicks too + ImGuiSelectableFlags_Disabled = 1 << 3, // Cannot be selected, display grayed out text + ImGuiSelectableFlags_AllowItemOverlap = 1 << 4 // (WIP) Hit testing to allow subsequent widgets to overlap this one +}; + +// Flags for ImGui::BeginCombo() +enum ImGuiComboFlags_ +{ + ImGuiComboFlags_None = 0, + ImGuiComboFlags_PopupAlignLeft = 1 << 0, // Align the popup toward the left by default + ImGuiComboFlags_HeightSmall = 1 << 1, // Max ~4 items visible. Tip: If you want your combo popup to be a specific size you can use SetNextWindowSizeConstraints() prior to calling BeginCombo() + ImGuiComboFlags_HeightRegular = 1 << 2, // Max ~8 items visible (default) + ImGuiComboFlags_HeightLarge = 1 << 3, // Max ~20 items visible + ImGuiComboFlags_HeightLargest = 1 << 4, // As many fitting items as possible + ImGuiComboFlags_NoArrowButton = 1 << 5, // Display on the preview box without the square arrow button + ImGuiComboFlags_NoPreview = 1 << 6, // Display only a square arrow button + ImGuiComboFlags_HeightMask_ = ImGuiComboFlags_HeightSmall | ImGuiComboFlags_HeightRegular | ImGuiComboFlags_HeightLarge | ImGuiComboFlags_HeightLargest +}; + +// Flags for ImGui::BeginTabBar() +enum ImGuiTabBarFlags_ +{ + ImGuiTabBarFlags_None = 0, + ImGuiTabBarFlags_Reorderable = 1 << 0, // Allow manually dragging tabs to re-order them + New tabs are appended at the end of list + ImGuiTabBarFlags_AutoSelectNewTabs = 1 << 1, // Automatically select new tabs when they appear + ImGuiTabBarFlags_TabListPopupButton = 1 << 2, // Disable buttons to open the tab list popup + ImGuiTabBarFlags_NoCloseWithMiddleMouseButton = 1 << 3, // Disable behavior of closing tabs (that are submitted with p_open != NULL) with middle mouse button. You can still repro this behavior on user's side with if (IsItemHovered() && IsMouseClicked(2)) *p_open = false. + ImGuiTabBarFlags_NoTabListScrollingButtons = 1 << 4, // Disable scrolling buttons (apply when fitting policy is ImGuiTabBarFlags_FittingPolicyScroll) + ImGuiTabBarFlags_NoTooltip = 1 << 5, // Disable tooltips when hovering a tab + ImGuiTabBarFlags_FittingPolicyResizeDown = 1 << 6, // Resize tabs when they don't fit + ImGuiTabBarFlags_FittingPolicyScroll = 1 << 7, // Add scroll buttons when tabs don't fit + ImGuiTabBarFlags_FittingPolicyMask_ = ImGuiTabBarFlags_FittingPolicyResizeDown | ImGuiTabBarFlags_FittingPolicyScroll, + ImGuiTabBarFlags_FittingPolicyDefault_ = ImGuiTabBarFlags_FittingPolicyResizeDown +}; + +// Flags for ImGui::BeginTabItem() +enum ImGuiTabItemFlags_ +{ + ImGuiTabItemFlags_None = 0, + ImGuiTabItemFlags_UnsavedDocument = 1 << 0, // Display a dot next to the title + tab is selected when clicking the X + closure is not assumed (will wait for user to stop submitting the tab). Otherwise closure is assumed when pressing the X, so if you keep submitting the tab may reappear at end of tab bar. + ImGuiTabItemFlags_SetSelected = 1 << 1, // Trigger flag to programmatically make the tab selected when calling BeginTabItem() + ImGuiTabItemFlags_NoCloseWithMiddleMouseButton = 1 << 2, // Disable behavior of closing tabs (that are submitted with p_open != NULL) with middle mouse button. You can still repro this behavior on user's side with if (IsItemHovered() && IsMouseClicked(2)) *p_open = false. + ImGuiTabItemFlags_NoPushId = 1 << 3, // Don't call PushID(tab->ID)/PopID() on BeginTabItem()/EndTabItem() + ImGuiTabItemFlags_NoTooltip = 1 << 4, // Disable tooltip for the given tab + ImGuiTabItemFlags_NoReorder = 1 << 5, // Disable reordering this tab or having another tab cross over this tab + ImGuiTabItemFlags_Leading = 1 << 6, // Enforce the tab position to the left of the tab bar (after the tab list popup button) + ImGuiTabItemFlags_Trailing = 1 << 7 // Enforce the tab position to the right of the tab bar (before the scrolling buttons) +}; + +// Flags for ImGui::BeginTable() +// [BETA API] API may evolve slightly! If you use this, please update to the next version when it comes out! +// - Important! Sizing policies have complex and subtle side effects, more so than you would expect. +// Read comments/demos carefully + experiment with live demos to get acquainted with them. +// - The DEFAULT sizing policies are: +// - Default to ImGuiTableFlags_SizingFixedFit if ScrollX is on, or if host window has ImGuiWindowFlags_AlwaysAutoResize. +// - Default to ImGuiTableFlags_SizingStretchSame if ScrollX is off. +// - When ScrollX is off: +// - Table defaults to ImGuiTableFlags_SizingStretchSame -> all Columns defaults to ImGuiTableColumnFlags_WidthStretch with same weight. +// - Columns sizing policy allowed: Stretch (default), Fixed/Auto. +// - Fixed Columns will generally obtain their requested width (unless the table cannot fit them all). +// - Stretch Columns will share the remaining width. +// - Mixed Fixed/Stretch columns is possible but has various side-effects on resizing behaviors. +// The typical use of mixing sizing policies is: any number of LEADING Fixed columns, followed by one or two TRAILING Stretch columns. +// (this is because the visible order of columns have subtle but necessary effects on how they react to manual resizing). +// - When ScrollX is on: +// - Table defaults to ImGuiTableFlags_SizingFixedFit -> all Columns defaults to ImGuiTableColumnFlags_WidthFixed +// - Columns sizing policy allowed: Fixed/Auto mostly. +// - Fixed Columns can be enlarged as needed. Table will show an horizontal scrollbar if needed. +// - When using auto-resizing (non-resizable) fixed columns, querying the content width to use item right-alignment e.g. SetNextItemWidth(-FLT_MIN) doesn't make sense, would create a feedback loop. +// - Using Stretch columns OFTEN DOES NOT MAKE SENSE if ScrollX is on, UNLESS you have specified a value for 'inner_width' in BeginTable(). +// If you specify a value for 'inner_width' then effectively the scrolling space is known and Stretch or mixed Fixed/Stretch columns become meaningful again. +// - Read on documentation at the top of imgui_tables.cpp for details. +enum ImGuiTableFlags_ +{ + // Features + ImGuiTableFlags_None = 0, + ImGuiTableFlags_Resizable = 1 << 0, // Enable resizing columns. + ImGuiTableFlags_Reorderable = 1 << 1, // Enable reordering columns in header row (need calling TableSetupColumn() + TableHeadersRow() to display headers) + ImGuiTableFlags_Hideable = 1 << 2, // Enable hiding/disabling columns in context menu. + ImGuiTableFlags_Sortable = 1 << 3, // Enable sorting. Call TableGetSortSpecs() to obtain sort specs. Also see ImGuiTableFlags_SortMulti and ImGuiTableFlags_SortTristate. + ImGuiTableFlags_NoSavedSettings = 1 << 4, // Disable persisting columns order, width and sort settings in the .ini file. + ImGuiTableFlags_ContextMenuInBody = 1 << 5, // Right-click on columns body/contents will display table context menu. By default it is available in TableHeadersRow(). + // Decorations + ImGuiTableFlags_RowBg = 1 << 6, // Set each RowBg color with ImGuiCol_TableRowBg or ImGuiCol_TableRowBgAlt (equivalent of calling TableSetBgColor with ImGuiTableBgFlags_RowBg0 on each row manually) + ImGuiTableFlags_BordersInnerH = 1 << 7, // Draw horizontal borders between rows. + ImGuiTableFlags_BordersOuterH = 1 << 8, // Draw horizontal borders at the top and bottom. + ImGuiTableFlags_BordersInnerV = 1 << 9, // Draw vertical borders between columns. + ImGuiTableFlags_BordersOuterV = 1 << 10, // Draw vertical borders on the left and right sides. + ImGuiTableFlags_BordersH = ImGuiTableFlags_BordersInnerH | ImGuiTableFlags_BordersOuterH, // Draw horizontal borders. + ImGuiTableFlags_BordersV = ImGuiTableFlags_BordersInnerV | ImGuiTableFlags_BordersOuterV, // Draw vertical borders. + ImGuiTableFlags_BordersInner = ImGuiTableFlags_BordersInnerV | ImGuiTableFlags_BordersInnerH, // Draw inner borders. + ImGuiTableFlags_BordersOuter = ImGuiTableFlags_BordersOuterV | ImGuiTableFlags_BordersOuterH, // Draw outer borders. + ImGuiTableFlags_Borders = ImGuiTableFlags_BordersInner | ImGuiTableFlags_BordersOuter, // Draw all borders. + ImGuiTableFlags_NoBordersInBody = 1 << 11, // [ALPHA] Disable vertical borders in columns Body (borders will always appears in Headers). -> May move to style + ImGuiTableFlags_NoBordersInBodyUntilResize = 1 << 12, // [ALPHA] Disable vertical borders in columns Body until hovered for resize (borders will always appears in Headers). -> May move to style + // Sizing Policy (read above for defaults) + ImGuiTableFlags_SizingFixedFit = 1 << 13, // Columns default to _WidthFixed or _WidthAuto (if resizable or not resizable), matching contents width. + ImGuiTableFlags_SizingFixedSame = 2 << 13, // Columns default to _WidthFixed or _WidthAuto (if resizable or not resizable), matching the maximum contents width of all columns. Implicitly enable ImGuiTableFlags_NoKeepColumnsVisible. + ImGuiTableFlags_SizingStretchProp = 3 << 13, // Columns default to _WidthStretch with default weights proportional to each columns contents widths. + ImGuiTableFlags_SizingStretchSame = 4 << 13, // Columns default to _WidthStretch with default weights all equal, unless overridden by TableSetupColumn(). + // Sizing Extra Options + ImGuiTableFlags_NoHostExtendX = 1 << 16, // Make outer width auto-fit to columns, overriding outer_size.x value. Only available when ScrollX/ScrollY are disabled and Stretch columns are not used. + ImGuiTableFlags_NoHostExtendY = 1 << 17, // Make outer height stop exactly at outer_size.y (prevent auto-extending table past the limit). Only available when ScrollX/ScrollY are disabled. Data below the limit will be clipped and not visible. + ImGuiTableFlags_NoKeepColumnsVisible = 1 << 18, // Disable keeping column always minimally visible when ScrollX is off and table gets too small. Not recommended if columns are resizable. + ImGuiTableFlags_PreciseWidths = 1 << 19, // Disable distributing remainder width to stretched columns (width allocation on a 100-wide table with 3 columns: Without this flag: 33,33,34. With this flag: 33,33,33). With larger number of columns, resizing will appear to be less smooth. + // Clipping + ImGuiTableFlags_NoClip = 1 << 20, // Disable clipping rectangle for every individual columns (reduce draw command count, items will be able to overflow into other columns). Generally incompatible with TableSetupScrollFreeze(). + // Padding + ImGuiTableFlags_PadOuterX = 1 << 21, // Default if BordersOuterV is on. Enable outer-most padding. Generally desirable if you have headers. + ImGuiTableFlags_NoPadOuterX = 1 << 22, // Default if BordersOuterV is off. Disable outer-most padding. + ImGuiTableFlags_NoPadInnerX = 1 << 23, // Disable inner padding between columns (double inner padding if BordersOuterV is on, single inner padding if BordersOuterV is off). + // Scrolling + ImGuiTableFlags_ScrollX = 1 << 24, // Enable horizontal scrolling. Require 'outer_size' parameter of BeginTable() to specify the container size. Changes default sizing policy. Because this create a child window, ScrollY is currently generally recommended when using ScrollX. + ImGuiTableFlags_ScrollY = 1 << 25, // Enable vertical scrolling. Require 'outer_size' parameter of BeginTable() to specify the container size. + // Sorting + ImGuiTableFlags_SortMulti = 1 << 26, // Hold shift when clicking headers to sort on multiple column. TableGetSortSpecs() may return specs where (SpecsCount > 1). + ImGuiTableFlags_SortTristate = 1 << 27, // Allow no sorting, disable default sorting. TableGetSortSpecs() may return specs where (SpecsCount == 0). + + // [Internal] Combinations and masks + ImGuiTableFlags_SizingMask_ = ImGuiTableFlags_SizingFixedFit | ImGuiTableFlags_SizingFixedSame | ImGuiTableFlags_SizingStretchProp | ImGuiTableFlags_SizingStretchSame + + // Obsolete names (will be removed soon) +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + //, ImGuiTableFlags_ColumnsWidthFixed = ImGuiTableFlags_SizingFixedFit, ImGuiTableFlags_ColumnsWidthStretch = ImGuiTableFlags_SizingStretchSame // WIP Tables 2020/12 + //, ImGuiTableFlags_SizingPolicyFixed = ImGuiTableFlags_SizingFixedFit, ImGuiTableFlags_SizingPolicyStretch = ImGuiTableFlags_SizingStretchSame // WIP Tables 2021/01 +#endif +}; + +// Flags for ImGui::TableSetupColumn() +enum ImGuiTableColumnFlags_ +{ + // Input configuration flags + ImGuiTableColumnFlags_None = 0, + ImGuiTableColumnFlags_Disabled = 1 << 0, // Overriding/master disable flag: hide column, won't show in context menu (unlike calling TableSetColumnEnabled() which manipulates the user accessible state) + ImGuiTableColumnFlags_DefaultHide = 1 << 1, // Default as a hidden/disabled column. + ImGuiTableColumnFlags_DefaultSort = 1 << 2, // Default as a sorting column. + ImGuiTableColumnFlags_WidthStretch = 1 << 3, // Column will stretch. Preferable with horizontal scrolling disabled (default if table sizing policy is _SizingStretchSame or _SizingStretchProp). + ImGuiTableColumnFlags_WidthFixed = 1 << 4, // Column will not stretch. Preferable with horizontal scrolling enabled (default if table sizing policy is _SizingFixedFit and table is resizable). + ImGuiTableColumnFlags_NoResize = 1 << 5, // Disable manual resizing. + ImGuiTableColumnFlags_NoReorder = 1 << 6, // Disable manual reordering this column, this will also prevent other columns from crossing over this column. + ImGuiTableColumnFlags_NoHide = 1 << 7, // Disable ability to hide/disable this column. + ImGuiTableColumnFlags_NoClip = 1 << 8, // Disable clipping for this column (all NoClip columns will render in a same draw command). + ImGuiTableColumnFlags_NoSort = 1 << 9, // Disable ability to sort on this field (even if ImGuiTableFlags_Sortable is set on the table). + ImGuiTableColumnFlags_NoSortAscending = 1 << 10, // Disable ability to sort in the ascending direction. + ImGuiTableColumnFlags_NoSortDescending = 1 << 11, // Disable ability to sort in the descending direction. + ImGuiTableColumnFlags_NoHeaderLabel = 1 << 12, // TableHeadersRow() will not submit label for this column. Convenient for some small columns. Name will still appear in context menu. + ImGuiTableColumnFlags_NoHeaderWidth = 1 << 13, // Disable header text width contribution to automatic column width. + ImGuiTableColumnFlags_PreferSortAscending = 1 << 14, // Make the initial sort direction Ascending when first sorting on this column (default). + ImGuiTableColumnFlags_PreferSortDescending = 1 << 15, // Make the initial sort direction Descending when first sorting on this column. + ImGuiTableColumnFlags_IndentEnable = 1 << 16, // Use current Indent value when entering cell (default for column 0). + ImGuiTableColumnFlags_IndentDisable = 1 << 17, // Ignore current Indent value when entering cell (default for columns > 0). Indentation changes _within_ the cell will still be honored. + + // Output status flags, read-only via TableGetColumnFlags() + ImGuiTableColumnFlags_IsEnabled = 1 << 24, // Status: is enabled == not hidden by user/api (referred to as "Hide" in _DefaultHide and _NoHide) flags. + ImGuiTableColumnFlags_IsVisible = 1 << 25, // Status: is visible == is enabled AND not clipped by scrolling. + ImGuiTableColumnFlags_IsSorted = 1 << 26, // Status: is currently part of the sort specs + ImGuiTableColumnFlags_IsHovered = 1 << 27, // Status: is hovered by mouse + + // [Internal] Combinations and masks + ImGuiTableColumnFlags_WidthMask_ = ImGuiTableColumnFlags_WidthStretch | ImGuiTableColumnFlags_WidthFixed, + ImGuiTableColumnFlags_IndentMask_ = ImGuiTableColumnFlags_IndentEnable | ImGuiTableColumnFlags_IndentDisable, + ImGuiTableColumnFlags_StatusMask_ = ImGuiTableColumnFlags_IsEnabled | ImGuiTableColumnFlags_IsVisible | ImGuiTableColumnFlags_IsSorted | ImGuiTableColumnFlags_IsHovered, + ImGuiTableColumnFlags_NoDirectResize_ = 1 << 30 // [Internal] Disable user resizing this column directly (it may however we resized indirectly from its left edge) + + // Obsolete names (will be removed soon) +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + //ImGuiTableColumnFlags_WidthAuto = ImGuiTableColumnFlags_WidthFixed | ImGuiTableColumnFlags_NoResize, // Column will not stretch and keep resizing based on submitted contents. +#endif +}; + +// Flags for ImGui::TableNextRow() +enum ImGuiTableRowFlags_ +{ + ImGuiTableRowFlags_None = 0, + ImGuiTableRowFlags_Headers = 1 << 0 // Identify header row (set default background color + width of its contents accounted different for auto column width) +}; + +// Enum for ImGui::TableSetBgColor() +// Background colors are rendering in 3 layers: +// - Layer 0: draw with RowBg0 color if set, otherwise draw with ColumnBg0 if set. +// - Layer 1: draw with RowBg1 color if set, otherwise draw with ColumnBg1 if set. +// - Layer 2: draw with CellBg color if set. +// The purpose of the two row/columns layers is to let you decide if a background color changes should override or blend with the existing color. +// When using ImGuiTableFlags_RowBg on the table, each row has the RowBg0 color automatically set for odd/even rows. +// If you set the color of RowBg0 target, your color will override the existing RowBg0 color. +// If you set the color of RowBg1 or ColumnBg1 target, your color will blend over the RowBg0 color. +enum ImGuiTableBgTarget_ +{ + ImGuiTableBgTarget_None = 0, + ImGuiTableBgTarget_RowBg0 = 1, // Set row background color 0 (generally used for background, automatically set when ImGuiTableFlags_RowBg is used) + ImGuiTableBgTarget_RowBg1 = 2, // Set row background color 1 (generally used for selection marking) + ImGuiTableBgTarget_CellBg = 3 // Set cell background color (top-most color) +}; + +// Flags for ImGui::IsWindowFocused() +enum ImGuiFocusedFlags_ +{ + ImGuiFocusedFlags_None = 0, + ImGuiFocusedFlags_ChildWindows = 1 << 0, // Return true if any children of the window is focused + ImGuiFocusedFlags_RootWindow = 1 << 1, // Test from root window (top most parent of the current hierarchy) + ImGuiFocusedFlags_AnyWindow = 1 << 2, // Return true if any window is focused. Important: If you are trying to tell how to dispatch your low-level inputs, do NOT use this. Use 'io.WantCaptureMouse' instead! Please read the FAQ! + //ImGuiFocusedFlags_DockHierarchy = 1 << 3, // Consider docking hierarchy (treat dockspace host as parent of docked window) + ImGuiFocusedFlags_RootAndChildWindows = ImGuiFocusedFlags_RootWindow | ImGuiFocusedFlags_ChildWindows +}; + +// Flags for ImGui::IsItemHovered(), ImGui::IsWindowHovered() +// Note: if you are trying to check whether your mouse should be dispatched to Dear ImGui or to your app, you should use 'io.WantCaptureMouse' instead! Please read the FAQ! +// Note: windows with the ImGuiWindowFlags_NoInputs flag are ignored by IsWindowHovered() calls. +enum ImGuiHoveredFlags_ +{ + ImGuiHoveredFlags_None = 0, // Return true if directly over the item/window, not obstructed by another window, not obstructed by an active popup or modal blocking inputs under them. + ImGuiHoveredFlags_ChildWindows = 1 << 0, // IsWindowHovered() only: Return true if any children of the window is hovered + ImGuiHoveredFlags_RootWindow = 1 << 1, // IsWindowHovered() only: Test from root window (top most parent of the current hierarchy) + ImGuiHoveredFlags_AnyWindow = 1 << 2, // IsWindowHovered() only: Return true if any window is hovered + //ImGuiHoveredFlags_DockHierarchy = 1 << 3, // IsWindowHovered() only: Consider docking hierarchy (treat dockspace host as parent of docked window) + ImGuiHoveredFlags_AllowWhenBlockedByPopup = 1 << 4, // Return true even if a popup window is normally blocking access to this item/window + //ImGuiHoveredFlags_AllowWhenBlockedByModal = 1 << 4, // Return true even if a modal popup window is normally blocking access to this item/window. FIXME-TODO: Unavailable yet. + ImGuiHoveredFlags_AllowWhenBlockedByActiveItem = 1 << 5, // Return true even if an active item is blocking access to this item/window. Useful for Drag and Drop patterns. + ImGuiHoveredFlags_AllowWhenOverlapped = 1 << 6, // Return true even if the position is obstructed or overlapped by another window + ImGuiHoveredFlags_AllowWhenDisabled = 1 << 7, // Return true even if the item is disabled + ImGuiHoveredFlags_RectOnly = ImGuiHoveredFlags_AllowWhenBlockedByPopup | ImGuiHoveredFlags_AllowWhenBlockedByActiveItem | ImGuiHoveredFlags_AllowWhenOverlapped, + ImGuiHoveredFlags_RootAndChildWindows = ImGuiHoveredFlags_RootWindow | ImGuiHoveredFlags_ChildWindows +}; + +// Flags for ImGui::BeginDragDropSource(), ImGui::AcceptDragDropPayload() +enum ImGuiDragDropFlags_ +{ + ImGuiDragDropFlags_None = 0, + // BeginDragDropSource() flags + ImGuiDragDropFlags_SourceNoPreviewTooltip = 1 << 0, // By default, a successful call to BeginDragDropSource opens a tooltip so you can display a preview or description of the source contents. This flag disable this behavior. + ImGuiDragDropFlags_SourceNoDisableHover = 1 << 1, // By default, when dragging we clear data so that IsItemHovered() will return false, to avoid subsequent user code submitting tooltips. This flag disable this behavior so you can still call IsItemHovered() on the source item. + ImGuiDragDropFlags_SourceNoHoldToOpenOthers = 1 << 2, // Disable the behavior that allows to open tree nodes and collapsing header by holding over them while dragging a source item. + ImGuiDragDropFlags_SourceAllowNullID = 1 << 3, // Allow items such as Text(), Image() that have no unique identifier to be used as drag source, by manufacturing a temporary identifier based on their window-relative position. This is extremely unusual within the dear imgui ecosystem and so we made it explicit. + ImGuiDragDropFlags_SourceExtern = 1 << 4, // External source (from outside of dear imgui), won't attempt to read current item/window info. Will always return true. Only one Extern source can be active simultaneously. + ImGuiDragDropFlags_SourceAutoExpirePayload = 1 << 5, // Automatically expire the payload if the source cease to be submitted (otherwise payloads are persisting while being dragged) + // AcceptDragDropPayload() flags + ImGuiDragDropFlags_AcceptBeforeDelivery = 1 << 10, // AcceptDragDropPayload() will returns true even before the mouse button is released. You can then call IsDelivery() to test if the payload needs to be delivered. + ImGuiDragDropFlags_AcceptNoDrawDefaultRect = 1 << 11, // Do not draw the default highlight rectangle when hovering over target. + ImGuiDragDropFlags_AcceptNoPreviewTooltip = 1 << 12, // Request hiding the BeginDragDropSource tooltip from the BeginDragDropTarget site. + ImGuiDragDropFlags_AcceptPeekOnly = ImGuiDragDropFlags_AcceptBeforeDelivery | ImGuiDragDropFlags_AcceptNoDrawDefaultRect // For peeking ahead and inspecting the payload before delivery. +}; + +// Standard Drag and Drop payload types. You can define you own payload types using short strings. Types starting with '_' are defined by Dear ImGui. +#define IMGUI_PAYLOAD_TYPE_COLOR_3F "_COL3F" // float[3]: Standard type for colors, without alpha. User code may use this type. +#define IMGUI_PAYLOAD_TYPE_COLOR_4F "_COL4F" // float[4]: Standard type for colors. User code may use this type. + +// A primary data type +enum ImGuiDataType_ +{ + ImGuiDataType_S8, // signed char / char (with sensible compilers) + ImGuiDataType_U8, // unsigned char + ImGuiDataType_S16, // short + ImGuiDataType_U16, // unsigned short + ImGuiDataType_S32, // int + ImGuiDataType_U32, // unsigned int + ImGuiDataType_S64, // long long / __int64 + ImGuiDataType_U64, // unsigned long long / unsigned __int64 + ImGuiDataType_Float, // float + ImGuiDataType_Double, // double + ImGuiDataType_COUNT +}; + +// A cardinal direction +enum ImGuiDir_ +{ + ImGuiDir_None = -1, + ImGuiDir_Left = 0, + ImGuiDir_Right = 1, + ImGuiDir_Up = 2, + ImGuiDir_Down = 3, + ImGuiDir_COUNT +}; + +// A sorting direction +enum ImGuiSortDirection_ +{ + ImGuiSortDirection_None = 0, + ImGuiSortDirection_Ascending = 1, // Ascending = 0->9, A->Z etc. + ImGuiSortDirection_Descending = 2 // Descending = 9->0, Z->A etc. +}; + +// User fill ImGuiIO.KeyMap[] array with indices into the ImGuiIO.KeysDown[512] array +enum ImGuiKey_ +{ + ImGuiKey_Tab, + ImGuiKey_LeftArrow, + ImGuiKey_RightArrow, + ImGuiKey_UpArrow, + ImGuiKey_DownArrow, + ImGuiKey_PageUp, + ImGuiKey_PageDown, + ImGuiKey_Home, + ImGuiKey_End, + ImGuiKey_Insert, + ImGuiKey_Delete, + ImGuiKey_Backspace, + ImGuiKey_Space, + ImGuiKey_Enter, + ImGuiKey_Escape, + ImGuiKey_KeyPadEnter, + ImGuiKey_A, // for text edit CTRL+A: select all + ImGuiKey_C, // for text edit CTRL+C: copy + ImGuiKey_V, // for text edit CTRL+V: paste + ImGuiKey_X, // for text edit CTRL+X: cut + ImGuiKey_Y, // for text edit CTRL+Y: redo + ImGuiKey_Z, // for text edit CTRL+Z: undo + ImGuiKey_COUNT +}; + +// To test io.KeyMods (which is a combination of individual fields io.KeyCtrl, io.KeyShift, io.KeyAlt set by user/backend) +enum ImGuiKeyModFlags_ +{ + ImGuiKeyModFlags_None = 0, + ImGuiKeyModFlags_Ctrl = 1 << 0, + ImGuiKeyModFlags_Shift = 1 << 1, + ImGuiKeyModFlags_Alt = 1 << 2, + ImGuiKeyModFlags_Super = 1 << 3 +}; + +// Gamepad/Keyboard navigation +// Keyboard: Set io.ConfigFlags |= ImGuiConfigFlags_NavEnableKeyboard to enable. NewFrame() will automatically fill io.NavInputs[] based on your io.KeysDown[] + io.KeyMap[] arrays. +// Gamepad: Set io.ConfigFlags |= ImGuiConfigFlags_NavEnableGamepad to enable. Backend: set ImGuiBackendFlags_HasGamepad and fill the io.NavInputs[] fields before calling NewFrame(). Note that io.NavInputs[] is cleared by EndFrame(). +// Read instructions in imgui.cpp for more details. Download PNG/PSD at http://dearimgui.org/controls_sheets. +enum ImGuiNavInput_ +{ + // Gamepad Mapping + ImGuiNavInput_Activate, // activate / open / toggle / tweak value // e.g. Cross (PS4), A (Xbox), A (Switch), Space (Keyboard) + ImGuiNavInput_Cancel, // cancel / close / exit // e.g. Circle (PS4), B (Xbox), B (Switch), Escape (Keyboard) + ImGuiNavInput_Input, // text input / on-screen keyboard // e.g. Triang.(PS4), Y (Xbox), X (Switch), Return (Keyboard) + ImGuiNavInput_Menu, // tap: toggle menu / hold: focus, move, resize // e.g. Square (PS4), X (Xbox), Y (Switch), Alt (Keyboard) + ImGuiNavInput_DpadLeft, // move / tweak / resize window (w/ PadMenu) // e.g. D-pad Left/Right/Up/Down (Gamepads), Arrow keys (Keyboard) + ImGuiNavInput_DpadRight, // + ImGuiNavInput_DpadUp, // + ImGuiNavInput_DpadDown, // + ImGuiNavInput_LStickLeft, // scroll / move window (w/ PadMenu) // e.g. Left Analog Stick Left/Right/Up/Down + ImGuiNavInput_LStickRight, // + ImGuiNavInput_LStickUp, // + ImGuiNavInput_LStickDown, // + ImGuiNavInput_FocusPrev, // next window (w/ PadMenu) // e.g. L1 or L2 (PS4), LB or LT (Xbox), L or ZL (Switch) + ImGuiNavInput_FocusNext, // prev window (w/ PadMenu) // e.g. R1 or R2 (PS4), RB or RT (Xbox), R or ZL (Switch) + ImGuiNavInput_TweakSlow, // slower tweaks // e.g. L1 or L2 (PS4), LB or LT (Xbox), L or ZL (Switch) + ImGuiNavInput_TweakFast, // faster tweaks // e.g. R1 or R2 (PS4), RB or RT (Xbox), R or ZL (Switch) + + // [Internal] Don't use directly! This is used internally to differentiate keyboard from gamepad inputs for behaviors that require to differentiate them. + // Keyboard behavior that have no corresponding gamepad mapping (e.g. CTRL+TAB) will be directly reading from io.KeysDown[] instead of io.NavInputs[]. + ImGuiNavInput_KeyLeft_, // move left // = Arrow keys + ImGuiNavInput_KeyRight_, // move right + ImGuiNavInput_KeyUp_, // move up + ImGuiNavInput_KeyDown_, // move down + ImGuiNavInput_COUNT, + ImGuiNavInput_InternalStart_ = ImGuiNavInput_KeyLeft_ +}; + +// Configuration flags stored in io.ConfigFlags. Set by user/application. +enum ImGuiConfigFlags_ +{ + ImGuiConfigFlags_None = 0, + ImGuiConfigFlags_NavEnableKeyboard = 1 << 0, // Master keyboard navigation enable flag. NewFrame() will automatically fill io.NavInputs[] based on io.KeysDown[]. + ImGuiConfigFlags_NavEnableGamepad = 1 << 1, // Master gamepad navigation enable flag. This is mostly to instruct your imgui backend to fill io.NavInputs[]. Backend also needs to set ImGuiBackendFlags_HasGamepad. + ImGuiConfigFlags_NavEnableSetMousePos = 1 << 2, // Instruct navigation to move the mouse cursor. May be useful on TV/console systems where moving a virtual mouse is awkward. Will update io.MousePos and set io.WantSetMousePos=true. If enabled you MUST honor io.WantSetMousePos requests in your backend, otherwise ImGui will react as if the mouse is jumping around back and forth. + ImGuiConfigFlags_NavNoCaptureKeyboard = 1 << 3, // Instruct navigation to not set the io.WantCaptureKeyboard flag when io.NavActive is set. + ImGuiConfigFlags_NoMouse = 1 << 4, // Instruct imgui to clear mouse position/buttons in NewFrame(). This allows ignoring the mouse information set by the backend. + ImGuiConfigFlags_NoMouseCursorChange = 1 << 5, // Instruct backend to not alter mouse cursor shape and visibility. Use if the backend cursor changes are interfering with yours and you don't want to use SetMouseCursor() to change mouse cursor. You may want to honor requests from imgui by reading GetMouseCursor() yourself instead. + + // User storage (to allow your backend/engine to communicate to code that may be shared between multiple projects. Those flags are not used by core Dear ImGui) + ImGuiConfigFlags_IsSRGB = 1 << 20, // Application is SRGB-aware. + ImGuiConfigFlags_IsTouchScreen = 1 << 21 // Application is using a touch screen instead of a mouse. +}; + +// Backend capabilities flags stored in io.BackendFlags. Set by imgui_impl_xxx or custom backend. +enum ImGuiBackendFlags_ +{ + ImGuiBackendFlags_None = 0, + ImGuiBackendFlags_HasGamepad = 1 << 0, // Backend Platform supports gamepad and currently has one connected. + ImGuiBackendFlags_HasMouseCursors = 1 << 1, // Backend Platform supports honoring GetMouseCursor() value to change the OS cursor shape. + ImGuiBackendFlags_HasSetMousePos = 1 << 2, // Backend Platform supports io.WantSetMousePos requests to reposition the OS mouse position (only used if ImGuiConfigFlags_NavEnableSetMousePos is set). + ImGuiBackendFlags_RendererHasVtxOffset = 1 << 3 // Backend Renderer supports ImDrawCmd::VtxOffset. This enables output of large meshes (64K+ vertices) while still using 16-bit indices. +}; + +// Enumeration for PushStyleColor() / PopStyleColor() +enum ImGuiCol_ +{ + ImGuiCol_Text, + ImGuiCol_TextDisabled, + ImGuiCol_WindowBg, // Background of normal windows + ImGuiCol_ChildBg, // Background of child windows + ImGuiCol_PopupBg, // Background of popups, menus, tooltips windows + ImGuiCol_Border, + ImGuiCol_BorderShadow, + ImGuiCol_FrameBg, // Background of checkbox, radio button, plot, slider, text input + ImGuiCol_FrameBgHovered, + ImGuiCol_FrameBgActive, + ImGuiCol_TitleBg, + ImGuiCol_TitleBgActive, + ImGuiCol_TitleBgCollapsed, + ImGuiCol_MenuBarBg, + ImGuiCol_ScrollbarBg, + ImGuiCol_ScrollbarGrab, + ImGuiCol_ScrollbarGrabHovered, + ImGuiCol_ScrollbarGrabActive, + ImGuiCol_CheckMark, + ImGuiCol_SliderGrab, + ImGuiCol_SliderGrabActive, + ImGuiCol_Button, + ImGuiCol_ButtonHovered, + ImGuiCol_ButtonActive, + ImGuiCol_Header, // Header* colors are used for CollapsingHeader, TreeNode, Selectable, MenuItem + ImGuiCol_HeaderHovered, + ImGuiCol_HeaderActive, + ImGuiCol_Separator, + ImGuiCol_SeparatorHovered, + ImGuiCol_SeparatorActive, + ImGuiCol_ResizeGrip, + ImGuiCol_ResizeGripHovered, + ImGuiCol_ResizeGripActive, + ImGuiCol_Tab, + ImGuiCol_TabHovered, + ImGuiCol_TabActive, + ImGuiCol_TabUnfocused, + ImGuiCol_TabUnfocusedActive, + ImGuiCol_PlotLines, + ImGuiCol_PlotLinesHovered, + ImGuiCol_PlotHistogram, + ImGuiCol_PlotHistogramHovered, + ImGuiCol_TableHeaderBg, // Table header background + ImGuiCol_TableBorderStrong, // Table outer and header borders (prefer using Alpha=1.0 here) + ImGuiCol_TableBorderLight, // Table inner borders (prefer using Alpha=1.0 here) + ImGuiCol_TableRowBg, // Table row background (even rows) + ImGuiCol_TableRowBgAlt, // Table row background (odd rows) + ImGuiCol_TextSelectedBg, + ImGuiCol_DragDropTarget, + ImGuiCol_NavHighlight, // Gamepad/keyboard: current highlighted item + ImGuiCol_NavWindowingHighlight, // Highlight window when using CTRL+TAB + ImGuiCol_NavWindowingDimBg, // Darken/colorize entire screen behind the CTRL+TAB window list, when active + ImGuiCol_ModalWindowDimBg, // Darken/colorize entire screen behind a modal window, when one is active + ImGuiCol_COUNT +}; + +// Enumeration for PushStyleVar() / PopStyleVar() to temporarily modify the ImGuiStyle structure. +// - The enum only refers to fields of ImGuiStyle which makes sense to be pushed/popped inside UI code. +// During initialization or between frames, feel free to just poke into ImGuiStyle directly. +// - Tip: Use your programming IDE navigation facilities on the names in the _second column_ below to find the actual members and their description. +// In Visual Studio IDE: CTRL+comma ("Edit.NavigateTo") can follow symbols in comments, whereas CTRL+F12 ("Edit.GoToImplementation") cannot. +// With Visual Assist installed: ALT+G ("VAssistX.GoToImplementation") can also follow symbols in comments. +// - When changing this enum, you need to update the associated internal table GStyleVarInfo[] accordingly. This is where we link enum values to members offset/type. +enum ImGuiStyleVar_ +{ + // Enum name --------------------- // Member in ImGuiStyle structure (see ImGuiStyle for descriptions) + ImGuiStyleVar_Alpha, // float Alpha + ImGuiStyleVar_DisabledAlpha, // float DisabledAlpha + ImGuiStyleVar_WindowPadding, // ImVec2 WindowPadding + ImGuiStyleVar_WindowRounding, // float WindowRounding + ImGuiStyleVar_WindowBorderSize, // float WindowBorderSize + ImGuiStyleVar_WindowMinSize, // ImVec2 WindowMinSize + ImGuiStyleVar_WindowTitleAlign, // ImVec2 WindowTitleAlign + ImGuiStyleVar_ChildRounding, // float ChildRounding + ImGuiStyleVar_ChildBorderSize, // float ChildBorderSize + ImGuiStyleVar_PopupRounding, // float PopupRounding + ImGuiStyleVar_PopupBorderSize, // float PopupBorderSize + ImGuiStyleVar_FramePadding, // ImVec2 FramePadding + ImGuiStyleVar_FrameRounding, // float FrameRounding + ImGuiStyleVar_FrameBorderSize, // float FrameBorderSize + ImGuiStyleVar_ItemSpacing, // ImVec2 ItemSpacing + ImGuiStyleVar_ItemInnerSpacing, // ImVec2 ItemInnerSpacing + ImGuiStyleVar_IndentSpacing, // float IndentSpacing + ImGuiStyleVar_CellPadding, // ImVec2 CellPadding + ImGuiStyleVar_ScrollbarSize, // float ScrollbarSize + ImGuiStyleVar_ScrollbarRounding, // float ScrollbarRounding + ImGuiStyleVar_GrabMinSize, // float GrabMinSize + ImGuiStyleVar_GrabRounding, // float GrabRounding + ImGuiStyleVar_TabRounding, // float TabRounding + ImGuiStyleVar_ButtonTextAlign, // ImVec2 ButtonTextAlign + ImGuiStyleVar_SelectableTextAlign, // ImVec2 SelectableTextAlign + ImGuiStyleVar_COUNT +}; + +// Flags for InvisibleButton() [extended in imgui_internal.h] +enum ImGuiButtonFlags_ +{ + ImGuiButtonFlags_None = 0, + ImGuiButtonFlags_MouseButtonLeft = 1 << 0, // React on left mouse button (default) + ImGuiButtonFlags_MouseButtonRight = 1 << 1, // React on right mouse button + ImGuiButtonFlags_MouseButtonMiddle = 1 << 2, // React on center mouse button + + // [Internal] + ImGuiButtonFlags_MouseButtonMask_ = ImGuiButtonFlags_MouseButtonLeft | ImGuiButtonFlags_MouseButtonRight | ImGuiButtonFlags_MouseButtonMiddle, + ImGuiButtonFlags_MouseButtonDefault_ = ImGuiButtonFlags_MouseButtonLeft +}; + +// Flags for ColorEdit3() / ColorEdit4() / ColorPicker3() / ColorPicker4() / ColorButton() +enum ImGuiColorEditFlags_ +{ + ImGuiColorEditFlags_None = 0, + ImGuiColorEditFlags_NoAlpha = 1 << 1, // // ColorEdit, ColorPicker, ColorButton: ignore Alpha component (will only read 3 components from the input pointer). + ImGuiColorEditFlags_NoPicker = 1 << 2, // // ColorEdit: disable picker when clicking on color square. + ImGuiColorEditFlags_NoOptions = 1 << 3, // // ColorEdit: disable toggling options menu when right-clicking on inputs/small preview. + ImGuiColorEditFlags_NoSmallPreview = 1 << 4, // // ColorEdit, ColorPicker: disable color square preview next to the inputs. (e.g. to show only the inputs) + ImGuiColorEditFlags_NoInputs = 1 << 5, // // ColorEdit, ColorPicker: disable inputs sliders/text widgets (e.g. to show only the small preview color square). + ImGuiColorEditFlags_NoTooltip = 1 << 6, // // ColorEdit, ColorPicker, ColorButton: disable tooltip when hovering the preview. + ImGuiColorEditFlags_NoLabel = 1 << 7, // // ColorEdit, ColorPicker: disable display of inline text label (the label is still forwarded to the tooltip and picker). + ImGuiColorEditFlags_NoSidePreview = 1 << 8, // // ColorPicker: disable bigger color preview on right side of the picker, use small color square preview instead. + ImGuiColorEditFlags_NoDragDrop = 1 << 9, // // ColorEdit: disable drag and drop target. ColorButton: disable drag and drop source. + ImGuiColorEditFlags_NoBorder = 1 << 10, // // ColorButton: disable border (which is enforced by default) + + // User Options (right-click on widget to change some of them). + ImGuiColorEditFlags_AlphaBar = 1 << 16, // // ColorEdit, ColorPicker: show vertical alpha bar/gradient in picker. + ImGuiColorEditFlags_AlphaPreview = 1 << 17, // // ColorEdit, ColorPicker, ColorButton: display preview as a transparent color over a checkerboard, instead of opaque. + ImGuiColorEditFlags_AlphaPreviewHalf= 1 << 18, // // ColorEdit, ColorPicker, ColorButton: display half opaque / half checkerboard, instead of opaque. + ImGuiColorEditFlags_HDR = 1 << 19, // // (WIP) ColorEdit: Currently only disable 0.0f..1.0f limits in RGBA edition (note: you probably want to use ImGuiColorEditFlags_Float flag as well). + ImGuiColorEditFlags_DisplayRGB = 1 << 20, // [Display] // ColorEdit: override _display_ type among RGB/HSV/Hex. ColorPicker: select any combination using one or more of RGB/HSV/Hex. + ImGuiColorEditFlags_DisplayHSV = 1 << 21, // [Display] // " + ImGuiColorEditFlags_DisplayHex = 1 << 22, // [Display] // " + ImGuiColorEditFlags_Uint8 = 1 << 23, // [DataType] // ColorEdit, ColorPicker, ColorButton: _display_ values formatted as 0..255. + ImGuiColorEditFlags_Float = 1 << 24, // [DataType] // ColorEdit, ColorPicker, ColorButton: _display_ values formatted as 0.0f..1.0f floats instead of 0..255 integers. No round-trip of value via integers. + ImGuiColorEditFlags_PickerHueBar = 1 << 25, // [Picker] // ColorPicker: bar for Hue, rectangle for Sat/Value. + ImGuiColorEditFlags_PickerHueWheel = 1 << 26, // [Picker] // ColorPicker: wheel for Hue, triangle for Sat/Value. + ImGuiColorEditFlags_InputRGB = 1 << 27, // [Input] // ColorEdit, ColorPicker: input and output data in RGB format. + ImGuiColorEditFlags_InputHSV = 1 << 28, // [Input] // ColorEdit, ColorPicker: input and output data in HSV format. + + // Defaults Options. You can set application defaults using SetColorEditOptions(). The intent is that you probably don't want to + // override them in most of your calls. Let the user choose via the option menu and/or call SetColorEditOptions() once during startup. + ImGuiColorEditFlags_DefaultOptions_ = ImGuiColorEditFlags_Uint8 | ImGuiColorEditFlags_DisplayRGB | ImGuiColorEditFlags_InputRGB | ImGuiColorEditFlags_PickerHueBar, + + // [Internal] Masks + ImGuiColorEditFlags_DisplayMask_ = ImGuiColorEditFlags_DisplayRGB | ImGuiColorEditFlags_DisplayHSV | ImGuiColorEditFlags_DisplayHex, + ImGuiColorEditFlags_DataTypeMask_ = ImGuiColorEditFlags_Uint8 | ImGuiColorEditFlags_Float, + ImGuiColorEditFlags_PickerMask_ = ImGuiColorEditFlags_PickerHueWheel | ImGuiColorEditFlags_PickerHueBar, + ImGuiColorEditFlags_InputMask_ = ImGuiColorEditFlags_InputRGB | ImGuiColorEditFlags_InputHSV + + // Obsolete names (will be removed) +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + , ImGuiColorEditFlags_RGB = ImGuiColorEditFlags_DisplayRGB, ImGuiColorEditFlags_HSV = ImGuiColorEditFlags_DisplayHSV, ImGuiColorEditFlags_HEX = ImGuiColorEditFlags_DisplayHex // [renamed in 1.69] +#endif +}; + +// Flags for DragFloat(), DragInt(), SliderFloat(), SliderInt() etc. +// We use the same sets of flags for DragXXX() and SliderXXX() functions as the features are the same and it makes it easier to swap them. +enum ImGuiSliderFlags_ +{ + ImGuiSliderFlags_None = 0, + ImGuiSliderFlags_AlwaysClamp = 1 << 4, // Clamp value to min/max bounds when input manually with CTRL+Click. By default CTRL+Click allows going out of bounds. + ImGuiSliderFlags_Logarithmic = 1 << 5, // Make the widget logarithmic (linear otherwise). Consider using ImGuiSliderFlags_NoRoundToFormat with this if using a format-string with small amount of digits. + ImGuiSliderFlags_NoRoundToFormat = 1 << 6, // Disable rounding underlying value to match precision of the display format string (e.g. %.3f values are rounded to those 3 digits) + ImGuiSliderFlags_NoInput = 1 << 7, // Disable CTRL+Click or Enter key allowing to input text directly into the widget + ImGuiSliderFlags_InvalidMask_ = 0x7000000F // [Internal] We treat using those bits as being potentially a 'float power' argument from the previous API that has got miscast to this enum, and will trigger an assert if needed. + + // Obsolete names (will be removed) +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + , ImGuiSliderFlags_ClampOnInput = ImGuiSliderFlags_AlwaysClamp // [renamed in 1.79] +#endif +}; + +// Identify a mouse button. +// Those values are guaranteed to be stable and we frequently use 0/1 directly. Named enums provided for convenience. +enum ImGuiMouseButton_ +{ + ImGuiMouseButton_Left = 0, + ImGuiMouseButton_Right = 1, + ImGuiMouseButton_Middle = 2, + ImGuiMouseButton_COUNT = 5 +}; + +// Enumeration for GetMouseCursor() +// User code may request backend to display given cursor by calling SetMouseCursor(), which is why we have some cursors that are marked unused here +enum ImGuiMouseCursor_ +{ + ImGuiMouseCursor_None = -1, + ImGuiMouseCursor_Arrow = 0, + ImGuiMouseCursor_TextInput, // When hovering over InputText, etc. + ImGuiMouseCursor_ResizeAll, // (Unused by Dear ImGui functions) + ImGuiMouseCursor_ResizeNS, // When hovering over an horizontal border + ImGuiMouseCursor_ResizeEW, // When hovering over a vertical border or a column + ImGuiMouseCursor_ResizeNESW, // When hovering over the bottom-left corner of a window + ImGuiMouseCursor_ResizeNWSE, // When hovering over the bottom-right corner of a window + ImGuiMouseCursor_Hand, // (Unused by Dear ImGui functions. Use for e.g. hyperlinks) + ImGuiMouseCursor_NotAllowed, // When hovering something with disallowed interaction. Usually a crossed circle. + ImGuiMouseCursor_COUNT +}; + +// Enumeration for ImGui::SetWindow***(), SetNextWindow***(), SetNextItem***() functions +// Represent a condition. +// Important: Treat as a regular enum! Do NOT combine multiple values using binary operators! All the functions above treat 0 as a shortcut to ImGuiCond_Always. +enum ImGuiCond_ +{ + ImGuiCond_None = 0, // No condition (always set the variable), same as _Always + ImGuiCond_Always = 1 << 0, // No condition (always set the variable) + ImGuiCond_Once = 1 << 1, // Set the variable once per runtime session (only the first call will succeed) + ImGuiCond_FirstUseEver = 1 << 2, // Set the variable if the object/window has no persistently saved data (no entry in .ini file) + ImGuiCond_Appearing = 1 << 3 // Set the variable if the object/window is appearing after being hidden/inactive (or the first time) +}; + +//----------------------------------------------------------------------------- +// [SECTION] Helpers: Memory allocations macros, ImVector<> +//----------------------------------------------------------------------------- + +//----------------------------------------------------------------------------- +// IM_MALLOC(), IM_FREE(), IM_NEW(), IM_PLACEMENT_NEW(), IM_DELETE() +// We call C++ constructor on own allocated memory via the placement "new(ptr) Type()" syntax. +// Defining a custom placement new() with a custom parameter allows us to bypass including which on some platforms complains when user has disabled exceptions. +//----------------------------------------------------------------------------- + +struct ImNewWrapper {}; +inline void* operator new(size_t, ImNewWrapper, void* ptr) { return ptr; } +inline void operator delete(void*, ImNewWrapper, void*) {} // This is only required so we can use the symmetrical new() +#define IM_ALLOC(_SIZE) ImGui::MemAlloc(_SIZE) +#define IM_FREE(_PTR) ImGui::MemFree(_PTR) +#define IM_PLACEMENT_NEW(_PTR) new(ImNewWrapper(), _PTR) +#define IM_NEW(_TYPE) new(ImNewWrapper(), ImGui::MemAlloc(sizeof(_TYPE))) _TYPE +template void IM_DELETE(T* p) { if (p) { p->~T(); ImGui::MemFree(p); } } + +//----------------------------------------------------------------------------- +// ImVector<> +// Lightweight std::vector<>-like class to avoid dragging dependencies (also, some implementations of STL with debug enabled are absurdly slow, we bypass it so our code runs fast in debug). +//----------------------------------------------------------------------------- +// - You generally do NOT need to care or use this ever. But we need to make it available in imgui.h because some of our public structures are relying on it. +// - We use std-like naming convention here, which is a little unusual for this codebase. +// - Important: clear() frees memory, resize(0) keep the allocated buffer. We use resize(0) a lot to intentionally recycle allocated buffers across frames and amortize our costs. +// - Important: our implementation does NOT call C++ constructors/destructors, we treat everything as raw data! This is intentional but be extra mindful of that, +// Do NOT use this class as a std::vector replacement in your own code! Many of the structures used by dear imgui can be safely initialized by a zero-memset. +//----------------------------------------------------------------------------- + +IM_MSVC_RUNTIME_CHECKS_OFF +template +struct ImVector +{ + int Size; + int Capacity; + T* Data; + + // Provide standard typedefs but we don't use them ourselves. + typedef T value_type; + typedef value_type* iterator; + typedef const value_type* const_iterator; + + // Constructors, destructor + inline ImVector() { Size = Capacity = 0; Data = NULL; } + inline ImVector(const ImVector& src) { Size = Capacity = 0; Data = NULL; operator=(src); } + inline ImVector& operator=(const ImVector& src) { clear(); resize(src.Size); memcpy(Data, src.Data, (size_t)Size * sizeof(T)); return *this; } + inline ~ImVector() { if (Data) IM_FREE(Data); } // Important: does not destruct anything + + inline void clear() { if (Data) { Size = Capacity = 0; IM_FREE(Data); Data = NULL; } } // Important: does not destruct anything + inline void clear_delete() { for (int n = 0; n < Size; n++) IM_DELETE(Data[n]); clear(); } // Important: never called automatically! always explicit. + inline void clear_destruct() { for (int n = 0; n < Size; n++) Data[n].~T(); clear(); } // Important: never called automatically! always explicit. + + inline bool empty() const { return Size == 0; } + inline int size() const { return Size; } + inline int size_in_bytes() const { return Size * (int)sizeof(T); } + inline int max_size() const { return 0x7FFFFFFF / (int)sizeof(T); } + inline int capacity() const { return Capacity; } + inline T& operator[](int i) { IM_ASSERT(i >= 0 && i < Size); return Data[i]; } + inline const T& operator[](int i) const { IM_ASSERT(i >= 0 && i < Size); return Data[i]; } + + inline T* begin() { return Data; } + inline const T* begin() const { return Data; } + inline T* end() { return Data + Size; } + inline const T* end() const { return Data + Size; } + inline T& front() { IM_ASSERT(Size > 0); return Data[0]; } + inline const T& front() const { IM_ASSERT(Size > 0); return Data[0]; } + inline T& back() { IM_ASSERT(Size > 0); return Data[Size - 1]; } + inline const T& back() const { IM_ASSERT(Size > 0); return Data[Size - 1]; } + inline void swap(ImVector& rhs) { int rhs_size = rhs.Size; rhs.Size = Size; Size = rhs_size; int rhs_cap = rhs.Capacity; rhs.Capacity = Capacity; Capacity = rhs_cap; T* rhs_data = rhs.Data; rhs.Data = Data; Data = rhs_data; } + + inline int _grow_capacity(int sz) const { int new_capacity = Capacity ? (Capacity + Capacity / 2) : 8; return new_capacity > sz ? new_capacity : sz; } + inline void resize(int new_size) { if (new_size > Capacity) reserve(_grow_capacity(new_size)); Size = new_size; } + inline void resize(int new_size, const T& v) { if (new_size > Capacity) reserve(_grow_capacity(new_size)); if (new_size > Size) for (int n = Size; n < new_size; n++) memcpy(&Data[n], &v, sizeof(v)); Size = new_size; } + inline void shrink(int new_size) { IM_ASSERT(new_size <= Size); Size = new_size; } // Resize a vector to a smaller size, guaranteed not to cause a reallocation + inline void reserve(int new_capacity) { if (new_capacity <= Capacity) return; T* new_data = (T*)IM_ALLOC((size_t)new_capacity * sizeof(T)); if (Data) { memcpy(new_data, Data, (size_t)Size * sizeof(T)); IM_FREE(Data); } Data = new_data; Capacity = new_capacity; } + + // NB: It is illegal to call push_back/push_front/insert with a reference pointing inside the ImVector data itself! e.g. v.push_back(v[10]) is forbidden. + inline void push_back(const T& v) { if (Size == Capacity) reserve(_grow_capacity(Size + 1)); memcpy(&Data[Size], &v, sizeof(v)); Size++; } + inline void pop_back() { IM_ASSERT(Size > 0); Size--; } + inline void push_front(const T& v) { if (Size == 0) push_back(v); else insert(Data, v); } + inline T* erase(const T* it) { IM_ASSERT(it >= Data && it < Data + Size); const ptrdiff_t off = it - Data; memmove(Data + off, Data + off + 1, ((size_t)Size - (size_t)off - 1) * sizeof(T)); Size--; return Data + off; } + inline T* erase(const T* it, const T* it_last){ IM_ASSERT(it >= Data && it < Data + Size && it_last > it && it_last <= Data + Size); const ptrdiff_t count = it_last - it; const ptrdiff_t off = it - Data; memmove(Data + off, Data + off + count, ((size_t)Size - (size_t)off - count) * sizeof(T)); Size -= (int)count; return Data + off; } + inline T* erase_unsorted(const T* it) { IM_ASSERT(it >= Data && it < Data + Size); const ptrdiff_t off = it - Data; if (it < Data + Size - 1) memcpy(Data + off, Data + Size - 1, sizeof(T)); Size--; return Data + off; } + inline T* insert(const T* it, const T& v) { IM_ASSERT(it >= Data && it <= Data + Size); const ptrdiff_t off = it - Data; if (Size == Capacity) reserve(_grow_capacity(Size + 1)); if (off < (int)Size) memmove(Data + off + 1, Data + off, ((size_t)Size - (size_t)off) * sizeof(T)); memcpy(&Data[off], &v, sizeof(v)); Size++; return Data + off; } + inline bool contains(const T& v) const { const T* data = Data; const T* data_end = Data + Size; while (data < data_end) if (*data++ == v) return true; return false; } + inline T* find(const T& v) { T* data = Data; const T* data_end = Data + Size; while (data < data_end) if (*data == v) break; else ++data; return data; } + inline const T* find(const T& v) const { const T* data = Data; const T* data_end = Data + Size; while (data < data_end) if (*data == v) break; else ++data; return data; } + inline bool find_erase(const T& v) { const T* it = find(v); if (it < Data + Size) { erase(it); return true; } return false; } + inline bool find_erase_unsorted(const T& v) { const T* it = find(v); if (it < Data + Size) { erase_unsorted(it); return true; } return false; } + inline int index_from_ptr(const T* it) const { IM_ASSERT(it >= Data && it < Data + Size); const ptrdiff_t off = it - Data; return (int)off; } +}; +IM_MSVC_RUNTIME_CHECKS_RESTORE + +//----------------------------------------------------------------------------- +// [SECTION] ImGuiStyle +//----------------------------------------------------------------------------- +// You may modify the ImGui::GetStyle() main instance during initialization and before NewFrame(). +// During the frame, use ImGui::PushStyleVar(ImGuiStyleVar_XXXX)/PopStyleVar() to alter the main style values, +// and ImGui::PushStyleColor(ImGuiCol_XXX)/PopStyleColor() for colors. +//----------------------------------------------------------------------------- + +struct ImGuiStyle +{ + float Alpha; // Global alpha applies to everything in Dear ImGui. + float DisabledAlpha; // Additional alpha multiplier applied by BeginDisabled(). Multiply over current value of Alpha. + ImVec2 WindowPadding; // Padding within a window. + float WindowRounding; // Radius of window corners rounding. Set to 0.0f to have rectangular windows. Large values tend to lead to variety of artifacts and are not recommended. + float WindowBorderSize; // Thickness of border around windows. Generally set to 0.0f or 1.0f. (Other values are not well tested and more CPU/GPU costly). + ImVec2 WindowMinSize; // Minimum window size. This is a global setting. If you want to constraint individual windows, use SetNextWindowSizeConstraints(). + ImVec2 WindowTitleAlign; // Alignment for title bar text. Defaults to (0.0f,0.5f) for left-aligned,vertically centered. + ImGuiDir WindowMenuButtonPosition; // Side of the collapsing/docking button in the title bar (None/Left/Right). Defaults to ImGuiDir_Left. + float ChildRounding; // Radius of child window corners rounding. Set to 0.0f to have rectangular windows. + float ChildBorderSize; // Thickness of border around child windows. Generally set to 0.0f or 1.0f. (Other values are not well tested and more CPU/GPU costly). + float PopupRounding; // Radius of popup window corners rounding. (Note that tooltip windows use WindowRounding) + float PopupBorderSize; // Thickness of border around popup/tooltip windows. Generally set to 0.0f or 1.0f. (Other values are not well tested and more CPU/GPU costly). + ImVec2 FramePadding; // Padding within a framed rectangle (used by most widgets). + float FrameRounding; // Radius of frame corners rounding. Set to 0.0f to have rectangular frame (used by most widgets). + float FrameBorderSize; // Thickness of border around frames. Generally set to 0.0f or 1.0f. (Other values are not well tested and more CPU/GPU costly). + ImVec2 ItemSpacing; // Horizontal and vertical spacing between widgets/lines. + ImVec2 ItemInnerSpacing; // Horizontal and vertical spacing between within elements of a composed widget (e.g. a slider and its label). + ImVec2 CellPadding; // Padding within a table cell + ImVec2 TouchExtraPadding; // Expand reactive bounding box for touch-based system where touch position is not accurate enough. Unfortunately we don't sort widgets so priority on overlap will always be given to the first widget. So don't grow this too much! + float IndentSpacing; // Horizontal indentation when e.g. entering a tree node. Generally == (FontSize + FramePadding.x*2). + float ColumnsMinSpacing; // Minimum horizontal spacing between two columns. Preferably > (FramePadding.x + 1). + float ScrollbarSize; // Width of the vertical scrollbar, Height of the horizontal scrollbar. + float ScrollbarRounding; // Radius of grab corners for scrollbar. + float GrabMinSize; // Minimum width/height of a grab box for slider/scrollbar. + float GrabRounding; // Radius of grabs corners rounding. Set to 0.0f to have rectangular slider grabs. + float LogSliderDeadzone; // The size in pixels of the dead-zone around zero on logarithmic sliders that cross zero. + float TabRounding; // Radius of upper corners of a tab. Set to 0.0f to have rectangular tabs. + float TabBorderSize; // Thickness of border around tabs. + float TabMinWidthForCloseButton; // Minimum width for close button to appears on an unselected tab when hovered. Set to 0.0f to always show when hovering, set to FLT_MAX to never show close button unless selected. + ImGuiDir ColorButtonPosition; // Side of the color button in the ColorEdit4 widget (left/right). Defaults to ImGuiDir_Right. + ImVec2 ButtonTextAlign; // Alignment of button text when button is larger than text. Defaults to (0.5f, 0.5f) (centered). + ImVec2 SelectableTextAlign; // Alignment of selectable text. Defaults to (0.0f, 0.0f) (top-left aligned). It's generally important to keep this left-aligned if you want to lay multiple items on a same line. + ImVec2 DisplayWindowPadding; // Window position are clamped to be visible within the display area or monitors by at least this amount. Only applies to regular windows. + ImVec2 DisplaySafeAreaPadding; // If you cannot see the edges of your screen (e.g. on a TV) increase the safe area padding. Apply to popups/tooltips as well regular windows. NB: Prefer configuring your TV sets correctly! + float MouseCursorScale; // Scale software rendered mouse cursor (when io.MouseDrawCursor is enabled). May be removed later. + bool AntiAliasedLines; // Enable anti-aliased lines/borders. Disable if you are really tight on CPU/GPU. Latched at the beginning of the frame (copied to ImDrawList). + bool AntiAliasedLinesUseTex; // Enable anti-aliased lines/borders using textures where possible. Require backend to render with bilinear filtering. Latched at the beginning of the frame (copied to ImDrawList). + bool AntiAliasedFill; // Enable anti-aliased edges around filled shapes (rounded rectangles, circles, etc.). Disable if you are really tight on CPU/GPU. Latched at the beginning of the frame (copied to ImDrawList). + float CurveTessellationTol; // Tessellation tolerance when using PathBezierCurveTo() without a specific number of segments. Decrease for highly tessellated curves (higher quality, more polygons), increase to reduce quality. + float CircleTessellationMaxError; // Maximum error (in pixels) allowed when using AddCircle()/AddCircleFilled() or drawing rounded corner rectangles with no explicit segment count specified. Decrease for higher quality but more geometry. + ImVec4 Colors[ImGuiCol_COUNT]; + + IMGUI_API ImGuiStyle(); + IMGUI_API void ScaleAllSizes(float scale_factor); +}; + +//----------------------------------------------------------------------------- +// [SECTION] ImGuiIO +//----------------------------------------------------------------------------- +// Communicate most settings and inputs/outputs to Dear ImGui using this structure. +// Access via ImGui::GetIO(). Read 'Programmer guide' section in .cpp file for general usage. +//----------------------------------------------------------------------------- + +struct ImGuiIO +{ + //------------------------------------------------------------------ + // Configuration (fill once) // Default value + //------------------------------------------------------------------ + + ImGuiConfigFlags ConfigFlags; // = 0 // See ImGuiConfigFlags_ enum. Set by user/application. Gamepad/keyboard navigation options, etc. + ImGuiBackendFlags BackendFlags; // = 0 // See ImGuiBackendFlags_ enum. Set by backend (imgui_impl_xxx files or custom backend) to communicate features supported by the backend. + ImVec2 DisplaySize; // // Main display size, in pixels (generally == GetMainViewport()->Size) + float DeltaTime; // = 1.0f/60.0f // Time elapsed since last frame, in seconds. + float IniSavingRate; // = 5.0f // Minimum time between saving positions/sizes to .ini file, in seconds. + const char* IniFilename; // = "imgui.ini" // Path to .ini file (important: default "imgui.ini" is relative to current working dir!). Set NULL to disable automatic .ini loading/saving or if you want to manually call LoadIniSettingsXXX() / SaveIniSettingsXXX() functions. + const char* LogFilename; // = "imgui_log.txt"// Path to .log file (default parameter to ImGui::LogToFile when no file is specified). + float MouseDoubleClickTime; // = 0.30f // Time for a double-click, in seconds. + float MouseDoubleClickMaxDist; // = 6.0f // Distance threshold to stay in to validate a double-click, in pixels. + float MouseDragThreshold; // = 6.0f // Distance threshold before considering we are dragging. + int KeyMap[ImGuiKey_COUNT]; // // Map of indices into the KeysDown[512] entries array which represent your "native" keyboard state. + float KeyRepeatDelay; // = 0.250f // When holding a key/button, time before it starts repeating, in seconds (for buttons in Repeat mode, etc.). + float KeyRepeatRate; // = 0.050f // When holding a key/button, rate at which it repeats, in seconds. + void* UserData; // = NULL // Store your own data for retrieval by callbacks. + + ImFontAtlas*Fonts; // // Font atlas: load, rasterize and pack one or more fonts into a single texture. + float FontGlobalScale; // = 1.0f // Global scale all fonts + bool FontAllowUserScaling; // = false // Allow user scaling text of individual window with CTRL+Wheel. + ImFont* FontDefault; // = NULL // Font to use on NewFrame(). Use NULL to uses Fonts->Fonts[0]. + ImVec2 DisplayFramebufferScale; // = (1, 1) // For retina display or other situations where window coordinates are different from framebuffer coordinates. This generally ends up in ImDrawData::FramebufferScale. + + // Miscellaneous options + bool MouseDrawCursor; // = false // Request ImGui to draw a mouse cursor for you (if you are on a platform without a mouse cursor). Cannot be easily renamed to 'io.ConfigXXX' because this is frequently used by backend implementations. + bool ConfigMacOSXBehaviors; // = defined(__APPLE__) // OS X style: Text editing cursor movement using Alt instead of Ctrl, Shortcuts using Cmd/Super instead of Ctrl, Line/Text Start and End using Cmd+Arrows instead of Home/End, Double click selects by word instead of selecting whole text, Multi-selection in lists uses Cmd/Super instead of Ctrl. + bool ConfigInputTextCursorBlink; // = true // Enable blinking cursor (optional as some users consider it to be distracting). + bool ConfigDragClickToInputText; // = false // [BETA] Enable turning DragXXX widgets into text input with a simple mouse click-release (without moving). Not desirable on devices without a keyboard. + bool ConfigWindowsResizeFromEdges; // = true // Enable resizing of windows from their edges and from the lower-left corner. This requires (io.BackendFlags & ImGuiBackendFlags_HasMouseCursors) because it needs mouse cursor feedback. (This used to be a per-window ImGuiWindowFlags_ResizeFromAnySide flag) + bool ConfigWindowsMoveFromTitleBarOnly; // = false // Enable allowing to move windows only when clicking on their title bar. Does not apply to windows without a title bar. + float ConfigMemoryCompactTimer; // = 60.0f // Timer (in seconds) to free transient windows/tables memory buffers when unused. Set to -1.0f to disable. + + //------------------------------------------------------------------ + // Platform Functions + // (the imgui_impl_xxxx backend files are setting those up for you) + //------------------------------------------------------------------ + + // Optional: Platform/Renderer backend name (informational only! will be displayed in About Window) + User data for backend/wrappers to store their own stuff. + const char* BackendPlatformName; // = NULL + const char* BackendRendererName; // = NULL + void* BackendPlatformUserData; // = NULL // User data for platform backend + void* BackendRendererUserData; // = NULL // User data for renderer backend + void* BackendLanguageUserData; // = NULL // User data for non C++ programming language backend + + // Optional: Access OS clipboard + // (default to use native Win32 clipboard on Windows, otherwise uses a private clipboard. Override to access OS clipboard on other architectures) + const char* (*GetClipboardTextFn)(void* user_data); + void (*SetClipboardTextFn)(void* user_data, const char* text); + void* ClipboardUserData; + + // Optional: Notify OS Input Method Editor of the screen position of your cursor for text input position (e.g. when using Japanese/Chinese IME on Windows) + // (default to use native imm32 api on Windows) + void (*ImeSetInputScreenPosFn)(int x, int y); + void* ImeWindowHandle; // = NULL // (Windows) Set this to your HWND to get automatic IME cursor positioning. + + //------------------------------------------------------------------ + // Input - Fill before calling NewFrame() + //------------------------------------------------------------------ + + ImVec2 MousePos; // Mouse position, in pixels. Set to ImVec2(-FLT_MAX, -FLT_MAX) if mouse is unavailable (on another screen, etc.) + bool MouseDown[5]; // Mouse buttons: 0=left, 1=right, 2=middle + extras (ImGuiMouseButton_COUNT == 5). Dear ImGui mostly uses left and right buttons. Others buttons allows us to track if the mouse is being used by your application + available to user as a convenience via IsMouse** API. + float MouseWheel; // Mouse wheel Vertical: 1 unit scrolls about 5 lines text. + float MouseWheelH; // Mouse wheel Horizontal. Most users don't have a mouse with an horizontal wheel, may not be filled by all backends. + bool KeyCtrl; // Keyboard modifier pressed: Control + bool KeyShift; // Keyboard modifier pressed: Shift + bool KeyAlt; // Keyboard modifier pressed: Alt + bool KeySuper; // Keyboard modifier pressed: Cmd/Super/Windows + bool KeysDown[512]; // Keyboard keys that are pressed (ideally left in the "native" order your engine has access to keyboard keys, so you can use your own defines/enums for keys). + float NavInputs[ImGuiNavInput_COUNT]; // Gamepad inputs. Cleared back to zero by EndFrame(). Keyboard keys will be auto-mapped and be written here by NewFrame(). + + // Functions + IMGUI_API void AddInputCharacter(unsigned int c); // Queue new character input + IMGUI_API void AddInputCharacterUTF16(ImWchar16 c); // Queue new character input from an UTF-16 character, it can be a surrogate + IMGUI_API void AddInputCharactersUTF8(const char* str); // Queue new characters input from an UTF-8 string + IMGUI_API void ClearInputCharacters(); // Clear the text input buffer manually + IMGUI_API void AddFocusEvent(bool focused); // Notifies Dear ImGui when hosting platform windows lose or gain input focus + + //------------------------------------------------------------------ + // Output - Updated by NewFrame() or EndFrame()/Render() + // (when reading from the io.WantCaptureMouse, io.WantCaptureKeyboard flags to dispatch your inputs, it is + // generally easier and more correct to use their state BEFORE calling NewFrame(). See FAQ for details!) + //------------------------------------------------------------------ + + bool WantCaptureMouse; // Set when Dear ImGui will use mouse inputs, in this case do not dispatch them to your main game/application (either way, always pass on mouse inputs to imgui). (e.g. unclicked mouse is hovering over an imgui window, widget is active, mouse was clicked over an imgui window, etc.). + bool WantCaptureKeyboard; // Set when Dear ImGui will use keyboard inputs, in this case do not dispatch them to your main game/application (either way, always pass keyboard inputs to imgui). (e.g. InputText active, or an imgui window is focused and navigation is enabled, etc.). + bool WantTextInput; // Mobile/console: when set, you may display an on-screen keyboard. This is set by Dear ImGui when it wants textual keyboard input to happen (e.g. when a InputText widget is active). + bool WantSetMousePos; // MousePos has been altered, backend should reposition mouse on next frame. Rarely used! Set only when ImGuiConfigFlags_NavEnableSetMousePos flag is enabled. + bool WantSaveIniSettings; // When manual .ini load/save is active (io.IniFilename == NULL), this will be set to notify your application that you can call SaveIniSettingsToMemory() and save yourself. Important: clear io.WantSaveIniSettings yourself after saving! + bool NavActive; // Keyboard/Gamepad navigation is currently allowed (will handle ImGuiKey_NavXXX events) = a window is focused and it doesn't use the ImGuiWindowFlags_NoNavInputs flag. + bool NavVisible; // Keyboard/Gamepad navigation is visible and allowed (will handle ImGuiKey_NavXXX events). + float Framerate; // Rough estimate of application framerate, in frame per second. Solely for convenience. Rolling average estimation based on io.DeltaTime over 120 frames. + int MetricsRenderVertices; // Vertices output during last call to Render() + int MetricsRenderIndices; // Indices output during last call to Render() = number of triangles * 3 + int MetricsRenderWindows; // Number of visible windows + int MetricsActiveWindows; // Number of active windows + int MetricsActiveAllocations; // Number of active allocations, updated by MemAlloc/MemFree based on current context. May be off if you have multiple imgui contexts. + ImVec2 MouseDelta; // Mouse delta. Note that this is zero if either current or previous position are invalid (-FLT_MAX,-FLT_MAX), so a disappearing/reappearing mouse won't have a huge delta. + + //------------------------------------------------------------------ + // [Internal] Dear ImGui will maintain those fields. Forward compatibility not guaranteed! + //------------------------------------------------------------------ + + bool WantCaptureMouseUnlessPopupClose;// Alternative to WantCaptureMouse: (WantCaptureMouse == true && WantCaptureMouseUnlessPopupClose == false) when a click over void is expected to close a popup. + ImGuiKeyModFlags KeyMods; // Key mods flags (same as io.KeyCtrl/KeyShift/KeyAlt/KeySuper but merged into flags), updated by NewFrame() + ImGuiKeyModFlags KeyModsPrev; // Previous key mods + ImVec2 MousePosPrev; // Previous mouse position (note that MouseDelta is not necessary == MousePos-MousePosPrev, in case either position is invalid) + ImVec2 MouseClickedPos[5]; // Position at time of clicking + double MouseClickedTime[5]; // Time of last click (used to figure out double-click) + bool MouseClicked[5]; // Mouse button went from !Down to Down + bool MouseDoubleClicked[5]; // Has mouse button been double-clicked? + bool MouseReleased[5]; // Mouse button went from Down to !Down + bool MouseDownOwned[5]; // Track if button was clicked inside a dear imgui window or over void blocked by a popup. We don't request mouse capture from the application if click started outside ImGui bounds. + bool MouseDownOwnedUnlessPopupClose[5];//Track if button was clicked inside a dear imgui window. + bool MouseDownWasDoubleClick[5]; // Track if button down was a double-click + float MouseDownDuration[5]; // Duration the mouse button has been down (0.0f == just clicked) + float MouseDownDurationPrev[5]; // Previous time the mouse button has been down + ImVec2 MouseDragMaxDistanceAbs[5]; // Maximum distance, absolute, on each axis, of how much mouse has traveled from the clicking point + float MouseDragMaxDistanceSqr[5]; // Squared maximum distance of how much mouse has traveled from the clicking point + float KeysDownDuration[512]; // Duration the keyboard key has been down (0.0f == just pressed) + float KeysDownDurationPrev[512]; // Previous duration the key has been down + float NavInputsDownDuration[ImGuiNavInput_COUNT]; + float NavInputsDownDurationPrev[ImGuiNavInput_COUNT]; + float PenPressure; // Touch/Pen pressure (0.0f to 1.0f, should be >0.0f only when MouseDown[0] == true). Helper storage currently unused by Dear ImGui. + ImWchar16 InputQueueSurrogate; // For AddInputCharacterUTF16 + ImVector InputQueueCharacters; // Queue of _characters_ input (obtained by platform backend). Fill using AddInputCharacter() helper. + + IMGUI_API ImGuiIO(); +}; + +//----------------------------------------------------------------------------- +// [SECTION] Misc data structures +//----------------------------------------------------------------------------- + +// Shared state of InputText(), passed as an argument to your callback when a ImGuiInputTextFlags_Callback* flag is used. +// The callback function should return 0 by default. +// Callbacks (follow a flag name and see comments in ImGuiInputTextFlags_ declarations for more details) +// - ImGuiInputTextFlags_CallbackEdit: Callback on buffer edit (note that InputText() already returns true on edit, the callback is useful mainly to manipulate the underlying buffer while focus is active) +// - ImGuiInputTextFlags_CallbackAlways: Callback on each iteration +// - ImGuiInputTextFlags_CallbackCompletion: Callback on pressing TAB +// - ImGuiInputTextFlags_CallbackHistory: Callback on pressing Up/Down arrows +// - ImGuiInputTextFlags_CallbackCharFilter: Callback on character inputs to replace or discard them. Modify 'EventChar' to replace or discard, or return 1 in callback to discard. +// - ImGuiInputTextFlags_CallbackResize: Callback on buffer capacity changes request (beyond 'buf_size' parameter value), allowing the string to grow. +struct ImGuiInputTextCallbackData +{ + ImGuiInputTextFlags EventFlag; // One ImGuiInputTextFlags_Callback* // Read-only + ImGuiInputTextFlags Flags; // What user passed to InputText() // Read-only + void* UserData; // What user passed to InputText() // Read-only + + // Arguments for the different callback events + // - To modify the text buffer in a callback, prefer using the InsertChars() / DeleteChars() function. InsertChars() will take care of calling the resize callback if necessary. + // - If you know your edits are not going to resize the underlying buffer allocation, you may modify the contents of 'Buf[]' directly. You need to update 'BufTextLen' accordingly (0 <= BufTextLen < BufSize) and set 'BufDirty'' to true so InputText can update its internal state. + ImWchar EventChar; // Character input // Read-write // [CharFilter] Replace character with another one, or set to zero to drop. return 1 is equivalent to setting EventChar=0; + ImGuiKey EventKey; // Key pressed (Up/Down/TAB) // Read-only // [Completion,History] + char* Buf; // Text buffer // Read-write // [Resize] Can replace pointer / [Completion,History,Always] Only write to pointed data, don't replace the actual pointer! + int BufTextLen; // Text length (in bytes) // Read-write // [Resize,Completion,History,Always] Exclude zero-terminator storage. In C land: == strlen(some_text), in C++ land: string.length() + int BufSize; // Buffer size (in bytes) = capacity+1 // Read-only // [Resize,Completion,History,Always] Include zero-terminator storage. In C land == ARRAYSIZE(my_char_array), in C++ land: string.capacity()+1 + bool BufDirty; // Set if you modify Buf/BufTextLen! // Write // [Completion,History,Always] + int CursorPos; // // Read-write // [Completion,History,Always] + int SelectionStart; // // Read-write // [Completion,History,Always] == to SelectionEnd when no selection) + int SelectionEnd; // // Read-write // [Completion,History,Always] + + // Helper functions for text manipulation. + // Use those function to benefit from the CallbackResize behaviors. Calling those function reset the selection. + IMGUI_API ImGuiInputTextCallbackData(); + IMGUI_API void DeleteChars(int pos, int bytes_count); + IMGUI_API void InsertChars(int pos, const char* text, const char* text_end = NULL); + void SelectAll() { SelectionStart = 0; SelectionEnd = BufTextLen; } + void ClearSelection() { SelectionStart = SelectionEnd = BufTextLen; } + bool HasSelection() const { return SelectionStart != SelectionEnd; } +}; + +// Resizing callback data to apply custom constraint. As enabled by SetNextWindowSizeConstraints(). Callback is called during the next Begin(). +// NB: For basic min/max size constraint on each axis you don't need to use the callback! The SetNextWindowSizeConstraints() parameters are enough. +struct ImGuiSizeCallbackData +{ + void* UserData; // Read-only. What user passed to SetNextWindowSizeConstraints() + ImVec2 Pos; // Read-only. Window position, for reference. + ImVec2 CurrentSize; // Read-only. Current window size. + ImVec2 DesiredSize; // Read-write. Desired size, based on user's mouse position. Write to this field to restrain resizing. +}; + +// Data payload for Drag and Drop operations: AcceptDragDropPayload(), GetDragDropPayload() +struct ImGuiPayload +{ + // Members + void* Data; // Data (copied and owned by dear imgui) + int DataSize; // Data size + + // [Internal] + ImGuiID SourceId; // Source item id + ImGuiID SourceParentId; // Source parent id (if available) + int DataFrameCount; // Data timestamp + char DataType[32 + 1]; // Data type tag (short user-supplied string, 32 characters max) + bool Preview; // Set when AcceptDragDropPayload() was called and mouse has been hovering the target item (nb: handle overlapping drag targets) + bool Delivery; // Set when AcceptDragDropPayload() was called and mouse button is released over the target item. + + ImGuiPayload() { Clear(); } + void Clear() { SourceId = SourceParentId = 0; Data = NULL; DataSize = 0; memset(DataType, 0, sizeof(DataType)); DataFrameCount = -1; Preview = Delivery = false; } + bool IsDataType(const char* type) const { return DataFrameCount != -1 && strcmp(type, DataType) == 0; } + bool IsPreview() const { return Preview; } + bool IsDelivery() const { return Delivery; } +}; + +// Sorting specification for one column of a table (sizeof == 12 bytes) +struct ImGuiTableColumnSortSpecs +{ + ImGuiID ColumnUserID; // User id of the column (if specified by a TableSetupColumn() call) + ImS16 ColumnIndex; // Index of the column + ImS16 SortOrder; // Index within parent ImGuiTableSortSpecs (always stored in order starting from 0, tables sorted on a single criteria will always have a 0 here) + ImGuiSortDirection SortDirection : 8; // ImGuiSortDirection_Ascending or ImGuiSortDirection_Descending (you can use this or SortSign, whichever is more convenient for your sort function) + + ImGuiTableColumnSortSpecs() { memset(this, 0, sizeof(*this)); } +}; + +// Sorting specifications for a table (often handling sort specs for a single column, occasionally more) +// Obtained by calling TableGetSortSpecs(). +// When 'SpecsDirty == true' you can sort your data. It will be true with sorting specs have changed since last call, or the first time. +// Make sure to set 'SpecsDirty = false' after sorting, else you may wastefully sort your data every frame! +struct ImGuiTableSortSpecs +{ + const ImGuiTableColumnSortSpecs* Specs; // Pointer to sort spec array. + int SpecsCount; // Sort spec count. Most often 1. May be > 1 when ImGuiTableFlags_SortMulti is enabled. May be == 0 when ImGuiTableFlags_SortTristate is enabled. + bool SpecsDirty; // Set to true when specs have changed since last time! Use this to sort again, then clear the flag. + + ImGuiTableSortSpecs() { memset(this, 0, sizeof(*this)); } +}; + +//----------------------------------------------------------------------------- +// [SECTION] Helpers (ImGuiOnceUponAFrame, ImGuiTextFilter, ImGuiTextBuffer, ImGuiStorage, ImGuiListClipper, ImColor) +//----------------------------------------------------------------------------- + +// Helper: Unicode defines +#define IM_UNICODE_CODEPOINT_INVALID 0xFFFD // Invalid Unicode code point (standard value). +#ifdef IMGUI_USE_WCHAR32 +#define IM_UNICODE_CODEPOINT_MAX 0x10FFFF // Maximum Unicode code point supported by this build. +#else +#define IM_UNICODE_CODEPOINT_MAX 0xFFFF // Maximum Unicode code point supported by this build. +#endif + +// Helper: Execute a block of code at maximum once a frame. Convenient if you want to quickly create an UI within deep-nested code that runs multiple times every frame. +// Usage: static ImGuiOnceUponAFrame oaf; if (oaf) ImGui::Text("This will be called only once per frame"); +struct ImGuiOnceUponAFrame +{ + ImGuiOnceUponAFrame() { RefFrame = -1; } + mutable int RefFrame; + operator bool() const { int current_frame = ImGui::GetFrameCount(); if (RefFrame == current_frame) return false; RefFrame = current_frame; return true; } +}; + +// Helper: Parse and apply text filters. In format "aaaaa[,bbbb][,ccccc]" +struct ImGuiTextFilter +{ + IMGUI_API ImGuiTextFilter(const char* default_filter = ""); + IMGUI_API bool Draw(const char* label = "Filter (inc,-exc)", float width = 0.0f); // Helper calling InputText+Build + IMGUI_API bool PassFilter(const char* text, const char* text_end = NULL) const; + IMGUI_API void Build(); + void Clear() { InputBuf[0] = 0; Build(); } + bool IsActive() const { return !Filters.empty(); } + + // [Internal] + struct ImGuiTextRange + { + const char* b; + const char* e; + + ImGuiTextRange() { b = e = NULL; } + ImGuiTextRange(const char* _b, const char* _e) { b = _b; e = _e; } + bool empty() const { return b == e; } + IMGUI_API void split(char separator, ImVector* out) const; + }; + char InputBuf[256]; + ImVectorFilters; + int CountGrep; +}; + +// Helper: Growable text buffer for logging/accumulating text +// (this could be called 'ImGuiTextBuilder' / 'ImGuiStringBuilder') +struct ImGuiTextBuffer +{ + ImVector Buf; + IMGUI_API static char EmptyString[1]; + + ImGuiTextBuffer() { } + inline char operator[](int i) const { IM_ASSERT(Buf.Data != NULL); return Buf.Data[i]; } + const char* begin() const { return Buf.Data ? &Buf.front() : EmptyString; } + const char* end() const { return Buf.Data ? &Buf.back() : EmptyString; } // Buf is zero-terminated, so end() will point on the zero-terminator + int size() const { return Buf.Size ? Buf.Size - 1 : 0; } + bool empty() const { return Buf.Size <= 1; } + void clear() { Buf.clear(); } + void reserve(int capacity) { Buf.reserve(capacity); } + const char* c_str() const { return Buf.Data ? Buf.Data : EmptyString; } + IMGUI_API void append(const char* str, const char* str_end = NULL); + IMGUI_API void appendf(const char* fmt, ...) IM_FMTARGS(2); + IMGUI_API void appendfv(const char* fmt, va_list args) IM_FMTLIST(2); +}; + +// Helper: Key->Value storage +// Typically you don't have to worry about this since a storage is held within each Window. +// We use it to e.g. store collapse state for a tree (Int 0/1) +// This is optimized for efficient lookup (dichotomy into a contiguous buffer) and rare insertion (typically tied to user interactions aka max once a frame) +// You can use it as custom user storage for temporary values. Declare your own storage if, for example: +// - You want to manipulate the open/close state of a particular sub-tree in your interface (tree node uses Int 0/1 to store their state). +// - You want to store custom debug data easily without adding or editing structures in your code (probably not efficient, but convenient) +// Types are NOT stored, so it is up to you to make sure your Key don't collide with different types. +struct ImGuiStorage +{ + // [Internal] + struct ImGuiStoragePair + { + ImGuiID key; + union { int val_i; float val_f; void* val_p; }; + ImGuiStoragePair(ImGuiID _key, int _val_i) { key = _key; val_i = _val_i; } + ImGuiStoragePair(ImGuiID _key, float _val_f) { key = _key; val_f = _val_f; } + ImGuiStoragePair(ImGuiID _key, void* _val_p) { key = _key; val_p = _val_p; } + }; + + ImVector Data; + + // - Get***() functions find pair, never add/allocate. Pairs are sorted so a query is O(log N) + // - Set***() functions find pair, insertion on demand if missing. + // - Sorted insertion is costly, paid once. A typical frame shouldn't need to insert any new pair. + void Clear() { Data.clear(); } + IMGUI_API int GetInt(ImGuiID key, int default_val = 0) const; + IMGUI_API void SetInt(ImGuiID key, int val); + IMGUI_API bool GetBool(ImGuiID key, bool default_val = false) const; + IMGUI_API void SetBool(ImGuiID key, bool val); + IMGUI_API float GetFloat(ImGuiID key, float default_val = 0.0f) const; + IMGUI_API void SetFloat(ImGuiID key, float val); + IMGUI_API void* GetVoidPtr(ImGuiID key) const; // default_val is NULL + IMGUI_API void SetVoidPtr(ImGuiID key, void* val); + + // - Get***Ref() functions finds pair, insert on demand if missing, return pointer. Useful if you intend to do Get+Set. + // - References are only valid until a new value is added to the storage. Calling a Set***() function or a Get***Ref() function invalidates the pointer. + // - A typical use case where this is convenient for quick hacking (e.g. add storage during a live Edit&Continue session if you can't modify existing struct) + // float* pvar = ImGui::GetFloatRef(key); ImGui::SliderFloat("var", pvar, 0, 100.0f); some_var += *pvar; + IMGUI_API int* GetIntRef(ImGuiID key, int default_val = 0); + IMGUI_API bool* GetBoolRef(ImGuiID key, bool default_val = false); + IMGUI_API float* GetFloatRef(ImGuiID key, float default_val = 0.0f); + IMGUI_API void** GetVoidPtrRef(ImGuiID key, void* default_val = NULL); + + // Use on your own storage if you know only integer are being stored (open/close all tree nodes) + IMGUI_API void SetAllInt(int val); + + // For quicker full rebuild of a storage (instead of an incremental one), you may add all your contents and then sort once. + IMGUI_API void BuildSortByKey(); +}; + +// Helper: Manually clip large list of items. +// If you are submitting lots of evenly spaced items and you have a random access to the list, you can perform coarse +// clipping based on visibility to save yourself from processing those items at all. +// The clipper calculates the range of visible items and advance the cursor to compensate for the non-visible items we have skipped. +// (Dear ImGui already clip items based on their bounds but it needs to measure text size to do so, whereas manual coarse clipping before submission makes this cost and your own data fetching/submission cost almost null) +// Usage: +// ImGuiListClipper clipper; +// clipper.Begin(1000); // We have 1000 elements, evenly spaced. +// while (clipper.Step()) +// for (int i = clipper.DisplayStart; i < clipper.DisplayEnd; i++) +// ImGui::Text("line number %d", i); +// Generally what happens is: +// - Clipper lets you process the first element (DisplayStart = 0, DisplayEnd = 1) regardless of it being visible or not. +// - User code submit one element. +// - Clipper can measure the height of the first element +// - Clipper calculate the actual range of elements to display based on the current clipping rectangle, position the cursor before the first visible element. +// - User code submit visible elements. +struct ImGuiListClipper +{ + int DisplayStart; + int DisplayEnd; + + // [Internal] + int ItemsCount; + int StepNo; + int ItemsFrozen; + float ItemsHeight; + float StartPosY; + + IMGUI_API ImGuiListClipper(); + IMGUI_API ~ImGuiListClipper(); + + // items_count: Use INT_MAX if you don't know how many items you have (in which case the cursor won't be advanced in the final step) + // items_height: Use -1.0f to be calculated automatically on first step. Otherwise pass in the distance between your items, typically GetTextLineHeightWithSpacing() or GetFrameHeightWithSpacing(). + IMGUI_API void Begin(int items_count, float items_height = -1.0f); // Automatically called by constructor if you passed 'items_count' or by Step() in Step 1. + IMGUI_API void End(); // Automatically called on the last call of Step() that returns false. + IMGUI_API bool Step(); // Call until it returns false. The DisplayStart/DisplayEnd fields will be set and you can process/draw those items. + +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + inline ImGuiListClipper(int items_count, float items_height = -1.0f) { memset(this, 0, sizeof(*this)); ItemsCount = -1; Begin(items_count, items_height); } // [removed in 1.79] +#endif +}; + +// Helpers macros to generate 32-bit encoded colors +#ifdef IMGUI_USE_BGRA_PACKED_COLOR +#define IM_COL32_R_SHIFT 16 +#define IM_COL32_G_SHIFT 8 +#define IM_COL32_B_SHIFT 0 +#define IM_COL32_A_SHIFT 24 +#define IM_COL32_A_MASK 0xFF000000 +#else +#define IM_COL32_R_SHIFT 0 +#define IM_COL32_G_SHIFT 8 +#define IM_COL32_B_SHIFT 16 +#define IM_COL32_A_SHIFT 24 +#define IM_COL32_A_MASK 0xFF000000 +#endif +#define IM_COL32(R,G,B,A) (((ImU32)(A)<> IM_COL32_R_SHIFT) & 0xFF) * sc; Value.y = (float)((rgba >> IM_COL32_G_SHIFT) & 0xFF) * sc; Value.z = (float)((rgba >> IM_COL32_B_SHIFT) & 0xFF) * sc; Value.w = (float)((rgba >> IM_COL32_A_SHIFT) & 0xFF) * sc; } + ImColor(float r, float g, float b, float a = 1.0f) { Value.x = r; Value.y = g; Value.z = b; Value.w = a; } + ImColor(const ImVec4& col) { Value = col; } + inline operator ImU32() const { return ImGui::ColorConvertFloat4ToU32(Value); } + inline operator ImVec4() const { return Value; } + + // FIXME-OBSOLETE: May need to obsolete/cleanup those helpers. + inline void SetHSV(float h, float s, float v, float a = 1.0f){ ImGui::ColorConvertHSVtoRGB(h, s, v, Value.x, Value.y, Value.z); Value.w = a; } + static ImColor HSV(float h, float s, float v, float a = 1.0f) { float r, g, b; ImGui::ColorConvertHSVtoRGB(h, s, v, r, g, b); return ImColor(r, g, b, a); } +}; + +//----------------------------------------------------------------------------- +// [SECTION] Drawing API (ImDrawCmd, ImDrawIdx, ImDrawVert, ImDrawChannel, ImDrawListSplitter, ImDrawListFlags, ImDrawList, ImDrawData) +// Hold a series of drawing commands. The user provides a renderer for ImDrawData which essentially contains an array of ImDrawList. +//----------------------------------------------------------------------------- + +// The maximum line width to bake anti-aliased textures for. Build atlas with ImFontAtlasFlags_NoBakedLines to disable baking. +#ifndef IM_DRAWLIST_TEX_LINES_WIDTH_MAX +#define IM_DRAWLIST_TEX_LINES_WIDTH_MAX (63) +#endif + +// ImDrawCallback: Draw callbacks for advanced uses [configurable type: override in imconfig.h] +// NB: You most likely do NOT need to use draw callbacks just to create your own widget or customized UI rendering, +// you can poke into the draw list for that! Draw callback may be useful for example to: +// A) Change your GPU render state, +// B) render a complex 3D scene inside a UI element without an intermediate texture/render target, etc. +// The expected behavior from your rendering function is 'if (cmd.UserCallback != NULL) { cmd.UserCallback(parent_list, cmd); } else { RenderTriangles() }' +// If you want to override the signature of ImDrawCallback, you can simply use e.g. '#define ImDrawCallback MyDrawCallback' (in imconfig.h) + update rendering backend accordingly. +#ifndef ImDrawCallback +typedef void (*ImDrawCallback)(const ImDrawList* parent_list, const ImDrawCmd* cmd); +#endif + +// Special Draw callback value to request renderer backend to reset the graphics/render state. +// The renderer backend needs to handle this special value, otherwise it will crash trying to call a function at this address. +// This is useful for example if you submitted callbacks which you know have altered the render state and you want it to be restored. +// It is not done by default because they are many perfectly useful way of altering render state for imgui contents (e.g. changing shader/blending settings before an Image call). +#define ImDrawCallback_ResetRenderState (ImDrawCallback)(-1) + +// Typically, 1 command = 1 GPU draw call (unless command is a callback) +// - VtxOffset/IdxOffset: When 'io.BackendFlags & ImGuiBackendFlags_RendererHasVtxOffset' is enabled, +// those fields allow us to render meshes larger than 64K vertices while keeping 16-bit indices. +// Pre-1.71 backends will typically ignore the VtxOffset/IdxOffset fields. +// - The ClipRect/TextureId/VtxOffset fields must be contiguous as we memcmp() them together (this is asserted for). +struct ImDrawCmd +{ + ImVec4 ClipRect; // 4*4 // Clipping rectangle (x1, y1, x2, y2). Subtract ImDrawData->DisplayPos to get clipping rectangle in "viewport" coordinates + ImTextureID TextureId; // 4-8 // User-provided texture ID. Set by user in ImfontAtlas::SetTexID() for fonts or passed to Image*() functions. Ignore if never using images or multiple fonts atlas. + unsigned int VtxOffset; // 4 // Start offset in vertex buffer. ImGuiBackendFlags_RendererHasVtxOffset: always 0, otherwise may be >0 to support meshes larger than 64K vertices with 16-bit indices. + unsigned int IdxOffset; // 4 // Start offset in index buffer. Always equal to sum of ElemCount drawn so far. + unsigned int ElemCount; // 4 // Number of indices (multiple of 3) to be rendered as triangles. Vertices are stored in the callee ImDrawList's vtx_buffer[] array, indices in idx_buffer[]. + ImDrawCallback UserCallback; // 4-8 // If != NULL, call the function instead of rendering the vertices. clip_rect and texture_id will be set normally. + void* UserCallbackData; // 4-8 // The draw callback code can access this. + + ImDrawCmd() { memset(this, 0, sizeof(*this)); } // Also ensure our padding fields are zeroed + + // Since 1.83: returns ImTextureID associated with this draw call. Warning: DO NOT assume this is always same as 'TextureId' (we will change this function for an upcoming feature) + inline ImTextureID GetTexID() const { return TextureId; } +}; + +// Vertex layout +#ifndef IMGUI_OVERRIDE_DRAWVERT_STRUCT_LAYOUT +struct ImDrawVert +{ + ImVec2 pos; + ImVec2 uv; + ImU32 col; +}; +#else +// You can override the vertex format layout by defining IMGUI_OVERRIDE_DRAWVERT_STRUCT_LAYOUT in imconfig.h +// The code expect ImVec2 pos (8 bytes), ImVec2 uv (8 bytes), ImU32 col (4 bytes), but you can re-order them or add other fields as needed to simplify integration in your engine. +// The type has to be described within the macro (you can either declare the struct or use a typedef). This is because ImVec2/ImU32 are likely not declared a the time you'd want to set your type up. +// NOTE: IMGUI DOESN'T CLEAR THE STRUCTURE AND DOESN'T CALL A CONSTRUCTOR SO ANY CUSTOM FIELD WILL BE UNINITIALIZED. IF YOU ADD EXTRA FIELDS (SUCH AS A 'Z' COORDINATES) YOU WILL NEED TO CLEAR THEM DURING RENDER OR TO IGNORE THEM. +IMGUI_OVERRIDE_DRAWVERT_STRUCT_LAYOUT; +#endif + +// [Internal] For use by ImDrawList +struct ImDrawCmdHeader +{ + ImVec4 ClipRect; + ImTextureID TextureId; + unsigned int VtxOffset; +}; + +// [Internal] For use by ImDrawListSplitter +struct ImDrawChannel +{ + ImVector _CmdBuffer; + ImVector _IdxBuffer; +}; + + +// Split/Merge functions are used to split the draw list into different layers which can be drawn into out of order. +// This is used by the Columns/Tables API, so items of each column can be batched together in a same draw call. +struct ImDrawListSplitter +{ + int _Current; // Current channel number (0) + int _Count; // Number of active channels (1+) + ImVector _Channels; // Draw channels (not resized down so _Count might be < Channels.Size) + + inline ImDrawListSplitter() { memset(this, 0, sizeof(*this)); } + inline ~ImDrawListSplitter() { ClearFreeMemory(); } + inline void Clear() { _Current = 0; _Count = 1; } // Do not clear Channels[] so our allocations are reused next frame + IMGUI_API void ClearFreeMemory(); + IMGUI_API void Split(ImDrawList* draw_list, int count); + IMGUI_API void Merge(ImDrawList* draw_list); + IMGUI_API void SetCurrentChannel(ImDrawList* draw_list, int channel_idx); +}; + +// Flags for ImDrawList functions +// (Legacy: bit 0 must always correspond to ImDrawFlags_Closed to be backward compatible with old API using a bool. Bits 1..3 must be unused) +enum ImDrawFlags_ +{ + ImDrawFlags_None = 0, + ImDrawFlags_Closed = 1 << 0, // PathStroke(), AddPolyline(): specify that shape should be closed (Important: this is always == 1 for legacy reason) + ImDrawFlags_RoundCornersTopLeft = 1 << 4, // AddRect(), AddRectFilled(), PathRect(): enable rounding top-left corner only (when rounding > 0.0f, we default to all corners). Was 0x01. + ImDrawFlags_RoundCornersTopRight = 1 << 5, // AddRect(), AddRectFilled(), PathRect(): enable rounding top-right corner only (when rounding > 0.0f, we default to all corners). Was 0x02. + ImDrawFlags_RoundCornersBottomLeft = 1 << 6, // AddRect(), AddRectFilled(), PathRect(): enable rounding bottom-left corner only (when rounding > 0.0f, we default to all corners). Was 0x04. + ImDrawFlags_RoundCornersBottomRight = 1 << 7, // AddRect(), AddRectFilled(), PathRect(): enable rounding bottom-right corner only (when rounding > 0.0f, we default to all corners). Wax 0x08. + ImDrawFlags_RoundCornersNone = 1 << 8, // AddRect(), AddRectFilled(), PathRect(): disable rounding on all corners (when rounding > 0.0f). This is NOT zero, NOT an implicit flag! + ImDrawFlags_RoundCornersTop = ImDrawFlags_RoundCornersTopLeft | ImDrawFlags_RoundCornersTopRight, + ImDrawFlags_RoundCornersBottom = ImDrawFlags_RoundCornersBottomLeft | ImDrawFlags_RoundCornersBottomRight, + ImDrawFlags_RoundCornersLeft = ImDrawFlags_RoundCornersBottomLeft | ImDrawFlags_RoundCornersTopLeft, + ImDrawFlags_RoundCornersRight = ImDrawFlags_RoundCornersBottomRight | ImDrawFlags_RoundCornersTopRight, + ImDrawFlags_RoundCornersAll = ImDrawFlags_RoundCornersTopLeft | ImDrawFlags_RoundCornersTopRight | ImDrawFlags_RoundCornersBottomLeft | ImDrawFlags_RoundCornersBottomRight, + ImDrawFlags_RoundCornersDefault_ = ImDrawFlags_RoundCornersAll, // Default to ALL corners if none of the _RoundCornersXX flags are specified. + ImDrawFlags_RoundCornersMask_ = ImDrawFlags_RoundCornersAll | ImDrawFlags_RoundCornersNone +}; + +// Flags for ImDrawList instance. Those are set automatically by ImGui:: functions from ImGuiIO settings, and generally not manipulated directly. +// It is however possible to temporarily alter flags between calls to ImDrawList:: functions. +enum ImDrawListFlags_ +{ + ImDrawListFlags_None = 0, + ImDrawListFlags_AntiAliasedLines = 1 << 0, // Enable anti-aliased lines/borders (*2 the number of triangles for 1.0f wide line or lines thin enough to be drawn using textures, otherwise *3 the number of triangles) + ImDrawListFlags_AntiAliasedLinesUseTex = 1 << 1, // Enable anti-aliased lines/borders using textures when possible. Require backend to render with bilinear filtering. + ImDrawListFlags_AntiAliasedFill = 1 << 2, // Enable anti-aliased edge around filled shapes (rounded rectangles, circles). + ImDrawListFlags_AllowVtxOffset = 1 << 3 // Can emit 'VtxOffset > 0' to allow large meshes. Set when 'ImGuiBackendFlags_RendererHasVtxOffset' is enabled. +}; + +// Draw command list +// This is the low-level list of polygons that ImGui:: functions are filling. At the end of the frame, +// all command lists are passed to your ImGuiIO::RenderDrawListFn function for rendering. +// Each dear imgui window contains its own ImDrawList. You can use ImGui::GetWindowDrawList() to +// access the current window draw list and draw custom primitives. +// You can interleave normal ImGui:: calls and adding primitives to the current draw list. +// In single viewport mode, top-left is == GetMainViewport()->Pos (generally 0,0), bottom-right is == GetMainViewport()->Pos+Size (generally io.DisplaySize). +// You are totally free to apply whatever transformation matrix to want to the data (depending on the use of the transformation you may want to apply it to ClipRect as well!) +// Important: Primitives are always added to the list and not culled (culling is done at higher-level by ImGui:: functions), if you use this API a lot consider coarse culling your drawn objects. +struct ImDrawList +{ + // This is what you have to render + ImVector CmdBuffer; // Draw commands. Typically 1 command = 1 GPU draw call, unless the command is a callback. + ImVector IdxBuffer; // Index buffer. Each command consume ImDrawCmd::ElemCount of those + ImVector VtxBuffer; // Vertex buffer. + ImDrawListFlags Flags; // Flags, you may poke into these to adjust anti-aliasing settings per-primitive. + + // [Internal, used while building lists] + unsigned int _VtxCurrentIdx; // [Internal] generally == VtxBuffer.Size unless we are past 64K vertices, in which case this gets reset to 0. + const ImDrawListSharedData* _Data; // Pointer to shared draw data (you can use ImGui::GetDrawListSharedData() to get the one from current ImGui context) + const char* _OwnerName; // Pointer to owner window's name for debugging + ImDrawVert* _VtxWritePtr; // [Internal] point within VtxBuffer.Data after each add command (to avoid using the ImVector<> operators too much) + ImDrawIdx* _IdxWritePtr; // [Internal] point within IdxBuffer.Data after each add command (to avoid using the ImVector<> operators too much) + ImVector _ClipRectStack; // [Internal] + ImVector _TextureIdStack; // [Internal] + ImVector _Path; // [Internal] current path building + ImDrawCmdHeader _CmdHeader; // [Internal] template of active commands. Fields should match those of CmdBuffer.back(). + ImDrawListSplitter _Splitter; // [Internal] for channels api (note: prefer using your own persistent instance of ImDrawListSplitter!) + float _FringeScale; // [Internal] anti-alias fringe is scaled by this value, this helps to keep things sharp while zooming at vertex buffer content + + // If you want to create ImDrawList instances, pass them ImGui::GetDrawListSharedData() or create and use your own ImDrawListSharedData (so you can use ImDrawList without ImGui) + ImDrawList(const ImDrawListSharedData* shared_data) { memset(this, 0, sizeof(*this)); _Data = shared_data; } + + ~ImDrawList() { _ClearFreeMemory(); } + IMGUI_API void PushClipRect(ImVec2 clip_rect_min, ImVec2 clip_rect_max, bool intersect_with_current_clip_rect = false); // Render-level scissoring. This is passed down to your render function but not used for CPU-side coarse clipping. Prefer using higher-level ImGui::PushClipRect() to affect logic (hit-testing and widget culling) + IMGUI_API void PushClipRectFullScreen(); + IMGUI_API void PopClipRect(); + IMGUI_API void PushTextureID(ImTextureID texture_id); + IMGUI_API void PopTextureID(); + inline ImVec2 GetClipRectMin() const { const ImVec4& cr = _ClipRectStack.back(); return ImVec2(cr.x, cr.y); } + inline ImVec2 GetClipRectMax() const { const ImVec4& cr = _ClipRectStack.back(); return ImVec2(cr.z, cr.w); } + + // Primitives + // - For rectangular primitives, "p_min" and "p_max" represent the upper-left and lower-right corners. + // - For circle primitives, use "num_segments == 0" to automatically calculate tessellation (preferred). + // In older versions (until Dear ImGui 1.77) the AddCircle functions defaulted to num_segments == 12. + // In future versions we will use textures to provide cheaper and higher-quality circles. + // Use AddNgon() and AddNgonFilled() functions if you need to guaranteed a specific number of sides. + IMGUI_API void AddLine(const ImVec2& p1, const ImVec2& p2, ImU32 col, float thickness = 1.0f); + IMGUI_API void AddRect(const ImVec2& p_min, const ImVec2& p_max, ImU32 col, float rounding = 0.0f, ImDrawFlags flags = 0, float thickness = 1.0f); // a: upper-left, b: lower-right (== upper-left + size) + IMGUI_API void AddRectFilled(const ImVec2& p_min, const ImVec2& p_max, ImU32 col, float rounding = 0.0f, ImDrawFlags flags = 0); // a: upper-left, b: lower-right (== upper-left + size) + IMGUI_API void AddRectFilledMultiColor(const ImVec2& p_min, const ImVec2& p_max, ImU32 col_upr_left, ImU32 col_upr_right, ImU32 col_bot_right, ImU32 col_bot_left); + IMGUI_API void AddQuad(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, ImU32 col, float thickness = 1.0f); + IMGUI_API void AddQuadFilled(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, ImU32 col); + IMGUI_API void AddTriangle(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, ImU32 col, float thickness = 1.0f); + IMGUI_API void AddTriangleFilled(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, ImU32 col); + IMGUI_API void AddCircle(const ImVec2& center, float radius, ImU32 col, int num_segments = 0, float thickness = 1.0f); + IMGUI_API void AddCircleFilled(const ImVec2& center, float radius, ImU32 col, int num_segments = 0); + IMGUI_API void AddNgon(const ImVec2& center, float radius, ImU32 col, int num_segments, float thickness = 1.0f); + IMGUI_API void AddNgonFilled(const ImVec2& center, float radius, ImU32 col, int num_segments); + IMGUI_API void AddText(const ImVec2& pos, ImU32 col, const char* text_begin, const char* text_end = NULL); + IMGUI_API void AddText(const ImFont* font, float font_size, const ImVec2& pos, ImU32 col, const char* text_begin, const char* text_end = NULL, float wrap_width = 0.0f, const ImVec4* cpu_fine_clip_rect = NULL); + IMGUI_API void AddPolyline(const ImVec2* points, int num_points, ImU32 col, ImDrawFlags flags, float thickness); + IMGUI_API void AddConvexPolyFilled(const ImVec2* points, int num_points, ImU32 col); // Note: Anti-aliased filling requires points to be in clockwise order. + IMGUI_API void AddBezierCubic(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, ImU32 col, float thickness, int num_segments = 0); // Cubic Bezier (4 control points) + IMGUI_API void AddBezierQuadratic(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, ImU32 col, float thickness, int num_segments = 0); // Quadratic Bezier (3 control points) + + // Image primitives + // - Read FAQ to understand what ImTextureID is. + // - "p_min" and "p_max" represent the upper-left and lower-right corners of the rectangle. + // - "uv_min" and "uv_max" represent the normalized texture coordinates to use for those corners. Using (0,0)->(1,1) texture coordinates will generally display the entire texture. + IMGUI_API void AddImage(ImTextureID user_texture_id, const ImVec2& p_min, const ImVec2& p_max, const ImVec2& uv_min = ImVec2(0, 0), const ImVec2& uv_max = ImVec2(1, 1), ImU32 col = IM_COL32_WHITE); + IMGUI_API void AddImageQuad(ImTextureID user_texture_id, const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, const ImVec2& uv1 = ImVec2(0, 0), const ImVec2& uv2 = ImVec2(1, 0), const ImVec2& uv3 = ImVec2(1, 1), const ImVec2& uv4 = ImVec2(0, 1), ImU32 col = IM_COL32_WHITE); + IMGUI_API void AddImageRounded(ImTextureID user_texture_id, const ImVec2& p_min, const ImVec2& p_max, const ImVec2& uv_min, const ImVec2& uv_max, ImU32 col, float rounding, ImDrawFlags flags = 0); + + // Stateful path API, add points then finish with PathFillConvex() or PathStroke() + inline void PathClear() { _Path.Size = 0; } + inline void PathLineTo(const ImVec2& pos) { _Path.push_back(pos); } + inline void PathLineToMergeDuplicate(const ImVec2& pos) { if (_Path.Size == 0 || memcmp(&_Path.Data[_Path.Size - 1], &pos, 8) != 0) _Path.push_back(pos); } + inline void PathFillConvex(ImU32 col) { AddConvexPolyFilled(_Path.Data, _Path.Size, col); _Path.Size = 0; } // Note: Anti-aliased filling requires points to be in clockwise order. + inline void PathStroke(ImU32 col, ImDrawFlags flags = 0, float thickness = 1.0f) { AddPolyline(_Path.Data, _Path.Size, col, flags, thickness); _Path.Size = 0; } + IMGUI_API void PathArcTo(const ImVec2& center, float radius, float a_min, float a_max, int num_segments = 0); + IMGUI_API void PathArcToFast(const ImVec2& center, float radius, int a_min_of_12, int a_max_of_12); // Use precomputed angles for a 12 steps circle + IMGUI_API void PathBezierCubicCurveTo(const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, int num_segments = 0); // Cubic Bezier (4 control points) + IMGUI_API void PathBezierQuadraticCurveTo(const ImVec2& p2, const ImVec2& p3, int num_segments = 0); // Quadratic Bezier (3 control points) + IMGUI_API void PathRect(const ImVec2& rect_min, const ImVec2& rect_max, float rounding = 0.0f, ImDrawFlags flags = 0); + + // Advanced + IMGUI_API void AddCallback(ImDrawCallback callback, void* callback_data); // Your rendering function must check for 'UserCallback' in ImDrawCmd and call the function instead of rendering triangles. + IMGUI_API void AddDrawCmd(); // This is useful if you need to forcefully create a new draw call (to allow for dependent rendering / blending). Otherwise primitives are merged into the same draw-call as much as possible + IMGUI_API ImDrawList* CloneOutput() const; // Create a clone of the CmdBuffer/IdxBuffer/VtxBuffer. + + // Advanced: Channels + // - Use to split render into layers. By switching channels to can render out-of-order (e.g. submit FG primitives before BG primitives) + // - Use to minimize draw calls (e.g. if going back-and-forth between multiple clipping rectangles, prefer to append into separate channels then merge at the end) + // - FIXME-OBSOLETE: This API shouldn't have been in ImDrawList in the first place! + // Prefer using your own persistent instance of ImDrawListSplitter as you can stack them. + // Using the ImDrawList::ChannelsXXXX you cannot stack a split over another. + inline void ChannelsSplit(int count) { _Splitter.Split(this, count); } + inline void ChannelsMerge() { _Splitter.Merge(this); } + inline void ChannelsSetCurrent(int n) { _Splitter.SetCurrentChannel(this, n); } + + // Advanced: Primitives allocations + // - We render triangles (three vertices) + // - All primitives needs to be reserved via PrimReserve() beforehand. + IMGUI_API void PrimReserve(int idx_count, int vtx_count); + IMGUI_API void PrimUnreserve(int idx_count, int vtx_count); + IMGUI_API void PrimRect(const ImVec2& a, const ImVec2& b, ImU32 col); // Axis aligned rectangle (composed of two triangles) + IMGUI_API void PrimRectUV(const ImVec2& a, const ImVec2& b, const ImVec2& uv_a, const ImVec2& uv_b, ImU32 col); + IMGUI_API void PrimQuadUV(const ImVec2& a, const ImVec2& b, const ImVec2& c, const ImVec2& d, const ImVec2& uv_a, const ImVec2& uv_b, const ImVec2& uv_c, const ImVec2& uv_d, ImU32 col); + inline void PrimWriteVtx(const ImVec2& pos, const ImVec2& uv, ImU32 col) { _VtxWritePtr->pos = pos; _VtxWritePtr->uv = uv; _VtxWritePtr->col = col; _VtxWritePtr++; _VtxCurrentIdx++; } + inline void PrimWriteIdx(ImDrawIdx idx) { *_IdxWritePtr = idx; _IdxWritePtr++; } + inline void PrimVtx(const ImVec2& pos, const ImVec2& uv, ImU32 col) { PrimWriteIdx((ImDrawIdx)_VtxCurrentIdx); PrimWriteVtx(pos, uv, col); } // Write vertex with unique index + +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + inline void AddBezierCurve(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, ImU32 col, float thickness, int num_segments = 0) { AddBezierCubic(p1, p2, p3, p4, col, thickness, num_segments); } + inline void PathBezierCurveTo(const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, int num_segments = 0) { PathBezierCubicCurveTo(p2, p3, p4, num_segments); } +#endif + + // [Internal helpers] + IMGUI_API void _ResetForNewFrame(); + IMGUI_API void _ClearFreeMemory(); + IMGUI_API void _PopUnusedDrawCmd(); + IMGUI_API void _TryMergeDrawCmds(); + IMGUI_API void _OnChangedClipRect(); + IMGUI_API void _OnChangedTextureID(); + IMGUI_API void _OnChangedVtxOffset(); + IMGUI_API int _CalcCircleAutoSegmentCount(float radius) const; + IMGUI_API void _PathArcToFastEx(const ImVec2& center, float radius, int a_min_sample, int a_max_sample, int a_step); + IMGUI_API void _PathArcToN(const ImVec2& center, float radius, float a_min, float a_max, int num_segments); +}; + +// All draw data to render a Dear ImGui frame +// (NB: the style and the naming convention here is a little inconsistent, we currently preserve them for backward compatibility purpose, +// as this is one of the oldest structure exposed by the library! Basically, ImDrawList == CmdList) +struct ImDrawData +{ + bool Valid; // Only valid after Render() is called and before the next NewFrame() is called. + int CmdListsCount; // Number of ImDrawList* to render + int TotalIdxCount; // For convenience, sum of all ImDrawList's IdxBuffer.Size + int TotalVtxCount; // For convenience, sum of all ImDrawList's VtxBuffer.Size + ImDrawList** CmdLists; // Array of ImDrawList* to render. The ImDrawList are owned by ImGuiContext and only pointed to from here. + ImVec2 DisplayPos; // Top-left position of the viewport to render (== top-left of the orthogonal projection matrix to use) (== GetMainViewport()->Pos for the main viewport, == (0.0) in most single-viewport applications) + ImVec2 DisplaySize; // Size of the viewport to render (== GetMainViewport()->Size for the main viewport, == io.DisplaySize in most single-viewport applications) + ImVec2 FramebufferScale; // Amount of pixels for each unit of DisplaySize. Based on io.DisplayFramebufferScale. Generally (1,1) on normal display, (2,2) on OSX with Retina display. + + // Functions + ImDrawData() { Clear(); } + void Clear() { memset(this, 0, sizeof(*this)); } // The ImDrawList are owned by ImGuiContext! + IMGUI_API void DeIndexAllBuffers(); // Helper to convert all buffers from indexed to non-indexed, in case you cannot render indexed. Note: this is slow and most likely a waste of resources. Always prefer indexed rendering! + IMGUI_API void ScaleClipRects(const ImVec2& fb_scale); // Helper to scale the ClipRect field of each ImDrawCmd. Use if your final output buffer is at a different scale than Dear ImGui expects, or if there is a difference between your window resolution and framebuffer resolution. +}; + +//----------------------------------------------------------------------------- +// [SECTION] Font API (ImFontConfig, ImFontGlyph, ImFontAtlasFlags, ImFontAtlas, ImFontGlyphRangesBuilder, ImFont) +//----------------------------------------------------------------------------- + +struct ImFontConfig +{ + void* FontData; // // TTF/OTF data + int FontDataSize; // // TTF/OTF data size + bool FontDataOwnedByAtlas; // true // TTF/OTF data ownership taken by the container ImFontAtlas (will delete memory itself). + int FontNo; // 0 // Index of font within TTF/OTF file + float SizePixels; // // Size in pixels for rasterizer (more or less maps to the resulting font height). + int OversampleH; // 3 // Rasterize at higher quality for sub-pixel positioning. Note the difference between 2 and 3 is minimal so you can reduce this to 2 to save memory. Read https://github.com/nothings/stb/blob/master/tests/oversample/README.md for details. + int OversampleV; // 1 // Rasterize at higher quality for sub-pixel positioning. This is not really useful as we don't use sub-pixel positions on the Y axis. + bool PixelSnapH; // false // Align every glyph to pixel boundary. Useful e.g. if you are merging a non-pixel aligned font with the default font. If enabled, you can set OversampleH/V to 1. + ImVec2 GlyphExtraSpacing; // 0, 0 // Extra spacing (in pixels) between glyphs. Only X axis is supported for now. + ImVec2 GlyphOffset; // 0, 0 // Offset all glyphs from this font input. + const ImWchar* GlyphRanges; // NULL // Pointer to a user-provided list of Unicode range (2 value per range, values are inclusive, zero-terminated list). THE ARRAY DATA NEEDS TO PERSIST AS LONG AS THE FONT IS ALIVE. + float GlyphMinAdvanceX; // 0 // Minimum AdvanceX for glyphs, set Min to align font icons, set both Min/Max to enforce mono-space font + float GlyphMaxAdvanceX; // FLT_MAX // Maximum AdvanceX for glyphs + bool MergeMode; // false // Merge into previous ImFont, so you can combine multiple inputs font into one ImFont (e.g. ASCII font + icons + Japanese glyphs). You may want to use GlyphOffset.y when merge font of different heights. + unsigned int FontBuilderFlags; // 0 // Settings for custom font builder. THIS IS BUILDER IMPLEMENTATION DEPENDENT. Leave as zero if unsure. + float RasterizerMultiply; // 1.0f // Brighten (>1.0f) or darken (<1.0f) font output. Brightening small fonts may be a good workaround to make them more readable. + ImWchar EllipsisChar; // -1 // Explicitly specify unicode codepoint of ellipsis character. When fonts are being merged first specified ellipsis will be used. + + // [Internal] + char Name[40]; // Name (strictly to ease debugging) + ImFont* DstFont; + + IMGUI_API ImFontConfig(); +}; + +// Hold rendering data for one glyph. +// (Note: some language parsers may fail to convert the 31+1 bitfield members, in this case maybe drop store a single u32 or we can rework this) +struct ImFontGlyph +{ + unsigned int Colored : 1; // Flag to indicate glyph is colored and should generally ignore tinting (make it usable with no shift on little-endian as this is used in loops) + unsigned int Visible : 1; // Flag to indicate glyph has no visible pixels (e.g. space). Allow early out when rendering. + unsigned int Codepoint : 30; // 0x0000..0x10FFFF + float AdvanceX; // Distance to next character (= data from font + ImFontConfig::GlyphExtraSpacing.x baked in) + float X0, Y0, X1, Y1; // Glyph corners + float U0, V0, U1, V1; // Texture coordinates +}; + +// Helper to build glyph ranges from text/string data. Feed your application strings/characters to it then call BuildRanges(). +// This is essentially a tightly packed of vector of 64k booleans = 8KB storage. +struct ImFontGlyphRangesBuilder +{ + ImVector UsedChars; // Store 1-bit per Unicode code point (0=unused, 1=used) + + ImFontGlyphRangesBuilder() { Clear(); } + inline void Clear() { int size_in_bytes = (IM_UNICODE_CODEPOINT_MAX + 1) / 8; UsedChars.resize(size_in_bytes / (int)sizeof(ImU32)); memset(UsedChars.Data, 0, (size_t)size_in_bytes); } + inline bool GetBit(size_t n) const { int off = (int)(n >> 5); ImU32 mask = 1u << (n & 31); return (UsedChars[off] & mask) != 0; } // Get bit n in the array + inline void SetBit(size_t n) { int off = (int)(n >> 5); ImU32 mask = 1u << (n & 31); UsedChars[off] |= mask; } // Set bit n in the array + inline void AddChar(ImWchar c) { SetBit(c); } // Add character + IMGUI_API void AddText(const char* text, const char* text_end = NULL); // Add string (each character of the UTF-8 string are added) + IMGUI_API void AddRanges(const ImWchar* ranges); // Add ranges, e.g. builder.AddRanges(ImFontAtlas::GetGlyphRangesDefault()) to force add all of ASCII/Latin+Ext + IMGUI_API void BuildRanges(ImVector* out_ranges); // Output new ranges +}; + +// See ImFontAtlas::AddCustomRectXXX functions. +struct ImFontAtlasCustomRect +{ + unsigned short Width, Height; // Input // Desired rectangle dimension + unsigned short X, Y; // Output // Packed position in Atlas + unsigned int GlyphID; // Input // For custom font glyphs only (ID < 0x110000) + float GlyphAdvanceX; // Input // For custom font glyphs only: glyph xadvance + ImVec2 GlyphOffset; // Input // For custom font glyphs only: glyph display offset + ImFont* Font; // Input // For custom font glyphs only: target font + ImFontAtlasCustomRect() { Width = Height = 0; X = Y = 0xFFFF; GlyphID = 0; GlyphAdvanceX = 0.0f; GlyphOffset = ImVec2(0, 0); Font = NULL; } + bool IsPacked() const { return X != 0xFFFF; } +}; + +// Flags for ImFontAtlas build +enum ImFontAtlasFlags_ +{ + ImFontAtlasFlags_None = 0, + ImFontAtlasFlags_NoPowerOfTwoHeight = 1 << 0, // Don't round the height to next power of two + ImFontAtlasFlags_NoMouseCursors = 1 << 1, // Don't build software mouse cursors into the atlas (save a little texture memory) + ImFontAtlasFlags_NoBakedLines = 1 << 2 // Don't build thick line textures into the atlas (save a little texture memory). The AntiAliasedLinesUseTex features uses them, otherwise they will be rendered using polygons (more expensive for CPU/GPU). +}; + +// Load and rasterize multiple TTF/OTF fonts into a same texture. The font atlas will build a single texture holding: +// - One or more fonts. +// - Custom graphics data needed to render the shapes needed by Dear ImGui. +// - Mouse cursor shapes for software cursor rendering (unless setting 'Flags |= ImFontAtlasFlags_NoMouseCursors' in the font atlas). +// It is the user-code responsibility to setup/build the atlas, then upload the pixel data into a texture accessible by your graphics api. +// - Optionally, call any of the AddFont*** functions. If you don't call any, the default font embedded in the code will be loaded for you. +// - Call GetTexDataAsAlpha8() or GetTexDataAsRGBA32() to build and retrieve pixels data. +// - Upload the pixels data into a texture within your graphics system (see imgui_impl_xxxx.cpp examples) +// - Call SetTexID(my_tex_id); and pass the pointer/identifier to your texture in a format natural to your graphics API. +// This value will be passed back to you during rendering to identify the texture. Read FAQ entry about ImTextureID for more details. +// Common pitfalls: +// - If you pass a 'glyph_ranges' array to AddFont*** functions, you need to make sure that your array persist up until the +// atlas is build (when calling GetTexData*** or Build()). We only copy the pointer, not the data. +// - Important: By default, AddFontFromMemoryTTF() takes ownership of the data. Even though we are not writing to it, we will free the pointer on destruction. +// You can set font_cfg->FontDataOwnedByAtlas=false to keep ownership of your data and it won't be freed, +// - Even though many functions are suffixed with "TTF", OTF data is supported just as well. +// - This is an old API and it is currently awkward for those and and various other reasons! We will address them in the future! +struct ImFontAtlas +{ + IMGUI_API ImFontAtlas(); + IMGUI_API ~ImFontAtlas(); + IMGUI_API ImFont* AddFont(const ImFontConfig* font_cfg); + IMGUI_API ImFont* AddFontDefault(const ImFontConfig* font_cfg = NULL); + IMGUI_API ImFont* AddFontFromFileTTF(const char* filename, float size_pixels, const ImFontConfig* font_cfg = NULL, const ImWchar* glyph_ranges = NULL); + IMGUI_API ImFont* AddFontFromMemoryTTF(void* font_data, int font_size, float size_pixels, const ImFontConfig* font_cfg = NULL, const ImWchar* glyph_ranges = NULL); // Note: Transfer ownership of 'ttf_data' to ImFontAtlas! Will be deleted after destruction of the atlas. Set font_cfg->FontDataOwnedByAtlas=false to keep ownership of your data and it won't be freed. + IMGUI_API ImFont* AddFontFromMemoryCompressedTTF(const void* compressed_font_data, int compressed_font_size, float size_pixels, const ImFontConfig* font_cfg = NULL, const ImWchar* glyph_ranges = NULL); // 'compressed_font_data' still owned by caller. Compress with binary_to_compressed_c.cpp. + IMGUI_API ImFont* AddFontFromMemoryCompressedBase85TTF(const char* compressed_font_data_base85, float size_pixels, const ImFontConfig* font_cfg = NULL, const ImWchar* glyph_ranges = NULL); // 'compressed_font_data_base85' still owned by caller. Compress with binary_to_compressed_c.cpp with -base85 parameter. + IMGUI_API void ClearInputData(); // Clear input data (all ImFontConfig structures including sizes, TTF data, glyph ranges, etc.) = all the data used to build the texture and fonts. + IMGUI_API void ClearTexData(); // Clear output texture data (CPU side). Saves RAM once the texture has been copied to graphics memory. + IMGUI_API void ClearFonts(); // Clear output font data (glyphs storage, UV coordinates). + IMGUI_API void Clear(); // Clear all input and output. + + // Build atlas, retrieve pixel data. + // User is in charge of copying the pixels into graphics memory (e.g. create a texture with your engine). Then store your texture handle with SetTexID(). + // The pitch is always = Width * BytesPerPixels (1 or 4) + // Building in RGBA32 format is provided for convenience and compatibility, but note that unless you manually manipulate or copy color data into + // the texture (e.g. when using the AddCustomRect*** api), then the RGB pixels emitted will always be white (~75% of memory/bandwidth waste. + IMGUI_API bool Build(); // Build pixels data. This is called automatically for you by the GetTexData*** functions. + IMGUI_API void GetTexDataAsAlpha8(unsigned char** out_pixels, int* out_width, int* out_height, int* out_bytes_per_pixel = NULL); // 1 byte per-pixel + IMGUI_API void GetTexDataAsRGBA32(unsigned char** out_pixels, int* out_width, int* out_height, int* out_bytes_per_pixel = NULL); // 4 bytes-per-pixel + bool IsBuilt() const { return Fonts.Size > 0 && TexReady; } // Bit ambiguous: used to detect when user didn't built texture but effectively we should check TexID != 0 except that would be backend dependent... + void SetTexID(ImTextureID id) { TexID = id; } + + //------------------------------------------- + // Glyph Ranges + //------------------------------------------- + + // Helpers to retrieve list of common Unicode ranges (2 value per range, values are inclusive, zero-terminated list) + // NB: Make sure that your string are UTF-8 and NOT in your local code page. In C++11, you can create UTF-8 string literal using the u8"Hello world" syntax. See FAQ for details. + // NB: Consider using ImFontGlyphRangesBuilder to build glyph ranges from textual data. + IMGUI_API const ImWchar* GetGlyphRangesDefault(); // Basic Latin, Extended Latin + IMGUI_API const ImWchar* GetGlyphRangesKorean(); // Default + Korean characters + IMGUI_API const ImWchar* GetGlyphRangesJapanese(); // Default + Hiragana, Katakana, Half-Width, Selection of 2999 Ideographs + IMGUI_API const ImWchar* GetGlyphRangesChineseFull(); // Default + Half-Width + Japanese Hiragana/Katakana + full set of about 21000 CJK Unified Ideographs + IMGUI_API const ImWchar* GetGlyphRangesChineseSimplifiedCommon();// Default + Half-Width + Japanese Hiragana/Katakana + set of 2500 CJK Unified Ideographs for common simplified Chinese + IMGUI_API const ImWchar* GetGlyphRangesCyrillic(); // Default + about 400 Cyrillic characters + IMGUI_API const ImWchar* GetGlyphRangesThai(); // Default + Thai characters + IMGUI_API const ImWchar* GetGlyphRangesVietnamese(); // Default + Vietnamese characters + + //------------------------------------------- + // [BETA] Custom Rectangles/Glyphs API + //------------------------------------------- + + // You can request arbitrary rectangles to be packed into the atlas, for your own purposes. + // - After calling Build(), you can query the rectangle position and render your pixels. + // - If you render colored output, set 'atlas->TexPixelsUseColors = true' as this may help some backends decide of prefered texture format. + // - You can also request your rectangles to be mapped as font glyph (given a font + Unicode point), + // so you can render e.g. custom colorful icons and use them as regular glyphs. + // - Read docs/FONTS.md for more details about using colorful icons. + // - Note: this API may be redesigned later in order to support multi-monitor varying DPI settings. + IMGUI_API int AddCustomRectRegular(int width, int height); + IMGUI_API int AddCustomRectFontGlyph(ImFont* font, ImWchar id, int width, int height, float advance_x, const ImVec2& offset = ImVec2(0, 0)); + ImFontAtlasCustomRect* GetCustomRectByIndex(int index) { IM_ASSERT(index >= 0); return &CustomRects[index]; } + + // [Internal] + IMGUI_API void CalcCustomRectUV(const ImFontAtlasCustomRect* rect, ImVec2* out_uv_min, ImVec2* out_uv_max) const; + IMGUI_API bool GetMouseCursorTexData(ImGuiMouseCursor cursor, ImVec2* out_offset, ImVec2* out_size, ImVec2 out_uv_border[2], ImVec2 out_uv_fill[2]); + + //------------------------------------------- + // Members + //------------------------------------------- + + ImFontAtlasFlags Flags; // Build flags (see ImFontAtlasFlags_) + ImTextureID TexID; // User data to refer to the texture once it has been uploaded to user's graphic systems. It is passed back to you during rendering via the ImDrawCmd structure. + int TexDesiredWidth; // Texture width desired by user before Build(). Must be a power-of-two. If have many glyphs your graphics API have texture size restrictions you may want to increase texture width to decrease height. + int TexGlyphPadding; // Padding between glyphs within texture in pixels. Defaults to 1. If your rendering method doesn't rely on bilinear filtering you may set this to 0. + bool Locked; // Marked as Locked by ImGui::NewFrame() so attempt to modify the atlas will assert. + + // [Internal] + // NB: Access texture data via GetTexData*() calls! Which will setup a default font for you. + bool TexReady; // Set when texture was built matching current font input + bool TexPixelsUseColors; // Tell whether our texture data is known to use colors (rather than just alpha channel), in order to help backend select a format. + unsigned char* TexPixelsAlpha8; // 1 component per pixel, each component is unsigned 8-bit. Total size = TexWidth * TexHeight + unsigned int* TexPixelsRGBA32; // 4 component per pixel, each component is unsigned 8-bit. Total size = TexWidth * TexHeight * 4 + int TexWidth; // Texture width calculated during Build(). + int TexHeight; // Texture height calculated during Build(). + ImVec2 TexUvScale; // = (1.0f/TexWidth, 1.0f/TexHeight) + ImVec2 TexUvWhitePixel; // Texture coordinates to a white pixel + ImVector Fonts; // Hold all the fonts returned by AddFont*. Fonts[0] is the default font upon calling ImGui::NewFrame(), use ImGui::PushFont()/PopFont() to change the current font. + ImVector CustomRects; // Rectangles for packing custom texture data into the atlas. + ImVector ConfigData; // Configuration data + ImVec4 TexUvLines[IM_DRAWLIST_TEX_LINES_WIDTH_MAX + 1]; // UVs for baked anti-aliased lines + + // [Internal] Font builder + const ImFontBuilderIO* FontBuilderIO; // Opaque interface to a font builder (default to stb_truetype, can be changed to use FreeType by defining IMGUI_ENABLE_FREETYPE). + unsigned int FontBuilderFlags; // Shared flags (for all fonts) for custom font builder. THIS IS BUILD IMPLEMENTATION DEPENDENT. Per-font override is also available in ImFontConfig. + + // [Internal] Packing data + int PackIdMouseCursors; // Custom texture rectangle ID for white pixel and mouse cursors + int PackIdLines; // Custom texture rectangle ID for baked anti-aliased lines + +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + typedef ImFontAtlasCustomRect CustomRect; // OBSOLETED in 1.72+ + //typedef ImFontGlyphRangesBuilder GlyphRangesBuilder; // OBSOLETED in 1.67+ +#endif +}; + +// Font runtime data and rendering +// ImFontAtlas automatically loads a default embedded font for you when you call GetTexDataAsAlpha8() or GetTexDataAsRGBA32(). +struct ImFont +{ + // Members: Hot ~20/24 bytes (for CalcTextSize) + ImVector IndexAdvanceX; // 12-16 // out // // Sparse. Glyphs->AdvanceX in a directly indexable way (cache-friendly for CalcTextSize functions which only this this info, and are often bottleneck in large UI). + float FallbackAdvanceX; // 4 // out // = FallbackGlyph->AdvanceX + float FontSize; // 4 // in // // Height of characters/line, set during loading (don't change after loading) + + // Members: Hot ~28/40 bytes (for CalcTextSize + render loop) + ImVector IndexLookup; // 12-16 // out // // Sparse. Index glyphs by Unicode code-point. + ImVector Glyphs; // 12-16 // out // // All glyphs. + const ImFontGlyph* FallbackGlyph; // 4-8 // out // = FindGlyph(FontFallbackChar) + + // Members: Cold ~32/40 bytes + ImFontAtlas* ContainerAtlas; // 4-8 // out // // What we has been loaded into + const ImFontConfig* ConfigData; // 4-8 // in // // Pointer within ContainerAtlas->ConfigData + short ConfigDataCount; // 2 // in // ~ 1 // Number of ImFontConfig involved in creating this font. Bigger than 1 when merging multiple font sources into one ImFont. + ImWchar FallbackChar; // 2 // out // = FFFD/'?' // Character used if a glyph isn't found. + ImWchar EllipsisChar; // 2 // out // = '...' // Character used for ellipsis rendering. + ImWchar DotChar; // 2 // out // = '.' // Character used for ellipsis rendering (if a single '...' character isn't found) + bool DirtyLookupTables; // 1 // out // + float Scale; // 4 // in // = 1.f // Base font scale, multiplied by the per-window font scale which you can adjust with SetWindowFontScale() + float Ascent, Descent; // 4+4 // out // // Ascent: distance from top to bottom of e.g. 'A' [0..FontSize] + int MetricsTotalSurface;// 4 // out // // Total surface in pixels to get an idea of the font rasterization/texture cost (not exact, we approximate the cost of padding between glyphs) + ImU8 Used4kPagesMap[(IM_UNICODE_CODEPOINT_MAX+1)/4096/8]; // 2 bytes if ImWchar=ImWchar16, 34 bytes if ImWchar==ImWchar32. Store 1-bit for each block of 4K codepoints that has one active glyph. This is mainly used to facilitate iterations across all used codepoints. + + // Methods + IMGUI_API ImFont(); + IMGUI_API ~ImFont(); + IMGUI_API const ImFontGlyph*FindGlyph(ImWchar c) const; + IMGUI_API const ImFontGlyph*FindGlyphNoFallback(ImWchar c) const; + float GetCharAdvance(ImWchar c) const { return ((int)c < IndexAdvanceX.Size) ? IndexAdvanceX[(int)c] : FallbackAdvanceX; } + bool IsLoaded() const { return ContainerAtlas != NULL; } + const char* GetDebugName() const { return ConfigData ? ConfigData->Name : ""; } + + // 'max_width' stops rendering after a certain width (could be turned into a 2d size). FLT_MAX to disable. + // 'wrap_width' enable automatic word-wrapping across multiple lines to fit into given width. 0.0f to disable. + IMGUI_API ImVec2 CalcTextSizeA(float size, float max_width, float wrap_width, const char* text_begin, const char* text_end = NULL, const char** remaining = NULL) const; // utf8 + IMGUI_API const char* CalcWordWrapPositionA(float scale, const char* text, const char* text_end, float wrap_width) const; + IMGUI_API void RenderChar(ImDrawList* draw_list, float size, ImVec2 pos, ImU32 col, ImWchar c) const; + IMGUI_API void RenderText(ImDrawList* draw_list, float size, ImVec2 pos, ImU32 col, const ImVec4& clip_rect, const char* text_begin, const char* text_end, float wrap_width = 0.0f, bool cpu_fine_clip = false) const; + + // [Internal] Don't use! + IMGUI_API void BuildLookupTable(); + IMGUI_API void ClearOutputData(); + IMGUI_API void GrowIndex(int new_size); + IMGUI_API void AddGlyph(const ImFontConfig* src_cfg, ImWchar c, float x0, float y0, float x1, float y1, float u0, float v0, float u1, float v1, float advance_x); + IMGUI_API void AddRemapChar(ImWchar dst, ImWchar src, bool overwrite_dst = true); // Makes 'dst' character/glyph points to 'src' character/glyph. Currently needs to be called AFTER fonts have been built. + IMGUI_API void SetGlyphVisible(ImWchar c, bool visible); + IMGUI_API bool IsGlyphRangeUnused(unsigned int c_begin, unsigned int c_last); +}; + +//----------------------------------------------------------------------------- +// [SECTION] Viewports +//----------------------------------------------------------------------------- + +// Flags stored in ImGuiViewport::Flags, giving indications to the platform backends. +enum ImGuiViewportFlags_ +{ + ImGuiViewportFlags_None = 0, + ImGuiViewportFlags_IsPlatformWindow = 1 << 0, // Represent a Platform Window + ImGuiViewportFlags_IsPlatformMonitor = 1 << 1, // Represent a Platform Monitor (unused yet) + ImGuiViewportFlags_OwnedByApp = 1 << 2 // Platform Window: is created/managed by the application (rather than a dear imgui backend) +}; + +// - Currently represents the Platform Window created by the application which is hosting our Dear ImGui windows. +// - In 'docking' branch with multi-viewport enabled, we extend this concept to have multiple active viewports. +// - In the future we will extend this concept further to also represent Platform Monitor and support a "no main platform window" operation mode. +// - About Main Area vs Work Area: +// - Main Area = entire viewport. +// - Work Area = entire viewport minus sections used by main menu bars (for platform windows), or by task bar (for platform monitor). +// - Windows are generally trying to stay within the Work Area of their host viewport. +struct ImGuiViewport +{ + ImGuiViewportFlags Flags; // See ImGuiViewportFlags_ + ImVec2 Pos; // Main Area: Position of the viewport (Dear ImGui coordinates are the same as OS desktop/native coordinates) + ImVec2 Size; // Main Area: Size of the viewport. + ImVec2 WorkPos; // Work Area: Position of the viewport minus task bars, menus bars, status bars (>= Pos) + ImVec2 WorkSize; // Work Area: Size of the viewport minus task bars, menu bars, status bars (<= Size) + + ImGuiViewport() { memset(this, 0, sizeof(*this)); } + + // Helpers + ImVec2 GetCenter() const { return ImVec2(Pos.x + Size.x * 0.5f, Pos.y + Size.y * 0.5f); } + ImVec2 GetWorkCenter() const { return ImVec2(WorkPos.x + WorkSize.x * 0.5f, WorkPos.y + WorkSize.y * 0.5f); } +}; + +//----------------------------------------------------------------------------- +// [SECTION] Obsolete functions and types +// (Will be removed! Read 'API BREAKING CHANGES' section in imgui.cpp for details) +// Please keep your copy of dear imgui up to date! Occasionally set '#define IMGUI_DISABLE_OBSOLETE_FUNCTIONS' in imconfig.h to stay ahead. +//----------------------------------------------------------------------------- + +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS +namespace ImGui +{ + // OBSOLETED in 1.85 (from August 2021) + static inline float GetWindowContentRegionWidth() { return GetWindowContentRegionMax().x - GetWindowContentRegionMin().x; } + // OBSOLETED in 1.81 (from February 2021) + IMGUI_API bool ListBoxHeader(const char* label, int items_count, int height_in_items = -1); // Helper to calculate size from items_count and height_in_items + static inline bool ListBoxHeader(const char* label, const ImVec2& size = ImVec2(0, 0)) { return BeginListBox(label, size); } + static inline void ListBoxFooter() { EndListBox(); } + // OBSOLETED in 1.79 (from August 2020) + static inline void OpenPopupContextItem(const char* str_id = NULL, ImGuiMouseButton mb = 1) { OpenPopupOnItemClick(str_id, mb); } // Bool return value removed. Use IsWindowAppearing() in BeginPopup() instead. Renamed in 1.77, renamed back in 1.79. Sorry! + // OBSOLETED in 1.78 (from June 2020) + // Old drag/sliders functions that took a 'float power = 1.0' argument instead of flags. + // For shared code, you can version check at compile-time with `#if IMGUI_VERSION_NUM >= 17704`. + IMGUI_API bool DragScalar(const char* label, ImGuiDataType data_type, void* p_data, float v_speed, const void* p_min, const void* p_max, const char* format, float power); + IMGUI_API bool DragScalarN(const char* label, ImGuiDataType data_type, void* p_data, int components, float v_speed, const void* p_min, const void* p_max, const char* format, float power); + static inline bool DragFloat(const char* label, float* v, float v_speed, float v_min, float v_max, const char* format, float power) { return DragScalar(label, ImGuiDataType_Float, v, v_speed, &v_min, &v_max, format, power); } + static inline bool DragFloat2(const char* label, float v[2], float v_speed, float v_min, float v_max, const char* format, float power) { return DragScalarN(label, ImGuiDataType_Float, v, 2, v_speed, &v_min, &v_max, format, power); } + static inline bool DragFloat3(const char* label, float v[3], float v_speed, float v_min, float v_max, const char* format, float power) { return DragScalarN(label, ImGuiDataType_Float, v, 3, v_speed, &v_min, &v_max, format, power); } + static inline bool DragFloat4(const char* label, float v[4], float v_speed, float v_min, float v_max, const char* format, float power) { return DragScalarN(label, ImGuiDataType_Float, v, 4, v_speed, &v_min, &v_max, format, power); } + IMGUI_API bool SliderScalar(const char* label, ImGuiDataType data_type, void* p_data, const void* p_min, const void* p_max, const char* format, float power); + IMGUI_API bool SliderScalarN(const char* label, ImGuiDataType data_type, void* p_data, int components, const void* p_min, const void* p_max, const char* format, float power); + static inline bool SliderFloat(const char* label, float* v, float v_min, float v_max, const char* format, float power) { return SliderScalar(label, ImGuiDataType_Float, v, &v_min, &v_max, format, power); } + static inline bool SliderFloat2(const char* label, float v[2], float v_min, float v_max, const char* format, float power) { return SliderScalarN(label, ImGuiDataType_Float, v, 2, &v_min, &v_max, format, power); } + static inline bool SliderFloat3(const char* label, float v[3], float v_min, float v_max, const char* format, float power) { return SliderScalarN(label, ImGuiDataType_Float, v, 3, &v_min, &v_max, format, power); } + static inline bool SliderFloat4(const char* label, float v[4], float v_min, float v_max, const char* format, float power) { return SliderScalarN(label, ImGuiDataType_Float, v, 4, &v_min, &v_max, format, power); } + // OBSOLETED in 1.77 (from June 2020) + static inline bool BeginPopupContextWindow(const char* str_id, ImGuiMouseButton mb, bool over_items) { return BeginPopupContextWindow(str_id, mb | (over_items ? 0 : ImGuiPopupFlags_NoOpenOverItems)); } + // OBSOLETED in 1.72 (from April 2019) + static inline void TreeAdvanceToLabelPos() { SetCursorPosX(GetCursorPosX() + GetTreeNodeToLabelSpacing()); } + // OBSOLETED in 1.71 (from June 2019) + static inline void SetNextTreeNodeOpen(bool open, ImGuiCond cond = 0) { SetNextItemOpen(open, cond); } + // OBSOLETED in 1.70 (from May 2019) + static inline float GetContentRegionAvailWidth() { return GetContentRegionAvail().x; } + + // Some of the older obsolete names along with their replacement (commented out so they are not reported in IDE) + //static inline ImDrawList* GetOverlayDrawList() { return GetForegroundDrawList(); } // OBSOLETED in 1.69 (from Mar 2019) + //static inline void SetScrollHere(float ratio = 0.5f) { SetScrollHereY(ratio); } // OBSOLETED in 1.66 (from Nov 2018) + //static inline bool IsItemDeactivatedAfterChange() { return IsItemDeactivatedAfterEdit(); } // OBSOLETED in 1.63 (from Aug 2018) + //static inline bool IsAnyWindowFocused() { return IsWindowFocused(ImGuiFocusedFlags_AnyWindow); } // OBSOLETED in 1.60 (from Apr 2018) + //static inline bool IsAnyWindowHovered() { return IsWindowHovered(ImGuiHoveredFlags_AnyWindow); } // OBSOLETED in 1.60 (between Dec 2017 and Apr 2018) + //static inline void ShowTestWindow() { return ShowDemoWindow(); } // OBSOLETED in 1.53 (between Oct 2017 and Dec 2017) + //static inline bool IsRootWindowFocused() { return IsWindowFocused(ImGuiFocusedFlags_RootWindow); } // OBSOLETED in 1.53 (between Oct 2017 and Dec 2017) + //static inline bool IsRootWindowOrAnyChildFocused() { return IsWindowFocused(ImGuiFocusedFlags_RootAndChildWindows); } // OBSOLETED in 1.53 (between Oct 2017 and Dec 2017) + //static inline void SetNextWindowContentWidth(float w) { SetNextWindowContentSize(ImVec2(w, 0.0f)); } // OBSOLETED in 1.53 (between Oct 2017 and Dec 2017) + //static inline float GetItemsLineHeightWithSpacing() { return GetFrameHeightWithSpacing(); } // OBSOLETED in 1.53 (between Oct 2017 and Dec 2017) +} + +// OBSOLETED in 1.82 (from Mars 2021): flags for AddRect(), AddRectFilled(), AddImageRounded(), PathRect() +typedef ImDrawFlags ImDrawCornerFlags; +enum ImDrawCornerFlags_ +{ + ImDrawCornerFlags_None = ImDrawFlags_RoundCornersNone, // Was == 0 prior to 1.82, this is now == ImDrawFlags_RoundCornersNone which is != 0 and not implicit + ImDrawCornerFlags_TopLeft = ImDrawFlags_RoundCornersTopLeft, // Was == 0x01 (1 << 0) prior to 1.82. Order matches ImDrawFlags_NoRoundCorner* flag (we exploit this internally). + ImDrawCornerFlags_TopRight = ImDrawFlags_RoundCornersTopRight, // Was == 0x02 (1 << 1) prior to 1.82. + ImDrawCornerFlags_BotLeft = ImDrawFlags_RoundCornersBottomLeft, // Was == 0x04 (1 << 2) prior to 1.82. + ImDrawCornerFlags_BotRight = ImDrawFlags_RoundCornersBottomRight, // Was == 0x08 (1 << 3) prior to 1.82. + ImDrawCornerFlags_All = ImDrawFlags_RoundCornersAll, // Was == 0x0F prior to 1.82 + ImDrawCornerFlags_Top = ImDrawCornerFlags_TopLeft | ImDrawCornerFlags_TopRight, + ImDrawCornerFlags_Bot = ImDrawCornerFlags_BotLeft | ImDrawCornerFlags_BotRight, + ImDrawCornerFlags_Left = ImDrawCornerFlags_TopLeft | ImDrawCornerFlags_BotLeft, + ImDrawCornerFlags_Right = ImDrawCornerFlags_TopRight | ImDrawCornerFlags_BotRight +}; + +#endif // #ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + +//----------------------------------------------------------------------------- + +#if defined(__clang__) +#pragma clang diagnostic pop +#elif defined(__GNUC__) +#pragma GCC diagnostic pop +#endif + +#ifdef _MSC_VER +#pragma warning (pop) +#endif + +// Include imgui_user.h at the end of imgui.h (convenient for user to only explicitly include vanilla imgui.h) +#ifdef IMGUI_INCLUDE_IMGUI_USER_H +#include "imgui_user.h" +#endif + +#endif // #ifndef IMGUI_DISABLE diff --git a/source/editor/imgui/imgui_demo.cpp b/source/editor/imgui/imgui_demo.cpp new file mode 100644 index 0000000..3cc50a8 --- /dev/null +++ b/source/editor/imgui/imgui_demo.cpp @@ -0,0 +1,7653 @@ +// dear imgui, v1.85 WIP +// (demo code) + +// Help: +// - Read FAQ at http://dearimgui.org/faq +// - Newcomers, read 'Programmer guide' in imgui.cpp for notes on how to setup Dear ImGui in your codebase. +// - Call and read ImGui::ShowDemoWindow() in imgui_demo.cpp. All applications in examples/ are doing that. +// Read imgui.cpp for more details, documentation and comments. +// Get the latest version at https://github.com/ocornut/imgui + +// Message to the person tempted to delete this file when integrating Dear ImGui into their codebase: +// Do NOT remove this file from your project! Think again! It is the most useful reference code that you and other +// coders will want to refer to and call. Have the ImGui::ShowDemoWindow() function wired in an always-available +// debug menu of your game/app! Removing this file from your project is hindering access to documentation for everyone +// in your team, likely leading you to poorer usage of the library. +// Everything in this file will be stripped out by the linker if you don't call ImGui::ShowDemoWindow(). +// If you want to link core Dear ImGui in your shipped builds but want a thorough guarantee that the demo will not be +// linked, you can setup your imconfig.h with #define IMGUI_DISABLE_DEMO_WINDOWS and those functions will be empty. +// In another situation, whenever you have Dear ImGui available you probably want this to be available for reference. +// Thank you, +// -Your beloved friend, imgui_demo.cpp (which you won't delete) + +// Message to beginner C/C++ programmers about the meaning of the 'static' keyword: +// In this demo code, we frequently use 'static' variables inside functions. A static variable persists across calls, +// so it is essentially like a global variable but declared inside the scope of the function. We do this as a way to +// gather code and data in the same place, to make the demo source code faster to read, faster to write, and smaller +// in size. It also happens to be a convenient way of storing simple UI related information as long as your function +// doesn't need to be reentrant or used in multiple threads. This might be a pattern you will want to use in your code, +// but most of the real data you would be editing is likely going to be stored outside your functions. + +// The Demo code in this file is designed to be easy to copy-and-paste into your application! +// Because of this: +// - We never omit the ImGui:: prefix when calling functions, even though most code here is in the same namespace. +// - We try to declare static variables in the local scope, as close as possible to the code using them. +// - We never use any of the helpers/facilities used internally by Dear ImGui, unless available in the public API. +// - We never use maths operators on ImVec2/ImVec4. For our other sources files we use them, and they are provided +// by imgui_internal.h using the IMGUI_DEFINE_MATH_OPERATORS define. For your own sources file they are optional +// and require you either enable those, either provide your own via IM_VEC2_CLASS_EXTRA in imconfig.h. +// Because we can't assume anything about your support of maths operators, we cannot use them in imgui_demo.cpp. + +// Navigating this file: +// - In Visual Studio IDE: CTRL+comma ("Edit.NavigateTo") can follow symbols in comments, whereas CTRL+F12 ("Edit.GoToImplementation") cannot. +// - With Visual Assist installed: ALT+G ("VAssistX.GoToImplementation") can also follow symbols in comments. + +/* + +Index of this file: + +// [SECTION] Forward Declarations, Helpers +// [SECTION] Demo Window / ShowDemoWindow() +// - sub section: ShowDemoWindowWidgets() +// - sub section: ShowDemoWindowLayout() +// - sub section: ShowDemoWindowPopups() +// - sub section: ShowDemoWindowTables() +// - sub section: ShowDemoWindowMisc() +// [SECTION] About Window / ShowAboutWindow() +// [SECTION] Style Editor / ShowStyleEditor() +// [SECTION] Example App: Main Menu Bar / ShowExampleAppMainMenuBar() +// [SECTION] Example App: Debug Console / ShowExampleAppConsole() +// [SECTION] Example App: Debug Log / ShowExampleAppLog() +// [SECTION] Example App: Simple Layout / ShowExampleAppLayout() +// [SECTION] Example App: Property Editor / ShowExampleAppPropertyEditor() +// [SECTION] Example App: Long Text / ShowExampleAppLongText() +// [SECTION] Example App: Auto Resize / ShowExampleAppAutoResize() +// [SECTION] Example App: Constrained Resize / ShowExampleAppConstrainedResize() +// [SECTION] Example App: Simple overlay / ShowExampleAppSimpleOverlay() +// [SECTION] Example App: Fullscreen window / ShowExampleAppFullscreen() +// [SECTION] Example App: Manipulating window titles / ShowExampleAppWindowTitles() +// [SECTION] Example App: Custom Rendering using ImDrawList API / ShowExampleAppCustomRendering() +// [SECTION] Example App: Documents Handling / ShowExampleAppDocuments() + +*/ + +#if defined(_MSC_VER) && !defined(_CRT_SECURE_NO_WARNINGS) +#define _CRT_SECURE_NO_WARNINGS +#endif + +#include "imgui.h" +#ifndef IMGUI_DISABLE + +// System includes +#include // toupper +#include // INT_MIN, INT_MAX +#include // sqrtf, powf, cosf, sinf, floorf, ceilf +#include // vsnprintf, sscanf, printf +#include // NULL, malloc, free, atoi +#if defined(_MSC_VER) && _MSC_VER <= 1500 // MSVC 2008 or earlier +#include // intptr_t +#else +#include // intptr_t +#endif + +// Visual Studio warnings +#ifdef _MSC_VER +#pragma warning (disable: 4996) // 'This function or variable may be unsafe': strcpy, strdup, sprintf, vsnprintf, sscanf, fopen +#pragma warning (disable: 26451) // [Static Analyzer] Arithmetic overflow : Using operator 'xxx' on a 4 byte value and then casting the result to a 8 byte value. Cast the value to the wider type before calling operator 'xxx' to avoid overflow(io.2). +#endif + +// Clang/GCC warnings with -Weverything +#if defined(__clang__) +#if __has_warning("-Wunknown-warning-option") +#pragma clang diagnostic ignored "-Wunknown-warning-option" // warning: unknown warning group 'xxx' // not all warnings are known by all Clang versions and they tend to be rename-happy.. so ignoring warnings triggers new warnings on some configuration. Great! +#endif +#pragma clang diagnostic ignored "-Wunknown-pragmas" // warning: unknown warning group 'xxx' +#pragma clang diagnostic ignored "-Wold-style-cast" // warning: use of old-style cast // yes, they are more terse. +#pragma clang diagnostic ignored "-Wdeprecated-declarations" // warning: 'xx' is deprecated: The POSIX name for this.. // for strdup used in demo code (so user can copy & paste the code) +#pragma clang diagnostic ignored "-Wint-to-void-pointer-cast" // warning: cast to 'void *' from smaller integer type +#pragma clang diagnostic ignored "-Wformat-security" // warning: format string is not a string literal +#pragma clang diagnostic ignored "-Wexit-time-destructors" // warning: declaration requires an exit-time destructor // exit-time destruction order is undefined. if MemFree() leads to users code that has been disabled before exit it might cause problems. ImGui coding style welcomes static/globals. +#pragma clang diagnostic ignored "-Wunused-macros" // warning: macro is not used // we define snprintf/vsnprintf on Windows so they are available, but not always used. +#pragma clang diagnostic ignored "-Wzero-as-null-pointer-constant" // warning: zero as null pointer constant // some standard header variations use #define NULL 0 +#pragma clang diagnostic ignored "-Wdouble-promotion" // warning: implicit conversion from 'float' to 'double' when passing argument to function // using printf() is a misery with this as C++ va_arg ellipsis changes float to double. +#pragma clang diagnostic ignored "-Wreserved-id-macro" // warning: macro name is a reserved identifier +#pragma clang diagnostic ignored "-Wimplicit-int-float-conversion" // warning: implicit conversion from 'xxx' to 'float' may lose precision +#elif defined(__GNUC__) +#pragma GCC diagnostic ignored "-Wpragmas" // warning: unknown option after '#pragma GCC diagnostic' kind +#pragma GCC diagnostic ignored "-Wint-to-pointer-cast" // warning: cast to pointer from integer of different size +#pragma GCC diagnostic ignored "-Wformat-security" // warning: format string is not a string literal (potentially insecure) +#pragma GCC diagnostic ignored "-Wdouble-promotion" // warning: implicit conversion from 'float' to 'double' when passing argument to function +#pragma GCC diagnostic ignored "-Wconversion" // warning: conversion to 'xxxx' from 'xxxx' may alter its value +#pragma GCC diagnostic ignored "-Wmisleading-indentation" // [__GNUC__ >= 6] warning: this 'if' clause does not guard this statement // GCC 6.0+ only. See #883 on GitHub. +#endif + +// Play it nice with Windows users (Update: May 2018, Notepad now supports Unix-style carriage returns!) +#ifdef _WIN32 +#define IM_NEWLINE "\r\n" +#else +#define IM_NEWLINE "\n" +#endif + +// Helpers +#if defined(_MSC_VER) && !defined(snprintf) +#define snprintf _snprintf +#endif +#if defined(_MSC_VER) && !defined(vsnprintf) +#define vsnprintf _vsnprintf +#endif + +// Format specifiers, printing 64-bit hasn't been decently standardized... +// In a real application you should be using PRId64 and PRIu64 from (non-windows) and on Windows define them yourself. +#ifdef _MSC_VER +#define IM_PRId64 "I64d" +#define IM_PRIu64 "I64u" +#else +#define IM_PRId64 "lld" +#define IM_PRIu64 "llu" +#endif + +// Helpers macros +// We normally try to not use many helpers in imgui_demo.cpp in order to make code easier to copy and paste, +// but making an exception here as those are largely simplifying code... +// In other imgui sources we can use nicer internal functions from imgui_internal.h (ImMin/ImMax) but not in the demo. +#define IM_MIN(A, B) (((A) < (B)) ? (A) : (B)) +#define IM_MAX(A, B) (((A) >= (B)) ? (A) : (B)) +#define IM_CLAMP(V, MN, MX) ((V) < (MN) ? (MN) : (V) > (MX) ? (MX) : (V)) + +// Enforce cdecl calling convention for functions called by the standard library, in case compilation settings changed the default to e.g. __vectorcall +#ifndef IMGUI_CDECL +#ifdef _MSC_VER +#define IMGUI_CDECL __cdecl +#else +#define IMGUI_CDECL +#endif +#endif + +//----------------------------------------------------------------------------- +// [SECTION] Forward Declarations, Helpers +//----------------------------------------------------------------------------- + +#if !defined(IMGUI_DISABLE_DEMO_WINDOWS) + +// Forward Declarations +static void ShowExampleAppDocuments(bool* p_open); +static void ShowExampleAppMainMenuBar(); +static void ShowExampleAppConsole(bool* p_open); +static void ShowExampleAppLog(bool* p_open); +static void ShowExampleAppLayout(bool* p_open); +static void ShowExampleAppPropertyEditor(bool* p_open); +static void ShowExampleAppLongText(bool* p_open); +static void ShowExampleAppAutoResize(bool* p_open); +static void ShowExampleAppConstrainedResize(bool* p_open); +static void ShowExampleAppSimpleOverlay(bool* p_open); +static void ShowExampleAppFullscreen(bool* p_open); +static void ShowExampleAppWindowTitles(bool* p_open); +static void ShowExampleAppCustomRendering(bool* p_open); +static void ShowExampleMenuFile(); + +// Helper to display a little (?) mark which shows a tooltip when hovered. +// In your own code you may want to display an actual icon if you are using a merged icon fonts (see docs/FONTS.md) +static void HelpMarker(const char* desc) +{ + ImGui::TextDisabled("(?)"); + if (ImGui::IsItemHovered()) + { + ImGui::BeginTooltip(); + ImGui::PushTextWrapPos(ImGui::GetFontSize() * 35.0f); + ImGui::TextUnformatted(desc); + ImGui::PopTextWrapPos(); + ImGui::EndTooltip(); + } +} + +// Helper to display basic user controls. +void ImGui::ShowUserGuide() +{ + ImGuiIO& io = ImGui::GetIO(); + ImGui::BulletText("Double-click on title bar to collapse window."); + ImGui::BulletText( + "Click and drag on lower corner to resize window\n" + "(double-click to auto fit window to its contents)."); + ImGui::BulletText("CTRL+Click on a slider or drag box to input value as text."); + ImGui::BulletText("TAB/SHIFT+TAB to cycle through keyboard editable fields."); + if (io.FontAllowUserScaling) + ImGui::BulletText("CTRL+Mouse Wheel to zoom window contents."); + ImGui::BulletText("While inputing text:\n"); + ImGui::Indent(); + ImGui::BulletText("CTRL+Left/Right to word jump."); + ImGui::BulletText("CTRL+A or double-click to select all."); + ImGui::BulletText("CTRL+X/C/V to use clipboard cut/copy/paste."); + ImGui::BulletText("CTRL+Z,CTRL+Y to undo/redo."); + ImGui::BulletText("ESCAPE to revert."); + ImGui::BulletText("You can apply arithmetic operators +,*,/ on numerical values.\nUse +- to subtract."); + ImGui::Unindent(); + ImGui::BulletText("With keyboard navigation enabled:"); + ImGui::Indent(); + ImGui::BulletText("Arrow keys to navigate."); + ImGui::BulletText("Space to activate a widget."); + ImGui::BulletText("Return to input text into a widget."); + ImGui::BulletText("Escape to deactivate a widget, close popup, exit child window."); + ImGui::BulletText("Alt to jump to the menu layer of a window."); + ImGui::BulletText("CTRL+Tab to select a window."); + ImGui::Unindent(); +} + +//----------------------------------------------------------------------------- +// [SECTION] Demo Window / ShowDemoWindow() +//----------------------------------------------------------------------------- +// - ShowDemoWindowWidgets() +// - ShowDemoWindowLayout() +// - ShowDemoWindowPopups() +// - ShowDemoWindowTables() +// - ShowDemoWindowColumns() +// - ShowDemoWindowMisc() +//----------------------------------------------------------------------------- + +// We split the contents of the big ShowDemoWindow() function into smaller functions +// (because the link time of very large functions grow non-linearly) +static void ShowDemoWindowWidgets(); +static void ShowDemoWindowLayout(); +static void ShowDemoWindowPopups(); +static void ShowDemoWindowTables(); +static void ShowDemoWindowColumns(); +static void ShowDemoWindowMisc(); + +// Demonstrate most Dear ImGui features (this is big function!) +// You may execute this function to experiment with the UI and understand what it does. +// You may then search for keywords in the code when you are interested by a specific feature. +void ImGui::ShowDemoWindow(bool* p_open) +{ + // Exceptionally add an extra assert here for people confused about initial Dear ImGui setup + // Most ImGui functions would normally just crash if the context is missing. + IM_ASSERT(ImGui::GetCurrentContext() != NULL && "Missing dear imgui context. Refer to examples app!"); + + // Examples Apps (accessible from the "Examples" menu) + static bool show_app_main_menu_bar = false; + static bool show_app_documents = false; + + static bool show_app_console = false; + static bool show_app_log = false; + static bool show_app_layout = false; + static bool show_app_property_editor = false; + static bool show_app_long_text = false; + static bool show_app_auto_resize = false; + static bool show_app_constrained_resize = false; + static bool show_app_simple_overlay = false; + static bool show_app_fullscreen = false; + static bool show_app_window_titles = false; + static bool show_app_custom_rendering = false; + + if (show_app_main_menu_bar) ShowExampleAppMainMenuBar(); + if (show_app_documents) ShowExampleAppDocuments(&show_app_documents); + + if (show_app_console) ShowExampleAppConsole(&show_app_console); + if (show_app_log) ShowExampleAppLog(&show_app_log); + if (show_app_layout) ShowExampleAppLayout(&show_app_layout); + if (show_app_property_editor) ShowExampleAppPropertyEditor(&show_app_property_editor); + if (show_app_long_text) ShowExampleAppLongText(&show_app_long_text); + if (show_app_auto_resize) ShowExampleAppAutoResize(&show_app_auto_resize); + if (show_app_constrained_resize) ShowExampleAppConstrainedResize(&show_app_constrained_resize); + if (show_app_simple_overlay) ShowExampleAppSimpleOverlay(&show_app_simple_overlay); + if (show_app_fullscreen) ShowExampleAppFullscreen(&show_app_fullscreen); + if (show_app_window_titles) ShowExampleAppWindowTitles(&show_app_window_titles); + if (show_app_custom_rendering) ShowExampleAppCustomRendering(&show_app_custom_rendering); + + // Dear ImGui Apps (accessible from the "Tools" menu) + static bool show_app_metrics = false; + static bool show_app_style_editor = false; + static bool show_app_about = false; + + if (show_app_metrics) { ImGui::ShowMetricsWindow(&show_app_metrics); } + if (show_app_about) { ImGui::ShowAboutWindow(&show_app_about); } + if (show_app_style_editor) + { + ImGui::Begin("Dear ImGui Style Editor", &show_app_style_editor); + ImGui::ShowStyleEditor(); + ImGui::End(); + } + + // Demonstrate the various window flags. Typically you would just use the default! + static bool no_titlebar = false; + static bool no_scrollbar = false; + static bool no_menu = false; + static bool no_move = false; + static bool no_resize = false; + static bool no_collapse = false; + static bool no_close = false; + static bool no_nav = false; + static bool no_background = false; + static bool no_bring_to_front = false; + static bool unsaved_document = false; + + ImGuiWindowFlags window_flags = 0; + if (no_titlebar) window_flags |= ImGuiWindowFlags_NoTitleBar; + if (no_scrollbar) window_flags |= ImGuiWindowFlags_NoScrollbar; + if (!no_menu) window_flags |= ImGuiWindowFlags_MenuBar; + if (no_move) window_flags |= ImGuiWindowFlags_NoMove; + if (no_resize) window_flags |= ImGuiWindowFlags_NoResize; + if (no_collapse) window_flags |= ImGuiWindowFlags_NoCollapse; + if (no_nav) window_flags |= ImGuiWindowFlags_NoNav; + if (no_background) window_flags |= ImGuiWindowFlags_NoBackground; + if (no_bring_to_front) window_flags |= ImGuiWindowFlags_NoBringToFrontOnFocus; + if (unsaved_document) window_flags |= ImGuiWindowFlags_UnsavedDocument; + if (no_close) p_open = NULL; // Don't pass our bool* to Begin + + // We specify a default position/size in case there's no data in the .ini file. + // We only do it to make the demo applications a little more welcoming, but typically this isn't required. + const ImGuiViewport* main_viewport = ImGui::GetMainViewport(); + ImGui::SetNextWindowPos(ImVec2(main_viewport->WorkPos.x + 650, main_viewport->WorkPos.y + 20), ImGuiCond_FirstUseEver); + ImGui::SetNextWindowSize(ImVec2(550, 680), ImGuiCond_FirstUseEver); + + // Main body of the Demo window starts here. + if (!ImGui::Begin("Dear ImGui Demo", p_open, window_flags)) + { + // Early out if the window is collapsed, as an optimization. + ImGui::End(); + return; + } + + // Most "big" widgets share a common width settings by default. See 'Demo->Layout->Widgets Width' for details. + + // e.g. Use 2/3 of the space for widgets and 1/3 for labels (right align) + //ImGui::PushItemWidth(-ImGui::GetWindowWidth() * 0.35f); + + // e.g. Leave a fixed amount of width for labels (by passing a negative value), the rest goes to widgets. + ImGui::PushItemWidth(ImGui::GetFontSize() * -12); + + // Menu Bar + if (ImGui::BeginMenuBar()) + { + if (ImGui::BeginMenu("Menu")) + { + ShowExampleMenuFile(); + ImGui::EndMenu(); + } + if (ImGui::BeginMenu("Examples")) + { + ImGui::MenuItem("Main menu bar", NULL, &show_app_main_menu_bar); + ImGui::MenuItem("Console", NULL, &show_app_console); + ImGui::MenuItem("Log", NULL, &show_app_log); + ImGui::MenuItem("Simple layout", NULL, &show_app_layout); + ImGui::MenuItem("Property editor", NULL, &show_app_property_editor); + ImGui::MenuItem("Long text display", NULL, &show_app_long_text); + ImGui::MenuItem("Auto-resizing window", NULL, &show_app_auto_resize); + ImGui::MenuItem("Constrained-resizing window", NULL, &show_app_constrained_resize); + ImGui::MenuItem("Simple overlay", NULL, &show_app_simple_overlay); + ImGui::MenuItem("Fullscreen window", NULL, &show_app_fullscreen); + ImGui::MenuItem("Manipulating window titles", NULL, &show_app_window_titles); + ImGui::MenuItem("Custom rendering", NULL, &show_app_custom_rendering); + ImGui::MenuItem("Documents", NULL, &show_app_documents); + ImGui::EndMenu(); + } + //if (ImGui::MenuItem("MenuItem")) {} // You can also use MenuItem() inside a menu bar! + if (ImGui::BeginMenu("Tools")) + { + ImGui::MenuItem("Metrics/Debugger", NULL, &show_app_metrics); + ImGui::MenuItem("Style Editor", NULL, &show_app_style_editor); + ImGui::MenuItem("About Dear ImGui", NULL, &show_app_about); + ImGui::EndMenu(); + } + ImGui::EndMenuBar(); + } + + ImGui::Text("dear imgui says hello. (%s)", IMGUI_VERSION); + ImGui::Spacing(); + + if (ImGui::CollapsingHeader("Help")) + { + ImGui::Text("ABOUT THIS DEMO:"); + ImGui::BulletText("Sections below are demonstrating many aspects of the library."); + ImGui::BulletText("The \"Examples\" menu above leads to more demo contents."); + ImGui::BulletText("The \"Tools\" menu above gives access to: About Box, Style Editor,\n" + "and Metrics/Debugger (general purpose Dear ImGui debugging tool)."); + ImGui::Separator(); + + ImGui::Text("PROGRAMMER GUIDE:"); + ImGui::BulletText("See the ShowDemoWindow() code in imgui_demo.cpp. <- you are here!"); + ImGui::BulletText("See comments in imgui.cpp."); + ImGui::BulletText("See example applications in the examples/ folder."); + ImGui::BulletText("Read the FAQ at http://www.dearimgui.org/faq/"); + ImGui::BulletText("Set 'io.ConfigFlags |= NavEnableKeyboard' for keyboard controls."); + ImGui::BulletText("Set 'io.ConfigFlags |= NavEnableGamepad' for gamepad controls."); + ImGui::Separator(); + + ImGui::Text("USER GUIDE:"); + ImGui::ShowUserGuide(); + } + + if (ImGui::CollapsingHeader("Configuration")) + { + ImGuiIO& io = ImGui::GetIO(); + + if (ImGui::TreeNode("Configuration##2")) + { + ImGui::CheckboxFlags("io.ConfigFlags: NavEnableKeyboard", &io.ConfigFlags, ImGuiConfigFlags_NavEnableKeyboard); + ImGui::SameLine(); HelpMarker("Enable keyboard controls."); + ImGui::CheckboxFlags("io.ConfigFlags: NavEnableGamepad", &io.ConfigFlags, ImGuiConfigFlags_NavEnableGamepad); + ImGui::SameLine(); HelpMarker("Enable gamepad controls. Require backend to set io.BackendFlags |= ImGuiBackendFlags_HasGamepad.\n\nRead instructions in imgui.cpp for details."); + ImGui::CheckboxFlags("io.ConfigFlags: NavEnableSetMousePos", &io.ConfigFlags, ImGuiConfigFlags_NavEnableSetMousePos); + ImGui::SameLine(); HelpMarker("Instruct navigation to move the mouse cursor. See comment for ImGuiConfigFlags_NavEnableSetMousePos."); + ImGui::CheckboxFlags("io.ConfigFlags: NoMouse", &io.ConfigFlags, ImGuiConfigFlags_NoMouse); + if (io.ConfigFlags & ImGuiConfigFlags_NoMouse) + { + // The "NoMouse" option can get us stuck with a disabled mouse! Let's provide an alternative way to fix it: + if (fmodf((float)ImGui::GetTime(), 0.40f) < 0.20f) + { + ImGui::SameLine(); + ImGui::Text("<>"); + } + if (ImGui::IsKeyPressed(ImGui::GetKeyIndex(ImGuiKey_Space))) + io.ConfigFlags &= ~ImGuiConfigFlags_NoMouse; + } + ImGui::CheckboxFlags("io.ConfigFlags: NoMouseCursorChange", &io.ConfigFlags, ImGuiConfigFlags_NoMouseCursorChange); + ImGui::SameLine(); HelpMarker("Instruct backend to not alter mouse cursor shape and visibility."); + ImGui::Checkbox("io.ConfigInputTextCursorBlink", &io.ConfigInputTextCursorBlink); + ImGui::SameLine(); HelpMarker("Enable blinking cursor (optional as some users consider it to be distracting)"); + ImGui::Checkbox("io.ConfigDragClickToInputText", &io.ConfigDragClickToInputText); + ImGui::SameLine(); HelpMarker("Enable turning DragXXX widgets into text input with a simple mouse click-release (without moving)."); + ImGui::Checkbox("io.ConfigWindowsResizeFromEdges", &io.ConfigWindowsResizeFromEdges); + ImGui::SameLine(); HelpMarker("Enable resizing of windows from their edges and from the lower-left corner.\nThis requires (io.BackendFlags & ImGuiBackendFlags_HasMouseCursors) because it needs mouse cursor feedback."); + ImGui::Checkbox("io.ConfigWindowsMoveFromTitleBarOnly", &io.ConfigWindowsMoveFromTitleBarOnly); + ImGui::Checkbox("io.MouseDrawCursor", &io.MouseDrawCursor); + ImGui::SameLine(); HelpMarker("Instruct Dear ImGui to render a mouse cursor itself. Note that a mouse cursor rendered via your application GPU rendering path will feel more laggy than hardware cursor, but will be more in sync with your other visuals.\n\nSome desktop applications may use both kinds of cursors (e.g. enable software cursor only when resizing/dragging something)."); + ImGui::Text("Also see Style->Rendering for rendering options."); + ImGui::TreePop(); + ImGui::Separator(); + } + + if (ImGui::TreeNode("Backend Flags")) + { + HelpMarker( + "Those flags are set by the backends (imgui_impl_xxx files) to specify their capabilities.\n" + "Here we expose them as read-only fields to avoid breaking interactions with your backend."); + + // Make a local copy to avoid modifying actual backend flags. + ImGuiBackendFlags backend_flags = io.BackendFlags; + ImGui::CheckboxFlags("io.BackendFlags: HasGamepad", &backend_flags, ImGuiBackendFlags_HasGamepad); + ImGui::CheckboxFlags("io.BackendFlags: HasMouseCursors", &backend_flags, ImGuiBackendFlags_HasMouseCursors); + ImGui::CheckboxFlags("io.BackendFlags: HasSetMousePos", &backend_flags, ImGuiBackendFlags_HasSetMousePos); + ImGui::CheckboxFlags("io.BackendFlags: RendererHasVtxOffset", &backend_flags, ImGuiBackendFlags_RendererHasVtxOffset); + ImGui::TreePop(); + ImGui::Separator(); + } + + if (ImGui::TreeNode("Style")) + { + HelpMarker("The same contents can be accessed in 'Tools->Style Editor' or by calling the ShowStyleEditor() function."); + ImGui::ShowStyleEditor(); + ImGui::TreePop(); + ImGui::Separator(); + } + + if (ImGui::TreeNode("Capture/Logging")) + { + HelpMarker( + "The logging API redirects all text output so you can easily capture the content of " + "a window or a block. Tree nodes can be automatically expanded.\n" + "Try opening any of the contents below in this window and then click one of the \"Log To\" button."); + ImGui::LogButtons(); + + HelpMarker("You can also call ImGui::LogText() to output directly to the log without a visual output."); + if (ImGui::Button("Copy \"Hello, world!\" to clipboard")) + { + ImGui::LogToClipboard(); + ImGui::LogText("Hello, world!"); + ImGui::LogFinish(); + } + ImGui::TreePop(); + } + } + + if (ImGui::CollapsingHeader("Window options")) + { + if (ImGui::BeginTable("split", 3)) + { + ImGui::TableNextColumn(); ImGui::Checkbox("No titlebar", &no_titlebar); + ImGui::TableNextColumn(); ImGui::Checkbox("No scrollbar", &no_scrollbar); + ImGui::TableNextColumn(); ImGui::Checkbox("No menu", &no_menu); + ImGui::TableNextColumn(); ImGui::Checkbox("No move", &no_move); + ImGui::TableNextColumn(); ImGui::Checkbox("No resize", &no_resize); + ImGui::TableNextColumn(); ImGui::Checkbox("No collapse", &no_collapse); + ImGui::TableNextColumn(); ImGui::Checkbox("No close", &no_close); + ImGui::TableNextColumn(); ImGui::Checkbox("No nav", &no_nav); + ImGui::TableNextColumn(); ImGui::Checkbox("No background", &no_background); + ImGui::TableNextColumn(); ImGui::Checkbox("No bring to front", &no_bring_to_front); + ImGui::TableNextColumn(); ImGui::Checkbox("Unsaved document", &unsaved_document); + ImGui::EndTable(); + } + } + + // All demo contents + ShowDemoWindowWidgets(); + ShowDemoWindowLayout(); + ShowDemoWindowPopups(); + ShowDemoWindowTables(); + ShowDemoWindowMisc(); + + // End of ShowDemoWindow() + ImGui::PopItemWidth(); + ImGui::End(); +} + +static void ShowDemoWindowWidgets() +{ + if (!ImGui::CollapsingHeader("Widgets")) + return; + + static bool disable_all = false; // The Checkbox for that is inside the "Disabled" section at the bottom + if (disable_all) + ImGui::BeginDisabled(); + + if (ImGui::TreeNode("Basic")) + { + static int clicked = 0; + if (ImGui::Button("Button")) + clicked++; + if (clicked & 1) + { + ImGui::SameLine(); + ImGui::Text("Thanks for clicking me!"); + } + + static bool check = true; + ImGui::Checkbox("checkbox", &check); + + static int e = 0; + ImGui::RadioButton("radio a", &e, 0); ImGui::SameLine(); + ImGui::RadioButton("radio b", &e, 1); ImGui::SameLine(); + ImGui::RadioButton("radio c", &e, 2); + + // Color buttons, demonstrate using PushID() to add unique identifier in the ID stack, and changing style. + for (int i = 0; i < 7; i++) + { + if (i > 0) + ImGui::SameLine(); + ImGui::PushID(i); + ImGui::PushStyleColor(ImGuiCol_Button, (ImVec4)ImColor::HSV(i / 7.0f, 0.6f, 0.6f)); + ImGui::PushStyleColor(ImGuiCol_ButtonHovered, (ImVec4)ImColor::HSV(i / 7.0f, 0.7f, 0.7f)); + ImGui::PushStyleColor(ImGuiCol_ButtonActive, (ImVec4)ImColor::HSV(i / 7.0f, 0.8f, 0.8f)); + ImGui::Button("Click"); + ImGui::PopStyleColor(3); + ImGui::PopID(); + } + + // Use AlignTextToFramePadding() to align text baseline to the baseline of framed widgets elements + // (otherwise a Text+SameLine+Button sequence will have the text a little too high by default!) + // See 'Demo->Layout->Text Baseline Alignment' for details. + ImGui::AlignTextToFramePadding(); + ImGui::Text("Hold to repeat:"); + ImGui::SameLine(); + + // Arrow buttons with Repeater + static int counter = 0; + float spacing = ImGui::GetStyle().ItemInnerSpacing.x; + ImGui::PushButtonRepeat(true); + if (ImGui::ArrowButton("##left", ImGuiDir_Left)) { counter--; } + ImGui::SameLine(0.0f, spacing); + if (ImGui::ArrowButton("##right", ImGuiDir_Right)) { counter++; } + ImGui::PopButtonRepeat(); + ImGui::SameLine(); + ImGui::Text("%d", counter); + + ImGui::Text("Hover over me"); + if (ImGui::IsItemHovered()) + ImGui::SetTooltip("I am a tooltip"); + + ImGui::SameLine(); + ImGui::Text("- or me"); + if (ImGui::IsItemHovered()) + { + ImGui::BeginTooltip(); + ImGui::Text("I am a fancy tooltip"); + static float arr[] = { 0.6f, 0.1f, 1.0f, 0.5f, 0.92f, 0.1f, 0.2f }; + ImGui::PlotLines("Curve", arr, IM_ARRAYSIZE(arr)); + ImGui::EndTooltip(); + } + + ImGui::Separator(); + + ImGui::LabelText("label", "Value"); + + { + // Using the _simplified_ one-liner Combo() api here + // See "Combo" section for examples of how to use the more flexible BeginCombo()/EndCombo() api. + const char* items[] = { "AAAA", "BBBB", "CCCC", "DDDD", "EEEE", "FFFF", "GGGG", "HHHH", "IIIIIII", "JJJJ", "KKKKKKK" }; + static int item_current = 0; + ImGui::Combo("combo", &item_current, items, IM_ARRAYSIZE(items)); + ImGui::SameLine(); HelpMarker( + "Using the simplified one-liner Combo API here.\nRefer to the \"Combo\" section below for an explanation of how to use the more flexible and general BeginCombo/EndCombo API."); + } + + { + // To wire InputText() with std::string or any other custom string type, + // see the "Text Input > Resize Callback" section of this demo, and the misc/cpp/imgui_stdlib.h file. + static char str0[128] = "Hello, world!"; + ImGui::InputText("input text", str0, IM_ARRAYSIZE(str0)); + ImGui::SameLine(); HelpMarker( + "USER:\n" + "Hold SHIFT or use mouse to select text.\n" + "CTRL+Left/Right to word jump.\n" + "CTRL+A or double-click to select all.\n" + "CTRL+X,CTRL+C,CTRL+V clipboard.\n" + "CTRL+Z,CTRL+Y undo/redo.\n" + "ESCAPE to revert.\n\n" + "PROGRAMMER:\n" + "You can use the ImGuiInputTextFlags_CallbackResize facility if you need to wire InputText() " + "to a dynamic string type. See misc/cpp/imgui_stdlib.h for an example (this is not demonstrated " + "in imgui_demo.cpp)."); + + static char str1[128] = ""; + ImGui::InputTextWithHint("input text (w/ hint)", "enter text here", str1, IM_ARRAYSIZE(str1)); + + static int i0 = 123; + ImGui::InputInt("input int", &i0); + ImGui::SameLine(); HelpMarker( + "You can apply arithmetic operators +,*,/ on numerical values.\n" + " e.g. [ 100 ], input \'*2\', result becomes [ 200 ]\n" + "Use +- to subtract."); + + static float f0 = 0.001f; + ImGui::InputFloat("input float", &f0, 0.01f, 1.0f, "%.3f"); + + static double d0 = 999999.00000001; + ImGui::InputDouble("input double", &d0, 0.01f, 1.0f, "%.8f"); + + static float f1 = 1.e10f; + ImGui::InputFloat("input scientific", &f1, 0.0f, 0.0f, "%e"); + ImGui::SameLine(); HelpMarker( + "You can input value using the scientific notation,\n" + " e.g. \"1e+8\" becomes \"100000000\"."); + + static float vec4a[4] = { 0.10f, 0.20f, 0.30f, 0.44f }; + ImGui::InputFloat3("input float3", vec4a); + } + + { + static int i1 = 50, i2 = 42; + ImGui::DragInt("drag int", &i1, 1); + ImGui::SameLine(); HelpMarker( + "Click and drag to edit value.\n" + "Hold SHIFT/ALT for faster/slower edit.\n" + "Double-click or CTRL+click to input value."); + + ImGui::DragInt("drag int 0..100", &i2, 1, 0, 100, "%d%%", ImGuiSliderFlags_AlwaysClamp); + + static float f1 = 1.00f, f2 = 0.0067f; + ImGui::DragFloat("drag float", &f1, 0.005f); + ImGui::DragFloat("drag small float", &f2, 0.0001f, 0.0f, 0.0f, "%.06f ns"); + } + + { + static int i1 = 0; + ImGui::SliderInt("slider int", &i1, -1, 3); + ImGui::SameLine(); HelpMarker("CTRL+click to input value."); + + static float f1 = 0.123f, f2 = 0.0f; + ImGui::SliderFloat("slider float", &f1, 0.0f, 1.0f, "ratio = %.3f"); + ImGui::SliderFloat("slider float (log)", &f2, -10.0f, 10.0f, "%.4f", ImGuiSliderFlags_Logarithmic); + + static float angle = 0.0f; + ImGui::SliderAngle("slider angle", &angle); + + // Using the format string to display a name instead of an integer. + // Here we completely omit '%d' from the format string, so it'll only display a name. + // This technique can also be used with DragInt(). + enum Element { Element_Fire, Element_Earth, Element_Air, Element_Water, Element_COUNT }; + static int elem = Element_Fire; + const char* elems_names[Element_COUNT] = { "Fire", "Earth", "Air", "Water" }; + const char* elem_name = (elem >= 0 && elem < Element_COUNT) ? elems_names[elem] : "Unknown"; + ImGui::SliderInt("slider enum", &elem, 0, Element_COUNT - 1, elem_name); + ImGui::SameLine(); HelpMarker("Using the format string parameter to display a name instead of the underlying integer."); + } + + { + static float col1[3] = { 1.0f, 0.0f, 0.2f }; + static float col2[4] = { 0.4f, 0.7f, 0.0f, 0.5f }; + ImGui::ColorEdit3("color 1", col1); + ImGui::SameLine(); HelpMarker( + "Click on the color square to open a color picker.\n" + "Click and hold to use drag and drop.\n" + "Right-click on the color square to show options.\n" + "CTRL+click on individual component to input value.\n"); + + ImGui::ColorEdit4("color 2", col2); + } + + { + // Using the _simplified_ one-liner ListBox() api here + // See "List boxes" section for examples of how to use the more flexible BeginListBox()/EndListBox() api. + const char* items[] = { "Apple", "Banana", "Cherry", "Kiwi", "Mango", "Orange", "Pineapple", "Strawberry", "Watermelon" }; + static int item_current = 1; + ImGui::ListBox("listbox", &item_current, items, IM_ARRAYSIZE(items), 4); + ImGui::SameLine(); HelpMarker( + "Using the simplified one-liner ListBox API here.\nRefer to the \"List boxes\" section below for an explanation of how to use the more flexible and general BeginListBox/EndListBox API."); + } + + ImGui::TreePop(); + } + + // Testing ImGuiOnceUponAFrame helper. + //static ImGuiOnceUponAFrame once; + //for (int i = 0; i < 5; i++) + // if (once) + // ImGui::Text("This will be displayed only once."); + + if (ImGui::TreeNode("Trees")) + { + if (ImGui::TreeNode("Basic trees")) + { + for (int i = 0; i < 5; i++) + { + // Use SetNextItemOpen() so set the default state of a node to be open. We could + // also use TreeNodeEx() with the ImGuiTreeNodeFlags_DefaultOpen flag to achieve the same thing! + if (i == 0) + ImGui::SetNextItemOpen(true, ImGuiCond_Once); + + if (ImGui::TreeNode((void*)(intptr_t)i, "Child %d", i)) + { + ImGui::Text("blah blah"); + ImGui::SameLine(); + if (ImGui::SmallButton("button")) {} + ImGui::TreePop(); + } + } + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Advanced, with Selectable nodes")) + { + HelpMarker( + "This is a more typical looking tree with selectable nodes.\n" + "Click to select, CTRL+Click to toggle, click on arrows or double-click to open."); + static ImGuiTreeNodeFlags base_flags = ImGuiTreeNodeFlags_OpenOnArrow | ImGuiTreeNodeFlags_OpenOnDoubleClick | ImGuiTreeNodeFlags_SpanAvailWidth; + static bool align_label_with_current_x_position = false; + static bool test_drag_and_drop = false; + ImGui::CheckboxFlags("ImGuiTreeNodeFlags_OpenOnArrow", &base_flags, ImGuiTreeNodeFlags_OpenOnArrow); + ImGui::CheckboxFlags("ImGuiTreeNodeFlags_OpenOnDoubleClick", &base_flags, ImGuiTreeNodeFlags_OpenOnDoubleClick); + ImGui::CheckboxFlags("ImGuiTreeNodeFlags_SpanAvailWidth", &base_flags, ImGuiTreeNodeFlags_SpanAvailWidth); ImGui::SameLine(); HelpMarker("Extend hit area to all available width instead of allowing more items to be laid out after the node."); + ImGui::CheckboxFlags("ImGuiTreeNodeFlags_SpanFullWidth", &base_flags, ImGuiTreeNodeFlags_SpanFullWidth); + ImGui::Checkbox("Align label with current X position", &align_label_with_current_x_position); + ImGui::Checkbox("Test tree node as drag source", &test_drag_and_drop); + ImGui::Text("Hello!"); + if (align_label_with_current_x_position) + ImGui::Unindent(ImGui::GetTreeNodeToLabelSpacing()); + + // 'selection_mask' is dumb representation of what may be user-side selection state. + // You may retain selection state inside or outside your objects in whatever format you see fit. + // 'node_clicked' is temporary storage of what node we have clicked to process selection at the end + /// of the loop. May be a pointer to your own node type, etc. + static int selection_mask = (1 << 2); + int node_clicked = -1; + for (int i = 0; i < 6; i++) + { + // Disable the default "open on single-click behavior" + set Selected flag according to our selection. + ImGuiTreeNodeFlags node_flags = base_flags; + const bool is_selected = (selection_mask & (1 << i)) != 0; + if (is_selected) + node_flags |= ImGuiTreeNodeFlags_Selected; + if (i < 3) + { + // Items 0..2 are Tree Node + bool node_open = ImGui::TreeNodeEx((void*)(intptr_t)i, node_flags, "Selectable Node %d", i); + if (ImGui::IsItemClicked()) + node_clicked = i; + if (test_drag_and_drop && ImGui::BeginDragDropSource()) + { + ImGui::SetDragDropPayload("_TREENODE", NULL, 0); + ImGui::Text("This is a drag and drop source"); + ImGui::EndDragDropSource(); + } + if (node_open) + { + ImGui::BulletText("Blah blah\nBlah Blah"); + ImGui::TreePop(); + } + } + else + { + // Items 3..5 are Tree Leaves + // The only reason we use TreeNode at all is to allow selection of the leaf. Otherwise we can + // use BulletText() or advance the cursor by GetTreeNodeToLabelSpacing() and call Text(). + node_flags |= ImGuiTreeNodeFlags_Leaf | ImGuiTreeNodeFlags_NoTreePushOnOpen; // ImGuiTreeNodeFlags_Bullet + ImGui::TreeNodeEx((void*)(intptr_t)i, node_flags, "Selectable Leaf %d", i); + if (ImGui::IsItemClicked()) + node_clicked = i; + if (test_drag_and_drop && ImGui::BeginDragDropSource()) + { + ImGui::SetDragDropPayload("_TREENODE", NULL, 0); + ImGui::Text("This is a drag and drop source"); + ImGui::EndDragDropSource(); + } + } + } + if (node_clicked != -1) + { + // Update selection state + // (process outside of tree loop to avoid visual inconsistencies during the clicking frame) + if (ImGui::GetIO().KeyCtrl) + selection_mask ^= (1 << node_clicked); // CTRL+click to toggle + else //if (!(selection_mask & (1 << node_clicked))) // Depending on selection behavior you want, may want to preserve selection when clicking on item that is part of the selection + selection_mask = (1 << node_clicked); // Click to single-select + } + if (align_label_with_current_x_position) + ImGui::Indent(ImGui::GetTreeNodeToLabelSpacing()); + ImGui::TreePop(); + } + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Collapsing Headers")) + { + static bool closable_group = true; + ImGui::Checkbox("Show 2nd header", &closable_group); + if (ImGui::CollapsingHeader("Header", ImGuiTreeNodeFlags_None)) + { + ImGui::Text("IsItemHovered: %d", ImGui::IsItemHovered()); + for (int i = 0; i < 5; i++) + ImGui::Text("Some content %d", i); + } + if (ImGui::CollapsingHeader("Header with a close button", &closable_group)) + { + ImGui::Text("IsItemHovered: %d", ImGui::IsItemHovered()); + for (int i = 0; i < 5; i++) + ImGui::Text("More content %d", i); + } + /* + if (ImGui::CollapsingHeader("Header with a bullet", ImGuiTreeNodeFlags_Bullet)) + ImGui::Text("IsItemHovered: %d", ImGui::IsItemHovered()); + */ + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Bullets")) + { + ImGui::BulletText("Bullet point 1"); + ImGui::BulletText("Bullet point 2\nOn multiple lines"); + if (ImGui::TreeNode("Tree node")) + { + ImGui::BulletText("Another bullet point"); + ImGui::TreePop(); + } + ImGui::Bullet(); ImGui::Text("Bullet point 3 (two calls)"); + ImGui::Bullet(); ImGui::SmallButton("Button"); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Text")) + { + if (ImGui::TreeNode("Colorful Text")) + { + // Using shortcut. You can use PushStyleColor()/PopStyleColor() for more flexibility. + ImGui::TextColored(ImVec4(1.0f, 0.0f, 1.0f, 1.0f), "Pink"); + ImGui::TextColored(ImVec4(1.0f, 1.0f, 0.0f, 1.0f), "Yellow"); + ImGui::TextDisabled("Disabled"); + ImGui::SameLine(); HelpMarker("The TextDisabled color is stored in ImGuiStyle."); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Word Wrapping")) + { + // Using shortcut. You can use PushTextWrapPos()/PopTextWrapPos() for more flexibility. + ImGui::TextWrapped( + "This text should automatically wrap on the edge of the window. The current implementation " + "for text wrapping follows simple rules suitable for English and possibly other languages."); + ImGui::Spacing(); + + static float wrap_width = 200.0f; + ImGui::SliderFloat("Wrap width", &wrap_width, -20, 600, "%.0f"); + + ImDrawList* draw_list = ImGui::GetWindowDrawList(); + for (int n = 0; n < 2; n++) + { + ImGui::Text("Test paragraph %d:", n); + ImVec2 pos = ImGui::GetCursorScreenPos(); + ImVec2 marker_min = ImVec2(pos.x + wrap_width, pos.y); + ImVec2 marker_max = ImVec2(pos.x + wrap_width + 10, pos.y + ImGui::GetTextLineHeight()); + ImGui::PushTextWrapPos(ImGui::GetCursorPos().x + wrap_width); + if (n == 0) + ImGui::Text("The lazy dog is a good dog. This paragraph should fit within %.0f pixels. Testing a 1 character word. The quick brown fox jumps over the lazy dog.", wrap_width); + else + ImGui::Text("aaaaaaaa bbbbbbbb, c cccccccc,dddddddd. d eeeeeeee ffffffff. gggggggg!hhhhhhhh"); + + // Draw actual text bounding box, following by marker of our expected limit (should not overlap!) + draw_list->AddRect(ImGui::GetItemRectMin(), ImGui::GetItemRectMax(), IM_COL32(255, 255, 0, 255)); + draw_list->AddRectFilled(marker_min, marker_max, IM_COL32(255, 0, 255, 255)); + ImGui::PopTextWrapPos(); + } + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("UTF-8 Text")) + { + // UTF-8 test with Japanese characters + // (Needs a suitable font? Try "Google Noto" or "Arial Unicode". See docs/FONTS.md for details.) + // - From C++11 you can use the u8"my text" syntax to encode literal strings as UTF-8 + // - For earlier compiler, you may be able to encode your sources as UTF-8 (e.g. in Visual Studio, you + // can save your source files as 'UTF-8 without signature'). + // - FOR THIS DEMO FILE ONLY, BECAUSE WE WANT TO SUPPORT OLD COMPILERS, WE ARE *NOT* INCLUDING RAW UTF-8 + // CHARACTERS IN THIS SOURCE FILE. Instead we are encoding a few strings with hexadecimal constants. + // Don't do this in your application! Please use u8"text in any language" in your application! + // Note that characters values are preserved even by InputText() if the font cannot be displayed, + // so you can safely copy & paste garbled characters into another application. + ImGui::TextWrapped( + "CJK text will only appears if the font was loaded with the appropriate CJK character ranges. " + "Call io.Fonts->AddFontFromFileTTF() manually to load extra character ranges. " + "Read docs/FONTS.md for details."); + ImGui::Text("Hiragana: \xe3\x81\x8b\xe3\x81\x8d\xe3\x81\x8f\xe3\x81\x91\xe3\x81\x93 (kakikukeko)"); // Normally we would use u8"blah blah" with the proper characters directly in the string. + ImGui::Text("Kanjis: \xe6\x97\xa5\xe6\x9c\xac\xe8\xaa\x9e (nihongo)"); + static char buf[32] = "\xe6\x97\xa5\xe6\x9c\xac\xe8\xaa\x9e"; + //static char buf[32] = u8"NIHONGO"; // <- this is how you would write it with C++11, using real kanjis + ImGui::InputText("UTF-8 input", buf, IM_ARRAYSIZE(buf)); + ImGui::TreePop(); + } + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Images")) + { + ImGuiIO& io = ImGui::GetIO(); + ImGui::TextWrapped( + "Below we are displaying the font texture (which is the only texture we have access to in this demo). " + "Use the 'ImTextureID' type as storage to pass pointers or identifier to your own texture data. " + "Hover the texture for a zoomed view!"); + + // Below we are displaying the font texture because it is the only texture we have access to inside the demo! + // Remember that ImTextureID is just storage for whatever you want it to be. It is essentially a value that + // will be passed to the rendering backend via the ImDrawCmd structure. + // If you use one of the default imgui_impl_XXXX.cpp rendering backend, they all have comments at the top + // of their respective source file to specify what they expect to be stored in ImTextureID, for example: + // - The imgui_impl_dx11.cpp renderer expect a 'ID3D11ShaderResourceView*' pointer + // - The imgui_impl_opengl3.cpp renderer expect a GLuint OpenGL texture identifier, etc. + // More: + // - If you decided that ImTextureID = MyEngineTexture*, then you can pass your MyEngineTexture* pointers + // to ImGui::Image(), and gather width/height through your own functions, etc. + // - You can use ShowMetricsWindow() to inspect the draw data that are being passed to your renderer, + // it will help you debug issues if you are confused about it. + // - Consider using the lower-level ImDrawList::AddImage() API, via ImGui::GetWindowDrawList()->AddImage(). + // - Read https://github.com/ocornut/imgui/blob/master/docs/FAQ.md + // - Read https://github.com/ocornut/imgui/wiki/Image-Loading-and-Displaying-Examples + ImTextureID my_tex_id = io.Fonts->TexID; + float my_tex_w = (float)io.Fonts->TexWidth; + float my_tex_h = (float)io.Fonts->TexHeight; + { + ImGui::Text("%.0fx%.0f", my_tex_w, my_tex_h); + ImVec2 pos = ImGui::GetCursorScreenPos(); + ImVec2 uv_min = ImVec2(0.0f, 0.0f); // Top-left + ImVec2 uv_max = ImVec2(1.0f, 1.0f); // Lower-right + ImVec4 tint_col = ImVec4(1.0f, 1.0f, 1.0f, 1.0f); // No tint + ImVec4 border_col = ImVec4(1.0f, 1.0f, 1.0f, 0.5f); // 50% opaque white + ImGui::Image(my_tex_id, ImVec2(my_tex_w, my_tex_h), uv_min, uv_max, tint_col, border_col); + if (ImGui::IsItemHovered()) + { + ImGui::BeginTooltip(); + float region_sz = 32.0f; + float region_x = io.MousePos.x - pos.x - region_sz * 0.5f; + float region_y = io.MousePos.y - pos.y - region_sz * 0.5f; + float zoom = 4.0f; + if (region_x < 0.0f) { region_x = 0.0f; } + else if (region_x > my_tex_w - region_sz) { region_x = my_tex_w - region_sz; } + if (region_y < 0.0f) { region_y = 0.0f; } + else if (region_y > my_tex_h - region_sz) { region_y = my_tex_h - region_sz; } + ImGui::Text("Min: (%.2f, %.2f)", region_x, region_y); + ImGui::Text("Max: (%.2f, %.2f)", region_x + region_sz, region_y + region_sz); + ImVec2 uv0 = ImVec2((region_x) / my_tex_w, (region_y) / my_tex_h); + ImVec2 uv1 = ImVec2((region_x + region_sz) / my_tex_w, (region_y + region_sz) / my_tex_h); + ImGui::Image(my_tex_id, ImVec2(region_sz * zoom, region_sz * zoom), uv0, uv1, tint_col, border_col); + ImGui::EndTooltip(); + } + } + ImGui::TextWrapped("And now some textured buttons.."); + static int pressed_count = 0; + for (int i = 0; i < 8; i++) + { + ImGui::PushID(i); + int frame_padding = -1 + i; // -1 == uses default padding (style.FramePadding) + ImVec2 size = ImVec2(32.0f, 32.0f); // Size of the image we want to make visible + ImVec2 uv0 = ImVec2(0.0f, 0.0f); // UV coordinates for lower-left + ImVec2 uv1 = ImVec2(32.0f / my_tex_w, 32.0f / my_tex_h);// UV coordinates for (32,32) in our texture + ImVec4 bg_col = ImVec4(0.0f, 0.0f, 0.0f, 1.0f); // Black background + ImVec4 tint_col = ImVec4(1.0f, 1.0f, 1.0f, 1.0f); // No tint + if (ImGui::ImageButton(my_tex_id, size, uv0, uv1, frame_padding, bg_col, tint_col)) + pressed_count += 1; + ImGui::PopID(); + ImGui::SameLine(); + } + ImGui::NewLine(); + ImGui::Text("Pressed %d times.", pressed_count); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Combo")) + { + // Expose flags as checkbox for the demo + static ImGuiComboFlags flags = 0; + ImGui::CheckboxFlags("ImGuiComboFlags_PopupAlignLeft", &flags, ImGuiComboFlags_PopupAlignLeft); + ImGui::SameLine(); HelpMarker("Only makes a difference if the popup is larger than the combo"); + if (ImGui::CheckboxFlags("ImGuiComboFlags_NoArrowButton", &flags, ImGuiComboFlags_NoArrowButton)) + flags &= ~ImGuiComboFlags_NoPreview; // Clear the other flag, as we cannot combine both + if (ImGui::CheckboxFlags("ImGuiComboFlags_NoPreview", &flags, ImGuiComboFlags_NoPreview)) + flags &= ~ImGuiComboFlags_NoArrowButton; // Clear the other flag, as we cannot combine both + + // Using the generic BeginCombo() API, you have full control over how to display the combo contents. + // (your selection data could be an index, a pointer to the object, an id for the object, a flag intrusively + // stored in the object itself, etc.) + const char* items[] = { "AAAA", "BBBB", "CCCC", "DDDD", "EEEE", "FFFF", "GGGG", "HHHH", "IIII", "JJJJ", "KKKK", "LLLLLLL", "MMMM", "OOOOOOO" }; + static int item_current_idx = 0; // Here we store our selection data as an index. + const char* combo_preview_value = items[item_current_idx]; // Pass in the preview value visible before opening the combo (it could be anything) + if (ImGui::BeginCombo("combo 1", combo_preview_value, flags)) + { + for (int n = 0; n < IM_ARRAYSIZE(items); n++) + { + const bool is_selected = (item_current_idx == n); + if (ImGui::Selectable(items[n], is_selected)) + item_current_idx = n; + + // Set the initial focus when opening the combo (scrolling + keyboard navigation focus) + if (is_selected) + ImGui::SetItemDefaultFocus(); + } + ImGui::EndCombo(); + } + + // Simplified one-liner Combo() API, using values packed in a single constant string + // This is a convenience for when the selection set is small and known at compile-time. + static int item_current_2 = 0; + ImGui::Combo("combo 2 (one-liner)", &item_current_2, "aaaa\0bbbb\0cccc\0dddd\0eeee\0\0"); + + // Simplified one-liner Combo() using an array of const char* + // This is not very useful (may obsolete): prefer using BeginCombo()/EndCombo() for full control. + static int item_current_3 = -1; // If the selection isn't within 0..count, Combo won't display a preview + ImGui::Combo("combo 3 (array)", &item_current_3, items, IM_ARRAYSIZE(items)); + + // Simplified one-liner Combo() using an accessor function + struct Funcs { static bool ItemGetter(void* data, int n, const char** out_str) { *out_str = ((const char**)data)[n]; return true; } }; + static int item_current_4 = 0; + ImGui::Combo("combo 4 (function)", &item_current_4, &Funcs::ItemGetter, items, IM_ARRAYSIZE(items)); + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("List boxes")) + { + // Using the generic BeginListBox() API, you have full control over how to display the combo contents. + // (your selection data could be an index, a pointer to the object, an id for the object, a flag intrusively + // stored in the object itself, etc.) + const char* items[] = { "AAAA", "BBBB", "CCCC", "DDDD", "EEEE", "FFFF", "GGGG", "HHHH", "IIII", "JJJJ", "KKKK", "LLLLLLL", "MMMM", "OOOOOOO" }; + static int item_current_idx = 0; // Here we store our selection data as an index. + if (ImGui::BeginListBox("listbox 1")) + { + for (int n = 0; n < IM_ARRAYSIZE(items); n++) + { + const bool is_selected = (item_current_idx == n); + if (ImGui::Selectable(items[n], is_selected)) + item_current_idx = n; + + // Set the initial focus when opening the combo (scrolling + keyboard navigation focus) + if (is_selected) + ImGui::SetItemDefaultFocus(); + } + ImGui::EndListBox(); + } + + // Custom size: use all width, 5 items tall + ImGui::Text("Full-width:"); + if (ImGui::BeginListBox("##listbox 2", ImVec2(-FLT_MIN, 5 * ImGui::GetTextLineHeightWithSpacing()))) + { + for (int n = 0; n < IM_ARRAYSIZE(items); n++) + { + const bool is_selected = (item_current_idx == n); + if (ImGui::Selectable(items[n], is_selected)) + item_current_idx = n; + + // Set the initial focus when opening the combo (scrolling + keyboard navigation focus) + if (is_selected) + ImGui::SetItemDefaultFocus(); + } + ImGui::EndListBox(); + } + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Selectables")) + { + // Selectable() has 2 overloads: + // - The one taking "bool selected" as a read-only selection information. + // When Selectable() has been clicked it returns true and you can alter selection state accordingly. + // - The one taking "bool* p_selected" as a read-write selection information (convenient in some cases) + // The earlier is more flexible, as in real application your selection may be stored in many different ways + // and not necessarily inside a bool value (e.g. in flags within objects, as an external list, etc). + if (ImGui::TreeNode("Basic")) + { + static bool selection[5] = { false, true, false, false, false }; + ImGui::Selectable("1. I am selectable", &selection[0]); + ImGui::Selectable("2. I am selectable", &selection[1]); + ImGui::Text("(I am not selectable)"); + ImGui::Selectable("4. I am selectable", &selection[3]); + if (ImGui::Selectable("5. I am double clickable", selection[4], ImGuiSelectableFlags_AllowDoubleClick)) + if (ImGui::IsMouseDoubleClicked(0)) + selection[4] = !selection[4]; + ImGui::TreePop(); + } + if (ImGui::TreeNode("Selection State: Single Selection")) + { + static int selected = -1; + for (int n = 0; n < 5; n++) + { + char buf[32]; + sprintf(buf, "Object %d", n); + if (ImGui::Selectable(buf, selected == n)) + selected = n; + } + ImGui::TreePop(); + } + if (ImGui::TreeNode("Selection State: Multiple Selection")) + { + HelpMarker("Hold CTRL and click to select multiple items."); + static bool selection[5] = { false, false, false, false, false }; + for (int n = 0; n < 5; n++) + { + char buf[32]; + sprintf(buf, "Object %d", n); + if (ImGui::Selectable(buf, selection[n])) + { + if (!ImGui::GetIO().KeyCtrl) // Clear selection when CTRL is not held + memset(selection, 0, sizeof(selection)); + selection[n] ^= 1; + } + } + ImGui::TreePop(); + } + if (ImGui::TreeNode("Rendering more text into the same line")) + { + // Using the Selectable() override that takes "bool* p_selected" parameter, + // this function toggle your bool value automatically. + static bool selected[3] = { false, false, false }; + ImGui::Selectable("main.c", &selected[0]); ImGui::SameLine(300); ImGui::Text(" 2,345 bytes"); + ImGui::Selectable("Hello.cpp", &selected[1]); ImGui::SameLine(300); ImGui::Text("12,345 bytes"); + ImGui::Selectable("Hello.h", &selected[2]); ImGui::SameLine(300); ImGui::Text(" 2,345 bytes"); + ImGui::TreePop(); + } + if (ImGui::TreeNode("In columns")) + { + static bool selected[10] = {}; + + if (ImGui::BeginTable("split1", 3, ImGuiTableFlags_Resizable | ImGuiTableFlags_NoSavedSettings | ImGuiTableFlags_Borders)) + { + for (int i = 0; i < 10; i++) + { + char label[32]; + sprintf(label, "Item %d", i); + ImGui::TableNextColumn(); + ImGui::Selectable(label, &selected[i]); // FIXME-TABLE: Selection overlap + } + ImGui::EndTable(); + } + ImGui::Spacing(); + if (ImGui::BeginTable("split2", 3, ImGuiTableFlags_Resizable | ImGuiTableFlags_NoSavedSettings | ImGuiTableFlags_Borders)) + { + for (int i = 0; i < 10; i++) + { + char label[32]; + sprintf(label, "Item %d", i); + ImGui::TableNextRow(); + ImGui::TableNextColumn(); + ImGui::Selectable(label, &selected[i], ImGuiSelectableFlags_SpanAllColumns); + ImGui::TableNextColumn(); + ImGui::Text("Some other contents"); + ImGui::TableNextColumn(); + ImGui::Text("123456"); + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + if (ImGui::TreeNode("Grid")) + { + static char selected[4][4] = { { 1, 0, 0, 0 }, { 0, 1, 0, 0 }, { 0, 0, 1, 0 }, { 0, 0, 0, 1 } }; + + // Add in a bit of silly fun... + const float time = (float)ImGui::GetTime(); + const bool winning_state = memchr(selected, 0, sizeof(selected)) == NULL; // If all cells are selected... + if (winning_state) + ImGui::PushStyleVar(ImGuiStyleVar_SelectableTextAlign, ImVec2(0.5f + 0.5f * cosf(time * 2.0f), 0.5f + 0.5f * sinf(time * 3.0f))); + + for (int y = 0; y < 4; y++) + for (int x = 0; x < 4; x++) + { + if (x > 0) + ImGui::SameLine(); + ImGui::PushID(y * 4 + x); + if (ImGui::Selectable("Sailor", selected[y][x] != 0, 0, ImVec2(50, 50))) + { + // Toggle clicked cell + toggle neighbors + selected[y][x] ^= 1; + if (x > 0) { selected[y][x - 1] ^= 1; } + if (x < 3) { selected[y][x + 1] ^= 1; } + if (y > 0) { selected[y - 1][x] ^= 1; } + if (y < 3) { selected[y + 1][x] ^= 1; } + } + ImGui::PopID(); + } + + if (winning_state) + ImGui::PopStyleVar(); + ImGui::TreePop(); + } + if (ImGui::TreeNode("Alignment")) + { + HelpMarker( + "By default, Selectables uses style.SelectableTextAlign but it can be overridden on a per-item " + "basis using PushStyleVar(). You'll probably want to always keep your default situation to " + "left-align otherwise it becomes difficult to layout multiple items on a same line"); + static bool selected[3 * 3] = { true, false, true, false, true, false, true, false, true }; + for (int y = 0; y < 3; y++) + { + for (int x = 0; x < 3; x++) + { + ImVec2 alignment = ImVec2((float)x / 2.0f, (float)y / 2.0f); + char name[32]; + sprintf(name, "(%.1f,%.1f)", alignment.x, alignment.y); + if (x > 0) ImGui::SameLine(); + ImGui::PushStyleVar(ImGuiStyleVar_SelectableTextAlign, alignment); + ImGui::Selectable(name, &selected[3 * y + x], ImGuiSelectableFlags_None, ImVec2(80, 80)); + ImGui::PopStyleVar(); + } + } + ImGui::TreePop(); + } + ImGui::TreePop(); + } + + // To wire InputText() with std::string or any other custom string type, + // see the "Text Input > Resize Callback" section of this demo, and the misc/cpp/imgui_stdlib.h file. + if (ImGui::TreeNode("Text Input")) + { + if (ImGui::TreeNode("Multi-line Text Input")) + { + // Note: we are using a fixed-sized buffer for simplicity here. See ImGuiInputTextFlags_CallbackResize + // and the code in misc/cpp/imgui_stdlib.h for how to setup InputText() for dynamically resizing strings. + static char text[1024 * 16] = + "/*\n" + " The Pentium F00F bug, shorthand for F0 0F C7 C8,\n" + " the hexadecimal encoding of one offending instruction,\n" + " more formally, the invalid operand with locked CMPXCHG8B\n" + " instruction bug, is a design flaw in the majority of\n" + " Intel Pentium, Pentium MMX, and Pentium OverDrive\n" + " processors (all in the P5 microarchitecture).\n" + "*/\n\n" + "label:\n" + "\tlock cmpxchg8b eax\n"; + + static ImGuiInputTextFlags flags = ImGuiInputTextFlags_AllowTabInput; + HelpMarker("You can use the ImGuiInputTextFlags_CallbackResize facility if you need to wire InputTextMultiline() to a dynamic string type. See misc/cpp/imgui_stdlib.h for an example. (This is not demonstrated in imgui_demo.cpp because we don't want to include in here)"); + ImGui::CheckboxFlags("ImGuiInputTextFlags_ReadOnly", &flags, ImGuiInputTextFlags_ReadOnly); + ImGui::CheckboxFlags("ImGuiInputTextFlags_AllowTabInput", &flags, ImGuiInputTextFlags_AllowTabInput); + ImGui::CheckboxFlags("ImGuiInputTextFlags_CtrlEnterForNewLine", &flags, ImGuiInputTextFlags_CtrlEnterForNewLine); + ImGui::InputTextMultiline("##source", text, IM_ARRAYSIZE(text), ImVec2(-FLT_MIN, ImGui::GetTextLineHeight() * 16), flags); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Filtered Text Input")) + { + struct TextFilters + { + // Return 0 (pass) if the character is 'i' or 'm' or 'g' or 'u' or 'i' + static int FilterImGuiLetters(ImGuiInputTextCallbackData* data) + { + if (data->EventChar < 256 && strchr("imgui", (char)data->EventChar)) + return 0; + return 1; + } + }; + + static char buf1[64] = ""; ImGui::InputText("default", buf1, 64); + static char buf2[64] = ""; ImGui::InputText("decimal", buf2, 64, ImGuiInputTextFlags_CharsDecimal); + static char buf3[64] = ""; ImGui::InputText("hexadecimal", buf3, 64, ImGuiInputTextFlags_CharsHexadecimal | ImGuiInputTextFlags_CharsUppercase); + static char buf4[64] = ""; ImGui::InputText("uppercase", buf4, 64, ImGuiInputTextFlags_CharsUppercase); + static char buf5[64] = ""; ImGui::InputText("no blank", buf5, 64, ImGuiInputTextFlags_CharsNoBlank); + static char buf6[64] = ""; ImGui::InputText("\"imgui\" letters", buf6, 64, ImGuiInputTextFlags_CallbackCharFilter, TextFilters::FilterImGuiLetters); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Password Input")) + { + static char password[64] = "password123"; + ImGui::InputText("password", password, IM_ARRAYSIZE(password), ImGuiInputTextFlags_Password); + ImGui::SameLine(); HelpMarker("Display all characters as '*'.\nDisable clipboard cut and copy.\nDisable logging.\n"); + ImGui::InputTextWithHint("password (w/ hint)", "", password, IM_ARRAYSIZE(password), ImGuiInputTextFlags_Password); + ImGui::InputText("password (clear)", password, IM_ARRAYSIZE(password)); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Completion, History, Edit Callbacks")) + { + struct Funcs + { + static int MyCallback(ImGuiInputTextCallbackData* data) + { + if (data->EventFlag == ImGuiInputTextFlags_CallbackCompletion) + { + data->InsertChars(data->CursorPos, ".."); + } + else if (data->EventFlag == ImGuiInputTextFlags_CallbackHistory) + { + if (data->EventKey == ImGuiKey_UpArrow) + { + data->DeleteChars(0, data->BufTextLen); + data->InsertChars(0, "Pressed Up!"); + data->SelectAll(); + } + else if (data->EventKey == ImGuiKey_DownArrow) + { + data->DeleteChars(0, data->BufTextLen); + data->InsertChars(0, "Pressed Down!"); + data->SelectAll(); + } + } + else if (data->EventFlag == ImGuiInputTextFlags_CallbackEdit) + { + // Toggle casing of first character + char c = data->Buf[0]; + if ((c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')) data->Buf[0] ^= 32; + data->BufDirty = true; + + // Increment a counter + int* p_int = (int*)data->UserData; + *p_int = *p_int + 1; + } + return 0; + } + }; + static char buf1[64]; + ImGui::InputText("Completion", buf1, 64, ImGuiInputTextFlags_CallbackCompletion, Funcs::MyCallback); + ImGui::SameLine(); HelpMarker("Here we append \"..\" each time Tab is pressed. See 'Examples>Console' for a more meaningful demonstration of using this callback."); + + static char buf2[64]; + ImGui::InputText("History", buf2, 64, ImGuiInputTextFlags_CallbackHistory, Funcs::MyCallback); + ImGui::SameLine(); HelpMarker("Here we replace and select text each time Up/Down are pressed. See 'Examples>Console' for a more meaningful demonstration of using this callback."); + + static char buf3[64]; + static int edit_count = 0; + ImGui::InputText("Edit", buf3, 64, ImGuiInputTextFlags_CallbackEdit, Funcs::MyCallback, (void*)&edit_count); + ImGui::SameLine(); HelpMarker("Here we toggle the casing of the first character on every edits + count edits."); + ImGui::SameLine(); ImGui::Text("(%d)", edit_count); + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Resize Callback")) + { + // To wire InputText() with std::string or any other custom string type, + // you can use the ImGuiInputTextFlags_CallbackResize flag + create a custom ImGui::InputText() wrapper + // using your preferred type. See misc/cpp/imgui_stdlib.h for an implementation of this using std::string. + HelpMarker( + "Using ImGuiInputTextFlags_CallbackResize to wire your custom string type to InputText().\n\n" + "See misc/cpp/imgui_stdlib.h for an implementation of this for std::string."); + struct Funcs + { + static int MyResizeCallback(ImGuiInputTextCallbackData* data) + { + if (data->EventFlag == ImGuiInputTextFlags_CallbackResize) + { + ImVector* my_str = (ImVector*)data->UserData; + IM_ASSERT(my_str->begin() == data->Buf); + my_str->resize(data->BufSize); // NB: On resizing calls, generally data->BufSize == data->BufTextLen + 1 + data->Buf = my_str->begin(); + } + return 0; + } + + // Note: Because ImGui:: is a namespace you would typically add your own function into the namespace. + // For example, you code may declare a function 'ImGui::InputText(const char* label, MyString* my_str)' + static bool MyInputTextMultiline(const char* label, ImVector* my_str, const ImVec2& size = ImVec2(0, 0), ImGuiInputTextFlags flags = 0) + { + IM_ASSERT((flags & ImGuiInputTextFlags_CallbackResize) == 0); + return ImGui::InputTextMultiline(label, my_str->begin(), (size_t)my_str->size(), size, flags | ImGuiInputTextFlags_CallbackResize, Funcs::MyResizeCallback, (void*)my_str); + } + }; + + // For this demo we are using ImVector as a string container. + // Note that because we need to store a terminating zero character, our size/capacity are 1 more + // than usually reported by a typical string class. + static ImVector my_str; + if (my_str.empty()) + my_str.push_back(0); + Funcs::MyInputTextMultiline("##MyStr", &my_str, ImVec2(-FLT_MIN, ImGui::GetTextLineHeight() * 16)); + ImGui::Text("Data: %p\nSize: %d\nCapacity: %d", (void*)my_str.begin(), my_str.size(), my_str.capacity()); + ImGui::TreePop(); + } + + ImGui::TreePop(); + } + + // Tabs + if (ImGui::TreeNode("Tabs")) + { + if (ImGui::TreeNode("Basic")) + { + ImGuiTabBarFlags tab_bar_flags = ImGuiTabBarFlags_None; + if (ImGui::BeginTabBar("MyTabBar", tab_bar_flags)) + { + if (ImGui::BeginTabItem("Avocado")) + { + ImGui::Text("This is the Avocado tab!\nblah blah blah blah blah"); + ImGui::EndTabItem(); + } + if (ImGui::BeginTabItem("Broccoli")) + { + ImGui::Text("This is the Broccoli tab!\nblah blah blah blah blah"); + ImGui::EndTabItem(); + } + if (ImGui::BeginTabItem("Cucumber")) + { + ImGui::Text("This is the Cucumber tab!\nblah blah blah blah blah"); + ImGui::EndTabItem(); + } + ImGui::EndTabBar(); + } + ImGui::Separator(); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Advanced & Close Button")) + { + // Expose a couple of the available flags. In most cases you may just call BeginTabBar() with no flags (0). + static ImGuiTabBarFlags tab_bar_flags = ImGuiTabBarFlags_Reorderable; + ImGui::CheckboxFlags("ImGuiTabBarFlags_Reorderable", &tab_bar_flags, ImGuiTabBarFlags_Reorderable); + ImGui::CheckboxFlags("ImGuiTabBarFlags_AutoSelectNewTabs", &tab_bar_flags, ImGuiTabBarFlags_AutoSelectNewTabs); + ImGui::CheckboxFlags("ImGuiTabBarFlags_TabListPopupButton", &tab_bar_flags, ImGuiTabBarFlags_TabListPopupButton); + ImGui::CheckboxFlags("ImGuiTabBarFlags_NoCloseWithMiddleMouseButton", &tab_bar_flags, ImGuiTabBarFlags_NoCloseWithMiddleMouseButton); + if ((tab_bar_flags & ImGuiTabBarFlags_FittingPolicyMask_) == 0) + tab_bar_flags |= ImGuiTabBarFlags_FittingPolicyDefault_; + if (ImGui::CheckboxFlags("ImGuiTabBarFlags_FittingPolicyResizeDown", &tab_bar_flags, ImGuiTabBarFlags_FittingPolicyResizeDown)) + tab_bar_flags &= ~(ImGuiTabBarFlags_FittingPolicyMask_ ^ ImGuiTabBarFlags_FittingPolicyResizeDown); + if (ImGui::CheckboxFlags("ImGuiTabBarFlags_FittingPolicyScroll", &tab_bar_flags, ImGuiTabBarFlags_FittingPolicyScroll)) + tab_bar_flags &= ~(ImGuiTabBarFlags_FittingPolicyMask_ ^ ImGuiTabBarFlags_FittingPolicyScroll); + + // Tab Bar + const char* names[4] = { "Artichoke", "Beetroot", "Celery", "Daikon" }; + static bool opened[4] = { true, true, true, true }; // Persistent user state + for (int n = 0; n < IM_ARRAYSIZE(opened); n++) + { + if (n > 0) { ImGui::SameLine(); } + ImGui::Checkbox(names[n], &opened[n]); + } + + // Passing a bool* to BeginTabItem() is similar to passing one to Begin(): + // the underlying bool will be set to false when the tab is closed. + if (ImGui::BeginTabBar("MyTabBar", tab_bar_flags)) + { + for (int n = 0; n < IM_ARRAYSIZE(opened); n++) + if (opened[n] && ImGui::BeginTabItem(names[n], &opened[n], ImGuiTabItemFlags_None)) + { + ImGui::Text("This is the %s tab!", names[n]); + if (n & 1) + ImGui::Text("I am an odd tab."); + ImGui::EndTabItem(); + } + ImGui::EndTabBar(); + } + ImGui::Separator(); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("TabItemButton & Leading/Trailing flags")) + { + static ImVector active_tabs; + static int next_tab_id = 0; + if (next_tab_id == 0) // Initialize with some default tabs + for (int i = 0; i < 3; i++) + active_tabs.push_back(next_tab_id++); + + // TabItemButton() and Leading/Trailing flags are distinct features which we will demo together. + // (It is possible to submit regular tabs with Leading/Trailing flags, or TabItemButton tabs without Leading/Trailing flags... + // but they tend to make more sense together) + static bool show_leading_button = true; + static bool show_trailing_button = true; + ImGui::Checkbox("Show Leading TabItemButton()", &show_leading_button); + ImGui::Checkbox("Show Trailing TabItemButton()", &show_trailing_button); + + // Expose some other flags which are useful to showcase how they interact with Leading/Trailing tabs + static ImGuiTabBarFlags tab_bar_flags = ImGuiTabBarFlags_AutoSelectNewTabs | ImGuiTabBarFlags_Reorderable | ImGuiTabBarFlags_FittingPolicyResizeDown; + ImGui::CheckboxFlags("ImGuiTabBarFlags_TabListPopupButton", &tab_bar_flags, ImGuiTabBarFlags_TabListPopupButton); + if (ImGui::CheckboxFlags("ImGuiTabBarFlags_FittingPolicyResizeDown", &tab_bar_flags, ImGuiTabBarFlags_FittingPolicyResizeDown)) + tab_bar_flags &= ~(ImGuiTabBarFlags_FittingPolicyMask_ ^ ImGuiTabBarFlags_FittingPolicyResizeDown); + if (ImGui::CheckboxFlags("ImGuiTabBarFlags_FittingPolicyScroll", &tab_bar_flags, ImGuiTabBarFlags_FittingPolicyScroll)) + tab_bar_flags &= ~(ImGuiTabBarFlags_FittingPolicyMask_ ^ ImGuiTabBarFlags_FittingPolicyScroll); + + if (ImGui::BeginTabBar("MyTabBar", tab_bar_flags)) + { + // Demo a Leading TabItemButton(): click the "?" button to open a menu + if (show_leading_button) + if (ImGui::TabItemButton("?", ImGuiTabItemFlags_Leading | ImGuiTabItemFlags_NoTooltip)) + ImGui::OpenPopup("MyHelpMenu"); + if (ImGui::BeginPopup("MyHelpMenu")) + { + ImGui::Selectable("Hello!"); + ImGui::EndPopup(); + } + + // Demo Trailing Tabs: click the "+" button to add a new tab (in your app you may want to use a font icon instead of the "+") + // Note that we submit it before the regular tabs, but because of the ImGuiTabItemFlags_Trailing flag it will always appear at the end. + if (show_trailing_button) + if (ImGui::TabItemButton("+", ImGuiTabItemFlags_Trailing | ImGuiTabItemFlags_NoTooltip)) + active_tabs.push_back(next_tab_id++); // Add new tab + + // Submit our regular tabs + for (int n = 0; n < active_tabs.Size; ) + { + bool open = true; + char name[16]; + snprintf(name, IM_ARRAYSIZE(name), "%04d", active_tabs[n]); + if (ImGui::BeginTabItem(name, &open, ImGuiTabItemFlags_None)) + { + ImGui::Text("This is the %s tab!", name); + ImGui::EndTabItem(); + } + + if (!open) + active_tabs.erase(active_tabs.Data + n); + else + n++; + } + + ImGui::EndTabBar(); + } + ImGui::Separator(); + ImGui::TreePop(); + } + ImGui::TreePop(); + } + + // Plot/Graph widgets are not very good. + // Consider using a third-party library such as ImPlot: https://github.com/epezent/implot + // (see others https://github.com/ocornut/imgui/wiki/Useful-Extensions) + if (ImGui::TreeNode("Plots Widgets")) + { + static bool animate = true; + ImGui::Checkbox("Animate", &animate); + + // Plot as lines and plot as histogram + static float arr[] = { 0.6f, 0.1f, 1.0f, 0.5f, 0.92f, 0.1f, 0.2f }; + ImGui::PlotLines("Frame Times", arr, IM_ARRAYSIZE(arr)); + ImGui::PlotHistogram("Histogram", arr, IM_ARRAYSIZE(arr), 0, NULL, 0.0f, 1.0f, ImVec2(0, 80.0f)); + + // Fill an array of contiguous float values to plot + // Tip: If your float aren't contiguous but part of a structure, you can pass a pointer to your first float + // and the sizeof() of your structure in the "stride" parameter. + static float values[90] = {}; + static int values_offset = 0; + static double refresh_time = 0.0; + if (!animate || refresh_time == 0.0) + refresh_time = ImGui::GetTime(); + while (refresh_time < ImGui::GetTime()) // Create data at fixed 60 Hz rate for the demo + { + static float phase = 0.0f; + values[values_offset] = cosf(phase); + values_offset = (values_offset + 1) % IM_ARRAYSIZE(values); + phase += 0.10f * values_offset; + refresh_time += 1.0f / 60.0f; + } + + // Plots can display overlay texts + // (in this example, we will display an average value) + { + float average = 0.0f; + for (int n = 0; n < IM_ARRAYSIZE(values); n++) + average += values[n]; + average /= (float)IM_ARRAYSIZE(values); + char overlay[32]; + sprintf(overlay, "avg %f", average); + ImGui::PlotLines("Lines", values, IM_ARRAYSIZE(values), values_offset, overlay, -1.0f, 1.0f, ImVec2(0, 80.0f)); + } + + // Use functions to generate output + // FIXME: This is rather awkward because current plot API only pass in indices. + // We probably want an API passing floats and user provide sample rate/count. + struct Funcs + { + static float Sin(void*, int i) { return sinf(i * 0.1f); } + static float Saw(void*, int i) { return (i & 1) ? 1.0f : -1.0f; } + }; + static int func_type = 0, display_count = 70; + ImGui::Separator(); + ImGui::SetNextItemWidth(ImGui::GetFontSize() * 8); + ImGui::Combo("func", &func_type, "Sin\0Saw\0"); + ImGui::SameLine(); + ImGui::SliderInt("Sample count", &display_count, 1, 400); + float (*func)(void*, int) = (func_type == 0) ? Funcs::Sin : Funcs::Saw; + ImGui::PlotLines("Lines", func, NULL, display_count, 0, NULL, -1.0f, 1.0f, ImVec2(0, 80)); + ImGui::PlotHistogram("Histogram", func, NULL, display_count, 0, NULL, -1.0f, 1.0f, ImVec2(0, 80)); + ImGui::Separator(); + + // Animate a simple progress bar + static float progress = 0.0f, progress_dir = 1.0f; + if (animate) + { + progress += progress_dir * 0.4f * ImGui::GetIO().DeltaTime; + if (progress >= +1.1f) { progress = +1.1f; progress_dir *= -1.0f; } + if (progress <= -0.1f) { progress = -0.1f; progress_dir *= -1.0f; } + } + + // Typically we would use ImVec2(-1.0f,0.0f) or ImVec2(-FLT_MIN,0.0f) to use all available width, + // or ImVec2(width,0.0f) for a specified width. ImVec2(0.0f,0.0f) uses ItemWidth. + ImGui::ProgressBar(progress, ImVec2(0.0f, 0.0f)); + ImGui::SameLine(0.0f, ImGui::GetStyle().ItemInnerSpacing.x); + ImGui::Text("Progress Bar"); + + float progress_saturated = IM_CLAMP(progress, 0.0f, 1.0f); + char buf[32]; + sprintf(buf, "%d/%d", (int)(progress_saturated * 1753), 1753); + ImGui::ProgressBar(progress, ImVec2(0.f, 0.f), buf); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Color/Picker Widgets")) + { + static ImVec4 color = ImVec4(114.0f / 255.0f, 144.0f / 255.0f, 154.0f / 255.0f, 200.0f / 255.0f); + + static bool alpha_preview = true; + static bool alpha_half_preview = false; + static bool drag_and_drop = true; + static bool options_menu = true; + static bool hdr = false; + ImGui::Checkbox("With Alpha Preview", &alpha_preview); + ImGui::Checkbox("With Half Alpha Preview", &alpha_half_preview); + ImGui::Checkbox("With Drag and Drop", &drag_and_drop); + ImGui::Checkbox("With Options Menu", &options_menu); ImGui::SameLine(); HelpMarker("Right-click on the individual color widget to show options."); + ImGui::Checkbox("With HDR", &hdr); ImGui::SameLine(); HelpMarker("Currently all this does is to lift the 0..1 limits on dragging widgets."); + ImGuiColorEditFlags misc_flags = (hdr ? ImGuiColorEditFlags_HDR : 0) | (drag_and_drop ? 0 : ImGuiColorEditFlags_NoDragDrop) | (alpha_half_preview ? ImGuiColorEditFlags_AlphaPreviewHalf : (alpha_preview ? ImGuiColorEditFlags_AlphaPreview : 0)) | (options_menu ? 0 : ImGuiColorEditFlags_NoOptions); + + ImGui::Text("Color widget:"); + ImGui::SameLine(); HelpMarker( + "Click on the color square to open a color picker.\n" + "CTRL+click on individual component to input value.\n"); + ImGui::ColorEdit3("MyColor##1", (float*)&color, misc_flags); + + ImGui::Text("Color widget HSV with Alpha:"); + ImGui::ColorEdit4("MyColor##2", (float*)&color, ImGuiColorEditFlags_DisplayHSV | misc_flags); + + ImGui::Text("Color widget with Float Display:"); + ImGui::ColorEdit4("MyColor##2f", (float*)&color, ImGuiColorEditFlags_Float | misc_flags); + + ImGui::Text("Color button with Picker:"); + ImGui::SameLine(); HelpMarker( + "With the ImGuiColorEditFlags_NoInputs flag you can hide all the slider/text inputs.\n" + "With the ImGuiColorEditFlags_NoLabel flag you can pass a non-empty label which will only " + "be used for the tooltip and picker popup."); + ImGui::ColorEdit4("MyColor##3", (float*)&color, ImGuiColorEditFlags_NoInputs | ImGuiColorEditFlags_NoLabel | misc_flags); + + ImGui::Text("Color button with Custom Picker Popup:"); + + // Generate a default palette. The palette will persist and can be edited. + static bool saved_palette_init = true; + static ImVec4 saved_palette[32] = {}; + if (saved_palette_init) + { + for (int n = 0; n < IM_ARRAYSIZE(saved_palette); n++) + { + ImGui::ColorConvertHSVtoRGB(n / 31.0f, 0.8f, 0.8f, + saved_palette[n].x, saved_palette[n].y, saved_palette[n].z); + saved_palette[n].w = 1.0f; // Alpha + } + saved_palette_init = false; + } + + static ImVec4 backup_color; + bool open_popup = ImGui::ColorButton("MyColor##3b", color, misc_flags); + ImGui::SameLine(0, ImGui::GetStyle().ItemInnerSpacing.x); + open_popup |= ImGui::Button("Palette"); + if (open_popup) + { + ImGui::OpenPopup("mypicker"); + backup_color = color; + } + if (ImGui::BeginPopup("mypicker")) + { + ImGui::Text("MY CUSTOM COLOR PICKER WITH AN AMAZING PALETTE!"); + ImGui::Separator(); + ImGui::ColorPicker4("##picker", (float*)&color, misc_flags | ImGuiColorEditFlags_NoSidePreview | ImGuiColorEditFlags_NoSmallPreview); + ImGui::SameLine(); + + ImGui::BeginGroup(); // Lock X position + ImGui::Text("Current"); + ImGui::ColorButton("##current", color, ImGuiColorEditFlags_NoPicker | ImGuiColorEditFlags_AlphaPreviewHalf, ImVec2(60, 40)); + ImGui::Text("Previous"); + if (ImGui::ColorButton("##previous", backup_color, ImGuiColorEditFlags_NoPicker | ImGuiColorEditFlags_AlphaPreviewHalf, ImVec2(60, 40))) + color = backup_color; + ImGui::Separator(); + ImGui::Text("Palette"); + for (int n = 0; n < IM_ARRAYSIZE(saved_palette); n++) + { + ImGui::PushID(n); + if ((n % 8) != 0) + ImGui::SameLine(0.0f, ImGui::GetStyle().ItemSpacing.y); + + ImGuiColorEditFlags palette_button_flags = ImGuiColorEditFlags_NoAlpha | ImGuiColorEditFlags_NoPicker | ImGuiColorEditFlags_NoTooltip; + if (ImGui::ColorButton("##palette", saved_palette[n], palette_button_flags, ImVec2(20, 20))) + color = ImVec4(saved_palette[n].x, saved_palette[n].y, saved_palette[n].z, color.w); // Preserve alpha! + + // Allow user to drop colors into each palette entry. Note that ColorButton() is already a + // drag source by default, unless specifying the ImGuiColorEditFlags_NoDragDrop flag. + if (ImGui::BeginDragDropTarget()) + { + if (const ImGuiPayload* payload = ImGui::AcceptDragDropPayload(IMGUI_PAYLOAD_TYPE_COLOR_3F)) + memcpy((float*)&saved_palette[n], payload->Data, sizeof(float) * 3); + if (const ImGuiPayload* payload = ImGui::AcceptDragDropPayload(IMGUI_PAYLOAD_TYPE_COLOR_4F)) + memcpy((float*)&saved_palette[n], payload->Data, sizeof(float) * 4); + ImGui::EndDragDropTarget(); + } + + ImGui::PopID(); + } + ImGui::EndGroup(); + ImGui::EndPopup(); + } + + ImGui::Text("Color button only:"); + static bool no_border = false; + ImGui::Checkbox("ImGuiColorEditFlags_NoBorder", &no_border); + ImGui::ColorButton("MyColor##3c", *(ImVec4*)&color, misc_flags | (no_border ? ImGuiColorEditFlags_NoBorder : 0), ImVec2(80, 80)); + + ImGui::Text("Color picker:"); + static bool alpha = true; + static bool alpha_bar = true; + static bool side_preview = true; + static bool ref_color = false; + static ImVec4 ref_color_v(1.0f, 0.0f, 1.0f, 0.5f); + static int display_mode = 0; + static int picker_mode = 0; + ImGui::Checkbox("With Alpha", &alpha); + ImGui::Checkbox("With Alpha Bar", &alpha_bar); + ImGui::Checkbox("With Side Preview", &side_preview); + if (side_preview) + { + ImGui::SameLine(); + ImGui::Checkbox("With Ref Color", &ref_color); + if (ref_color) + { + ImGui::SameLine(); + ImGui::ColorEdit4("##RefColor", &ref_color_v.x, ImGuiColorEditFlags_NoInputs | misc_flags); + } + } + ImGui::Combo("Display Mode", &display_mode, "Auto/Current\0None\0RGB Only\0HSV Only\0Hex Only\0"); + ImGui::SameLine(); HelpMarker( + "ColorEdit defaults to displaying RGB inputs if you don't specify a display mode, " + "but the user can change it with a right-click.\n\nColorPicker defaults to displaying RGB+HSV+Hex " + "if you don't specify a display mode.\n\nYou can change the defaults using SetColorEditOptions()."); + ImGui::Combo("Picker Mode", &picker_mode, "Auto/Current\0Hue bar + SV rect\0Hue wheel + SV triangle\0"); + ImGui::SameLine(); HelpMarker("User can right-click the picker to change mode."); + ImGuiColorEditFlags flags = misc_flags; + if (!alpha) flags |= ImGuiColorEditFlags_NoAlpha; // This is by default if you call ColorPicker3() instead of ColorPicker4() + if (alpha_bar) flags |= ImGuiColorEditFlags_AlphaBar; + if (!side_preview) flags |= ImGuiColorEditFlags_NoSidePreview; + if (picker_mode == 1) flags |= ImGuiColorEditFlags_PickerHueBar; + if (picker_mode == 2) flags |= ImGuiColorEditFlags_PickerHueWheel; + if (display_mode == 1) flags |= ImGuiColorEditFlags_NoInputs; // Disable all RGB/HSV/Hex displays + if (display_mode == 2) flags |= ImGuiColorEditFlags_DisplayRGB; // Override display mode + if (display_mode == 3) flags |= ImGuiColorEditFlags_DisplayHSV; + if (display_mode == 4) flags |= ImGuiColorEditFlags_DisplayHex; + ImGui::ColorPicker4("MyColor##4", (float*)&color, flags, ref_color ? &ref_color_v.x : NULL); + + ImGui::Text("Set defaults in code:"); + ImGui::SameLine(); HelpMarker( + "SetColorEditOptions() is designed to allow you to set boot-time default.\n" + "We don't have Push/Pop functions because you can force options on a per-widget basis if needed," + "and the user can change non-forced ones with the options menu.\nWe don't have a getter to avoid" + "encouraging you to persistently save values that aren't forward-compatible."); + if (ImGui::Button("Default: Uint8 + HSV + Hue Bar")) + ImGui::SetColorEditOptions(ImGuiColorEditFlags_Uint8 | ImGuiColorEditFlags_DisplayHSV | ImGuiColorEditFlags_PickerHueBar); + if (ImGui::Button("Default: Float + HDR + Hue Wheel")) + ImGui::SetColorEditOptions(ImGuiColorEditFlags_Float | ImGuiColorEditFlags_HDR | ImGuiColorEditFlags_PickerHueWheel); + + // HSV encoded support (to avoid RGB<>HSV round trips and singularities when S==0 or V==0) + static ImVec4 color_hsv(0.23f, 1.0f, 1.0f, 1.0f); // Stored as HSV! + ImGui::Spacing(); + ImGui::Text("HSV encoded colors"); + ImGui::SameLine(); HelpMarker( + "By default, colors are given to ColorEdit and ColorPicker in RGB, but ImGuiColorEditFlags_InputHSV" + "allows you to store colors as HSV and pass them to ColorEdit and ColorPicker as HSV. This comes with the" + "added benefit that you can manipulate hue values with the picker even when saturation or value are zero."); + ImGui::Text("Color widget with InputHSV:"); + ImGui::ColorEdit4("HSV shown as RGB##1", (float*)&color_hsv, ImGuiColorEditFlags_DisplayRGB | ImGuiColorEditFlags_InputHSV | ImGuiColorEditFlags_Float); + ImGui::ColorEdit4("HSV shown as HSV##1", (float*)&color_hsv, ImGuiColorEditFlags_DisplayHSV | ImGuiColorEditFlags_InputHSV | ImGuiColorEditFlags_Float); + ImGui::DragFloat4("Raw HSV values", (float*)&color_hsv, 0.01f, 0.0f, 1.0f); + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Drag/Slider Flags")) + { + // Demonstrate using advanced flags for DragXXX and SliderXXX functions. Note that the flags are the same! + static ImGuiSliderFlags flags = ImGuiSliderFlags_None; + ImGui::CheckboxFlags("ImGuiSliderFlags_AlwaysClamp", &flags, ImGuiSliderFlags_AlwaysClamp); + ImGui::SameLine(); HelpMarker("Always clamp value to min/max bounds (if any) when input manually with CTRL+Click."); + ImGui::CheckboxFlags("ImGuiSliderFlags_Logarithmic", &flags, ImGuiSliderFlags_Logarithmic); + ImGui::SameLine(); HelpMarker("Enable logarithmic editing (more precision for small values)."); + ImGui::CheckboxFlags("ImGuiSliderFlags_NoRoundToFormat", &flags, ImGuiSliderFlags_NoRoundToFormat); + ImGui::SameLine(); HelpMarker("Disable rounding underlying value to match precision of the format string (e.g. %.3f values are rounded to those 3 digits)."); + ImGui::CheckboxFlags("ImGuiSliderFlags_NoInput", &flags, ImGuiSliderFlags_NoInput); + ImGui::SameLine(); HelpMarker("Disable CTRL+Click or Enter key allowing to input text directly into the widget."); + + // Drags + static float drag_f = 0.5f; + static int drag_i = 50; + ImGui::Text("Underlying float value: %f", drag_f); + ImGui::DragFloat("DragFloat (0 -> 1)", &drag_f, 0.005f, 0.0f, 1.0f, "%.3f", flags); + ImGui::DragFloat("DragFloat (0 -> +inf)", &drag_f, 0.005f, 0.0f, FLT_MAX, "%.3f", flags); + ImGui::DragFloat("DragFloat (-inf -> 1)", &drag_f, 0.005f, -FLT_MAX, 1.0f, "%.3f", flags); + ImGui::DragFloat("DragFloat (-inf -> +inf)", &drag_f, 0.005f, -FLT_MAX, +FLT_MAX, "%.3f", flags); + ImGui::DragInt("DragInt (0 -> 100)", &drag_i, 0.5f, 0, 100, "%d", flags); + + // Sliders + static float slider_f = 0.5f; + static int slider_i = 50; + ImGui::Text("Underlying float value: %f", slider_f); + ImGui::SliderFloat("SliderFloat (0 -> 1)", &slider_f, 0.0f, 1.0f, "%.3f", flags); + ImGui::SliderInt("SliderInt (0 -> 100)", &slider_i, 0, 100, "%d", flags); + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Range Widgets")) + { + static float begin = 10, end = 90; + static int begin_i = 100, end_i = 1000; + ImGui::DragFloatRange2("range float", &begin, &end, 0.25f, 0.0f, 100.0f, "Min: %.1f %%", "Max: %.1f %%", ImGuiSliderFlags_AlwaysClamp); + ImGui::DragIntRange2("range int", &begin_i, &end_i, 5, 0, 1000, "Min: %d units", "Max: %d units"); + ImGui::DragIntRange2("range int (no bounds)", &begin_i, &end_i, 5, 0, 0, "Min: %d units", "Max: %d units"); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Data Types")) + { + // DragScalar/InputScalar/SliderScalar functions allow various data types + // - signed/unsigned + // - 8/16/32/64-bits + // - integer/float/double + // To avoid polluting the public API with all possible combinations, we use the ImGuiDataType enum + // to pass the type, and passing all arguments by pointer. + // This is the reason the test code below creates local variables to hold "zero" "one" etc. for each types. + // In practice, if you frequently use a given type that is not covered by the normal API entry points, + // you can wrap it yourself inside a 1 line function which can take typed argument as value instead of void*, + // and then pass their address to the generic function. For example: + // bool MySliderU64(const char *label, u64* value, u64 min = 0, u64 max = 0, const char* format = "%lld") + // { + // return SliderScalar(label, ImGuiDataType_U64, value, &min, &max, format); + // } + + // Setup limits (as helper variables so we can take their address, as explained above) + // Note: SliderScalar() functions have a maximum usable range of half the natural type maximum, hence the /2. + #ifndef LLONG_MIN + ImS64 LLONG_MIN = -9223372036854775807LL - 1; + ImS64 LLONG_MAX = 9223372036854775807LL; + ImU64 ULLONG_MAX = (2ULL * 9223372036854775807LL + 1); + #endif + const char s8_zero = 0, s8_one = 1, s8_fifty = 50, s8_min = -128, s8_max = 127; + const ImU8 u8_zero = 0, u8_one = 1, u8_fifty = 50, u8_min = 0, u8_max = 255; + const short s16_zero = 0, s16_one = 1, s16_fifty = 50, s16_min = -32768, s16_max = 32767; + const ImU16 u16_zero = 0, u16_one = 1, u16_fifty = 50, u16_min = 0, u16_max = 65535; + const ImS32 s32_zero = 0, s32_one = 1, s32_fifty = 50, s32_min = INT_MIN/2, s32_max = INT_MAX/2, s32_hi_a = INT_MAX/2 - 100, s32_hi_b = INT_MAX/2; + const ImU32 u32_zero = 0, u32_one = 1, u32_fifty = 50, u32_min = 0, u32_max = UINT_MAX/2, u32_hi_a = UINT_MAX/2 - 100, u32_hi_b = UINT_MAX/2; + const ImS64 s64_zero = 0, s64_one = 1, s64_fifty = 50, s64_min = LLONG_MIN/2, s64_max = LLONG_MAX/2, s64_hi_a = LLONG_MAX/2 - 100, s64_hi_b = LLONG_MAX/2; + const ImU64 u64_zero = 0, u64_one = 1, u64_fifty = 50, u64_min = 0, u64_max = ULLONG_MAX/2, u64_hi_a = ULLONG_MAX/2 - 100, u64_hi_b = ULLONG_MAX/2; + const float f32_zero = 0.f, f32_one = 1.f, f32_lo_a = -10000000000.0f, f32_hi_a = +10000000000.0f; + const double f64_zero = 0., f64_one = 1., f64_lo_a = -1000000000000000.0, f64_hi_a = +1000000000000000.0; + + // State + static char s8_v = 127; + static ImU8 u8_v = 255; + static short s16_v = 32767; + static ImU16 u16_v = 65535; + static ImS32 s32_v = -1; + static ImU32 u32_v = (ImU32)-1; + static ImS64 s64_v = -1; + static ImU64 u64_v = (ImU64)-1; + static float f32_v = 0.123f; + static double f64_v = 90000.01234567890123456789; + + const float drag_speed = 0.2f; + static bool drag_clamp = false; + ImGui::Text("Drags:"); + ImGui::Checkbox("Clamp integers to 0..50", &drag_clamp); + ImGui::SameLine(); HelpMarker( + "As with every widgets in dear imgui, we never modify values unless there is a user interaction.\n" + "You can override the clamping limits by using CTRL+Click to input a value."); + ImGui::DragScalar("drag s8", ImGuiDataType_S8, &s8_v, drag_speed, drag_clamp ? &s8_zero : NULL, drag_clamp ? &s8_fifty : NULL); + ImGui::DragScalar("drag u8", ImGuiDataType_U8, &u8_v, drag_speed, drag_clamp ? &u8_zero : NULL, drag_clamp ? &u8_fifty : NULL, "%u ms"); + ImGui::DragScalar("drag s16", ImGuiDataType_S16, &s16_v, drag_speed, drag_clamp ? &s16_zero : NULL, drag_clamp ? &s16_fifty : NULL); + ImGui::DragScalar("drag u16", ImGuiDataType_U16, &u16_v, drag_speed, drag_clamp ? &u16_zero : NULL, drag_clamp ? &u16_fifty : NULL, "%u ms"); + ImGui::DragScalar("drag s32", ImGuiDataType_S32, &s32_v, drag_speed, drag_clamp ? &s32_zero : NULL, drag_clamp ? &s32_fifty : NULL); + ImGui::DragScalar("drag u32", ImGuiDataType_U32, &u32_v, drag_speed, drag_clamp ? &u32_zero : NULL, drag_clamp ? &u32_fifty : NULL, "%u ms"); + ImGui::DragScalar("drag s64", ImGuiDataType_S64, &s64_v, drag_speed, drag_clamp ? &s64_zero : NULL, drag_clamp ? &s64_fifty : NULL); + ImGui::DragScalar("drag u64", ImGuiDataType_U64, &u64_v, drag_speed, drag_clamp ? &u64_zero : NULL, drag_clamp ? &u64_fifty : NULL); + ImGui::DragScalar("drag float", ImGuiDataType_Float, &f32_v, 0.005f, &f32_zero, &f32_one, "%f"); + ImGui::DragScalar("drag float log", ImGuiDataType_Float, &f32_v, 0.005f, &f32_zero, &f32_one, "%f", ImGuiSliderFlags_Logarithmic); + ImGui::DragScalar("drag double", ImGuiDataType_Double, &f64_v, 0.0005f, &f64_zero, NULL, "%.10f grams"); + ImGui::DragScalar("drag double log",ImGuiDataType_Double, &f64_v, 0.0005f, &f64_zero, &f64_one, "0 < %.10f < 1", ImGuiSliderFlags_Logarithmic); + + ImGui::Text("Sliders"); + ImGui::SliderScalar("slider s8 full", ImGuiDataType_S8, &s8_v, &s8_min, &s8_max, "%d"); + ImGui::SliderScalar("slider u8 full", ImGuiDataType_U8, &u8_v, &u8_min, &u8_max, "%u"); + ImGui::SliderScalar("slider s16 full", ImGuiDataType_S16, &s16_v, &s16_min, &s16_max, "%d"); + ImGui::SliderScalar("slider u16 full", ImGuiDataType_U16, &u16_v, &u16_min, &u16_max, "%u"); + ImGui::SliderScalar("slider s32 low", ImGuiDataType_S32, &s32_v, &s32_zero, &s32_fifty,"%d"); + ImGui::SliderScalar("slider s32 high", ImGuiDataType_S32, &s32_v, &s32_hi_a, &s32_hi_b, "%d"); + ImGui::SliderScalar("slider s32 full", ImGuiDataType_S32, &s32_v, &s32_min, &s32_max, "%d"); + ImGui::SliderScalar("slider u32 low", ImGuiDataType_U32, &u32_v, &u32_zero, &u32_fifty,"%u"); + ImGui::SliderScalar("slider u32 high", ImGuiDataType_U32, &u32_v, &u32_hi_a, &u32_hi_b, "%u"); + ImGui::SliderScalar("slider u32 full", ImGuiDataType_U32, &u32_v, &u32_min, &u32_max, "%u"); + ImGui::SliderScalar("slider s64 low", ImGuiDataType_S64, &s64_v, &s64_zero, &s64_fifty,"%" IM_PRId64); + ImGui::SliderScalar("slider s64 high", ImGuiDataType_S64, &s64_v, &s64_hi_a, &s64_hi_b, "%" IM_PRId64); + ImGui::SliderScalar("slider s64 full", ImGuiDataType_S64, &s64_v, &s64_min, &s64_max, "%" IM_PRId64); + ImGui::SliderScalar("slider u64 low", ImGuiDataType_U64, &u64_v, &u64_zero, &u64_fifty,"%" IM_PRIu64 " ms"); + ImGui::SliderScalar("slider u64 high", ImGuiDataType_U64, &u64_v, &u64_hi_a, &u64_hi_b, "%" IM_PRIu64 " ms"); + ImGui::SliderScalar("slider u64 full", ImGuiDataType_U64, &u64_v, &u64_min, &u64_max, "%" IM_PRIu64 " ms"); + ImGui::SliderScalar("slider float low", ImGuiDataType_Float, &f32_v, &f32_zero, &f32_one); + ImGui::SliderScalar("slider float low log", ImGuiDataType_Float, &f32_v, &f32_zero, &f32_one, "%.10f", ImGuiSliderFlags_Logarithmic); + ImGui::SliderScalar("slider float high", ImGuiDataType_Float, &f32_v, &f32_lo_a, &f32_hi_a, "%e"); + ImGui::SliderScalar("slider double low", ImGuiDataType_Double, &f64_v, &f64_zero, &f64_one, "%.10f grams"); + ImGui::SliderScalar("slider double low log",ImGuiDataType_Double, &f64_v, &f64_zero, &f64_one, "%.10f", ImGuiSliderFlags_Logarithmic); + ImGui::SliderScalar("slider double high", ImGuiDataType_Double, &f64_v, &f64_lo_a, &f64_hi_a, "%e grams"); + + ImGui::Text("Sliders (reverse)"); + ImGui::SliderScalar("slider s8 reverse", ImGuiDataType_S8, &s8_v, &s8_max, &s8_min, "%d"); + ImGui::SliderScalar("slider u8 reverse", ImGuiDataType_U8, &u8_v, &u8_max, &u8_min, "%u"); + ImGui::SliderScalar("slider s32 reverse", ImGuiDataType_S32, &s32_v, &s32_fifty, &s32_zero, "%d"); + ImGui::SliderScalar("slider u32 reverse", ImGuiDataType_U32, &u32_v, &u32_fifty, &u32_zero, "%u"); + ImGui::SliderScalar("slider s64 reverse", ImGuiDataType_S64, &s64_v, &s64_fifty, &s64_zero, "%" IM_PRId64); + ImGui::SliderScalar("slider u64 reverse", ImGuiDataType_U64, &u64_v, &u64_fifty, &u64_zero, "%" IM_PRIu64 " ms"); + + static bool inputs_step = true; + ImGui::Text("Inputs"); + ImGui::Checkbox("Show step buttons", &inputs_step); + ImGui::InputScalar("input s8", ImGuiDataType_S8, &s8_v, inputs_step ? &s8_one : NULL, NULL, "%d"); + ImGui::InputScalar("input u8", ImGuiDataType_U8, &u8_v, inputs_step ? &u8_one : NULL, NULL, "%u"); + ImGui::InputScalar("input s16", ImGuiDataType_S16, &s16_v, inputs_step ? &s16_one : NULL, NULL, "%d"); + ImGui::InputScalar("input u16", ImGuiDataType_U16, &u16_v, inputs_step ? &u16_one : NULL, NULL, "%u"); + ImGui::InputScalar("input s32", ImGuiDataType_S32, &s32_v, inputs_step ? &s32_one : NULL, NULL, "%d"); + ImGui::InputScalar("input s32 hex", ImGuiDataType_S32, &s32_v, inputs_step ? &s32_one : NULL, NULL, "%08X", ImGuiInputTextFlags_CharsHexadecimal); + ImGui::InputScalar("input u32", ImGuiDataType_U32, &u32_v, inputs_step ? &u32_one : NULL, NULL, "%u"); + ImGui::InputScalar("input u32 hex", ImGuiDataType_U32, &u32_v, inputs_step ? &u32_one : NULL, NULL, "%08X", ImGuiInputTextFlags_CharsHexadecimal); + ImGui::InputScalar("input s64", ImGuiDataType_S64, &s64_v, inputs_step ? &s64_one : NULL); + ImGui::InputScalar("input u64", ImGuiDataType_U64, &u64_v, inputs_step ? &u64_one : NULL); + ImGui::InputScalar("input float", ImGuiDataType_Float, &f32_v, inputs_step ? &f32_one : NULL); + ImGui::InputScalar("input double", ImGuiDataType_Double, &f64_v, inputs_step ? &f64_one : NULL); + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Multi-component Widgets")) + { + static float vec4f[4] = { 0.10f, 0.20f, 0.30f, 0.44f }; + static int vec4i[4] = { 1, 5, 100, 255 }; + + ImGui::InputFloat2("input float2", vec4f); + ImGui::DragFloat2("drag float2", vec4f, 0.01f, 0.0f, 1.0f); + ImGui::SliderFloat2("slider float2", vec4f, 0.0f, 1.0f); + ImGui::InputInt2("input int2", vec4i); + ImGui::DragInt2("drag int2", vec4i, 1, 0, 255); + ImGui::SliderInt2("slider int2", vec4i, 0, 255); + ImGui::Spacing(); + + ImGui::InputFloat3("input float3", vec4f); + ImGui::DragFloat3("drag float3", vec4f, 0.01f, 0.0f, 1.0f); + ImGui::SliderFloat3("slider float3", vec4f, 0.0f, 1.0f); + ImGui::InputInt3("input int3", vec4i); + ImGui::DragInt3("drag int3", vec4i, 1, 0, 255); + ImGui::SliderInt3("slider int3", vec4i, 0, 255); + ImGui::Spacing(); + + ImGui::InputFloat4("input float4", vec4f); + ImGui::DragFloat4("drag float4", vec4f, 0.01f, 0.0f, 1.0f); + ImGui::SliderFloat4("slider float4", vec4f, 0.0f, 1.0f); + ImGui::InputInt4("input int4", vec4i); + ImGui::DragInt4("drag int4", vec4i, 1, 0, 255); + ImGui::SliderInt4("slider int4", vec4i, 0, 255); + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Vertical Sliders")) + { + const float spacing = 4; + ImGui::PushStyleVar(ImGuiStyleVar_ItemSpacing, ImVec2(spacing, spacing)); + + static int int_value = 0; + ImGui::VSliderInt("##int", ImVec2(18, 160), &int_value, 0, 5); + ImGui::SameLine(); + + static float values[7] = { 0.0f, 0.60f, 0.35f, 0.9f, 0.70f, 0.20f, 0.0f }; + ImGui::PushID("set1"); + for (int i = 0; i < 7; i++) + { + if (i > 0) ImGui::SameLine(); + ImGui::PushID(i); + ImGui::PushStyleColor(ImGuiCol_FrameBg, (ImVec4)ImColor::HSV(i / 7.0f, 0.5f, 0.5f)); + ImGui::PushStyleColor(ImGuiCol_FrameBgHovered, (ImVec4)ImColor::HSV(i / 7.0f, 0.6f, 0.5f)); + ImGui::PushStyleColor(ImGuiCol_FrameBgActive, (ImVec4)ImColor::HSV(i / 7.0f, 0.7f, 0.5f)); + ImGui::PushStyleColor(ImGuiCol_SliderGrab, (ImVec4)ImColor::HSV(i / 7.0f, 0.9f, 0.9f)); + ImGui::VSliderFloat("##v", ImVec2(18, 160), &values[i], 0.0f, 1.0f, ""); + if (ImGui::IsItemActive() || ImGui::IsItemHovered()) + ImGui::SetTooltip("%.3f", values[i]); + ImGui::PopStyleColor(4); + ImGui::PopID(); + } + ImGui::PopID(); + + ImGui::SameLine(); + ImGui::PushID("set2"); + static float values2[4] = { 0.20f, 0.80f, 0.40f, 0.25f }; + const int rows = 3; + const ImVec2 small_slider_size(18, (float)(int)((160.0f - (rows - 1) * spacing) / rows)); + for (int nx = 0; nx < 4; nx++) + { + if (nx > 0) ImGui::SameLine(); + ImGui::BeginGroup(); + for (int ny = 0; ny < rows; ny++) + { + ImGui::PushID(nx * rows + ny); + ImGui::VSliderFloat("##v", small_slider_size, &values2[nx], 0.0f, 1.0f, ""); + if (ImGui::IsItemActive() || ImGui::IsItemHovered()) + ImGui::SetTooltip("%.3f", values2[nx]); + ImGui::PopID(); + } + ImGui::EndGroup(); + } + ImGui::PopID(); + + ImGui::SameLine(); + ImGui::PushID("set3"); + for (int i = 0; i < 4; i++) + { + if (i > 0) ImGui::SameLine(); + ImGui::PushID(i); + ImGui::PushStyleVar(ImGuiStyleVar_GrabMinSize, 40); + ImGui::VSliderFloat("##v", ImVec2(40, 160), &values[i], 0.0f, 1.0f, "%.2f\nsec"); + ImGui::PopStyleVar(); + ImGui::PopID(); + } + ImGui::PopID(); + ImGui::PopStyleVar(); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Drag and Drop")) + { + if (ImGui::TreeNode("Drag and drop in standard widgets")) + { + // ColorEdit widgets automatically act as drag source and drag target. + // They are using standardized payload strings IMGUI_PAYLOAD_TYPE_COLOR_3F and IMGUI_PAYLOAD_TYPE_COLOR_4F + // to allow your own widgets to use colors in their drag and drop interaction. + // Also see 'Demo->Widgets->Color/Picker Widgets->Palette' demo. + HelpMarker("You can drag from the color squares."); + static float col1[3] = { 1.0f, 0.0f, 0.2f }; + static float col2[4] = { 0.4f, 0.7f, 0.0f, 0.5f }; + ImGui::ColorEdit3("color 1", col1); + ImGui::ColorEdit4("color 2", col2); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Drag and drop to copy/swap items")) + { + enum Mode + { + Mode_Copy, + Mode_Move, + Mode_Swap + }; + static int mode = 0; + if (ImGui::RadioButton("Copy", mode == Mode_Copy)) { mode = Mode_Copy; } ImGui::SameLine(); + if (ImGui::RadioButton("Move", mode == Mode_Move)) { mode = Mode_Move; } ImGui::SameLine(); + if (ImGui::RadioButton("Swap", mode == Mode_Swap)) { mode = Mode_Swap; } + static const char* names[9] = + { + "Bobby", "Beatrice", "Betty", + "Brianna", "Barry", "Bernard", + "Bibi", "Blaine", "Bryn" + }; + for (int n = 0; n < IM_ARRAYSIZE(names); n++) + { + ImGui::PushID(n); + if ((n % 3) != 0) + ImGui::SameLine(); + ImGui::Button(names[n], ImVec2(60, 60)); + + // Our buttons are both drag sources and drag targets here! + if (ImGui::BeginDragDropSource(ImGuiDragDropFlags_None)) + { + // Set payload to carry the index of our item (could be anything) + ImGui::SetDragDropPayload("DND_DEMO_CELL", &n, sizeof(int)); + + // Display preview (could be anything, e.g. when dragging an image we could decide to display + // the filename and a small preview of the image, etc.) + if (mode == Mode_Copy) { ImGui::Text("Copy %s", names[n]); } + if (mode == Mode_Move) { ImGui::Text("Move %s", names[n]); } + if (mode == Mode_Swap) { ImGui::Text("Swap %s", names[n]); } + ImGui::EndDragDropSource(); + } + if (ImGui::BeginDragDropTarget()) + { + if (const ImGuiPayload* payload = ImGui::AcceptDragDropPayload("DND_DEMO_CELL")) + { + IM_ASSERT(payload->DataSize == sizeof(int)); + int payload_n = *(const int*)payload->Data; + if (mode == Mode_Copy) + { + names[n] = names[payload_n]; + } + if (mode == Mode_Move) + { + names[n] = names[payload_n]; + names[payload_n] = ""; + } + if (mode == Mode_Swap) + { + const char* tmp = names[n]; + names[n] = names[payload_n]; + names[payload_n] = tmp; + } + } + ImGui::EndDragDropTarget(); + } + ImGui::PopID(); + } + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Drag to reorder items (simple)")) + { + // Simple reordering + HelpMarker( + "We don't use the drag and drop api at all here! " + "Instead we query when the item is held but not hovered, and order items accordingly."); + static const char* item_names[] = { "Item One", "Item Two", "Item Three", "Item Four", "Item Five" }; + for (int n = 0; n < IM_ARRAYSIZE(item_names); n++) + { + const char* item = item_names[n]; + ImGui::Selectable(item); + + if (ImGui::IsItemActive() && !ImGui::IsItemHovered()) + { + int n_next = n + (ImGui::GetMouseDragDelta(0).y < 0.f ? -1 : 1); + if (n_next >= 0 && n_next < IM_ARRAYSIZE(item_names)) + { + item_names[n] = item_names[n_next]; + item_names[n_next] = item; + ImGui::ResetMouseDragDelta(); + } + } + } + ImGui::TreePop(); + } + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Querying Status (Edited/Active/Hovered etc.)")) + { + // Select an item type + const char* item_names[] = + { + "Text", "Button", "Button (w/ repeat)", "Checkbox", "SliderFloat", "InputText", "InputFloat", + "InputFloat3", "ColorEdit4", "Selectable", "MenuItem", "TreeNode", "TreeNode (w/ double-click)", "Combo", "ListBox" + }; + static int item_type = 4; + static bool item_disabled = false; + ImGui::Combo("Item Type", &item_type, item_names, IM_ARRAYSIZE(item_names), IM_ARRAYSIZE(item_names)); + ImGui::SameLine(); + HelpMarker("Testing how various types of items are interacting with the IsItemXXX functions. Note that the bool return value of most ImGui function is generally equivalent to calling ImGui::IsItemHovered()."); + ImGui::Checkbox("Item Disabled", &item_disabled); + + // Submit selected item item so we can query their status in the code following it. + bool ret = false; + static bool b = false; + static float col4f[4] = { 1.0f, 0.5, 0.0f, 1.0f }; + static char str[16] = {}; + if (item_disabled) + ImGui::BeginDisabled(true); + if (item_type == 0) { ImGui::Text("ITEM: Text"); } // Testing text items with no identifier/interaction + if (item_type == 1) { ret = ImGui::Button("ITEM: Button"); } // Testing button + if (item_type == 2) { ImGui::PushButtonRepeat(true); ret = ImGui::Button("ITEM: Button"); ImGui::PopButtonRepeat(); } // Testing button (with repeater) + if (item_type == 3) { ret = ImGui::Checkbox("ITEM: Checkbox", &b); } // Testing checkbox + if (item_type == 4) { ret = ImGui::SliderFloat("ITEM: SliderFloat", &col4f[0], 0.0f, 1.0f); } // Testing basic item + if (item_type == 5) { ret = ImGui::InputText("ITEM: InputText", &str[0], IM_ARRAYSIZE(str)); } // Testing input text (which handles tabbing) + if (item_type == 6) { ret = ImGui::InputFloat("ITEM: InputFloat", col4f, 1.0f); } // Testing +/- buttons on scalar input + if (item_type == 7) { ret = ImGui::InputFloat3("ITEM: InputFloat3", col4f); } // Testing multi-component items (IsItemXXX flags are reported merged) + if (item_type == 8) { ret = ImGui::ColorEdit4("ITEM: ColorEdit4", col4f); } // Testing multi-component items (IsItemXXX flags are reported merged) + if (item_type == 9) { ret = ImGui::Selectable("ITEM: Selectable"); } // Testing selectable item + if (item_type == 10){ ret = ImGui::MenuItem("ITEM: MenuItem"); } // Testing menu item (they use ImGuiButtonFlags_PressedOnRelease button policy) + if (item_type == 11){ ret = ImGui::TreeNode("ITEM: TreeNode"); if (ret) ImGui::TreePop(); } // Testing tree node + if (item_type == 12){ ret = ImGui::TreeNodeEx("ITEM: TreeNode w/ ImGuiTreeNodeFlags_OpenOnDoubleClick", ImGuiTreeNodeFlags_OpenOnDoubleClick | ImGuiTreeNodeFlags_NoTreePushOnOpen); } // Testing tree node with ImGuiButtonFlags_PressedOnDoubleClick button policy. + if (item_type == 13){ const char* items[] = { "Apple", "Banana", "Cherry", "Kiwi" }; static int current = 1; ret = ImGui::Combo("ITEM: Combo", ¤t, items, IM_ARRAYSIZE(items)); } + if (item_type == 14){ const char* items[] = { "Apple", "Banana", "Cherry", "Kiwi" }; static int current = 1; ret = ImGui::ListBox("ITEM: ListBox", ¤t, items, IM_ARRAYSIZE(items), IM_ARRAYSIZE(items)); } + + // Display the values of IsItemHovered() and other common item state functions. + // Note that the ImGuiHoveredFlags_XXX flags can be combined. + // Because BulletText is an item itself and that would affect the output of IsItemXXX functions, + // we query every state in a single call to avoid storing them and to simplify the code. + ImGui::BulletText( + "Return value = %d\n" + "IsItemFocused() = %d\n" + "IsItemHovered() = %d\n" + "IsItemHovered(_AllowWhenBlockedByPopup) = %d\n" + "IsItemHovered(_AllowWhenBlockedByActiveItem) = %d\n" + "IsItemHovered(_AllowWhenOverlapped) = %d\n" + "IsItemHovered(_AllowWhenDisabled) = %d\n" + "IsItemHovered(_RectOnly) = %d\n" + "IsItemActive() = %d\n" + "IsItemEdited() = %d\n" + "IsItemActivated() = %d\n" + "IsItemDeactivated() = %d\n" + "IsItemDeactivatedAfterEdit() = %d\n" + "IsItemVisible() = %d\n" + "IsItemClicked() = %d\n" + "IsItemToggledOpen() = %d\n" + "GetItemRectMin() = (%.1f, %.1f)\n" + "GetItemRectMax() = (%.1f, %.1f)\n" + "GetItemRectSize() = (%.1f, %.1f)", + ret, + ImGui::IsItemFocused(), + ImGui::IsItemHovered(), + ImGui::IsItemHovered(ImGuiHoveredFlags_AllowWhenBlockedByPopup), + ImGui::IsItemHovered(ImGuiHoveredFlags_AllowWhenBlockedByActiveItem), + ImGui::IsItemHovered(ImGuiHoveredFlags_AllowWhenOverlapped), + ImGui::IsItemHovered(ImGuiHoveredFlags_AllowWhenDisabled), + ImGui::IsItemHovered(ImGuiHoveredFlags_RectOnly), + ImGui::IsItemActive(), + ImGui::IsItemEdited(), + ImGui::IsItemActivated(), + ImGui::IsItemDeactivated(), + ImGui::IsItemDeactivatedAfterEdit(), + ImGui::IsItemVisible(), + ImGui::IsItemClicked(), + ImGui::IsItemToggledOpen(), + ImGui::GetItemRectMin().x, ImGui::GetItemRectMin().y, + ImGui::GetItemRectMax().x, ImGui::GetItemRectMax().y, + ImGui::GetItemRectSize().x, ImGui::GetItemRectSize().y + ); + + if (item_disabled) + ImGui::EndDisabled(); + + static bool embed_all_inside_a_child_window = false; + ImGui::Checkbox("Embed everything inside a child window (for additional testing)", &embed_all_inside_a_child_window); + if (embed_all_inside_a_child_window) + ImGui::BeginChild("outer_child", ImVec2(0, ImGui::GetFontSize() * 20.0f), true); + + // Testing IsWindowFocused() function with its various flags. + // Note that the ImGuiFocusedFlags_XXX flags can be combined. + ImGui::BulletText( + "IsWindowFocused() = %d\n" + "IsWindowFocused(_ChildWindows) = %d\n" + "IsWindowFocused(_ChildWindows|_RootWindow) = %d\n" + "IsWindowFocused(_RootWindow) = %d\n" + "IsWindowFocused(_AnyWindow) = %d\n", + ImGui::IsWindowFocused(), + ImGui::IsWindowFocused(ImGuiFocusedFlags_ChildWindows), + ImGui::IsWindowFocused(ImGuiFocusedFlags_ChildWindows | ImGuiFocusedFlags_RootWindow), + ImGui::IsWindowFocused(ImGuiFocusedFlags_RootWindow), + ImGui::IsWindowFocused(ImGuiFocusedFlags_AnyWindow)); + + // Testing IsWindowHovered() function with its various flags. + // Note that the ImGuiHoveredFlags_XXX flags can be combined. + ImGui::BulletText( + "IsWindowHovered() = %d\n" + "IsWindowHovered(_AllowWhenBlockedByPopup) = %d\n" + "IsWindowHovered(_AllowWhenBlockedByActiveItem) = %d\n" + "IsWindowHovered(_ChildWindows) = %d\n" + "IsWindowHovered(_ChildWindows|_RootWindow) = %d\n" + "IsWindowHovered(_ChildWindows|_AllowWhenBlockedByPopup) = %d\n" + "IsWindowHovered(_RootWindow) = %d\n" + "IsWindowHovered(_AnyWindow) = %d\n", + ImGui::IsWindowHovered(), + ImGui::IsWindowHovered(ImGuiHoveredFlags_AllowWhenBlockedByPopup), + ImGui::IsWindowHovered(ImGuiHoveredFlags_AllowWhenBlockedByActiveItem), + ImGui::IsWindowHovered(ImGuiHoveredFlags_ChildWindows), + ImGui::IsWindowHovered(ImGuiHoveredFlags_ChildWindows | ImGuiHoveredFlags_RootWindow), + ImGui::IsWindowHovered(ImGuiHoveredFlags_ChildWindows | ImGuiHoveredFlags_AllowWhenBlockedByPopup), + ImGui::IsWindowHovered(ImGuiHoveredFlags_RootWindow), + ImGui::IsWindowHovered(ImGuiHoveredFlags_AnyWindow)); + + ImGui::BeginChild("child", ImVec2(0, 50), true); + ImGui::Text("This is another child window for testing the _ChildWindows flag."); + ImGui::EndChild(); + if (embed_all_inside_a_child_window) + ImGui::EndChild(); + + static char unused_str[] = "This widget is only here to be able to tab-out of the widgets above."; + ImGui::InputText("unused", unused_str, IM_ARRAYSIZE(unused_str), ImGuiInputTextFlags_ReadOnly); + + // Calling IsItemHovered() after begin returns the hovered status of the title bar. + // This is useful in particular if you want to create a context menu associated to the title bar of a window. + static bool test_window = false; + ImGui::Checkbox("Hovered/Active tests after Begin() for title bar testing", &test_window); + if (test_window) + { + ImGui::Begin("Title bar Hovered/Active tests", &test_window); + if (ImGui::BeginPopupContextItem()) // <-- This is using IsItemHovered() + { + if (ImGui::MenuItem("Close")) { test_window = false; } + ImGui::EndPopup(); + } + ImGui::Text( + "IsItemHovered() after begin = %d (== is title bar hovered)\n" + "IsItemActive() after begin = %d (== is window being clicked/moved)\n", + ImGui::IsItemHovered(), ImGui::IsItemActive()); + ImGui::End(); + } + + ImGui::TreePop(); + } + + // Demonstrate BeginDisabled/EndDisabled using a checkbox located at the bottom of the section (which is a bit odd: + // logically we'd have this checkbox at the top of the section, but we don't want this feature to steal that space) + if (disable_all) + ImGui::EndDisabled(); + + if (ImGui::TreeNode("Disable block")) + { + ImGui::Checkbox("Disable entire section above", &disable_all); + ImGui::SameLine(); HelpMarker("Demonstrate using BeginDisabled()/EndDisabled() across this section."); + ImGui::TreePop(); + } +} + +static void ShowDemoWindowLayout() +{ + if (!ImGui::CollapsingHeader("Layout & Scrolling")) + return; + + if (ImGui::TreeNode("Child windows")) + { + HelpMarker("Use child windows to begin into a self-contained independent scrolling/clipping regions within a host window."); + static bool disable_mouse_wheel = false; + static bool disable_menu = false; + ImGui::Checkbox("Disable Mouse Wheel", &disable_mouse_wheel); + ImGui::Checkbox("Disable Menu", &disable_menu); + + // Child 1: no border, enable horizontal scrollbar + { + ImGuiWindowFlags window_flags = ImGuiWindowFlags_HorizontalScrollbar; + if (disable_mouse_wheel) + window_flags |= ImGuiWindowFlags_NoScrollWithMouse; + ImGui::BeginChild("ChildL", ImVec2(ImGui::GetContentRegionAvail().x * 0.5f, 260), false, window_flags); + for (int i = 0; i < 100; i++) + ImGui::Text("%04d: scrollable region", i); + ImGui::EndChild(); + } + + ImGui::SameLine(); + + // Child 2: rounded border + { + ImGuiWindowFlags window_flags = ImGuiWindowFlags_None; + if (disable_mouse_wheel) + window_flags |= ImGuiWindowFlags_NoScrollWithMouse; + if (!disable_menu) + window_flags |= ImGuiWindowFlags_MenuBar; + ImGui::PushStyleVar(ImGuiStyleVar_ChildRounding, 5.0f); + ImGui::BeginChild("ChildR", ImVec2(0, 260), true, window_flags); + if (!disable_menu && ImGui::BeginMenuBar()) + { + if (ImGui::BeginMenu("Menu")) + { + ShowExampleMenuFile(); + ImGui::EndMenu(); + } + ImGui::EndMenuBar(); + } + if (ImGui::BeginTable("split", 2, ImGuiTableFlags_Resizable | ImGuiTableFlags_NoSavedSettings)) + { + for (int i = 0; i < 100; i++) + { + char buf[32]; + sprintf(buf, "%03d", i); + ImGui::TableNextColumn(); + ImGui::Button(buf, ImVec2(-FLT_MIN, 0.0f)); + } + ImGui::EndTable(); + } + ImGui::EndChild(); + ImGui::PopStyleVar(); + } + + ImGui::Separator(); + + // Demonstrate a few extra things + // - Changing ImGuiCol_ChildBg (which is transparent black in default styles) + // - Using SetCursorPos() to position child window (the child window is an item from the POV of parent window) + // You can also call SetNextWindowPos() to position the child window. The parent window will effectively + // layout from this position. + // - Using ImGui::GetItemRectMin/Max() to query the "item" state (because the child window is an item from + // the POV of the parent window). See 'Demo->Querying Status (Edited/Active/Hovered etc.)' for details. + { + static int offset_x = 0; + ImGui::SetNextItemWidth(ImGui::GetFontSize() * 8); + ImGui::DragInt("Offset X", &offset_x, 1.0f, -1000, 1000); + + ImGui::SetCursorPosX(ImGui::GetCursorPosX() + (float)offset_x); + ImGui::PushStyleColor(ImGuiCol_ChildBg, IM_COL32(255, 0, 0, 100)); + ImGui::BeginChild("Red", ImVec2(200, 100), true, ImGuiWindowFlags_None); + for (int n = 0; n < 50; n++) + ImGui::Text("Some test %d", n); + ImGui::EndChild(); + bool child_is_hovered = ImGui::IsItemHovered(); + ImVec2 child_rect_min = ImGui::GetItemRectMin(); + ImVec2 child_rect_max = ImGui::GetItemRectMax(); + ImGui::PopStyleColor(); + ImGui::Text("Hovered: %d", child_is_hovered); + ImGui::Text("Rect of child window is: (%.0f,%.0f) (%.0f,%.0f)", child_rect_min.x, child_rect_min.y, child_rect_max.x, child_rect_max.y); + } + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Widgets Width")) + { + static float f = 0.0f; + static bool show_indented_items = true; + ImGui::Checkbox("Show indented items", &show_indented_items); + + // Use SetNextItemWidth() to set the width of a single upcoming item. + // Use PushItemWidth()/PopItemWidth() to set the width of a group of items. + // In real code use you'll probably want to choose width values that are proportional to your font size + // e.g. Using '20.0f * GetFontSize()' as width instead of '200.0f', etc. + + ImGui::Text("SetNextItemWidth/PushItemWidth(100)"); + ImGui::SameLine(); HelpMarker("Fixed width."); + ImGui::PushItemWidth(100); + ImGui::DragFloat("float##1b", &f); + if (show_indented_items) + { + ImGui::Indent(); + ImGui::DragFloat("float (indented)##1b", &f); + ImGui::Unindent(); + } + ImGui::PopItemWidth(); + + ImGui::Text("SetNextItemWidth/PushItemWidth(-100)"); + ImGui::SameLine(); HelpMarker("Align to right edge minus 100"); + ImGui::PushItemWidth(-100); + ImGui::DragFloat("float##2a", &f); + if (show_indented_items) + { + ImGui::Indent(); + ImGui::DragFloat("float (indented)##2b", &f); + ImGui::Unindent(); + } + ImGui::PopItemWidth(); + + ImGui::Text("SetNextItemWidth/PushItemWidth(GetContentRegionAvail().x * 0.5f)"); + ImGui::SameLine(); HelpMarker("Half of available width.\n(~ right-cursor_pos)\n(works within a column set)"); + ImGui::PushItemWidth(ImGui::GetContentRegionAvail().x * 0.5f); + ImGui::DragFloat("float##3a", &f); + if (show_indented_items) + { + ImGui::Indent(); + ImGui::DragFloat("float (indented)##3b", &f); + ImGui::Unindent(); + } + ImGui::PopItemWidth(); + + ImGui::Text("SetNextItemWidth/PushItemWidth(-GetContentRegionAvail().x * 0.5f)"); + ImGui::SameLine(); HelpMarker("Align to right edge minus half"); + ImGui::PushItemWidth(-ImGui::GetContentRegionAvail().x * 0.5f); + ImGui::DragFloat("float##4a", &f); + if (show_indented_items) + { + ImGui::Indent(); + ImGui::DragFloat("float (indented)##4b", &f); + ImGui::Unindent(); + } + ImGui::PopItemWidth(); + + // Demonstrate using PushItemWidth to surround three items. + // Calling SetNextItemWidth() before each of them would have the same effect. + ImGui::Text("SetNextItemWidth/PushItemWidth(-FLT_MIN)"); + ImGui::SameLine(); HelpMarker("Align to right edge"); + ImGui::PushItemWidth(-FLT_MIN); + ImGui::DragFloat("##float5a", &f); + if (show_indented_items) + { + ImGui::Indent(); + ImGui::DragFloat("float (indented)##5b", &f); + ImGui::Unindent(); + } + ImGui::PopItemWidth(); + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Basic Horizontal Layout")) + { + ImGui::TextWrapped("(Use ImGui::SameLine() to keep adding items to the right of the preceding item)"); + + // Text + ImGui::Text("Two items: Hello"); ImGui::SameLine(); + ImGui::TextColored(ImVec4(1,1,0,1), "Sailor"); + + // Adjust spacing + ImGui::Text("More spacing: Hello"); ImGui::SameLine(0, 20); + ImGui::TextColored(ImVec4(1,1,0,1), "Sailor"); + + // Button + ImGui::AlignTextToFramePadding(); + ImGui::Text("Normal buttons"); ImGui::SameLine(); + ImGui::Button("Banana"); ImGui::SameLine(); + ImGui::Button("Apple"); ImGui::SameLine(); + ImGui::Button("Corniflower"); + + // Button + ImGui::Text("Small buttons"); ImGui::SameLine(); + ImGui::SmallButton("Like this one"); ImGui::SameLine(); + ImGui::Text("can fit within a text block."); + + // Aligned to arbitrary position. Easy/cheap column. + ImGui::Text("Aligned"); + ImGui::SameLine(150); ImGui::Text("x=150"); + ImGui::SameLine(300); ImGui::Text("x=300"); + ImGui::Text("Aligned"); + ImGui::SameLine(150); ImGui::SmallButton("x=150"); + ImGui::SameLine(300); ImGui::SmallButton("x=300"); + + // Checkbox + static bool c1 = false, c2 = false, c3 = false, c4 = false; + ImGui::Checkbox("My", &c1); ImGui::SameLine(); + ImGui::Checkbox("Tailor", &c2); ImGui::SameLine(); + ImGui::Checkbox("Is", &c3); ImGui::SameLine(); + ImGui::Checkbox("Rich", &c4); + + // Various + static float f0 = 1.0f, f1 = 2.0f, f2 = 3.0f; + ImGui::PushItemWidth(80); + const char* items[] = { "AAAA", "BBBB", "CCCC", "DDDD" }; + static int item = -1; + ImGui::Combo("Combo", &item, items, IM_ARRAYSIZE(items)); ImGui::SameLine(); + ImGui::SliderFloat("X", &f0, 0.0f, 5.0f); ImGui::SameLine(); + ImGui::SliderFloat("Y", &f1, 0.0f, 5.0f); ImGui::SameLine(); + ImGui::SliderFloat("Z", &f2, 0.0f, 5.0f); + ImGui::PopItemWidth(); + + ImGui::PushItemWidth(80); + ImGui::Text("Lists:"); + static int selection[4] = { 0, 1, 2, 3 }; + for (int i = 0; i < 4; i++) + { + if (i > 0) ImGui::SameLine(); + ImGui::PushID(i); + ImGui::ListBox("", &selection[i], items, IM_ARRAYSIZE(items)); + ImGui::PopID(); + //if (ImGui::IsItemHovered()) ImGui::SetTooltip("ListBox %d hovered", i); + } + ImGui::PopItemWidth(); + + // Dummy + ImVec2 button_sz(40, 40); + ImGui::Button("A", button_sz); ImGui::SameLine(); + ImGui::Dummy(button_sz); ImGui::SameLine(); + ImGui::Button("B", button_sz); + + // Manually wrapping + // (we should eventually provide this as an automatic layout feature, but for now you can do it manually) + ImGui::Text("Manually wrapping:"); + ImGuiStyle& style = ImGui::GetStyle(); + int buttons_count = 20; + float window_visible_x2 = ImGui::GetWindowPos().x + ImGui::GetWindowContentRegionMax().x; + for (int n = 0; n < buttons_count; n++) + { + ImGui::PushID(n); + ImGui::Button("Box", button_sz); + float last_button_x2 = ImGui::GetItemRectMax().x; + float next_button_x2 = last_button_x2 + style.ItemSpacing.x + button_sz.x; // Expected position if next button was on same line + if (n + 1 < buttons_count && next_button_x2 < window_visible_x2) + ImGui::SameLine(); + ImGui::PopID(); + } + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Groups")) + { + HelpMarker( + "BeginGroup() basically locks the horizontal position for new line. " + "EndGroup() bundles the whole group so that you can use \"item\" functions such as " + "IsItemHovered()/IsItemActive() or SameLine() etc. on the whole group."); + ImGui::BeginGroup(); + { + ImGui::BeginGroup(); + ImGui::Button("AAA"); + ImGui::SameLine(); + ImGui::Button("BBB"); + ImGui::SameLine(); + ImGui::BeginGroup(); + ImGui::Button("CCC"); + ImGui::Button("DDD"); + ImGui::EndGroup(); + ImGui::SameLine(); + ImGui::Button("EEE"); + ImGui::EndGroup(); + if (ImGui::IsItemHovered()) + ImGui::SetTooltip("First group hovered"); + } + // Capture the group size and create widgets using the same size + ImVec2 size = ImGui::GetItemRectSize(); + const float values[5] = { 0.5f, 0.20f, 0.80f, 0.60f, 0.25f }; + ImGui::PlotHistogram("##values", values, IM_ARRAYSIZE(values), 0, NULL, 0.0f, 1.0f, size); + + ImGui::Button("ACTION", ImVec2((size.x - ImGui::GetStyle().ItemSpacing.x) * 0.5f, size.y)); + ImGui::SameLine(); + ImGui::Button("REACTION", ImVec2((size.x - ImGui::GetStyle().ItemSpacing.x) * 0.5f, size.y)); + ImGui::EndGroup(); + ImGui::SameLine(); + + ImGui::Button("LEVERAGE\nBUZZWORD", size); + ImGui::SameLine(); + + if (ImGui::BeginListBox("List", size)) + { + ImGui::Selectable("Selected", true); + ImGui::Selectable("Not Selected", false); + ImGui::EndListBox(); + } + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Text Baseline Alignment")) + { + { + ImGui::BulletText("Text baseline:"); + ImGui::SameLine(); HelpMarker( + "This is testing the vertical alignment that gets applied on text to keep it aligned with widgets. " + "Lines only composed of text or \"small\" widgets use less vertical space than lines with framed widgets."); + ImGui::Indent(); + + ImGui::Text("KO Blahblah"); ImGui::SameLine(); + ImGui::Button("Some framed item"); ImGui::SameLine(); + HelpMarker("Baseline of button will look misaligned with text.."); + + // If your line starts with text, call AlignTextToFramePadding() to align text to upcoming widgets. + // (because we don't know what's coming after the Text() statement, we need to move the text baseline + // down by FramePadding.y ahead of time) + ImGui::AlignTextToFramePadding(); + ImGui::Text("OK Blahblah"); ImGui::SameLine(); + ImGui::Button("Some framed item"); ImGui::SameLine(); + HelpMarker("We call AlignTextToFramePadding() to vertically align the text baseline by +FramePadding.y"); + + // SmallButton() uses the same vertical padding as Text + ImGui::Button("TEST##1"); ImGui::SameLine(); + ImGui::Text("TEST"); ImGui::SameLine(); + ImGui::SmallButton("TEST##2"); + + // If your line starts with text, call AlignTextToFramePadding() to align text to upcoming widgets. + ImGui::AlignTextToFramePadding(); + ImGui::Text("Text aligned to framed item"); ImGui::SameLine(); + ImGui::Button("Item##1"); ImGui::SameLine(); + ImGui::Text("Item"); ImGui::SameLine(); + ImGui::SmallButton("Item##2"); ImGui::SameLine(); + ImGui::Button("Item##3"); + + ImGui::Unindent(); + } + + ImGui::Spacing(); + + { + ImGui::BulletText("Multi-line text:"); + ImGui::Indent(); + ImGui::Text("One\nTwo\nThree"); ImGui::SameLine(); + ImGui::Text("Hello\nWorld"); ImGui::SameLine(); + ImGui::Text("Banana"); + + ImGui::Text("Banana"); ImGui::SameLine(); + ImGui::Text("Hello\nWorld"); ImGui::SameLine(); + ImGui::Text("One\nTwo\nThree"); + + ImGui::Button("HOP##1"); ImGui::SameLine(); + ImGui::Text("Banana"); ImGui::SameLine(); + ImGui::Text("Hello\nWorld"); ImGui::SameLine(); + ImGui::Text("Banana"); + + ImGui::Button("HOP##2"); ImGui::SameLine(); + ImGui::Text("Hello\nWorld"); ImGui::SameLine(); + ImGui::Text("Banana"); + ImGui::Unindent(); + } + + ImGui::Spacing(); + + { + ImGui::BulletText("Misc items:"); + ImGui::Indent(); + + // SmallButton() sets FramePadding to zero. Text baseline is aligned to match baseline of previous Button. + ImGui::Button("80x80", ImVec2(80, 80)); + ImGui::SameLine(); + ImGui::Button("50x50", ImVec2(50, 50)); + ImGui::SameLine(); + ImGui::Button("Button()"); + ImGui::SameLine(); + ImGui::SmallButton("SmallButton()"); + + // Tree + const float spacing = ImGui::GetStyle().ItemInnerSpacing.x; + ImGui::Button("Button##1"); + ImGui::SameLine(0.0f, spacing); + if (ImGui::TreeNode("Node##1")) + { + // Placeholder tree data + for (int i = 0; i < 6; i++) + ImGui::BulletText("Item %d..", i); + ImGui::TreePop(); + } + + // Vertically align text node a bit lower so it'll be vertically centered with upcoming widget. + // Otherwise you can use SmallButton() (smaller fit). + ImGui::AlignTextToFramePadding(); + + // Common mistake to avoid: if we want to SameLine after TreeNode we need to do it before we add + // other contents below the node. + bool node_open = ImGui::TreeNode("Node##2"); + ImGui::SameLine(0.0f, spacing); ImGui::Button("Button##2"); + if (node_open) + { + // Placeholder tree data + for (int i = 0; i < 6; i++) + ImGui::BulletText("Item %d..", i); + ImGui::TreePop(); + } + + // Bullet + ImGui::Button("Button##3"); + ImGui::SameLine(0.0f, spacing); + ImGui::BulletText("Bullet text"); + + ImGui::AlignTextToFramePadding(); + ImGui::BulletText("Node"); + ImGui::SameLine(0.0f, spacing); ImGui::Button("Button##4"); + ImGui::Unindent(); + } + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Scrolling")) + { + // Vertical scroll functions + HelpMarker("Use SetScrollHereY() or SetScrollFromPosY() to scroll to a given vertical position."); + + static int track_item = 50; + static bool enable_track = true; + static bool enable_extra_decorations = false; + static float scroll_to_off_px = 0.0f; + static float scroll_to_pos_px = 200.0f; + + ImGui::Checkbox("Decoration", &enable_extra_decorations); + + ImGui::Checkbox("Track", &enable_track); + ImGui::PushItemWidth(100); + ImGui::SameLine(140); enable_track |= ImGui::DragInt("##item", &track_item, 0.25f, 0, 99, "Item = %d"); + + bool scroll_to_off = ImGui::Button("Scroll Offset"); + ImGui::SameLine(140); scroll_to_off |= ImGui::DragFloat("##off", &scroll_to_off_px, 1.00f, 0, FLT_MAX, "+%.0f px"); + + bool scroll_to_pos = ImGui::Button("Scroll To Pos"); + ImGui::SameLine(140); scroll_to_pos |= ImGui::DragFloat("##pos", &scroll_to_pos_px, 1.00f, -10, FLT_MAX, "X/Y = %.0f px"); + ImGui::PopItemWidth(); + + if (scroll_to_off || scroll_to_pos) + enable_track = false; + + ImGuiStyle& style = ImGui::GetStyle(); + float child_w = (ImGui::GetContentRegionAvail().x - 4 * style.ItemSpacing.x) / 5; + if (child_w < 1.0f) + child_w = 1.0f; + ImGui::PushID("##VerticalScrolling"); + for (int i = 0; i < 5; i++) + { + if (i > 0) ImGui::SameLine(); + ImGui::BeginGroup(); + const char* names[] = { "Top", "25%", "Center", "75%", "Bottom" }; + ImGui::TextUnformatted(names[i]); + + const ImGuiWindowFlags child_flags = enable_extra_decorations ? ImGuiWindowFlags_MenuBar : 0; + const ImGuiID child_id = ImGui::GetID((void*)(intptr_t)i); + const bool child_is_visible = ImGui::BeginChild(child_id, ImVec2(child_w, 200.0f), true, child_flags); + if (ImGui::BeginMenuBar()) + { + ImGui::TextUnformatted("abc"); + ImGui::EndMenuBar(); + } + if (scroll_to_off) + ImGui::SetScrollY(scroll_to_off_px); + if (scroll_to_pos) + ImGui::SetScrollFromPosY(ImGui::GetCursorStartPos().y + scroll_to_pos_px, i * 0.25f); + if (child_is_visible) // Avoid calling SetScrollHereY when running with culled items + { + for (int item = 0; item < 100; item++) + { + if (enable_track && item == track_item) + { + ImGui::TextColored(ImVec4(1, 1, 0, 1), "Item %d", item); + ImGui::SetScrollHereY(i * 0.25f); // 0.0f:top, 0.5f:center, 1.0f:bottom + } + else + { + ImGui::Text("Item %d", item); + } + } + } + float scroll_y = ImGui::GetScrollY(); + float scroll_max_y = ImGui::GetScrollMaxY(); + ImGui::EndChild(); + ImGui::Text("%.0f/%.0f", scroll_y, scroll_max_y); + ImGui::EndGroup(); + } + ImGui::PopID(); + + // Horizontal scroll functions + ImGui::Spacing(); + HelpMarker( + "Use SetScrollHereX() or SetScrollFromPosX() to scroll to a given horizontal position.\n\n" + "Because the clipping rectangle of most window hides half worth of WindowPadding on the " + "left/right, using SetScrollFromPosX(+1) will usually result in clipped text whereas the " + "equivalent SetScrollFromPosY(+1) wouldn't."); + ImGui::PushID("##HorizontalScrolling"); + for (int i = 0; i < 5; i++) + { + float child_height = ImGui::GetTextLineHeight() + style.ScrollbarSize + style.WindowPadding.y * 2.0f; + ImGuiWindowFlags child_flags = ImGuiWindowFlags_HorizontalScrollbar | (enable_extra_decorations ? ImGuiWindowFlags_AlwaysVerticalScrollbar : 0); + ImGuiID child_id = ImGui::GetID((void*)(intptr_t)i); + bool child_is_visible = ImGui::BeginChild(child_id, ImVec2(-100, child_height), true, child_flags); + if (scroll_to_off) + ImGui::SetScrollX(scroll_to_off_px); + if (scroll_to_pos) + ImGui::SetScrollFromPosX(ImGui::GetCursorStartPos().x + scroll_to_pos_px, i * 0.25f); + if (child_is_visible) // Avoid calling SetScrollHereY when running with culled items + { + for (int item = 0; item < 100; item++) + { + if (item > 0) + ImGui::SameLine(); + if (enable_track && item == track_item) + { + ImGui::TextColored(ImVec4(1, 1, 0, 1), "Item %d", item); + ImGui::SetScrollHereX(i * 0.25f); // 0.0f:left, 0.5f:center, 1.0f:right + } + else + { + ImGui::Text("Item %d", item); + } + } + } + float scroll_x = ImGui::GetScrollX(); + float scroll_max_x = ImGui::GetScrollMaxX(); + ImGui::EndChild(); + ImGui::SameLine(); + const char* names[] = { "Left", "25%", "Center", "75%", "Right" }; + ImGui::Text("%s\n%.0f/%.0f", names[i], scroll_x, scroll_max_x); + ImGui::Spacing(); + } + ImGui::PopID(); + + // Miscellaneous Horizontal Scrolling Demo + HelpMarker( + "Horizontal scrolling for a window is enabled via the ImGuiWindowFlags_HorizontalScrollbar flag.\n\n" + "You may want to also explicitly specify content width by using SetNextWindowContentWidth() before Begin()."); + static int lines = 7; + ImGui::SliderInt("Lines", &lines, 1, 15); + ImGui::PushStyleVar(ImGuiStyleVar_FrameRounding, 3.0f); + ImGui::PushStyleVar(ImGuiStyleVar_FramePadding, ImVec2(2.0f, 1.0f)); + ImVec2 scrolling_child_size = ImVec2(0, ImGui::GetFrameHeightWithSpacing() * 7 + 30); + ImGui::BeginChild("scrolling", scrolling_child_size, true, ImGuiWindowFlags_HorizontalScrollbar); + for (int line = 0; line < lines; line++) + { + // Display random stuff. For the sake of this trivial demo we are using basic Button() + SameLine() + // If you want to create your own time line for a real application you may be better off manipulating + // the cursor position yourself, aka using SetCursorPos/SetCursorScreenPos to position the widgets + // yourself. You may also want to use the lower-level ImDrawList API. + int num_buttons = 10 + ((line & 1) ? line * 9 : line * 3); + for (int n = 0; n < num_buttons; n++) + { + if (n > 0) ImGui::SameLine(); + ImGui::PushID(n + line * 1000); + char num_buf[16]; + sprintf(num_buf, "%d", n); + const char* label = (!(n % 15)) ? "FizzBuzz" : (!(n % 3)) ? "Fizz" : (!(n % 5)) ? "Buzz" : num_buf; + float hue = n * 0.05f; + ImGui::PushStyleColor(ImGuiCol_Button, (ImVec4)ImColor::HSV(hue, 0.6f, 0.6f)); + ImGui::PushStyleColor(ImGuiCol_ButtonHovered, (ImVec4)ImColor::HSV(hue, 0.7f, 0.7f)); + ImGui::PushStyleColor(ImGuiCol_ButtonActive, (ImVec4)ImColor::HSV(hue, 0.8f, 0.8f)); + ImGui::Button(label, ImVec2(40.0f + sinf((float)(line + n)) * 20.0f, 0.0f)); + ImGui::PopStyleColor(3); + ImGui::PopID(); + } + } + float scroll_x = ImGui::GetScrollX(); + float scroll_max_x = ImGui::GetScrollMaxX(); + ImGui::EndChild(); + ImGui::PopStyleVar(2); + float scroll_x_delta = 0.0f; + ImGui::SmallButton("<<"); + if (ImGui::IsItemActive()) + scroll_x_delta = -ImGui::GetIO().DeltaTime * 1000.0f; + ImGui::SameLine(); + ImGui::Text("Scroll from code"); ImGui::SameLine(); + ImGui::SmallButton(">>"); + if (ImGui::IsItemActive()) + scroll_x_delta = +ImGui::GetIO().DeltaTime * 1000.0f; + ImGui::SameLine(); + ImGui::Text("%.0f/%.0f", scroll_x, scroll_max_x); + if (scroll_x_delta != 0.0f) + { + // Demonstrate a trick: you can use Begin to set yourself in the context of another window + // (here we are already out of your child window) + ImGui::BeginChild("scrolling"); + ImGui::SetScrollX(ImGui::GetScrollX() + scroll_x_delta); + ImGui::EndChild(); + } + ImGui::Spacing(); + + static bool show_horizontal_contents_size_demo_window = false; + ImGui::Checkbox("Show Horizontal contents size demo window", &show_horizontal_contents_size_demo_window); + + if (show_horizontal_contents_size_demo_window) + { + static bool show_h_scrollbar = true; + static bool show_button = true; + static bool show_tree_nodes = true; + static bool show_text_wrapped = false; + static bool show_columns = true; + static bool show_tab_bar = true; + static bool show_child = false; + static bool explicit_content_size = false; + static float contents_size_x = 300.0f; + if (explicit_content_size) + ImGui::SetNextWindowContentSize(ImVec2(contents_size_x, 0.0f)); + ImGui::Begin("Horizontal contents size demo window", &show_horizontal_contents_size_demo_window, show_h_scrollbar ? ImGuiWindowFlags_HorizontalScrollbar : 0); + ImGui::PushStyleVar(ImGuiStyleVar_ItemSpacing, ImVec2(2, 0)); + ImGui::PushStyleVar(ImGuiStyleVar_FramePadding, ImVec2(2, 0)); + HelpMarker("Test of different widgets react and impact the work rectangle growing when horizontal scrolling is enabled.\n\nUse 'Metrics->Tools->Show windows rectangles' to visualize rectangles."); + ImGui::Checkbox("H-scrollbar", &show_h_scrollbar); + ImGui::Checkbox("Button", &show_button); // Will grow contents size (unless explicitly overwritten) + ImGui::Checkbox("Tree nodes", &show_tree_nodes); // Will grow contents size and display highlight over full width + ImGui::Checkbox("Text wrapped", &show_text_wrapped);// Will grow and use contents size + ImGui::Checkbox("Columns", &show_columns); // Will use contents size + ImGui::Checkbox("Tab bar", &show_tab_bar); // Will use contents size + ImGui::Checkbox("Child", &show_child); // Will grow and use contents size + ImGui::Checkbox("Explicit content size", &explicit_content_size); + ImGui::Text("Scroll %.1f/%.1f %.1f/%.1f", ImGui::GetScrollX(), ImGui::GetScrollMaxX(), ImGui::GetScrollY(), ImGui::GetScrollMaxY()); + if (explicit_content_size) + { + ImGui::SameLine(); + ImGui::SetNextItemWidth(100); + ImGui::DragFloat("##csx", &contents_size_x); + ImVec2 p = ImGui::GetCursorScreenPos(); + ImGui::GetWindowDrawList()->AddRectFilled(p, ImVec2(p.x + 10, p.y + 10), IM_COL32_WHITE); + ImGui::GetWindowDrawList()->AddRectFilled(ImVec2(p.x + contents_size_x - 10, p.y), ImVec2(p.x + contents_size_x, p.y + 10), IM_COL32_WHITE); + ImGui::Dummy(ImVec2(0, 10)); + } + ImGui::PopStyleVar(2); + ImGui::Separator(); + if (show_button) + { + ImGui::Button("this is a 300-wide button", ImVec2(300, 0)); + } + if (show_tree_nodes) + { + bool open = true; + if (ImGui::TreeNode("this is a tree node")) + { + if (ImGui::TreeNode("another one of those tree node...")) + { + ImGui::Text("Some tree contents"); + ImGui::TreePop(); + } + ImGui::TreePop(); + } + ImGui::CollapsingHeader("CollapsingHeader", &open); + } + if (show_text_wrapped) + { + ImGui::TextWrapped("This text should automatically wrap on the edge of the work rectangle."); + } + if (show_columns) + { + ImGui::Text("Tables:"); + if (ImGui::BeginTable("table", 4, ImGuiTableFlags_Borders)) + { + for (int n = 0; n < 4; n++) + { + ImGui::TableNextColumn(); + ImGui::Text("Width %.2f", ImGui::GetContentRegionAvail().x); + } + ImGui::EndTable(); + } + ImGui::Text("Columns:"); + ImGui::Columns(4); + for (int n = 0; n < 4; n++) + { + ImGui::Text("Width %.2f", ImGui::GetColumnWidth()); + ImGui::NextColumn(); + } + ImGui::Columns(1); + } + if (show_tab_bar && ImGui::BeginTabBar("Hello")) + { + if (ImGui::BeginTabItem("OneOneOne")) { ImGui::EndTabItem(); } + if (ImGui::BeginTabItem("TwoTwoTwo")) { ImGui::EndTabItem(); } + if (ImGui::BeginTabItem("ThreeThreeThree")) { ImGui::EndTabItem(); } + if (ImGui::BeginTabItem("FourFourFour")) { ImGui::EndTabItem(); } + ImGui::EndTabBar(); + } + if (show_child) + { + ImGui::BeginChild("child", ImVec2(0, 0), true); + ImGui::EndChild(); + } + ImGui::End(); + } + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Clipping")) + { + static ImVec2 size(100.0f, 100.0f); + static ImVec2 offset(30.0f, 30.0f); + ImGui::DragFloat2("size", (float*)&size, 0.5f, 1.0f, 200.0f, "%.0f"); + ImGui::TextWrapped("(Click and drag to scroll)"); + + for (int n = 0; n < 3; n++) + { + if (n > 0) + ImGui::SameLine(); + ImGui::PushID(n); + ImGui::BeginGroup(); // Lock X position + + ImGui::InvisibleButton("##empty", size); + if (ImGui::IsItemActive() && ImGui::IsMouseDragging(ImGuiMouseButton_Left)) + { + offset.x += ImGui::GetIO().MouseDelta.x; + offset.y += ImGui::GetIO().MouseDelta.y; + } + const ImVec2 p0 = ImGui::GetItemRectMin(); + const ImVec2 p1 = ImGui::GetItemRectMax(); + const char* text_str = "Line 1 hello\nLine 2 clip me!"; + const ImVec2 text_pos = ImVec2(p0.x + offset.x, p0.y + offset.y); + ImDrawList* draw_list = ImGui::GetWindowDrawList(); + + switch (n) + { + case 0: + HelpMarker( + "Using ImGui::PushClipRect():\n" + "Will alter ImGui hit-testing logic + ImDrawList rendering.\n" + "(use this if you want your clipping rectangle to affect interactions)"); + ImGui::PushClipRect(p0, p1, true); + draw_list->AddRectFilled(p0, p1, IM_COL32(90, 90, 120, 255)); + draw_list->AddText(text_pos, IM_COL32_WHITE, text_str); + ImGui::PopClipRect(); + break; + case 1: + HelpMarker( + "Using ImDrawList::PushClipRect():\n" + "Will alter ImDrawList rendering only.\n" + "(use this as a shortcut if you are only using ImDrawList calls)"); + draw_list->PushClipRect(p0, p1, true); + draw_list->AddRectFilled(p0, p1, IM_COL32(90, 90, 120, 255)); + draw_list->AddText(text_pos, IM_COL32_WHITE, text_str); + draw_list->PopClipRect(); + break; + case 2: + HelpMarker( + "Using ImDrawList::AddText() with a fine ClipRect:\n" + "Will alter only this specific ImDrawList::AddText() rendering.\n" + "(this is often used internally to avoid altering the clipping rectangle and minimize draw calls)"); + ImVec4 clip_rect(p0.x, p0.y, p1.x, p1.y); // AddText() takes a ImVec4* here so let's convert. + draw_list->AddRectFilled(p0, p1, IM_COL32(90, 90, 120, 255)); + draw_list->AddText(ImGui::GetFont(), ImGui::GetFontSize(), text_pos, IM_COL32_WHITE, text_str, NULL, 0.0f, &clip_rect); + break; + } + ImGui::EndGroup(); + ImGui::PopID(); + } + + ImGui::TreePop(); + } +} + +static void ShowDemoWindowPopups() +{ + if (!ImGui::CollapsingHeader("Popups & Modal windows")) + return; + + // The properties of popups windows are: + // - They block normal mouse hovering detection outside them. (*) + // - Unless modal, they can be closed by clicking anywhere outside them, or by pressing ESCAPE. + // - Their visibility state (~bool) is held internally by Dear ImGui instead of being held by the programmer as + // we are used to with regular Begin() calls. User can manipulate the visibility state by calling OpenPopup(). + // (*) One can use IsItemHovered(ImGuiHoveredFlags_AllowWhenBlockedByPopup) to bypass it and detect hovering even + // when normally blocked by a popup. + // Those three properties are connected. The library needs to hold their visibility state BECAUSE it can close + // popups at any time. + + // Typical use for regular windows: + // bool my_tool_is_active = false; if (ImGui::Button("Open")) my_tool_is_active = true; [...] if (my_tool_is_active) Begin("My Tool", &my_tool_is_active) { [...] } End(); + // Typical use for popups: + // if (ImGui::Button("Open")) ImGui::OpenPopup("MyPopup"); if (ImGui::BeginPopup("MyPopup") { [...] EndPopup(); } + + // With popups we have to go through a library call (here OpenPopup) to manipulate the visibility state. + // This may be a bit confusing at first but it should quickly make sense. Follow on the examples below. + + if (ImGui::TreeNode("Popups")) + { + ImGui::TextWrapped( + "When a popup is active, it inhibits interacting with windows that are behind the popup. " + "Clicking outside the popup closes it."); + + static int selected_fish = -1; + const char* names[] = { "Bream", "Haddock", "Mackerel", "Pollock", "Tilefish" }; + static bool toggles[] = { true, false, false, false, false }; + + // Simple selection popup (if you want to show the current selection inside the Button itself, + // you may want to build a string using the "###" operator to preserve a constant ID with a variable label) + if (ImGui::Button("Select..")) + ImGui::OpenPopup("my_select_popup"); + ImGui::SameLine(); + ImGui::TextUnformatted(selected_fish == -1 ? "" : names[selected_fish]); + if (ImGui::BeginPopup("my_select_popup")) + { + ImGui::Text("Aquarium"); + ImGui::Separator(); + for (int i = 0; i < IM_ARRAYSIZE(names); i++) + if (ImGui::Selectable(names[i])) + selected_fish = i; + ImGui::EndPopup(); + } + + // Showing a menu with toggles + if (ImGui::Button("Toggle..")) + ImGui::OpenPopup("my_toggle_popup"); + if (ImGui::BeginPopup("my_toggle_popup")) + { + for (int i = 0; i < IM_ARRAYSIZE(names); i++) + ImGui::MenuItem(names[i], "", &toggles[i]); + if (ImGui::BeginMenu("Sub-menu")) + { + ImGui::MenuItem("Click me"); + ImGui::EndMenu(); + } + + ImGui::Separator(); + ImGui::Text("Tooltip here"); + if (ImGui::IsItemHovered()) + ImGui::SetTooltip("I am a tooltip over a popup"); + + if (ImGui::Button("Stacked Popup")) + ImGui::OpenPopup("another popup"); + if (ImGui::BeginPopup("another popup")) + { + for (int i = 0; i < IM_ARRAYSIZE(names); i++) + ImGui::MenuItem(names[i], "", &toggles[i]); + if (ImGui::BeginMenu("Sub-menu")) + { + ImGui::MenuItem("Click me"); + if (ImGui::Button("Stacked Popup")) + ImGui::OpenPopup("another popup"); + if (ImGui::BeginPopup("another popup")) + { + ImGui::Text("I am the last one here."); + ImGui::EndPopup(); + } + ImGui::EndMenu(); + } + ImGui::EndPopup(); + } + ImGui::EndPopup(); + } + + // Call the more complete ShowExampleMenuFile which we use in various places of this demo + if (ImGui::Button("File Menu..")) + ImGui::OpenPopup("my_file_popup"); + if (ImGui::BeginPopup("my_file_popup")) + { + ShowExampleMenuFile(); + ImGui::EndPopup(); + } + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Context menus")) + { + HelpMarker("\"Context\" functions are simple helpers to associate a Popup to a given Item or Window identifier."); + + // BeginPopupContextItem() is a helper to provide common/simple popup behavior of essentially doing: + // if (id == 0) + // id = GetItemID(); // Use last item id + // if (IsItemHovered() && IsMouseReleased(ImGuiMouseButton_Right)) + // OpenPopup(id); + // return BeginPopup(id); + // For advanced advanced uses you may want to replicate and customize this code. + // See more details in BeginPopupContextItem(). + + // Example 1 + // When used after an item that has an ID (e.g. Button), we can skip providing an ID to BeginPopupContextItem(), + // and BeginPopupContextItem() will use the last item ID as the popup ID. + { + const char* names[5] = { "Label1", "Label2", "Label3", "Label4", "Label5" }; + for (int n = 0; n < 5; n++) + { + ImGui::Selectable(names[n]); + if (ImGui::BeginPopupContextItem()) // <-- use last item id as popup id + { + ImGui::Text("This a popup for \"%s\"!", names[n]); + if (ImGui::Button("Close")) + ImGui::CloseCurrentPopup(); + ImGui::EndPopup(); + } + if (ImGui::IsItemHovered()) + ImGui::SetTooltip("Right-click to open popup"); + } + } + + // Example 2 + // Popup on a Text() element which doesn't have an identifier: we need to provide an identifier to BeginPopupContextItem(). + // Using an explicit identifier is also convenient if you want to activate the popups from different locations. + { + HelpMarker("Text() elements don't have stable identifiers so we need to provide one."); + static float value = 0.5f; + ImGui::Text("Value = %.3f <-- (1) right-click this value", value); + if (ImGui::BeginPopupContextItem("my popup")) + { + if (ImGui::Selectable("Set to zero")) value = 0.0f; + if (ImGui::Selectable("Set to PI")) value = 3.1415f; + ImGui::SetNextItemWidth(-FLT_MIN); + ImGui::DragFloat("##Value", &value, 0.1f, 0.0f, 0.0f); + ImGui::EndPopup(); + } + + // We can also use OpenPopupOnItemClick() to toggle the visibility of a given popup. + // Here we make it that right-clicking this other text element opens the same popup as above. + // The popup itself will be submitted by the code above. + ImGui::Text("(2) Or right-click this text"); + ImGui::OpenPopupOnItemClick("my popup", ImGuiPopupFlags_MouseButtonRight); + + // Back to square one: manually open the same popup. + if (ImGui::Button("(3) Or click this button")) + ImGui::OpenPopup("my popup"); + } + + // Example 3 + // When using BeginPopupContextItem() with an implicit identifier (NULL == use last item ID), + // we need to make sure your item identifier is stable. + // In this example we showcase altering the item label while preserving its identifier, using the ### operator (see FAQ). + { + HelpMarker("Showcase using a popup ID linked to item ID, with the item having a changing label + stable ID using the ### operator."); + static char name[32] = "Label1"; + char buf[64]; + sprintf(buf, "Button: %s###Button", name); // ### operator override ID ignoring the preceding label + ImGui::Button(buf); + if (ImGui::BeginPopupContextItem()) + { + ImGui::Text("Edit name:"); + ImGui::InputText("##edit", name, IM_ARRAYSIZE(name)); + if (ImGui::Button("Close")) + ImGui::CloseCurrentPopup(); + ImGui::EndPopup(); + } + ImGui::SameLine(); ImGui::Text("(<-- right-click here)"); + } + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Modals")) + { + ImGui::TextWrapped("Modal windows are like popups but the user cannot close them by clicking outside."); + + if (ImGui::Button("Delete..")) + ImGui::OpenPopup("Delete?"); + + // Always center this window when appearing + ImVec2 center = ImGui::GetMainViewport()->GetCenter(); + ImGui::SetNextWindowPos(center, ImGuiCond_Appearing, ImVec2(0.5f, 0.5f)); + + if (ImGui::BeginPopupModal("Delete?", NULL, ImGuiWindowFlags_AlwaysAutoResize)) + { + ImGui::Text("All those beautiful files will be deleted.\nThis operation cannot be undone!\n\n"); + ImGui::Separator(); + + //static int unused_i = 0; + //ImGui::Combo("Combo", &unused_i, "Delete\0Delete harder\0"); + + static bool dont_ask_me_next_time = false; + ImGui::PushStyleVar(ImGuiStyleVar_FramePadding, ImVec2(0, 0)); + ImGui::Checkbox("Don't ask me next time", &dont_ask_me_next_time); + ImGui::PopStyleVar(); + + if (ImGui::Button("OK", ImVec2(120, 0))) { ImGui::CloseCurrentPopup(); } + ImGui::SetItemDefaultFocus(); + ImGui::SameLine(); + if (ImGui::Button("Cancel", ImVec2(120, 0))) { ImGui::CloseCurrentPopup(); } + ImGui::EndPopup(); + } + + if (ImGui::Button("Stacked modals..")) + ImGui::OpenPopup("Stacked 1"); + if (ImGui::BeginPopupModal("Stacked 1", NULL, ImGuiWindowFlags_MenuBar)) + { + if (ImGui::BeginMenuBar()) + { + if (ImGui::BeginMenu("File")) + { + if (ImGui::MenuItem("Some menu item")) {} + ImGui::EndMenu(); + } + ImGui::EndMenuBar(); + } + ImGui::Text("Hello from Stacked The First\nUsing style.Colors[ImGuiCol_ModalWindowDimBg] behind it."); + + // Testing behavior of widgets stacking their own regular popups over the modal. + static int item = 1; + static float color[4] = { 0.4f, 0.7f, 0.0f, 0.5f }; + ImGui::Combo("Combo", &item, "aaaa\0bbbb\0cccc\0dddd\0eeee\0\0"); + ImGui::ColorEdit4("color", color); + + if (ImGui::Button("Add another modal..")) + ImGui::OpenPopup("Stacked 2"); + + // Also demonstrate passing a bool* to BeginPopupModal(), this will create a regular close button which + // will close the popup. Note that the visibility state of popups is owned by imgui, so the input value + // of the bool actually doesn't matter here. + bool unused_open = true; + if (ImGui::BeginPopupModal("Stacked 2", &unused_open)) + { + ImGui::Text("Hello from Stacked The Second!"); + if (ImGui::Button("Close")) + ImGui::CloseCurrentPopup(); + ImGui::EndPopup(); + } + + if (ImGui::Button("Close")) + ImGui::CloseCurrentPopup(); + ImGui::EndPopup(); + } + + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Menus inside a regular window")) + { + ImGui::TextWrapped("Below we are testing adding menu items to a regular window. It's rather unusual but should work!"); + ImGui::Separator(); + + // Note: As a quirk in this very specific example, we want to differentiate the parent of this menu from the + // parent of the various popup menus above. To do so we are encloding the items in a PushID()/PopID() block + // to make them two different menusets. If we don't, opening any popup above and hovering our menu here would + // open it. This is because once a menu is active, we allow to switch to a sibling menu by just hovering on it, + // which is the desired behavior for regular menus. + ImGui::PushID("foo"); + ImGui::MenuItem("Menu item", "CTRL+M"); + if (ImGui::BeginMenu("Menu inside a regular window")) + { + ShowExampleMenuFile(); + ImGui::EndMenu(); + } + ImGui::PopID(); + ImGui::Separator(); + ImGui::TreePop(); + } +} + +// Dummy data structure that we use for the Table demo. +// (pre-C++11 doesn't allow us to instantiate ImVector template if this structure if defined inside the demo function) +namespace +{ +// We are passing our own identifier to TableSetupColumn() to facilitate identifying columns in the sorting code. +// This identifier will be passed down into ImGuiTableSortSpec::ColumnUserID. +// But it is possible to omit the user id parameter of TableSetupColumn() and just use the column index instead! (ImGuiTableSortSpec::ColumnIndex) +// If you don't use sorting, you will generally never care about giving column an ID! +enum MyItemColumnID +{ + MyItemColumnID_ID, + MyItemColumnID_Name, + MyItemColumnID_Action, + MyItemColumnID_Quantity, + MyItemColumnID_Description +}; + +struct MyItem +{ + int ID; + const char* Name; + int Quantity; + + // We have a problem which is affecting _only this demo_ and should not affect your code: + // As we don't rely on std:: or other third-party library to compile dear imgui, we only have reliable access to qsort(), + // however qsort doesn't allow passing user data to comparing function. + // As a workaround, we are storing the sort specs in a static/global for the comparing function to access. + // In your own use case you would probably pass the sort specs to your sorting/comparing functions directly and not use a global. + // We could technically call ImGui::TableGetSortSpecs() in CompareWithSortSpecs(), but considering that this function is called + // very often by the sorting algorithm it would be a little wasteful. + static const ImGuiTableSortSpecs* s_current_sort_specs; + + // Compare function to be used by qsort() + static int IMGUI_CDECL CompareWithSortSpecs(const void* lhs, const void* rhs) + { + const MyItem* a = (const MyItem*)lhs; + const MyItem* b = (const MyItem*)rhs; + for (int n = 0; n < s_current_sort_specs->SpecsCount; n++) + { + // Here we identify columns using the ColumnUserID value that we ourselves passed to TableSetupColumn() + // We could also choose to identify columns based on their index (sort_spec->ColumnIndex), which is simpler! + const ImGuiTableColumnSortSpecs* sort_spec = &s_current_sort_specs->Specs[n]; + int delta = 0; + switch (sort_spec->ColumnUserID) + { + case MyItemColumnID_ID: delta = (a->ID - b->ID); break; + case MyItemColumnID_Name: delta = (strcmp(a->Name, b->Name)); break; + case MyItemColumnID_Quantity: delta = (a->Quantity - b->Quantity); break; + case MyItemColumnID_Description: delta = (strcmp(a->Name, b->Name)); break; + default: IM_ASSERT(0); break; + } + if (delta > 0) + return (sort_spec->SortDirection == ImGuiSortDirection_Ascending) ? +1 : -1; + if (delta < 0) + return (sort_spec->SortDirection == ImGuiSortDirection_Ascending) ? -1 : +1; + } + + // qsort() is instable so always return a way to differenciate items. + // Your own compare function may want to avoid fallback on implicit sort specs e.g. a Name compare if it wasn't already part of the sort specs. + return (a->ID - b->ID); + } +}; +const ImGuiTableSortSpecs* MyItem::s_current_sort_specs = NULL; +} + +// Make the UI compact because there are so many fields +static void PushStyleCompact() +{ + ImGuiStyle& style = ImGui::GetStyle(); + ImGui::PushStyleVar(ImGuiStyleVar_FramePadding, ImVec2(style.FramePadding.x, (float)(int)(style.FramePadding.y * 0.60f))); + ImGui::PushStyleVar(ImGuiStyleVar_ItemSpacing, ImVec2(style.ItemSpacing.x, (float)(int)(style.ItemSpacing.y * 0.60f))); +} + +static void PopStyleCompact() +{ + ImGui::PopStyleVar(2); +} + +// Show a combo box with a choice of sizing policies +static void EditTableSizingFlags(ImGuiTableFlags* p_flags) +{ + struct EnumDesc { ImGuiTableFlags Value; const char* Name; const char* Tooltip; }; + static const EnumDesc policies[] = + { + { ImGuiTableFlags_None, "Default", "Use default sizing policy:\n- ImGuiTableFlags_SizingFixedFit if ScrollX is on or if host window has ImGuiWindowFlags_AlwaysAutoResize.\n- ImGuiTableFlags_SizingStretchSame otherwise." }, + { ImGuiTableFlags_SizingFixedFit, "ImGuiTableFlags_SizingFixedFit", "Columns default to _WidthFixed (if resizable) or _WidthAuto (if not resizable), matching contents width." }, + { ImGuiTableFlags_SizingFixedSame, "ImGuiTableFlags_SizingFixedSame", "Columns are all the same width, matching the maximum contents width.\nImplicitly disable ImGuiTableFlags_Resizable and enable ImGuiTableFlags_NoKeepColumnsVisible." }, + { ImGuiTableFlags_SizingStretchProp, "ImGuiTableFlags_SizingStretchProp", "Columns default to _WidthStretch with weights proportional to their widths." }, + { ImGuiTableFlags_SizingStretchSame, "ImGuiTableFlags_SizingStretchSame", "Columns default to _WidthStretch with same weights." } + }; + int idx; + for (idx = 0; idx < IM_ARRAYSIZE(policies); idx++) + if (policies[idx].Value == (*p_flags & ImGuiTableFlags_SizingMask_)) + break; + const char* preview_text = (idx < IM_ARRAYSIZE(policies)) ? policies[idx].Name + (idx > 0 ? strlen("ImGuiTableFlags") : 0) : ""; + if (ImGui::BeginCombo("Sizing Policy", preview_text)) + { + for (int n = 0; n < IM_ARRAYSIZE(policies); n++) + if (ImGui::Selectable(policies[n].Name, idx == n)) + *p_flags = (*p_flags & ~ImGuiTableFlags_SizingMask_) | policies[n].Value; + ImGui::EndCombo(); + } + ImGui::SameLine(); + ImGui::TextDisabled("(?)"); + if (ImGui::IsItemHovered()) + { + ImGui::BeginTooltip(); + ImGui::PushTextWrapPos(ImGui::GetFontSize() * 50.0f); + for (int m = 0; m < IM_ARRAYSIZE(policies); m++) + { + ImGui::Separator(); + ImGui::Text("%s:", policies[m].Name); + ImGui::Separator(); + ImGui::SetCursorPosX(ImGui::GetCursorPosX() + ImGui::GetStyle().IndentSpacing * 0.5f); + ImGui::TextUnformatted(policies[m].Tooltip); + } + ImGui::PopTextWrapPos(); + ImGui::EndTooltip(); + } +} + +static void EditTableColumnsFlags(ImGuiTableColumnFlags* p_flags) +{ + ImGui::CheckboxFlags("_Disabled", p_flags, ImGuiTableColumnFlags_Disabled); ImGui::SameLine(); HelpMarker("Master disable flag (also hide from context menu)"); + ImGui::CheckboxFlags("_DefaultHide", p_flags, ImGuiTableColumnFlags_DefaultHide); + ImGui::CheckboxFlags("_DefaultSort", p_flags, ImGuiTableColumnFlags_DefaultSort); + if (ImGui::CheckboxFlags("_WidthStretch", p_flags, ImGuiTableColumnFlags_WidthStretch)) + *p_flags &= ~(ImGuiTableColumnFlags_WidthMask_ ^ ImGuiTableColumnFlags_WidthStretch); + if (ImGui::CheckboxFlags("_WidthFixed", p_flags, ImGuiTableColumnFlags_WidthFixed)) + *p_flags &= ~(ImGuiTableColumnFlags_WidthMask_ ^ ImGuiTableColumnFlags_WidthFixed); + ImGui::CheckboxFlags("_NoResize", p_flags, ImGuiTableColumnFlags_NoResize); + ImGui::CheckboxFlags("_NoReorder", p_flags, ImGuiTableColumnFlags_NoReorder); + ImGui::CheckboxFlags("_NoHide", p_flags, ImGuiTableColumnFlags_NoHide); + ImGui::CheckboxFlags("_NoClip", p_flags, ImGuiTableColumnFlags_NoClip); + ImGui::CheckboxFlags("_NoSort", p_flags, ImGuiTableColumnFlags_NoSort); + ImGui::CheckboxFlags("_NoSortAscending", p_flags, ImGuiTableColumnFlags_NoSortAscending); + ImGui::CheckboxFlags("_NoSortDescending", p_flags, ImGuiTableColumnFlags_NoSortDescending); + ImGui::CheckboxFlags("_NoHeaderLabel", p_flags, ImGuiTableColumnFlags_NoHeaderLabel); + ImGui::CheckboxFlags("_NoHeaderWidth", p_flags, ImGuiTableColumnFlags_NoHeaderWidth); + ImGui::CheckboxFlags("_PreferSortAscending", p_flags, ImGuiTableColumnFlags_PreferSortAscending); + ImGui::CheckboxFlags("_PreferSortDescending", p_flags, ImGuiTableColumnFlags_PreferSortDescending); + ImGui::CheckboxFlags("_IndentEnable", p_flags, ImGuiTableColumnFlags_IndentEnable); ImGui::SameLine(); HelpMarker("Default for column 0"); + ImGui::CheckboxFlags("_IndentDisable", p_flags, ImGuiTableColumnFlags_IndentDisable); ImGui::SameLine(); HelpMarker("Default for column >0"); +} + +static void ShowTableColumnsStatusFlags(ImGuiTableColumnFlags flags) +{ + ImGui::CheckboxFlags("_IsEnabled", &flags, ImGuiTableColumnFlags_IsEnabled); + ImGui::CheckboxFlags("_IsVisible", &flags, ImGuiTableColumnFlags_IsVisible); + ImGui::CheckboxFlags("_IsSorted", &flags, ImGuiTableColumnFlags_IsSorted); + ImGui::CheckboxFlags("_IsHovered", &flags, ImGuiTableColumnFlags_IsHovered); +} + +static void ShowDemoWindowTables() +{ + //ImGui::SetNextItemOpen(true, ImGuiCond_Once); + if (!ImGui::CollapsingHeader("Tables & Columns")) + return; + + // Using those as a base value to create width/height that are factor of the size of our font + const float TEXT_BASE_WIDTH = ImGui::CalcTextSize("A").x; + const float TEXT_BASE_HEIGHT = ImGui::GetTextLineHeightWithSpacing(); + + ImGui::PushID("Tables"); + + int open_action = -1; + if (ImGui::Button("Open all")) + open_action = 1; + ImGui::SameLine(); + if (ImGui::Button("Close all")) + open_action = 0; + ImGui::SameLine(); + + // Options + static bool disable_indent = false; + ImGui::Checkbox("Disable tree indentation", &disable_indent); + ImGui::SameLine(); + HelpMarker("Disable the indenting of tree nodes so demo tables can use the full window width."); + ImGui::Separator(); + if (disable_indent) + ImGui::PushStyleVar(ImGuiStyleVar_IndentSpacing, 0.0f); + + // About Styling of tables + // Most settings are configured on a per-table basis via the flags passed to BeginTable() and TableSetupColumns APIs. + // There are however a few settings that a shared and part of the ImGuiStyle structure: + // style.CellPadding // Padding within each cell + // style.Colors[ImGuiCol_TableHeaderBg] // Table header background + // style.Colors[ImGuiCol_TableBorderStrong] // Table outer and header borders + // style.Colors[ImGuiCol_TableBorderLight] // Table inner borders + // style.Colors[ImGuiCol_TableRowBg] // Table row background when ImGuiTableFlags_RowBg is enabled (even rows) + // style.Colors[ImGuiCol_TableRowBgAlt] // Table row background when ImGuiTableFlags_RowBg is enabled (odds rows) + + // Demos + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Basic")) + { + // Here we will showcase three different ways to output a table. + // They are very simple variations of a same thing! + + // [Method 1] Using TableNextRow() to create a new row, and TableSetColumnIndex() to select the column. + // In many situations, this is the most flexible and easy to use pattern. + HelpMarker("Using TableNextRow() + calling TableSetColumnIndex() _before_ each cell, in a loop."); + if (ImGui::BeginTable("table1", 3)) + { + for (int row = 0; row < 4; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + ImGui::TableSetColumnIndex(column); + ImGui::Text("Row %d Column %d", row, column); + } + } + ImGui::EndTable(); + } + + // [Method 2] Using TableNextColumn() called multiple times, instead of using a for loop + TableSetColumnIndex(). + // This is generally more convenient when you have code manually submitting the contents of each columns. + HelpMarker("Using TableNextRow() + calling TableNextColumn() _before_ each cell, manually."); + if (ImGui::BeginTable("table2", 3)) + { + for (int row = 0; row < 4; row++) + { + ImGui::TableNextRow(); + ImGui::TableNextColumn(); + ImGui::Text("Row %d", row); + ImGui::TableNextColumn(); + ImGui::Text("Some contents"); + ImGui::TableNextColumn(); + ImGui::Text("123.456"); + } + ImGui::EndTable(); + } + + // [Method 3] We call TableNextColumn() _before_ each cell. We never call TableNextRow(), + // as TableNextColumn() will automatically wrap around and create new roes as needed. + // This is generally more convenient when your cells all contains the same type of data. + HelpMarker( + "Only using TableNextColumn(), which tends to be convenient for tables where every cells contains the same type of contents.\n" + "This is also more similar to the old NextColumn() function of the Columns API, and provided to facilitate the Columns->Tables API transition."); + if (ImGui::BeginTable("table3", 3)) + { + for (int item = 0; item < 14; item++) + { + ImGui::TableNextColumn(); + ImGui::Text("Item %d", item); + } + ImGui::EndTable(); + } + + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Borders, background")) + { + // Expose a few Borders related flags interactively + enum ContentsType { CT_Text, CT_FillButton }; + static ImGuiTableFlags flags = ImGuiTableFlags_Borders | ImGuiTableFlags_RowBg; + static bool display_headers = false; + static int contents_type = CT_Text; + + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_RowBg", &flags, ImGuiTableFlags_RowBg); + ImGui::CheckboxFlags("ImGuiTableFlags_Borders", &flags, ImGuiTableFlags_Borders); + ImGui::SameLine(); HelpMarker("ImGuiTableFlags_Borders\n = ImGuiTableFlags_BordersInnerV\n | ImGuiTableFlags_BordersOuterV\n | ImGuiTableFlags_BordersInnerV\n | ImGuiTableFlags_BordersOuterH"); + ImGui::Indent(); + + ImGui::CheckboxFlags("ImGuiTableFlags_BordersH", &flags, ImGuiTableFlags_BordersH); + ImGui::Indent(); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersOuterH", &flags, ImGuiTableFlags_BordersOuterH); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersInnerH", &flags, ImGuiTableFlags_BordersInnerH); + ImGui::Unindent(); + + ImGui::CheckboxFlags("ImGuiTableFlags_BordersV", &flags, ImGuiTableFlags_BordersV); + ImGui::Indent(); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersOuterV", &flags, ImGuiTableFlags_BordersOuterV); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersInnerV", &flags, ImGuiTableFlags_BordersInnerV); + ImGui::Unindent(); + + ImGui::CheckboxFlags("ImGuiTableFlags_BordersOuter", &flags, ImGuiTableFlags_BordersOuter); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersInner", &flags, ImGuiTableFlags_BordersInner); + ImGui::Unindent(); + + ImGui::AlignTextToFramePadding(); ImGui::Text("Cell contents:"); + ImGui::SameLine(); ImGui::RadioButton("Text", &contents_type, CT_Text); + ImGui::SameLine(); ImGui::RadioButton("FillButton", &contents_type, CT_FillButton); + ImGui::Checkbox("Display headers", &display_headers); + ImGui::CheckboxFlags("ImGuiTableFlags_NoBordersInBody", &flags, ImGuiTableFlags_NoBordersInBody); ImGui::SameLine(); HelpMarker("Disable vertical borders in columns Body (borders will always appears in Headers"); + PopStyleCompact(); + + if (ImGui::BeginTable("table1", 3, flags)) + { + // Display headers so we can inspect their interaction with borders. + // (Headers are not the main purpose of this section of the demo, so we are not elaborating on them too much. See other sections for details) + if (display_headers) + { + ImGui::TableSetupColumn("One"); + ImGui::TableSetupColumn("Two"); + ImGui::TableSetupColumn("Three"); + ImGui::TableHeadersRow(); + } + + for (int row = 0; row < 5; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + ImGui::TableSetColumnIndex(column); + char buf[32]; + sprintf(buf, "Hello %d,%d", column, row); + if (contents_type == CT_Text) + ImGui::TextUnformatted(buf); + else if (contents_type) + ImGui::Button(buf, ImVec2(-FLT_MIN, 0.0f)); + } + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Resizable, stretch")) + { + // By default, if we don't enable ScrollX the sizing policy for each columns is "Stretch" + // Each columns maintain a sizing weight, and they will occupy all available width. + static ImGuiTableFlags flags = ImGuiTableFlags_SizingStretchSame | ImGuiTableFlags_Resizable | ImGuiTableFlags_BordersOuter | ImGuiTableFlags_BordersV | ImGuiTableFlags_ContextMenuInBody; + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_Resizable", &flags, ImGuiTableFlags_Resizable); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersV", &flags, ImGuiTableFlags_BordersV); + ImGui::SameLine(); HelpMarker("Using the _Resizable flag automatically enables the _BordersInnerV flag as well, this is why the resize borders are still showing when unchecking this."); + PopStyleCompact(); + + if (ImGui::BeginTable("table1", 3, flags)) + { + for (int row = 0; row < 5; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + ImGui::TableSetColumnIndex(column); + ImGui::Text("Hello %d,%d", column, row); + } + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Resizable, fixed")) + { + // Here we use ImGuiTableFlags_SizingFixedFit (even though _ScrollX is not set) + // So columns will adopt the "Fixed" policy and will maintain a fixed width regardless of the whole available width (unless table is small) + // If there is not enough available width to fit all columns, they will however be resized down. + // FIXME-TABLE: Providing a stretch-on-init would make sense especially for tables which don't have saved settings + HelpMarker( + "Using _Resizable + _SizingFixedFit flags.\n" + "Fixed-width columns generally makes more sense if you want to use horizontal scrolling.\n\n" + "Double-click a column border to auto-fit the column to its contents."); + PushStyleCompact(); + static ImGuiTableFlags flags = ImGuiTableFlags_SizingFixedFit | ImGuiTableFlags_Resizable | ImGuiTableFlags_BordersOuter | ImGuiTableFlags_BordersV | ImGuiTableFlags_ContextMenuInBody; + ImGui::CheckboxFlags("ImGuiTableFlags_NoHostExtendX", &flags, ImGuiTableFlags_NoHostExtendX); + PopStyleCompact(); + + if (ImGui::BeginTable("table1", 3, flags)) + { + for (int row = 0; row < 5; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + ImGui::TableSetColumnIndex(column); + ImGui::Text("Hello %d,%d", column, row); + } + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Resizable, mixed")) + { + HelpMarker( + "Using TableSetupColumn() to alter resizing policy on a per-column basis.\n\n" + "When combining Fixed and Stretch columns, generally you only want one, maybe two trailing columns to use _WidthStretch."); + static ImGuiTableFlags flags = ImGuiTableFlags_SizingFixedFit | ImGuiTableFlags_RowBg | ImGuiTableFlags_Borders | ImGuiTableFlags_Resizable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable; + + if (ImGui::BeginTable("table1", 3, flags)) + { + ImGui::TableSetupColumn("AAA", ImGuiTableColumnFlags_WidthFixed); + ImGui::TableSetupColumn("BBB", ImGuiTableColumnFlags_WidthFixed); + ImGui::TableSetupColumn("CCC", ImGuiTableColumnFlags_WidthStretch); + ImGui::TableHeadersRow(); + for (int row = 0; row < 5; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + ImGui::TableSetColumnIndex(column); + ImGui::Text("%s %d,%d", (column == 2) ? "Stretch" : "Fixed", column, row); + } + } + ImGui::EndTable(); + } + if (ImGui::BeginTable("table2", 6, flags)) + { + ImGui::TableSetupColumn("AAA", ImGuiTableColumnFlags_WidthFixed); + ImGui::TableSetupColumn("BBB", ImGuiTableColumnFlags_WidthFixed); + ImGui::TableSetupColumn("CCC", ImGuiTableColumnFlags_WidthFixed | ImGuiTableColumnFlags_DefaultHide); + ImGui::TableSetupColumn("DDD", ImGuiTableColumnFlags_WidthStretch); + ImGui::TableSetupColumn("EEE", ImGuiTableColumnFlags_WidthStretch); + ImGui::TableSetupColumn("FFF", ImGuiTableColumnFlags_WidthStretch | ImGuiTableColumnFlags_DefaultHide); + ImGui::TableHeadersRow(); + for (int row = 0; row < 5; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 6; column++) + { + ImGui::TableSetColumnIndex(column); + ImGui::Text("%s %d,%d", (column >= 3) ? "Stretch" : "Fixed", column, row); + } + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Reorderable, hideable, with headers")) + { + HelpMarker( + "Click and drag column headers to reorder columns.\n\n" + "Right-click on a header to open a context menu."); + static ImGuiTableFlags flags = ImGuiTableFlags_Resizable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable | ImGuiTableFlags_BordersOuter | ImGuiTableFlags_BordersV; + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_Resizable", &flags, ImGuiTableFlags_Resizable); + ImGui::CheckboxFlags("ImGuiTableFlags_Reorderable", &flags, ImGuiTableFlags_Reorderable); + ImGui::CheckboxFlags("ImGuiTableFlags_Hideable", &flags, ImGuiTableFlags_Hideable); + ImGui::CheckboxFlags("ImGuiTableFlags_NoBordersInBody", &flags, ImGuiTableFlags_NoBordersInBody); + ImGui::CheckboxFlags("ImGuiTableFlags_NoBordersInBodyUntilResize", &flags, ImGuiTableFlags_NoBordersInBodyUntilResize); ImGui::SameLine(); HelpMarker("Disable vertical borders in columns Body until hovered for resize (borders will always appears in Headers)"); + PopStyleCompact(); + + if (ImGui::BeginTable("table1", 3, flags)) + { + // Submit columns name with TableSetupColumn() and call TableHeadersRow() to create a row with a header in each column. + // (Later we will show how TableSetupColumn() has other uses, optional flags, sizing weight etc.) + ImGui::TableSetupColumn("One"); + ImGui::TableSetupColumn("Two"); + ImGui::TableSetupColumn("Three"); + ImGui::TableHeadersRow(); + for (int row = 0; row < 6; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + ImGui::TableSetColumnIndex(column); + ImGui::Text("Hello %d,%d", column, row); + } + } + ImGui::EndTable(); + } + + // Use outer_size.x == 0.0f instead of default to make the table as tight as possible (only valid when no scrolling and no stretch column) + if (ImGui::BeginTable("table2", 3, flags | ImGuiTableFlags_SizingFixedFit, ImVec2(0.0f, 0.0f))) + { + ImGui::TableSetupColumn("One"); + ImGui::TableSetupColumn("Two"); + ImGui::TableSetupColumn("Three"); + ImGui::TableHeadersRow(); + for (int row = 0; row < 6; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + ImGui::TableSetColumnIndex(column); + ImGui::Text("Fixed %d,%d", column, row); + } + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Padding")) + { + // First example: showcase use of padding flags and effect of BorderOuterV/BorderInnerV on X padding. + // We don't expose BorderOuterH/BorderInnerH here because they have no effect on X padding. + HelpMarker( + "We often want outer padding activated when any using features which makes the edges of a column visible:\n" + "e.g.:\n" + "- BorderOuterV\n" + "- any form of row selection\n" + "Because of this, activating BorderOuterV sets the default to PadOuterX. Using PadOuterX or NoPadOuterX you can override the default.\n\n" + "Actual padding values are using style.CellPadding.\n\n" + "In this demo we don't show horizontal borders to emphasis how they don't affect default horizontal padding."); + + static ImGuiTableFlags flags1 = ImGuiTableFlags_BordersV; + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_PadOuterX", &flags1, ImGuiTableFlags_PadOuterX); + ImGui::SameLine(); HelpMarker("Enable outer-most padding (default if ImGuiTableFlags_BordersOuterV is set)"); + ImGui::CheckboxFlags("ImGuiTableFlags_NoPadOuterX", &flags1, ImGuiTableFlags_NoPadOuterX); + ImGui::SameLine(); HelpMarker("Disable outer-most padding (default if ImGuiTableFlags_BordersOuterV is not set)"); + ImGui::CheckboxFlags("ImGuiTableFlags_NoPadInnerX", &flags1, ImGuiTableFlags_NoPadInnerX); + ImGui::SameLine(); HelpMarker("Disable inner padding between columns (double inner padding if BordersOuterV is on, single inner padding if BordersOuterV is off)"); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersOuterV", &flags1, ImGuiTableFlags_BordersOuterV); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersInnerV", &flags1, ImGuiTableFlags_BordersInnerV); + static bool show_headers = false; + ImGui::Checkbox("show_headers", &show_headers); + PopStyleCompact(); + + if (ImGui::BeginTable("table_padding", 3, flags1)) + { + if (show_headers) + { + ImGui::TableSetupColumn("One"); + ImGui::TableSetupColumn("Two"); + ImGui::TableSetupColumn("Three"); + ImGui::TableHeadersRow(); + } + + for (int row = 0; row < 5; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + ImGui::TableSetColumnIndex(column); + if (row == 0) + { + ImGui::Text("Avail %.2f", ImGui::GetContentRegionAvail().x); + } + else + { + char buf[32]; + sprintf(buf, "Hello %d,%d", column, row); + ImGui::Button(buf, ImVec2(-FLT_MIN, 0.0f)); + } + //if (ImGui::TableGetColumnFlags() & ImGuiTableColumnFlags_IsHovered) + // ImGui::TableSetBgColor(ImGuiTableBgTarget_CellBg, IM_COL32(0, 100, 0, 255)); + } + } + ImGui::EndTable(); + } + + // Second example: set style.CellPadding to (0.0) or a custom value. + // FIXME-TABLE: Vertical border effectively not displayed the same way as horizontal one... + HelpMarker("Setting style.CellPadding to (0,0) or a custom value."); + static ImGuiTableFlags flags2 = ImGuiTableFlags_Borders | ImGuiTableFlags_RowBg; + static ImVec2 cell_padding(0.0f, 0.0f); + static bool show_widget_frame_bg = true; + + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_Borders", &flags2, ImGuiTableFlags_Borders); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersH", &flags2, ImGuiTableFlags_BordersH); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersV", &flags2, ImGuiTableFlags_BordersV); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersInner", &flags2, ImGuiTableFlags_BordersInner); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersOuter", &flags2, ImGuiTableFlags_BordersOuter); + ImGui::CheckboxFlags("ImGuiTableFlags_RowBg", &flags2, ImGuiTableFlags_RowBg); + ImGui::CheckboxFlags("ImGuiTableFlags_Resizable", &flags2, ImGuiTableFlags_Resizable); + ImGui::Checkbox("show_widget_frame_bg", &show_widget_frame_bg); + ImGui::SliderFloat2("CellPadding", &cell_padding.x, 0.0f, 10.0f, "%.0f"); + PopStyleCompact(); + + ImGui::PushStyleVar(ImGuiStyleVar_CellPadding, cell_padding); + if (ImGui::BeginTable("table_padding_2", 3, flags2)) + { + static char text_bufs[3 * 5][16]; // Mini text storage for 3x5 cells + static bool init = true; + if (!show_widget_frame_bg) + ImGui::PushStyleColor(ImGuiCol_FrameBg, 0); + for (int cell = 0; cell < 3 * 5; cell++) + { + ImGui::TableNextColumn(); + if (init) + strcpy(text_bufs[cell], "edit me"); + ImGui::SetNextItemWidth(-FLT_MIN); + ImGui::PushID(cell); + ImGui::InputText("##cell", text_bufs[cell], IM_ARRAYSIZE(text_bufs[cell])); + ImGui::PopID(); + } + if (!show_widget_frame_bg) + ImGui::PopStyleColor(); + init = false; + ImGui::EndTable(); + } + ImGui::PopStyleVar(); + + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Sizing policies")) + { + static ImGuiTableFlags flags1 = ImGuiTableFlags_BordersV | ImGuiTableFlags_BordersOuterH | ImGuiTableFlags_RowBg | ImGuiTableFlags_ContextMenuInBody; + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_Resizable", &flags1, ImGuiTableFlags_Resizable); + ImGui::CheckboxFlags("ImGuiTableFlags_NoHostExtendX", &flags1, ImGuiTableFlags_NoHostExtendX); + PopStyleCompact(); + + static ImGuiTableFlags sizing_policy_flags[4] = { ImGuiTableFlags_SizingFixedFit, ImGuiTableFlags_SizingFixedSame, ImGuiTableFlags_SizingStretchProp, ImGuiTableFlags_SizingStretchSame }; + for (int table_n = 0; table_n < 4; table_n++) + { + ImGui::PushID(table_n); + ImGui::SetNextItemWidth(TEXT_BASE_WIDTH * 30); + EditTableSizingFlags(&sizing_policy_flags[table_n]); + + // To make it easier to understand the different sizing policy, + // For each policy: we display one table where the columns have equal contents width, and one where the columns have different contents width. + if (ImGui::BeginTable("table1", 3, sizing_policy_flags[table_n] | flags1)) + { + for (int row = 0; row < 3; row++) + { + ImGui::TableNextRow(); + ImGui::TableNextColumn(); ImGui::Text("Oh dear"); + ImGui::TableNextColumn(); ImGui::Text("Oh dear"); + ImGui::TableNextColumn(); ImGui::Text("Oh dear"); + } + ImGui::EndTable(); + } + if (ImGui::BeginTable("table2", 3, sizing_policy_flags[table_n] | flags1)) + { + for (int row = 0; row < 3; row++) + { + ImGui::TableNextRow(); + ImGui::TableNextColumn(); ImGui::Text("AAAA"); + ImGui::TableNextColumn(); ImGui::Text("BBBBBBBB"); + ImGui::TableNextColumn(); ImGui::Text("CCCCCCCCCCCC"); + } + ImGui::EndTable(); + } + ImGui::PopID(); + } + + ImGui::Spacing(); + ImGui::TextUnformatted("Advanced"); + ImGui::SameLine(); + HelpMarker("This section allows you to interact and see the effect of various sizing policies depending on whether Scroll is enabled and the contents of your columns."); + + enum ContentsType { CT_ShowWidth, CT_ShortText, CT_LongText, CT_Button, CT_FillButton, CT_InputText }; + static ImGuiTableFlags flags = ImGuiTableFlags_ScrollY | ImGuiTableFlags_Borders | ImGuiTableFlags_RowBg | ImGuiTableFlags_Resizable; + static int contents_type = CT_ShowWidth; + static int column_count = 3; + + PushStyleCompact(); + ImGui::PushID("Advanced"); + ImGui::PushItemWidth(TEXT_BASE_WIDTH * 30); + EditTableSizingFlags(&flags); + ImGui::Combo("Contents", &contents_type, "Show width\0Short Text\0Long Text\0Button\0Fill Button\0InputText\0"); + if (contents_type == CT_FillButton) + { + ImGui::SameLine(); + HelpMarker("Be mindful that using right-alignment (e.g. size.x = -FLT_MIN) creates a feedback loop where contents width can feed into auto-column width can feed into contents width."); + } + ImGui::DragInt("Columns", &column_count, 0.1f, 1, 64, "%d", ImGuiSliderFlags_AlwaysClamp); + ImGui::CheckboxFlags("ImGuiTableFlags_Resizable", &flags, ImGuiTableFlags_Resizable); + ImGui::CheckboxFlags("ImGuiTableFlags_PreciseWidths", &flags, ImGuiTableFlags_PreciseWidths); + ImGui::SameLine(); HelpMarker("Disable distributing remainder width to stretched columns (width allocation on a 100-wide table with 3 columns: Without this flag: 33,33,34. With this flag: 33,33,33). With larger number of columns, resizing will appear to be less smooth."); + ImGui::CheckboxFlags("ImGuiTableFlags_ScrollX", &flags, ImGuiTableFlags_ScrollX); + ImGui::CheckboxFlags("ImGuiTableFlags_ScrollY", &flags, ImGuiTableFlags_ScrollY); + ImGui::CheckboxFlags("ImGuiTableFlags_NoClip", &flags, ImGuiTableFlags_NoClip); + ImGui::PopItemWidth(); + ImGui::PopID(); + PopStyleCompact(); + + if (ImGui::BeginTable("table2", column_count, flags, ImVec2(0.0f, TEXT_BASE_HEIGHT * 7))) + { + for (int cell = 0; cell < 10 * column_count; cell++) + { + ImGui::TableNextColumn(); + int column = ImGui::TableGetColumnIndex(); + int row = ImGui::TableGetRowIndex(); + + ImGui::PushID(cell); + char label[32]; + static char text_buf[32] = ""; + sprintf(label, "Hello %d,%d", column, row); + switch (contents_type) + { + case CT_ShortText: ImGui::TextUnformatted(label); break; + case CT_LongText: ImGui::Text("Some %s text %d,%d\nOver two lines..", column == 0 ? "long" : "longeeer", column, row); break; + case CT_ShowWidth: ImGui::Text("W: %.1f", ImGui::GetContentRegionAvail().x); break; + case CT_Button: ImGui::Button(label); break; + case CT_FillButton: ImGui::Button(label, ImVec2(-FLT_MIN, 0.0f)); break; + case CT_InputText: ImGui::SetNextItemWidth(-FLT_MIN); ImGui::InputText("##", text_buf, IM_ARRAYSIZE(text_buf)); break; + } + ImGui::PopID(); + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Vertical scrolling, with clipping")) + { + HelpMarker("Here we activate ScrollY, which will create a child window container to allow hosting scrollable contents.\n\nWe also demonstrate using ImGuiListClipper to virtualize the submission of many items."); + static ImGuiTableFlags flags = ImGuiTableFlags_ScrollY | ImGuiTableFlags_RowBg | ImGuiTableFlags_BordersOuter | ImGuiTableFlags_BordersV | ImGuiTableFlags_Resizable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable; + + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_ScrollY", &flags, ImGuiTableFlags_ScrollY); + PopStyleCompact(); + + // When using ScrollX or ScrollY we need to specify a size for our table container! + // Otherwise by default the table will fit all available space, like a BeginChild() call. + ImVec2 outer_size = ImVec2(0.0f, TEXT_BASE_HEIGHT * 8); + if (ImGui::BeginTable("table_scrolly", 3, flags, outer_size)) + { + ImGui::TableSetupScrollFreeze(0, 1); // Make top row always visible + ImGui::TableSetupColumn("One", ImGuiTableColumnFlags_None); + ImGui::TableSetupColumn("Two", ImGuiTableColumnFlags_None); + ImGui::TableSetupColumn("Three", ImGuiTableColumnFlags_None); + ImGui::TableHeadersRow(); + + // Demonstrate using clipper for large vertical lists + ImGuiListClipper clipper; + clipper.Begin(1000); + while (clipper.Step()) + { + for (int row = clipper.DisplayStart; row < clipper.DisplayEnd; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + ImGui::TableSetColumnIndex(column); + ImGui::Text("Hello %d,%d", column, row); + } + } + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Horizontal scrolling")) + { + HelpMarker( + "When ScrollX is enabled, the default sizing policy becomes ImGuiTableFlags_SizingFixedFit, " + "as automatically stretching columns doesn't make much sense with horizontal scrolling.\n\n" + "Also note that as of the current version, you will almost always want to enable ScrollY along with ScrollX," + "because the container window won't automatically extend vertically to fix contents (this may be improved in future versions)."); + static ImGuiTableFlags flags = ImGuiTableFlags_ScrollX | ImGuiTableFlags_ScrollY | ImGuiTableFlags_RowBg | ImGuiTableFlags_BordersOuter | ImGuiTableFlags_BordersV | ImGuiTableFlags_Resizable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable; + static int freeze_cols = 1; + static int freeze_rows = 1; + + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_Resizable", &flags, ImGuiTableFlags_Resizable); + ImGui::CheckboxFlags("ImGuiTableFlags_ScrollX", &flags, ImGuiTableFlags_ScrollX); + ImGui::CheckboxFlags("ImGuiTableFlags_ScrollY", &flags, ImGuiTableFlags_ScrollY); + ImGui::SetNextItemWidth(ImGui::GetFrameHeight()); + ImGui::DragInt("freeze_cols", &freeze_cols, 0.2f, 0, 9, NULL, ImGuiSliderFlags_NoInput); + ImGui::SetNextItemWidth(ImGui::GetFrameHeight()); + ImGui::DragInt("freeze_rows", &freeze_rows, 0.2f, 0, 9, NULL, ImGuiSliderFlags_NoInput); + PopStyleCompact(); + + // When using ScrollX or ScrollY we need to specify a size for our table container! + // Otherwise by default the table will fit all available space, like a BeginChild() call. + ImVec2 outer_size = ImVec2(0.0f, TEXT_BASE_HEIGHT * 8); + if (ImGui::BeginTable("table_scrollx", 7, flags, outer_size)) + { + ImGui::TableSetupScrollFreeze(freeze_cols, freeze_rows); + ImGui::TableSetupColumn("Line #", ImGuiTableColumnFlags_NoHide); // Make the first column not hideable to match our use of TableSetupScrollFreeze() + ImGui::TableSetupColumn("One"); + ImGui::TableSetupColumn("Two"); + ImGui::TableSetupColumn("Three"); + ImGui::TableSetupColumn("Four"); + ImGui::TableSetupColumn("Five"); + ImGui::TableSetupColumn("Six"); + ImGui::TableHeadersRow(); + for (int row = 0; row < 20; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 7; column++) + { + // Both TableNextColumn() and TableSetColumnIndex() return true when a column is visible or performing width measurement. + // Because here we know that: + // - A) all our columns are contributing the same to row height + // - B) column 0 is always visible, + // We only always submit this one column and can skip others. + // More advanced per-column clipping behaviors may benefit from polling the status flags via TableGetColumnFlags(). + if (!ImGui::TableSetColumnIndex(column) && column > 0) + continue; + if (column == 0) + ImGui::Text("Line %d", row); + else + ImGui::Text("Hello world %d,%d", column, row); + } + } + ImGui::EndTable(); + } + + ImGui::Spacing(); + ImGui::TextUnformatted("Stretch + ScrollX"); + ImGui::SameLine(); + HelpMarker( + "Showcase using Stretch columns + ScrollX together: " + "this is rather unusual and only makes sense when specifying an 'inner_width' for the table!\n" + "Without an explicit value, inner_width is == outer_size.x and therefore using Stretch columns + ScrollX together doesn't make sense."); + static ImGuiTableFlags flags2 = ImGuiTableFlags_SizingStretchSame | ImGuiTableFlags_ScrollX | ImGuiTableFlags_ScrollY | ImGuiTableFlags_BordersOuter | ImGuiTableFlags_RowBg | ImGuiTableFlags_ContextMenuInBody; + static float inner_width = 1000.0f; + PushStyleCompact(); + ImGui::PushID("flags3"); + ImGui::PushItemWidth(TEXT_BASE_WIDTH * 30); + ImGui::CheckboxFlags("ImGuiTableFlags_ScrollX", &flags2, ImGuiTableFlags_ScrollX); + ImGui::DragFloat("inner_width", &inner_width, 1.0f, 0.0f, FLT_MAX, "%.1f"); + ImGui::PopItemWidth(); + ImGui::PopID(); + PopStyleCompact(); + if (ImGui::BeginTable("table2", 7, flags2, outer_size, inner_width)) + { + for (int cell = 0; cell < 20 * 7; cell++) + { + ImGui::TableNextColumn(); + ImGui::Text("Hello world %d,%d", ImGui::TableGetColumnIndex(), ImGui::TableGetRowIndex()); + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Columns flags")) + { + // Create a first table just to show all the options/flags we want to make visible in our example! + const int column_count = 3; + const char* column_names[column_count] = { "One", "Two", "Three" }; + static ImGuiTableColumnFlags column_flags[column_count] = { ImGuiTableColumnFlags_DefaultSort, ImGuiTableColumnFlags_None, ImGuiTableColumnFlags_DefaultHide }; + static ImGuiTableColumnFlags column_flags_out[column_count] = { 0, 0, 0 }; // Output from TableGetColumnFlags() + + if (ImGui::BeginTable("table_columns_flags_checkboxes", column_count, ImGuiTableFlags_None)) + { + PushStyleCompact(); + for (int column = 0; column < column_count; column++) + { + ImGui::TableNextColumn(); + ImGui::PushID(column); + ImGui::AlignTextToFramePadding(); // FIXME-TABLE: Workaround for wrong text baseline propagation + ImGui::Text("'%s'", column_names[column]); + ImGui::Spacing(); + ImGui::Text("Input flags:"); + EditTableColumnsFlags(&column_flags[column]); + ImGui::Spacing(); + ImGui::Text("Output flags:"); + ShowTableColumnsStatusFlags(column_flags_out[column]); + ImGui::PopID(); + } + PopStyleCompact(); + ImGui::EndTable(); + } + + // Create the real table we care about for the example! + // We use a scrolling table to be able to showcase the difference between the _IsEnabled and _IsVisible flags above, otherwise in + // a non-scrolling table columns are always visible (unless using ImGuiTableFlags_NoKeepColumnsVisible + resizing the parent window down) + const ImGuiTableFlags flags + = ImGuiTableFlags_SizingFixedFit | ImGuiTableFlags_ScrollX | ImGuiTableFlags_ScrollY + | ImGuiTableFlags_RowBg | ImGuiTableFlags_BordersOuter | ImGuiTableFlags_BordersV + | ImGuiTableFlags_Resizable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable | ImGuiTableFlags_Sortable; + ImVec2 outer_size = ImVec2(0.0f, TEXT_BASE_HEIGHT * 9); + if (ImGui::BeginTable("table_columns_flags", column_count, flags, outer_size)) + { + for (int column = 0; column < column_count; column++) + ImGui::TableSetupColumn(column_names[column], column_flags[column]); + ImGui::TableHeadersRow(); + for (int column = 0; column < column_count; column++) + column_flags_out[column] = ImGui::TableGetColumnFlags(column); + float indent_step = (float)((int)TEXT_BASE_WIDTH / 2); + for (int row = 0; row < 8; row++) + { + ImGui::Indent(indent_step); // Add some indentation to demonstrate usage of per-column IndentEnable/IndentDisable flags. + ImGui::TableNextRow(); + for (int column = 0; column < column_count; column++) + { + ImGui::TableSetColumnIndex(column); + ImGui::Text("%s %s", (column == 0) ? "Indented" : "Hello", ImGui::TableGetColumnName(column)); + } + } + ImGui::Unindent(indent_step * 8.0f); + + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Columns widths")) + { + HelpMarker("Using TableSetupColumn() to setup default width."); + + static ImGuiTableFlags flags1 = ImGuiTableFlags_Borders | ImGuiTableFlags_NoBordersInBodyUntilResize; + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_Resizable", &flags1, ImGuiTableFlags_Resizable); + ImGui::CheckboxFlags("ImGuiTableFlags_NoBordersInBodyUntilResize", &flags1, ImGuiTableFlags_NoBordersInBodyUntilResize); + PopStyleCompact(); + if (ImGui::BeginTable("table1", 3, flags1)) + { + // We could also set ImGuiTableFlags_SizingFixedFit on the table and all columns will default to ImGuiTableColumnFlags_WidthFixed. + ImGui::TableSetupColumn("one", ImGuiTableColumnFlags_WidthFixed, 100.0f); // Default to 100.0f + ImGui::TableSetupColumn("two", ImGuiTableColumnFlags_WidthFixed, 200.0f); // Default to 200.0f + ImGui::TableSetupColumn("three", ImGuiTableColumnFlags_WidthFixed); // Default to auto + ImGui::TableHeadersRow(); + for (int row = 0; row < 4; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + ImGui::TableSetColumnIndex(column); + if (row == 0) + ImGui::Text("(w: %5.1f)", ImGui::GetContentRegionAvail().x); + else + ImGui::Text("Hello %d,%d", column, row); + } + } + ImGui::EndTable(); + } + + HelpMarker("Using TableSetupColumn() to setup explicit width.\n\nUnless _NoKeepColumnsVisible is set, fixed columns with set width may still be shrunk down if there's not enough space in the host."); + + static ImGuiTableFlags flags2 = ImGuiTableFlags_None; + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_NoKeepColumnsVisible", &flags2, ImGuiTableFlags_NoKeepColumnsVisible); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersInnerV", &flags2, ImGuiTableFlags_BordersInnerV); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersOuterV", &flags2, ImGuiTableFlags_BordersOuterV); + PopStyleCompact(); + if (ImGui::BeginTable("table2", 4, flags2)) + { + // We could also set ImGuiTableFlags_SizingFixedFit on the table and all columns will default to ImGuiTableColumnFlags_WidthFixed. + ImGui::TableSetupColumn("", ImGuiTableColumnFlags_WidthFixed, 100.0f); + ImGui::TableSetupColumn("", ImGuiTableColumnFlags_WidthFixed, TEXT_BASE_WIDTH * 15.0f); + ImGui::TableSetupColumn("", ImGuiTableColumnFlags_WidthFixed, TEXT_BASE_WIDTH * 30.0f); + ImGui::TableSetupColumn("", ImGuiTableColumnFlags_WidthFixed, TEXT_BASE_WIDTH * 15.0f); + for (int row = 0; row < 5; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 4; column++) + { + ImGui::TableSetColumnIndex(column); + if (row == 0) + ImGui::Text("(w: %5.1f)", ImGui::GetContentRegionAvail().x); + else + ImGui::Text("Hello %d,%d", column, row); + } + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Nested tables")) + { + HelpMarker("This demonstrate embedding a table into another table cell."); + + if (ImGui::BeginTable("table_nested1", 2, ImGuiTableFlags_Borders | ImGuiTableFlags_Resizable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable)) + { + ImGui::TableSetupColumn("A0"); + ImGui::TableSetupColumn("A1"); + ImGui::TableHeadersRow(); + + ImGui::TableNextColumn(); + ImGui::Text("A0 Row 0"); + { + float rows_height = TEXT_BASE_HEIGHT * 2; + if (ImGui::BeginTable("table_nested2", 2, ImGuiTableFlags_Borders | ImGuiTableFlags_Resizable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable)) + { + ImGui::TableSetupColumn("B0"); + ImGui::TableSetupColumn("B1"); + ImGui::TableHeadersRow(); + + ImGui::TableNextRow(ImGuiTableRowFlags_None, rows_height); + ImGui::TableNextColumn(); + ImGui::Text("B0 Row 0"); + ImGui::TableNextColumn(); + ImGui::Text("B1 Row 0"); + ImGui::TableNextRow(ImGuiTableRowFlags_None, rows_height); + ImGui::TableNextColumn(); + ImGui::Text("B0 Row 1"); + ImGui::TableNextColumn(); + ImGui::Text("B1 Row 1"); + + ImGui::EndTable(); + } + } + ImGui::TableNextColumn(); ImGui::Text("A1 Row 0"); + ImGui::TableNextColumn(); ImGui::Text("A0 Row 1"); + ImGui::TableNextColumn(); ImGui::Text("A1 Row 1"); + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Row height")) + { + HelpMarker("You can pass a 'min_row_height' to TableNextRow().\n\nRows are padded with 'style.CellPadding.y' on top and bottom, so effectively the minimum row height will always be >= 'style.CellPadding.y * 2.0f'.\n\nWe cannot honor a _maximum_ row height as that would requires a unique clipping rectangle per row."); + if (ImGui::BeginTable("table_row_height", 1, ImGuiTableFlags_BordersOuter | ImGuiTableFlags_BordersInnerV)) + { + for (int row = 0; row < 10; row++) + { + float min_row_height = (float)(int)(TEXT_BASE_HEIGHT * 0.30f * row); + ImGui::TableNextRow(ImGuiTableRowFlags_None, min_row_height); + ImGui::TableNextColumn(); + ImGui::Text("min_row_height = %.2f", min_row_height); + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Outer size")) + { + // Showcasing use of ImGuiTableFlags_NoHostExtendX and ImGuiTableFlags_NoHostExtendY + // Important to that note how the two flags have slightly different behaviors! + ImGui::Text("Using NoHostExtendX and NoHostExtendY:"); + PushStyleCompact(); + static ImGuiTableFlags flags = ImGuiTableFlags_Borders | ImGuiTableFlags_Resizable | ImGuiTableFlags_ContextMenuInBody | ImGuiTableFlags_RowBg | ImGuiTableFlags_SizingFixedFit | ImGuiTableFlags_NoHostExtendX; + ImGui::CheckboxFlags("ImGuiTableFlags_NoHostExtendX", &flags, ImGuiTableFlags_NoHostExtendX); + ImGui::SameLine(); HelpMarker("Make outer width auto-fit to columns, overriding outer_size.x value.\n\nOnly available when ScrollX/ScrollY are disabled and Stretch columns are not used."); + ImGui::CheckboxFlags("ImGuiTableFlags_NoHostExtendY", &flags, ImGuiTableFlags_NoHostExtendY); + ImGui::SameLine(); HelpMarker("Make outer height stop exactly at outer_size.y (prevent auto-extending table past the limit).\n\nOnly available when ScrollX/ScrollY are disabled. Data below the limit will be clipped and not visible."); + PopStyleCompact(); + + ImVec2 outer_size = ImVec2(0.0f, TEXT_BASE_HEIGHT * 5.5f); + if (ImGui::BeginTable("table1", 3, flags, outer_size)) + { + for (int row = 0; row < 10; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + ImGui::TableNextColumn(); + ImGui::Text("Cell %d,%d", column, row); + } + } + ImGui::EndTable(); + } + ImGui::SameLine(); + ImGui::Text("Hello!"); + + ImGui::Spacing(); + + ImGui::Text("Using explicit size:"); + if (ImGui::BeginTable("table2", 3, ImGuiTableFlags_Borders | ImGuiTableFlags_RowBg, ImVec2(TEXT_BASE_WIDTH * 30, 0.0f))) + { + for (int row = 0; row < 5; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + ImGui::TableNextColumn(); + ImGui::Text("Cell %d,%d", column, row); + } + } + ImGui::EndTable(); + } + ImGui::SameLine(); + if (ImGui::BeginTable("table3", 3, ImGuiTableFlags_Borders | ImGuiTableFlags_RowBg, ImVec2(TEXT_BASE_WIDTH * 30, 0.0f))) + { + for (int row = 0; row < 3; row++) + { + ImGui::TableNextRow(0, TEXT_BASE_HEIGHT * 1.5f); + for (int column = 0; column < 3; column++) + { + ImGui::TableNextColumn(); + ImGui::Text("Cell %d,%d", column, row); + } + } + ImGui::EndTable(); + } + + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Background color")) + { + static ImGuiTableFlags flags = ImGuiTableFlags_RowBg; + static int row_bg_type = 1; + static int row_bg_target = 1; + static int cell_bg_type = 1; + + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_Borders", &flags, ImGuiTableFlags_Borders); + ImGui::CheckboxFlags("ImGuiTableFlags_RowBg", &flags, ImGuiTableFlags_RowBg); + ImGui::SameLine(); HelpMarker("ImGuiTableFlags_RowBg automatically sets RowBg0 to alternative colors pulled from the Style."); + ImGui::Combo("row bg type", (int*)&row_bg_type, "None\0Red\0Gradient\0"); + ImGui::Combo("row bg target", (int*)&row_bg_target, "RowBg0\0RowBg1\0"); ImGui::SameLine(); HelpMarker("Target RowBg0 to override the alternating odd/even colors,\nTarget RowBg1 to blend with them."); + ImGui::Combo("cell bg type", (int*)&cell_bg_type, "None\0Blue\0"); ImGui::SameLine(); HelpMarker("We are colorizing cells to B1->C2 here."); + IM_ASSERT(row_bg_type >= 0 && row_bg_type <= 2); + IM_ASSERT(row_bg_target >= 0 && row_bg_target <= 1); + IM_ASSERT(cell_bg_type >= 0 && cell_bg_type <= 1); + PopStyleCompact(); + + if (ImGui::BeginTable("table1", 5, flags)) + { + for (int row = 0; row < 6; row++) + { + ImGui::TableNextRow(); + + // Demonstrate setting a row background color with 'ImGui::TableSetBgColor(ImGuiTableBgTarget_RowBgX, ...)' + // We use a transparent color so we can see the one behind in case our target is RowBg1 and RowBg0 was already targeted by the ImGuiTableFlags_RowBg flag. + if (row_bg_type != 0) + { + ImU32 row_bg_color = ImGui::GetColorU32(row_bg_type == 1 ? ImVec4(0.7f, 0.3f, 0.3f, 0.65f) : ImVec4(0.2f + row * 0.1f, 0.2f, 0.2f, 0.65f)); // Flat or Gradient? + ImGui::TableSetBgColor(ImGuiTableBgTarget_RowBg0 + row_bg_target, row_bg_color); + } + + // Fill cells + for (int column = 0; column < 5; column++) + { + ImGui::TableSetColumnIndex(column); + ImGui::Text("%c%c", 'A' + row, '0' + column); + + // Change background of Cells B1->C2 + // Demonstrate setting a cell background color with 'ImGui::TableSetBgColor(ImGuiTableBgTarget_CellBg, ...)' + // (the CellBg color will be blended over the RowBg and ColumnBg colors) + // We can also pass a column number as a third parameter to TableSetBgColor() and do this outside the column loop. + if (row >= 1 && row <= 2 && column >= 1 && column <= 2 && cell_bg_type == 1) + { + ImU32 cell_bg_color = ImGui::GetColorU32(ImVec4(0.3f, 0.3f, 0.7f, 0.65f)); + ImGui::TableSetBgColor(ImGuiTableBgTarget_CellBg, cell_bg_color); + } + } + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Tree view")) + { + static ImGuiTableFlags flags = ImGuiTableFlags_BordersV | ImGuiTableFlags_BordersOuterH | ImGuiTableFlags_Resizable | ImGuiTableFlags_RowBg | ImGuiTableFlags_NoBordersInBody; + + if (ImGui::BeginTable("3ways", 3, flags)) + { + // The first column will use the default _WidthStretch when ScrollX is Off and _WidthFixed when ScrollX is On + ImGui::TableSetupColumn("Name", ImGuiTableColumnFlags_NoHide); + ImGui::TableSetupColumn("Size", ImGuiTableColumnFlags_WidthFixed, TEXT_BASE_WIDTH * 12.0f); + ImGui::TableSetupColumn("Type", ImGuiTableColumnFlags_WidthFixed, TEXT_BASE_WIDTH * 18.0f); + ImGui::TableHeadersRow(); + + // Simple storage to output a dummy file-system. + struct MyTreeNode + { + const char* Name; + const char* Type; + int Size; + int ChildIdx; + int ChildCount; + static void DisplayNode(const MyTreeNode* node, const MyTreeNode* all_nodes) + { + ImGui::TableNextRow(); + ImGui::TableNextColumn(); + const bool is_folder = (node->ChildCount > 0); + if (is_folder) + { + bool open = ImGui::TreeNodeEx(node->Name, ImGuiTreeNodeFlags_SpanFullWidth); + ImGui::TableNextColumn(); + ImGui::TextDisabled("--"); + ImGui::TableNextColumn(); + ImGui::TextUnformatted(node->Type); + if (open) + { + for (int child_n = 0; child_n < node->ChildCount; child_n++) + DisplayNode(&all_nodes[node->ChildIdx + child_n], all_nodes); + ImGui::TreePop(); + } + } + else + { + ImGui::TreeNodeEx(node->Name, ImGuiTreeNodeFlags_Leaf | ImGuiTreeNodeFlags_Bullet | ImGuiTreeNodeFlags_NoTreePushOnOpen | ImGuiTreeNodeFlags_SpanFullWidth); + ImGui::TableNextColumn(); + ImGui::Text("%d", node->Size); + ImGui::TableNextColumn(); + ImGui::TextUnformatted(node->Type); + } + } + }; + static const MyTreeNode nodes[] = + { + { "Root", "Folder", -1, 1, 3 }, // 0 + { "Music", "Folder", -1, 4, 2 }, // 1 + { "Textures", "Folder", -1, 6, 3 }, // 2 + { "desktop.ini", "System file", 1024, -1,-1 }, // 3 + { "File1_a.wav", "Audio file", 123000, -1,-1 }, // 4 + { "File1_b.wav", "Audio file", 456000, -1,-1 }, // 5 + { "Image001.png", "Image file", 203128, -1,-1 }, // 6 + { "Copy of Image001.png", "Image file", 203256, -1,-1 }, // 7 + { "Copy of Image001 (Final2).png","Image file", 203512, -1,-1 }, // 8 + }; + + MyTreeNode::DisplayNode(&nodes[0], nodes); + + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Item width")) + { + HelpMarker( + "Showcase using PushItemWidth() and how it is preserved on a per-column basis.\n\n" + "Note that on auto-resizing non-resizable fixed columns, querying the content width for e.g. right-alignment doesn't make sense."); + if (ImGui::BeginTable("table_item_width", 3, ImGuiTableFlags_Borders)) + { + ImGui::TableSetupColumn("small"); + ImGui::TableSetupColumn("half"); + ImGui::TableSetupColumn("right-align"); + ImGui::TableHeadersRow(); + + for (int row = 0; row < 3; row++) + { + ImGui::TableNextRow(); + if (row == 0) + { + // Setup ItemWidth once (instead of setting up every time, which is also possible but less efficient) + ImGui::TableSetColumnIndex(0); + ImGui::PushItemWidth(TEXT_BASE_WIDTH * 3.0f); // Small + ImGui::TableSetColumnIndex(1); + ImGui::PushItemWidth(-ImGui::GetContentRegionAvail().x * 0.5f); + ImGui::TableSetColumnIndex(2); + ImGui::PushItemWidth(-FLT_MIN); // Right-aligned + } + + // Draw our contents + static float dummy_f = 0.0f; + ImGui::PushID(row); + ImGui::TableSetColumnIndex(0); + ImGui::SliderFloat("float0", &dummy_f, 0.0f, 1.0f); + ImGui::TableSetColumnIndex(1); + ImGui::SliderFloat("float1", &dummy_f, 0.0f, 1.0f); + ImGui::TableSetColumnIndex(2); + ImGui::SliderFloat("float2", &dummy_f, 0.0f, 1.0f); + ImGui::PopID(); + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + // Demonstrate using TableHeader() calls instead of TableHeadersRow() + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Custom headers")) + { + const int COLUMNS_COUNT = 3; + if (ImGui::BeginTable("table_custom_headers", COLUMNS_COUNT, ImGuiTableFlags_Borders | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable)) + { + ImGui::TableSetupColumn("Apricot"); + ImGui::TableSetupColumn("Banana"); + ImGui::TableSetupColumn("Cherry"); + + // Dummy entire-column selection storage + // FIXME: It would be nice to actually demonstrate full-featured selection using those checkbox. + static bool column_selected[3] = {}; + + // Instead of calling TableHeadersRow() we'll submit custom headers ourselves + ImGui::TableNextRow(ImGuiTableRowFlags_Headers); + for (int column = 0; column < COLUMNS_COUNT; column++) + { + ImGui::TableSetColumnIndex(column); + const char* column_name = ImGui::TableGetColumnName(column); // Retrieve name passed to TableSetupColumn() + ImGui::PushID(column); + ImGui::PushStyleVar(ImGuiStyleVar_FramePadding, ImVec2(0, 0)); + ImGui::Checkbox("##checkall", &column_selected[column]); + ImGui::PopStyleVar(); + ImGui::SameLine(0.0f, ImGui::GetStyle().ItemInnerSpacing.x); + ImGui::TableHeader(column_name); + ImGui::PopID(); + } + + for (int row = 0; row < 5; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < 3; column++) + { + char buf[32]; + sprintf(buf, "Cell %d,%d", column, row); + ImGui::TableSetColumnIndex(column); + ImGui::Selectable(buf, column_selected[column]); + } + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + // Demonstrate creating custom context menus inside columns, while playing it nice with context menus provided by TableHeadersRow()/TableHeader() + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Context menus")) + { + HelpMarker("By default, right-clicking over a TableHeadersRow()/TableHeader() line will open the default context-menu.\nUsing ImGuiTableFlags_ContextMenuInBody we also allow right-clicking over columns body."); + static ImGuiTableFlags flags1 = ImGuiTableFlags_Resizable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable | ImGuiTableFlags_Borders | ImGuiTableFlags_ContextMenuInBody; + + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_ContextMenuInBody", &flags1, ImGuiTableFlags_ContextMenuInBody); + PopStyleCompact(); + + // Context Menus: first example + // [1.1] Right-click on the TableHeadersRow() line to open the default table context menu. + // [1.2] Right-click in columns also open the default table context menu (if ImGuiTableFlags_ContextMenuInBody is set) + const int COLUMNS_COUNT = 3; + if (ImGui::BeginTable("table_context_menu", COLUMNS_COUNT, flags1)) + { + ImGui::TableSetupColumn("One"); + ImGui::TableSetupColumn("Two"); + ImGui::TableSetupColumn("Three"); + + // [1.1]] Right-click on the TableHeadersRow() line to open the default table context menu. + ImGui::TableHeadersRow(); + + // Submit dummy contents + for (int row = 0; row < 4; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < COLUMNS_COUNT; column++) + { + ImGui::TableSetColumnIndex(column); + ImGui::Text("Cell %d,%d", column, row); + } + } + ImGui::EndTable(); + } + + // Context Menus: second example + // [2.1] Right-click on the TableHeadersRow() line to open the default table context menu. + // [2.2] Right-click on the ".." to open a custom popup + // [2.3] Right-click in columns to open another custom popup + HelpMarker("Demonstrate mixing table context menu (over header), item context button (over button) and custom per-colum context menu (over column body)."); + ImGuiTableFlags flags2 = ImGuiTableFlags_Resizable | ImGuiTableFlags_SizingFixedFit | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable | ImGuiTableFlags_Borders; + if (ImGui::BeginTable("table_context_menu_2", COLUMNS_COUNT, flags2)) + { + ImGui::TableSetupColumn("One"); + ImGui::TableSetupColumn("Two"); + ImGui::TableSetupColumn("Three"); + + // [2.1] Right-click on the TableHeadersRow() line to open the default table context menu. + ImGui::TableHeadersRow(); + for (int row = 0; row < 4; row++) + { + ImGui::TableNextRow(); + for (int column = 0; column < COLUMNS_COUNT; column++) + { + // Submit dummy contents + ImGui::TableSetColumnIndex(column); + ImGui::Text("Cell %d,%d", column, row); + ImGui::SameLine(); + + // [2.2] Right-click on the ".." to open a custom popup + ImGui::PushID(row * COLUMNS_COUNT + column); + ImGui::SmallButton(".."); + if (ImGui::BeginPopupContextItem()) + { + ImGui::Text("This is the popup for Button(\"..\") in Cell %d,%d", column, row); + if (ImGui::Button("Close")) + ImGui::CloseCurrentPopup(); + ImGui::EndPopup(); + } + ImGui::PopID(); + } + } + + // [2.3] Right-click anywhere in columns to open another custom popup + // (instead of testing for !IsAnyItemHovered() we could also call OpenPopup() with ImGuiPopupFlags_NoOpenOverExistingPopup + // to manage popup priority as the popups triggers, here "are we hovering a column" are overlapping) + int hovered_column = -1; + for (int column = 0; column < COLUMNS_COUNT + 1; column++) + { + ImGui::PushID(column); + if (ImGui::TableGetColumnFlags(column) & ImGuiTableColumnFlags_IsHovered) + hovered_column = column; + if (hovered_column == column && !ImGui::IsAnyItemHovered() && ImGui::IsMouseReleased(1)) + ImGui::OpenPopup("MyPopup"); + if (ImGui::BeginPopup("MyPopup")) + { + if (column == COLUMNS_COUNT) + ImGui::Text("This is a custom popup for unused space after the last column."); + else + ImGui::Text("This is a custom popup for Column %d", column); + if (ImGui::Button("Close")) + ImGui::CloseCurrentPopup(); + ImGui::EndPopup(); + } + ImGui::PopID(); + } + + ImGui::EndTable(); + ImGui::Text("Hovered column: %d", hovered_column); + } + ImGui::TreePop(); + } + + // Demonstrate creating multiple tables with the same ID + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Synced instances")) + { + HelpMarker("Multiple tables with the same identifier will share their settings, width, visibility, order etc."); + for (int n = 0; n < 3; n++) + { + char buf[32]; + sprintf(buf, "Synced Table %d", n); + bool open = ImGui::CollapsingHeader(buf, ImGuiTreeNodeFlags_DefaultOpen); + if (open && ImGui::BeginTable("Table", 3, ImGuiTableFlags_Resizable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable | ImGuiTableFlags_Borders | ImGuiTableFlags_SizingFixedFit | ImGuiTableFlags_NoSavedSettings)) + { + ImGui::TableSetupColumn("One"); + ImGui::TableSetupColumn("Two"); + ImGui::TableSetupColumn("Three"); + ImGui::TableHeadersRow(); + for (int cell = 0; cell < 9; cell++) + { + ImGui::TableNextColumn(); + ImGui::Text("this cell %d", cell); + } + ImGui::EndTable(); + } + } + ImGui::TreePop(); + } + + // Demonstrate using Sorting facilities + // This is a simplified version of the "Advanced" example, where we mostly focus on the code necessary to handle sorting. + // Note that the "Advanced" example also showcase manually triggering a sort (e.g. if item quantities have been modified) + static const char* template_items_names[] = + { + "Banana", "Apple", "Cherry", "Watermelon", "Grapefruit", "Strawberry", "Mango", + "Kiwi", "Orange", "Pineapple", "Blueberry", "Plum", "Coconut", "Pear", "Apricot" + }; + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Sorting")) + { + // Create item list + static ImVector items; + if (items.Size == 0) + { + items.resize(50, MyItem()); + for (int n = 0; n < items.Size; n++) + { + const int template_n = n % IM_ARRAYSIZE(template_items_names); + MyItem& item = items[n]; + item.ID = n; + item.Name = template_items_names[template_n]; + item.Quantity = (n * n - n) % 20; // Assign default quantities + } + } + + // Options + static ImGuiTableFlags flags = + ImGuiTableFlags_Resizable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable | ImGuiTableFlags_Sortable | ImGuiTableFlags_SortMulti + | ImGuiTableFlags_RowBg | ImGuiTableFlags_BordersOuter | ImGuiTableFlags_BordersV | ImGuiTableFlags_NoBordersInBody + | ImGuiTableFlags_ScrollY; + PushStyleCompact(); + ImGui::CheckboxFlags("ImGuiTableFlags_SortMulti", &flags, ImGuiTableFlags_SortMulti); + ImGui::SameLine(); HelpMarker("When sorting is enabled: hold shift when clicking headers to sort on multiple column. TableGetSortSpecs() may return specs where (SpecsCount > 1)."); + ImGui::CheckboxFlags("ImGuiTableFlags_SortTristate", &flags, ImGuiTableFlags_SortTristate); + ImGui::SameLine(); HelpMarker("When sorting is enabled: allow no sorting, disable default sorting. TableGetSortSpecs() may return specs where (SpecsCount == 0)."); + PopStyleCompact(); + + if (ImGui::BeginTable("table_sorting", 4, flags, ImVec2(0.0f, TEXT_BASE_HEIGHT * 15), 0.0f)) + { + // Declare columns + // We use the "user_id" parameter of TableSetupColumn() to specify a user id that will be stored in the sort specifications. + // This is so our sort function can identify a column given our own identifier. We could also identify them based on their index! + // Demonstrate using a mixture of flags among available sort-related flags: + // - ImGuiTableColumnFlags_DefaultSort + // - ImGuiTableColumnFlags_NoSort / ImGuiTableColumnFlags_NoSortAscending / ImGuiTableColumnFlags_NoSortDescending + // - ImGuiTableColumnFlags_PreferSortAscending / ImGuiTableColumnFlags_PreferSortDescending + ImGui::TableSetupColumn("ID", ImGuiTableColumnFlags_DefaultSort | ImGuiTableColumnFlags_WidthFixed, 0.0f, MyItemColumnID_ID); + ImGui::TableSetupColumn("Name", ImGuiTableColumnFlags_WidthFixed, 0.0f, MyItemColumnID_Name); + ImGui::TableSetupColumn("Action", ImGuiTableColumnFlags_NoSort | ImGuiTableColumnFlags_WidthFixed, 0.0f, MyItemColumnID_Action); + ImGui::TableSetupColumn("Quantity", ImGuiTableColumnFlags_PreferSortDescending | ImGuiTableColumnFlags_WidthStretch, 0.0f, MyItemColumnID_Quantity); + ImGui::TableSetupScrollFreeze(0, 1); // Make row always visible + ImGui::TableHeadersRow(); + + // Sort our data if sort specs have been changed! + if (ImGuiTableSortSpecs* sorts_specs = ImGui::TableGetSortSpecs()) + if (sorts_specs->SpecsDirty) + { + MyItem::s_current_sort_specs = sorts_specs; // Store in variable accessible by the sort function. + if (items.Size > 1) + qsort(&items[0], (size_t)items.Size, sizeof(items[0]), MyItem::CompareWithSortSpecs); + MyItem::s_current_sort_specs = NULL; + sorts_specs->SpecsDirty = false; + } + + // Demonstrate using clipper for large vertical lists + ImGuiListClipper clipper; + clipper.Begin(items.Size); + while (clipper.Step()) + for (int row_n = clipper.DisplayStart; row_n < clipper.DisplayEnd; row_n++) + { + // Display a data item + MyItem* item = &items[row_n]; + ImGui::PushID(item->ID); + ImGui::TableNextRow(); + ImGui::TableNextColumn(); + ImGui::Text("%04d", item->ID); + ImGui::TableNextColumn(); + ImGui::TextUnformatted(item->Name); + ImGui::TableNextColumn(); + ImGui::SmallButton("None"); + ImGui::TableNextColumn(); + ImGui::Text("%d", item->Quantity); + ImGui::PopID(); + } + ImGui::EndTable(); + } + ImGui::TreePop(); + } + + // In this example we'll expose most table flags and settings. + // For specific flags and settings refer to the corresponding section for more detailed explanation. + // This section is mostly useful to experiment with combining certain flags or settings with each others. + //ImGui::SetNextItemOpen(true, ImGuiCond_Once); // [DEBUG] + if (open_action != -1) + ImGui::SetNextItemOpen(open_action != 0); + if (ImGui::TreeNode("Advanced")) + { + static ImGuiTableFlags flags = + ImGuiTableFlags_Resizable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable + | ImGuiTableFlags_Sortable | ImGuiTableFlags_SortMulti + | ImGuiTableFlags_RowBg | ImGuiTableFlags_Borders | ImGuiTableFlags_NoBordersInBody + | ImGuiTableFlags_ScrollX | ImGuiTableFlags_ScrollY + | ImGuiTableFlags_SizingFixedFit; + + enum ContentsType { CT_Text, CT_Button, CT_SmallButton, CT_FillButton, CT_Selectable, CT_SelectableSpanRow }; + static int contents_type = CT_SelectableSpanRow; + const char* contents_type_names[] = { "Text", "Button", "SmallButton", "FillButton", "Selectable", "Selectable (span row)" }; + static int freeze_cols = 1; + static int freeze_rows = 1; + static int items_count = IM_ARRAYSIZE(template_items_names) * 2; + static ImVec2 outer_size_value = ImVec2(0.0f, TEXT_BASE_HEIGHT * 12); + static float row_min_height = 0.0f; // Auto + static float inner_width_with_scroll = 0.0f; // Auto-extend + static bool outer_size_enabled = true; + static bool show_headers = true; + static bool show_wrapped_text = false; + //static ImGuiTextFilter filter; + //ImGui::SetNextItemOpen(true, ImGuiCond_Once); // FIXME-TABLE: Enabling this results in initial clipped first pass on table which tend to affects column sizing + if (ImGui::TreeNode("Options")) + { + // Make the UI compact because there are so many fields + PushStyleCompact(); + ImGui::PushItemWidth(TEXT_BASE_WIDTH * 28.0f); + + if (ImGui::TreeNodeEx("Features:", ImGuiTreeNodeFlags_DefaultOpen)) + { + ImGui::CheckboxFlags("ImGuiTableFlags_Resizable", &flags, ImGuiTableFlags_Resizable); + ImGui::CheckboxFlags("ImGuiTableFlags_Reorderable", &flags, ImGuiTableFlags_Reorderable); + ImGui::CheckboxFlags("ImGuiTableFlags_Hideable", &flags, ImGuiTableFlags_Hideable); + ImGui::CheckboxFlags("ImGuiTableFlags_Sortable", &flags, ImGuiTableFlags_Sortable); + ImGui::CheckboxFlags("ImGuiTableFlags_NoSavedSettings", &flags, ImGuiTableFlags_NoSavedSettings); + ImGui::CheckboxFlags("ImGuiTableFlags_ContextMenuInBody", &flags, ImGuiTableFlags_ContextMenuInBody); + ImGui::TreePop(); + } + + if (ImGui::TreeNodeEx("Decorations:", ImGuiTreeNodeFlags_DefaultOpen)) + { + ImGui::CheckboxFlags("ImGuiTableFlags_RowBg", &flags, ImGuiTableFlags_RowBg); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersV", &flags, ImGuiTableFlags_BordersV); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersOuterV", &flags, ImGuiTableFlags_BordersOuterV); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersInnerV", &flags, ImGuiTableFlags_BordersInnerV); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersH", &flags, ImGuiTableFlags_BordersH); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersOuterH", &flags, ImGuiTableFlags_BordersOuterH); + ImGui::CheckboxFlags("ImGuiTableFlags_BordersInnerH", &flags, ImGuiTableFlags_BordersInnerH); + ImGui::CheckboxFlags("ImGuiTableFlags_NoBordersInBody", &flags, ImGuiTableFlags_NoBordersInBody); ImGui::SameLine(); HelpMarker("Disable vertical borders in columns Body (borders will always appears in Headers"); + ImGui::CheckboxFlags("ImGuiTableFlags_NoBordersInBodyUntilResize", &flags, ImGuiTableFlags_NoBordersInBodyUntilResize); ImGui::SameLine(); HelpMarker("Disable vertical borders in columns Body until hovered for resize (borders will always appears in Headers)"); + ImGui::TreePop(); + } + + if (ImGui::TreeNodeEx("Sizing:", ImGuiTreeNodeFlags_DefaultOpen)) + { + EditTableSizingFlags(&flags); + ImGui::SameLine(); HelpMarker("In the Advanced demo we override the policy of each column so those table-wide settings have less effect that typical."); + ImGui::CheckboxFlags("ImGuiTableFlags_NoHostExtendX", &flags, ImGuiTableFlags_NoHostExtendX); + ImGui::SameLine(); HelpMarker("Make outer width auto-fit to columns, overriding outer_size.x value.\n\nOnly available when ScrollX/ScrollY are disabled and Stretch columns are not used."); + ImGui::CheckboxFlags("ImGuiTableFlags_NoHostExtendY", &flags, ImGuiTableFlags_NoHostExtendY); + ImGui::SameLine(); HelpMarker("Make outer height stop exactly at outer_size.y (prevent auto-extending table past the limit).\n\nOnly available when ScrollX/ScrollY are disabled. Data below the limit will be clipped and not visible."); + ImGui::CheckboxFlags("ImGuiTableFlags_NoKeepColumnsVisible", &flags, ImGuiTableFlags_NoKeepColumnsVisible); + ImGui::SameLine(); HelpMarker("Only available if ScrollX is disabled."); + ImGui::CheckboxFlags("ImGuiTableFlags_PreciseWidths", &flags, ImGuiTableFlags_PreciseWidths); + ImGui::SameLine(); HelpMarker("Disable distributing remainder width to stretched columns (width allocation on a 100-wide table with 3 columns: Without this flag: 33,33,34. With this flag: 33,33,33). With larger number of columns, resizing will appear to be less smooth."); + ImGui::CheckboxFlags("ImGuiTableFlags_NoClip", &flags, ImGuiTableFlags_NoClip); + ImGui::SameLine(); HelpMarker("Disable clipping rectangle for every individual columns (reduce draw command count, items will be able to overflow into other columns). Generally incompatible with ScrollFreeze options."); + ImGui::TreePop(); + } + + if (ImGui::TreeNodeEx("Padding:", ImGuiTreeNodeFlags_DefaultOpen)) + { + ImGui::CheckboxFlags("ImGuiTableFlags_PadOuterX", &flags, ImGuiTableFlags_PadOuterX); + ImGui::CheckboxFlags("ImGuiTableFlags_NoPadOuterX", &flags, ImGuiTableFlags_NoPadOuterX); + ImGui::CheckboxFlags("ImGuiTableFlags_NoPadInnerX", &flags, ImGuiTableFlags_NoPadInnerX); + ImGui::TreePop(); + } + + if (ImGui::TreeNodeEx("Scrolling:", ImGuiTreeNodeFlags_DefaultOpen)) + { + ImGui::CheckboxFlags("ImGuiTableFlags_ScrollX", &flags, ImGuiTableFlags_ScrollX); + ImGui::SameLine(); + ImGui::SetNextItemWidth(ImGui::GetFrameHeight()); + ImGui::DragInt("freeze_cols", &freeze_cols, 0.2f, 0, 9, NULL, ImGuiSliderFlags_NoInput); + ImGui::CheckboxFlags("ImGuiTableFlags_ScrollY", &flags, ImGuiTableFlags_ScrollY); + ImGui::SameLine(); + ImGui::SetNextItemWidth(ImGui::GetFrameHeight()); + ImGui::DragInt("freeze_rows", &freeze_rows, 0.2f, 0, 9, NULL, ImGuiSliderFlags_NoInput); + ImGui::TreePop(); + } + + if (ImGui::TreeNodeEx("Sorting:", ImGuiTreeNodeFlags_DefaultOpen)) + { + ImGui::CheckboxFlags("ImGuiTableFlags_SortMulti", &flags, ImGuiTableFlags_SortMulti); + ImGui::SameLine(); HelpMarker("When sorting is enabled: hold shift when clicking headers to sort on multiple column. TableGetSortSpecs() may return specs where (SpecsCount > 1)."); + ImGui::CheckboxFlags("ImGuiTableFlags_SortTristate", &flags, ImGuiTableFlags_SortTristate); + ImGui::SameLine(); HelpMarker("When sorting is enabled: allow no sorting, disable default sorting. TableGetSortSpecs() may return specs where (SpecsCount == 0)."); + ImGui::TreePop(); + } + + if (ImGui::TreeNodeEx("Other:", ImGuiTreeNodeFlags_DefaultOpen)) + { + ImGui::Checkbox("show_headers", &show_headers); + ImGui::Checkbox("show_wrapped_text", &show_wrapped_text); + + ImGui::DragFloat2("##OuterSize", &outer_size_value.x); + ImGui::SameLine(0.0f, ImGui::GetStyle().ItemInnerSpacing.x); + ImGui::Checkbox("outer_size", &outer_size_enabled); + ImGui::SameLine(); + HelpMarker("If scrolling is disabled (ScrollX and ScrollY not set):\n" + "- The table is output directly in the parent window.\n" + "- OuterSize.x < 0.0f will right-align the table.\n" + "- OuterSize.x = 0.0f will narrow fit the table unless there are any Stretch column.\n" + "- OuterSize.y then becomes the minimum size for the table, which will extend vertically if there are more rows (unless NoHostExtendY is set)."); + + // From a user point of view we will tend to use 'inner_width' differently depending on whether our table is embedding scrolling. + // To facilitate toying with this demo we will actually pass 0.0f to the BeginTable() when ScrollX is disabled. + ImGui::DragFloat("inner_width (when ScrollX active)", &inner_width_with_scroll, 1.0f, 0.0f, FLT_MAX); + + ImGui::DragFloat("row_min_height", &row_min_height, 1.0f, 0.0f, FLT_MAX); + ImGui::SameLine(); HelpMarker("Specify height of the Selectable item."); + + ImGui::DragInt("items_count", &items_count, 0.1f, 0, 9999); + ImGui::Combo("items_type (first column)", &contents_type, contents_type_names, IM_ARRAYSIZE(contents_type_names)); + //filter.Draw("filter"); + ImGui::TreePop(); + } + + ImGui::PopItemWidth(); + PopStyleCompact(); + ImGui::Spacing(); + ImGui::TreePop(); + } + + // Update item list if we changed the number of items + static ImVector items; + static ImVector selection; + static bool items_need_sort = false; + if (items.Size != items_count) + { + items.resize(items_count, MyItem()); + for (int n = 0; n < items_count; n++) + { + const int template_n = n % IM_ARRAYSIZE(template_items_names); + MyItem& item = items[n]; + item.ID = n; + item.Name = template_items_names[template_n]; + item.Quantity = (template_n == 3) ? 10 : (template_n == 4) ? 20 : 0; // Assign default quantities + } + } + + const ImDrawList* parent_draw_list = ImGui::GetWindowDrawList(); + const int parent_draw_list_draw_cmd_count = parent_draw_list->CmdBuffer.Size; + ImVec2 table_scroll_cur, table_scroll_max; // For debug display + const ImDrawList* table_draw_list = NULL; // " + + // Submit table + const float inner_width_to_use = (flags & ImGuiTableFlags_ScrollX) ? inner_width_with_scroll : 0.0f; + if (ImGui::BeginTable("table_advanced", 6, flags, outer_size_enabled ? outer_size_value : ImVec2(0, 0), inner_width_to_use)) + { + // Declare columns + // We use the "user_id" parameter of TableSetupColumn() to specify a user id that will be stored in the sort specifications. + // This is so our sort function can identify a column given our own identifier. We could also identify them based on their index! + ImGui::TableSetupColumn("ID", ImGuiTableColumnFlags_DefaultSort | ImGuiTableColumnFlags_WidthFixed | ImGuiTableColumnFlags_NoHide, 0.0f, MyItemColumnID_ID); + ImGui::TableSetupColumn("Name", ImGuiTableColumnFlags_WidthFixed, 0.0f, MyItemColumnID_Name); + ImGui::TableSetupColumn("Action", ImGuiTableColumnFlags_NoSort | ImGuiTableColumnFlags_WidthFixed, 0.0f, MyItemColumnID_Action); + ImGui::TableSetupColumn("Quantity", ImGuiTableColumnFlags_PreferSortDescending, 0.0f, MyItemColumnID_Quantity); + ImGui::TableSetupColumn("Description", (flags & ImGuiTableFlags_NoHostExtendX) ? 0 : ImGuiTableColumnFlags_WidthStretch, 0.0f, MyItemColumnID_Description); + ImGui::TableSetupColumn("Hidden", ImGuiTableColumnFlags_DefaultHide | ImGuiTableColumnFlags_NoSort); + ImGui::TableSetupScrollFreeze(freeze_cols, freeze_rows); + + // Sort our data if sort specs have been changed! + ImGuiTableSortSpecs* sorts_specs = ImGui::TableGetSortSpecs(); + if (sorts_specs && sorts_specs->SpecsDirty) + items_need_sort = true; + if (sorts_specs && items_need_sort && items.Size > 1) + { + MyItem::s_current_sort_specs = sorts_specs; // Store in variable accessible by the sort function. + qsort(&items[0], (size_t)items.Size, sizeof(items[0]), MyItem::CompareWithSortSpecs); + MyItem::s_current_sort_specs = NULL; + sorts_specs->SpecsDirty = false; + } + items_need_sort = false; + + // Take note of whether we are currently sorting based on the Quantity field, + // we will use this to trigger sorting when we know the data of this column has been modified. + const bool sorts_specs_using_quantity = (ImGui::TableGetColumnFlags(3) & ImGuiTableColumnFlags_IsSorted) != 0; + + // Show headers + if (show_headers) + ImGui::TableHeadersRow(); + + // Show data + // FIXME-TABLE FIXME-NAV: How we can get decent up/down even though we have the buttons here? + ImGui::PushButtonRepeat(true); +#if 1 + // Demonstrate using clipper for large vertical lists + ImGuiListClipper clipper; + clipper.Begin(items.Size); + while (clipper.Step()) + { + for (int row_n = clipper.DisplayStart; row_n < clipper.DisplayEnd; row_n++) +#else + // Without clipper + { + for (int row_n = 0; row_n < items.Size; row_n++) +#endif + { + MyItem* item = &items[row_n]; + //if (!filter.PassFilter(item->Name)) + // continue; + + const bool item_is_selected = selection.contains(item->ID); + ImGui::PushID(item->ID); + ImGui::TableNextRow(ImGuiTableRowFlags_None, row_min_height); + + // For the demo purpose we can select among different type of items submitted in the first column + ImGui::TableSetColumnIndex(0); + char label[32]; + sprintf(label, "%04d", item->ID); + if (contents_type == CT_Text) + ImGui::TextUnformatted(label); + else if (contents_type == CT_Button) + ImGui::Button(label); + else if (contents_type == CT_SmallButton) + ImGui::SmallButton(label); + else if (contents_type == CT_FillButton) + ImGui::Button(label, ImVec2(-FLT_MIN, 0.0f)); + else if (contents_type == CT_Selectable || contents_type == CT_SelectableSpanRow) + { + ImGuiSelectableFlags selectable_flags = (contents_type == CT_SelectableSpanRow) ? ImGuiSelectableFlags_SpanAllColumns | ImGuiSelectableFlags_AllowItemOverlap : ImGuiSelectableFlags_None; + if (ImGui::Selectable(label, item_is_selected, selectable_flags, ImVec2(0, row_min_height))) + { + if (ImGui::GetIO().KeyCtrl) + { + if (item_is_selected) + selection.find_erase_unsorted(item->ID); + else + selection.push_back(item->ID); + } + else + { + selection.clear(); + selection.push_back(item->ID); + } + } + } + + if (ImGui::TableSetColumnIndex(1)) + ImGui::TextUnformatted(item->Name); + + // Here we demonstrate marking our data set as needing to be sorted again if we modified a quantity, + // and we are currently sorting on the column showing the Quantity. + // To avoid triggering a sort while holding the button, we only trigger it when the button has been released. + // You will probably need a more advanced system in your code if you want to automatically sort when a specific entry changes. + if (ImGui::TableSetColumnIndex(2)) + { + if (ImGui::SmallButton("Chop")) { item->Quantity += 1; } + if (sorts_specs_using_quantity && ImGui::IsItemDeactivated()) { items_need_sort = true; } + ImGui::SameLine(); + if (ImGui::SmallButton("Eat")) { item->Quantity -= 1; } + if (sorts_specs_using_quantity && ImGui::IsItemDeactivated()) { items_need_sort = true; } + } + + if (ImGui::TableSetColumnIndex(3)) + ImGui::Text("%d", item->Quantity); + + ImGui::TableSetColumnIndex(4); + if (show_wrapped_text) + ImGui::TextWrapped("Lorem ipsum dolor sit amet"); + else + ImGui::Text("Lorem ipsum dolor sit amet"); + + if (ImGui::TableSetColumnIndex(5)) + ImGui::Text("1234"); + + ImGui::PopID(); + } + } + ImGui::PopButtonRepeat(); + + // Store some info to display debug details below + table_scroll_cur = ImVec2(ImGui::GetScrollX(), ImGui::GetScrollY()); + table_scroll_max = ImVec2(ImGui::GetScrollMaxX(), ImGui::GetScrollMaxY()); + table_draw_list = ImGui::GetWindowDrawList(); + ImGui::EndTable(); + } + static bool show_debug_details = false; + ImGui::Checkbox("Debug details", &show_debug_details); + if (show_debug_details && table_draw_list) + { + ImGui::SameLine(0.0f, 0.0f); + const int table_draw_list_draw_cmd_count = table_draw_list->CmdBuffer.Size; + if (table_draw_list == parent_draw_list) + ImGui::Text(": DrawCmd: +%d (in same window)", + table_draw_list_draw_cmd_count - parent_draw_list_draw_cmd_count); + else + ImGui::Text(": DrawCmd: +%d (in child window), Scroll: (%.f/%.f) (%.f/%.f)", + table_draw_list_draw_cmd_count - 1, table_scroll_cur.x, table_scroll_max.x, table_scroll_cur.y, table_scroll_max.y); + } + ImGui::TreePop(); + } + + ImGui::PopID(); + + ShowDemoWindowColumns(); + + if (disable_indent) + ImGui::PopStyleVar(); +} + +// Demonstrate old/legacy Columns API! +// [2020: Columns are under-featured and not maintained. Prefer using the more flexible and powerful BeginTable() API!] +static void ShowDemoWindowColumns() +{ + bool open = ImGui::TreeNode("Legacy Columns API"); + ImGui::SameLine(); + HelpMarker("Columns() is an old API! Prefer using the more flexible and powerful BeginTable() API!"); + if (!open) + return; + + // Basic columns + if (ImGui::TreeNode("Basic")) + { + ImGui::Text("Without border:"); + ImGui::Columns(3, "mycolumns3", false); // 3-ways, no border + ImGui::Separator(); + for (int n = 0; n < 14; n++) + { + char label[32]; + sprintf(label, "Item %d", n); + if (ImGui::Selectable(label)) {} + //if (ImGui::Button(label, ImVec2(-FLT_MIN,0.0f))) {} + ImGui::NextColumn(); + } + ImGui::Columns(1); + ImGui::Separator(); + + ImGui::Text("With border:"); + ImGui::Columns(4, "mycolumns"); // 4-ways, with border + ImGui::Separator(); + ImGui::Text("ID"); ImGui::NextColumn(); + ImGui::Text("Name"); ImGui::NextColumn(); + ImGui::Text("Path"); ImGui::NextColumn(); + ImGui::Text("Hovered"); ImGui::NextColumn(); + ImGui::Separator(); + const char* names[3] = { "One", "Two", "Three" }; + const char* paths[3] = { "/path/one", "/path/two", "/path/three" }; + static int selected = -1; + for (int i = 0; i < 3; i++) + { + char label[32]; + sprintf(label, "%04d", i); + if (ImGui::Selectable(label, selected == i, ImGuiSelectableFlags_SpanAllColumns)) + selected = i; + bool hovered = ImGui::IsItemHovered(); + ImGui::NextColumn(); + ImGui::Text(names[i]); ImGui::NextColumn(); + ImGui::Text(paths[i]); ImGui::NextColumn(); + ImGui::Text("%d", hovered); ImGui::NextColumn(); + } + ImGui::Columns(1); + ImGui::Separator(); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Borders")) + { + // NB: Future columns API should allow automatic horizontal borders. + static bool h_borders = true; + static bool v_borders = true; + static int columns_count = 4; + const int lines_count = 3; + ImGui::SetNextItemWidth(ImGui::GetFontSize() * 8); + ImGui::DragInt("##columns_count", &columns_count, 0.1f, 2, 10, "%d columns"); + if (columns_count < 2) + columns_count = 2; + ImGui::SameLine(); + ImGui::Checkbox("horizontal", &h_borders); + ImGui::SameLine(); + ImGui::Checkbox("vertical", &v_borders); + ImGui::Columns(columns_count, NULL, v_borders); + for (int i = 0; i < columns_count * lines_count; i++) + { + if (h_borders && ImGui::GetColumnIndex() == 0) + ImGui::Separator(); + ImGui::Text("%c%c%c", 'a' + i, 'a' + i, 'a' + i); + ImGui::Text("Width %.2f", ImGui::GetColumnWidth()); + ImGui::Text("Avail %.2f", ImGui::GetContentRegionAvail().x); + ImGui::Text("Offset %.2f", ImGui::GetColumnOffset()); + ImGui::Text("Long text that is likely to clip"); + ImGui::Button("Button", ImVec2(-FLT_MIN, 0.0f)); + ImGui::NextColumn(); + } + ImGui::Columns(1); + if (h_borders) + ImGui::Separator(); + ImGui::TreePop(); + } + + // Create multiple items in a same cell before switching to next column + if (ImGui::TreeNode("Mixed items")) + { + ImGui::Columns(3, "mixed"); + ImGui::Separator(); + + ImGui::Text("Hello"); + ImGui::Button("Banana"); + ImGui::NextColumn(); + + ImGui::Text("ImGui"); + ImGui::Button("Apple"); + static float foo = 1.0f; + ImGui::InputFloat("red", &foo, 0.05f, 0, "%.3f"); + ImGui::Text("An extra line here."); + ImGui::NextColumn(); + + ImGui::Text("Sailor"); + ImGui::Button("Corniflower"); + static float bar = 1.0f; + ImGui::InputFloat("blue", &bar, 0.05f, 0, "%.3f"); + ImGui::NextColumn(); + + if (ImGui::CollapsingHeader("Category A")) { ImGui::Text("Blah blah blah"); } ImGui::NextColumn(); + if (ImGui::CollapsingHeader("Category B")) { ImGui::Text("Blah blah blah"); } ImGui::NextColumn(); + if (ImGui::CollapsingHeader("Category C")) { ImGui::Text("Blah blah blah"); } ImGui::NextColumn(); + ImGui::Columns(1); + ImGui::Separator(); + ImGui::TreePop(); + } + + // Word wrapping + if (ImGui::TreeNode("Word-wrapping")) + { + ImGui::Columns(2, "word-wrapping"); + ImGui::Separator(); + ImGui::TextWrapped("The quick brown fox jumps over the lazy dog."); + ImGui::TextWrapped("Hello Left"); + ImGui::NextColumn(); + ImGui::TextWrapped("The quick brown fox jumps over the lazy dog."); + ImGui::TextWrapped("Hello Right"); + ImGui::Columns(1); + ImGui::Separator(); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Horizontal Scrolling")) + { + ImGui::SetNextWindowContentSize(ImVec2(1500.0f, 0.0f)); + ImVec2 child_size = ImVec2(0, ImGui::GetFontSize() * 20.0f); + ImGui::BeginChild("##ScrollingRegion", child_size, false, ImGuiWindowFlags_HorizontalScrollbar); + ImGui::Columns(10); + + // Also demonstrate using clipper for large vertical lists + int ITEMS_COUNT = 2000; + ImGuiListClipper clipper; + clipper.Begin(ITEMS_COUNT); + while (clipper.Step()) + { + for (int i = clipper.DisplayStart; i < clipper.DisplayEnd; i++) + for (int j = 0; j < 10; j++) + { + ImGui::Text("Line %d Column %d...", i, j); + ImGui::NextColumn(); + } + } + ImGui::Columns(1); + ImGui::EndChild(); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Tree")) + { + ImGui::Columns(2, "tree", true); + for (int x = 0; x < 3; x++) + { + bool open1 = ImGui::TreeNode((void*)(intptr_t)x, "Node%d", x); + ImGui::NextColumn(); + ImGui::Text("Node contents"); + ImGui::NextColumn(); + if (open1) + { + for (int y = 0; y < 3; y++) + { + bool open2 = ImGui::TreeNode((void*)(intptr_t)y, "Node%d.%d", x, y); + ImGui::NextColumn(); + ImGui::Text("Node contents"); + if (open2) + { + ImGui::Text("Even more contents"); + if (ImGui::TreeNode("Tree in column")) + { + ImGui::Text("The quick brown fox jumps over the lazy dog"); + ImGui::TreePop(); + } + } + ImGui::NextColumn(); + if (open2) + ImGui::TreePop(); + } + ImGui::TreePop(); + } + } + ImGui::Columns(1); + ImGui::TreePop(); + } + + ImGui::TreePop(); +} + +static void ShowDemoWindowMisc() +{ + if (ImGui::CollapsingHeader("Filtering")) + { + // Helper class to easy setup a text filter. + // You may want to implement a more feature-full filtering scheme in your own application. + static ImGuiTextFilter filter; + ImGui::Text("Filter usage:\n" + " \"\" display all lines\n" + " \"xxx\" display lines containing \"xxx\"\n" + " \"xxx,yyy\" display lines containing \"xxx\" or \"yyy\"\n" + " \"-xxx\" hide lines containing \"xxx\""); + filter.Draw(); + const char* lines[] = { "aaa1.c", "bbb1.c", "ccc1.c", "aaa2.cpp", "bbb2.cpp", "ccc2.cpp", "abc.h", "hello, world" }; + for (int i = 0; i < IM_ARRAYSIZE(lines); i++) + if (filter.PassFilter(lines[i])) + ImGui::BulletText("%s", lines[i]); + } + + if (ImGui::CollapsingHeader("Inputs, Navigation & Focus")) + { + ImGuiIO& io = ImGui::GetIO(); + + // Display ImGuiIO output flags + ImGui::Text("WantCaptureMouse: %d", io.WantCaptureMouse); + ImGui::Text("WantCaptureMouseUnlessPopupClose: %d", io.WantCaptureMouseUnlessPopupClose); + ImGui::Text("WantCaptureKeyboard: %d", io.WantCaptureKeyboard); + ImGui::Text("WantTextInput: %d", io.WantTextInput); + ImGui::Text("WantSetMousePos: %d", io.WantSetMousePos); + ImGui::Text("NavActive: %d, NavVisible: %d", io.NavActive, io.NavVisible); + + // Display Mouse state + if (ImGui::TreeNode("Mouse State")) + { + if (ImGui::IsMousePosValid()) + ImGui::Text("Mouse pos: (%g, %g)", io.MousePos.x, io.MousePos.y); + else + ImGui::Text("Mouse pos: "); + ImGui::Text("Mouse delta: (%g, %g)", io.MouseDelta.x, io.MouseDelta.y); + ImGui::Text("Mouse down:"); for (int i = 0; i < IM_ARRAYSIZE(io.MouseDown); i++) if (ImGui::IsMouseDown(i)) { ImGui::SameLine(); ImGui::Text("b%d (%.02f secs)", i, io.MouseDownDuration[i]); } + ImGui::Text("Mouse clicked:"); for (int i = 0; i < IM_ARRAYSIZE(io.MouseDown); i++) if (ImGui::IsMouseClicked(i)) { ImGui::SameLine(); ImGui::Text("b%d", i); } + ImGui::Text("Mouse dblclick:"); for (int i = 0; i < IM_ARRAYSIZE(io.MouseDown); i++) if (ImGui::IsMouseDoubleClicked(i)){ ImGui::SameLine(); ImGui::Text("b%d", i); } + ImGui::Text("Mouse released:"); for (int i = 0; i < IM_ARRAYSIZE(io.MouseDown); i++) if (ImGui::IsMouseReleased(i)) { ImGui::SameLine(); ImGui::Text("b%d", i); } + ImGui::Text("Mouse wheel: %.1f", io.MouseWheel); + ImGui::Text("Pen Pressure: %.1f", io.PenPressure); // Note: currently unused + ImGui::TreePop(); + } + + // Display Keyboard/Mouse state + if (ImGui::TreeNode("Keyboard & Navigation State")) + { + ImGui::Text("Keys down:"); for (int i = 0; i < IM_ARRAYSIZE(io.KeysDown); i++) if (ImGui::IsKeyDown(i)) { ImGui::SameLine(); ImGui::Text("%d (0x%X) (%.02f secs)", i, i, io.KeysDownDuration[i]); } + ImGui::Text("Keys pressed:"); for (int i = 0; i < IM_ARRAYSIZE(io.KeysDown); i++) if (ImGui::IsKeyPressed(i)) { ImGui::SameLine(); ImGui::Text("%d (0x%X)", i, i); } + ImGui::Text("Keys release:"); for (int i = 0; i < IM_ARRAYSIZE(io.KeysDown); i++) if (ImGui::IsKeyReleased(i)) { ImGui::SameLine(); ImGui::Text("%d (0x%X)", i, i); } + ImGui::Text("Keys mods: %s%s%s%s", io.KeyCtrl ? "CTRL " : "", io.KeyShift ? "SHIFT " : "", io.KeyAlt ? "ALT " : "", io.KeySuper ? "SUPER " : ""); + ImGui::Text("Chars queue:"); for (int i = 0; i < io.InputQueueCharacters.Size; i++) { ImWchar c = io.InputQueueCharacters[i]; ImGui::SameLine(); ImGui::Text("\'%c\' (0x%04X)", (c > ' ' && c <= 255) ? (char)c : '?', c); } // FIXME: We should convert 'c' to UTF-8 here but the functions are not public. + + ImGui::Text("NavInputs down:"); for (int i = 0; i < IM_ARRAYSIZE(io.NavInputs); i++) if (io.NavInputs[i] > 0.0f) { ImGui::SameLine(); ImGui::Text("[%d] %.2f (%.02f secs)", i, io.NavInputs[i], io.NavInputsDownDuration[i]); } + ImGui::Text("NavInputs pressed:"); for (int i = 0; i < IM_ARRAYSIZE(io.NavInputs); i++) if (io.NavInputsDownDuration[i] == 0.0f) { ImGui::SameLine(); ImGui::Text("[%d]", i); } + + ImGui::Button("Hovering me sets the\nkeyboard capture flag"); + if (ImGui::IsItemHovered()) + ImGui::CaptureKeyboardFromApp(true); + ImGui::SameLine(); + ImGui::Button("Holding me clears the\nthe keyboard capture flag"); + if (ImGui::IsItemActive()) + ImGui::CaptureKeyboardFromApp(false); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Tabbing")) + { + ImGui::Text("Use TAB/SHIFT+TAB to cycle through keyboard editable fields."); + static char buf[32] = "hello"; + ImGui::InputText("1", buf, IM_ARRAYSIZE(buf)); + ImGui::InputText("2", buf, IM_ARRAYSIZE(buf)); + ImGui::InputText("3", buf, IM_ARRAYSIZE(buf)); + ImGui::PushAllowKeyboardFocus(false); + ImGui::InputText("4 (tab skip)", buf, IM_ARRAYSIZE(buf)); + ImGui::SameLine(); HelpMarker("Item won't be cycled through when using TAB or Shift+Tab."); + ImGui::PopAllowKeyboardFocus(); + ImGui::InputText("5", buf, IM_ARRAYSIZE(buf)); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Focus from code")) + { + bool focus_1 = ImGui::Button("Focus on 1"); ImGui::SameLine(); + bool focus_2 = ImGui::Button("Focus on 2"); ImGui::SameLine(); + bool focus_3 = ImGui::Button("Focus on 3"); + int has_focus = 0; + static char buf[128] = "click on a button to set focus"; + + if (focus_1) ImGui::SetKeyboardFocusHere(); + ImGui::InputText("1", buf, IM_ARRAYSIZE(buf)); + if (ImGui::IsItemActive()) has_focus = 1; + + if (focus_2) ImGui::SetKeyboardFocusHere(); + ImGui::InputText("2", buf, IM_ARRAYSIZE(buf)); + if (ImGui::IsItemActive()) has_focus = 2; + + ImGui::PushAllowKeyboardFocus(false); + if (focus_3) ImGui::SetKeyboardFocusHere(); + ImGui::InputText("3 (tab skip)", buf, IM_ARRAYSIZE(buf)); + if (ImGui::IsItemActive()) has_focus = 3; + ImGui::SameLine(); HelpMarker("Item won't be cycled through when using TAB or Shift+Tab."); + ImGui::PopAllowKeyboardFocus(); + + if (has_focus) + ImGui::Text("Item with focus: %d", has_focus); + else + ImGui::Text("Item with focus: "); + + // Use >= 0 parameter to SetKeyboardFocusHere() to focus an upcoming item + static float f3[3] = { 0.0f, 0.0f, 0.0f }; + int focus_ahead = -1; + if (ImGui::Button("Focus on X")) { focus_ahead = 0; } ImGui::SameLine(); + if (ImGui::Button("Focus on Y")) { focus_ahead = 1; } ImGui::SameLine(); + if (ImGui::Button("Focus on Z")) { focus_ahead = 2; } + if (focus_ahead != -1) ImGui::SetKeyboardFocusHere(focus_ahead); + ImGui::SliderFloat3("Float3", &f3[0], 0.0f, 1.0f); + + ImGui::TextWrapped("NB: Cursor & selection are preserved when refocusing last used item in code."); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Dragging")) + { + ImGui::TextWrapped("You can use ImGui::GetMouseDragDelta(0) to query for the dragged amount on any widget."); + for (int button = 0; button < 3; button++) + { + ImGui::Text("IsMouseDragging(%d):", button); + ImGui::Text(" w/ default threshold: %d,", ImGui::IsMouseDragging(button)); + ImGui::Text(" w/ zero threshold: %d,", ImGui::IsMouseDragging(button, 0.0f)); + ImGui::Text(" w/ large threshold: %d,", ImGui::IsMouseDragging(button, 20.0f)); + } + + ImGui::Button("Drag Me"); + if (ImGui::IsItemActive()) + ImGui::GetForegroundDrawList()->AddLine(io.MouseClickedPos[0], io.MousePos, ImGui::GetColorU32(ImGuiCol_Button), 4.0f); // Draw a line between the button and the mouse cursor + + // Drag operations gets "unlocked" when the mouse has moved past a certain threshold + // (the default threshold is stored in io.MouseDragThreshold). You can request a lower or higher + // threshold using the second parameter of IsMouseDragging() and GetMouseDragDelta(). + ImVec2 value_raw = ImGui::GetMouseDragDelta(0, 0.0f); + ImVec2 value_with_lock_threshold = ImGui::GetMouseDragDelta(0); + ImVec2 mouse_delta = io.MouseDelta; + ImGui::Text("GetMouseDragDelta(0):"); + ImGui::Text(" w/ default threshold: (%.1f, %.1f)", value_with_lock_threshold.x, value_with_lock_threshold.y); + ImGui::Text(" w/ zero threshold: (%.1f, %.1f)", value_raw.x, value_raw.y); + ImGui::Text("io.MouseDelta: (%.1f, %.1f)", mouse_delta.x, mouse_delta.y); + ImGui::TreePop(); + } + + if (ImGui::TreeNode("Mouse cursors")) + { + const char* mouse_cursors_names[] = { "Arrow", "TextInput", "ResizeAll", "ResizeNS", "ResizeEW", "ResizeNESW", "ResizeNWSE", "Hand", "NotAllowed" }; + IM_ASSERT(IM_ARRAYSIZE(mouse_cursors_names) == ImGuiMouseCursor_COUNT); + + ImGuiMouseCursor current = ImGui::GetMouseCursor(); + ImGui::Text("Current mouse cursor = %d: %s", current, mouse_cursors_names[current]); + ImGui::Text("Hover to see mouse cursors:"); + ImGui::SameLine(); HelpMarker( + "Your application can render a different mouse cursor based on what ImGui::GetMouseCursor() returns. " + "If software cursor rendering (io.MouseDrawCursor) is set ImGui will draw the right cursor for you, " + "otherwise your backend needs to handle it."); + for (int i = 0; i < ImGuiMouseCursor_COUNT; i++) + { + char label[32]; + sprintf(label, "Mouse cursor %d: %s", i, mouse_cursors_names[i]); + ImGui::Bullet(); ImGui::Selectable(label, false); + if (ImGui::IsItemHovered()) + ImGui::SetMouseCursor(i); + } + ImGui::TreePop(); + } + } +} + +//----------------------------------------------------------------------------- +// [SECTION] About Window / ShowAboutWindow() +// Access from Dear ImGui Demo -> Tools -> About +//----------------------------------------------------------------------------- + +void ImGui::ShowAboutWindow(bool* p_open) +{ + if (!ImGui::Begin("About Dear ImGui", p_open, ImGuiWindowFlags_AlwaysAutoResize)) + { + ImGui::End(); + return; + } + ImGui::Text("Dear ImGui %s", ImGui::GetVersion()); + ImGui::Separator(); + ImGui::Text("By Omar Cornut and all Dear ImGui contributors."); + ImGui::Text("Dear ImGui is licensed under the MIT License, see LICENSE for more information."); + + static bool show_config_info = false; + ImGui::Checkbox("Config/Build Information", &show_config_info); + if (show_config_info) + { + ImGuiIO& io = ImGui::GetIO(); + ImGuiStyle& style = ImGui::GetStyle(); + + bool copy_to_clipboard = ImGui::Button("Copy to clipboard"); + ImVec2 child_size = ImVec2(0, ImGui::GetTextLineHeightWithSpacing() * 18); + ImGui::BeginChildFrame(ImGui::GetID("cfg_infos"), child_size, ImGuiWindowFlags_NoMove); + if (copy_to_clipboard) + { + ImGui::LogToClipboard(); + ImGui::LogText("```\n"); // Back quotes will make text appears without formatting when pasting on GitHub + } + + ImGui::Text("Dear ImGui %s (%d)", IMGUI_VERSION, IMGUI_VERSION_NUM); + ImGui::Separator(); + ImGui::Text("sizeof(size_t): %d, sizeof(ImDrawIdx): %d, sizeof(ImDrawVert): %d", (int)sizeof(size_t), (int)sizeof(ImDrawIdx), (int)sizeof(ImDrawVert)); + ImGui::Text("define: __cplusplus=%d", (int)__cplusplus); +#ifdef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + ImGui::Text("define: IMGUI_DISABLE_OBSOLETE_FUNCTIONS"); +#endif +#ifdef IMGUI_DISABLE_WIN32_DEFAULT_CLIPBOARD_FUNCTIONS + ImGui::Text("define: IMGUI_DISABLE_WIN32_DEFAULT_CLIPBOARD_FUNCTIONS"); +#endif +#ifdef IMGUI_DISABLE_WIN32_DEFAULT_IME_FUNCTIONS + ImGui::Text("define: IMGUI_DISABLE_WIN32_DEFAULT_IME_FUNCTIONS"); +#endif +#ifdef IMGUI_DISABLE_WIN32_FUNCTIONS + ImGui::Text("define: IMGUI_DISABLE_WIN32_FUNCTIONS"); +#endif +#ifdef IMGUI_DISABLE_DEFAULT_FORMAT_FUNCTIONS + ImGui::Text("define: IMGUI_DISABLE_DEFAULT_FORMAT_FUNCTIONS"); +#endif +#ifdef IMGUI_DISABLE_DEFAULT_MATH_FUNCTIONS + ImGui::Text("define: IMGUI_DISABLE_DEFAULT_MATH_FUNCTIONS"); +#endif +#ifdef IMGUI_DISABLE_DEFAULT_FILE_FUNCTIONS + ImGui::Text("define: IMGUI_DISABLE_DEFAULT_FILE_FUNCTIONS"); +#endif +#ifdef IMGUI_DISABLE_FILE_FUNCTIONS + ImGui::Text("define: IMGUI_DISABLE_FILE_FUNCTIONS"); +#endif +#ifdef IMGUI_DISABLE_DEFAULT_ALLOCATORS + ImGui::Text("define: IMGUI_DISABLE_DEFAULT_ALLOCATORS"); +#endif +#ifdef IMGUI_USE_BGRA_PACKED_COLOR + ImGui::Text("define: IMGUI_USE_BGRA_PACKED_COLOR"); +#endif +#ifdef _WIN32 + ImGui::Text("define: _WIN32"); +#endif +#ifdef _WIN64 + ImGui::Text("define: _WIN64"); +#endif +#ifdef __linux__ + ImGui::Text("define: __linux__"); +#endif +#ifdef __APPLE__ + ImGui::Text("define: __APPLE__"); +#endif +#ifdef _MSC_VER + ImGui::Text("define: _MSC_VER=%d", _MSC_VER); +#endif +#ifdef _MSVC_LANG + ImGui::Text("define: _MSVC_LANG=%d", (int)_MSVC_LANG); +#endif +#ifdef __MINGW32__ + ImGui::Text("define: __MINGW32__"); +#endif +#ifdef __MINGW64__ + ImGui::Text("define: __MINGW64__"); +#endif +#ifdef __GNUC__ + ImGui::Text("define: __GNUC__=%d", (int)__GNUC__); +#endif +#ifdef __clang_version__ + ImGui::Text("define: __clang_version__=%s", __clang_version__); +#endif + ImGui::Separator(); + ImGui::Text("io.BackendPlatformName: %s", io.BackendPlatformName ? io.BackendPlatformName : "NULL"); + ImGui::Text("io.BackendRendererName: %s", io.BackendRendererName ? io.BackendRendererName : "NULL"); + ImGui::Text("io.ConfigFlags: 0x%08X", io.ConfigFlags); + if (io.ConfigFlags & ImGuiConfigFlags_NavEnableKeyboard) ImGui::Text(" NavEnableKeyboard"); + if (io.ConfigFlags & ImGuiConfigFlags_NavEnableGamepad) ImGui::Text(" NavEnableGamepad"); + if (io.ConfigFlags & ImGuiConfigFlags_NavEnableSetMousePos) ImGui::Text(" NavEnableSetMousePos"); + if (io.ConfigFlags & ImGuiConfigFlags_NavNoCaptureKeyboard) ImGui::Text(" NavNoCaptureKeyboard"); + if (io.ConfigFlags & ImGuiConfigFlags_NoMouse) ImGui::Text(" NoMouse"); + if (io.ConfigFlags & ImGuiConfigFlags_NoMouseCursorChange) ImGui::Text(" NoMouseCursorChange"); + if (io.MouseDrawCursor) ImGui::Text("io.MouseDrawCursor"); + if (io.ConfigMacOSXBehaviors) ImGui::Text("io.ConfigMacOSXBehaviors"); + if (io.ConfigInputTextCursorBlink) ImGui::Text("io.ConfigInputTextCursorBlink"); + if (io.ConfigWindowsResizeFromEdges) ImGui::Text("io.ConfigWindowsResizeFromEdges"); + if (io.ConfigWindowsMoveFromTitleBarOnly) ImGui::Text("io.ConfigWindowsMoveFromTitleBarOnly"); + if (io.ConfigMemoryCompactTimer >= 0.0f) ImGui::Text("io.ConfigMemoryCompactTimer = %.1f", io.ConfigMemoryCompactTimer); + ImGui::Text("io.BackendFlags: 0x%08X", io.BackendFlags); + if (io.BackendFlags & ImGuiBackendFlags_HasGamepad) ImGui::Text(" HasGamepad"); + if (io.BackendFlags & ImGuiBackendFlags_HasMouseCursors) ImGui::Text(" HasMouseCursors"); + if (io.BackendFlags & ImGuiBackendFlags_HasSetMousePos) ImGui::Text(" HasSetMousePos"); + if (io.BackendFlags & ImGuiBackendFlags_RendererHasVtxOffset) ImGui::Text(" RendererHasVtxOffset"); + ImGui::Separator(); + ImGui::Text("io.Fonts: %d fonts, Flags: 0x%08X, TexSize: %d,%d", io.Fonts->Fonts.Size, io.Fonts->Flags, io.Fonts->TexWidth, io.Fonts->TexHeight); + ImGui::Text("io.DisplaySize: %.2f,%.2f", io.DisplaySize.x, io.DisplaySize.y); + ImGui::Text("io.DisplayFramebufferScale: %.2f,%.2f", io.DisplayFramebufferScale.x, io.DisplayFramebufferScale.y); + ImGui::Separator(); + ImGui::Text("style.WindowPadding: %.2f,%.2f", style.WindowPadding.x, style.WindowPadding.y); + ImGui::Text("style.WindowBorderSize: %.2f", style.WindowBorderSize); + ImGui::Text("style.FramePadding: %.2f,%.2f", style.FramePadding.x, style.FramePadding.y); + ImGui::Text("style.FrameRounding: %.2f", style.FrameRounding); + ImGui::Text("style.FrameBorderSize: %.2f", style.FrameBorderSize); + ImGui::Text("style.ItemSpacing: %.2f,%.2f", style.ItemSpacing.x, style.ItemSpacing.y); + ImGui::Text("style.ItemInnerSpacing: %.2f,%.2f", style.ItemInnerSpacing.x, style.ItemInnerSpacing.y); + + if (copy_to_clipboard) + { + ImGui::LogText("\n```\n"); + ImGui::LogFinish(); + } + ImGui::EndChildFrame(); + } + ImGui::End(); +} + +//----------------------------------------------------------------------------- +// [SECTION] Style Editor / ShowStyleEditor() +//----------------------------------------------------------------------------- +// - ShowFontSelector() +// - ShowStyleSelector() +// - ShowStyleEditor() +//----------------------------------------------------------------------------- + +// Forward declare ShowFontAtlas() which isn't worth putting in public API yet +namespace ImGui { IMGUI_API void ShowFontAtlas(ImFontAtlas* atlas); } + +// Demo helper function to select among loaded fonts. +// Here we use the regular BeginCombo()/EndCombo() api which is more the more flexible one. +void ImGui::ShowFontSelector(const char* label) +{ + ImGuiIO& io = ImGui::GetIO(); + ImFont* font_current = ImGui::GetFont(); + if (ImGui::BeginCombo(label, font_current->GetDebugName())) + { + for (int n = 0; n < io.Fonts->Fonts.Size; n++) + { + ImFont* font = io.Fonts->Fonts[n]; + ImGui::PushID((void*)font); + if (ImGui::Selectable(font->GetDebugName(), font == font_current)) + io.FontDefault = font; + ImGui::PopID(); + } + ImGui::EndCombo(); + } + ImGui::SameLine(); + HelpMarker( + "- Load additional fonts with io.Fonts->AddFontFromFileTTF().\n" + "- The font atlas is built when calling io.Fonts->GetTexDataAsXXXX() or io.Fonts->Build().\n" + "- Read FAQ and docs/FONTS.md for more details.\n" + "- If you need to add/remove fonts at runtime (e.g. for DPI change), do it before calling NewFrame()."); +} + +// Demo helper function to select among default colors. See ShowStyleEditor() for more advanced options. +// Here we use the simplified Combo() api that packs items into a single literal string. +// Useful for quick combo boxes where the choices are known locally. +bool ImGui::ShowStyleSelector(const char* label) +{ + static int style_idx = -1; + if (ImGui::Combo(label, &style_idx, "Dark\0Light\0Classic\0")) + { + switch (style_idx) + { + case 0: ImGui::StyleColorsDark(); break; + case 1: ImGui::StyleColorsLight(); break; + case 2: ImGui::StyleColorsClassic(); break; + } + return true; + } + return false; +} + +void ImGui::ShowStyleEditor(ImGuiStyle* ref) +{ + // You can pass in a reference ImGuiStyle structure to compare to, revert to and save to + // (without a reference style pointer, we will use one compared locally as a reference) + ImGuiStyle& style = ImGui::GetStyle(); + static ImGuiStyle ref_saved_style; + + // Default to using internal storage as reference + static bool init = true; + if (init && ref == NULL) + ref_saved_style = style; + init = false; + if (ref == NULL) + ref = &ref_saved_style; + + ImGui::PushItemWidth(ImGui::GetWindowWidth() * 0.50f); + + if (ImGui::ShowStyleSelector("Colors##Selector")) + ref_saved_style = style; + ImGui::ShowFontSelector("Fonts##Selector"); + + // Simplified Settings (expose floating-pointer border sizes as boolean representing 0.0f or 1.0f) + if (ImGui::SliderFloat("FrameRounding", &style.FrameRounding, 0.0f, 12.0f, "%.0f")) + style.GrabRounding = style.FrameRounding; // Make GrabRounding always the same value as FrameRounding + { bool border = (style.WindowBorderSize > 0.0f); if (ImGui::Checkbox("WindowBorder", &border)) { style.WindowBorderSize = border ? 1.0f : 0.0f; } } + ImGui::SameLine(); + { bool border = (style.FrameBorderSize > 0.0f); if (ImGui::Checkbox("FrameBorder", &border)) { style.FrameBorderSize = border ? 1.0f : 0.0f; } } + ImGui::SameLine(); + { bool border = (style.PopupBorderSize > 0.0f); if (ImGui::Checkbox("PopupBorder", &border)) { style.PopupBorderSize = border ? 1.0f : 0.0f; } } + + // Save/Revert button + if (ImGui::Button("Save Ref")) + *ref = ref_saved_style = style; + ImGui::SameLine(); + if (ImGui::Button("Revert Ref")) + style = *ref; + ImGui::SameLine(); + HelpMarker( + "Save/Revert in local non-persistent storage. Default Colors definition are not affected. " + "Use \"Export\" below to save them somewhere."); + + ImGui::Separator(); + + if (ImGui::BeginTabBar("##tabs", ImGuiTabBarFlags_None)) + { + if (ImGui::BeginTabItem("Sizes")) + { + ImGui::Text("Main"); + ImGui::SliderFloat2("WindowPadding", (float*)&style.WindowPadding, 0.0f, 20.0f, "%.0f"); + ImGui::SliderFloat2("FramePadding", (float*)&style.FramePadding, 0.0f, 20.0f, "%.0f"); + ImGui::SliderFloat2("CellPadding", (float*)&style.CellPadding, 0.0f, 20.0f, "%.0f"); + ImGui::SliderFloat2("ItemSpacing", (float*)&style.ItemSpacing, 0.0f, 20.0f, "%.0f"); + ImGui::SliderFloat2("ItemInnerSpacing", (float*)&style.ItemInnerSpacing, 0.0f, 20.0f, "%.0f"); + ImGui::SliderFloat2("TouchExtraPadding", (float*)&style.TouchExtraPadding, 0.0f, 10.0f, "%.0f"); + ImGui::SliderFloat("IndentSpacing", &style.IndentSpacing, 0.0f, 30.0f, "%.0f"); + ImGui::SliderFloat("ScrollbarSize", &style.ScrollbarSize, 1.0f, 20.0f, "%.0f"); + ImGui::SliderFloat("GrabMinSize", &style.GrabMinSize, 1.0f, 20.0f, "%.0f"); + ImGui::Text("Borders"); + ImGui::SliderFloat("WindowBorderSize", &style.WindowBorderSize, 0.0f, 1.0f, "%.0f"); + ImGui::SliderFloat("ChildBorderSize", &style.ChildBorderSize, 0.0f, 1.0f, "%.0f"); + ImGui::SliderFloat("PopupBorderSize", &style.PopupBorderSize, 0.0f, 1.0f, "%.0f"); + ImGui::SliderFloat("FrameBorderSize", &style.FrameBorderSize, 0.0f, 1.0f, "%.0f"); + ImGui::SliderFloat("TabBorderSize", &style.TabBorderSize, 0.0f, 1.0f, "%.0f"); + ImGui::Text("Rounding"); + ImGui::SliderFloat("WindowRounding", &style.WindowRounding, 0.0f, 12.0f, "%.0f"); + ImGui::SliderFloat("ChildRounding", &style.ChildRounding, 0.0f, 12.0f, "%.0f"); + ImGui::SliderFloat("FrameRounding", &style.FrameRounding, 0.0f, 12.0f, "%.0f"); + ImGui::SliderFloat("PopupRounding", &style.PopupRounding, 0.0f, 12.0f, "%.0f"); + ImGui::SliderFloat("ScrollbarRounding", &style.ScrollbarRounding, 0.0f, 12.0f, "%.0f"); + ImGui::SliderFloat("GrabRounding", &style.GrabRounding, 0.0f, 12.0f, "%.0f"); + ImGui::SliderFloat("LogSliderDeadzone", &style.LogSliderDeadzone, 0.0f, 12.0f, "%.0f"); + ImGui::SliderFloat("TabRounding", &style.TabRounding, 0.0f, 12.0f, "%.0f"); + ImGui::Text("Alignment"); + ImGui::SliderFloat2("WindowTitleAlign", (float*)&style.WindowTitleAlign, 0.0f, 1.0f, "%.2f"); + int window_menu_button_position = style.WindowMenuButtonPosition + 1; + if (ImGui::Combo("WindowMenuButtonPosition", (int*)&window_menu_button_position, "None\0Left\0Right\0")) + style.WindowMenuButtonPosition = window_menu_button_position - 1; + ImGui::Combo("ColorButtonPosition", (int*)&style.ColorButtonPosition, "Left\0Right\0"); + ImGui::SliderFloat2("ButtonTextAlign", (float*)&style.ButtonTextAlign, 0.0f, 1.0f, "%.2f"); + ImGui::SameLine(); HelpMarker("Alignment applies when a button is larger than its text content."); + ImGui::SliderFloat2("SelectableTextAlign", (float*)&style.SelectableTextAlign, 0.0f, 1.0f, "%.2f"); + ImGui::SameLine(); HelpMarker("Alignment applies when a selectable is larger than its text content."); + ImGui::Text("Safe Area Padding"); + ImGui::SameLine(); HelpMarker("Adjust if you cannot see the edges of your screen (e.g. on a TV where scaling has not been configured)."); + ImGui::SliderFloat2("DisplaySafeAreaPadding", (float*)&style.DisplaySafeAreaPadding, 0.0f, 30.0f, "%.0f"); + ImGui::EndTabItem(); + } + + if (ImGui::BeginTabItem("Colors")) + { + static int output_dest = 0; + static bool output_only_modified = true; + if (ImGui::Button("Export")) + { + if (output_dest == 0) + ImGui::LogToClipboard(); + else + ImGui::LogToTTY(); + ImGui::LogText("ImVec4* colors = ImGui::GetStyle().Colors;" IM_NEWLINE); + for (int i = 0; i < ImGuiCol_COUNT; i++) + { + const ImVec4& col = style.Colors[i]; + const char* name = ImGui::GetStyleColorName(i); + if (!output_only_modified || memcmp(&col, &ref->Colors[i], sizeof(ImVec4)) != 0) + ImGui::LogText("colors[ImGuiCol_%s]%*s= ImVec4(%.2ff, %.2ff, %.2ff, %.2ff);" IM_NEWLINE, + name, 23 - (int)strlen(name), "", col.x, col.y, col.z, col.w); + } + ImGui::LogFinish(); + } + ImGui::SameLine(); ImGui::SetNextItemWidth(120); ImGui::Combo("##output_type", &output_dest, "To Clipboard\0To TTY\0"); + ImGui::SameLine(); ImGui::Checkbox("Only Modified Colors", &output_only_modified); + + static ImGuiTextFilter filter; + filter.Draw("Filter colors", ImGui::GetFontSize() * 16); + + static ImGuiColorEditFlags alpha_flags = 0; + if (ImGui::RadioButton("Opaque", alpha_flags == ImGuiColorEditFlags_None)) { alpha_flags = ImGuiColorEditFlags_None; } ImGui::SameLine(); + if (ImGui::RadioButton("Alpha", alpha_flags == ImGuiColorEditFlags_AlphaPreview)) { alpha_flags = ImGuiColorEditFlags_AlphaPreview; } ImGui::SameLine(); + if (ImGui::RadioButton("Both", alpha_flags == ImGuiColorEditFlags_AlphaPreviewHalf)) { alpha_flags = ImGuiColorEditFlags_AlphaPreviewHalf; } ImGui::SameLine(); + HelpMarker( + "In the color list:\n" + "Left-click on color square to open color picker,\n" + "Right-click to open edit options menu."); + + ImGui::BeginChild("##colors", ImVec2(0, 0), true, ImGuiWindowFlags_AlwaysVerticalScrollbar | ImGuiWindowFlags_AlwaysHorizontalScrollbar | ImGuiWindowFlags_NavFlattened); + ImGui::PushItemWidth(-160); + for (int i = 0; i < ImGuiCol_COUNT; i++) + { + const char* name = ImGui::GetStyleColorName(i); + if (!filter.PassFilter(name)) + continue; + ImGui::PushID(i); + ImGui::ColorEdit4("##color", (float*)&style.Colors[i], ImGuiColorEditFlags_AlphaBar | alpha_flags); + if (memcmp(&style.Colors[i], &ref->Colors[i], sizeof(ImVec4)) != 0) + { + // Tips: in a real user application, you may want to merge and use an icon font into the main font, + // so instead of "Save"/"Revert" you'd use icons! + // Read the FAQ and docs/FONTS.md about using icon fonts. It's really easy and super convenient! + ImGui::SameLine(0.0f, style.ItemInnerSpacing.x); if (ImGui::Button("Save")) { ref->Colors[i] = style.Colors[i]; } + ImGui::SameLine(0.0f, style.ItemInnerSpacing.x); if (ImGui::Button("Revert")) { style.Colors[i] = ref->Colors[i]; } + } + ImGui::SameLine(0.0f, style.ItemInnerSpacing.x); + ImGui::TextUnformatted(name); + ImGui::PopID(); + } + ImGui::PopItemWidth(); + ImGui::EndChild(); + + ImGui::EndTabItem(); + } + + if (ImGui::BeginTabItem("Fonts")) + { + ImGuiIO& io = ImGui::GetIO(); + ImFontAtlas* atlas = io.Fonts; + HelpMarker("Read FAQ and docs/FONTS.md for details on font loading."); + ImGui::ShowFontAtlas(atlas); + + // Post-baking font scaling. Note that this is NOT the nice way of scaling fonts, read below. + // (we enforce hard clamping manually as by default DragFloat/SliderFloat allows CTRL+Click text to get out of bounds). + const float MIN_SCALE = 0.3f; + const float MAX_SCALE = 2.0f; + HelpMarker( + "Those are old settings provided for convenience.\n" + "However, the _correct_ way of scaling your UI is currently to reload your font at the designed size, " + "rebuild the font atlas, and call style.ScaleAllSizes() on a reference ImGuiStyle structure.\n" + "Using those settings here will give you poor quality results."); + static float window_scale = 1.0f; + ImGui::PushItemWidth(ImGui::GetFontSize() * 8); + if (ImGui::DragFloat("window scale", &window_scale, 0.005f, MIN_SCALE, MAX_SCALE, "%.2f", ImGuiSliderFlags_AlwaysClamp)) // Scale only this window + ImGui::SetWindowFontScale(window_scale); + ImGui::DragFloat("global scale", &io.FontGlobalScale, 0.005f, MIN_SCALE, MAX_SCALE, "%.2f", ImGuiSliderFlags_AlwaysClamp); // Scale everything + ImGui::PopItemWidth(); + + ImGui::EndTabItem(); + } + + if (ImGui::BeginTabItem("Rendering")) + { + ImGui::Checkbox("Anti-aliased lines", &style.AntiAliasedLines); + ImGui::SameLine(); + HelpMarker("When disabling anti-aliasing lines, you'll probably want to disable borders in your style as well."); + + ImGui::Checkbox("Anti-aliased lines use texture", &style.AntiAliasedLinesUseTex); + ImGui::SameLine(); + HelpMarker("Faster lines using texture data. Require backend to render with bilinear filtering (not point/nearest filtering)."); + + ImGui::Checkbox("Anti-aliased fill", &style.AntiAliasedFill); + ImGui::PushItemWidth(ImGui::GetFontSize() * 8); + ImGui::DragFloat("Curve Tessellation Tolerance", &style.CurveTessellationTol, 0.02f, 0.10f, 10.0f, "%.2f"); + if (style.CurveTessellationTol < 0.10f) style.CurveTessellationTol = 0.10f; + + // When editing the "Circle Segment Max Error" value, draw a preview of its effect on auto-tessellated circles. + ImGui::DragFloat("Circle Tessellation Max Error", &style.CircleTessellationMaxError , 0.005f, 0.10f, 5.0f, "%.2f", ImGuiSliderFlags_AlwaysClamp); + if (ImGui::IsItemActive()) + { + ImGui::SetNextWindowPos(ImGui::GetCursorScreenPos()); + ImGui::BeginTooltip(); + ImGui::TextUnformatted("(R = radius, N = number of segments)"); + ImGui::Spacing(); + ImDrawList* draw_list = ImGui::GetWindowDrawList(); + const float min_widget_width = ImGui::CalcTextSize("N: MMM\nR: MMM").x; + for (int n = 0; n < 8; n++) + { + const float RAD_MIN = 5.0f; + const float RAD_MAX = 70.0f; + const float rad = RAD_MIN + (RAD_MAX - RAD_MIN) * (float)n / (8.0f - 1.0f); + + ImGui::BeginGroup(); + + ImGui::Text("R: %.f\nN: %d", rad, draw_list->_CalcCircleAutoSegmentCount(rad)); + + const float canvas_width = IM_MAX(min_widget_width, rad * 2.0f); + const float offset_x = floorf(canvas_width * 0.5f); + const float offset_y = floorf(RAD_MAX); + + const ImVec2 p1 = ImGui::GetCursorScreenPos(); + draw_list->AddCircle(ImVec2(p1.x + offset_x, p1.y + offset_y), rad, ImGui::GetColorU32(ImGuiCol_Text)); + ImGui::Dummy(ImVec2(canvas_width, RAD_MAX * 2)); + + /* + const ImVec2 p2 = ImGui::GetCursorScreenPos(); + draw_list->AddCircleFilled(ImVec2(p2.x + offset_x, p2.y + offset_y), rad, ImGui::GetColorU32(ImGuiCol_Text)); + ImGui::Dummy(ImVec2(canvas_width, RAD_MAX * 2)); + */ + + ImGui::EndGroup(); + ImGui::SameLine(); + } + ImGui::EndTooltip(); + } + ImGui::SameLine(); + HelpMarker("When drawing circle primitives with \"num_segments == 0\" tesselation will be calculated automatically."); + + ImGui::DragFloat("Global Alpha", &style.Alpha, 0.005f, 0.20f, 1.0f, "%.2f"); // Not exposing zero here so user doesn't "lose" the UI (zero alpha clips all widgets). But application code could have a toggle to switch between zero and non-zero. + ImGui::DragFloat("Disabled Alpha", &style.DisabledAlpha, 0.005f, 0.0f, 1.0f, "%.2f"); ImGui::SameLine(); HelpMarker("Additional alpha multiplier for disabled items (multiply over current value of Alpha)."); + ImGui::PopItemWidth(); + + ImGui::EndTabItem(); + } + + ImGui::EndTabBar(); + } + + ImGui::PopItemWidth(); +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Main Menu Bar / ShowExampleAppMainMenuBar() +//----------------------------------------------------------------------------- +// - ShowExampleAppMainMenuBar() +// - ShowExampleMenuFile() +//----------------------------------------------------------------------------- + +// Demonstrate creating a "main" fullscreen menu bar and populating it. +// Note the difference between BeginMainMenuBar() and BeginMenuBar(): +// - BeginMenuBar() = menu-bar inside current window (which needs the ImGuiWindowFlags_MenuBar flag!) +// - BeginMainMenuBar() = helper to create menu-bar-sized window at the top of the main viewport + call BeginMenuBar() into it. +static void ShowExampleAppMainMenuBar() +{ + if (ImGui::BeginMainMenuBar()) + { + if (ImGui::BeginMenu("File")) + { + ShowExampleMenuFile(); + ImGui::EndMenu(); + } + if (ImGui::BeginMenu("Edit")) + { + if (ImGui::MenuItem("Undo", "CTRL+Z")) {} + if (ImGui::MenuItem("Redo", "CTRL+Y", false, false)) {} // Disabled item + ImGui::Separator(); + if (ImGui::MenuItem("Cut", "CTRL+X")) {} + if (ImGui::MenuItem("Copy", "CTRL+C")) {} + if (ImGui::MenuItem("Paste", "CTRL+V")) {} + ImGui::EndMenu(); + } + ImGui::EndMainMenuBar(); + } +} + +// Note that shortcuts are currently provided for display only +// (future version will add explicit flags to BeginMenu() to request processing shortcuts) +static void ShowExampleMenuFile() +{ + ImGui::MenuItem("(demo menu)", NULL, false, false); + if (ImGui::MenuItem("New")) {} + if (ImGui::MenuItem("Open", "Ctrl+O")) {} + if (ImGui::BeginMenu("Open Recent")) + { + ImGui::MenuItem("fish_hat.c"); + ImGui::MenuItem("fish_hat.inl"); + ImGui::MenuItem("fish_hat.h"); + if (ImGui::BeginMenu("More..")) + { + ImGui::MenuItem("Hello"); + ImGui::MenuItem("Sailor"); + if (ImGui::BeginMenu("Recurse..")) + { + ShowExampleMenuFile(); + ImGui::EndMenu(); + } + ImGui::EndMenu(); + } + ImGui::EndMenu(); + } + if (ImGui::MenuItem("Save", "Ctrl+S")) {} + if (ImGui::MenuItem("Save As..")) {} + + ImGui::Separator(); + if (ImGui::BeginMenu("Options")) + { + static bool enabled = true; + ImGui::MenuItem("Enabled", "", &enabled); + ImGui::BeginChild("child", ImVec2(0, 60), true); + for (int i = 0; i < 10; i++) + ImGui::Text("Scrolling Text %d", i); + ImGui::EndChild(); + static float f = 0.5f; + static int n = 0; + ImGui::SliderFloat("Value", &f, 0.0f, 1.0f); + ImGui::InputFloat("Input", &f, 0.1f); + ImGui::Combo("Combo", &n, "Yes\0No\0Maybe\0\0"); + ImGui::EndMenu(); + } + + if (ImGui::BeginMenu("Colors")) + { + float sz = ImGui::GetTextLineHeight(); + for (int i = 0; i < ImGuiCol_COUNT; i++) + { + const char* name = ImGui::GetStyleColorName((ImGuiCol)i); + ImVec2 p = ImGui::GetCursorScreenPos(); + ImGui::GetWindowDrawList()->AddRectFilled(p, ImVec2(p.x + sz, p.y + sz), ImGui::GetColorU32((ImGuiCol)i)); + ImGui::Dummy(ImVec2(sz, sz)); + ImGui::SameLine(); + ImGui::MenuItem(name); + } + ImGui::EndMenu(); + } + + // Here we demonstrate appending again to the "Options" menu (which we already created above) + // Of course in this demo it is a little bit silly that this function calls BeginMenu("Options") twice. + // In a real code-base using it would make senses to use this feature from very different code locations. + if (ImGui::BeginMenu("Options")) // <-- Append! + { + static bool b = true; + ImGui::Checkbox("SomeOption", &b); + ImGui::EndMenu(); + } + + if (ImGui::BeginMenu("Disabled", false)) // Disabled + { + IM_ASSERT(0); + } + if (ImGui::MenuItem("Checked", NULL, true)) {} + if (ImGui::MenuItem("Quit", "Alt+F4")) {} +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Debug Console / ShowExampleAppConsole() +//----------------------------------------------------------------------------- + +// Demonstrate creating a simple console window, with scrolling, filtering, completion and history. +// For the console example, we are using a more C++ like approach of declaring a class to hold both data and functions. +struct ExampleAppConsole +{ + char InputBuf[256]; + ImVector Items; + ImVector Commands; + ImVector History; + int HistoryPos; // -1: new line, 0..History.Size-1 browsing history. + ImGuiTextFilter Filter; + bool AutoScroll; + bool ScrollToBottom; + + ExampleAppConsole() + { + ClearLog(); + memset(InputBuf, 0, sizeof(InputBuf)); + HistoryPos = -1; + + // "CLASSIFY" is here to provide the test case where "C"+[tab] completes to "CL" and display multiple matches. + Commands.push_back("HELP"); + Commands.push_back("HISTORY"); + Commands.push_back("CLEAR"); + Commands.push_back("CLASSIFY"); + AutoScroll = true; + ScrollToBottom = false; + AddLog("Welcome to Dear ImGui!"); + } + ~ExampleAppConsole() + { + ClearLog(); + for (int i = 0; i < History.Size; i++) + free(History[i]); + } + + // Portable helpers + static int Stricmp(const char* s1, const char* s2) { int d; while ((d = toupper(*s2) - toupper(*s1)) == 0 && *s1) { s1++; s2++; } return d; } + static int Strnicmp(const char* s1, const char* s2, int n) { int d = 0; while (n > 0 && (d = toupper(*s2) - toupper(*s1)) == 0 && *s1) { s1++; s2++; n--; } return d; } + static char* Strdup(const char* s) { IM_ASSERT(s); size_t len = strlen(s) + 1; void* buf = malloc(len); IM_ASSERT(buf); return (char*)memcpy(buf, (const void*)s, len); } + static void Strtrim(char* s) { char* str_end = s + strlen(s); while (str_end > s && str_end[-1] == ' ') str_end--; *str_end = 0; } + + void ClearLog() + { + for (int i = 0; i < Items.Size; i++) + free(Items[i]); + Items.clear(); + } + + void AddLog(const char* fmt, ...) IM_FMTARGS(2) + { + // FIXME-OPT + char buf[1024]; + va_list args; + va_start(args, fmt); + vsnprintf(buf, IM_ARRAYSIZE(buf), fmt, args); + buf[IM_ARRAYSIZE(buf)-1] = 0; + va_end(args); + Items.push_back(Strdup(buf)); + } + + void Draw(const char* title, bool* p_open) + { + ImGui::SetNextWindowSize(ImVec2(520, 600), ImGuiCond_FirstUseEver); + if (!ImGui::Begin(title, p_open)) + { + ImGui::End(); + return; + } + + // As a specific feature guaranteed by the library, after calling Begin() the last Item represent the title bar. + // So e.g. IsItemHovered() will return true when hovering the title bar. + // Here we create a context menu only available from the title bar. + if (ImGui::BeginPopupContextItem()) + { + if (ImGui::MenuItem("Close Console")) + *p_open = false; + ImGui::EndPopup(); + } + + ImGui::TextWrapped( + "This example implements a console with basic coloring, completion (TAB key) and history (Up/Down keys). A more elaborate " + "implementation may want to store entries along with extra data such as timestamp, emitter, etc."); + ImGui::TextWrapped("Enter 'HELP' for help."); + + // TODO: display items starting from the bottom + + if (ImGui::SmallButton("Add Debug Text")) { AddLog("%d some text", Items.Size); AddLog("some more text"); AddLog("display very important message here!"); } + ImGui::SameLine(); + if (ImGui::SmallButton("Add Debug Error")) { AddLog("[error] something went wrong"); } + ImGui::SameLine(); + if (ImGui::SmallButton("Clear")) { ClearLog(); } + ImGui::SameLine(); + bool copy_to_clipboard = ImGui::SmallButton("Copy"); + //static float t = 0.0f; if (ImGui::GetTime() - t > 0.02f) { t = ImGui::GetTime(); AddLog("Spam %f", t); } + + ImGui::Separator(); + + // Options menu + if (ImGui::BeginPopup("Options")) + { + ImGui::Checkbox("Auto-scroll", &AutoScroll); + ImGui::EndPopup(); + } + + // Options, Filter + if (ImGui::Button("Options")) + ImGui::OpenPopup("Options"); + ImGui::SameLine(); + Filter.Draw("Filter (\"incl,-excl\") (\"error\")", 180); + ImGui::Separator(); + + // Reserve enough left-over height for 1 separator + 1 input text + const float footer_height_to_reserve = ImGui::GetStyle().ItemSpacing.y + ImGui::GetFrameHeightWithSpacing(); + ImGui::BeginChild("ScrollingRegion", ImVec2(0, -footer_height_to_reserve), false, ImGuiWindowFlags_HorizontalScrollbar); + if (ImGui::BeginPopupContextWindow()) + { + if (ImGui::Selectable("Clear")) ClearLog(); + ImGui::EndPopup(); + } + + // Display every line as a separate entry so we can change their color or add custom widgets. + // If you only want raw text you can use ImGui::TextUnformatted(log.begin(), log.end()); + // NB- if you have thousands of entries this approach may be too inefficient and may require user-side clipping + // to only process visible items. The clipper will automatically measure the height of your first item and then + // "seek" to display only items in the visible area. + // To use the clipper we can replace your standard loop: + // for (int i = 0; i < Items.Size; i++) + // With: + // ImGuiListClipper clipper; + // clipper.Begin(Items.Size); + // while (clipper.Step()) + // for (int i = clipper.DisplayStart; i < clipper.DisplayEnd; i++) + // - That your items are evenly spaced (same height) + // - That you have cheap random access to your elements (you can access them given their index, + // without processing all the ones before) + // You cannot this code as-is if a filter is active because it breaks the 'cheap random-access' property. + // We would need random-access on the post-filtered list. + // A typical application wanting coarse clipping and filtering may want to pre-compute an array of indices + // or offsets of items that passed the filtering test, recomputing this array when user changes the filter, + // and appending newly elements as they are inserted. This is left as a task to the user until we can manage + // to improve this example code! + // If your items are of variable height: + // - Split them into same height items would be simpler and facilitate random-seeking into your list. + // - Consider using manual call to IsRectVisible() and skipping extraneous decoration from your items. + ImGui::PushStyleVar(ImGuiStyleVar_ItemSpacing, ImVec2(4, 1)); // Tighten spacing + if (copy_to_clipboard) + ImGui::LogToClipboard(); + for (int i = 0; i < Items.Size; i++) + { + const char* item = Items[i]; + if (!Filter.PassFilter(item)) + continue; + + // Normally you would store more information in your item than just a string. + // (e.g. make Items[] an array of structure, store color/type etc.) + ImVec4 color; + bool has_color = false; + if (strstr(item, "[error]")) { color = ImVec4(1.0f, 0.4f, 0.4f, 1.0f); has_color = true; } + else if (strncmp(item, "# ", 2) == 0) { color = ImVec4(1.0f, 0.8f, 0.6f, 1.0f); has_color = true; } + if (has_color) + ImGui::PushStyleColor(ImGuiCol_Text, color); + ImGui::TextUnformatted(item); + if (has_color) + ImGui::PopStyleColor(); + } + if (copy_to_clipboard) + ImGui::LogFinish(); + + if (ScrollToBottom || (AutoScroll && ImGui::GetScrollY() >= ImGui::GetScrollMaxY())) + ImGui::SetScrollHereY(1.0f); + ScrollToBottom = false; + + ImGui::PopStyleVar(); + ImGui::EndChild(); + ImGui::Separator(); + + // Command-line + bool reclaim_focus = false; + ImGuiInputTextFlags input_text_flags = ImGuiInputTextFlags_EnterReturnsTrue | ImGuiInputTextFlags_CallbackCompletion | ImGuiInputTextFlags_CallbackHistory; + if (ImGui::InputText("Input", InputBuf, IM_ARRAYSIZE(InputBuf), input_text_flags, &TextEditCallbackStub, (void*)this)) + { + char* s = InputBuf; + Strtrim(s); + if (s[0]) + ExecCommand(s); + strcpy(s, ""); + reclaim_focus = true; + } + + // Auto-focus on window apparition + ImGui::SetItemDefaultFocus(); + if (reclaim_focus) + ImGui::SetKeyboardFocusHere(-1); // Auto focus previous widget + + ImGui::End(); + } + + void ExecCommand(const char* command_line) + { + AddLog("# %s\n", command_line); + + // Insert into history. First find match and delete it so it can be pushed to the back. + // This isn't trying to be smart or optimal. + HistoryPos = -1; + for (int i = History.Size - 1; i >= 0; i--) + if (Stricmp(History[i], command_line) == 0) + { + free(History[i]); + History.erase(History.begin() + i); + break; + } + History.push_back(Strdup(command_line)); + + // Process command + if (Stricmp(command_line, "CLEAR") == 0) + { + ClearLog(); + } + else if (Stricmp(command_line, "HELP") == 0) + { + AddLog("Commands:"); + for (int i = 0; i < Commands.Size; i++) + AddLog("- %s", Commands[i]); + } + else if (Stricmp(command_line, "HISTORY") == 0) + { + int first = History.Size - 10; + for (int i = first > 0 ? first : 0; i < History.Size; i++) + AddLog("%3d: %s\n", i, History[i]); + } + else + { + AddLog("Unknown command: '%s'\n", command_line); + } + + // On command input, we scroll to bottom even if AutoScroll==false + ScrollToBottom = true; + } + + // In C++11 you'd be better off using lambdas for this sort of forwarding callbacks + static int TextEditCallbackStub(ImGuiInputTextCallbackData* data) + { + ExampleAppConsole* console = (ExampleAppConsole*)data->UserData; + return console->TextEditCallback(data); + } + + int TextEditCallback(ImGuiInputTextCallbackData* data) + { + //AddLog("cursor: %d, selection: %d-%d", data->CursorPos, data->SelectionStart, data->SelectionEnd); + switch (data->EventFlag) + { + case ImGuiInputTextFlags_CallbackCompletion: + { + // Example of TEXT COMPLETION + + // Locate beginning of current word + const char* word_end = data->Buf + data->CursorPos; + const char* word_start = word_end; + while (word_start > data->Buf) + { + const char c = word_start[-1]; + if (c == ' ' || c == '\t' || c == ',' || c == ';') + break; + word_start--; + } + + // Build a list of candidates + ImVector candidates; + for (int i = 0; i < Commands.Size; i++) + if (Strnicmp(Commands[i], word_start, (int)(word_end - word_start)) == 0) + candidates.push_back(Commands[i]); + + if (candidates.Size == 0) + { + // No match + AddLog("No match for \"%.*s\"!\n", (int)(word_end - word_start), word_start); + } + else if (candidates.Size == 1) + { + // Single match. Delete the beginning of the word and replace it entirely so we've got nice casing. + data->DeleteChars((int)(word_start - data->Buf), (int)(word_end - word_start)); + data->InsertChars(data->CursorPos, candidates[0]); + data->InsertChars(data->CursorPos, " "); + } + else + { + // Multiple matches. Complete as much as we can.. + // So inputing "C"+Tab will complete to "CL" then display "CLEAR" and "CLASSIFY" as matches. + int match_len = (int)(word_end - word_start); + for (;;) + { + int c = 0; + bool all_candidates_matches = true; + for (int i = 0; i < candidates.Size && all_candidates_matches; i++) + if (i == 0) + c = toupper(candidates[i][match_len]); + else if (c == 0 || c != toupper(candidates[i][match_len])) + all_candidates_matches = false; + if (!all_candidates_matches) + break; + match_len++; + } + + if (match_len > 0) + { + data->DeleteChars((int)(word_start - data->Buf), (int)(word_end - word_start)); + data->InsertChars(data->CursorPos, candidates[0], candidates[0] + match_len); + } + + // List matches + AddLog("Possible matches:\n"); + for (int i = 0; i < candidates.Size; i++) + AddLog("- %s\n", candidates[i]); + } + + break; + } + case ImGuiInputTextFlags_CallbackHistory: + { + // Example of HISTORY + const int prev_history_pos = HistoryPos; + if (data->EventKey == ImGuiKey_UpArrow) + { + if (HistoryPos == -1) + HistoryPos = History.Size - 1; + else if (HistoryPos > 0) + HistoryPos--; + } + else if (data->EventKey == ImGuiKey_DownArrow) + { + if (HistoryPos != -1) + if (++HistoryPos >= History.Size) + HistoryPos = -1; + } + + // A better implementation would preserve the data on the current input line along with cursor position. + if (prev_history_pos != HistoryPos) + { + const char* history_str = (HistoryPos >= 0) ? History[HistoryPos] : ""; + data->DeleteChars(0, data->BufTextLen); + data->InsertChars(0, history_str); + } + } + } + return 0; + } +}; + +static void ShowExampleAppConsole(bool* p_open) +{ + static ExampleAppConsole console; + console.Draw("Example: Console", p_open); +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Debug Log / ShowExampleAppLog() +//----------------------------------------------------------------------------- + +// Usage: +// static ExampleAppLog my_log; +// my_log.AddLog("Hello %d world\n", 123); +// my_log.Draw("title"); +struct ExampleAppLog +{ + ImGuiTextBuffer Buf; + ImGuiTextFilter Filter; + ImVector LineOffsets; // Index to lines offset. We maintain this with AddLog() calls. + bool AutoScroll; // Keep scrolling if already at the bottom. + + ExampleAppLog() + { + AutoScroll = true; + Clear(); + } + + void Clear() + { + Buf.clear(); + LineOffsets.clear(); + LineOffsets.push_back(0); + } + + void AddLog(const char* fmt, ...) IM_FMTARGS(2) + { + int old_size = Buf.size(); + va_list args; + va_start(args, fmt); + Buf.appendfv(fmt, args); + va_end(args); + for (int new_size = Buf.size(); old_size < new_size; old_size++) + if (Buf[old_size] == '\n') + LineOffsets.push_back(old_size + 1); + } + + void Draw(const char* title, bool* p_open = NULL) + { + if (!ImGui::Begin(title, p_open)) + { + ImGui::End(); + return; + } + + // Options menu + if (ImGui::BeginPopup("Options")) + { + ImGui::Checkbox("Auto-scroll", &AutoScroll); + ImGui::EndPopup(); + } + + // Main window + if (ImGui::Button("Options")) + ImGui::OpenPopup("Options"); + ImGui::SameLine(); + bool clear = ImGui::Button("Clear"); + ImGui::SameLine(); + bool copy = ImGui::Button("Copy"); + ImGui::SameLine(); + Filter.Draw("Filter", -100.0f); + + ImGui::Separator(); + ImGui::BeginChild("scrolling", ImVec2(0, 0), false, ImGuiWindowFlags_HorizontalScrollbar); + + if (clear) + Clear(); + if (copy) + ImGui::LogToClipboard(); + + ImGui::PushStyleVar(ImGuiStyleVar_ItemSpacing, ImVec2(0, 0)); + const char* buf = Buf.begin(); + const char* buf_end = Buf.end(); + if (Filter.IsActive()) + { + // In this example we don't use the clipper when Filter is enabled. + // This is because we don't have a random access on the result on our filter. + // A real application processing logs with ten of thousands of entries may want to store the result of + // search/filter.. especially if the filtering function is not trivial (e.g. reg-exp). + for (int line_no = 0; line_no < LineOffsets.Size; line_no++) + { + const char* line_start = buf + LineOffsets[line_no]; + const char* line_end = (line_no + 1 < LineOffsets.Size) ? (buf + LineOffsets[line_no + 1] - 1) : buf_end; + if (Filter.PassFilter(line_start, line_end)) + ImGui::TextUnformatted(line_start, line_end); + } + } + else + { + // The simplest and easy way to display the entire buffer: + // ImGui::TextUnformatted(buf_begin, buf_end); + // And it'll just work. TextUnformatted() has specialization for large blob of text and will fast-forward + // to skip non-visible lines. Here we instead demonstrate using the clipper to only process lines that are + // within the visible area. + // If you have tens of thousands of items and their processing cost is non-negligible, coarse clipping them + // on your side is recommended. Using ImGuiListClipper requires + // - A) random access into your data + // - B) items all being the same height, + // both of which we can handle since we an array pointing to the beginning of each line of text. + // When using the filter (in the block of code above) we don't have random access into the data to display + // anymore, which is why we don't use the clipper. Storing or skimming through the search result would make + // it possible (and would be recommended if you want to search through tens of thousands of entries). + ImGuiListClipper clipper; + clipper.Begin(LineOffsets.Size); + while (clipper.Step()) + { + for (int line_no = clipper.DisplayStart; line_no < clipper.DisplayEnd; line_no++) + { + const char* line_start = buf + LineOffsets[line_no]; + const char* line_end = (line_no + 1 < LineOffsets.Size) ? (buf + LineOffsets[line_no + 1] - 1) : buf_end; + ImGui::TextUnformatted(line_start, line_end); + } + } + clipper.End(); + } + ImGui::PopStyleVar(); + + if (AutoScroll && ImGui::GetScrollY() >= ImGui::GetScrollMaxY()) + ImGui::SetScrollHereY(1.0f); + + ImGui::EndChild(); + ImGui::End(); + } +}; + +// Demonstrate creating a simple log window with basic filtering. +static void ShowExampleAppLog(bool* p_open) +{ + static ExampleAppLog log; + + // For the demo: add a debug button _BEFORE_ the normal log window contents + // We take advantage of a rarely used feature: multiple calls to Begin()/End() are appending to the _same_ window. + // Most of the contents of the window will be added by the log.Draw() call. + ImGui::SetNextWindowSize(ImVec2(500, 400), ImGuiCond_FirstUseEver); + ImGui::Begin("Example: Log", p_open); + if (ImGui::SmallButton("[Debug] Add 5 entries")) + { + static int counter = 0; + const char* categories[3] = { "info", "warn", "error" }; + const char* words[] = { "Bumfuzzled", "Cattywampus", "Snickersnee", "Abibliophobia", "Absquatulate", "Nincompoop", "Pauciloquent" }; + for (int n = 0; n < 5; n++) + { + const char* category = categories[counter % IM_ARRAYSIZE(categories)]; + const char* word = words[counter % IM_ARRAYSIZE(words)]; + log.AddLog("[%05d] [%s] Hello, current time is %.1f, here's a word: '%s'\n", + ImGui::GetFrameCount(), category, ImGui::GetTime(), word); + counter++; + } + } + ImGui::End(); + + // Actually call in the regular Log helper (which will Begin() into the same window as we just did) + log.Draw("Example: Log", p_open); +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Simple Layout / ShowExampleAppLayout() +//----------------------------------------------------------------------------- + +// Demonstrate create a window with multiple child windows. +static void ShowExampleAppLayout(bool* p_open) +{ + ImGui::SetNextWindowSize(ImVec2(500, 440), ImGuiCond_FirstUseEver); + if (ImGui::Begin("Example: Simple layout", p_open, ImGuiWindowFlags_MenuBar)) + { + if (ImGui::BeginMenuBar()) + { + if (ImGui::BeginMenu("File")) + { + if (ImGui::MenuItem("Close")) *p_open = false; + ImGui::EndMenu(); + } + ImGui::EndMenuBar(); + } + + // Left + static int selected = 0; + { + ImGui::BeginChild("left pane", ImVec2(150, 0), true); + for (int i = 0; i < 100; i++) + { + // FIXME: Good candidate to use ImGuiSelectableFlags_SelectOnNav + char label[128]; + sprintf(label, "MyObject %d", i); + if (ImGui::Selectable(label, selected == i)) + selected = i; + } + ImGui::EndChild(); + } + ImGui::SameLine(); + + // Right + { + ImGui::BeginGroup(); + ImGui::BeginChild("item view", ImVec2(0, -ImGui::GetFrameHeightWithSpacing())); // Leave room for 1 line below us + ImGui::Text("MyObject: %d", selected); + ImGui::Separator(); + if (ImGui::BeginTabBar("##Tabs", ImGuiTabBarFlags_None)) + { + if (ImGui::BeginTabItem("Description")) + { + ImGui::TextWrapped("Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. "); + ImGui::EndTabItem(); + } + if (ImGui::BeginTabItem("Details")) + { + ImGui::Text("ID: 0123456789"); + ImGui::EndTabItem(); + } + ImGui::EndTabBar(); + } + ImGui::EndChild(); + if (ImGui::Button("Revert")) {} + ImGui::SameLine(); + if (ImGui::Button("Save")) {} + ImGui::EndGroup(); + } + } + ImGui::End(); +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Property Editor / ShowExampleAppPropertyEditor() +//----------------------------------------------------------------------------- + +static void ShowPlaceholderObject(const char* prefix, int uid) +{ + // Use object uid as identifier. Most commonly you could also use the object pointer as a base ID. + ImGui::PushID(uid); + + // Text and Tree nodes are less high than framed widgets, using AlignTextToFramePadding() we add vertical spacing to make the tree lines equal high. + ImGui::TableNextRow(); + ImGui::TableSetColumnIndex(0); + ImGui::AlignTextToFramePadding(); + bool node_open = ImGui::TreeNode("Object", "%s_%u", prefix, uid); + ImGui::TableSetColumnIndex(1); + ImGui::Text("my sailor is rich"); + + if (node_open) + { + static float placeholder_members[8] = { 0.0f, 0.0f, 1.0f, 3.1416f, 100.0f, 999.0f }; + for (int i = 0; i < 8; i++) + { + ImGui::PushID(i); // Use field index as identifier. + if (i < 2) + { + ShowPlaceholderObject("Child", 424242); + } + else + { + // Here we use a TreeNode to highlight on hover (we could use e.g. Selectable as well) + ImGui::TableNextRow(); + ImGui::TableSetColumnIndex(0); + ImGui::AlignTextToFramePadding(); + ImGuiTreeNodeFlags flags = ImGuiTreeNodeFlags_Leaf | ImGuiTreeNodeFlags_NoTreePushOnOpen | ImGuiTreeNodeFlags_Bullet; + ImGui::TreeNodeEx("Field", flags, "Field_%d", i); + + ImGui::TableSetColumnIndex(1); + ImGui::SetNextItemWidth(-FLT_MIN); + if (i >= 5) + ImGui::InputFloat("##value", &placeholder_members[i], 1.0f); + else + ImGui::DragFloat("##value", &placeholder_members[i], 0.01f); + ImGui::NextColumn(); + } + ImGui::PopID(); + } + ImGui::TreePop(); + } + ImGui::PopID(); +} + +// Demonstrate create a simple property editor. +static void ShowExampleAppPropertyEditor(bool* p_open) +{ + ImGui::SetNextWindowSize(ImVec2(430, 450), ImGuiCond_FirstUseEver); + if (!ImGui::Begin("Example: Property editor", p_open)) + { + ImGui::End(); + return; + } + + HelpMarker( + "This example shows how you may implement a property editor using two columns.\n" + "All objects/fields data are dummies here.\n" + "Remember that in many simple cases, you can use ImGui::SameLine(xxx) to position\n" + "your cursor horizontally instead of using the Columns() API."); + + ImGui::PushStyleVar(ImGuiStyleVar_FramePadding, ImVec2(2, 2)); + if (ImGui::BeginTable("split", 2, ImGuiTableFlags_BordersOuter | ImGuiTableFlags_Resizable)) + { + // Iterate placeholder objects (all the same data) + for (int obj_i = 0; obj_i < 4; obj_i++) + { + ShowPlaceholderObject("Object", obj_i); + //ImGui::Separator(); + } + ImGui::EndTable(); + } + ImGui::PopStyleVar(); + ImGui::End(); +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Long Text / ShowExampleAppLongText() +//----------------------------------------------------------------------------- + +// Demonstrate/test rendering huge amount of text, and the incidence of clipping. +static void ShowExampleAppLongText(bool* p_open) +{ + ImGui::SetNextWindowSize(ImVec2(520, 600), ImGuiCond_FirstUseEver); + if (!ImGui::Begin("Example: Long text display", p_open)) + { + ImGui::End(); + return; + } + + static int test_type = 0; + static ImGuiTextBuffer log; + static int lines = 0; + ImGui::Text("Printing unusually long amount of text."); + ImGui::Combo("Test type", &test_type, + "Single call to TextUnformatted()\0" + "Multiple calls to Text(), clipped\0" + "Multiple calls to Text(), not clipped (slow)\0"); + ImGui::Text("Buffer contents: %d lines, %d bytes", lines, log.size()); + if (ImGui::Button("Clear")) { log.clear(); lines = 0; } + ImGui::SameLine(); + if (ImGui::Button("Add 1000 lines")) + { + for (int i = 0; i < 1000; i++) + log.appendf("%i The quick brown fox jumps over the lazy dog\n", lines + i); + lines += 1000; + } + ImGui::BeginChild("Log"); + switch (test_type) + { + case 0: + // Single call to TextUnformatted() with a big buffer + ImGui::TextUnformatted(log.begin(), log.end()); + break; + case 1: + { + // Multiple calls to Text(), manually coarsely clipped - demonstrate how to use the ImGuiListClipper helper. + ImGui::PushStyleVar(ImGuiStyleVar_ItemSpacing, ImVec2(0, 0)); + ImGuiListClipper clipper; + clipper.Begin(lines); + while (clipper.Step()) + for (int i = clipper.DisplayStart; i < clipper.DisplayEnd; i++) + ImGui::Text("%i The quick brown fox jumps over the lazy dog", i); + ImGui::PopStyleVar(); + break; + } + case 2: + // Multiple calls to Text(), not clipped (slow) + ImGui::PushStyleVar(ImGuiStyleVar_ItemSpacing, ImVec2(0, 0)); + for (int i = 0; i < lines; i++) + ImGui::Text("%i The quick brown fox jumps over the lazy dog", i); + ImGui::PopStyleVar(); + break; + } + ImGui::EndChild(); + ImGui::End(); +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Auto Resize / ShowExampleAppAutoResize() +//----------------------------------------------------------------------------- + +// Demonstrate creating a window which gets auto-resized according to its content. +static void ShowExampleAppAutoResize(bool* p_open) +{ + if (!ImGui::Begin("Example: Auto-resizing window", p_open, ImGuiWindowFlags_AlwaysAutoResize)) + { + ImGui::End(); + return; + } + + static int lines = 10; + ImGui::TextUnformatted( + "Window will resize every-frame to the size of its content.\n" + "Note that you probably don't want to query the window size to\n" + "output your content because that would create a feedback loop."); + ImGui::SliderInt("Number of lines", &lines, 1, 20); + for (int i = 0; i < lines; i++) + ImGui::Text("%*sThis is line %d", i * 4, "", i); // Pad with space to extend size horizontally + ImGui::End(); +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Constrained Resize / ShowExampleAppConstrainedResize() +//----------------------------------------------------------------------------- + +// Demonstrate creating a window with custom resize constraints. +static void ShowExampleAppConstrainedResize(bool* p_open) +{ + struct CustomConstraints + { + // Helper functions to demonstrate programmatic constraints + static void Square(ImGuiSizeCallbackData* data) { data->DesiredSize.x = data->DesiredSize.y = IM_MAX(data->DesiredSize.x, data->DesiredSize.y); } + static void Step(ImGuiSizeCallbackData* data) { float step = (float)(int)(intptr_t)data->UserData; data->DesiredSize = ImVec2((int)(data->DesiredSize.x / step + 0.5f) * step, (int)(data->DesiredSize.y / step + 0.5f) * step); } + }; + + const char* test_desc[] = + { + "Resize vertical only", + "Resize horizontal only", + "Width > 100, Height > 100", + "Width 400-500", + "Height 400-500", + "Custom: Always Square", + "Custom: Fixed Steps (100)", + }; + + static bool auto_resize = false; + static int type = 0; + static int display_lines = 10; + if (type == 0) ImGui::SetNextWindowSizeConstraints(ImVec2(-1, 0), ImVec2(-1, FLT_MAX)); // Vertical only + if (type == 1) ImGui::SetNextWindowSizeConstraints(ImVec2(0, -1), ImVec2(FLT_MAX, -1)); // Horizontal only + if (type == 2) ImGui::SetNextWindowSizeConstraints(ImVec2(100, 100), ImVec2(FLT_MAX, FLT_MAX)); // Width > 100, Height > 100 + if (type == 3) ImGui::SetNextWindowSizeConstraints(ImVec2(400, -1), ImVec2(500, -1)); // Width 400-500 + if (type == 4) ImGui::SetNextWindowSizeConstraints(ImVec2(-1, 400), ImVec2(-1, 500)); // Height 400-500 + if (type == 5) ImGui::SetNextWindowSizeConstraints(ImVec2(0, 0), ImVec2(FLT_MAX, FLT_MAX), CustomConstraints::Square); // Always Square + if (type == 6) ImGui::SetNextWindowSizeConstraints(ImVec2(0, 0), ImVec2(FLT_MAX, FLT_MAX), CustomConstraints::Step, (void*)(intptr_t)100); // Fixed Step + + ImGuiWindowFlags flags = auto_resize ? ImGuiWindowFlags_AlwaysAutoResize : 0; + if (ImGui::Begin("Example: Constrained Resize", p_open, flags)) + { + if (ImGui::Button("200x200")) { ImGui::SetWindowSize(ImVec2(200, 200)); } ImGui::SameLine(); + if (ImGui::Button("500x500")) { ImGui::SetWindowSize(ImVec2(500, 500)); } ImGui::SameLine(); + if (ImGui::Button("800x200")) { ImGui::SetWindowSize(ImVec2(800, 200)); } + ImGui::SetNextItemWidth(200); + ImGui::Combo("Constraint", &type, test_desc, IM_ARRAYSIZE(test_desc)); + ImGui::SetNextItemWidth(200); + ImGui::DragInt("Lines", &display_lines, 0.2f, 1, 100); + ImGui::Checkbox("Auto-resize", &auto_resize); + for (int i = 0; i < display_lines; i++) + ImGui::Text("%*sHello, sailor! Making this line long enough for the example.", i * 4, ""); + } + ImGui::End(); +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Simple overlay / ShowExampleAppSimpleOverlay() +//----------------------------------------------------------------------------- + +// Demonstrate creating a simple static window with no decoration +// + a context-menu to choose which corner of the screen to use. +static void ShowExampleAppSimpleOverlay(bool* p_open) +{ + static int corner = 0; + ImGuiIO& io = ImGui::GetIO(); + ImGuiWindowFlags window_flags = ImGuiWindowFlags_NoDecoration | ImGuiWindowFlags_AlwaysAutoResize | ImGuiWindowFlags_NoSavedSettings | ImGuiWindowFlags_NoFocusOnAppearing | ImGuiWindowFlags_NoNav; + if (corner != -1) + { + const float PAD = 10.0f; + const ImGuiViewport* viewport = ImGui::GetMainViewport(); + ImVec2 work_pos = viewport->WorkPos; // Use work area to avoid menu-bar/task-bar, if any! + ImVec2 work_size = viewport->WorkSize; + ImVec2 window_pos, window_pos_pivot; + window_pos.x = (corner & 1) ? (work_pos.x + work_size.x - PAD) : (work_pos.x + PAD); + window_pos.y = (corner & 2) ? (work_pos.y + work_size.y - PAD) : (work_pos.y + PAD); + window_pos_pivot.x = (corner & 1) ? 1.0f : 0.0f; + window_pos_pivot.y = (corner & 2) ? 1.0f : 0.0f; + ImGui::SetNextWindowPos(window_pos, ImGuiCond_Always, window_pos_pivot); + window_flags |= ImGuiWindowFlags_NoMove; + } + ImGui::SetNextWindowBgAlpha(0.35f); // Transparent background + if (ImGui::Begin("Example: Simple overlay", p_open, window_flags)) + { + ImGui::Text("Simple overlay\n" "in the corner of the screen.\n" "(right-click to change position)"); + ImGui::Separator(); + if (ImGui::IsMousePosValid()) + ImGui::Text("Mouse Position: (%.1f,%.1f)", io.MousePos.x, io.MousePos.y); + else + ImGui::Text("Mouse Position: "); + if (ImGui::BeginPopupContextWindow()) + { + if (ImGui::MenuItem("Custom", NULL, corner == -1)) corner = -1; + if (ImGui::MenuItem("Top-left", NULL, corner == 0)) corner = 0; + if (ImGui::MenuItem("Top-right", NULL, corner == 1)) corner = 1; + if (ImGui::MenuItem("Bottom-left", NULL, corner == 2)) corner = 2; + if (ImGui::MenuItem("Bottom-right", NULL, corner == 3)) corner = 3; + if (p_open && ImGui::MenuItem("Close")) *p_open = false; + ImGui::EndPopup(); + } + } + ImGui::End(); +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Fullscreen window / ShowExampleAppFullscreen() +//----------------------------------------------------------------------------- + +// Demonstrate creating a window covering the entire screen/viewport +static void ShowExampleAppFullscreen(bool* p_open) +{ + static bool use_work_area = true; + static ImGuiWindowFlags flags = ImGuiWindowFlags_NoDecoration | ImGuiWindowFlags_NoMove | ImGuiWindowFlags_NoResize | ImGuiWindowFlags_NoSavedSettings; + + // We demonstrate using the full viewport area or the work area (without menu-bars, task-bars etc.) + // Based on your use case you may want one of the other. + const ImGuiViewport* viewport = ImGui::GetMainViewport(); + ImGui::SetNextWindowPos(use_work_area ? viewport->WorkPos : viewport->Pos); + ImGui::SetNextWindowSize(use_work_area ? viewport->WorkSize : viewport->Size); + + if (ImGui::Begin("Example: Fullscreen window", p_open, flags)) + { + ImGui::Checkbox("Use work area instead of main area", &use_work_area); + ImGui::SameLine(); + HelpMarker("Main Area = entire viewport,\nWork Area = entire viewport minus sections used by the main menu bars, task bars etc.\n\nEnable the main-menu bar in Examples menu to see the difference."); + + ImGui::CheckboxFlags("ImGuiWindowFlags_NoBackground", &flags, ImGuiWindowFlags_NoBackground); + ImGui::CheckboxFlags("ImGuiWindowFlags_NoDecoration", &flags, ImGuiWindowFlags_NoDecoration); + ImGui::Indent(); + ImGui::CheckboxFlags("ImGuiWindowFlags_NoTitleBar", &flags, ImGuiWindowFlags_NoTitleBar); + ImGui::CheckboxFlags("ImGuiWindowFlags_NoCollapse", &flags, ImGuiWindowFlags_NoCollapse); + ImGui::CheckboxFlags("ImGuiWindowFlags_NoScrollbar", &flags, ImGuiWindowFlags_NoScrollbar); + ImGui::Unindent(); + + if (p_open && ImGui::Button("Close this window")) + *p_open = false; + } + ImGui::End(); +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Manipulating Window Titles / ShowExampleAppWindowTitles() +//----------------------------------------------------------------------------- + +// Demonstrate using "##" and "###" in identifiers to manipulate ID generation. +// This apply to all regular items as well. +// Read FAQ section "How can I have multiple widgets with the same label?" for details. +static void ShowExampleAppWindowTitles(bool*) +{ + const ImGuiViewport* viewport = ImGui::GetMainViewport(); + const ImVec2 base_pos = viewport->Pos; + + // By default, Windows are uniquely identified by their title. + // You can use the "##" and "###" markers to manipulate the display/ID. + + // Using "##" to display same title but have unique identifier. + ImGui::SetNextWindowPos(ImVec2(base_pos.x + 100, base_pos.y + 100), ImGuiCond_FirstUseEver); + ImGui::Begin("Same title as another window##1"); + ImGui::Text("This is window 1.\nMy title is the same as window 2, but my identifier is unique."); + ImGui::End(); + + ImGui::SetNextWindowPos(ImVec2(base_pos.x + 100, base_pos.y + 200), ImGuiCond_FirstUseEver); + ImGui::Begin("Same title as another window##2"); + ImGui::Text("This is window 2.\nMy title is the same as window 1, but my identifier is unique."); + ImGui::End(); + + // Using "###" to display a changing title but keep a static identifier "AnimatedTitle" + char buf[128]; + sprintf(buf, "Animated title %c %d###AnimatedTitle", "|/-\\"[(int)(ImGui::GetTime() / 0.25f) & 3], ImGui::GetFrameCount()); + ImGui::SetNextWindowPos(ImVec2(base_pos.x + 100, base_pos.y + 300), ImGuiCond_FirstUseEver); + ImGui::Begin(buf); + ImGui::Text("This window has a changing title."); + ImGui::End(); +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Custom Rendering using ImDrawList API / ShowExampleAppCustomRendering() +//----------------------------------------------------------------------------- + +// Demonstrate using the low-level ImDrawList to draw custom shapes. +static void ShowExampleAppCustomRendering(bool* p_open) +{ + if (!ImGui::Begin("Example: Custom rendering", p_open)) + { + ImGui::End(); + return; + } + + // Tip: If you do a lot of custom rendering, you probably want to use your own geometrical types and benefit of + // overloaded operators, etc. Define IM_VEC2_CLASS_EXTRA in imconfig.h to create implicit conversions between your + // types and ImVec2/ImVec4. Dear ImGui defines overloaded operators but they are internal to imgui.cpp and not + // exposed outside (to avoid messing with your types) In this example we are not using the maths operators! + + if (ImGui::BeginTabBar("##TabBar")) + { + if (ImGui::BeginTabItem("Primitives")) + { + ImGui::PushItemWidth(-ImGui::GetFontSize() * 15); + ImDrawList* draw_list = ImGui::GetWindowDrawList(); + + // Draw gradients + // (note that those are currently exacerbating our sRGB/Linear issues) + // Calling ImGui::GetColorU32() multiplies the given colors by the current Style Alpha, but you may pass the IM_COL32() directly as well.. + ImGui::Text("Gradients"); + ImVec2 gradient_size = ImVec2(ImGui::CalcItemWidth(), ImGui::GetFrameHeight()); + { + ImVec2 p0 = ImGui::GetCursorScreenPos(); + ImVec2 p1 = ImVec2(p0.x + gradient_size.x, p0.y + gradient_size.y); + ImU32 col_a = ImGui::GetColorU32(IM_COL32(0, 0, 0, 255)); + ImU32 col_b = ImGui::GetColorU32(IM_COL32(255, 255, 255, 255)); + draw_list->AddRectFilledMultiColor(p0, p1, col_a, col_b, col_b, col_a); + ImGui::InvisibleButton("##gradient1", gradient_size); + } + { + ImVec2 p0 = ImGui::GetCursorScreenPos(); + ImVec2 p1 = ImVec2(p0.x + gradient_size.x, p0.y + gradient_size.y); + ImU32 col_a = ImGui::GetColorU32(IM_COL32(0, 255, 0, 255)); + ImU32 col_b = ImGui::GetColorU32(IM_COL32(255, 0, 0, 255)); + draw_list->AddRectFilledMultiColor(p0, p1, col_a, col_b, col_b, col_a); + ImGui::InvisibleButton("##gradient2", gradient_size); + } + + // Draw a bunch of primitives + ImGui::Text("All primitives"); + static float sz = 36.0f; + static float thickness = 3.0f; + static int ngon_sides = 6; + static bool circle_segments_override = false; + static int circle_segments_override_v = 12; + static bool curve_segments_override = false; + static int curve_segments_override_v = 8; + static ImVec4 colf = ImVec4(1.0f, 1.0f, 0.4f, 1.0f); + ImGui::DragFloat("Size", &sz, 0.2f, 2.0f, 100.0f, "%.0f"); + ImGui::DragFloat("Thickness", &thickness, 0.05f, 1.0f, 8.0f, "%.02f"); + ImGui::SliderInt("N-gon sides", &ngon_sides, 3, 12); + ImGui::Checkbox("##circlesegmentoverride", &circle_segments_override); + ImGui::SameLine(0.0f, ImGui::GetStyle().ItemInnerSpacing.x); + circle_segments_override |= ImGui::SliderInt("Circle segments override", &circle_segments_override_v, 3, 40); + ImGui::Checkbox("##curvessegmentoverride", &curve_segments_override); + ImGui::SameLine(0.0f, ImGui::GetStyle().ItemInnerSpacing.x); + curve_segments_override |= ImGui::SliderInt("Curves segments override", &curve_segments_override_v, 3, 40); + ImGui::ColorEdit4("Color", &colf.x); + + const ImVec2 p = ImGui::GetCursorScreenPos(); + const ImU32 col = ImColor(colf); + const float spacing = 10.0f; + const ImDrawFlags corners_tl_br = ImDrawFlags_RoundCornersTopLeft | ImDrawFlags_RoundCornersBottomRight; + const float rounding = sz / 5.0f; + const int circle_segments = circle_segments_override ? circle_segments_override_v : 0; + const int curve_segments = curve_segments_override ? curve_segments_override_v : 0; + float x = p.x + 4.0f; + float y = p.y + 4.0f; + for (int n = 0; n < 2; n++) + { + // First line uses a thickness of 1.0f, second line uses the configurable thickness + float th = (n == 0) ? 1.0f : thickness; + draw_list->AddNgon(ImVec2(x + sz*0.5f, y + sz*0.5f), sz*0.5f, col, ngon_sides, th); x += sz + spacing; // N-gon + draw_list->AddCircle(ImVec2(x + sz*0.5f, y + sz*0.5f), sz*0.5f, col, circle_segments, th); x += sz + spacing; // Circle + draw_list->AddRect(ImVec2(x, y), ImVec2(x + sz, y + sz), col, 0.0f, ImDrawFlags_None, th); x += sz + spacing; // Square + draw_list->AddRect(ImVec2(x, y), ImVec2(x + sz, y + sz), col, rounding, ImDrawFlags_None, th); x += sz + spacing; // Square with all rounded corners + draw_list->AddRect(ImVec2(x, y), ImVec2(x + sz, y + sz), col, rounding, corners_tl_br, th); x += sz + spacing; // Square with two rounded corners + draw_list->AddTriangle(ImVec2(x+sz*0.5f,y), ImVec2(x+sz, y+sz-0.5f), ImVec2(x, y+sz-0.5f), col, th);x += sz + spacing; // Triangle + //draw_list->AddTriangle(ImVec2(x+sz*0.2f,y), ImVec2(x, y+sz-0.5f), ImVec2(x+sz*0.4f, y+sz-0.5f), col, th);x+= sz*0.4f + spacing; // Thin triangle + draw_list->AddLine(ImVec2(x, y), ImVec2(x + sz, y), col, th); x += sz + spacing; // Horizontal line (note: drawing a filled rectangle will be faster!) + draw_list->AddLine(ImVec2(x, y), ImVec2(x, y + sz), col, th); x += spacing; // Vertical line (note: drawing a filled rectangle will be faster!) + draw_list->AddLine(ImVec2(x, y), ImVec2(x + sz, y + sz), col, th); x += sz + spacing; // Diagonal line + + // Quadratic Bezier Curve (3 control points) + ImVec2 cp3[3] = { ImVec2(x, y + sz * 0.6f), ImVec2(x + sz * 0.5f, y - sz * 0.4f), ImVec2(x + sz, y + sz) }; + draw_list->AddBezierQuadratic(cp3[0], cp3[1], cp3[2], col, th, curve_segments); x += sz + spacing; + + // Cubic Bezier Curve (4 control points) + ImVec2 cp4[4] = { ImVec2(x, y), ImVec2(x + sz * 1.3f, y + sz * 0.3f), ImVec2(x + sz - sz * 1.3f, y + sz - sz * 0.3f), ImVec2(x + sz, y + sz) }; + draw_list->AddBezierCubic(cp4[0], cp4[1], cp4[2], cp4[3], col, th, curve_segments); + + x = p.x + 4; + y += sz + spacing; + } + draw_list->AddNgonFilled(ImVec2(x + sz * 0.5f, y + sz * 0.5f), sz*0.5f, col, ngon_sides); x += sz + spacing; // N-gon + draw_list->AddCircleFilled(ImVec2(x + sz*0.5f, y + sz*0.5f), sz*0.5f, col, circle_segments); x += sz + spacing; // Circle + draw_list->AddRectFilled(ImVec2(x, y), ImVec2(x + sz, y + sz), col); x += sz + spacing; // Square + draw_list->AddRectFilled(ImVec2(x, y), ImVec2(x + sz, y + sz), col, 10.0f); x += sz + spacing; // Square with all rounded corners + draw_list->AddRectFilled(ImVec2(x, y), ImVec2(x + sz, y + sz), col, 10.0f, corners_tl_br); x += sz + spacing; // Square with two rounded corners + draw_list->AddTriangleFilled(ImVec2(x+sz*0.5f,y), ImVec2(x+sz, y+sz-0.5f), ImVec2(x, y+sz-0.5f), col); x += sz + spacing; // Triangle + //draw_list->AddTriangleFilled(ImVec2(x+sz*0.2f,y), ImVec2(x, y+sz-0.5f), ImVec2(x+sz*0.4f, y+sz-0.5f), col); x += sz*0.4f + spacing; // Thin triangle + draw_list->AddRectFilled(ImVec2(x, y), ImVec2(x + sz, y + thickness), col); x += sz + spacing; // Horizontal line (faster than AddLine, but only handle integer thickness) + draw_list->AddRectFilled(ImVec2(x, y), ImVec2(x + thickness, y + sz), col); x += spacing * 2.0f;// Vertical line (faster than AddLine, but only handle integer thickness) + draw_list->AddRectFilled(ImVec2(x, y), ImVec2(x + 1, y + 1), col); x += sz; // Pixel (faster than AddLine) + draw_list->AddRectFilledMultiColor(ImVec2(x, y), ImVec2(x + sz, y + sz), IM_COL32(0, 0, 0, 255), IM_COL32(255, 0, 0, 255), IM_COL32(255, 255, 0, 255), IM_COL32(0, 255, 0, 255)); + + ImGui::Dummy(ImVec2((sz + spacing) * 10.2f, (sz + spacing) * 3.0f)); + ImGui::PopItemWidth(); + ImGui::EndTabItem(); + } + + if (ImGui::BeginTabItem("Canvas")) + { + static ImVector points; + static ImVec2 scrolling(0.0f, 0.0f); + static bool opt_enable_grid = true; + static bool opt_enable_context_menu = true; + static bool adding_line = false; + + ImGui::Checkbox("Enable grid", &opt_enable_grid); + ImGui::Checkbox("Enable context menu", &opt_enable_context_menu); + ImGui::Text("Mouse Left: drag to add lines,\nMouse Right: drag to scroll, click for context menu."); + + // Typically you would use a BeginChild()/EndChild() pair to benefit from a clipping region + own scrolling. + // Here we demonstrate that this can be replaced by simple offsetting + custom drawing + PushClipRect/PopClipRect() calls. + // To use a child window instead we could use, e.g: + // ImGui::PushStyleVar(ImGuiStyleVar_WindowPadding, ImVec2(0, 0)); // Disable padding + // ImGui::PushStyleColor(ImGuiCol_ChildBg, IM_COL32(50, 50, 50, 255)); // Set a background color + // ImGui::BeginChild("canvas", ImVec2(0.0f, 0.0f), true, ImGuiWindowFlags_NoMove); + // ImGui::PopStyleColor(); + // ImGui::PopStyleVar(); + // [...] + // ImGui::EndChild(); + + // Using InvisibleButton() as a convenience 1) it will advance the layout cursor and 2) allows us to use IsItemHovered()/IsItemActive() + ImVec2 canvas_p0 = ImGui::GetCursorScreenPos(); // ImDrawList API uses screen coordinates! + ImVec2 canvas_sz = ImGui::GetContentRegionAvail(); // Resize canvas to what's available + if (canvas_sz.x < 50.0f) canvas_sz.x = 50.0f; + if (canvas_sz.y < 50.0f) canvas_sz.y = 50.0f; + ImVec2 canvas_p1 = ImVec2(canvas_p0.x + canvas_sz.x, canvas_p0.y + canvas_sz.y); + + // Draw border and background color + ImGuiIO& io = ImGui::GetIO(); + ImDrawList* draw_list = ImGui::GetWindowDrawList(); + draw_list->AddRectFilled(canvas_p0, canvas_p1, IM_COL32(50, 50, 50, 255)); + draw_list->AddRect(canvas_p0, canvas_p1, IM_COL32(255, 255, 255, 255)); + + // This will catch our interactions + ImGui::InvisibleButton("canvas", canvas_sz, ImGuiButtonFlags_MouseButtonLeft | ImGuiButtonFlags_MouseButtonRight); + const bool is_hovered = ImGui::IsItemHovered(); // Hovered + const bool is_active = ImGui::IsItemActive(); // Held + const ImVec2 origin(canvas_p0.x + scrolling.x, canvas_p0.y + scrolling.y); // Lock scrolled origin + const ImVec2 mouse_pos_in_canvas(io.MousePos.x - origin.x, io.MousePos.y - origin.y); + + // Add first and second point + if (is_hovered && !adding_line && ImGui::IsMouseClicked(ImGuiMouseButton_Left)) + { + points.push_back(mouse_pos_in_canvas); + points.push_back(mouse_pos_in_canvas); + adding_line = true; + } + if (adding_line) + { + points.back() = mouse_pos_in_canvas; + if (!ImGui::IsMouseDown(ImGuiMouseButton_Left)) + adding_line = false; + } + + // Pan (we use a zero mouse threshold when there's no context menu) + // You may decide to make that threshold dynamic based on whether the mouse is hovering something etc. + const float mouse_threshold_for_pan = opt_enable_context_menu ? -1.0f : 0.0f; + if (is_active && ImGui::IsMouseDragging(ImGuiMouseButton_Right, mouse_threshold_for_pan)) + { + scrolling.x += io.MouseDelta.x; + scrolling.y += io.MouseDelta.y; + } + + // Context menu (under default mouse threshold) + ImVec2 drag_delta = ImGui::GetMouseDragDelta(ImGuiMouseButton_Right); + if (opt_enable_context_menu && ImGui::IsMouseReleased(ImGuiMouseButton_Right) && drag_delta.x == 0.0f && drag_delta.y == 0.0f) + ImGui::OpenPopupOnItemClick("context"); + if (ImGui::BeginPopup("context")) + { + if (adding_line) + points.resize(points.size() - 2); + adding_line = false; + if (ImGui::MenuItem("Remove one", NULL, false, points.Size > 0)) { points.resize(points.size() - 2); } + if (ImGui::MenuItem("Remove all", NULL, false, points.Size > 0)) { points.clear(); } + ImGui::EndPopup(); + } + + // Draw grid + all lines in the canvas + draw_list->PushClipRect(canvas_p0, canvas_p1, true); + if (opt_enable_grid) + { + const float GRID_STEP = 64.0f; + for (float x = fmodf(scrolling.x, GRID_STEP); x < canvas_sz.x; x += GRID_STEP) + draw_list->AddLine(ImVec2(canvas_p0.x + x, canvas_p0.y), ImVec2(canvas_p0.x + x, canvas_p1.y), IM_COL32(200, 200, 200, 40)); + for (float y = fmodf(scrolling.y, GRID_STEP); y < canvas_sz.y; y += GRID_STEP) + draw_list->AddLine(ImVec2(canvas_p0.x, canvas_p0.y + y), ImVec2(canvas_p1.x, canvas_p0.y + y), IM_COL32(200, 200, 200, 40)); + } + for (int n = 0; n < points.Size; n += 2) + draw_list->AddLine(ImVec2(origin.x + points[n].x, origin.y + points[n].y), ImVec2(origin.x + points[n + 1].x, origin.y + points[n + 1].y), IM_COL32(255, 255, 0, 255), 2.0f); + draw_list->PopClipRect(); + + ImGui::EndTabItem(); + } + + if (ImGui::BeginTabItem("BG/FG draw lists")) + { + static bool draw_bg = true; + static bool draw_fg = true; + ImGui::Checkbox("Draw in Background draw list", &draw_bg); + ImGui::SameLine(); HelpMarker("The Background draw list will be rendered below every Dear ImGui windows."); + ImGui::Checkbox("Draw in Foreground draw list", &draw_fg); + ImGui::SameLine(); HelpMarker("The Foreground draw list will be rendered over every Dear ImGui windows."); + ImVec2 window_pos = ImGui::GetWindowPos(); + ImVec2 window_size = ImGui::GetWindowSize(); + ImVec2 window_center = ImVec2(window_pos.x + window_size.x * 0.5f, window_pos.y + window_size.y * 0.5f); + if (draw_bg) + ImGui::GetBackgroundDrawList()->AddCircle(window_center, window_size.x * 0.6f, IM_COL32(255, 0, 0, 200), 0, 10 + 4); + if (draw_fg) + ImGui::GetForegroundDrawList()->AddCircle(window_center, window_size.y * 0.6f, IM_COL32(0, 255, 0, 200), 0, 10); + ImGui::EndTabItem(); + } + + ImGui::EndTabBar(); + } + + ImGui::End(); +} + +//----------------------------------------------------------------------------- +// [SECTION] Example App: Documents Handling / ShowExampleAppDocuments() +//----------------------------------------------------------------------------- + +// Simplified structure to mimic a Document model +struct MyDocument +{ + const char* Name; // Document title + bool Open; // Set when open (we keep an array of all available documents to simplify demo code!) + bool OpenPrev; // Copy of Open from last update. + bool Dirty; // Set when the document has been modified + bool WantClose; // Set when the document + ImVec4 Color; // An arbitrary variable associated to the document + + MyDocument(const char* name, bool open = true, const ImVec4& color = ImVec4(1.0f, 1.0f, 1.0f, 1.0f)) + { + Name = name; + Open = OpenPrev = open; + Dirty = false; + WantClose = false; + Color = color; + } + void DoOpen() { Open = true; } + void DoQueueClose() { WantClose = true; } + void DoForceClose() { Open = false; Dirty = false; } + void DoSave() { Dirty = false; } + + // Display placeholder contents for the Document + static void DisplayContents(MyDocument* doc) + { + ImGui::PushID(doc); + ImGui::Text("Document \"%s\"", doc->Name); + ImGui::PushStyleColor(ImGuiCol_Text, doc->Color); + ImGui::TextWrapped("Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua."); + ImGui::PopStyleColor(); + if (ImGui::Button("Modify", ImVec2(100, 0))) + doc->Dirty = true; + ImGui::SameLine(); + if (ImGui::Button("Save", ImVec2(100, 0))) + doc->DoSave(); + ImGui::ColorEdit3("color", &doc->Color.x); // Useful to test drag and drop and hold-dragged-to-open-tab behavior. + ImGui::PopID(); + } + + // Display context menu for the Document + static void DisplayContextMenu(MyDocument* doc) + { + if (!ImGui::BeginPopupContextItem()) + return; + + char buf[256]; + sprintf(buf, "Save %s", doc->Name); + if (ImGui::MenuItem(buf, "CTRL+S", false, doc->Open)) + doc->DoSave(); + if (ImGui::MenuItem("Close", "CTRL+W", false, doc->Open)) + doc->DoQueueClose(); + ImGui::EndPopup(); + } +}; + +struct ExampleAppDocuments +{ + ImVector Documents; + + ExampleAppDocuments() + { + Documents.push_back(MyDocument("Lettuce", true, ImVec4(0.4f, 0.8f, 0.4f, 1.0f))); + Documents.push_back(MyDocument("Eggplant", true, ImVec4(0.8f, 0.5f, 1.0f, 1.0f))); + Documents.push_back(MyDocument("Carrot", true, ImVec4(1.0f, 0.8f, 0.5f, 1.0f))); + Documents.push_back(MyDocument("Tomato", false, ImVec4(1.0f, 0.3f, 0.4f, 1.0f))); + Documents.push_back(MyDocument("A Rather Long Title", false)); + Documents.push_back(MyDocument("Some Document", false)); + } +}; + +// [Optional] Notify the system of Tabs/Windows closure that happened outside the regular tab interface. +// If a tab has been closed programmatically (aka closed from another source such as the Checkbox() in the demo, +// as opposed to clicking on the regular tab closing button) and stops being submitted, it will take a frame for +// the tab bar to notice its absence. During this frame there will be a gap in the tab bar, and if the tab that has +// disappeared was the selected one, the tab bar will report no selected tab during the frame. This will effectively +// give the impression of a flicker for one frame. +// We call SetTabItemClosed() to manually notify the Tab Bar or Docking system of removed tabs to avoid this glitch. +// Note that this completely optional, and only affect tab bars with the ImGuiTabBarFlags_Reorderable flag. +static void NotifyOfDocumentsClosedElsewhere(ExampleAppDocuments& app) +{ + for (int doc_n = 0; doc_n < app.Documents.Size; doc_n++) + { + MyDocument* doc = &app.Documents[doc_n]; + if (!doc->Open && doc->OpenPrev) + ImGui::SetTabItemClosed(doc->Name); + doc->OpenPrev = doc->Open; + } +} + +void ShowExampleAppDocuments(bool* p_open) +{ + static ExampleAppDocuments app; + + // Options + static bool opt_reorderable = true; + static ImGuiTabBarFlags opt_fitting_flags = ImGuiTabBarFlags_FittingPolicyDefault_; + + bool window_contents_visible = ImGui::Begin("Example: Documents", p_open, ImGuiWindowFlags_MenuBar); + if (!window_contents_visible) + { + ImGui::End(); + return; + } + + // Menu + if (ImGui::BeginMenuBar()) + { + if (ImGui::BeginMenu("File")) + { + int open_count = 0; + for (int doc_n = 0; doc_n < app.Documents.Size; doc_n++) + open_count += app.Documents[doc_n].Open ? 1 : 0; + + if (ImGui::BeginMenu("Open", open_count < app.Documents.Size)) + { + for (int doc_n = 0; doc_n < app.Documents.Size; doc_n++) + { + MyDocument* doc = &app.Documents[doc_n]; + if (!doc->Open) + if (ImGui::MenuItem(doc->Name)) + doc->DoOpen(); + } + ImGui::EndMenu(); + } + if (ImGui::MenuItem("Close All Documents", NULL, false, open_count > 0)) + for (int doc_n = 0; doc_n < app.Documents.Size; doc_n++) + app.Documents[doc_n].DoQueueClose(); + if (ImGui::MenuItem("Exit", "Alt+F4")) {} + ImGui::EndMenu(); + } + ImGui::EndMenuBar(); + } + + // [Debug] List documents with one checkbox for each + for (int doc_n = 0; doc_n < app.Documents.Size; doc_n++) + { + MyDocument* doc = &app.Documents[doc_n]; + if (doc_n > 0) + ImGui::SameLine(); + ImGui::PushID(doc); + if (ImGui::Checkbox(doc->Name, &doc->Open)) + if (!doc->Open) + doc->DoForceClose(); + ImGui::PopID(); + } + + ImGui::Separator(); + + // About the ImGuiWindowFlags_UnsavedDocument / ImGuiTabItemFlags_UnsavedDocument flags. + // They have multiple effects: + // - Display a dot next to the title. + // - Tab is selected when clicking the X close button. + // - Closure is not assumed (will wait for user to stop submitting the tab). + // Otherwise closure is assumed when pressing the X, so if you keep submitting the tab may reappear at end of tab bar. + // We need to assume closure by default otherwise waiting for "lack of submission" on the next frame would leave an empty + // hole for one-frame, both in the tab-bar and in tab-contents when closing a tab/window. + // The rarely used SetTabItemClosed() function is a way to notify of programmatic closure to avoid the one-frame hole. + + // Submit Tab Bar and Tabs + { + ImGuiTabBarFlags tab_bar_flags = (opt_fitting_flags) | (opt_reorderable ? ImGuiTabBarFlags_Reorderable : 0); + if (ImGui::BeginTabBar("##tabs", tab_bar_flags)) + { + if (opt_reorderable) + NotifyOfDocumentsClosedElsewhere(app); + + // [DEBUG] Stress tests + //if ((ImGui::GetFrameCount() % 30) == 0) docs[1].Open ^= 1; // [DEBUG] Automatically show/hide a tab. Test various interactions e.g. dragging with this on. + //if (ImGui::GetIO().KeyCtrl) ImGui::SetTabItemSelected(docs[1].Name); // [DEBUG] Test SetTabItemSelected(), probably not very useful as-is anyway.. + + // Submit Tabs + for (int doc_n = 0; doc_n < app.Documents.Size; doc_n++) + { + MyDocument* doc = &app.Documents[doc_n]; + if (!doc->Open) + continue; + + ImGuiTabItemFlags tab_flags = (doc->Dirty ? ImGuiTabItemFlags_UnsavedDocument : 0); + bool visible = ImGui::BeginTabItem(doc->Name, &doc->Open, tab_flags); + + // Cancel attempt to close when unsaved add to save queue so we can display a popup. + if (!doc->Open && doc->Dirty) + { + doc->Open = true; + doc->DoQueueClose(); + } + + MyDocument::DisplayContextMenu(doc); + if (visible) + { + MyDocument::DisplayContents(doc); + ImGui::EndTabItem(); + } + } + + ImGui::EndTabBar(); + } + } + + // Update closing queue + static ImVector close_queue; + if (close_queue.empty()) + { + // Close queue is locked once we started a popup + for (int doc_n = 0; doc_n < app.Documents.Size; doc_n++) + { + MyDocument* doc = &app.Documents[doc_n]; + if (doc->WantClose) + { + doc->WantClose = false; + close_queue.push_back(doc); + } + } + } + + // Display closing confirmation UI + if (!close_queue.empty()) + { + int close_queue_unsaved_documents = 0; + for (int n = 0; n < close_queue.Size; n++) + if (close_queue[n]->Dirty) + close_queue_unsaved_documents++; + + if (close_queue_unsaved_documents == 0) + { + // Close documents when all are unsaved + for (int n = 0; n < close_queue.Size; n++) + close_queue[n]->DoForceClose(); + close_queue.clear(); + } + else + { + if (!ImGui::IsPopupOpen("Save?")) + ImGui::OpenPopup("Save?"); + if (ImGui::BeginPopupModal("Save?", NULL, ImGuiWindowFlags_AlwaysAutoResize)) + { + ImGui::Text("Save change to the following items?"); + float item_height = ImGui::GetTextLineHeightWithSpacing(); + if (ImGui::BeginChildFrame(ImGui::GetID("frame"), ImVec2(-FLT_MIN, 6.25f * item_height))) + { + for (int n = 0; n < close_queue.Size; n++) + if (close_queue[n]->Dirty) + ImGui::Text("%s", close_queue[n]->Name); + ImGui::EndChildFrame(); + } + + ImVec2 button_size(ImGui::GetFontSize() * 7.0f, 0.0f); + if (ImGui::Button("Yes", button_size)) + { + for (int n = 0; n < close_queue.Size; n++) + { + if (close_queue[n]->Dirty) + close_queue[n]->DoSave(); + close_queue[n]->DoForceClose(); + } + close_queue.clear(); + ImGui::CloseCurrentPopup(); + } + ImGui::SameLine(); + if (ImGui::Button("No", button_size)) + { + for (int n = 0; n < close_queue.Size; n++) + close_queue[n]->DoForceClose(); + close_queue.clear(); + ImGui::CloseCurrentPopup(); + } + ImGui::SameLine(); + if (ImGui::Button("Cancel", button_size)) + { + close_queue.clear(); + ImGui::CloseCurrentPopup(); + } + ImGui::EndPopup(); + } + } + } + + ImGui::End(); +} + +// End of Demo code +#else + +void ImGui::ShowAboutWindow(bool*) {} +void ImGui::ShowDemoWindow(bool*) {} +void ImGui::ShowUserGuide() {} +void ImGui::ShowStyleEditor(ImGuiStyle*) {} + +#endif + +#endif // #ifndef IMGUI_DISABLE diff --git a/source/editor/imgui/imgui_draw.cpp b/source/editor/imgui/imgui_draw.cpp new file mode 100644 index 0000000..0abc75f --- /dev/null +++ b/source/editor/imgui/imgui_draw.cpp @@ -0,0 +1,4177 @@ +// dear imgui, v1.85 WIP +// (drawing and font code) + +/* + +Index of this file: + +// [SECTION] STB libraries implementation +// [SECTION] Style functions +// [SECTION] ImDrawList +// [SECTION] ImDrawListSplitter +// [SECTION] ImDrawData +// [SECTION] Helpers ShadeVertsXXX functions +// [SECTION] ImFontConfig +// [SECTION] ImFontAtlas +// [SECTION] ImFontAtlas glyph ranges helpers +// [SECTION] ImFontGlyphRangesBuilder +// [SECTION] ImFont +// [SECTION] ImGui Internal Render Helpers +// [SECTION] Decompression code +// [SECTION] Default font data (ProggyClean.ttf) + +*/ + +#if defined(_MSC_VER) && !defined(_CRT_SECURE_NO_WARNINGS) +#define _CRT_SECURE_NO_WARNINGS +#endif + +#include "imgui.h" +#ifndef IMGUI_DISABLE + +#ifndef IMGUI_DEFINE_MATH_OPERATORS +#define IMGUI_DEFINE_MATH_OPERATORS +#endif + +#include "imgui_internal.h" +#ifdef IMGUI_ENABLE_FREETYPE +#include "misc/freetype/imgui_freetype.h" +#endif + +#include // vsnprintf, sscanf, printf +#if !defined(alloca) +#if defined(__GLIBC__) || defined(__sun) || defined(__APPLE__) || defined(__NEWLIB__) +#include // alloca (glibc uses . Note that Cygwin may have _WIN32 defined, so the order matters here) +#elif defined(_WIN32) +#include // alloca +#if !defined(alloca) +#define alloca _alloca // for clang with MS Codegen +#endif +#else +#include // alloca +#endif +#endif + +// Visual Studio warnings +#ifdef _MSC_VER +#pragma warning (disable: 4127) // condition expression is constant +#pragma warning (disable: 4505) // unreferenced local function has been removed (stb stuff) +#pragma warning (disable: 4996) // 'This function or variable may be unsafe': strcpy, strdup, sprintf, vsnprintf, sscanf, fopen +#pragma warning (disable: 6255) // [Static Analyzer] _alloca indicates failure by raising a stack overflow exception. Consider using _malloca instead. +#pragma warning (disable: 26451) // [Static Analyzer] Arithmetic overflow : Using operator 'xxx' on a 4 byte value and then casting the result to a 8 byte value. Cast the value to the wider type before calling operator 'xxx' to avoid overflow(io.2). +#pragma warning (disable: 26812) // [Static Analyzer] The enum type 'xxx' is unscoped. Prefer 'enum class' over 'enum' (Enum.3). [MSVC Static Analyzer) +#endif + +// Clang/GCC warnings with -Weverything +#if defined(__clang__) +#if __has_warning("-Wunknown-warning-option") +#pragma clang diagnostic ignored "-Wunknown-warning-option" // warning: unknown warning group 'xxx' // not all warnings are known by all Clang versions and they tend to be rename-happy.. so ignoring warnings triggers new warnings on some configuration. Great! +#endif +#if __has_warning("-Walloca") +#pragma clang diagnostic ignored "-Walloca" // warning: use of function '__builtin_alloca' is discouraged +#endif +#pragma clang diagnostic ignored "-Wunknown-pragmas" // warning: unknown warning group 'xxx' +#pragma clang diagnostic ignored "-Wold-style-cast" // warning: use of old-style cast // yes, they are more terse. +#pragma clang diagnostic ignored "-Wfloat-equal" // warning: comparing floating point with == or != is unsafe // storing and comparing against same constants ok. +#pragma clang diagnostic ignored "-Wglobal-constructors" // warning: declaration requires a global destructor // similar to above, not sure what the exact difference is. +#pragma clang diagnostic ignored "-Wsign-conversion" // warning: implicit conversion changes signedness +#pragma clang diagnostic ignored "-Wzero-as-null-pointer-constant" // warning: zero as null pointer constant // some standard header variations use #define NULL 0 +#pragma clang diagnostic ignored "-Wcomma" // warning: possible misuse of comma operator here +#pragma clang diagnostic ignored "-Wreserved-id-macro" // warning: macro name is a reserved identifier +#pragma clang diagnostic ignored "-Wdouble-promotion" // warning: implicit conversion from 'float' to 'double' when passing argument to function // using printf() is a misery with this as C++ va_arg ellipsis changes float to double. +#pragma clang diagnostic ignored "-Wimplicit-int-float-conversion" // warning: implicit conversion from 'xxx' to 'float' may lose precision +#elif defined(__GNUC__) +#pragma GCC diagnostic ignored "-Wpragmas" // warning: unknown option after '#pragma GCC diagnostic' kind +#pragma GCC diagnostic ignored "-Wunused-function" // warning: 'xxxx' defined but not used +#pragma GCC diagnostic ignored "-Wdouble-promotion" // warning: implicit conversion from 'float' to 'double' when passing argument to function +#pragma GCC diagnostic ignored "-Wconversion" // warning: conversion to 'xxxx' from 'xxxx' may alter its value +#pragma GCC diagnostic ignored "-Wstack-protector" // warning: stack protector not protecting local variables: variable length buffer +#pragma GCC diagnostic ignored "-Wclass-memaccess" // [__GNUC__ >= 8] warning: 'memset/memcpy' clearing/writing an object of type 'xxxx' with no trivial copy-assignment; use assignment or value-initialization instead +#endif + +//------------------------------------------------------------------------- +// [SECTION] STB libraries implementation +//------------------------------------------------------------------------- + +// Compile time options: +//#define IMGUI_STB_NAMESPACE ImStb +//#define IMGUI_STB_TRUETYPE_FILENAME "my_folder/stb_truetype.h" +//#define IMGUI_STB_RECT_PACK_FILENAME "my_folder/stb_rect_pack.h" +//#define IMGUI_DISABLE_STB_TRUETYPE_IMPLEMENTATION +//#define IMGUI_DISABLE_STB_RECT_PACK_IMPLEMENTATION + +#ifdef IMGUI_STB_NAMESPACE +namespace IMGUI_STB_NAMESPACE +{ +#endif + +#ifdef _MSC_VER +#pragma warning (push) +#pragma warning (disable: 4456) // declaration of 'xx' hides previous local declaration +#pragma warning (disable: 6011) // (stb_rectpack) Dereferencing NULL pointer 'cur->next'. +#pragma warning (disable: 6385) // (stb_truetype) Reading invalid data from 'buffer': the readable size is '_Old_3`kernel_width' bytes, but '3' bytes may be read. +#pragma warning (disable: 28182) // (stb_rectpack) Dereferencing NULL pointer. 'cur' contains the same NULL value as 'cur->next' did. +#endif + +#if defined(__clang__) +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wunused-function" +#pragma clang diagnostic ignored "-Wmissing-prototypes" +#pragma clang diagnostic ignored "-Wimplicit-fallthrough" +#pragma clang diagnostic ignored "-Wcast-qual" // warning: cast from 'const xxxx *' to 'xxx *' drops const qualifier +#endif + +#if defined(__GNUC__) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wtype-limits" // warning: comparison is always true due to limited range of data type [-Wtype-limits] +#pragma GCC diagnostic ignored "-Wcast-qual" // warning: cast from type 'const xxxx *' to type 'xxxx *' casts away qualifiers +#endif + +#ifndef STB_RECT_PACK_IMPLEMENTATION // in case the user already have an implementation in the _same_ compilation unit (e.g. unity builds) +#ifndef IMGUI_DISABLE_STB_RECT_PACK_IMPLEMENTATION // in case the user already have an implementation in another compilation unit +#define STBRP_STATIC +#define STBRP_ASSERT(x) do { IM_ASSERT(x); } while (0) +#define STBRP_SORT ImQsort +#define STB_RECT_PACK_IMPLEMENTATION +#endif +#ifdef IMGUI_STB_RECT_PACK_FILENAME +#include IMGUI_STB_RECT_PACK_FILENAME +#else +#include "imstb_rectpack.h" +#endif +#endif + +#ifdef IMGUI_ENABLE_STB_TRUETYPE +#ifndef STB_TRUETYPE_IMPLEMENTATION // in case the user already have an implementation in the _same_ compilation unit (e.g. unity builds) +#ifndef IMGUI_DISABLE_STB_TRUETYPE_IMPLEMENTATION // in case the user already have an implementation in another compilation unit +#define STBTT_malloc(x,u) ((void)(u), IM_ALLOC(x)) +#define STBTT_free(x,u) ((void)(u), IM_FREE(x)) +#define STBTT_assert(x) do { IM_ASSERT(x); } while(0) +#define STBTT_fmod(x,y) ImFmod(x,y) +#define STBTT_sqrt(x) ImSqrt(x) +#define STBTT_pow(x,y) ImPow(x,y) +#define STBTT_fabs(x) ImFabs(x) +#define STBTT_ifloor(x) ((int)ImFloorSigned(x)) +#define STBTT_iceil(x) ((int)ImCeil(x)) +#define STBTT_STATIC +#define STB_TRUETYPE_IMPLEMENTATION +#else +#define STBTT_DEF extern +#endif +#ifdef IMGUI_STB_TRUETYPE_FILENAME +#include IMGUI_STB_TRUETYPE_FILENAME +#else +#include "imstb_truetype.h" +#endif +#endif +#endif // IMGUI_ENABLE_STB_TRUETYPE + +#if defined(__GNUC__) +#pragma GCC diagnostic pop +#endif + +#if defined(__clang__) +#pragma clang diagnostic pop +#endif + +#if defined(_MSC_VER) +#pragma warning (pop) +#endif + +#ifdef IMGUI_STB_NAMESPACE +} // namespace ImStb +using namespace IMGUI_STB_NAMESPACE; +#endif + +//----------------------------------------------------------------------------- +// [SECTION] Style functions +//----------------------------------------------------------------------------- + +void ImGui::StyleColorsDark(ImGuiStyle* dst) +{ + ImGuiStyle* style = dst ? dst : &ImGui::GetStyle(); + ImVec4* colors = style->Colors; + + colors[ImGuiCol_Text] = ImVec4(1.00f, 1.00f, 1.00f, 1.00f); + colors[ImGuiCol_TextDisabled] = ImVec4(0.50f, 0.50f, 0.50f, 1.00f); + colors[ImGuiCol_WindowBg] = ImVec4(0.06f, 0.06f, 0.06f, 0.94f); + colors[ImGuiCol_ChildBg] = ImVec4(0.00f, 0.00f, 0.00f, 0.00f); + colors[ImGuiCol_PopupBg] = ImVec4(0.08f, 0.08f, 0.08f, 0.94f); + colors[ImGuiCol_Border] = ImVec4(0.43f, 0.43f, 0.50f, 0.50f); + colors[ImGuiCol_BorderShadow] = ImVec4(0.00f, 0.00f, 0.00f, 0.00f); + colors[ImGuiCol_FrameBg] = ImVec4(0.16f, 0.29f, 0.48f, 0.54f); + colors[ImGuiCol_FrameBgHovered] = ImVec4(0.26f, 0.59f, 0.98f, 0.40f); + colors[ImGuiCol_FrameBgActive] = ImVec4(0.26f, 0.59f, 0.98f, 0.67f); + colors[ImGuiCol_TitleBg] = ImVec4(0.04f, 0.04f, 0.04f, 1.00f); + colors[ImGuiCol_TitleBgActive] = ImVec4(0.16f, 0.29f, 0.48f, 1.00f); + colors[ImGuiCol_TitleBgCollapsed] = ImVec4(0.00f, 0.00f, 0.00f, 0.51f); + colors[ImGuiCol_MenuBarBg] = ImVec4(0.14f, 0.14f, 0.14f, 1.00f); + colors[ImGuiCol_ScrollbarBg] = ImVec4(0.02f, 0.02f, 0.02f, 0.53f); + colors[ImGuiCol_ScrollbarGrab] = ImVec4(0.31f, 0.31f, 0.31f, 1.00f); + colors[ImGuiCol_ScrollbarGrabHovered] = ImVec4(0.41f, 0.41f, 0.41f, 1.00f); + colors[ImGuiCol_ScrollbarGrabActive] = ImVec4(0.51f, 0.51f, 0.51f, 1.00f); + colors[ImGuiCol_CheckMark] = ImVec4(0.26f, 0.59f, 0.98f, 1.00f); + colors[ImGuiCol_SliderGrab] = ImVec4(0.24f, 0.52f, 0.88f, 1.00f); + colors[ImGuiCol_SliderGrabActive] = ImVec4(0.26f, 0.59f, 0.98f, 1.00f); + colors[ImGuiCol_Button] = ImVec4(0.26f, 0.59f, 0.98f, 0.40f); + colors[ImGuiCol_ButtonHovered] = ImVec4(0.26f, 0.59f, 0.98f, 1.00f); + colors[ImGuiCol_ButtonActive] = ImVec4(0.06f, 0.53f, 0.98f, 1.00f); + colors[ImGuiCol_Header] = ImVec4(0.26f, 0.59f, 0.98f, 0.31f); + colors[ImGuiCol_HeaderHovered] = ImVec4(0.26f, 0.59f, 0.98f, 0.80f); + colors[ImGuiCol_HeaderActive] = ImVec4(0.26f, 0.59f, 0.98f, 1.00f); + colors[ImGuiCol_Separator] = colors[ImGuiCol_Border]; + colors[ImGuiCol_SeparatorHovered] = ImVec4(0.10f, 0.40f, 0.75f, 0.78f); + colors[ImGuiCol_SeparatorActive] = ImVec4(0.10f, 0.40f, 0.75f, 1.00f); + colors[ImGuiCol_ResizeGrip] = ImVec4(0.26f, 0.59f, 0.98f, 0.20f); + colors[ImGuiCol_ResizeGripHovered] = ImVec4(0.26f, 0.59f, 0.98f, 0.67f); + colors[ImGuiCol_ResizeGripActive] = ImVec4(0.26f, 0.59f, 0.98f, 0.95f); + colors[ImGuiCol_Tab] = ImLerp(colors[ImGuiCol_Header], colors[ImGuiCol_TitleBgActive], 0.80f); + colors[ImGuiCol_TabHovered] = colors[ImGuiCol_HeaderHovered]; + colors[ImGuiCol_TabActive] = ImLerp(colors[ImGuiCol_HeaderActive], colors[ImGuiCol_TitleBgActive], 0.60f); + colors[ImGuiCol_TabUnfocused] = ImLerp(colors[ImGuiCol_Tab], colors[ImGuiCol_TitleBg], 0.80f); + colors[ImGuiCol_TabUnfocusedActive] = ImLerp(colors[ImGuiCol_TabActive], colors[ImGuiCol_TitleBg], 0.40f); + colors[ImGuiCol_PlotLines] = ImVec4(0.61f, 0.61f, 0.61f, 1.00f); + colors[ImGuiCol_PlotLinesHovered] = ImVec4(1.00f, 0.43f, 0.35f, 1.00f); + colors[ImGuiCol_PlotHistogram] = ImVec4(0.90f, 0.70f, 0.00f, 1.00f); + colors[ImGuiCol_PlotHistogramHovered] = ImVec4(1.00f, 0.60f, 0.00f, 1.00f); + colors[ImGuiCol_TableHeaderBg] = ImVec4(0.19f, 0.19f, 0.20f, 1.00f); + colors[ImGuiCol_TableBorderStrong] = ImVec4(0.31f, 0.31f, 0.35f, 1.00f); // Prefer using Alpha=1.0 here + colors[ImGuiCol_TableBorderLight] = ImVec4(0.23f, 0.23f, 0.25f, 1.00f); // Prefer using Alpha=1.0 here + colors[ImGuiCol_TableRowBg] = ImVec4(0.00f, 0.00f, 0.00f, 0.00f); + colors[ImGuiCol_TableRowBgAlt] = ImVec4(1.00f, 1.00f, 1.00f, 0.06f); + colors[ImGuiCol_TextSelectedBg] = ImVec4(0.26f, 0.59f, 0.98f, 0.35f); + colors[ImGuiCol_DragDropTarget] = ImVec4(1.00f, 1.00f, 0.00f, 0.90f); + colors[ImGuiCol_NavHighlight] = ImVec4(0.26f, 0.59f, 0.98f, 1.00f); + colors[ImGuiCol_NavWindowingHighlight] = ImVec4(1.00f, 1.00f, 1.00f, 0.70f); + colors[ImGuiCol_NavWindowingDimBg] = ImVec4(0.80f, 0.80f, 0.80f, 0.20f); + colors[ImGuiCol_ModalWindowDimBg] = ImVec4(0.80f, 0.80f, 0.80f, 0.35f); +} + +void ImGui::StyleColorsClassic(ImGuiStyle* dst) +{ + ImGuiStyle* style = dst ? dst : &ImGui::GetStyle(); + ImVec4* colors = style->Colors; + + colors[ImGuiCol_Text] = ImVec4(0.90f, 0.90f, 0.90f, 1.00f); + colors[ImGuiCol_TextDisabled] = ImVec4(0.60f, 0.60f, 0.60f, 1.00f); + colors[ImGuiCol_WindowBg] = ImVec4(0.00f, 0.00f, 0.00f, 0.85f); + colors[ImGuiCol_ChildBg] = ImVec4(0.00f, 0.00f, 0.00f, 0.00f); + colors[ImGuiCol_PopupBg] = ImVec4(0.11f, 0.11f, 0.14f, 0.92f); + colors[ImGuiCol_Border] = ImVec4(0.50f, 0.50f, 0.50f, 0.50f); + colors[ImGuiCol_BorderShadow] = ImVec4(0.00f, 0.00f, 0.00f, 0.00f); + colors[ImGuiCol_FrameBg] = ImVec4(0.43f, 0.43f, 0.43f, 0.39f); + colors[ImGuiCol_FrameBgHovered] = ImVec4(0.47f, 0.47f, 0.69f, 0.40f); + colors[ImGuiCol_FrameBgActive] = ImVec4(0.42f, 0.41f, 0.64f, 0.69f); + colors[ImGuiCol_TitleBg] = ImVec4(0.27f, 0.27f, 0.54f, 0.83f); + colors[ImGuiCol_TitleBgActive] = ImVec4(0.32f, 0.32f, 0.63f, 0.87f); + colors[ImGuiCol_TitleBgCollapsed] = ImVec4(0.40f, 0.40f, 0.80f, 0.20f); + colors[ImGuiCol_MenuBarBg] = ImVec4(0.40f, 0.40f, 0.55f, 0.80f); + colors[ImGuiCol_ScrollbarBg] = ImVec4(0.20f, 0.25f, 0.30f, 0.60f); + colors[ImGuiCol_ScrollbarGrab] = ImVec4(0.40f, 0.40f, 0.80f, 0.30f); + colors[ImGuiCol_ScrollbarGrabHovered] = ImVec4(0.40f, 0.40f, 0.80f, 0.40f); + colors[ImGuiCol_ScrollbarGrabActive] = ImVec4(0.41f, 0.39f, 0.80f, 0.60f); + colors[ImGuiCol_CheckMark] = ImVec4(0.90f, 0.90f, 0.90f, 0.50f); + colors[ImGuiCol_SliderGrab] = ImVec4(1.00f, 1.00f, 1.00f, 0.30f); + colors[ImGuiCol_SliderGrabActive] = ImVec4(0.41f, 0.39f, 0.80f, 0.60f); + colors[ImGuiCol_Button] = ImVec4(0.35f, 0.40f, 0.61f, 0.62f); + colors[ImGuiCol_ButtonHovered] = ImVec4(0.40f, 0.48f, 0.71f, 0.79f); + colors[ImGuiCol_ButtonActive] = ImVec4(0.46f, 0.54f, 0.80f, 1.00f); + colors[ImGuiCol_Header] = ImVec4(0.40f, 0.40f, 0.90f, 0.45f); + colors[ImGuiCol_HeaderHovered] = ImVec4(0.45f, 0.45f, 0.90f, 0.80f); + colors[ImGuiCol_HeaderActive] = ImVec4(0.53f, 0.53f, 0.87f, 0.80f); + colors[ImGuiCol_Separator] = ImVec4(0.50f, 0.50f, 0.50f, 0.60f); + colors[ImGuiCol_SeparatorHovered] = ImVec4(0.60f, 0.60f, 0.70f, 1.00f); + colors[ImGuiCol_SeparatorActive] = ImVec4(0.70f, 0.70f, 0.90f, 1.00f); + colors[ImGuiCol_ResizeGrip] = ImVec4(1.00f, 1.00f, 1.00f, 0.10f); + colors[ImGuiCol_ResizeGripHovered] = ImVec4(0.78f, 0.82f, 1.00f, 0.60f); + colors[ImGuiCol_ResizeGripActive] = ImVec4(0.78f, 0.82f, 1.00f, 0.90f); + colors[ImGuiCol_Tab] = ImLerp(colors[ImGuiCol_Header], colors[ImGuiCol_TitleBgActive], 0.80f); + colors[ImGuiCol_TabHovered] = colors[ImGuiCol_HeaderHovered]; + colors[ImGuiCol_TabActive] = ImLerp(colors[ImGuiCol_HeaderActive], colors[ImGuiCol_TitleBgActive], 0.60f); + colors[ImGuiCol_TabUnfocused] = ImLerp(colors[ImGuiCol_Tab], colors[ImGuiCol_TitleBg], 0.80f); + colors[ImGuiCol_TabUnfocusedActive] = ImLerp(colors[ImGuiCol_TabActive], colors[ImGuiCol_TitleBg], 0.40f); + colors[ImGuiCol_PlotLines] = ImVec4(1.00f, 1.00f, 1.00f, 1.00f); + colors[ImGuiCol_PlotLinesHovered] = ImVec4(0.90f, 0.70f, 0.00f, 1.00f); + colors[ImGuiCol_PlotHistogram] = ImVec4(0.90f, 0.70f, 0.00f, 1.00f); + colors[ImGuiCol_PlotHistogramHovered] = ImVec4(1.00f, 0.60f, 0.00f, 1.00f); + colors[ImGuiCol_TableHeaderBg] = ImVec4(0.27f, 0.27f, 0.38f, 1.00f); + colors[ImGuiCol_TableBorderStrong] = ImVec4(0.31f, 0.31f, 0.45f, 1.00f); // Prefer using Alpha=1.0 here + colors[ImGuiCol_TableBorderLight] = ImVec4(0.26f, 0.26f, 0.28f, 1.00f); // Prefer using Alpha=1.0 here + colors[ImGuiCol_TableRowBg] = ImVec4(0.00f, 0.00f, 0.00f, 0.00f); + colors[ImGuiCol_TableRowBgAlt] = ImVec4(1.00f, 1.00f, 1.00f, 0.07f); + colors[ImGuiCol_TextSelectedBg] = ImVec4(0.00f, 0.00f, 1.00f, 0.35f); + colors[ImGuiCol_DragDropTarget] = ImVec4(1.00f, 1.00f, 0.00f, 0.90f); + colors[ImGuiCol_NavHighlight] = colors[ImGuiCol_HeaderHovered]; + colors[ImGuiCol_NavWindowingHighlight] = ImVec4(1.00f, 1.00f, 1.00f, 0.70f); + colors[ImGuiCol_NavWindowingDimBg] = ImVec4(0.80f, 0.80f, 0.80f, 0.20f); + colors[ImGuiCol_ModalWindowDimBg] = ImVec4(0.20f, 0.20f, 0.20f, 0.35f); +} + +// Those light colors are better suited with a thicker font than the default one + FrameBorder +void ImGui::StyleColorsLight(ImGuiStyle* dst) +{ + ImGuiStyle* style = dst ? dst : &ImGui::GetStyle(); + ImVec4* colors = style->Colors; + + colors[ImGuiCol_Text] = ImVec4(0.00f, 0.00f, 0.00f, 1.00f); + colors[ImGuiCol_TextDisabled] = ImVec4(0.60f, 0.60f, 0.60f, 1.00f); + colors[ImGuiCol_WindowBg] = ImVec4(0.94f, 0.94f, 0.94f, 1.00f); + colors[ImGuiCol_ChildBg] = ImVec4(0.00f, 0.00f, 0.00f, 0.00f); + colors[ImGuiCol_PopupBg] = ImVec4(1.00f, 1.00f, 1.00f, 0.98f); + colors[ImGuiCol_Border] = ImVec4(0.00f, 0.00f, 0.00f, 0.30f); + colors[ImGuiCol_BorderShadow] = ImVec4(0.00f, 0.00f, 0.00f, 0.00f); + colors[ImGuiCol_FrameBg] = ImVec4(1.00f, 1.00f, 1.00f, 1.00f); + colors[ImGuiCol_FrameBgHovered] = ImVec4(0.26f, 0.59f, 0.98f, 0.40f); + colors[ImGuiCol_FrameBgActive] = ImVec4(0.26f, 0.59f, 0.98f, 0.67f); + colors[ImGuiCol_TitleBg] = ImVec4(0.96f, 0.96f, 0.96f, 1.00f); + colors[ImGuiCol_TitleBgActive] = ImVec4(0.82f, 0.82f, 0.82f, 1.00f); + colors[ImGuiCol_TitleBgCollapsed] = ImVec4(1.00f, 1.00f, 1.00f, 0.51f); + colors[ImGuiCol_MenuBarBg] = ImVec4(0.86f, 0.86f, 0.86f, 1.00f); + colors[ImGuiCol_ScrollbarBg] = ImVec4(0.98f, 0.98f, 0.98f, 0.53f); + colors[ImGuiCol_ScrollbarGrab] = ImVec4(0.69f, 0.69f, 0.69f, 0.80f); + colors[ImGuiCol_ScrollbarGrabHovered] = ImVec4(0.49f, 0.49f, 0.49f, 0.80f); + colors[ImGuiCol_ScrollbarGrabActive] = ImVec4(0.49f, 0.49f, 0.49f, 1.00f); + colors[ImGuiCol_CheckMark] = ImVec4(0.26f, 0.59f, 0.98f, 1.00f); + colors[ImGuiCol_SliderGrab] = ImVec4(0.26f, 0.59f, 0.98f, 0.78f); + colors[ImGuiCol_SliderGrabActive] = ImVec4(0.46f, 0.54f, 0.80f, 0.60f); + colors[ImGuiCol_Button] = ImVec4(0.26f, 0.59f, 0.98f, 0.40f); + colors[ImGuiCol_ButtonHovered] = ImVec4(0.26f, 0.59f, 0.98f, 1.00f); + colors[ImGuiCol_ButtonActive] = ImVec4(0.06f, 0.53f, 0.98f, 1.00f); + colors[ImGuiCol_Header] = ImVec4(0.26f, 0.59f, 0.98f, 0.31f); + colors[ImGuiCol_HeaderHovered] = ImVec4(0.26f, 0.59f, 0.98f, 0.80f); + colors[ImGuiCol_HeaderActive] = ImVec4(0.26f, 0.59f, 0.98f, 1.00f); + colors[ImGuiCol_Separator] = ImVec4(0.39f, 0.39f, 0.39f, 0.62f); + colors[ImGuiCol_SeparatorHovered] = ImVec4(0.14f, 0.44f, 0.80f, 0.78f); + colors[ImGuiCol_SeparatorActive] = ImVec4(0.14f, 0.44f, 0.80f, 1.00f); + colors[ImGuiCol_ResizeGrip] = ImVec4(0.35f, 0.35f, 0.35f, 0.17f); + colors[ImGuiCol_ResizeGripHovered] = ImVec4(0.26f, 0.59f, 0.98f, 0.67f); + colors[ImGuiCol_ResizeGripActive] = ImVec4(0.26f, 0.59f, 0.98f, 0.95f); + colors[ImGuiCol_Tab] = ImLerp(colors[ImGuiCol_Header], colors[ImGuiCol_TitleBgActive], 0.90f); + colors[ImGuiCol_TabHovered] = colors[ImGuiCol_HeaderHovered]; + colors[ImGuiCol_TabActive] = ImLerp(colors[ImGuiCol_HeaderActive], colors[ImGuiCol_TitleBgActive], 0.60f); + colors[ImGuiCol_TabUnfocused] = ImLerp(colors[ImGuiCol_Tab], colors[ImGuiCol_TitleBg], 0.80f); + colors[ImGuiCol_TabUnfocusedActive] = ImLerp(colors[ImGuiCol_TabActive], colors[ImGuiCol_TitleBg], 0.40f); + colors[ImGuiCol_PlotLines] = ImVec4(0.39f, 0.39f, 0.39f, 1.00f); + colors[ImGuiCol_PlotLinesHovered] = ImVec4(1.00f, 0.43f, 0.35f, 1.00f); + colors[ImGuiCol_PlotHistogram] = ImVec4(0.90f, 0.70f, 0.00f, 1.00f); + colors[ImGuiCol_PlotHistogramHovered] = ImVec4(1.00f, 0.45f, 0.00f, 1.00f); + colors[ImGuiCol_TableHeaderBg] = ImVec4(0.78f, 0.87f, 0.98f, 1.00f); + colors[ImGuiCol_TableBorderStrong] = ImVec4(0.57f, 0.57f, 0.64f, 1.00f); // Prefer using Alpha=1.0 here + colors[ImGuiCol_TableBorderLight] = ImVec4(0.68f, 0.68f, 0.74f, 1.00f); // Prefer using Alpha=1.0 here + colors[ImGuiCol_TableRowBg] = ImVec4(0.00f, 0.00f, 0.00f, 0.00f); + colors[ImGuiCol_TableRowBgAlt] = ImVec4(0.30f, 0.30f, 0.30f, 0.09f); + colors[ImGuiCol_TextSelectedBg] = ImVec4(0.26f, 0.59f, 0.98f, 0.35f); + colors[ImGuiCol_DragDropTarget] = ImVec4(0.26f, 0.59f, 0.98f, 0.95f); + colors[ImGuiCol_NavHighlight] = colors[ImGuiCol_HeaderHovered]; + colors[ImGuiCol_NavWindowingHighlight] = ImVec4(0.70f, 0.70f, 0.70f, 0.70f); + colors[ImGuiCol_NavWindowingDimBg] = ImVec4(0.20f, 0.20f, 0.20f, 0.20f); + colors[ImGuiCol_ModalWindowDimBg] = ImVec4(0.20f, 0.20f, 0.20f, 0.35f); +} + +//----------------------------------------------------------------------------- +// [SECTION] ImDrawList +//----------------------------------------------------------------------------- + +ImDrawListSharedData::ImDrawListSharedData() +{ + memset(this, 0, sizeof(*this)); + for (int i = 0; i < IM_ARRAYSIZE(ArcFastVtx); i++) + { + const float a = ((float)i * 2 * IM_PI) / (float)IM_ARRAYSIZE(ArcFastVtx); + ArcFastVtx[i] = ImVec2(ImCos(a), ImSin(a)); + } + ArcFastRadiusCutoff = IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_CALC_R(IM_DRAWLIST_ARCFAST_SAMPLE_MAX, CircleSegmentMaxError); +} + +void ImDrawListSharedData::SetCircleTessellationMaxError(float max_error) +{ + if (CircleSegmentMaxError == max_error) + return; + + IM_ASSERT(max_error > 0.0f); + CircleSegmentMaxError = max_error; + for (int i = 0; i < IM_ARRAYSIZE(CircleSegmentCounts); i++) + { + const float radius = (float)i; + CircleSegmentCounts[i] = (ImU8)((i > 0) ? IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_CALC(radius, CircleSegmentMaxError) : 0); + } + ArcFastRadiusCutoff = IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_CALC_R(IM_DRAWLIST_ARCFAST_SAMPLE_MAX, CircleSegmentMaxError); +} + +// Initialize before use in a new frame. We always have a command ready in the buffer. +void ImDrawList::_ResetForNewFrame() +{ + // Verify that the ImDrawCmd fields we want to memcmp() are contiguous in memory. + // (those should be IM_STATIC_ASSERT() in theory but with our pre C++11 setup the whole check doesn't compile with GCC) + IM_ASSERT(IM_OFFSETOF(ImDrawCmd, ClipRect) == 0); + IM_ASSERT(IM_OFFSETOF(ImDrawCmd, TextureId) == sizeof(ImVec4)); + IM_ASSERT(IM_OFFSETOF(ImDrawCmd, VtxOffset) == sizeof(ImVec4) + sizeof(ImTextureID)); + + CmdBuffer.resize(0); + IdxBuffer.resize(0); + VtxBuffer.resize(0); + Flags = _Data->InitialFlags; + memset(&_CmdHeader, 0, sizeof(_CmdHeader)); + _VtxCurrentIdx = 0; + _VtxWritePtr = NULL; + _IdxWritePtr = NULL; + _ClipRectStack.resize(0); + _TextureIdStack.resize(0); + _Path.resize(0); + _Splitter.Clear(); + CmdBuffer.push_back(ImDrawCmd()); + _FringeScale = 1.0f; +} + +void ImDrawList::_ClearFreeMemory() +{ + CmdBuffer.clear(); + IdxBuffer.clear(); + VtxBuffer.clear(); + Flags = ImDrawListFlags_None; + _VtxCurrentIdx = 0; + _VtxWritePtr = NULL; + _IdxWritePtr = NULL; + _ClipRectStack.clear(); + _TextureIdStack.clear(); + _Path.clear(); + _Splitter.ClearFreeMemory(); +} + +ImDrawList* ImDrawList::CloneOutput() const +{ + ImDrawList* dst = IM_NEW(ImDrawList(_Data)); + dst->CmdBuffer = CmdBuffer; + dst->IdxBuffer = IdxBuffer; + dst->VtxBuffer = VtxBuffer; + dst->Flags = Flags; + return dst; +} + +void ImDrawList::AddDrawCmd() +{ + ImDrawCmd draw_cmd; + draw_cmd.ClipRect = _CmdHeader.ClipRect; // Same as calling ImDrawCmd_HeaderCopy() + draw_cmd.TextureId = _CmdHeader.TextureId; + draw_cmd.VtxOffset = _CmdHeader.VtxOffset; + draw_cmd.IdxOffset = IdxBuffer.Size; + + IM_ASSERT(draw_cmd.ClipRect.x <= draw_cmd.ClipRect.z && draw_cmd.ClipRect.y <= draw_cmd.ClipRect.w); + CmdBuffer.push_back(draw_cmd); +} + +// Pop trailing draw command (used before merging or presenting to user) +// Note that this leaves the ImDrawList in a state unfit for further commands, as most code assume that CmdBuffer.Size > 0 && CmdBuffer.back().UserCallback == NULL +void ImDrawList::_PopUnusedDrawCmd() +{ + if (CmdBuffer.Size == 0) + return; + ImDrawCmd* curr_cmd = &CmdBuffer.Data[CmdBuffer.Size - 1]; + if (curr_cmd->ElemCount == 0 && curr_cmd->UserCallback == NULL) + CmdBuffer.pop_back(); +} + +void ImDrawList::AddCallback(ImDrawCallback callback, void* callback_data) +{ + ImDrawCmd* curr_cmd = &CmdBuffer.Data[CmdBuffer.Size - 1]; + IM_ASSERT(curr_cmd->UserCallback == NULL); + if (curr_cmd->ElemCount != 0) + { + AddDrawCmd(); + curr_cmd = &CmdBuffer.Data[CmdBuffer.Size - 1]; + } + curr_cmd->UserCallback = callback; + curr_cmd->UserCallbackData = callback_data; + + AddDrawCmd(); // Force a new command after us (see comment below) +} + +// Compare ClipRect, TextureId and VtxOffset with a single memcmp() +#define ImDrawCmd_HeaderSize (IM_OFFSETOF(ImDrawCmd, VtxOffset) + sizeof(unsigned int)) +#define ImDrawCmd_HeaderCompare(CMD_LHS, CMD_RHS) (memcmp(CMD_LHS, CMD_RHS, ImDrawCmd_HeaderSize)) // Compare ClipRect, TextureId, VtxOffset +#define ImDrawCmd_HeaderCopy(CMD_DST, CMD_SRC) (memcpy(CMD_DST, CMD_SRC, ImDrawCmd_HeaderSize)) // Copy ClipRect, TextureId, VtxOffset + +// Try to merge two last draw commands +void ImDrawList::_TryMergeDrawCmds() +{ + ImDrawCmd* curr_cmd = &CmdBuffer.Data[CmdBuffer.Size - 1]; + ImDrawCmd* prev_cmd = curr_cmd - 1; + if (ImDrawCmd_HeaderCompare(curr_cmd, prev_cmd) == 0 && curr_cmd->UserCallback == NULL && prev_cmd->UserCallback == NULL) + { + prev_cmd->ElemCount += curr_cmd->ElemCount; + CmdBuffer.pop_back(); + } +} + +// Our scheme may appears a bit unusual, basically we want the most-common calls AddLine AddRect etc. to not have to perform any check so we always have a command ready in the stack. +// The cost of figuring out if a new command has to be added or if we can merge is paid in those Update** functions only. +void ImDrawList::_OnChangedClipRect() +{ + // If current command is used with different settings we need to add a new command + ImDrawCmd* curr_cmd = &CmdBuffer.Data[CmdBuffer.Size - 1]; + if (curr_cmd->ElemCount != 0 && memcmp(&curr_cmd->ClipRect, &_CmdHeader.ClipRect, sizeof(ImVec4)) != 0) + { + AddDrawCmd(); + return; + } + IM_ASSERT(curr_cmd->UserCallback == NULL); + + // Try to merge with previous command if it matches, else use current command + ImDrawCmd* prev_cmd = curr_cmd - 1; + if (curr_cmd->ElemCount == 0 && CmdBuffer.Size > 1 && ImDrawCmd_HeaderCompare(&_CmdHeader, prev_cmd) == 0 && prev_cmd->UserCallback == NULL) + { + CmdBuffer.pop_back(); + return; + } + + curr_cmd->ClipRect = _CmdHeader.ClipRect; +} + +void ImDrawList::_OnChangedTextureID() +{ + // If current command is used with different settings we need to add a new command + ImDrawCmd* curr_cmd = &CmdBuffer.Data[CmdBuffer.Size - 1]; + if (curr_cmd->ElemCount != 0 && curr_cmd->TextureId != _CmdHeader.TextureId) + { + AddDrawCmd(); + return; + } + IM_ASSERT(curr_cmd->UserCallback == NULL); + + // Try to merge with previous command if it matches, else use current command + ImDrawCmd* prev_cmd = curr_cmd - 1; + if (curr_cmd->ElemCount == 0 && CmdBuffer.Size > 1 && ImDrawCmd_HeaderCompare(&_CmdHeader, prev_cmd) == 0 && prev_cmd->UserCallback == NULL) + { + CmdBuffer.pop_back(); + return; + } + + curr_cmd->TextureId = _CmdHeader.TextureId; +} + +void ImDrawList::_OnChangedVtxOffset() +{ + // We don't need to compare curr_cmd->VtxOffset != _CmdHeader.VtxOffset because we know it'll be different at the time we call this. + _VtxCurrentIdx = 0; + ImDrawCmd* curr_cmd = &CmdBuffer.Data[CmdBuffer.Size - 1]; + //IM_ASSERT(curr_cmd->VtxOffset != _CmdHeader.VtxOffset); // See #3349 + if (curr_cmd->ElemCount != 0) + { + AddDrawCmd(); + return; + } + IM_ASSERT(curr_cmd->UserCallback == NULL); + curr_cmd->VtxOffset = _CmdHeader.VtxOffset; +} + +int ImDrawList::_CalcCircleAutoSegmentCount(float radius) const +{ + // Automatic segment count + const int radius_idx = (int)(radius + 0.999999f); // ceil to never reduce accuracy + if (radius_idx < IM_ARRAYSIZE(_Data->CircleSegmentCounts)) + return _Data->CircleSegmentCounts[radius_idx]; // Use cached value + else + return IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_CALC(radius, _Data->CircleSegmentMaxError); +} + +// Render-level scissoring. This is passed down to your render function but not used for CPU-side coarse clipping. Prefer using higher-level ImGui::PushClipRect() to affect logic (hit-testing and widget culling) +void ImDrawList::PushClipRect(ImVec2 cr_min, ImVec2 cr_max, bool intersect_with_current_clip_rect) +{ + ImVec4 cr(cr_min.x, cr_min.y, cr_max.x, cr_max.y); + if (intersect_with_current_clip_rect) + { + ImVec4 current = _CmdHeader.ClipRect; + if (cr.x < current.x) cr.x = current.x; + if (cr.y < current.y) cr.y = current.y; + if (cr.z > current.z) cr.z = current.z; + if (cr.w > current.w) cr.w = current.w; + } + cr.z = ImMax(cr.x, cr.z); + cr.w = ImMax(cr.y, cr.w); + + _ClipRectStack.push_back(cr); + _CmdHeader.ClipRect = cr; + _OnChangedClipRect(); +} + +void ImDrawList::PushClipRectFullScreen() +{ + PushClipRect(ImVec2(_Data->ClipRectFullscreen.x, _Data->ClipRectFullscreen.y), ImVec2(_Data->ClipRectFullscreen.z, _Data->ClipRectFullscreen.w)); +} + +void ImDrawList::PopClipRect() +{ + _ClipRectStack.pop_back(); + _CmdHeader.ClipRect = (_ClipRectStack.Size == 0) ? _Data->ClipRectFullscreen : _ClipRectStack.Data[_ClipRectStack.Size - 1]; + _OnChangedClipRect(); +} + +void ImDrawList::PushTextureID(ImTextureID texture_id) +{ + _TextureIdStack.push_back(texture_id); + _CmdHeader.TextureId = texture_id; + _OnChangedTextureID(); +} + +void ImDrawList::PopTextureID() +{ + _TextureIdStack.pop_back(); + _CmdHeader.TextureId = (_TextureIdStack.Size == 0) ? (ImTextureID)NULL : _TextureIdStack.Data[_TextureIdStack.Size - 1]; + _OnChangedTextureID(); +} + +// Reserve space for a number of vertices and indices. +// You must finish filling your reserved data before calling PrimReserve() again, as it may reallocate or +// submit the intermediate results. PrimUnreserve() can be used to release unused allocations. +void ImDrawList::PrimReserve(int idx_count, int vtx_count) +{ + // Large mesh support (when enabled) + IM_ASSERT_PARANOID(idx_count >= 0 && vtx_count >= 0); + if (sizeof(ImDrawIdx) == 2 && (_VtxCurrentIdx + vtx_count >= (1 << 16)) && (Flags & ImDrawListFlags_AllowVtxOffset)) + { + // FIXME: In theory we should be testing that vtx_count <64k here. + // In practice, RenderText() relies on reserving ahead for a worst case scenario so it is currently useful for us + // to not make that check until we rework the text functions to handle clipping and large horizontal lines better. + _CmdHeader.VtxOffset = VtxBuffer.Size; + _OnChangedVtxOffset(); + } + + ImDrawCmd* draw_cmd = &CmdBuffer.Data[CmdBuffer.Size - 1]; + draw_cmd->ElemCount += idx_count; + + int vtx_buffer_old_size = VtxBuffer.Size; + VtxBuffer.resize(vtx_buffer_old_size + vtx_count); + _VtxWritePtr = VtxBuffer.Data + vtx_buffer_old_size; + + int idx_buffer_old_size = IdxBuffer.Size; + IdxBuffer.resize(idx_buffer_old_size + idx_count); + _IdxWritePtr = IdxBuffer.Data + idx_buffer_old_size; +} + +// Release the a number of reserved vertices/indices from the end of the last reservation made with PrimReserve(). +void ImDrawList::PrimUnreserve(int idx_count, int vtx_count) +{ + IM_ASSERT_PARANOID(idx_count >= 0 && vtx_count >= 0); + + ImDrawCmd* draw_cmd = &CmdBuffer.Data[CmdBuffer.Size - 1]; + draw_cmd->ElemCount -= idx_count; + VtxBuffer.shrink(VtxBuffer.Size - vtx_count); + IdxBuffer.shrink(IdxBuffer.Size - idx_count); +} + +// Fully unrolled with inline call to keep our debug builds decently fast. +void ImDrawList::PrimRect(const ImVec2& a, const ImVec2& c, ImU32 col) +{ + ImVec2 b(c.x, a.y), d(a.x, c.y), uv(_Data->TexUvWhitePixel); + ImDrawIdx idx = (ImDrawIdx)_VtxCurrentIdx; + _IdxWritePtr[0] = idx; _IdxWritePtr[1] = (ImDrawIdx)(idx+1); _IdxWritePtr[2] = (ImDrawIdx)(idx+2); + _IdxWritePtr[3] = idx; _IdxWritePtr[4] = (ImDrawIdx)(idx+2); _IdxWritePtr[5] = (ImDrawIdx)(idx+3); + _VtxWritePtr[0].pos = a; _VtxWritePtr[0].uv = uv; _VtxWritePtr[0].col = col; + _VtxWritePtr[1].pos = b; _VtxWritePtr[1].uv = uv; _VtxWritePtr[1].col = col; + _VtxWritePtr[2].pos = c; _VtxWritePtr[2].uv = uv; _VtxWritePtr[2].col = col; + _VtxWritePtr[3].pos = d; _VtxWritePtr[3].uv = uv; _VtxWritePtr[3].col = col; + _VtxWritePtr += 4; + _VtxCurrentIdx += 4; + _IdxWritePtr += 6; +} + +void ImDrawList::PrimRectUV(const ImVec2& a, const ImVec2& c, const ImVec2& uv_a, const ImVec2& uv_c, ImU32 col) +{ + ImVec2 b(c.x, a.y), d(a.x, c.y), uv_b(uv_c.x, uv_a.y), uv_d(uv_a.x, uv_c.y); + ImDrawIdx idx = (ImDrawIdx)_VtxCurrentIdx; + _IdxWritePtr[0] = idx; _IdxWritePtr[1] = (ImDrawIdx)(idx+1); _IdxWritePtr[2] = (ImDrawIdx)(idx+2); + _IdxWritePtr[3] = idx; _IdxWritePtr[4] = (ImDrawIdx)(idx+2); _IdxWritePtr[5] = (ImDrawIdx)(idx+3); + _VtxWritePtr[0].pos = a; _VtxWritePtr[0].uv = uv_a; _VtxWritePtr[0].col = col; + _VtxWritePtr[1].pos = b; _VtxWritePtr[1].uv = uv_b; _VtxWritePtr[1].col = col; + _VtxWritePtr[2].pos = c; _VtxWritePtr[2].uv = uv_c; _VtxWritePtr[2].col = col; + _VtxWritePtr[3].pos = d; _VtxWritePtr[3].uv = uv_d; _VtxWritePtr[3].col = col; + _VtxWritePtr += 4; + _VtxCurrentIdx += 4; + _IdxWritePtr += 6; +} + +void ImDrawList::PrimQuadUV(const ImVec2& a, const ImVec2& b, const ImVec2& c, const ImVec2& d, const ImVec2& uv_a, const ImVec2& uv_b, const ImVec2& uv_c, const ImVec2& uv_d, ImU32 col) +{ + ImDrawIdx idx = (ImDrawIdx)_VtxCurrentIdx; + _IdxWritePtr[0] = idx; _IdxWritePtr[1] = (ImDrawIdx)(idx+1); _IdxWritePtr[2] = (ImDrawIdx)(idx+2); + _IdxWritePtr[3] = idx; _IdxWritePtr[4] = (ImDrawIdx)(idx+2); _IdxWritePtr[5] = (ImDrawIdx)(idx+3); + _VtxWritePtr[0].pos = a; _VtxWritePtr[0].uv = uv_a; _VtxWritePtr[0].col = col; + _VtxWritePtr[1].pos = b; _VtxWritePtr[1].uv = uv_b; _VtxWritePtr[1].col = col; + _VtxWritePtr[2].pos = c; _VtxWritePtr[2].uv = uv_c; _VtxWritePtr[2].col = col; + _VtxWritePtr[3].pos = d; _VtxWritePtr[3].uv = uv_d; _VtxWritePtr[3].col = col; + _VtxWritePtr += 4; + _VtxCurrentIdx += 4; + _IdxWritePtr += 6; +} + +// On AddPolyline() and AddConvexPolyFilled() we intentionally avoid using ImVec2 and superfluous function calls to optimize debug/non-inlined builds. +// - Those macros expects l-values and need to be used as their own statement. +// - Those macros are intentionally not surrounded by the 'do {} while (0)' idiom because even that translates to runtime with debug compilers. +#define IM_NORMALIZE2F_OVER_ZERO(VX,VY) { float d2 = VX*VX + VY*VY; if (d2 > 0.0f) { float inv_len = ImRsqrt(d2); VX *= inv_len; VY *= inv_len; } } (void)0 +#define IM_FIXNORMAL2F_MAX_INVLEN2 100.0f // 500.0f (see #4053, #3366) +#define IM_FIXNORMAL2F(VX,VY) { float d2 = VX*VX + VY*VY; if (d2 > 0.000001f) { float inv_len2 = 1.0f / d2; if (inv_len2 > IM_FIXNORMAL2F_MAX_INVLEN2) inv_len2 = IM_FIXNORMAL2F_MAX_INVLEN2; VX *= inv_len2; VY *= inv_len2; } } (void)0 + +// TODO: Thickness anti-aliased lines cap are missing their AA fringe. +// We avoid using the ImVec2 math operators here to reduce cost to a minimum for debug/non-inlined builds. +void ImDrawList::AddPolyline(const ImVec2* points, const int points_count, ImU32 col, ImDrawFlags flags, float thickness) +{ + if (points_count < 2) + return; + + const bool closed = (flags & ImDrawFlags_Closed) != 0; + const ImVec2 opaque_uv = _Data->TexUvWhitePixel; + const int count = closed ? points_count : points_count - 1; // The number of line segments we need to draw + const bool thick_line = (thickness > _FringeScale); + + if (Flags & ImDrawListFlags_AntiAliasedLines) + { + // Anti-aliased stroke + const float AA_SIZE = _FringeScale; + const ImU32 col_trans = col & ~IM_COL32_A_MASK; + + // Thicknesses <1.0 should behave like thickness 1.0 + thickness = ImMax(thickness, 1.0f); + const int integer_thickness = (int)thickness; + const float fractional_thickness = thickness - integer_thickness; + + // Do we want to draw this line using a texture? + // - For now, only draw integer-width lines using textures to avoid issues with the way scaling occurs, could be improved. + // - If AA_SIZE is not 1.0f we cannot use the texture path. + const bool use_texture = (Flags & ImDrawListFlags_AntiAliasedLinesUseTex) && (integer_thickness < IM_DRAWLIST_TEX_LINES_WIDTH_MAX) && (fractional_thickness <= 0.00001f) && (AA_SIZE == 1.0f); + + // We should never hit this, because NewFrame() doesn't set ImDrawListFlags_AntiAliasedLinesUseTex unless ImFontAtlasFlags_NoBakedLines is off + IM_ASSERT_PARANOID(!use_texture || !(_Data->Font->ContainerAtlas->Flags & ImFontAtlasFlags_NoBakedLines)); + + const int idx_count = use_texture ? (count * 6) : (thick_line ? count * 18 : count * 12); + const int vtx_count = use_texture ? (points_count * 2) : (thick_line ? points_count * 4 : points_count * 3); + PrimReserve(idx_count, vtx_count); + + // Temporary buffer + // The first items are normals at each line point, then after that there are either 2 or 4 temp points for each line point + ImVec2* temp_normals = (ImVec2*)alloca(points_count * ((use_texture || !thick_line) ? 3 : 5) * sizeof(ImVec2)); //-V630 + ImVec2* temp_points = temp_normals + points_count; + + // Calculate normals (tangents) for each line segment + for (int i1 = 0; i1 < count; i1++) + { + const int i2 = (i1 + 1) == points_count ? 0 : i1 + 1; + float dx = points[i2].x - points[i1].x; + float dy = points[i2].y - points[i1].y; + IM_NORMALIZE2F_OVER_ZERO(dx, dy); + temp_normals[i1].x = dy; + temp_normals[i1].y = -dx; + } + if (!closed) + temp_normals[points_count - 1] = temp_normals[points_count - 2]; + + // If we are drawing a one-pixel-wide line without a texture, or a textured line of any width, we only need 2 or 3 vertices per point + if (use_texture || !thick_line) + { + // [PATH 1] Texture-based lines (thick or non-thick) + // [PATH 2] Non texture-based lines (non-thick) + + // The width of the geometry we need to draw - this is essentially pixels for the line itself, plus "one pixel" for AA. + // - In the texture-based path, we don't use AA_SIZE here because the +1 is tied to the generated texture + // (see ImFontAtlasBuildRenderLinesTexData() function), and so alternate values won't work without changes to that code. + // - In the non texture-based paths, we would allow AA_SIZE to potentially be != 1.0f with a patch (e.g. fringe_scale patch to + // allow scaling geometry while preserving one-screen-pixel AA fringe). + const float half_draw_size = use_texture ? ((thickness * 0.5f) + 1) : AA_SIZE; + + // If line is not closed, the first and last points need to be generated differently as there are no normals to blend + if (!closed) + { + temp_points[0] = points[0] + temp_normals[0] * half_draw_size; + temp_points[1] = points[0] - temp_normals[0] * half_draw_size; + temp_points[(points_count-1)*2+0] = points[points_count-1] + temp_normals[points_count-1] * half_draw_size; + temp_points[(points_count-1)*2+1] = points[points_count-1] - temp_normals[points_count-1] * half_draw_size; + } + + // Generate the indices to form a number of triangles for each line segment, and the vertices for the line edges + // This takes points n and n+1 and writes into n+1, with the first point in a closed line being generated from the final one (as n+1 wraps) + // FIXME-OPT: Merge the different loops, possibly remove the temporary buffer. + unsigned int idx1 = _VtxCurrentIdx; // Vertex index for start of line segment + for (int i1 = 0; i1 < count; i1++) // i1 is the first point of the line segment + { + const int i2 = (i1 + 1) == points_count ? 0 : i1 + 1; // i2 is the second point of the line segment + const unsigned int idx2 = ((i1 + 1) == points_count) ? _VtxCurrentIdx : (idx1 + (use_texture ? 2 : 3)); // Vertex index for end of segment + + // Average normals + float dm_x = (temp_normals[i1].x + temp_normals[i2].x) * 0.5f; + float dm_y = (temp_normals[i1].y + temp_normals[i2].y) * 0.5f; + IM_FIXNORMAL2F(dm_x, dm_y); + dm_x *= half_draw_size; // dm_x, dm_y are offset to the outer edge of the AA area + dm_y *= half_draw_size; + + // Add temporary vertexes for the outer edges + ImVec2* out_vtx = &temp_points[i2 * 2]; + out_vtx[0].x = points[i2].x + dm_x; + out_vtx[0].y = points[i2].y + dm_y; + out_vtx[1].x = points[i2].x - dm_x; + out_vtx[1].y = points[i2].y - dm_y; + + if (use_texture) + { + // Add indices for two triangles + _IdxWritePtr[0] = (ImDrawIdx)(idx2 + 0); _IdxWritePtr[1] = (ImDrawIdx)(idx1 + 0); _IdxWritePtr[2] = (ImDrawIdx)(idx1 + 1); // Right tri + _IdxWritePtr[3] = (ImDrawIdx)(idx2 + 1); _IdxWritePtr[4] = (ImDrawIdx)(idx1 + 1); _IdxWritePtr[5] = (ImDrawIdx)(idx2 + 0); // Left tri + _IdxWritePtr += 6; + } + else + { + // Add indexes for four triangles + _IdxWritePtr[0] = (ImDrawIdx)(idx2 + 0); _IdxWritePtr[1] = (ImDrawIdx)(idx1 + 0); _IdxWritePtr[2] = (ImDrawIdx)(idx1 + 2); // Right tri 1 + _IdxWritePtr[3] = (ImDrawIdx)(idx1 + 2); _IdxWritePtr[4] = (ImDrawIdx)(idx2 + 2); _IdxWritePtr[5] = (ImDrawIdx)(idx2 + 0); // Right tri 2 + _IdxWritePtr[6] = (ImDrawIdx)(idx2 + 1); _IdxWritePtr[7] = (ImDrawIdx)(idx1 + 1); _IdxWritePtr[8] = (ImDrawIdx)(idx1 + 0); // Left tri 1 + _IdxWritePtr[9] = (ImDrawIdx)(idx1 + 0); _IdxWritePtr[10] = (ImDrawIdx)(idx2 + 0); _IdxWritePtr[11] = (ImDrawIdx)(idx2 + 1); // Left tri 2 + _IdxWritePtr += 12; + } + + idx1 = idx2; + } + + // Add vertexes for each point on the line + if (use_texture) + { + // If we're using textures we only need to emit the left/right edge vertices + ImVec4 tex_uvs = _Data->TexUvLines[integer_thickness]; + /*if (fractional_thickness != 0.0f) // Currently always zero when use_texture==false! + { + const ImVec4 tex_uvs_1 = _Data->TexUvLines[integer_thickness + 1]; + tex_uvs.x = tex_uvs.x + (tex_uvs_1.x - tex_uvs.x) * fractional_thickness; // inlined ImLerp() + tex_uvs.y = tex_uvs.y + (tex_uvs_1.y - tex_uvs.y) * fractional_thickness; + tex_uvs.z = tex_uvs.z + (tex_uvs_1.z - tex_uvs.z) * fractional_thickness; + tex_uvs.w = tex_uvs.w + (tex_uvs_1.w - tex_uvs.w) * fractional_thickness; + }*/ + ImVec2 tex_uv0(tex_uvs.x, tex_uvs.y); + ImVec2 tex_uv1(tex_uvs.z, tex_uvs.w); + for (int i = 0; i < points_count; i++) + { + _VtxWritePtr[0].pos = temp_points[i * 2 + 0]; _VtxWritePtr[0].uv = tex_uv0; _VtxWritePtr[0].col = col; // Left-side outer edge + _VtxWritePtr[1].pos = temp_points[i * 2 + 1]; _VtxWritePtr[1].uv = tex_uv1; _VtxWritePtr[1].col = col; // Right-side outer edge + _VtxWritePtr += 2; + } + } + else + { + // If we're not using a texture, we need the center vertex as well + for (int i = 0; i < points_count; i++) + { + _VtxWritePtr[0].pos = points[i]; _VtxWritePtr[0].uv = opaque_uv; _VtxWritePtr[0].col = col; // Center of line + _VtxWritePtr[1].pos = temp_points[i * 2 + 0]; _VtxWritePtr[1].uv = opaque_uv; _VtxWritePtr[1].col = col_trans; // Left-side outer edge + _VtxWritePtr[2].pos = temp_points[i * 2 + 1]; _VtxWritePtr[2].uv = opaque_uv; _VtxWritePtr[2].col = col_trans; // Right-side outer edge + _VtxWritePtr += 3; + } + } + } + else + { + // [PATH 2] Non texture-based lines (thick): we need to draw the solid line core and thus require four vertices per point + const float half_inner_thickness = (thickness - AA_SIZE) * 0.5f; + + // If line is not closed, the first and last points need to be generated differently as there are no normals to blend + if (!closed) + { + const int points_last = points_count - 1; + temp_points[0] = points[0] + temp_normals[0] * (half_inner_thickness + AA_SIZE); + temp_points[1] = points[0] + temp_normals[0] * (half_inner_thickness); + temp_points[2] = points[0] - temp_normals[0] * (half_inner_thickness); + temp_points[3] = points[0] - temp_normals[0] * (half_inner_thickness + AA_SIZE); + temp_points[points_last * 4 + 0] = points[points_last] + temp_normals[points_last] * (half_inner_thickness + AA_SIZE); + temp_points[points_last * 4 + 1] = points[points_last] + temp_normals[points_last] * (half_inner_thickness); + temp_points[points_last * 4 + 2] = points[points_last] - temp_normals[points_last] * (half_inner_thickness); + temp_points[points_last * 4 + 3] = points[points_last] - temp_normals[points_last] * (half_inner_thickness + AA_SIZE); + } + + // Generate the indices to form a number of triangles for each line segment, and the vertices for the line edges + // This takes points n and n+1 and writes into n+1, with the first point in a closed line being generated from the final one (as n+1 wraps) + // FIXME-OPT: Merge the different loops, possibly remove the temporary buffer. + unsigned int idx1 = _VtxCurrentIdx; // Vertex index for start of line segment + for (int i1 = 0; i1 < count; i1++) // i1 is the first point of the line segment + { + const int i2 = (i1 + 1) == points_count ? 0 : (i1 + 1); // i2 is the second point of the line segment + const unsigned int idx2 = (i1 + 1) == points_count ? _VtxCurrentIdx : (idx1 + 4); // Vertex index for end of segment + + // Average normals + float dm_x = (temp_normals[i1].x + temp_normals[i2].x) * 0.5f; + float dm_y = (temp_normals[i1].y + temp_normals[i2].y) * 0.5f; + IM_FIXNORMAL2F(dm_x, dm_y); + float dm_out_x = dm_x * (half_inner_thickness + AA_SIZE); + float dm_out_y = dm_y * (half_inner_thickness + AA_SIZE); + float dm_in_x = dm_x * half_inner_thickness; + float dm_in_y = dm_y * half_inner_thickness; + + // Add temporary vertices + ImVec2* out_vtx = &temp_points[i2 * 4]; + out_vtx[0].x = points[i2].x + dm_out_x; + out_vtx[0].y = points[i2].y + dm_out_y; + out_vtx[1].x = points[i2].x + dm_in_x; + out_vtx[1].y = points[i2].y + dm_in_y; + out_vtx[2].x = points[i2].x - dm_in_x; + out_vtx[2].y = points[i2].y - dm_in_y; + out_vtx[3].x = points[i2].x - dm_out_x; + out_vtx[3].y = points[i2].y - dm_out_y; + + // Add indexes + _IdxWritePtr[0] = (ImDrawIdx)(idx2 + 1); _IdxWritePtr[1] = (ImDrawIdx)(idx1 + 1); _IdxWritePtr[2] = (ImDrawIdx)(idx1 + 2); + _IdxWritePtr[3] = (ImDrawIdx)(idx1 + 2); _IdxWritePtr[4] = (ImDrawIdx)(idx2 + 2); _IdxWritePtr[5] = (ImDrawIdx)(idx2 + 1); + _IdxWritePtr[6] = (ImDrawIdx)(idx2 + 1); _IdxWritePtr[7] = (ImDrawIdx)(idx1 + 1); _IdxWritePtr[8] = (ImDrawIdx)(idx1 + 0); + _IdxWritePtr[9] = (ImDrawIdx)(idx1 + 0); _IdxWritePtr[10] = (ImDrawIdx)(idx2 + 0); _IdxWritePtr[11] = (ImDrawIdx)(idx2 + 1); + _IdxWritePtr[12] = (ImDrawIdx)(idx2 + 2); _IdxWritePtr[13] = (ImDrawIdx)(idx1 + 2); _IdxWritePtr[14] = (ImDrawIdx)(idx1 + 3); + _IdxWritePtr[15] = (ImDrawIdx)(idx1 + 3); _IdxWritePtr[16] = (ImDrawIdx)(idx2 + 3); _IdxWritePtr[17] = (ImDrawIdx)(idx2 + 2); + _IdxWritePtr += 18; + + idx1 = idx2; + } + + // Add vertices + for (int i = 0; i < points_count; i++) + { + _VtxWritePtr[0].pos = temp_points[i * 4 + 0]; _VtxWritePtr[0].uv = opaque_uv; _VtxWritePtr[0].col = col_trans; + _VtxWritePtr[1].pos = temp_points[i * 4 + 1]; _VtxWritePtr[1].uv = opaque_uv; _VtxWritePtr[1].col = col; + _VtxWritePtr[2].pos = temp_points[i * 4 + 2]; _VtxWritePtr[2].uv = opaque_uv; _VtxWritePtr[2].col = col; + _VtxWritePtr[3].pos = temp_points[i * 4 + 3]; _VtxWritePtr[3].uv = opaque_uv; _VtxWritePtr[3].col = col_trans; + _VtxWritePtr += 4; + } + } + _VtxCurrentIdx += (ImDrawIdx)vtx_count; + } + else + { + // [PATH 4] Non texture-based, Non anti-aliased lines + const int idx_count = count * 6; + const int vtx_count = count * 4; // FIXME-OPT: Not sharing edges + PrimReserve(idx_count, vtx_count); + + for (int i1 = 0; i1 < count; i1++) + { + const int i2 = (i1 + 1) == points_count ? 0 : i1 + 1; + const ImVec2& p1 = points[i1]; + const ImVec2& p2 = points[i2]; + + float dx = p2.x - p1.x; + float dy = p2.y - p1.y; + IM_NORMALIZE2F_OVER_ZERO(dx, dy); + dx *= (thickness * 0.5f); + dy *= (thickness * 0.5f); + + _VtxWritePtr[0].pos.x = p1.x + dy; _VtxWritePtr[0].pos.y = p1.y - dx; _VtxWritePtr[0].uv = opaque_uv; _VtxWritePtr[0].col = col; + _VtxWritePtr[1].pos.x = p2.x + dy; _VtxWritePtr[1].pos.y = p2.y - dx; _VtxWritePtr[1].uv = opaque_uv; _VtxWritePtr[1].col = col; + _VtxWritePtr[2].pos.x = p2.x - dy; _VtxWritePtr[2].pos.y = p2.y + dx; _VtxWritePtr[2].uv = opaque_uv; _VtxWritePtr[2].col = col; + _VtxWritePtr[3].pos.x = p1.x - dy; _VtxWritePtr[3].pos.y = p1.y + dx; _VtxWritePtr[3].uv = opaque_uv; _VtxWritePtr[3].col = col; + _VtxWritePtr += 4; + + _IdxWritePtr[0] = (ImDrawIdx)(_VtxCurrentIdx); _IdxWritePtr[1] = (ImDrawIdx)(_VtxCurrentIdx + 1); _IdxWritePtr[2] = (ImDrawIdx)(_VtxCurrentIdx + 2); + _IdxWritePtr[3] = (ImDrawIdx)(_VtxCurrentIdx); _IdxWritePtr[4] = (ImDrawIdx)(_VtxCurrentIdx + 2); _IdxWritePtr[5] = (ImDrawIdx)(_VtxCurrentIdx + 3); + _IdxWritePtr += 6; + _VtxCurrentIdx += 4; + } + } +} + +// We intentionally avoid using ImVec2 and its math operators here to reduce cost to a minimum for debug/non-inlined builds. +void ImDrawList::AddConvexPolyFilled(const ImVec2* points, const int points_count, ImU32 col) +{ + if (points_count < 3) + return; + + const ImVec2 uv = _Data->TexUvWhitePixel; + + if (Flags & ImDrawListFlags_AntiAliasedFill) + { + // Anti-aliased Fill + const float AA_SIZE = _FringeScale; + const ImU32 col_trans = col & ~IM_COL32_A_MASK; + const int idx_count = (points_count - 2)*3 + points_count * 6; + const int vtx_count = (points_count * 2); + PrimReserve(idx_count, vtx_count); + + // Add indexes for fill + unsigned int vtx_inner_idx = _VtxCurrentIdx; + unsigned int vtx_outer_idx = _VtxCurrentIdx + 1; + for (int i = 2; i < points_count; i++) + { + _IdxWritePtr[0] = (ImDrawIdx)(vtx_inner_idx); _IdxWritePtr[1] = (ImDrawIdx)(vtx_inner_idx + ((i - 1) << 1)); _IdxWritePtr[2] = (ImDrawIdx)(vtx_inner_idx + (i << 1)); + _IdxWritePtr += 3; + } + + // Compute normals + ImVec2* temp_normals = (ImVec2*)alloca(points_count * sizeof(ImVec2)); //-V630 + for (int i0 = points_count - 1, i1 = 0; i1 < points_count; i0 = i1++) + { + const ImVec2& p0 = points[i0]; + const ImVec2& p1 = points[i1]; + float dx = p1.x - p0.x; + float dy = p1.y - p0.y; + IM_NORMALIZE2F_OVER_ZERO(dx, dy); + temp_normals[i0].x = dy; + temp_normals[i0].y = -dx; + } + + for (int i0 = points_count - 1, i1 = 0; i1 < points_count; i0 = i1++) + { + // Average normals + const ImVec2& n0 = temp_normals[i0]; + const ImVec2& n1 = temp_normals[i1]; + float dm_x = (n0.x + n1.x) * 0.5f; + float dm_y = (n0.y + n1.y) * 0.5f; + IM_FIXNORMAL2F(dm_x, dm_y); + dm_x *= AA_SIZE * 0.5f; + dm_y *= AA_SIZE * 0.5f; + + // Add vertices + _VtxWritePtr[0].pos.x = (points[i1].x - dm_x); _VtxWritePtr[0].pos.y = (points[i1].y - dm_y); _VtxWritePtr[0].uv = uv; _VtxWritePtr[0].col = col; // Inner + _VtxWritePtr[1].pos.x = (points[i1].x + dm_x); _VtxWritePtr[1].pos.y = (points[i1].y + dm_y); _VtxWritePtr[1].uv = uv; _VtxWritePtr[1].col = col_trans; // Outer + _VtxWritePtr += 2; + + // Add indexes for fringes + _IdxWritePtr[0] = (ImDrawIdx)(vtx_inner_idx + (i1 << 1)); _IdxWritePtr[1] = (ImDrawIdx)(vtx_inner_idx + (i0 << 1)); _IdxWritePtr[2] = (ImDrawIdx)(vtx_outer_idx + (i0 << 1)); + _IdxWritePtr[3] = (ImDrawIdx)(vtx_outer_idx + (i0 << 1)); _IdxWritePtr[4] = (ImDrawIdx)(vtx_outer_idx + (i1 << 1)); _IdxWritePtr[5] = (ImDrawIdx)(vtx_inner_idx + (i1 << 1)); + _IdxWritePtr += 6; + } + _VtxCurrentIdx += (ImDrawIdx)vtx_count; + } + else + { + // Non Anti-aliased Fill + const int idx_count = (points_count - 2)*3; + const int vtx_count = points_count; + PrimReserve(idx_count, vtx_count); + for (int i = 0; i < vtx_count; i++) + { + _VtxWritePtr[0].pos = points[i]; _VtxWritePtr[0].uv = uv; _VtxWritePtr[0].col = col; + _VtxWritePtr++; + } + for (int i = 2; i < points_count; i++) + { + _IdxWritePtr[0] = (ImDrawIdx)(_VtxCurrentIdx); _IdxWritePtr[1] = (ImDrawIdx)(_VtxCurrentIdx + i - 1); _IdxWritePtr[2] = (ImDrawIdx)(_VtxCurrentIdx + i); + _IdxWritePtr += 3; + } + _VtxCurrentIdx += (ImDrawIdx)vtx_count; + } +} + +void ImDrawList::_PathArcToFastEx(const ImVec2& center, float radius, int a_min_sample, int a_max_sample, int a_step) +{ + if (radius <= 0.0f) + { + _Path.push_back(center); + return; + } + + // Calculate arc auto segment step size + if (a_step <= 0) + a_step = IM_DRAWLIST_ARCFAST_SAMPLE_MAX / _CalcCircleAutoSegmentCount(radius); + + // Make sure we never do steps larger than one quarter of the circle + a_step = ImClamp(a_step, 1, IM_DRAWLIST_ARCFAST_TABLE_SIZE / 4); + + const int sample_range = ImAbs(a_max_sample - a_min_sample); + const int a_next_step = a_step; + + int samples = sample_range + 1; + bool extra_max_sample = false; + if (a_step > 1) + { + samples = sample_range / a_step + 1; + const int overstep = sample_range % a_step; + + if (overstep > 0) + { + extra_max_sample = true; + samples++; + + // When we have overstep to avoid awkwardly looking one long line and one tiny one at the end, + // distribute first step range evenly between them by reducing first step size. + if (sample_range > 0) + a_step -= (a_step - overstep) / 2; + } + } + + _Path.resize(_Path.Size + samples); + ImVec2* out_ptr = _Path.Data + (_Path.Size - samples); + + int sample_index = a_min_sample; + if (sample_index < 0 || sample_index >= IM_DRAWLIST_ARCFAST_SAMPLE_MAX) + { + sample_index = sample_index % IM_DRAWLIST_ARCFAST_SAMPLE_MAX; + if (sample_index < 0) + sample_index += IM_DRAWLIST_ARCFAST_SAMPLE_MAX; + } + + if (a_max_sample >= a_min_sample) + { + for (int a = a_min_sample; a <= a_max_sample; a += a_step, sample_index += a_step, a_step = a_next_step) + { + // a_step is clamped to IM_DRAWLIST_ARCFAST_SAMPLE_MAX, so we have guaranteed that it will not wrap over range twice or more + if (sample_index >= IM_DRAWLIST_ARCFAST_SAMPLE_MAX) + sample_index -= IM_DRAWLIST_ARCFAST_SAMPLE_MAX; + + const ImVec2 s = _Data->ArcFastVtx[sample_index]; + out_ptr->x = center.x + s.x * radius; + out_ptr->y = center.y + s.y * radius; + out_ptr++; + } + } + else + { + for (int a = a_min_sample; a >= a_max_sample; a -= a_step, sample_index -= a_step, a_step = a_next_step) + { + // a_step is clamped to IM_DRAWLIST_ARCFAST_SAMPLE_MAX, so we have guaranteed that it will not wrap over range twice or more + if (sample_index < 0) + sample_index += IM_DRAWLIST_ARCFAST_SAMPLE_MAX; + + const ImVec2 s = _Data->ArcFastVtx[sample_index]; + out_ptr->x = center.x + s.x * radius; + out_ptr->y = center.y + s.y * radius; + out_ptr++; + } + } + + if (extra_max_sample) + { + int normalized_max_sample = a_max_sample % IM_DRAWLIST_ARCFAST_SAMPLE_MAX; + if (normalized_max_sample < 0) + normalized_max_sample += IM_DRAWLIST_ARCFAST_SAMPLE_MAX; + + const ImVec2 s = _Data->ArcFastVtx[normalized_max_sample]; + out_ptr->x = center.x + s.x * radius; + out_ptr->y = center.y + s.y * radius; + out_ptr++; + } + + IM_ASSERT_PARANOID(_Path.Data + _Path.Size == out_ptr); +} + +void ImDrawList::_PathArcToN(const ImVec2& center, float radius, float a_min, float a_max, int num_segments) +{ + if (radius <= 0.0f) + { + _Path.push_back(center); + return; + } + + // Note that we are adding a point at both a_min and a_max. + // If you are trying to draw a full closed circle you don't want the overlapping points! + _Path.reserve(_Path.Size + (num_segments + 1)); + for (int i = 0; i <= num_segments; i++) + { + const float a = a_min + ((float)i / (float)num_segments) * (a_max - a_min); + _Path.push_back(ImVec2(center.x + ImCos(a) * radius, center.y + ImSin(a) * radius)); + } +} + +// 0: East, 3: South, 6: West, 9: North, 12: East +void ImDrawList::PathArcToFast(const ImVec2& center, float radius, int a_min_of_12, int a_max_of_12) +{ + if (radius <= 0.0f) + { + _Path.push_back(center); + return; + } + _PathArcToFastEx(center, radius, a_min_of_12 * IM_DRAWLIST_ARCFAST_SAMPLE_MAX / 12, a_max_of_12 * IM_DRAWLIST_ARCFAST_SAMPLE_MAX / 12, 0); +} + +void ImDrawList::PathArcTo(const ImVec2& center, float radius, float a_min, float a_max, int num_segments) +{ + if (radius <= 0.0f) + { + _Path.push_back(center); + return; + } + + if (num_segments > 0) + { + _PathArcToN(center, radius, a_min, a_max, num_segments); + return; + } + + // Automatic segment count + if (radius <= _Data->ArcFastRadiusCutoff) + { + const bool a_is_reverse = a_max < a_min; + + // We are going to use precomputed values for mid samples. + // Determine first and last sample in lookup table that belong to the arc. + const float a_min_sample_f = IM_DRAWLIST_ARCFAST_SAMPLE_MAX * a_min / (IM_PI * 2.0f); + const float a_max_sample_f = IM_DRAWLIST_ARCFAST_SAMPLE_MAX * a_max / (IM_PI * 2.0f); + + const int a_min_sample = a_is_reverse ? (int)ImFloorSigned(a_min_sample_f) : (int)ImCeil(a_min_sample_f); + const int a_max_sample = a_is_reverse ? (int)ImCeil(a_max_sample_f) : (int)ImFloorSigned(a_max_sample_f); + const int a_mid_samples = a_is_reverse ? ImMax(a_min_sample - a_max_sample, 0) : ImMax(a_max_sample - a_min_sample, 0); + + const float a_min_segment_angle = a_min_sample * IM_PI * 2.0f / IM_DRAWLIST_ARCFAST_SAMPLE_MAX; + const float a_max_segment_angle = a_max_sample * IM_PI * 2.0f / IM_DRAWLIST_ARCFAST_SAMPLE_MAX; + const bool a_emit_start = (a_min_segment_angle - a_min) != 0.0f; + const bool a_emit_end = (a_max - a_max_segment_angle) != 0.0f; + + _Path.reserve(_Path.Size + (a_mid_samples + 1 + (a_emit_start ? 1 : 0) + (a_emit_end ? 1 : 0))); + if (a_emit_start) + _Path.push_back(ImVec2(center.x + ImCos(a_min) * radius, center.y + ImSin(a_min) * radius)); + if (a_mid_samples > 0) + _PathArcToFastEx(center, radius, a_min_sample, a_max_sample, 0); + if (a_emit_end) + _Path.push_back(ImVec2(center.x + ImCos(a_max) * radius, center.y + ImSin(a_max) * radius)); + } + else + { + const float arc_length = ImAbs(a_max - a_min); + const int circle_segment_count = _CalcCircleAutoSegmentCount(radius); + const int arc_segment_count = ImMax((int)ImCeil(circle_segment_count * arc_length / (IM_PI * 2.0f)), (int)(2.0f * IM_PI / arc_length)); + _PathArcToN(center, radius, a_min, a_max, arc_segment_count); + } +} + +ImVec2 ImBezierCubicCalc(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, float t) +{ + float u = 1.0f - t; + float w1 = u * u * u; + float w2 = 3 * u * u * t; + float w3 = 3 * u * t * t; + float w4 = t * t * t; + return ImVec2(w1 * p1.x + w2 * p2.x + w3 * p3.x + w4 * p4.x, w1 * p1.y + w2 * p2.y + w3 * p3.y + w4 * p4.y); +} + +ImVec2 ImBezierQuadraticCalc(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, float t) +{ + float u = 1.0f - t; + float w1 = u * u; + float w2 = 2 * u * t; + float w3 = t * t; + return ImVec2(w1 * p1.x + w2 * p2.x + w3 * p3.x, w1 * p1.y + w2 * p2.y + w3 * p3.y); +} + +// Closely mimics ImBezierCubicClosestPointCasteljau() in imgui.cpp +static void PathBezierCubicCurveToCasteljau(ImVector* path, float x1, float y1, float x2, float y2, float x3, float y3, float x4, float y4, float tess_tol, int level) +{ + float dx = x4 - x1; + float dy = y4 - y1; + float d2 = (x2 - x4) * dy - (y2 - y4) * dx; + float d3 = (x3 - x4) * dy - (y3 - y4) * dx; + d2 = (d2 >= 0) ? d2 : -d2; + d3 = (d3 >= 0) ? d3 : -d3; + if ((d2 + d3) * (d2 + d3) < tess_tol * (dx * dx + dy * dy)) + { + path->push_back(ImVec2(x4, y4)); + } + else if (level < 10) + { + float x12 = (x1 + x2) * 0.5f, y12 = (y1 + y2) * 0.5f; + float x23 = (x2 + x3) * 0.5f, y23 = (y2 + y3) * 0.5f; + float x34 = (x3 + x4) * 0.5f, y34 = (y3 + y4) * 0.5f; + float x123 = (x12 + x23) * 0.5f, y123 = (y12 + y23) * 0.5f; + float x234 = (x23 + x34) * 0.5f, y234 = (y23 + y34) * 0.5f; + float x1234 = (x123 + x234) * 0.5f, y1234 = (y123 + y234) * 0.5f; + PathBezierCubicCurveToCasteljau(path, x1, y1, x12, y12, x123, y123, x1234, y1234, tess_tol, level + 1); + PathBezierCubicCurveToCasteljau(path, x1234, y1234, x234, y234, x34, y34, x4, y4, tess_tol, level + 1); + } +} + +static void PathBezierQuadraticCurveToCasteljau(ImVector* path, float x1, float y1, float x2, float y2, float x3, float y3, float tess_tol, int level) +{ + float dx = x3 - x1, dy = y3 - y1; + float det = (x2 - x3) * dy - (y2 - y3) * dx; + if (det * det * 4.0f < tess_tol * (dx * dx + dy * dy)) + { + path->push_back(ImVec2(x3, y3)); + } + else if (level < 10) + { + float x12 = (x1 + x2) * 0.5f, y12 = (y1 + y2) * 0.5f; + float x23 = (x2 + x3) * 0.5f, y23 = (y2 + y3) * 0.5f; + float x123 = (x12 + x23) * 0.5f, y123 = (y12 + y23) * 0.5f; + PathBezierQuadraticCurveToCasteljau(path, x1, y1, x12, y12, x123, y123, tess_tol, level + 1); + PathBezierQuadraticCurveToCasteljau(path, x123, y123, x23, y23, x3, y3, tess_tol, level + 1); + } +} + +void ImDrawList::PathBezierCubicCurveTo(const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, int num_segments) +{ + ImVec2 p1 = _Path.back(); + if (num_segments == 0) + { + PathBezierCubicCurveToCasteljau(&_Path, p1.x, p1.y, p2.x, p2.y, p3.x, p3.y, p4.x, p4.y, _Data->CurveTessellationTol, 0); // Auto-tessellated + } + else + { + float t_step = 1.0f / (float)num_segments; + for (int i_step = 1; i_step <= num_segments; i_step++) + _Path.push_back(ImBezierCubicCalc(p1, p2, p3, p4, t_step * i_step)); + } +} + +void ImDrawList::PathBezierQuadraticCurveTo(const ImVec2& p2, const ImVec2& p3, int num_segments) +{ + ImVec2 p1 = _Path.back(); + if (num_segments == 0) + { + PathBezierQuadraticCurveToCasteljau(&_Path, p1.x, p1.y, p2.x, p2.y, p3.x, p3.y, _Data->CurveTessellationTol, 0);// Auto-tessellated + } + else + { + float t_step = 1.0f / (float)num_segments; + for (int i_step = 1; i_step <= num_segments; i_step++) + _Path.push_back(ImBezierQuadraticCalc(p1, p2, p3, t_step * i_step)); + } +} + +IM_STATIC_ASSERT(ImDrawFlags_RoundCornersTopLeft == (1 << 4)); +static inline ImDrawFlags FixRectCornerFlags(ImDrawFlags flags) +{ +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + // Legacy Support for hard coded ~0 (used to be a suggested equivalent to ImDrawCornerFlags_All) + // ~0 --> ImDrawFlags_RoundCornersAll or 0 + if (flags == ~0) + return ImDrawFlags_RoundCornersAll; + + // Legacy Support for hard coded 0x01 to 0x0F (matching 15 out of 16 old flags combinations) + // 0x01 --> ImDrawFlags_RoundCornersTopLeft (VALUE 0x01 OVERLAPS ImDrawFlags_Closed but ImDrawFlags_Closed is never valid in this path!) + // 0x02 --> ImDrawFlags_RoundCornersTopRight + // 0x03 --> ImDrawFlags_RoundCornersTopLeft | ImDrawFlags_RoundCornersTopRight + // 0x04 --> ImDrawFlags_RoundCornersBotLeft + // 0x05 --> ImDrawFlags_RoundCornersTopLeft | ImDrawFlags_RoundCornersBotLeft + // ... + // 0x0F --> ImDrawFlags_RoundCornersAll or 0 + // (See all values in ImDrawCornerFlags_) + if (flags >= 0x01 && flags <= 0x0F) + return (flags << 4); + + // We cannot support hard coded 0x00 with 'float rounding > 0.0f' --> replace with ImDrawFlags_RoundCornersNone or use 'float rounding = 0.0f' +#endif + + // If this triggers, please update your code replacing hardcoded values with new ImDrawFlags_RoundCorners* values. + // Note that ImDrawFlags_Closed (== 0x01) is an invalid flag for AddRect(), AddRectFilled(), PathRect() etc... + IM_ASSERT((flags & 0x0F) == 0 && "Misuse of legacy hardcoded ImDrawCornerFlags values!"); + + if ((flags & ImDrawFlags_RoundCornersMask_) == 0) + flags |= ImDrawFlags_RoundCornersAll; + + return flags; +} + +void ImDrawList::PathRect(const ImVec2& a, const ImVec2& b, float rounding, ImDrawFlags flags) +{ + flags = FixRectCornerFlags(flags); + rounding = ImMin(rounding, ImFabs(b.x - a.x) * ( ((flags & ImDrawFlags_RoundCornersTop) == ImDrawFlags_RoundCornersTop) || ((flags & ImDrawFlags_RoundCornersBottom) == ImDrawFlags_RoundCornersBottom) ? 0.5f : 1.0f ) - 1.0f); + rounding = ImMin(rounding, ImFabs(b.y - a.y) * ( ((flags & ImDrawFlags_RoundCornersLeft) == ImDrawFlags_RoundCornersLeft) || ((flags & ImDrawFlags_RoundCornersRight) == ImDrawFlags_RoundCornersRight) ? 0.5f : 1.0f ) - 1.0f); + + if (rounding <= 0.0f || (flags & ImDrawFlags_RoundCornersMask_) == ImDrawFlags_RoundCornersNone) + { + PathLineTo(a); + PathLineTo(ImVec2(b.x, a.y)); + PathLineTo(b); + PathLineTo(ImVec2(a.x, b.y)); + } + else + { + const float rounding_tl = (flags & ImDrawFlags_RoundCornersTopLeft) ? rounding : 0.0f; + const float rounding_tr = (flags & ImDrawFlags_RoundCornersTopRight) ? rounding : 0.0f; + const float rounding_br = (flags & ImDrawFlags_RoundCornersBottomRight) ? rounding : 0.0f; + const float rounding_bl = (flags & ImDrawFlags_RoundCornersBottomLeft) ? rounding : 0.0f; + PathArcToFast(ImVec2(a.x + rounding_tl, a.y + rounding_tl), rounding_tl, 6, 9); + PathArcToFast(ImVec2(b.x - rounding_tr, a.y + rounding_tr), rounding_tr, 9, 12); + PathArcToFast(ImVec2(b.x - rounding_br, b.y - rounding_br), rounding_br, 0, 3); + PathArcToFast(ImVec2(a.x + rounding_bl, b.y - rounding_bl), rounding_bl, 3, 6); + } +} + +void ImDrawList::AddLine(const ImVec2& p1, const ImVec2& p2, ImU32 col, float thickness) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + PathLineTo(p1 + ImVec2(0.5f, 0.5f)); + PathLineTo(p2 + ImVec2(0.5f, 0.5f)); + PathStroke(col, 0, thickness); +} + +// p_min = upper-left, p_max = lower-right +// Note we don't render 1 pixels sized rectangles properly. +void ImDrawList::AddRect(const ImVec2& p_min, const ImVec2& p_max, ImU32 col, float rounding, ImDrawFlags flags, float thickness) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + if (Flags & ImDrawListFlags_AntiAliasedLines) + PathRect(p_min + ImVec2(0.50f, 0.50f), p_max - ImVec2(0.50f, 0.50f), rounding, flags); + else + PathRect(p_min + ImVec2(0.50f, 0.50f), p_max - ImVec2(0.49f, 0.49f), rounding, flags); // Better looking lower-right corner and rounded non-AA shapes. + PathStroke(col, ImDrawFlags_Closed, thickness); +} + +void ImDrawList::AddRectFilled(const ImVec2& p_min, const ImVec2& p_max, ImU32 col, float rounding, ImDrawFlags flags) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + if (rounding <= 0.0f || (flags & ImDrawFlags_RoundCornersMask_) == ImDrawFlags_RoundCornersNone) + { + PrimReserve(6, 4); + PrimRect(p_min, p_max, col); + } + else + { + PathRect(p_min, p_max, rounding, flags); + PathFillConvex(col); + } +} + +// p_min = upper-left, p_max = lower-right +void ImDrawList::AddRectFilledMultiColor(const ImVec2& p_min, const ImVec2& p_max, ImU32 col_upr_left, ImU32 col_upr_right, ImU32 col_bot_right, ImU32 col_bot_left) +{ + if (((col_upr_left | col_upr_right | col_bot_right | col_bot_left) & IM_COL32_A_MASK) == 0) + return; + + const ImVec2 uv = _Data->TexUvWhitePixel; + PrimReserve(6, 4); + PrimWriteIdx((ImDrawIdx)(_VtxCurrentIdx)); PrimWriteIdx((ImDrawIdx)(_VtxCurrentIdx + 1)); PrimWriteIdx((ImDrawIdx)(_VtxCurrentIdx + 2)); + PrimWriteIdx((ImDrawIdx)(_VtxCurrentIdx)); PrimWriteIdx((ImDrawIdx)(_VtxCurrentIdx + 2)); PrimWriteIdx((ImDrawIdx)(_VtxCurrentIdx + 3)); + PrimWriteVtx(p_min, uv, col_upr_left); + PrimWriteVtx(ImVec2(p_max.x, p_min.y), uv, col_upr_right); + PrimWriteVtx(p_max, uv, col_bot_right); + PrimWriteVtx(ImVec2(p_min.x, p_max.y), uv, col_bot_left); +} + +void ImDrawList::AddQuad(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, ImU32 col, float thickness) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + + PathLineTo(p1); + PathLineTo(p2); + PathLineTo(p3); + PathLineTo(p4); + PathStroke(col, ImDrawFlags_Closed, thickness); +} + +void ImDrawList::AddQuadFilled(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, ImU32 col) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + + PathLineTo(p1); + PathLineTo(p2); + PathLineTo(p3); + PathLineTo(p4); + PathFillConvex(col); +} + +void ImDrawList::AddTriangle(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, ImU32 col, float thickness) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + + PathLineTo(p1); + PathLineTo(p2); + PathLineTo(p3); + PathStroke(col, ImDrawFlags_Closed, thickness); +} + +void ImDrawList::AddTriangleFilled(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, ImU32 col) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + + PathLineTo(p1); + PathLineTo(p2); + PathLineTo(p3); + PathFillConvex(col); +} + +void ImDrawList::AddCircle(const ImVec2& center, float radius, ImU32 col, int num_segments, float thickness) +{ + if ((col & IM_COL32_A_MASK) == 0 || radius <= 0.0f) + return; + + if (num_segments <= 0) + { + // Use arc with automatic segment count + _PathArcToFastEx(center, radius - 0.5f, 0, IM_DRAWLIST_ARCFAST_SAMPLE_MAX, 0); + _Path.Size--; + } + else + { + // Explicit segment count (still clamp to avoid drawing insanely tessellated shapes) + num_segments = ImClamp(num_segments, 3, IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_MAX); + + // Because we are filling a closed shape we remove 1 from the count of segments/points + const float a_max = (IM_PI * 2.0f) * ((float)num_segments - 1.0f) / (float)num_segments; + PathArcTo(center, radius - 0.5f, 0.0f, a_max, num_segments - 1); + } + + PathStroke(col, ImDrawFlags_Closed, thickness); +} + +void ImDrawList::AddCircleFilled(const ImVec2& center, float radius, ImU32 col, int num_segments) +{ + if ((col & IM_COL32_A_MASK) == 0 || radius <= 0.0f) + return; + + if (num_segments <= 0) + { + // Use arc with automatic segment count + _PathArcToFastEx(center, radius, 0, IM_DRAWLIST_ARCFAST_SAMPLE_MAX, 0); + _Path.Size--; + } + else + { + // Explicit segment count (still clamp to avoid drawing insanely tessellated shapes) + num_segments = ImClamp(num_segments, 3, IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_MAX); + + // Because we are filling a closed shape we remove 1 from the count of segments/points + const float a_max = (IM_PI * 2.0f) * ((float)num_segments - 1.0f) / (float)num_segments; + PathArcTo(center, radius, 0.0f, a_max, num_segments - 1); + } + + PathFillConvex(col); +} + +// Guaranteed to honor 'num_segments' +void ImDrawList::AddNgon(const ImVec2& center, float radius, ImU32 col, int num_segments, float thickness) +{ + if ((col & IM_COL32_A_MASK) == 0 || num_segments <= 2) + return; + + // Because we are filling a closed shape we remove 1 from the count of segments/points + const float a_max = (IM_PI * 2.0f) * ((float)num_segments - 1.0f) / (float)num_segments; + PathArcTo(center, radius - 0.5f, 0.0f, a_max, num_segments - 1); + PathStroke(col, ImDrawFlags_Closed, thickness); +} + +// Guaranteed to honor 'num_segments' +void ImDrawList::AddNgonFilled(const ImVec2& center, float radius, ImU32 col, int num_segments) +{ + if ((col & IM_COL32_A_MASK) == 0 || num_segments <= 2) + return; + + // Because we are filling a closed shape we remove 1 from the count of segments/points + const float a_max = (IM_PI * 2.0f) * ((float)num_segments - 1.0f) / (float)num_segments; + PathArcTo(center, radius, 0.0f, a_max, num_segments - 1); + PathFillConvex(col); +} + +// Cubic Bezier takes 4 controls points +void ImDrawList::AddBezierCubic(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, ImU32 col, float thickness, int num_segments) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + + PathLineTo(p1); + PathBezierCubicCurveTo(p2, p3, p4, num_segments); + PathStroke(col, 0, thickness); +} + +// Quadratic Bezier takes 3 controls points +void ImDrawList::AddBezierQuadratic(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, ImU32 col, float thickness, int num_segments) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + + PathLineTo(p1); + PathBezierQuadraticCurveTo(p2, p3, num_segments); + PathStroke(col, 0, thickness); +} + +void ImDrawList::AddText(const ImFont* font, float font_size, const ImVec2& pos, ImU32 col, const char* text_begin, const char* text_end, float wrap_width, const ImVec4* cpu_fine_clip_rect) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + + if (text_end == NULL) + text_end = text_begin + strlen(text_begin); + if (text_begin == text_end) + return; + + // Pull default font/size from the shared ImDrawListSharedData instance + if (font == NULL) + font = _Data->Font; + if (font_size == 0.0f) + font_size = _Data->FontSize; + + IM_ASSERT(font->ContainerAtlas->TexID == _CmdHeader.TextureId); // Use high-level ImGui::PushFont() or low-level ImDrawList::PushTextureId() to change font. + + ImVec4 clip_rect = _CmdHeader.ClipRect; + if (cpu_fine_clip_rect) + { + clip_rect.x = ImMax(clip_rect.x, cpu_fine_clip_rect->x); + clip_rect.y = ImMax(clip_rect.y, cpu_fine_clip_rect->y); + clip_rect.z = ImMin(clip_rect.z, cpu_fine_clip_rect->z); + clip_rect.w = ImMin(clip_rect.w, cpu_fine_clip_rect->w); + } + font->RenderText(this, font_size, pos, col, clip_rect, text_begin, text_end, wrap_width, cpu_fine_clip_rect != NULL); +} + +void ImDrawList::AddText(const ImVec2& pos, ImU32 col, const char* text_begin, const char* text_end) +{ + AddText(NULL, 0.0f, pos, col, text_begin, text_end); +} + +void ImDrawList::AddImage(ImTextureID user_texture_id, const ImVec2& p_min, const ImVec2& p_max, const ImVec2& uv_min, const ImVec2& uv_max, ImU32 col) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + + const bool push_texture_id = user_texture_id != _CmdHeader.TextureId; + if (push_texture_id) + PushTextureID(user_texture_id); + + PrimReserve(6, 4); + PrimRectUV(p_min, p_max, uv_min, uv_max, col); + + if (push_texture_id) + PopTextureID(); +} + +void ImDrawList::AddImageQuad(ImTextureID user_texture_id, const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, const ImVec2& uv1, const ImVec2& uv2, const ImVec2& uv3, const ImVec2& uv4, ImU32 col) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + + const bool push_texture_id = user_texture_id != _CmdHeader.TextureId; + if (push_texture_id) + PushTextureID(user_texture_id); + + PrimReserve(6, 4); + PrimQuadUV(p1, p2, p3, p4, uv1, uv2, uv3, uv4, col); + + if (push_texture_id) + PopTextureID(); +} + +void ImDrawList::AddImageRounded(ImTextureID user_texture_id, const ImVec2& p_min, const ImVec2& p_max, const ImVec2& uv_min, const ImVec2& uv_max, ImU32 col, float rounding, ImDrawFlags flags) +{ + if ((col & IM_COL32_A_MASK) == 0) + return; + + flags = FixRectCornerFlags(flags); + if (rounding <= 0.0f || (flags & ImDrawFlags_RoundCornersMask_) == ImDrawFlags_RoundCornersNone) + { + AddImage(user_texture_id, p_min, p_max, uv_min, uv_max, col); + return; + } + + const bool push_texture_id = user_texture_id != _CmdHeader.TextureId; + if (push_texture_id) + PushTextureID(user_texture_id); + + int vert_start_idx = VtxBuffer.Size; + PathRect(p_min, p_max, rounding, flags); + PathFillConvex(col); + int vert_end_idx = VtxBuffer.Size; + ImGui::ShadeVertsLinearUV(this, vert_start_idx, vert_end_idx, p_min, p_max, uv_min, uv_max, true); + + if (push_texture_id) + PopTextureID(); +} + + +//----------------------------------------------------------------------------- +// [SECTION] ImDrawListSplitter +//----------------------------------------------------------------------------- +// FIXME: This may be a little confusing, trying to be a little too low-level/optimal instead of just doing vector swap.. +//----------------------------------------------------------------------------- + +void ImDrawListSplitter::ClearFreeMemory() +{ + for (int i = 0; i < _Channels.Size; i++) + { + if (i == _Current) + memset(&_Channels[i], 0, sizeof(_Channels[i])); // Current channel is a copy of CmdBuffer/IdxBuffer, don't destruct again + _Channels[i]._CmdBuffer.clear(); + _Channels[i]._IdxBuffer.clear(); + } + _Current = 0; + _Count = 1; + _Channels.clear(); +} + +void ImDrawListSplitter::Split(ImDrawList* draw_list, int channels_count) +{ + IM_UNUSED(draw_list); + IM_ASSERT(_Current == 0 && _Count <= 1 && "Nested channel splitting is not supported. Please use separate instances of ImDrawListSplitter."); + int old_channels_count = _Channels.Size; + if (old_channels_count < channels_count) + { + _Channels.reserve(channels_count); // Avoid over reserving since this is likely to stay stable + _Channels.resize(channels_count); + } + _Count = channels_count; + + // Channels[] (24/32 bytes each) hold storage that we'll swap with draw_list->_CmdBuffer/_IdxBuffer + // The content of Channels[0] at this point doesn't matter. We clear it to make state tidy in a debugger but we don't strictly need to. + // When we switch to the next channel, we'll copy draw_list->_CmdBuffer/_IdxBuffer into Channels[0] and then Channels[1] into draw_list->CmdBuffer/_IdxBuffer + memset(&_Channels[0], 0, sizeof(ImDrawChannel)); + for (int i = 1; i < channels_count; i++) + { + if (i >= old_channels_count) + { + IM_PLACEMENT_NEW(&_Channels[i]) ImDrawChannel(); + } + else + { + _Channels[i]._CmdBuffer.resize(0); + _Channels[i]._IdxBuffer.resize(0); + } + } +} + +void ImDrawListSplitter::Merge(ImDrawList* draw_list) +{ + // Note that we never use or rely on _Channels.Size because it is merely a buffer that we never shrink back to 0 to keep all sub-buffers ready for use. + if (_Count <= 1) + return; + + SetCurrentChannel(draw_list, 0); + draw_list->_PopUnusedDrawCmd(); + + // Calculate our final buffer sizes. Also fix the incorrect IdxOffset values in each command. + int new_cmd_buffer_count = 0; + int new_idx_buffer_count = 0; + ImDrawCmd* last_cmd = (_Count > 0 && draw_list->CmdBuffer.Size > 0) ? &draw_list->CmdBuffer.back() : NULL; + int idx_offset = last_cmd ? last_cmd->IdxOffset + last_cmd->ElemCount : 0; + for (int i = 1; i < _Count; i++) + { + ImDrawChannel& ch = _Channels[i]; + + // Equivalent of PopUnusedDrawCmd() for this channel's cmdbuffer and except we don't need to test for UserCallback. + if (ch._CmdBuffer.Size > 0 && ch._CmdBuffer.back().ElemCount == 0) + ch._CmdBuffer.pop_back(); + + if (ch._CmdBuffer.Size > 0 && last_cmd != NULL) + { + ImDrawCmd* next_cmd = &ch._CmdBuffer[0]; + if (ImDrawCmd_HeaderCompare(last_cmd, next_cmd) == 0 && last_cmd->UserCallback == NULL && next_cmd->UserCallback == NULL) + { + // Merge previous channel last draw command with current channel first draw command if matching. + last_cmd->ElemCount += next_cmd->ElemCount; + idx_offset += next_cmd->ElemCount; + ch._CmdBuffer.erase(ch._CmdBuffer.Data); // FIXME-OPT: Improve for multiple merges. + } + } + if (ch._CmdBuffer.Size > 0) + last_cmd = &ch._CmdBuffer.back(); + new_cmd_buffer_count += ch._CmdBuffer.Size; + new_idx_buffer_count += ch._IdxBuffer.Size; + for (int cmd_n = 0; cmd_n < ch._CmdBuffer.Size; cmd_n++) + { + ch._CmdBuffer.Data[cmd_n].IdxOffset = idx_offset; + idx_offset += ch._CmdBuffer.Data[cmd_n].ElemCount; + } + } + draw_list->CmdBuffer.resize(draw_list->CmdBuffer.Size + new_cmd_buffer_count); + draw_list->IdxBuffer.resize(draw_list->IdxBuffer.Size + new_idx_buffer_count); + + // Write commands and indices in order (they are fairly small structures, we don't copy vertices only indices) + ImDrawCmd* cmd_write = draw_list->CmdBuffer.Data + draw_list->CmdBuffer.Size - new_cmd_buffer_count; + ImDrawIdx* idx_write = draw_list->IdxBuffer.Data + draw_list->IdxBuffer.Size - new_idx_buffer_count; + for (int i = 1; i < _Count; i++) + { + ImDrawChannel& ch = _Channels[i]; + if (int sz = ch._CmdBuffer.Size) { memcpy(cmd_write, ch._CmdBuffer.Data, sz * sizeof(ImDrawCmd)); cmd_write += sz; } + if (int sz = ch._IdxBuffer.Size) { memcpy(idx_write, ch._IdxBuffer.Data, sz * sizeof(ImDrawIdx)); idx_write += sz; } + } + draw_list->_IdxWritePtr = idx_write; + + // Ensure there's always a non-callback draw command trailing the command-buffer + if (draw_list->CmdBuffer.Size == 0 || draw_list->CmdBuffer.back().UserCallback != NULL) + draw_list->AddDrawCmd(); + + // If current command is used with different settings we need to add a new command + ImDrawCmd* curr_cmd = &draw_list->CmdBuffer.Data[draw_list->CmdBuffer.Size - 1]; + if (curr_cmd->ElemCount == 0) + ImDrawCmd_HeaderCopy(curr_cmd, &draw_list->_CmdHeader); // Copy ClipRect, TextureId, VtxOffset + else if (ImDrawCmd_HeaderCompare(curr_cmd, &draw_list->_CmdHeader) != 0) + draw_list->AddDrawCmd(); + + _Count = 1; +} + +void ImDrawListSplitter::SetCurrentChannel(ImDrawList* draw_list, int idx) +{ + IM_ASSERT(idx >= 0 && idx < _Count); + if (_Current == idx) + return; + + // Overwrite ImVector (12/16 bytes), four times. This is merely a silly optimization instead of doing .swap() + memcpy(&_Channels.Data[_Current]._CmdBuffer, &draw_list->CmdBuffer, sizeof(draw_list->CmdBuffer)); + memcpy(&_Channels.Data[_Current]._IdxBuffer, &draw_list->IdxBuffer, sizeof(draw_list->IdxBuffer)); + _Current = idx; + memcpy(&draw_list->CmdBuffer, &_Channels.Data[idx]._CmdBuffer, sizeof(draw_list->CmdBuffer)); + memcpy(&draw_list->IdxBuffer, &_Channels.Data[idx]._IdxBuffer, sizeof(draw_list->IdxBuffer)); + draw_list->_IdxWritePtr = draw_list->IdxBuffer.Data + draw_list->IdxBuffer.Size; + + // If current command is used with different settings we need to add a new command + ImDrawCmd* curr_cmd = (draw_list->CmdBuffer.Size == 0) ? NULL : &draw_list->CmdBuffer.Data[draw_list->CmdBuffer.Size - 1]; + if (curr_cmd == NULL) + draw_list->AddDrawCmd(); + else if (curr_cmd->ElemCount == 0) + ImDrawCmd_HeaderCopy(curr_cmd, &draw_list->_CmdHeader); // Copy ClipRect, TextureId, VtxOffset + else if (ImDrawCmd_HeaderCompare(curr_cmd, &draw_list->_CmdHeader) != 0) + draw_list->AddDrawCmd(); +} + +//----------------------------------------------------------------------------- +// [SECTION] ImDrawData +//----------------------------------------------------------------------------- + +// For backward compatibility: convert all buffers from indexed to de-indexed, in case you cannot render indexed. Note: this is slow and most likely a waste of resources. Always prefer indexed rendering! +void ImDrawData::DeIndexAllBuffers() +{ + ImVector new_vtx_buffer; + TotalVtxCount = TotalIdxCount = 0; + for (int i = 0; i < CmdListsCount; i++) + { + ImDrawList* cmd_list = CmdLists[i]; + if (cmd_list->IdxBuffer.empty()) + continue; + new_vtx_buffer.resize(cmd_list->IdxBuffer.Size); + for (int j = 0; j < cmd_list->IdxBuffer.Size; j++) + new_vtx_buffer[j] = cmd_list->VtxBuffer[cmd_list->IdxBuffer[j]]; + cmd_list->VtxBuffer.swap(new_vtx_buffer); + cmd_list->IdxBuffer.resize(0); + TotalVtxCount += cmd_list->VtxBuffer.Size; + } +} + +// Helper to scale the ClipRect field of each ImDrawCmd. +// Use if your final output buffer is at a different scale than draw_data->DisplaySize, +// or if there is a difference between your window resolution and framebuffer resolution. +void ImDrawData::ScaleClipRects(const ImVec2& fb_scale) +{ + for (int i = 0; i < CmdListsCount; i++) + { + ImDrawList* cmd_list = CmdLists[i]; + for (int cmd_i = 0; cmd_i < cmd_list->CmdBuffer.Size; cmd_i++) + { + ImDrawCmd* cmd = &cmd_list->CmdBuffer[cmd_i]; + cmd->ClipRect = ImVec4(cmd->ClipRect.x * fb_scale.x, cmd->ClipRect.y * fb_scale.y, cmd->ClipRect.z * fb_scale.x, cmd->ClipRect.w * fb_scale.y); + } + } +} + +//----------------------------------------------------------------------------- +// [SECTION] Helpers ShadeVertsXXX functions +//----------------------------------------------------------------------------- + +// Generic linear color gradient, write to RGB fields, leave A untouched. +void ImGui::ShadeVertsLinearColorGradientKeepAlpha(ImDrawList* draw_list, int vert_start_idx, int vert_end_idx, ImVec2 gradient_p0, ImVec2 gradient_p1, ImU32 col0, ImU32 col1) +{ + ImVec2 gradient_extent = gradient_p1 - gradient_p0; + float gradient_inv_length2 = 1.0f / ImLengthSqr(gradient_extent); + ImDrawVert* vert_start = draw_list->VtxBuffer.Data + vert_start_idx; + ImDrawVert* vert_end = draw_list->VtxBuffer.Data + vert_end_idx; + const int col0_r = (int)(col0 >> IM_COL32_R_SHIFT) & 0xFF; + const int col0_g = (int)(col0 >> IM_COL32_G_SHIFT) & 0xFF; + const int col0_b = (int)(col0 >> IM_COL32_B_SHIFT) & 0xFF; + const int col_delta_r = ((int)(col1 >> IM_COL32_R_SHIFT) & 0xFF) - col0_r; + const int col_delta_g = ((int)(col1 >> IM_COL32_G_SHIFT) & 0xFF) - col0_g; + const int col_delta_b = ((int)(col1 >> IM_COL32_B_SHIFT) & 0xFF) - col0_b; + for (ImDrawVert* vert = vert_start; vert < vert_end; vert++) + { + float d = ImDot(vert->pos - gradient_p0, gradient_extent); + float t = ImClamp(d * gradient_inv_length2, 0.0f, 1.0f); + int r = (int)(col0_r + col_delta_r * t); + int g = (int)(col0_g + col_delta_g * t); + int b = (int)(col0_b + col_delta_b * t); + vert->col = (r << IM_COL32_R_SHIFT) | (g << IM_COL32_G_SHIFT) | (b << IM_COL32_B_SHIFT) | (vert->col & IM_COL32_A_MASK); + } +} + +// Distribute UV over (a, b) rectangle +void ImGui::ShadeVertsLinearUV(ImDrawList* draw_list, int vert_start_idx, int vert_end_idx, const ImVec2& a, const ImVec2& b, const ImVec2& uv_a, const ImVec2& uv_b, bool clamp) +{ + const ImVec2 size = b - a; + const ImVec2 uv_size = uv_b - uv_a; + const ImVec2 scale = ImVec2( + size.x != 0.0f ? (uv_size.x / size.x) : 0.0f, + size.y != 0.0f ? (uv_size.y / size.y) : 0.0f); + + ImDrawVert* vert_start = draw_list->VtxBuffer.Data + vert_start_idx; + ImDrawVert* vert_end = draw_list->VtxBuffer.Data + vert_end_idx; + if (clamp) + { + const ImVec2 min = ImMin(uv_a, uv_b); + const ImVec2 max = ImMax(uv_a, uv_b); + for (ImDrawVert* vertex = vert_start; vertex < vert_end; ++vertex) + vertex->uv = ImClamp(uv_a + ImMul(ImVec2(vertex->pos.x, vertex->pos.y) - a, scale), min, max); + } + else + { + for (ImDrawVert* vertex = vert_start; vertex < vert_end; ++vertex) + vertex->uv = uv_a + ImMul(ImVec2(vertex->pos.x, vertex->pos.y) - a, scale); + } +} + +//----------------------------------------------------------------------------- +// [SECTION] ImFontConfig +//----------------------------------------------------------------------------- + +ImFontConfig::ImFontConfig() +{ + memset(this, 0, sizeof(*this)); + FontDataOwnedByAtlas = true; + OversampleH = 3; // FIXME: 2 may be a better default? + OversampleV = 1; + GlyphMaxAdvanceX = FLT_MAX; + RasterizerMultiply = 1.0f; + EllipsisChar = (ImWchar)-1; +} + +//----------------------------------------------------------------------------- +// [SECTION] ImFontAtlas +//----------------------------------------------------------------------------- + +// A work of art lies ahead! (. = white layer, X = black layer, others are blank) +// The 2x2 white texels on the top left are the ones we'll use everywhere in Dear ImGui to render filled shapes. +const int FONT_ATLAS_DEFAULT_TEX_DATA_W = 108; // Actual texture will be 2 times that + 1 spacing. +const int FONT_ATLAS_DEFAULT_TEX_DATA_H = 27; +static const char FONT_ATLAS_DEFAULT_TEX_DATA_PIXELS[FONT_ATLAS_DEFAULT_TEX_DATA_W * FONT_ATLAS_DEFAULT_TEX_DATA_H + 1] = +{ + "..- -XXXXXXX- X - X -XXXXXXX - XXXXXXX- XX " + "..- -X.....X- X.X - X.X -X.....X - X.....X- X..X " + "--- -XXX.XXX- X...X - X...X -X....X - X....X- X..X " + "X - X.X - X.....X - X.....X -X...X - X...X- X..X " + "XX - X.X -X.......X- X.......X -X..X.X - X.X..X- X..X " + "X.X - X.X -XXXX.XXXX- XXXX.XXXX -X.X X.X - X.X X.X- X..XXX " + "X..X - X.X - X.X - X.X -XX X.X - X.X XX- X..X..XXX " + "X...X - X.X - X.X - XX X.X XX - X.X - X.X - X..X..X..XX " + "X....X - X.X - X.X - X.X X.X X.X - X.X - X.X - X..X..X..X.X " + "X.....X - X.X - X.X - X..X X.X X..X - X.X - X.X -XXX X..X..X..X..X" + "X......X - X.X - X.X - X...XXXXXX.XXXXXX...X - X.X XX-XX X.X -X..XX........X..X" + "X.......X - X.X - X.X -X.....................X- X.X X.X-X.X X.X -X...X...........X" + "X........X - X.X - X.X - X...XXXXXX.XXXXXX...X - X.X..X-X..X.X - X..............X" + "X.........X -XXX.XXX- X.X - X..X X.X X..X - X...X-X...X - X.............X" + "X..........X-X.....X- X.X - X.X X.X X.X - X....X-X....X - X.............X" + "X......XXXXX-XXXXXXX- X.X - XX X.X XX - X.....X-X.....X - X............X" + "X...X..X --------- X.X - X.X - XXXXXXX-XXXXXXX - X...........X " + "X..X X..X - -XXXX.XXXX- XXXX.XXXX ------------------------------------- X..........X " + "X.X X..X - -X.......X- X.......X - XX XX - - X..........X " + "XX X..X - - X.....X - X.....X - X.X X.X - - X........X " + " X..X - X...X - X...X - X..X X..X - - X........X " + " XX - X.X - X.X - X...XXXXXXXXXXXXX...X - - XXXXXXXXXX " + "------------ - X - X -X.....................X- ------------------" + " ----------------------------------- X...XXXXXXXXXXXXX...X - " + " - X..X X..X - " + " - X.X X.X - " + " - XX XX - " +}; + +static const ImVec2 FONT_ATLAS_DEFAULT_TEX_CURSOR_DATA[ImGuiMouseCursor_COUNT][3] = +{ + // Pos ........ Size ......... Offset ...... + { ImVec2( 0,3), ImVec2(12,19), ImVec2( 0, 0) }, // ImGuiMouseCursor_Arrow + { ImVec2(13,0), ImVec2( 7,16), ImVec2( 1, 8) }, // ImGuiMouseCursor_TextInput + { ImVec2(31,0), ImVec2(23,23), ImVec2(11,11) }, // ImGuiMouseCursor_ResizeAll + { ImVec2(21,0), ImVec2( 9,23), ImVec2( 4,11) }, // ImGuiMouseCursor_ResizeNS + { ImVec2(55,18),ImVec2(23, 9), ImVec2(11, 4) }, // ImGuiMouseCursor_ResizeEW + { ImVec2(73,0), ImVec2(17,17), ImVec2( 8, 8) }, // ImGuiMouseCursor_ResizeNESW + { ImVec2(55,0), ImVec2(17,17), ImVec2( 8, 8) }, // ImGuiMouseCursor_ResizeNWSE + { ImVec2(91,0), ImVec2(17,22), ImVec2( 5, 0) }, // ImGuiMouseCursor_Hand +}; + +ImFontAtlas::ImFontAtlas() +{ + memset(this, 0, sizeof(*this)); + TexGlyphPadding = 1; + PackIdMouseCursors = PackIdLines = -1; +} + +ImFontAtlas::~ImFontAtlas() +{ + IM_ASSERT(!Locked && "Cannot modify a locked ImFontAtlas between NewFrame() and EndFrame/Render()!"); + Clear(); +} + +void ImFontAtlas::ClearInputData() +{ + IM_ASSERT(!Locked && "Cannot modify a locked ImFontAtlas between NewFrame() and EndFrame/Render()!"); + for (int i = 0; i < ConfigData.Size; i++) + if (ConfigData[i].FontData && ConfigData[i].FontDataOwnedByAtlas) + { + IM_FREE(ConfigData[i].FontData); + ConfigData[i].FontData = NULL; + } + + // When clearing this we lose access to the font name and other information used to build the font. + for (int i = 0; i < Fonts.Size; i++) + if (Fonts[i]->ConfigData >= ConfigData.Data && Fonts[i]->ConfigData < ConfigData.Data + ConfigData.Size) + { + Fonts[i]->ConfigData = NULL; + Fonts[i]->ConfigDataCount = 0; + } + ConfigData.clear(); + CustomRects.clear(); + PackIdMouseCursors = PackIdLines = -1; + // Important: we leave TexReady untouched +} + +void ImFontAtlas::ClearTexData() +{ + IM_ASSERT(!Locked && "Cannot modify a locked ImFontAtlas between NewFrame() and EndFrame/Render()!"); + if (TexPixelsAlpha8) + IM_FREE(TexPixelsAlpha8); + if (TexPixelsRGBA32) + IM_FREE(TexPixelsRGBA32); + TexPixelsAlpha8 = NULL; + TexPixelsRGBA32 = NULL; + TexPixelsUseColors = false; + // Important: we leave TexReady untouched +} + +void ImFontAtlas::ClearFonts() +{ + IM_ASSERT(!Locked && "Cannot modify a locked ImFontAtlas between NewFrame() and EndFrame/Render()!"); + Fonts.clear_delete(); + TexReady = false; +} + +void ImFontAtlas::Clear() +{ + ClearInputData(); + ClearTexData(); + ClearFonts(); +} + +void ImFontAtlas::GetTexDataAsAlpha8(unsigned char** out_pixels, int* out_width, int* out_height, int* out_bytes_per_pixel) +{ + // Build atlas on demand + if (TexPixelsAlpha8 == NULL) + Build(); + + *out_pixels = TexPixelsAlpha8; + if (out_width) *out_width = TexWidth; + if (out_height) *out_height = TexHeight; + if (out_bytes_per_pixel) *out_bytes_per_pixel = 1; +} + +void ImFontAtlas::GetTexDataAsRGBA32(unsigned char** out_pixels, int* out_width, int* out_height, int* out_bytes_per_pixel) +{ + // Convert to RGBA32 format on demand + // Although it is likely to be the most commonly used format, our font rendering is 1 channel / 8 bpp + if (!TexPixelsRGBA32) + { + unsigned char* pixels = NULL; + GetTexDataAsAlpha8(&pixels, NULL, NULL); + if (pixels) + { + TexPixelsRGBA32 = (unsigned int*)IM_ALLOC((size_t)TexWidth * (size_t)TexHeight * 4); + const unsigned char* src = pixels; + unsigned int* dst = TexPixelsRGBA32; + for (int n = TexWidth * TexHeight; n > 0; n--) + *dst++ = IM_COL32(255, 255, 255, (unsigned int)(*src++)); + } + } + + *out_pixels = (unsigned char*)TexPixelsRGBA32; + if (out_width) *out_width = TexWidth; + if (out_height) *out_height = TexHeight; + if (out_bytes_per_pixel) *out_bytes_per_pixel = 4; +} + +ImFont* ImFontAtlas::AddFont(const ImFontConfig* font_cfg) +{ + IM_ASSERT(!Locked && "Cannot modify a locked ImFontAtlas between NewFrame() and EndFrame/Render()!"); + IM_ASSERT(font_cfg->FontData != NULL && font_cfg->FontDataSize > 0); + IM_ASSERT(font_cfg->SizePixels > 0.0f); + + // Create new font + if (!font_cfg->MergeMode) + Fonts.push_back(IM_NEW(ImFont)); + else + IM_ASSERT(!Fonts.empty() && "Cannot use MergeMode for the first font"); // When using MergeMode make sure that a font has already been added before. You can use ImGui::GetIO().Fonts->AddFontDefault() to add the default imgui font. + + ConfigData.push_back(*font_cfg); + ImFontConfig& new_font_cfg = ConfigData.back(); + if (new_font_cfg.DstFont == NULL) + new_font_cfg.DstFont = Fonts.back(); + if (!new_font_cfg.FontDataOwnedByAtlas) + { + new_font_cfg.FontData = IM_ALLOC(new_font_cfg.FontDataSize); + new_font_cfg.FontDataOwnedByAtlas = true; + memcpy(new_font_cfg.FontData, font_cfg->FontData, (size_t)new_font_cfg.FontDataSize); + } + + if (new_font_cfg.DstFont->EllipsisChar == (ImWchar)-1) + new_font_cfg.DstFont->EllipsisChar = font_cfg->EllipsisChar; + + // Invalidate texture + TexReady = false; + ClearTexData(); + return new_font_cfg.DstFont; +} + +// Default font TTF is compressed with stb_compress then base85 encoded (see misc/fonts/binary_to_compressed_c.cpp for encoder) +static unsigned int stb_decompress_length(const unsigned char* input); +static unsigned int stb_decompress(unsigned char* output, const unsigned char* input, unsigned int length); +static const char* GetDefaultCompressedFontDataTTFBase85(); +static unsigned int Decode85Byte(char c) { return c >= '\\' ? c-36 : c-35; } +static void Decode85(const unsigned char* src, unsigned char* dst) +{ + while (*src) + { + unsigned int tmp = Decode85Byte(src[0]) + 85 * (Decode85Byte(src[1]) + 85 * (Decode85Byte(src[2]) + 85 * (Decode85Byte(src[3]) + 85 * Decode85Byte(src[4])))); + dst[0] = ((tmp >> 0) & 0xFF); dst[1] = ((tmp >> 8) & 0xFF); dst[2] = ((tmp >> 16) & 0xFF); dst[3] = ((tmp >> 24) & 0xFF); // We can't assume little-endianness. + src += 5; + dst += 4; + } +} + +// Load embedded ProggyClean.ttf at size 13, disable oversampling +ImFont* ImFontAtlas::AddFontDefault(const ImFontConfig* font_cfg_template) +{ + ImFontConfig font_cfg = font_cfg_template ? *font_cfg_template : ImFontConfig(); + if (!font_cfg_template) + { + font_cfg.OversampleH = font_cfg.OversampleV = 1; + font_cfg.PixelSnapH = true; + } + if (font_cfg.SizePixels <= 0.0f) + font_cfg.SizePixels = 13.0f * 1.0f; + if (font_cfg.Name[0] == '\0') + ImFormatString(font_cfg.Name, IM_ARRAYSIZE(font_cfg.Name), "ProggyClean.ttf, %dpx", (int)font_cfg.SizePixels); + font_cfg.EllipsisChar = (ImWchar)0x0085; + font_cfg.GlyphOffset.y = 1.0f * IM_FLOOR(font_cfg.SizePixels / 13.0f); // Add +1 offset per 13 units + + const char* ttf_compressed_base85 = GetDefaultCompressedFontDataTTFBase85(); + const ImWchar* glyph_ranges = font_cfg.GlyphRanges != NULL ? font_cfg.GlyphRanges : GetGlyphRangesDefault(); + ImFont* font = AddFontFromMemoryCompressedBase85TTF(ttf_compressed_base85, font_cfg.SizePixels, &font_cfg, glyph_ranges); + return font; +} + +ImFont* ImFontAtlas::AddFontFromFileTTF(const char* filename, float size_pixels, const ImFontConfig* font_cfg_template, const ImWchar* glyph_ranges) +{ + IM_ASSERT(!Locked && "Cannot modify a locked ImFontAtlas between NewFrame() and EndFrame/Render()!"); + size_t data_size = 0; + void* data = ImFileLoadToMemory(filename, "rb", &data_size, 0); + if (!data) + { + IM_ASSERT_USER_ERROR(0, "Could not load font file!"); + return NULL; + } + ImFontConfig font_cfg = font_cfg_template ? *font_cfg_template : ImFontConfig(); + if (font_cfg.Name[0] == '\0') + { + // Store a short copy of filename into into the font name for convenience + const char* p; + for (p = filename + strlen(filename); p > filename && p[-1] != '/' && p[-1] != '\\'; p--) {} + ImFormatString(font_cfg.Name, IM_ARRAYSIZE(font_cfg.Name), "%s, %.0fpx", p, size_pixels); + } + return AddFontFromMemoryTTF(data, (int)data_size, size_pixels, &font_cfg, glyph_ranges); +} + +// NB: Transfer ownership of 'ttf_data' to ImFontAtlas, unless font_cfg_template->FontDataOwnedByAtlas == false. Owned TTF buffer will be deleted after Build(). +ImFont* ImFontAtlas::AddFontFromMemoryTTF(void* ttf_data, int ttf_size, float size_pixels, const ImFontConfig* font_cfg_template, const ImWchar* glyph_ranges) +{ + IM_ASSERT(!Locked && "Cannot modify a locked ImFontAtlas between NewFrame() and EndFrame/Render()!"); + ImFontConfig font_cfg = font_cfg_template ? *font_cfg_template : ImFontConfig(); + IM_ASSERT(font_cfg.FontData == NULL); + font_cfg.FontData = ttf_data; + font_cfg.FontDataSize = ttf_size; + font_cfg.SizePixels = size_pixels > 0.0f ? size_pixels : font_cfg.SizePixels; + if (glyph_ranges) + font_cfg.GlyphRanges = glyph_ranges; + return AddFont(&font_cfg); +} + +ImFont* ImFontAtlas::AddFontFromMemoryCompressedTTF(const void* compressed_ttf_data, int compressed_ttf_size, float size_pixels, const ImFontConfig* font_cfg_template, const ImWchar* glyph_ranges) +{ + const unsigned int buf_decompressed_size = stb_decompress_length((const unsigned char*)compressed_ttf_data); + unsigned char* buf_decompressed_data = (unsigned char*)IM_ALLOC(buf_decompressed_size); + stb_decompress(buf_decompressed_data, (const unsigned char*)compressed_ttf_data, (unsigned int)compressed_ttf_size); + + ImFontConfig font_cfg = font_cfg_template ? *font_cfg_template : ImFontConfig(); + IM_ASSERT(font_cfg.FontData == NULL); + font_cfg.FontDataOwnedByAtlas = true; + return AddFontFromMemoryTTF(buf_decompressed_data, (int)buf_decompressed_size, size_pixels, &font_cfg, glyph_ranges); +} + +ImFont* ImFontAtlas::AddFontFromMemoryCompressedBase85TTF(const char* compressed_ttf_data_base85, float size_pixels, const ImFontConfig* font_cfg, const ImWchar* glyph_ranges) +{ + int compressed_ttf_size = (((int)strlen(compressed_ttf_data_base85) + 4) / 5) * 4; + void* compressed_ttf = IM_ALLOC((size_t)compressed_ttf_size); + Decode85((const unsigned char*)compressed_ttf_data_base85, (unsigned char*)compressed_ttf); + ImFont* font = AddFontFromMemoryCompressedTTF(compressed_ttf, compressed_ttf_size, size_pixels, font_cfg, glyph_ranges); + IM_FREE(compressed_ttf); + return font; +} + +int ImFontAtlas::AddCustomRectRegular(int width, int height) +{ + IM_ASSERT(width > 0 && width <= 0xFFFF); + IM_ASSERT(height > 0 && height <= 0xFFFF); + ImFontAtlasCustomRect r; + r.Width = (unsigned short)width; + r.Height = (unsigned short)height; + CustomRects.push_back(r); + return CustomRects.Size - 1; // Return index +} + +int ImFontAtlas::AddCustomRectFontGlyph(ImFont* font, ImWchar id, int width, int height, float advance_x, const ImVec2& offset) +{ +#ifdef IMGUI_USE_WCHAR32 + IM_ASSERT(id <= IM_UNICODE_CODEPOINT_MAX); +#endif + IM_ASSERT(font != NULL); + IM_ASSERT(width > 0 && width <= 0xFFFF); + IM_ASSERT(height > 0 && height <= 0xFFFF); + ImFontAtlasCustomRect r; + r.Width = (unsigned short)width; + r.Height = (unsigned short)height; + r.GlyphID = id; + r.GlyphAdvanceX = advance_x; + r.GlyphOffset = offset; + r.Font = font; + CustomRects.push_back(r); + return CustomRects.Size - 1; // Return index +} + +void ImFontAtlas::CalcCustomRectUV(const ImFontAtlasCustomRect* rect, ImVec2* out_uv_min, ImVec2* out_uv_max) const +{ + IM_ASSERT(TexWidth > 0 && TexHeight > 0); // Font atlas needs to be built before we can calculate UV coordinates + IM_ASSERT(rect->IsPacked()); // Make sure the rectangle has been packed + *out_uv_min = ImVec2((float)rect->X * TexUvScale.x, (float)rect->Y * TexUvScale.y); + *out_uv_max = ImVec2((float)(rect->X + rect->Width) * TexUvScale.x, (float)(rect->Y + rect->Height) * TexUvScale.y); +} + +bool ImFontAtlas::GetMouseCursorTexData(ImGuiMouseCursor cursor_type, ImVec2* out_offset, ImVec2* out_size, ImVec2 out_uv_border[2], ImVec2 out_uv_fill[2]) +{ + if (cursor_type <= ImGuiMouseCursor_None || cursor_type >= ImGuiMouseCursor_COUNT) + return false; + if (Flags & ImFontAtlasFlags_NoMouseCursors) + return false; + + IM_ASSERT(PackIdMouseCursors != -1); + ImFontAtlasCustomRect* r = GetCustomRectByIndex(PackIdMouseCursors); + ImVec2 pos = FONT_ATLAS_DEFAULT_TEX_CURSOR_DATA[cursor_type][0] + ImVec2((float)r->X, (float)r->Y); + ImVec2 size = FONT_ATLAS_DEFAULT_TEX_CURSOR_DATA[cursor_type][1]; + *out_size = size; + *out_offset = FONT_ATLAS_DEFAULT_TEX_CURSOR_DATA[cursor_type][2]; + out_uv_border[0] = (pos) * TexUvScale; + out_uv_border[1] = (pos + size) * TexUvScale; + pos.x += FONT_ATLAS_DEFAULT_TEX_DATA_W + 1; + out_uv_fill[0] = (pos) * TexUvScale; + out_uv_fill[1] = (pos + size) * TexUvScale; + return true; +} + +bool ImFontAtlas::Build() +{ + IM_ASSERT(!Locked && "Cannot modify a locked ImFontAtlas between NewFrame() and EndFrame/Render()!"); + + // Default font is none are specified + if (ConfigData.Size == 0) + AddFontDefault(); + + // Select builder + // - Note that we do not reassign to atlas->FontBuilderIO, since it is likely to point to static data which + // may mess with some hot-reloading schemes. If you need to assign to this (for dynamic selection) AND are + // using a hot-reloading scheme that messes up static data, store your own instance of ImFontBuilderIO somewhere + // and point to it instead of pointing directly to return value of the GetBuilderXXX functions. + const ImFontBuilderIO* builder_io = FontBuilderIO; + if (builder_io == NULL) + { +#ifdef IMGUI_ENABLE_FREETYPE + builder_io = ImGuiFreeType::GetBuilderForFreeType(); +#elif defined(IMGUI_ENABLE_STB_TRUETYPE) + builder_io = ImFontAtlasGetBuilderForStbTruetype(); +#else + IM_ASSERT(0); // Invalid Build function +#endif + } + + // Build + return builder_io->FontBuilder_Build(this); +} + +void ImFontAtlasBuildMultiplyCalcLookupTable(unsigned char out_table[256], float in_brighten_factor) +{ + for (unsigned int i = 0; i < 256; i++) + { + unsigned int value = (unsigned int)(i * in_brighten_factor); + out_table[i] = value > 255 ? 255 : (value & 0xFF); + } +} + +void ImFontAtlasBuildMultiplyRectAlpha8(const unsigned char table[256], unsigned char* pixels, int x, int y, int w, int h, int stride) +{ + unsigned char* data = pixels + x + y * stride; + for (int j = h; j > 0; j--, data += stride) + for (int i = 0; i < w; i++) + data[i] = table[data[i]]; +} + +#ifdef IMGUI_ENABLE_STB_TRUETYPE +// Temporary data for one source font (multiple source fonts can be merged into one destination ImFont) +// (C++03 doesn't allow instancing ImVector<> with function-local types so we declare the type here.) +struct ImFontBuildSrcData +{ + stbtt_fontinfo FontInfo; + stbtt_pack_range PackRange; // Hold the list of codepoints to pack (essentially points to Codepoints.Data) + stbrp_rect* Rects; // Rectangle to pack. We first fill in their size and the packer will give us their position. + stbtt_packedchar* PackedChars; // Output glyphs + const ImWchar* SrcRanges; // Ranges as requested by user (user is allowed to request too much, e.g. 0x0020..0xFFFF) + int DstIndex; // Index into atlas->Fonts[] and dst_tmp_array[] + int GlyphsHighest; // Highest requested codepoint + int GlyphsCount; // Glyph count (excluding missing glyphs and glyphs already set by an earlier source font) + ImBitVector GlyphsSet; // Glyph bit map (random access, 1-bit per codepoint. This will be a maximum of 8KB) + ImVector GlyphsList; // Glyph codepoints list (flattened version of GlyphsMap) +}; + +// Temporary data for one destination ImFont* (multiple source fonts can be merged into one destination ImFont) +struct ImFontBuildDstData +{ + int SrcCount; // Number of source fonts targeting this destination font. + int GlyphsHighest; + int GlyphsCount; + ImBitVector GlyphsSet; // This is used to resolve collision when multiple sources are merged into a same destination font. +}; + +static void UnpackBitVectorToFlatIndexList(const ImBitVector* in, ImVector* out) +{ + IM_ASSERT(sizeof(in->Storage.Data[0]) == sizeof(int)); + const ImU32* it_begin = in->Storage.begin(); + const ImU32* it_end = in->Storage.end(); + for (const ImU32* it = it_begin; it < it_end; it++) + if (ImU32 entries_32 = *it) + for (ImU32 bit_n = 0; bit_n < 32; bit_n++) + if (entries_32 & ((ImU32)1 << bit_n)) + out->push_back((int)(((it - it_begin) << 5) + bit_n)); +} + +static bool ImFontAtlasBuildWithStbTruetype(ImFontAtlas* atlas) +{ + IM_ASSERT(atlas->ConfigData.Size > 0); + + ImFontAtlasBuildInit(atlas); + + // Clear atlas + atlas->TexID = (ImTextureID)NULL; + atlas->TexWidth = atlas->TexHeight = 0; + atlas->TexUvScale = ImVec2(0.0f, 0.0f); + atlas->TexUvWhitePixel = ImVec2(0.0f, 0.0f); + atlas->ClearTexData(); + + // Temporary storage for building + ImVector src_tmp_array; + ImVector dst_tmp_array; + src_tmp_array.resize(atlas->ConfigData.Size); + dst_tmp_array.resize(atlas->Fonts.Size); + memset(src_tmp_array.Data, 0, (size_t)src_tmp_array.size_in_bytes()); + memset(dst_tmp_array.Data, 0, (size_t)dst_tmp_array.size_in_bytes()); + + // 1. Initialize font loading structure, check font data validity + for (int src_i = 0; src_i < atlas->ConfigData.Size; src_i++) + { + ImFontBuildSrcData& src_tmp = src_tmp_array[src_i]; + ImFontConfig& cfg = atlas->ConfigData[src_i]; + IM_ASSERT(cfg.DstFont && (!cfg.DstFont->IsLoaded() || cfg.DstFont->ContainerAtlas == atlas)); + + // Find index from cfg.DstFont (we allow the user to set cfg.DstFont. Also it makes casual debugging nicer than when storing indices) + src_tmp.DstIndex = -1; + for (int output_i = 0; output_i < atlas->Fonts.Size && src_tmp.DstIndex == -1; output_i++) + if (cfg.DstFont == atlas->Fonts[output_i]) + src_tmp.DstIndex = output_i; + if (src_tmp.DstIndex == -1) + { + IM_ASSERT(src_tmp.DstIndex != -1); // cfg.DstFont not pointing within atlas->Fonts[] array? + return false; + } + // Initialize helper structure for font loading and verify that the TTF/OTF data is correct + const int font_offset = stbtt_GetFontOffsetForIndex((unsigned char*)cfg.FontData, cfg.FontNo); + IM_ASSERT(font_offset >= 0 && "FontData is incorrect, or FontNo cannot be found."); + if (!stbtt_InitFont(&src_tmp.FontInfo, (unsigned char*)cfg.FontData, font_offset)) + return false; + + // Measure highest codepoints + ImFontBuildDstData& dst_tmp = dst_tmp_array[src_tmp.DstIndex]; + src_tmp.SrcRanges = cfg.GlyphRanges ? cfg.GlyphRanges : atlas->GetGlyphRangesDefault(); + for (const ImWchar* src_range = src_tmp.SrcRanges; src_range[0] && src_range[1]; src_range += 2) + src_tmp.GlyphsHighest = ImMax(src_tmp.GlyphsHighest, (int)src_range[1]); + dst_tmp.SrcCount++; + dst_tmp.GlyphsHighest = ImMax(dst_tmp.GlyphsHighest, src_tmp.GlyphsHighest); + } + + // 2. For every requested codepoint, check for their presence in the font data, and handle redundancy or overlaps between source fonts to avoid unused glyphs. + int total_glyphs_count = 0; + for (int src_i = 0; src_i < src_tmp_array.Size; src_i++) + { + ImFontBuildSrcData& src_tmp = src_tmp_array[src_i]; + ImFontBuildDstData& dst_tmp = dst_tmp_array[src_tmp.DstIndex]; + src_tmp.GlyphsSet.Create(src_tmp.GlyphsHighest + 1); + if (dst_tmp.GlyphsSet.Storage.empty()) + dst_tmp.GlyphsSet.Create(dst_tmp.GlyphsHighest + 1); + + for (const ImWchar* src_range = src_tmp.SrcRanges; src_range[0] && src_range[1]; src_range += 2) + for (unsigned int codepoint = src_range[0]; codepoint <= src_range[1]; codepoint++) + { + if (dst_tmp.GlyphsSet.TestBit(codepoint)) // Don't overwrite existing glyphs. We could make this an option for MergeMode (e.g. MergeOverwrite==true) + continue; + if (!stbtt_FindGlyphIndex(&src_tmp.FontInfo, codepoint)) // It is actually in the font? + continue; + + // Add to avail set/counters + src_tmp.GlyphsCount++; + dst_tmp.GlyphsCount++; + src_tmp.GlyphsSet.SetBit(codepoint); + dst_tmp.GlyphsSet.SetBit(codepoint); + total_glyphs_count++; + } + } + + // 3. Unpack our bit map into a flat list (we now have all the Unicode points that we know are requested _and_ available _and_ not overlapping another) + for (int src_i = 0; src_i < src_tmp_array.Size; src_i++) + { + ImFontBuildSrcData& src_tmp = src_tmp_array[src_i]; + src_tmp.GlyphsList.reserve(src_tmp.GlyphsCount); + UnpackBitVectorToFlatIndexList(&src_tmp.GlyphsSet, &src_tmp.GlyphsList); + src_tmp.GlyphsSet.Clear(); + IM_ASSERT(src_tmp.GlyphsList.Size == src_tmp.GlyphsCount); + } + for (int dst_i = 0; dst_i < dst_tmp_array.Size; dst_i++) + dst_tmp_array[dst_i].GlyphsSet.Clear(); + dst_tmp_array.clear(); + + // Allocate packing character data and flag packed characters buffer as non-packed (x0=y0=x1=y1=0) + // (We technically don't need to zero-clear buf_rects, but let's do it for the sake of sanity) + ImVector buf_rects; + ImVector buf_packedchars; + buf_rects.resize(total_glyphs_count); + buf_packedchars.resize(total_glyphs_count); + memset(buf_rects.Data, 0, (size_t)buf_rects.size_in_bytes()); + memset(buf_packedchars.Data, 0, (size_t)buf_packedchars.size_in_bytes()); + + // 4. Gather glyphs sizes so we can pack them in our virtual canvas. + int total_surface = 0; + int buf_rects_out_n = 0; + int buf_packedchars_out_n = 0; + for (int src_i = 0; src_i < src_tmp_array.Size; src_i++) + { + ImFontBuildSrcData& src_tmp = src_tmp_array[src_i]; + if (src_tmp.GlyphsCount == 0) + continue; + + src_tmp.Rects = &buf_rects[buf_rects_out_n]; + src_tmp.PackedChars = &buf_packedchars[buf_packedchars_out_n]; + buf_rects_out_n += src_tmp.GlyphsCount; + buf_packedchars_out_n += src_tmp.GlyphsCount; + + // Convert our ranges in the format stb_truetype wants + ImFontConfig& cfg = atlas->ConfigData[src_i]; + src_tmp.PackRange.font_size = cfg.SizePixels; + src_tmp.PackRange.first_unicode_codepoint_in_range = 0; + src_tmp.PackRange.array_of_unicode_codepoints = src_tmp.GlyphsList.Data; + src_tmp.PackRange.num_chars = src_tmp.GlyphsList.Size; + src_tmp.PackRange.chardata_for_range = src_tmp.PackedChars; + src_tmp.PackRange.h_oversample = (unsigned char)cfg.OversampleH; + src_tmp.PackRange.v_oversample = (unsigned char)cfg.OversampleV; + + // Gather the sizes of all rectangles we will need to pack (this loop is based on stbtt_PackFontRangesGatherRects) + const float scale = (cfg.SizePixels > 0) ? stbtt_ScaleForPixelHeight(&src_tmp.FontInfo, cfg.SizePixels) : stbtt_ScaleForMappingEmToPixels(&src_tmp.FontInfo, -cfg.SizePixels); + const int padding = atlas->TexGlyphPadding; + for (int glyph_i = 0; glyph_i < src_tmp.GlyphsList.Size; glyph_i++) + { + int x0, y0, x1, y1; + const int glyph_index_in_font = stbtt_FindGlyphIndex(&src_tmp.FontInfo, src_tmp.GlyphsList[glyph_i]); + IM_ASSERT(glyph_index_in_font != 0); + stbtt_GetGlyphBitmapBoxSubpixel(&src_tmp.FontInfo, glyph_index_in_font, scale * cfg.OversampleH, scale * cfg.OversampleV, 0, 0, &x0, &y0, &x1, &y1); + src_tmp.Rects[glyph_i].w = (stbrp_coord)(x1 - x0 + padding + cfg.OversampleH - 1); + src_tmp.Rects[glyph_i].h = (stbrp_coord)(y1 - y0 + padding + cfg.OversampleV - 1); + total_surface += src_tmp.Rects[glyph_i].w * src_tmp.Rects[glyph_i].h; + } + } + + // We need a width for the skyline algorithm, any width! + // The exact width doesn't really matter much, but some API/GPU have texture size limitations and increasing width can decrease height. + // User can override TexDesiredWidth and TexGlyphPadding if they wish, otherwise we use a simple heuristic to select the width based on expected surface. + const int surface_sqrt = (int)ImSqrt((float)total_surface) + 1; + atlas->TexHeight = 0; + if (atlas->TexDesiredWidth > 0) + atlas->TexWidth = atlas->TexDesiredWidth; + else + atlas->TexWidth = (surface_sqrt >= 4096 * 0.7f) ? 4096 : (surface_sqrt >= 2048 * 0.7f) ? 2048 : (surface_sqrt >= 1024 * 0.7f) ? 1024 : 512; + + // 5. Start packing + // Pack our extra data rectangles first, so it will be on the upper-left corner of our texture (UV will have small values). + const int TEX_HEIGHT_MAX = 1024 * 32; + stbtt_pack_context spc = {}; + stbtt_PackBegin(&spc, NULL, atlas->TexWidth, TEX_HEIGHT_MAX, 0, atlas->TexGlyphPadding, NULL); + ImFontAtlasBuildPackCustomRects(atlas, spc.pack_info); + + // 6. Pack each source font. No rendering yet, we are working with rectangles in an infinitely tall texture at this point. + for (int src_i = 0; src_i < src_tmp_array.Size; src_i++) + { + ImFontBuildSrcData& src_tmp = src_tmp_array[src_i]; + if (src_tmp.GlyphsCount == 0) + continue; + + stbrp_pack_rects((stbrp_context*)spc.pack_info, src_tmp.Rects, src_tmp.GlyphsCount); + + // Extend texture height and mark missing glyphs as non-packed so we won't render them. + // FIXME: We are not handling packing failure here (would happen if we got off TEX_HEIGHT_MAX or if a single if larger than TexWidth?) + for (int glyph_i = 0; glyph_i < src_tmp.GlyphsCount; glyph_i++) + if (src_tmp.Rects[glyph_i].was_packed) + atlas->TexHeight = ImMax(atlas->TexHeight, src_tmp.Rects[glyph_i].y + src_tmp.Rects[glyph_i].h); + } + + // 7. Allocate texture + atlas->TexHeight = (atlas->Flags & ImFontAtlasFlags_NoPowerOfTwoHeight) ? (atlas->TexHeight + 1) : ImUpperPowerOfTwo(atlas->TexHeight); + atlas->TexUvScale = ImVec2(1.0f / atlas->TexWidth, 1.0f / atlas->TexHeight); + atlas->TexPixelsAlpha8 = (unsigned char*)IM_ALLOC(atlas->TexWidth * atlas->TexHeight); + memset(atlas->TexPixelsAlpha8, 0, atlas->TexWidth * atlas->TexHeight); + spc.pixels = atlas->TexPixelsAlpha8; + spc.height = atlas->TexHeight; + + // 8. Render/rasterize font characters into the texture + for (int src_i = 0; src_i < src_tmp_array.Size; src_i++) + { + ImFontConfig& cfg = atlas->ConfigData[src_i]; + ImFontBuildSrcData& src_tmp = src_tmp_array[src_i]; + if (src_tmp.GlyphsCount == 0) + continue; + + stbtt_PackFontRangesRenderIntoRects(&spc, &src_tmp.FontInfo, &src_tmp.PackRange, 1, src_tmp.Rects); + + // Apply multiply operator + if (cfg.RasterizerMultiply != 1.0f) + { + unsigned char multiply_table[256]; + ImFontAtlasBuildMultiplyCalcLookupTable(multiply_table, cfg.RasterizerMultiply); + stbrp_rect* r = &src_tmp.Rects[0]; + for (int glyph_i = 0; glyph_i < src_tmp.GlyphsCount; glyph_i++, r++) + if (r->was_packed) + ImFontAtlasBuildMultiplyRectAlpha8(multiply_table, atlas->TexPixelsAlpha8, r->x, r->y, r->w, r->h, atlas->TexWidth * 1); + } + src_tmp.Rects = NULL; + } + + // End packing + stbtt_PackEnd(&spc); + buf_rects.clear(); + + // 9. Setup ImFont and glyphs for runtime + for (int src_i = 0; src_i < src_tmp_array.Size; src_i++) + { + ImFontBuildSrcData& src_tmp = src_tmp_array[src_i]; + if (src_tmp.GlyphsCount == 0) + continue; + + // When merging fonts with MergeMode=true: + // - We can have multiple input fonts writing into a same destination font. + // - dst_font->ConfigData is != from cfg which is our source configuration. + ImFontConfig& cfg = atlas->ConfigData[src_i]; + ImFont* dst_font = cfg.DstFont; + + const float font_scale = stbtt_ScaleForPixelHeight(&src_tmp.FontInfo, cfg.SizePixels); + int unscaled_ascent, unscaled_descent, unscaled_line_gap; + stbtt_GetFontVMetrics(&src_tmp.FontInfo, &unscaled_ascent, &unscaled_descent, &unscaled_line_gap); + + const float ascent = ImFloor(unscaled_ascent * font_scale + ((unscaled_ascent > 0.0f) ? +1 : -1)); + const float descent = ImFloor(unscaled_descent * font_scale + ((unscaled_descent > 0.0f) ? +1 : -1)); + ImFontAtlasBuildSetupFont(atlas, dst_font, &cfg, ascent, descent); + const float font_off_x = cfg.GlyphOffset.x; + const float font_off_y = cfg.GlyphOffset.y + IM_ROUND(dst_font->Ascent); + + for (int glyph_i = 0; glyph_i < src_tmp.GlyphsCount; glyph_i++) + { + // Register glyph + const int codepoint = src_tmp.GlyphsList[glyph_i]; + const stbtt_packedchar& pc = src_tmp.PackedChars[glyph_i]; + stbtt_aligned_quad q; + float unused_x = 0.0f, unused_y = 0.0f; + stbtt_GetPackedQuad(src_tmp.PackedChars, atlas->TexWidth, atlas->TexHeight, glyph_i, &unused_x, &unused_y, &q, 0); + dst_font->AddGlyph(&cfg, (ImWchar)codepoint, q.x0 + font_off_x, q.y0 + font_off_y, q.x1 + font_off_x, q.y1 + font_off_y, q.s0, q.t0, q.s1, q.t1, pc.xadvance); + } + } + + // Cleanup + src_tmp_array.clear_destruct(); + + ImFontAtlasBuildFinish(atlas); + return true; +} + +const ImFontBuilderIO* ImFontAtlasGetBuilderForStbTruetype() +{ + static ImFontBuilderIO io; + io.FontBuilder_Build = ImFontAtlasBuildWithStbTruetype; + return &io; +} + +#endif // IMGUI_ENABLE_STB_TRUETYPE + +void ImFontAtlasBuildSetupFont(ImFontAtlas* atlas, ImFont* font, ImFontConfig* font_config, float ascent, float descent) +{ + if (!font_config->MergeMode) + { + font->ClearOutputData(); + font->FontSize = font_config->SizePixels; + font->ConfigData = font_config; + font->ConfigDataCount = 0; + font->ContainerAtlas = atlas; + font->Ascent = ascent; + font->Descent = descent; + } + font->ConfigDataCount++; +} + +void ImFontAtlasBuildPackCustomRects(ImFontAtlas* atlas, void* stbrp_context_opaque) +{ + stbrp_context* pack_context = (stbrp_context*)stbrp_context_opaque; + IM_ASSERT(pack_context != NULL); + + ImVector& user_rects = atlas->CustomRects; + IM_ASSERT(user_rects.Size >= 1); // We expect at least the default custom rects to be registered, else something went wrong. + + ImVector pack_rects; + pack_rects.resize(user_rects.Size); + memset(pack_rects.Data, 0, (size_t)pack_rects.size_in_bytes()); + for (int i = 0; i < user_rects.Size; i++) + { + pack_rects[i].w = user_rects[i].Width; + pack_rects[i].h = user_rects[i].Height; + } + stbrp_pack_rects(pack_context, &pack_rects[0], pack_rects.Size); + for (int i = 0; i < pack_rects.Size; i++) + if (pack_rects[i].was_packed) + { + user_rects[i].X = pack_rects[i].x; + user_rects[i].Y = pack_rects[i].y; + IM_ASSERT(pack_rects[i].w == user_rects[i].Width && pack_rects[i].h == user_rects[i].Height); + atlas->TexHeight = ImMax(atlas->TexHeight, pack_rects[i].y + pack_rects[i].h); + } +} + +void ImFontAtlasBuildRender8bppRectFromString(ImFontAtlas* atlas, int x, int y, int w, int h, const char* in_str, char in_marker_char, unsigned char in_marker_pixel_value) +{ + IM_ASSERT(x >= 0 && x + w <= atlas->TexWidth); + IM_ASSERT(y >= 0 && y + h <= atlas->TexHeight); + unsigned char* out_pixel = atlas->TexPixelsAlpha8 + x + (y * atlas->TexWidth); + for (int off_y = 0; off_y < h; off_y++, out_pixel += atlas->TexWidth, in_str += w) + for (int off_x = 0; off_x < w; off_x++) + out_pixel[off_x] = (in_str[off_x] == in_marker_char) ? in_marker_pixel_value : 0x00; +} + +void ImFontAtlasBuildRender32bppRectFromString(ImFontAtlas* atlas, int x, int y, int w, int h, const char* in_str, char in_marker_char, unsigned int in_marker_pixel_value) +{ + IM_ASSERT(x >= 0 && x + w <= atlas->TexWidth); + IM_ASSERT(y >= 0 && y + h <= atlas->TexHeight); + unsigned int* out_pixel = atlas->TexPixelsRGBA32 + x + (y * atlas->TexWidth); + for (int off_y = 0; off_y < h; off_y++, out_pixel += atlas->TexWidth, in_str += w) + for (int off_x = 0; off_x < w; off_x++) + out_pixel[off_x] = (in_str[off_x] == in_marker_char) ? in_marker_pixel_value : IM_COL32_BLACK_TRANS; +} + +static void ImFontAtlasBuildRenderDefaultTexData(ImFontAtlas* atlas) +{ + ImFontAtlasCustomRect* r = atlas->GetCustomRectByIndex(atlas->PackIdMouseCursors); + IM_ASSERT(r->IsPacked()); + + const int w = atlas->TexWidth; + if (!(atlas->Flags & ImFontAtlasFlags_NoMouseCursors)) + { + // Render/copy pixels + IM_ASSERT(r->Width == FONT_ATLAS_DEFAULT_TEX_DATA_W * 2 + 1 && r->Height == FONT_ATLAS_DEFAULT_TEX_DATA_H); + const int x_for_white = r->X; + const int x_for_black = r->X + FONT_ATLAS_DEFAULT_TEX_DATA_W + 1; + if (atlas->TexPixelsAlpha8 != NULL) + { + ImFontAtlasBuildRender8bppRectFromString(atlas, x_for_white, r->Y, FONT_ATLAS_DEFAULT_TEX_DATA_W, FONT_ATLAS_DEFAULT_TEX_DATA_H, FONT_ATLAS_DEFAULT_TEX_DATA_PIXELS, '.', 0xFF); + ImFontAtlasBuildRender8bppRectFromString(atlas, x_for_black, r->Y, FONT_ATLAS_DEFAULT_TEX_DATA_W, FONT_ATLAS_DEFAULT_TEX_DATA_H, FONT_ATLAS_DEFAULT_TEX_DATA_PIXELS, 'X', 0xFF); + } + else + { + ImFontAtlasBuildRender32bppRectFromString(atlas, x_for_white, r->Y, FONT_ATLAS_DEFAULT_TEX_DATA_W, FONT_ATLAS_DEFAULT_TEX_DATA_H, FONT_ATLAS_DEFAULT_TEX_DATA_PIXELS, '.', IM_COL32_WHITE); + ImFontAtlasBuildRender32bppRectFromString(atlas, x_for_black, r->Y, FONT_ATLAS_DEFAULT_TEX_DATA_W, FONT_ATLAS_DEFAULT_TEX_DATA_H, FONT_ATLAS_DEFAULT_TEX_DATA_PIXELS, 'X', IM_COL32_WHITE); + } + } + else + { + // Render 4 white pixels + IM_ASSERT(r->Width == 2 && r->Height == 2); + const int offset = (int)r->X + (int)r->Y * w; + if (atlas->TexPixelsAlpha8 != NULL) + { + atlas->TexPixelsAlpha8[offset] = atlas->TexPixelsAlpha8[offset + 1] = atlas->TexPixelsAlpha8[offset + w] = atlas->TexPixelsAlpha8[offset + w + 1] = 0xFF; + } + else + { + atlas->TexPixelsRGBA32[offset] = atlas->TexPixelsRGBA32[offset + 1] = atlas->TexPixelsRGBA32[offset + w] = atlas->TexPixelsRGBA32[offset + w + 1] = IM_COL32_WHITE; + } + } + atlas->TexUvWhitePixel = ImVec2((r->X + 0.5f) * atlas->TexUvScale.x, (r->Y + 0.5f) * atlas->TexUvScale.y); +} + +static void ImFontAtlasBuildRenderLinesTexData(ImFontAtlas* atlas) +{ + if (atlas->Flags & ImFontAtlasFlags_NoBakedLines) + return; + + // This generates a triangular shape in the texture, with the various line widths stacked on top of each other to allow interpolation between them + ImFontAtlasCustomRect* r = atlas->GetCustomRectByIndex(atlas->PackIdLines); + IM_ASSERT(r->IsPacked()); + for (unsigned int n = 0; n < IM_DRAWLIST_TEX_LINES_WIDTH_MAX + 1; n++) // +1 because of the zero-width row + { + // Each line consists of at least two empty pixels at the ends, with a line of solid pixels in the middle + unsigned int y = n; + unsigned int line_width = n; + unsigned int pad_left = (r->Width - line_width) / 2; + unsigned int pad_right = r->Width - (pad_left + line_width); + + // Write each slice + IM_ASSERT(pad_left + line_width + pad_right == r->Width && y < r->Height); // Make sure we're inside the texture bounds before we start writing pixels + if (atlas->TexPixelsAlpha8 != NULL) + { + unsigned char* write_ptr = &atlas->TexPixelsAlpha8[r->X + ((r->Y + y) * atlas->TexWidth)]; + for (unsigned int i = 0; i < pad_left; i++) + *(write_ptr + i) = 0x00; + + for (unsigned int i = 0; i < line_width; i++) + *(write_ptr + pad_left + i) = 0xFF; + + for (unsigned int i = 0; i < pad_right; i++) + *(write_ptr + pad_left + line_width + i) = 0x00; + } + else + { + unsigned int* write_ptr = &atlas->TexPixelsRGBA32[r->X + ((r->Y + y) * atlas->TexWidth)]; + for (unsigned int i = 0; i < pad_left; i++) + *(write_ptr + i) = IM_COL32_BLACK_TRANS; + + for (unsigned int i = 0; i < line_width; i++) + *(write_ptr + pad_left + i) = IM_COL32_WHITE; + + for (unsigned int i = 0; i < pad_right; i++) + *(write_ptr + pad_left + line_width + i) = IM_COL32_BLACK_TRANS; + } + + // Calculate UVs for this line + ImVec2 uv0 = ImVec2((float)(r->X + pad_left - 1), (float)(r->Y + y)) * atlas->TexUvScale; + ImVec2 uv1 = ImVec2((float)(r->X + pad_left + line_width + 1), (float)(r->Y + y + 1)) * atlas->TexUvScale; + float half_v = (uv0.y + uv1.y) * 0.5f; // Calculate a constant V in the middle of the row to avoid sampling artifacts + atlas->TexUvLines[n] = ImVec4(uv0.x, half_v, uv1.x, half_v); + } +} + +// Note: this is called / shared by both the stb_truetype and the FreeType builder +void ImFontAtlasBuildInit(ImFontAtlas* atlas) +{ + // Register texture region for mouse cursors or standard white pixels + if (atlas->PackIdMouseCursors < 0) + { + if (!(atlas->Flags & ImFontAtlasFlags_NoMouseCursors)) + atlas->PackIdMouseCursors = atlas->AddCustomRectRegular(FONT_ATLAS_DEFAULT_TEX_DATA_W * 2 + 1, FONT_ATLAS_DEFAULT_TEX_DATA_H); + else + atlas->PackIdMouseCursors = atlas->AddCustomRectRegular(2, 2); + } + + // Register texture region for thick lines + // The +2 here is to give space for the end caps, whilst height +1 is to accommodate the fact we have a zero-width row + if (atlas->PackIdLines < 0) + { + if (!(atlas->Flags & ImFontAtlasFlags_NoBakedLines)) + atlas->PackIdLines = atlas->AddCustomRectRegular(IM_DRAWLIST_TEX_LINES_WIDTH_MAX + 2, IM_DRAWLIST_TEX_LINES_WIDTH_MAX + 1); + } +} + +// This is called/shared by both the stb_truetype and the FreeType builder. +void ImFontAtlasBuildFinish(ImFontAtlas* atlas) +{ + // Render into our custom data blocks + IM_ASSERT(atlas->TexPixelsAlpha8 != NULL || atlas->TexPixelsRGBA32 != NULL); + ImFontAtlasBuildRenderDefaultTexData(atlas); + ImFontAtlasBuildRenderLinesTexData(atlas); + + // Register custom rectangle glyphs + for (int i = 0; i < atlas->CustomRects.Size; i++) + { + const ImFontAtlasCustomRect* r = &atlas->CustomRects[i]; + if (r->Font == NULL || r->GlyphID == 0) + continue; + + // Will ignore ImFontConfig settings: GlyphMinAdvanceX, GlyphMinAdvanceY, GlyphExtraSpacing, PixelSnapH + IM_ASSERT(r->Font->ContainerAtlas == atlas); + ImVec2 uv0, uv1; + atlas->CalcCustomRectUV(r, &uv0, &uv1); + r->Font->AddGlyph(NULL, (ImWchar)r->GlyphID, r->GlyphOffset.x, r->GlyphOffset.y, r->GlyphOffset.x + r->Width, r->GlyphOffset.y + r->Height, uv0.x, uv0.y, uv1.x, uv1.y, r->GlyphAdvanceX); + } + + // Build all fonts lookup tables + for (int i = 0; i < atlas->Fonts.Size; i++) + if (atlas->Fonts[i]->DirtyLookupTables) + atlas->Fonts[i]->BuildLookupTable(); + + atlas->TexReady = true; +} + +// Retrieve list of range (2 int per range, values are inclusive) +const ImWchar* ImFontAtlas::GetGlyphRangesDefault() +{ + static const ImWchar ranges[] = + { + 0x0020, 0x00FF, // Basic Latin + Latin Supplement + 0, + }; + return &ranges[0]; +} + +const ImWchar* ImFontAtlas::GetGlyphRangesKorean() +{ + static const ImWchar ranges[] = + { + 0x0020, 0x00FF, // Basic Latin + Latin Supplement + 0x3131, 0x3163, // Korean alphabets + 0xAC00, 0xD7A3, // Korean characters + 0xFFFD, 0xFFFD, // Invalid + 0, + }; + return &ranges[0]; +} + +const ImWchar* ImFontAtlas::GetGlyphRangesChineseFull() +{ + static const ImWchar ranges[] = + { + 0x0020, 0x00FF, // Basic Latin + Latin Supplement + 0x2000, 0x206F, // General Punctuation + 0x3000, 0x30FF, // CJK Symbols and Punctuations, Hiragana, Katakana + 0x31F0, 0x31FF, // Katakana Phonetic Extensions + 0xFF00, 0xFFEF, // Half-width characters + 0xFFFD, 0xFFFD, // Invalid + 0x4e00, 0x9FAF, // CJK Ideograms + 0, + }; + return &ranges[0]; +} + +static void UnpackAccumulativeOffsetsIntoRanges(int base_codepoint, const short* accumulative_offsets, int accumulative_offsets_count, ImWchar* out_ranges) +{ + for (int n = 0; n < accumulative_offsets_count; n++, out_ranges += 2) + { + out_ranges[0] = out_ranges[1] = (ImWchar)(base_codepoint + accumulative_offsets[n]); + base_codepoint += accumulative_offsets[n]; + } + out_ranges[0] = 0; +} + +//------------------------------------------------------------------------- +// [SECTION] ImFontAtlas glyph ranges helpers +//------------------------------------------------------------------------- + +const ImWchar* ImFontAtlas::GetGlyphRangesChineseSimplifiedCommon() +{ + // Store 2500 regularly used characters for Simplified Chinese. + // Sourced from https://zh.wiktionary.org/wiki/%E9%99%84%E5%BD%95:%E7%8E%B0%E4%BB%A3%E6%B1%89%E8%AF%AD%E5%B8%B8%E7%94%A8%E5%AD%97%E8%A1%A8 + // This table covers 97.97% of all characters used during the month in July, 1987. + // You can use ImFontGlyphRangesBuilder to create your own ranges derived from this, by merging existing ranges or adding new characters. + // (Stored as accumulative offsets from the initial unicode codepoint 0x4E00. This encoding is designed to helps us compact the source code size.) + static const short accumulative_offsets_from_0x4E00[] = + { + 0,1,2,4,1,1,1,1,2,1,3,2,1,2,2,1,1,1,1,1,5,2,1,2,3,3,3,2,2,4,1,1,1,2,1,5,2,3,1,2,1,2,1,1,2,1,1,2,2,1,4,1,1,1,1,5,10,1,2,19,2,1,2,1,2,1,2,1,2, + 1,5,1,6,3,2,1,2,2,1,1,1,4,8,5,1,1,4,1,1,3,1,2,1,5,1,2,1,1,1,10,1,1,5,2,4,6,1,4,2,2,2,12,2,1,1,6,1,1,1,4,1,1,4,6,5,1,4,2,2,4,10,7,1,1,4,2,4, + 2,1,4,3,6,10,12,5,7,2,14,2,9,1,1,6,7,10,4,7,13,1,5,4,8,4,1,1,2,28,5,6,1,1,5,2,5,20,2,2,9,8,11,2,9,17,1,8,6,8,27,4,6,9,20,11,27,6,68,2,2,1,1, + 1,2,1,2,2,7,6,11,3,3,1,1,3,1,2,1,1,1,1,1,3,1,1,8,3,4,1,5,7,2,1,4,4,8,4,2,1,2,1,1,4,5,6,3,6,2,12,3,1,3,9,2,4,3,4,1,5,3,3,1,3,7,1,5,1,1,1,1,2, + 3,4,5,2,3,2,6,1,1,2,1,7,1,7,3,4,5,15,2,2,1,5,3,22,19,2,1,1,1,1,2,5,1,1,1,6,1,1,12,8,2,9,18,22,4,1,1,5,1,16,1,2,7,10,15,1,1,6,2,4,1,2,4,1,6, + 1,1,3,2,4,1,6,4,5,1,2,1,1,2,1,10,3,1,3,2,1,9,3,2,5,7,2,19,4,3,6,1,1,1,1,1,4,3,2,1,1,1,2,5,3,1,1,1,2,2,1,1,2,1,1,2,1,3,1,1,1,3,7,1,4,1,1,2,1, + 1,2,1,2,4,4,3,8,1,1,1,2,1,3,5,1,3,1,3,4,6,2,2,14,4,6,6,11,9,1,15,3,1,28,5,2,5,5,3,1,3,4,5,4,6,14,3,2,3,5,21,2,7,20,10,1,2,19,2,4,28,28,2,3, + 2,1,14,4,1,26,28,42,12,40,3,52,79,5,14,17,3,2,2,11,3,4,6,3,1,8,2,23,4,5,8,10,4,2,7,3,5,1,1,6,3,1,2,2,2,5,28,1,1,7,7,20,5,3,29,3,17,26,1,8,4, + 27,3,6,11,23,5,3,4,6,13,24,16,6,5,10,25,35,7,3,2,3,3,14,3,6,2,6,1,4,2,3,8,2,1,1,3,3,3,4,1,1,13,2,2,4,5,2,1,14,14,1,2,2,1,4,5,2,3,1,14,3,12, + 3,17,2,16,5,1,2,1,8,9,3,19,4,2,2,4,17,25,21,20,28,75,1,10,29,103,4,1,2,1,1,4,2,4,1,2,3,24,2,2,2,1,1,2,1,3,8,1,1,1,2,1,1,3,1,1,1,6,1,5,3,1,1, + 1,3,4,1,1,5,2,1,5,6,13,9,16,1,1,1,1,3,2,3,2,4,5,2,5,2,2,3,7,13,7,2,2,1,1,1,1,2,3,3,2,1,6,4,9,2,1,14,2,14,2,1,18,3,4,14,4,11,41,15,23,15,23, + 176,1,3,4,1,1,1,1,5,3,1,2,3,7,3,1,1,2,1,2,4,4,6,2,4,1,9,7,1,10,5,8,16,29,1,1,2,2,3,1,3,5,2,4,5,4,1,1,2,2,3,3,7,1,6,10,1,17,1,44,4,6,2,1,1,6, + 5,4,2,10,1,6,9,2,8,1,24,1,2,13,7,8,8,2,1,4,1,3,1,3,3,5,2,5,10,9,4,9,12,2,1,6,1,10,1,1,7,7,4,10,8,3,1,13,4,3,1,6,1,3,5,2,1,2,17,16,5,2,16,6, + 1,4,2,1,3,3,6,8,5,11,11,1,3,3,2,4,6,10,9,5,7,4,7,4,7,1,1,4,2,1,3,6,8,7,1,6,11,5,5,3,24,9,4,2,7,13,5,1,8,82,16,61,1,1,1,4,2,2,16,10,3,8,1,1, + 6,4,2,1,3,1,1,1,4,3,8,4,2,2,1,1,1,1,1,6,3,5,1,1,4,6,9,2,1,1,1,2,1,7,2,1,6,1,5,4,4,3,1,8,1,3,3,1,3,2,2,2,2,3,1,6,1,2,1,2,1,3,7,1,8,2,1,2,1,5, + 2,5,3,5,10,1,2,1,1,3,2,5,11,3,9,3,5,1,1,5,9,1,2,1,5,7,9,9,8,1,3,3,3,6,8,2,3,2,1,1,32,6,1,2,15,9,3,7,13,1,3,10,13,2,14,1,13,10,2,1,3,10,4,15, + 2,15,15,10,1,3,9,6,9,32,25,26,47,7,3,2,3,1,6,3,4,3,2,8,5,4,1,9,4,2,2,19,10,6,2,3,8,1,2,2,4,2,1,9,4,4,4,6,4,8,9,2,3,1,1,1,1,3,5,5,1,3,8,4,6, + 2,1,4,12,1,5,3,7,13,2,5,8,1,6,1,2,5,14,6,1,5,2,4,8,15,5,1,23,6,62,2,10,1,1,8,1,2,2,10,4,2,2,9,2,1,1,3,2,3,1,5,3,3,2,1,3,8,1,1,1,11,3,1,1,4, + 3,7,1,14,1,2,3,12,5,2,5,1,6,7,5,7,14,11,1,3,1,8,9,12,2,1,11,8,4,4,2,6,10,9,13,1,1,3,1,5,1,3,2,4,4,1,18,2,3,14,11,4,29,4,2,7,1,3,13,9,2,2,5, + 3,5,20,7,16,8,5,72,34,6,4,22,12,12,28,45,36,9,7,39,9,191,1,1,1,4,11,8,4,9,2,3,22,1,1,1,1,4,17,1,7,7,1,11,31,10,2,4,8,2,3,2,1,4,2,16,4,32,2, + 3,19,13,4,9,1,5,2,14,8,1,1,3,6,19,6,5,1,16,6,2,10,8,5,1,2,3,1,5,5,1,11,6,6,1,3,3,2,6,3,8,1,1,4,10,7,5,7,7,5,8,9,2,1,3,4,1,1,3,1,3,3,2,6,16, + 1,4,6,3,1,10,6,1,3,15,2,9,2,10,25,13,9,16,6,2,2,10,11,4,3,9,1,2,6,6,5,4,30,40,1,10,7,12,14,33,6,3,6,7,3,1,3,1,11,14,4,9,5,12,11,49,18,51,31, + 140,31,2,2,1,5,1,8,1,10,1,4,4,3,24,1,10,1,3,6,6,16,3,4,5,2,1,4,2,57,10,6,22,2,22,3,7,22,6,10,11,36,18,16,33,36,2,5,5,1,1,1,4,10,1,4,13,2,7, + 5,2,9,3,4,1,7,43,3,7,3,9,14,7,9,1,11,1,1,3,7,4,18,13,1,14,1,3,6,10,73,2,2,30,6,1,11,18,19,13,22,3,46,42,37,89,7,3,16,34,2,2,3,9,1,7,1,1,1,2, + 2,4,10,7,3,10,3,9,5,28,9,2,6,13,7,3,1,3,10,2,7,2,11,3,6,21,54,85,2,1,4,2,2,1,39,3,21,2,2,5,1,1,1,4,1,1,3,4,15,1,3,2,4,4,2,3,8,2,20,1,8,7,13, + 4,1,26,6,2,9,34,4,21,52,10,4,4,1,5,12,2,11,1,7,2,30,12,44,2,30,1,1,3,6,16,9,17,39,82,2,2,24,7,1,7,3,16,9,14,44,2,1,2,1,2,3,5,2,4,1,6,7,5,3, + 2,6,1,11,5,11,2,1,18,19,8,1,3,24,29,2,1,3,5,2,2,1,13,6,5,1,46,11,3,5,1,1,5,8,2,10,6,12,6,3,7,11,2,4,16,13,2,5,1,1,2,2,5,2,28,5,2,23,10,8,4, + 4,22,39,95,38,8,14,9,5,1,13,5,4,3,13,12,11,1,9,1,27,37,2,5,4,4,63,211,95,2,2,2,1,3,5,2,1,1,2,2,1,1,1,3,2,4,1,2,1,1,5,2,2,1,1,2,3,1,3,1,1,1, + 3,1,4,2,1,3,6,1,1,3,7,15,5,3,2,5,3,9,11,4,2,22,1,6,3,8,7,1,4,28,4,16,3,3,25,4,4,27,27,1,4,1,2,2,7,1,3,5,2,28,8,2,14,1,8,6,16,25,3,3,3,14,3, + 3,1,1,2,1,4,6,3,8,4,1,1,1,2,3,6,10,6,2,3,18,3,2,5,5,4,3,1,5,2,5,4,23,7,6,12,6,4,17,11,9,5,1,1,10,5,12,1,1,11,26,33,7,3,6,1,17,7,1,5,12,1,11, + 2,4,1,8,14,17,23,1,2,1,7,8,16,11,9,6,5,2,6,4,16,2,8,14,1,11,8,9,1,1,1,9,25,4,11,19,7,2,15,2,12,8,52,7,5,19,2,16,4,36,8,1,16,8,24,26,4,6,2,9, + 5,4,36,3,28,12,25,15,37,27,17,12,59,38,5,32,127,1,2,9,17,14,4,1,2,1,1,8,11,50,4,14,2,19,16,4,17,5,4,5,26,12,45,2,23,45,104,30,12,8,3,10,2,2, + 3,3,1,4,20,7,2,9,6,15,2,20,1,3,16,4,11,15,6,134,2,5,59,1,2,2,2,1,9,17,3,26,137,10,211,59,1,2,4,1,4,1,1,1,2,6,2,3,1,1,2,3,2,3,1,3,4,4,2,3,3, + 1,4,3,1,7,2,2,3,1,2,1,3,3,3,2,2,3,2,1,3,14,6,1,3,2,9,6,15,27,9,34,145,1,1,2,1,1,1,1,2,1,1,1,1,2,2,2,3,1,2,1,1,1,2,3,5,8,3,5,2,4,1,3,2,2,2,12, + 4,1,1,1,10,4,5,1,20,4,16,1,15,9,5,12,2,9,2,5,4,2,26,19,7,1,26,4,30,12,15,42,1,6,8,172,1,1,4,2,1,1,11,2,2,4,2,1,2,1,10,8,1,2,1,4,5,1,2,5,1,8, + 4,1,3,4,2,1,6,2,1,3,4,1,2,1,1,1,1,12,5,7,2,4,3,1,1,1,3,3,6,1,2,2,3,3,3,2,1,2,12,14,11,6,6,4,12,2,8,1,7,10,1,35,7,4,13,15,4,3,23,21,28,52,5, + 26,5,6,1,7,10,2,7,53,3,2,1,1,1,2,163,532,1,10,11,1,3,3,4,8,2,8,6,2,2,23,22,4,2,2,4,2,1,3,1,3,3,5,9,8,2,1,2,8,1,10,2,12,21,20,15,105,2,3,1,1, + 3,2,3,1,1,2,5,1,4,15,11,19,1,1,1,1,5,4,5,1,1,2,5,3,5,12,1,2,5,1,11,1,1,15,9,1,4,5,3,26,8,2,1,3,1,1,15,19,2,12,1,2,5,2,7,2,19,2,20,6,26,7,5, + 2,2,7,34,21,13,70,2,128,1,1,2,1,1,2,1,1,3,2,2,2,15,1,4,1,3,4,42,10,6,1,49,85,8,1,2,1,1,4,4,2,3,6,1,5,7,4,3,211,4,1,2,1,2,5,1,2,4,2,2,6,5,6, + 10,3,4,48,100,6,2,16,296,5,27,387,2,2,3,7,16,8,5,38,15,39,21,9,10,3,7,59,13,27,21,47,5,21,6 + }; + static ImWchar base_ranges[] = // not zero-terminated + { + 0x0020, 0x00FF, // Basic Latin + Latin Supplement + 0x2000, 0x206F, // General Punctuation + 0x3000, 0x30FF, // CJK Symbols and Punctuations, Hiragana, Katakana + 0x31F0, 0x31FF, // Katakana Phonetic Extensions + 0xFF00, 0xFFEF, // Half-width characters + 0xFFFD, 0xFFFD // Invalid + }; + static ImWchar full_ranges[IM_ARRAYSIZE(base_ranges) + IM_ARRAYSIZE(accumulative_offsets_from_0x4E00) * 2 + 1] = { 0 }; + if (!full_ranges[0]) + { + memcpy(full_ranges, base_ranges, sizeof(base_ranges)); + UnpackAccumulativeOffsetsIntoRanges(0x4E00, accumulative_offsets_from_0x4E00, IM_ARRAYSIZE(accumulative_offsets_from_0x4E00), full_ranges + IM_ARRAYSIZE(base_ranges)); + } + return &full_ranges[0]; +} + +const ImWchar* ImFontAtlas::GetGlyphRangesJapanese() +{ + // 2999 ideograms code points for Japanese + // - 2136 Joyo (meaning "for regular use" or "for common use") Kanji code points + // - 863 Jinmeiyo (meaning "for personal name") Kanji code points + // - Sourced from the character information database of the Information-technology Promotion Agency, Japan + // - https://mojikiban.ipa.go.jp/mji/ + // - Available under the terms of the Creative Commons Attribution-ShareAlike 2.1 Japan (CC BY-SA 2.1 JP). + // - https://creativecommons.org/licenses/by-sa/2.1/jp/deed.en + // - https://creativecommons.org/licenses/by-sa/2.1/jp/legalcode + // - You can generate this code by the script at: + // - https://github.com/vaiorabbit/everyday_use_kanji + // - References: + // - List of Joyo Kanji + // - (Official list by the Agency for Cultural Affairs) https://www.bunka.go.jp/kokugo_nihongo/sisaku/joho/joho/kakuki/14/tosin02/index.html + // - (Wikipedia) https://en.wikipedia.org/wiki/List_of_j%C5%8Dy%C5%8D_kanji + // - List of Jinmeiyo Kanji + // - (Official list by the Ministry of Justice) http://www.moj.go.jp/MINJI/minji86.html + // - (Wikipedia) https://en.wikipedia.org/wiki/Jinmeiy%C5%8D_kanji + // - Missing 1 Joyo Kanji: U+20B9F (Kun'yomi: Shikaru, On'yomi: Shitsu,shichi), see https://github.com/ocornut/imgui/pull/3627 for details. + // You can use ImFontGlyphRangesBuilder to create your own ranges derived from this, by merging existing ranges or adding new characters. + // (Stored as accumulative offsets from the initial unicode codepoint 0x4E00. This encoding is designed to helps us compact the source code size.) + static const short accumulative_offsets_from_0x4E00[] = + { + 0,1,2,4,1,1,1,1,2,1,3,3,2,2,1,5,3,5,7,5,6,1,2,1,7,2,6,3,1,8,1,1,4,1,1,18,2,11,2,6,2,1,2,1,5,1,2,1,3,1,2,1,2,3,3,1,1,2,3,1,1,1,12,7,9,1,4,5,1, + 1,2,1,10,1,1,9,2,2,4,5,6,9,3,1,1,1,1,9,3,18,5,2,2,2,2,1,6,3,7,1,1,1,1,2,2,4,2,1,23,2,10,4,3,5,2,4,10,2,4,13,1,6,1,9,3,1,1,6,6,7,6,3,1,2,11,3, + 2,2,3,2,15,2,2,5,4,3,6,4,1,2,5,2,12,16,6,13,9,13,2,1,1,7,16,4,7,1,19,1,5,1,2,2,7,7,8,2,6,5,4,9,18,7,4,5,9,13,11,8,15,2,1,1,1,2,1,2,2,1,2,2,8, + 2,9,3,3,1,1,4,4,1,1,1,4,9,1,4,3,5,5,2,7,5,3,4,8,2,1,13,2,3,3,1,14,1,1,4,5,1,3,6,1,5,2,1,1,3,3,3,3,1,1,2,7,6,6,7,1,4,7,6,1,1,1,1,1,12,3,3,9,5, + 2,6,1,5,6,1,2,3,18,2,4,14,4,1,3,6,1,1,6,3,5,5,3,2,2,2,2,12,3,1,4,2,3,2,3,11,1,7,4,1,2,1,3,17,1,9,1,24,1,1,4,2,2,4,1,2,7,1,1,1,3,1,2,2,4,15,1, + 1,2,1,1,2,1,5,2,5,20,2,5,9,1,10,8,7,6,1,1,1,1,1,1,6,2,1,2,8,1,1,1,1,5,1,1,3,1,1,1,1,3,1,1,12,4,1,3,1,1,1,1,1,10,3,1,7,5,13,1,2,3,4,6,1,1,30, + 2,9,9,1,15,38,11,3,1,8,24,7,1,9,8,10,2,1,9,31,2,13,6,2,9,4,49,5,2,15,2,1,10,2,1,1,1,2,2,6,15,30,35,3,14,18,8,1,16,10,28,12,19,45,38,1,3,2,3, + 13,2,1,7,3,6,5,3,4,3,1,5,7,8,1,5,3,18,5,3,6,1,21,4,24,9,24,40,3,14,3,21,3,2,1,2,4,2,3,1,15,15,6,5,1,1,3,1,5,6,1,9,7,3,3,2,1,4,3,8,21,5,16,4, + 5,2,10,11,11,3,6,3,2,9,3,6,13,1,2,1,1,1,1,11,12,6,6,1,4,2,6,5,2,1,1,3,3,6,13,3,1,1,5,1,2,3,3,14,2,1,2,2,2,5,1,9,5,1,1,6,12,3,12,3,4,13,2,14, + 2,8,1,17,5,1,16,4,2,2,21,8,9,6,23,20,12,25,19,9,38,8,3,21,40,25,33,13,4,3,1,4,1,2,4,1,2,5,26,2,1,1,2,1,3,6,2,1,1,1,1,1,1,2,3,1,1,1,9,2,3,1,1, + 1,3,6,3,2,1,1,6,6,1,8,2,2,2,1,4,1,2,3,2,7,3,2,4,1,2,1,2,2,1,1,1,1,1,3,1,2,5,4,10,9,4,9,1,1,1,1,1,1,5,3,2,1,6,4,9,6,1,10,2,31,17,8,3,7,5,40,1, + 7,7,1,6,5,2,10,7,8,4,15,39,25,6,28,47,18,10,7,1,3,1,1,2,1,1,1,3,3,3,1,1,1,3,4,2,1,4,1,3,6,10,7,8,6,2,2,1,3,3,2,5,8,7,9,12,2,15,1,1,4,1,2,1,1, + 1,3,2,1,3,3,5,6,2,3,2,10,1,4,2,8,1,1,1,11,6,1,21,4,16,3,1,3,1,4,2,3,6,5,1,3,1,1,3,3,4,6,1,1,10,4,2,7,10,4,7,4,2,9,4,3,1,1,1,4,1,8,3,4,1,3,1, + 6,1,4,2,1,4,7,2,1,8,1,4,5,1,1,2,2,4,6,2,7,1,10,1,1,3,4,11,10,8,21,4,6,1,3,5,2,1,2,28,5,5,2,3,13,1,2,3,1,4,2,1,5,20,3,8,11,1,3,3,3,1,8,10,9,2, + 10,9,2,3,1,1,2,4,1,8,3,6,1,7,8,6,11,1,4,29,8,4,3,1,2,7,13,1,4,1,6,2,6,12,12,2,20,3,2,3,6,4,8,9,2,7,34,5,1,18,6,1,1,4,4,5,7,9,1,2,2,4,3,4,1,7, + 2,2,2,6,2,3,25,5,3,6,1,4,6,7,4,2,1,4,2,13,6,4,4,3,1,5,3,4,4,3,2,1,1,4,1,2,1,1,3,1,11,1,6,3,1,7,3,6,2,8,8,6,9,3,4,11,3,2,10,12,2,5,11,1,6,4,5, + 3,1,8,5,4,6,6,3,5,1,1,3,2,1,2,2,6,17,12,1,10,1,6,12,1,6,6,19,9,6,16,1,13,4,4,15,7,17,6,11,9,15,12,6,7,2,1,2,2,15,9,3,21,4,6,49,18,7,3,2,3,1, + 6,8,2,2,6,2,9,1,3,6,4,4,1,2,16,2,5,2,1,6,2,3,5,3,1,2,5,1,2,1,9,3,1,8,6,4,8,11,3,1,1,1,1,3,1,13,8,4,1,3,2,2,1,4,1,11,1,5,2,1,5,2,5,8,6,1,1,7, + 4,3,8,3,2,7,2,1,5,1,5,2,4,7,6,2,8,5,1,11,4,5,3,6,18,1,2,13,3,3,1,21,1,1,4,1,4,1,1,1,8,1,2,2,7,1,2,4,2,2,9,2,1,1,1,4,3,6,3,12,5,1,1,1,5,6,3,2, + 4,8,2,2,4,2,7,1,8,9,5,2,3,2,1,3,2,13,7,14,6,5,1,1,2,1,4,2,23,2,1,1,6,3,1,4,1,15,3,1,7,3,9,14,1,3,1,4,1,1,5,8,1,3,8,3,8,15,11,4,14,4,4,2,5,5, + 1,7,1,6,14,7,7,8,5,15,4,8,6,5,6,2,1,13,1,20,15,11,9,2,5,6,2,11,2,6,2,5,1,5,8,4,13,19,25,4,1,1,11,1,34,2,5,9,14,6,2,2,6,1,1,14,1,3,14,13,1,6, + 12,21,14,14,6,32,17,8,32,9,28,1,2,4,11,8,3,1,14,2,5,15,1,1,1,1,3,6,4,1,3,4,11,3,1,1,11,30,1,5,1,4,1,5,8,1,1,3,2,4,3,17,35,2,6,12,17,3,1,6,2, + 1,1,12,2,7,3,3,2,1,16,2,8,3,6,5,4,7,3,3,8,1,9,8,5,1,2,1,3,2,8,1,2,9,12,1,1,2,3,8,3,24,12,4,3,7,5,8,3,3,3,3,3,3,1,23,10,3,1,2,2,6,3,1,16,1,16, + 22,3,10,4,11,6,9,7,7,3,6,2,2,2,4,10,2,1,1,2,8,7,1,6,4,1,3,3,3,5,10,12,12,2,3,12,8,15,1,1,16,6,6,1,5,9,11,4,11,4,2,6,12,1,17,5,13,1,4,9,5,1,11, + 2,1,8,1,5,7,28,8,3,5,10,2,17,3,38,22,1,2,18,12,10,4,38,18,1,4,44,19,4,1,8,4,1,12,1,4,31,12,1,14,7,75,7,5,10,6,6,13,3,2,11,11,3,2,5,28,15,6,18, + 18,5,6,4,3,16,1,7,18,7,36,3,5,3,1,7,1,9,1,10,7,2,4,2,6,2,9,7,4,3,32,12,3,7,10,2,23,16,3,1,12,3,31,4,11,1,3,8,9,5,1,30,15,6,12,3,2,2,11,19,9, + 14,2,6,2,3,19,13,17,5,3,3,25,3,14,1,1,1,36,1,3,2,19,3,13,36,9,13,31,6,4,16,34,2,5,4,2,3,3,5,1,1,1,4,3,1,17,3,2,3,5,3,1,3,2,3,5,6,3,12,11,1,3, + 1,2,26,7,12,7,2,14,3,3,7,7,11,25,25,28,16,4,36,1,2,1,6,2,1,9,3,27,17,4,3,4,13,4,1,3,2,2,1,10,4,2,4,6,3,8,2,1,18,1,1,24,2,2,4,33,2,3,63,7,1,6, + 40,7,3,4,4,2,4,15,18,1,16,1,1,11,2,41,14,1,3,18,13,3,2,4,16,2,17,7,15,24,7,18,13,44,2,2,3,6,1,1,7,5,1,7,1,4,3,3,5,10,8,2,3,1,8,1,1,27,4,2,1, + 12,1,2,1,10,6,1,6,7,5,2,3,7,11,5,11,3,6,6,2,3,15,4,9,1,1,2,1,2,11,2,8,12,8,5,4,2,3,1,5,2,2,1,14,1,12,11,4,1,11,17,17,4,3,2,5,5,7,3,1,5,9,9,8, + 2,5,6,6,13,13,2,1,2,6,1,2,2,49,4,9,1,2,10,16,7,8,4,3,2,23,4,58,3,29,1,14,19,19,11,11,2,7,5,1,3,4,6,2,18,5,12,12,17,17,3,3,2,4,1,6,2,3,4,3,1, + 1,1,1,5,1,1,9,1,3,1,3,6,1,8,1,1,2,6,4,14,3,1,4,11,4,1,3,32,1,2,4,13,4,1,2,4,2,1,3,1,11,1,4,2,1,4,4,6,3,5,1,6,5,7,6,3,23,3,5,3,5,3,3,13,3,9,10, + 1,12,10,2,3,18,13,7,160,52,4,2,2,3,2,14,5,4,12,4,6,4,1,20,4,11,6,2,12,27,1,4,1,2,2,7,4,5,2,28,3,7,25,8,3,19,3,6,10,2,2,1,10,2,5,4,1,3,4,1,5, + 3,2,6,9,3,6,2,16,3,3,16,4,5,5,3,2,1,2,16,15,8,2,6,21,2,4,1,22,5,8,1,1,21,11,2,1,11,11,19,13,12,4,2,3,2,3,6,1,8,11,1,4,2,9,5,2,1,11,2,9,1,1,2, + 14,31,9,3,4,21,14,4,8,1,7,2,2,2,5,1,4,20,3,3,4,10,1,11,9,8,2,1,4,5,14,12,14,2,17,9,6,31,4,14,1,20,13,26,5,2,7,3,6,13,2,4,2,19,6,2,2,18,9,3,5, + 12,12,14,4,6,2,3,6,9,5,22,4,5,25,6,4,8,5,2,6,27,2,35,2,16,3,7,8,8,6,6,5,9,17,2,20,6,19,2,13,3,1,1,1,4,17,12,2,14,7,1,4,18,12,38,33,2,10,1,1, + 2,13,14,17,11,50,6,33,20,26,74,16,23,45,50,13,38,33,6,6,7,4,4,2,1,3,2,5,8,7,8,9,3,11,21,9,13,1,3,10,6,7,1,2,2,18,5,5,1,9,9,2,68,9,19,13,2,5, + 1,4,4,7,4,13,3,9,10,21,17,3,26,2,1,5,2,4,5,4,1,7,4,7,3,4,2,1,6,1,1,20,4,1,9,2,2,1,3,3,2,3,2,1,1,1,20,2,3,1,6,2,3,6,2,4,8,1,3,2,10,3,5,3,4,4, + 3,4,16,1,6,1,10,2,4,2,1,1,2,10,11,2,2,3,1,24,31,4,10,10,2,5,12,16,164,15,4,16,7,9,15,19,17,1,2,1,1,5,1,1,1,1,1,3,1,4,3,1,3,1,3,1,2,1,1,3,3,7, + 2,8,1,2,2,2,1,3,4,3,7,8,12,92,2,10,3,1,3,14,5,25,16,42,4,7,7,4,2,21,5,27,26,27,21,25,30,31,2,1,5,13,3,22,5,6,6,11,9,12,1,5,9,7,5,5,22,60,3,5, + 13,1,1,8,1,1,3,3,2,1,9,3,3,18,4,1,2,3,7,6,3,1,2,3,9,1,3,1,3,2,1,3,1,1,1,2,1,11,3,1,6,9,1,3,2,3,1,2,1,5,1,1,4,3,4,1,2,2,4,4,1,7,2,1,2,2,3,5,13, + 18,3,4,14,9,9,4,16,3,7,5,8,2,6,48,28,3,1,1,4,2,14,8,2,9,2,1,15,2,4,3,2,10,16,12,8,7,1,1,3,1,1,1,2,7,4,1,6,4,38,39,16,23,7,15,15,3,2,12,7,21, + 37,27,6,5,4,8,2,10,8,8,6,5,1,2,1,3,24,1,16,17,9,23,10,17,6,1,51,55,44,13,294,9,3,6,2,4,2,2,15,1,1,1,13,21,17,68,14,8,9,4,1,4,9,3,11,7,1,1,1, + 5,6,3,2,1,1,1,2,3,8,1,2,2,4,1,5,5,2,1,4,3,7,13,4,1,4,1,3,1,1,1,5,5,10,1,6,1,5,2,1,5,2,4,1,4,5,7,3,18,2,9,11,32,4,3,3,2,4,7,11,16,9,11,8,13,38, + 32,8,4,2,1,1,2,1,2,4,4,1,1,1,4,1,21,3,11,1,16,1,1,6,1,3,2,4,9,8,57,7,44,1,3,3,13,3,10,1,1,7,5,2,7,21,47,63,3,15,4,7,1,16,1,1,2,8,2,3,42,15,4, + 1,29,7,22,10,3,78,16,12,20,18,4,67,11,5,1,3,15,6,21,31,32,27,18,13,71,35,5,142,4,10,1,2,50,19,33,16,35,37,16,19,27,7,1,133,19,1,4,8,7,20,1,4, + 4,1,10,3,1,6,1,2,51,5,40,15,24,43,22928,11,1,13,154,70,3,1,1,7,4,10,1,2,1,1,2,1,2,1,2,2,1,1,2,1,1,1,1,1,2,1,1,1,1,1,1,1,1,1,1,1,1,1,2,1,1,1, + 3,2,1,1,1,1,2,1,1, + }; + static ImWchar base_ranges[] = // not zero-terminated + { + 0x0020, 0x00FF, // Basic Latin + Latin Supplement + 0x3000, 0x30FF, // CJK Symbols and Punctuations, Hiragana, Katakana + 0x31F0, 0x31FF, // Katakana Phonetic Extensions + 0xFF00, 0xFFEF, // Half-width characters + 0xFFFD, 0xFFFD // Invalid + }; + static ImWchar full_ranges[IM_ARRAYSIZE(base_ranges) + IM_ARRAYSIZE(accumulative_offsets_from_0x4E00)*2 + 1] = { 0 }; + if (!full_ranges[0]) + { + memcpy(full_ranges, base_ranges, sizeof(base_ranges)); + UnpackAccumulativeOffsetsIntoRanges(0x4E00, accumulative_offsets_from_0x4E00, IM_ARRAYSIZE(accumulative_offsets_from_0x4E00), full_ranges + IM_ARRAYSIZE(base_ranges)); + } + return &full_ranges[0]; +} + +const ImWchar* ImFontAtlas::GetGlyphRangesCyrillic() +{ + static const ImWchar ranges[] = + { + 0x0020, 0x00FF, // Basic Latin + Latin Supplement + 0x0400, 0x052F, // Cyrillic + Cyrillic Supplement + 0x2DE0, 0x2DFF, // Cyrillic Extended-A + 0xA640, 0xA69F, // Cyrillic Extended-B + 0, + }; + return &ranges[0]; +} + +const ImWchar* ImFontAtlas::GetGlyphRangesThai() +{ + static const ImWchar ranges[] = + { + 0x0020, 0x00FF, // Basic Latin + 0x2010, 0x205E, // Punctuations + 0x0E00, 0x0E7F, // Thai + 0, + }; + return &ranges[0]; +} + +const ImWchar* ImFontAtlas::GetGlyphRangesVietnamese() +{ + static const ImWchar ranges[] = + { + 0x0020, 0x00FF, // Basic Latin + 0x0102, 0x0103, + 0x0110, 0x0111, + 0x0128, 0x0129, + 0x0168, 0x0169, + 0x01A0, 0x01A1, + 0x01AF, 0x01B0, + 0x1EA0, 0x1EF9, + 0, + }; + return &ranges[0]; +} + +//----------------------------------------------------------------------------- +// [SECTION] ImFontGlyphRangesBuilder +//----------------------------------------------------------------------------- + +void ImFontGlyphRangesBuilder::AddText(const char* text, const char* text_end) +{ + while (text_end ? (text < text_end) : *text) + { + unsigned int c = 0; + int c_len = ImTextCharFromUtf8(&c, text, text_end); + text += c_len; + if (c_len == 0) + break; + AddChar((ImWchar)c); + } +} + +void ImFontGlyphRangesBuilder::AddRanges(const ImWchar* ranges) +{ + for (; ranges[0]; ranges += 2) + for (ImWchar c = ranges[0]; c <= ranges[1]; c++) + AddChar(c); +} + +void ImFontGlyphRangesBuilder::BuildRanges(ImVector* out_ranges) +{ + const int max_codepoint = IM_UNICODE_CODEPOINT_MAX; + for (int n = 0; n <= max_codepoint; n++) + if (GetBit(n)) + { + out_ranges->push_back((ImWchar)n); + while (n < max_codepoint && GetBit(n + 1)) + n++; + out_ranges->push_back((ImWchar)n); + } + out_ranges->push_back(0); +} + +//----------------------------------------------------------------------------- +// [SECTION] ImFont +//----------------------------------------------------------------------------- + +ImFont::ImFont() +{ + FontSize = 0.0f; + FallbackAdvanceX = 0.0f; + FallbackChar = (ImWchar)-1; + EllipsisChar = (ImWchar)-1; + DotChar = (ImWchar)-1; + FallbackGlyph = NULL; + ContainerAtlas = NULL; + ConfigData = NULL; + ConfigDataCount = 0; + DirtyLookupTables = false; + Scale = 1.0f; + Ascent = Descent = 0.0f; + MetricsTotalSurface = 0; + memset(Used4kPagesMap, 0, sizeof(Used4kPagesMap)); +} + +ImFont::~ImFont() +{ + ClearOutputData(); +} + +void ImFont::ClearOutputData() +{ + FontSize = 0.0f; + FallbackAdvanceX = 0.0f; + Glyphs.clear(); + IndexAdvanceX.clear(); + IndexLookup.clear(); + FallbackGlyph = NULL; + ContainerAtlas = NULL; + DirtyLookupTables = true; + Ascent = Descent = 0.0f; + MetricsTotalSurface = 0; +} + +static ImWchar FindFirstExistingGlyph(ImFont* font, const ImWchar* candidate_chars, int candidate_chars_count) +{ + for (int n = 0; n < candidate_chars_count; n++) + if (font->FindGlyphNoFallback(candidate_chars[n]) != NULL) + return candidate_chars[n]; + return (ImWchar)-1; +} + +void ImFont::BuildLookupTable() +{ + int max_codepoint = 0; + for (int i = 0; i != Glyphs.Size; i++) + max_codepoint = ImMax(max_codepoint, (int)Glyphs[i].Codepoint); + + // Build lookup table + IM_ASSERT(Glyphs.Size < 0xFFFF); // -1 is reserved + IndexAdvanceX.clear(); + IndexLookup.clear(); + DirtyLookupTables = false; + memset(Used4kPagesMap, 0, sizeof(Used4kPagesMap)); + GrowIndex(max_codepoint + 1); + for (int i = 0; i < Glyphs.Size; i++) + { + int codepoint = (int)Glyphs[i].Codepoint; + IndexAdvanceX[codepoint] = Glyphs[i].AdvanceX; + IndexLookup[codepoint] = (ImWchar)i; + + // Mark 4K page as used + const int page_n = codepoint / 4096; + Used4kPagesMap[page_n >> 3] |= 1 << (page_n & 7); + } + + // Create a glyph to handle TAB + // FIXME: Needs proper TAB handling but it needs to be contextualized (or we could arbitrary say that each string starts at "column 0" ?) + if (FindGlyph((ImWchar)' ')) + { + if (Glyphs.back().Codepoint != '\t') // So we can call this function multiple times (FIXME: Flaky) + Glyphs.resize(Glyphs.Size + 1); + ImFontGlyph& tab_glyph = Glyphs.back(); + tab_glyph = *FindGlyph((ImWchar)' '); + tab_glyph.Codepoint = '\t'; + tab_glyph.AdvanceX *= IM_TABSIZE; + IndexAdvanceX[(int)tab_glyph.Codepoint] = (float)tab_glyph.AdvanceX; + IndexLookup[(int)tab_glyph.Codepoint] = (ImWchar)(Glyphs.Size - 1); + } + + // Mark special glyphs as not visible (note that AddGlyph already mark as non-visible glyphs with zero-size polygons) + SetGlyphVisible((ImWchar)' ', false); + SetGlyphVisible((ImWchar)'\t', false); + + // Ellipsis character is required for rendering elided text. We prefer using U+2026 (horizontal ellipsis). + // However some old fonts may contain ellipsis at U+0085. Here we auto-detect most suitable ellipsis character. + // FIXME: Note that 0x2026 is rarely included in our font ranges. Because of this we are more likely to use three individual dots. + const ImWchar ellipsis_chars[] = { (ImWchar)0x2026, (ImWchar)0x0085 }; + const ImWchar dots_chars[] = { (ImWchar)'.', (ImWchar)0xFF0E }; + if (EllipsisChar == (ImWchar)-1) + EllipsisChar = FindFirstExistingGlyph(this, ellipsis_chars, IM_ARRAYSIZE(ellipsis_chars)); + if (DotChar == (ImWchar)-1) + DotChar = FindFirstExistingGlyph(this, dots_chars, IM_ARRAYSIZE(dots_chars)); + + // Setup fallback character + const ImWchar fallback_chars[] = { (ImWchar)IM_UNICODE_CODEPOINT_INVALID, (ImWchar)'?', (ImWchar)' ' }; + FallbackGlyph = FindGlyphNoFallback(FallbackChar); + if (FallbackGlyph == NULL) + { + FallbackChar = FindFirstExistingGlyph(this, fallback_chars, IM_ARRAYSIZE(fallback_chars)); + FallbackGlyph = FindGlyphNoFallback(FallbackChar); + if (FallbackGlyph == NULL) + { + FallbackGlyph = &Glyphs.back(); + FallbackChar = (ImWchar)FallbackGlyph->Codepoint; + } + } + + FallbackAdvanceX = FallbackGlyph->AdvanceX; + for (int i = 0; i < max_codepoint + 1; i++) + if (IndexAdvanceX[i] < 0.0f) + IndexAdvanceX[i] = FallbackAdvanceX; +} + +// API is designed this way to avoid exposing the 4K page size +// e.g. use with IsGlyphRangeUnused(0, 255) +bool ImFont::IsGlyphRangeUnused(unsigned int c_begin, unsigned int c_last) +{ + unsigned int page_begin = (c_begin / 4096); + unsigned int page_last = (c_last / 4096); + for (unsigned int page_n = page_begin; page_n <= page_last; page_n++) + if ((page_n >> 3) < sizeof(Used4kPagesMap)) + if (Used4kPagesMap[page_n >> 3] & (1 << (page_n & 7))) + return false; + return true; +} + +void ImFont::SetGlyphVisible(ImWchar c, bool visible) +{ + if (ImFontGlyph* glyph = (ImFontGlyph*)(void*)FindGlyph((ImWchar)c)) + glyph->Visible = visible ? 1 : 0; +} + +void ImFont::GrowIndex(int new_size) +{ + IM_ASSERT(IndexAdvanceX.Size == IndexLookup.Size); + if (new_size <= IndexLookup.Size) + return; + IndexAdvanceX.resize(new_size, -1.0f); + IndexLookup.resize(new_size, (ImWchar)-1); +} + +// x0/y0/x1/y1 are offset from the character upper-left layout position, in pixels. Therefore x0/y0 are often fairly close to zero. +// Not to be mistaken with texture coordinates, which are held by u0/v0/u1/v1 in normalized format (0.0..1.0 on each texture axis). +// 'cfg' is not necessarily == 'this->ConfigData' because multiple source fonts+configs can be used to build one target font. +void ImFont::AddGlyph(const ImFontConfig* cfg, ImWchar codepoint, float x0, float y0, float x1, float y1, float u0, float v0, float u1, float v1, float advance_x) +{ + if (cfg != NULL) + { + // Clamp & recenter if needed + const float advance_x_original = advance_x; + advance_x = ImClamp(advance_x, cfg->GlyphMinAdvanceX, cfg->GlyphMaxAdvanceX); + if (advance_x != advance_x_original) + { + float char_off_x = cfg->PixelSnapH ? ImFloor((advance_x - advance_x_original) * 0.5f) : (advance_x - advance_x_original) * 0.5f; + x0 += char_off_x; + x1 += char_off_x; + } + + // Snap to pixel + if (cfg->PixelSnapH) + advance_x = IM_ROUND(advance_x); + + // Bake spacing + advance_x += cfg->GlyphExtraSpacing.x; + } + + Glyphs.resize(Glyphs.Size + 1); + ImFontGlyph& glyph = Glyphs.back(); + glyph.Codepoint = (unsigned int)codepoint; + glyph.Visible = (x0 != x1) && (y0 != y1); + glyph.Colored = false; + glyph.X0 = x0; + glyph.Y0 = y0; + glyph.X1 = x1; + glyph.Y1 = y1; + glyph.U0 = u0; + glyph.V0 = v0; + glyph.U1 = u1; + glyph.V1 = v1; + glyph.AdvanceX = advance_x; + + // Compute rough surface usage metrics (+1 to account for average padding, +0.99 to round) + // We use (U1-U0)*TexWidth instead of X1-X0 to account for oversampling. + float pad = ContainerAtlas->TexGlyphPadding + 0.99f; + DirtyLookupTables = true; + MetricsTotalSurface += (int)((glyph.U1 - glyph.U0) * ContainerAtlas->TexWidth + pad) * (int)((glyph.V1 - glyph.V0) * ContainerAtlas->TexHeight + pad); +} + +void ImFont::AddRemapChar(ImWchar dst, ImWchar src, bool overwrite_dst) +{ + IM_ASSERT(IndexLookup.Size > 0); // Currently this can only be called AFTER the font has been built, aka after calling ImFontAtlas::GetTexDataAs*() function. + unsigned int index_size = (unsigned int)IndexLookup.Size; + + if (dst < index_size && IndexLookup.Data[dst] == (ImWchar)-1 && !overwrite_dst) // 'dst' already exists + return; + if (src >= index_size && dst >= index_size) // both 'dst' and 'src' don't exist -> no-op + return; + + GrowIndex(dst + 1); + IndexLookup[dst] = (src < index_size) ? IndexLookup.Data[src] : (ImWchar)-1; + IndexAdvanceX[dst] = (src < index_size) ? IndexAdvanceX.Data[src] : 1.0f; +} + +const ImFontGlyph* ImFont::FindGlyph(ImWchar c) const +{ + if (c >= (size_t)IndexLookup.Size) + return FallbackGlyph; + const ImWchar i = IndexLookup.Data[c]; + if (i == (ImWchar)-1) + return FallbackGlyph; + return &Glyphs.Data[i]; +} + +const ImFontGlyph* ImFont::FindGlyphNoFallback(ImWchar c) const +{ + if (c >= (size_t)IndexLookup.Size) + return NULL; + const ImWchar i = IndexLookup.Data[c]; + if (i == (ImWchar)-1) + return NULL; + return &Glyphs.Data[i]; +} + +const char* ImFont::CalcWordWrapPositionA(float scale, const char* text, const char* text_end, float wrap_width) const +{ + // Simple word-wrapping for English, not full-featured. Please submit failing cases! + // FIXME: Much possible improvements (don't cut things like "word !", "word!!!" but cut within "word,,,,", more sensible support for punctuations, support for Unicode punctuations, etc.) + + // For references, possible wrap point marked with ^ + // "aaa bbb, ccc,ddd. eee fff. ggg!" + // ^ ^ ^ ^ ^__ ^ ^ + + // List of hardcoded separators: .,;!?'" + + // Skip extra blanks after a line returns (that includes not counting them in width computation) + // e.g. "Hello world" --> "Hello" "World" + + // Cut words that cannot possibly fit within one line. + // e.g.: "The tropical fish" with ~5 characters worth of width --> "The tr" "opical" "fish" + + float line_width = 0.0f; + float word_width = 0.0f; + float blank_width = 0.0f; + wrap_width /= scale; // We work with unscaled widths to avoid scaling every characters + + const char* word_end = text; + const char* prev_word_end = NULL; + bool inside_word = true; + + const char* s = text; + while (s < text_end) + { + unsigned int c = (unsigned int)*s; + const char* next_s; + if (c < 0x80) + next_s = s + 1; + else + next_s = s + ImTextCharFromUtf8(&c, s, text_end); + if (c == 0) + break; + + if (c < 32) + { + if (c == '\n') + { + line_width = word_width = blank_width = 0.0f; + inside_word = true; + s = next_s; + continue; + } + if (c == '\r') + { + s = next_s; + continue; + } + } + + const float char_width = ((int)c < IndexAdvanceX.Size ? IndexAdvanceX.Data[c] : FallbackAdvanceX); + if (ImCharIsBlankW(c)) + { + if (inside_word) + { + line_width += blank_width; + blank_width = 0.0f; + word_end = s; + } + blank_width += char_width; + inside_word = false; + } + else + { + word_width += char_width; + if (inside_word) + { + word_end = next_s; + } + else + { + prev_word_end = word_end; + line_width += word_width + blank_width; + word_width = blank_width = 0.0f; + } + + // Allow wrapping after punctuation. + inside_word = (c != '.' && c != ',' && c != ';' && c != '!' && c != '?' && c != '\"'); + } + + // We ignore blank width at the end of the line (they can be skipped) + if (line_width + word_width > wrap_width) + { + // Words that cannot possibly fit within an entire line will be cut anywhere. + if (word_width < wrap_width) + s = prev_word_end ? prev_word_end : word_end; + break; + } + + s = next_s; + } + + return s; +} + +ImVec2 ImFont::CalcTextSizeA(float size, float max_width, float wrap_width, const char* text_begin, const char* text_end, const char** remaining) const +{ + if (!text_end) + text_end = text_begin + strlen(text_begin); // FIXME-OPT: Need to avoid this. + + const float line_height = size; + const float scale = size / FontSize; + + ImVec2 text_size = ImVec2(0, 0); + float line_width = 0.0f; + + const bool word_wrap_enabled = (wrap_width > 0.0f); + const char* word_wrap_eol = NULL; + + const char* s = text_begin; + while (s < text_end) + { + if (word_wrap_enabled) + { + // Calculate how far we can render. Requires two passes on the string data but keeps the code simple and not intrusive for what's essentially an uncommon feature. + if (!word_wrap_eol) + { + word_wrap_eol = CalcWordWrapPositionA(scale, s, text_end, wrap_width - line_width); + if (word_wrap_eol == s) // Wrap_width is too small to fit anything. Force displaying 1 character to minimize the height discontinuity. + word_wrap_eol++; // +1 may not be a character start point in UTF-8 but it's ok because we use s >= word_wrap_eol below + } + + if (s >= word_wrap_eol) + { + if (text_size.x < line_width) + text_size.x = line_width; + text_size.y += line_height; + line_width = 0.0f; + word_wrap_eol = NULL; + + // Wrapping skips upcoming blanks + while (s < text_end) + { + const char c = *s; + if (ImCharIsBlankA(c)) { s++; } else if (c == '\n') { s++; break; } else { break; } + } + continue; + } + } + + // Decode and advance source + const char* prev_s = s; + unsigned int c = (unsigned int)*s; + if (c < 0x80) + { + s += 1; + } + else + { + s += ImTextCharFromUtf8(&c, s, text_end); + if (c == 0) // Malformed UTF-8? + break; + } + + if (c < 32) + { + if (c == '\n') + { + text_size.x = ImMax(text_size.x, line_width); + text_size.y += line_height; + line_width = 0.0f; + continue; + } + if (c == '\r') + continue; + } + + const float char_width = ((int)c < IndexAdvanceX.Size ? IndexAdvanceX.Data[c] : FallbackAdvanceX) * scale; + if (line_width + char_width >= max_width) + { + s = prev_s; + break; + } + + line_width += char_width; + } + + if (text_size.x < line_width) + text_size.x = line_width; + + if (line_width > 0 || text_size.y == 0.0f) + text_size.y += line_height; + + if (remaining) + *remaining = s; + + return text_size; +} + +// Note: as with every ImDrawList drawing function, this expects that the font atlas texture is bound. +void ImFont::RenderChar(ImDrawList* draw_list, float size, ImVec2 pos, ImU32 col, ImWchar c) const +{ + const ImFontGlyph* glyph = FindGlyph(c); + if (!glyph || !glyph->Visible) + return; + if (glyph->Colored) + col |= ~IM_COL32_A_MASK; + float scale = (size >= 0.0f) ? (size / FontSize) : 1.0f; + pos.x = IM_FLOOR(pos.x); + pos.y = IM_FLOOR(pos.y); + draw_list->PrimReserve(6, 4); + draw_list->PrimRectUV(ImVec2(pos.x + glyph->X0 * scale, pos.y + glyph->Y0 * scale), ImVec2(pos.x + glyph->X1 * scale, pos.y + glyph->Y1 * scale), ImVec2(glyph->U0, glyph->V0), ImVec2(glyph->U1, glyph->V1), col); +} + +// Note: as with every ImDrawList drawing function, this expects that the font atlas texture is bound. +void ImFont::RenderText(ImDrawList* draw_list, float size, ImVec2 pos, ImU32 col, const ImVec4& clip_rect, const char* text_begin, const char* text_end, float wrap_width, bool cpu_fine_clip) const +{ + if (!text_end) + text_end = text_begin + strlen(text_begin); // ImGui:: functions generally already provides a valid text_end, so this is merely to handle direct calls. + + // Align to be pixel perfect + pos.x = IM_FLOOR(pos.x); + pos.y = IM_FLOOR(pos.y); + float x = pos.x; + float y = pos.y; + if (y > clip_rect.w) + return; + + const float scale = size / FontSize; + const float line_height = FontSize * scale; + const bool word_wrap_enabled = (wrap_width > 0.0f); + const char* word_wrap_eol = NULL; + + // Fast-forward to first visible line + const char* s = text_begin; + if (y + line_height < clip_rect.y && !word_wrap_enabled) + while (y + line_height < clip_rect.y && s < text_end) + { + s = (const char*)memchr(s, '\n', text_end - s); + s = s ? s + 1 : text_end; + y += line_height; + } + + // For large text, scan for the last visible line in order to avoid over-reserving in the call to PrimReserve() + // Note that very large horizontal line will still be affected by the issue (e.g. a one megabyte string buffer without a newline will likely crash atm) + if (text_end - s > 10000 && !word_wrap_enabled) + { + const char* s_end = s; + float y_end = y; + while (y_end < clip_rect.w && s_end < text_end) + { + s_end = (const char*)memchr(s_end, '\n', text_end - s_end); + s_end = s_end ? s_end + 1 : text_end; + y_end += line_height; + } + text_end = s_end; + } + if (s == text_end) + return; + + // Reserve vertices for remaining worse case (over-reserving is useful and easily amortized) + const int vtx_count_max = (int)(text_end - s) * 4; + const int idx_count_max = (int)(text_end - s) * 6; + const int idx_expected_size = draw_list->IdxBuffer.Size + idx_count_max; + draw_list->PrimReserve(idx_count_max, vtx_count_max); + + ImDrawVert* vtx_write = draw_list->_VtxWritePtr; + ImDrawIdx* idx_write = draw_list->_IdxWritePtr; + unsigned int vtx_current_idx = draw_list->_VtxCurrentIdx; + + const ImU32 col_untinted = col | ~IM_COL32_A_MASK; + + while (s < text_end) + { + if (word_wrap_enabled) + { + // Calculate how far we can render. Requires two passes on the string data but keeps the code simple and not intrusive for what's essentially an uncommon feature. + if (!word_wrap_eol) + { + word_wrap_eol = CalcWordWrapPositionA(scale, s, text_end, wrap_width - (x - pos.x)); + if (word_wrap_eol == s) // Wrap_width is too small to fit anything. Force displaying 1 character to minimize the height discontinuity. + word_wrap_eol++; // +1 may not be a character start point in UTF-8 but it's ok because we use s >= word_wrap_eol below + } + + if (s >= word_wrap_eol) + { + x = pos.x; + y += line_height; + word_wrap_eol = NULL; + + // Wrapping skips upcoming blanks + while (s < text_end) + { + const char c = *s; + if (ImCharIsBlankA(c)) { s++; } else if (c == '\n') { s++; break; } else { break; } + } + continue; + } + } + + // Decode and advance source + unsigned int c = (unsigned int)*s; + if (c < 0x80) + { + s += 1; + } + else + { + s += ImTextCharFromUtf8(&c, s, text_end); + if (c == 0) // Malformed UTF-8? + break; + } + + if (c < 32) + { + if (c == '\n') + { + x = pos.x; + y += line_height; + if (y > clip_rect.w) + break; // break out of main loop + continue; + } + if (c == '\r') + continue; + } + + const ImFontGlyph* glyph = FindGlyph((ImWchar)c); + if (glyph == NULL) + continue; + + float char_width = glyph->AdvanceX * scale; + if (glyph->Visible) + { + // We don't do a second finer clipping test on the Y axis as we've already skipped anything before clip_rect.y and exit once we pass clip_rect.w + float x1 = x + glyph->X0 * scale; + float x2 = x + glyph->X1 * scale; + float y1 = y + glyph->Y0 * scale; + float y2 = y + glyph->Y1 * scale; + if (x1 <= clip_rect.z && x2 >= clip_rect.x) + { + // Render a character + float u1 = glyph->U0; + float v1 = glyph->V0; + float u2 = glyph->U1; + float v2 = glyph->V1; + + // CPU side clipping used to fit text in their frame when the frame is too small. Only does clipping for axis aligned quads. + if (cpu_fine_clip) + { + if (x1 < clip_rect.x) + { + u1 = u1 + (1.0f - (x2 - clip_rect.x) / (x2 - x1)) * (u2 - u1); + x1 = clip_rect.x; + } + if (y1 < clip_rect.y) + { + v1 = v1 + (1.0f - (y2 - clip_rect.y) / (y2 - y1)) * (v2 - v1); + y1 = clip_rect.y; + } + if (x2 > clip_rect.z) + { + u2 = u1 + ((clip_rect.z - x1) / (x2 - x1)) * (u2 - u1); + x2 = clip_rect.z; + } + if (y2 > clip_rect.w) + { + v2 = v1 + ((clip_rect.w - y1) / (y2 - y1)) * (v2 - v1); + y2 = clip_rect.w; + } + if (y1 >= y2) + { + x += char_width; + continue; + } + } + + // Support for untinted glyphs + ImU32 glyph_col = glyph->Colored ? col_untinted : col; + + // We are NOT calling PrimRectUV() here because non-inlined causes too much overhead in a debug builds. Inlined here: + { + idx_write[0] = (ImDrawIdx)(vtx_current_idx); idx_write[1] = (ImDrawIdx)(vtx_current_idx+1); idx_write[2] = (ImDrawIdx)(vtx_current_idx+2); + idx_write[3] = (ImDrawIdx)(vtx_current_idx); idx_write[4] = (ImDrawIdx)(vtx_current_idx+2); idx_write[5] = (ImDrawIdx)(vtx_current_idx+3); + vtx_write[0].pos.x = x1; vtx_write[0].pos.y = y1; vtx_write[0].col = glyph_col; vtx_write[0].uv.x = u1; vtx_write[0].uv.y = v1; + vtx_write[1].pos.x = x2; vtx_write[1].pos.y = y1; vtx_write[1].col = glyph_col; vtx_write[1].uv.x = u2; vtx_write[1].uv.y = v1; + vtx_write[2].pos.x = x2; vtx_write[2].pos.y = y2; vtx_write[2].col = glyph_col; vtx_write[2].uv.x = u2; vtx_write[2].uv.y = v2; + vtx_write[3].pos.x = x1; vtx_write[3].pos.y = y2; vtx_write[3].col = glyph_col; vtx_write[3].uv.x = u1; vtx_write[3].uv.y = v2; + vtx_write += 4; + vtx_current_idx += 4; + idx_write += 6; + } + } + } + x += char_width; + } + + // Give back unused vertices (clipped ones, blanks) ~ this is essentially a PrimUnreserve() action. + draw_list->VtxBuffer.Size = (int)(vtx_write - draw_list->VtxBuffer.Data); // Same as calling shrink() + draw_list->IdxBuffer.Size = (int)(idx_write - draw_list->IdxBuffer.Data); + draw_list->CmdBuffer[draw_list->CmdBuffer.Size - 1].ElemCount -= (idx_expected_size - draw_list->IdxBuffer.Size); + draw_list->_VtxWritePtr = vtx_write; + draw_list->_IdxWritePtr = idx_write; + draw_list->_VtxCurrentIdx = vtx_current_idx; +} + +//----------------------------------------------------------------------------- +// [SECTION] ImGui Internal Render Helpers +//----------------------------------------------------------------------------- +// Vaguely redesigned to stop accessing ImGui global state: +// - RenderArrow() +// - RenderBullet() +// - RenderCheckMark() +// - RenderMouseCursor() +// - RenderArrowPointingAt() +// - RenderRectFilledRangeH() +// - RenderRectFilledWithHole() +//----------------------------------------------------------------------------- +// Function in need of a redesign (legacy mess) +// - RenderColorRectWithAlphaCheckerboard() +//----------------------------------------------------------------------------- + +// Render an arrow aimed to be aligned with text (p_min is a position in the same space text would be positioned). To e.g. denote expanded/collapsed state +void ImGui::RenderArrow(ImDrawList* draw_list, ImVec2 pos, ImU32 col, ImGuiDir dir, float scale) +{ + const float h = draw_list->_Data->FontSize * 1.00f; + float r = h * 0.40f * scale; + ImVec2 center = pos + ImVec2(h * 0.50f, h * 0.50f * scale); + + ImVec2 a, b, c; + switch (dir) + { + case ImGuiDir_Up: + case ImGuiDir_Down: + if (dir == ImGuiDir_Up) r = -r; + a = ImVec2(+0.000f, +0.750f) * r; + b = ImVec2(-0.866f, -0.750f) * r; + c = ImVec2(+0.866f, -0.750f) * r; + break; + case ImGuiDir_Left: + case ImGuiDir_Right: + if (dir == ImGuiDir_Left) r = -r; + a = ImVec2(+0.750f, +0.000f) * r; + b = ImVec2(-0.750f, +0.866f) * r; + c = ImVec2(-0.750f, -0.866f) * r; + break; + case ImGuiDir_None: + case ImGuiDir_COUNT: + IM_ASSERT(0); + break; + } + draw_list->AddTriangleFilled(center + a, center + b, center + c, col); +} + +void ImGui::RenderBullet(ImDrawList* draw_list, ImVec2 pos, ImU32 col) +{ + draw_list->AddCircleFilled(pos, draw_list->_Data->FontSize * 0.20f, col, 8); +} + +void ImGui::RenderCheckMark(ImDrawList* draw_list, ImVec2 pos, ImU32 col, float sz) +{ + float thickness = ImMax(sz / 5.0f, 1.0f); + sz -= thickness * 0.5f; + pos += ImVec2(thickness * 0.25f, thickness * 0.25f); + + float third = sz / 3.0f; + float bx = pos.x + third; + float by = pos.y + sz - third * 0.5f; + draw_list->PathLineTo(ImVec2(bx - third, by - third)); + draw_list->PathLineTo(ImVec2(bx, by)); + draw_list->PathLineTo(ImVec2(bx + third * 2.0f, by - third * 2.0f)); + draw_list->PathStroke(col, 0, thickness); +} + +void ImGui::RenderMouseCursor(ImDrawList* draw_list, ImVec2 pos, float scale, ImGuiMouseCursor mouse_cursor, ImU32 col_fill, ImU32 col_border, ImU32 col_shadow) +{ + if (mouse_cursor == ImGuiMouseCursor_None) + return; + IM_ASSERT(mouse_cursor > ImGuiMouseCursor_None && mouse_cursor < ImGuiMouseCursor_COUNT); + + ImFontAtlas* font_atlas = draw_list->_Data->Font->ContainerAtlas; + ImVec2 offset, size, uv[4]; + if (font_atlas->GetMouseCursorTexData(mouse_cursor, &offset, &size, &uv[0], &uv[2])) + { + pos -= offset; + ImTextureID tex_id = font_atlas->TexID; + draw_list->PushTextureID(tex_id); + draw_list->AddImage(tex_id, pos + ImVec2(1, 0) * scale, pos + (ImVec2(1, 0) + size) * scale, uv[2], uv[3], col_shadow); + draw_list->AddImage(tex_id, pos + ImVec2(2, 0) * scale, pos + (ImVec2(2, 0) + size) * scale, uv[2], uv[3], col_shadow); + draw_list->AddImage(tex_id, pos, pos + size * scale, uv[2], uv[3], col_border); + draw_list->AddImage(tex_id, pos, pos + size * scale, uv[0], uv[1], col_fill); + draw_list->PopTextureID(); + } +} + +// Render an arrow. 'pos' is position of the arrow tip. half_sz.x is length from base to tip. half_sz.y is length on each side. +void ImGui::RenderArrowPointingAt(ImDrawList* draw_list, ImVec2 pos, ImVec2 half_sz, ImGuiDir direction, ImU32 col) +{ + switch (direction) + { + case ImGuiDir_Left: draw_list->AddTriangleFilled(ImVec2(pos.x + half_sz.x, pos.y - half_sz.y), ImVec2(pos.x + half_sz.x, pos.y + half_sz.y), pos, col); return; + case ImGuiDir_Right: draw_list->AddTriangleFilled(ImVec2(pos.x - half_sz.x, pos.y + half_sz.y), ImVec2(pos.x - half_sz.x, pos.y - half_sz.y), pos, col); return; + case ImGuiDir_Up: draw_list->AddTriangleFilled(ImVec2(pos.x + half_sz.x, pos.y + half_sz.y), ImVec2(pos.x - half_sz.x, pos.y + half_sz.y), pos, col); return; + case ImGuiDir_Down: draw_list->AddTriangleFilled(ImVec2(pos.x - half_sz.x, pos.y - half_sz.y), ImVec2(pos.x + half_sz.x, pos.y - half_sz.y), pos, col); return; + case ImGuiDir_None: case ImGuiDir_COUNT: break; // Fix warnings + } +} + +static inline float ImAcos01(float x) +{ + if (x <= 0.0f) return IM_PI * 0.5f; + if (x >= 1.0f) return 0.0f; + return ImAcos(x); + //return (-0.69813170079773212f * x * x - 0.87266462599716477f) * x + 1.5707963267948966f; // Cheap approximation, may be enough for what we do. +} + +// FIXME: Cleanup and move code to ImDrawList. +void ImGui::RenderRectFilledRangeH(ImDrawList* draw_list, const ImRect& rect, ImU32 col, float x_start_norm, float x_end_norm, float rounding) +{ + if (x_end_norm == x_start_norm) + return; + if (x_start_norm > x_end_norm) + ImSwap(x_start_norm, x_end_norm); + + ImVec2 p0 = ImVec2(ImLerp(rect.Min.x, rect.Max.x, x_start_norm), rect.Min.y); + ImVec2 p1 = ImVec2(ImLerp(rect.Min.x, rect.Max.x, x_end_norm), rect.Max.y); + if (rounding == 0.0f) + { + draw_list->AddRectFilled(p0, p1, col, 0.0f); + return; + } + + rounding = ImClamp(ImMin((rect.Max.x - rect.Min.x) * 0.5f, (rect.Max.y - rect.Min.y) * 0.5f) - 1.0f, 0.0f, rounding); + const float inv_rounding = 1.0f / rounding; + const float arc0_b = ImAcos01(1.0f - (p0.x - rect.Min.x) * inv_rounding); + const float arc0_e = ImAcos01(1.0f - (p1.x - rect.Min.x) * inv_rounding); + const float half_pi = IM_PI * 0.5f; // We will == compare to this because we know this is the exact value ImAcos01 can return. + const float x0 = ImMax(p0.x, rect.Min.x + rounding); + if (arc0_b == arc0_e) + { + draw_list->PathLineTo(ImVec2(x0, p1.y)); + draw_list->PathLineTo(ImVec2(x0, p0.y)); + } + else if (arc0_b == 0.0f && arc0_e == half_pi) + { + draw_list->PathArcToFast(ImVec2(x0, p1.y - rounding), rounding, 3, 6); // BL + draw_list->PathArcToFast(ImVec2(x0, p0.y + rounding), rounding, 6, 9); // TR + } + else + { + draw_list->PathArcTo(ImVec2(x0, p1.y - rounding), rounding, IM_PI - arc0_e, IM_PI - arc0_b, 3); // BL + draw_list->PathArcTo(ImVec2(x0, p0.y + rounding), rounding, IM_PI + arc0_b, IM_PI + arc0_e, 3); // TR + } + if (p1.x > rect.Min.x + rounding) + { + const float arc1_b = ImAcos01(1.0f - (rect.Max.x - p1.x) * inv_rounding); + const float arc1_e = ImAcos01(1.0f - (rect.Max.x - p0.x) * inv_rounding); + const float x1 = ImMin(p1.x, rect.Max.x - rounding); + if (arc1_b == arc1_e) + { + draw_list->PathLineTo(ImVec2(x1, p0.y)); + draw_list->PathLineTo(ImVec2(x1, p1.y)); + } + else if (arc1_b == 0.0f && arc1_e == half_pi) + { + draw_list->PathArcToFast(ImVec2(x1, p0.y + rounding), rounding, 9, 12); // TR + draw_list->PathArcToFast(ImVec2(x1, p1.y - rounding), rounding, 0, 3); // BR + } + else + { + draw_list->PathArcTo(ImVec2(x1, p0.y + rounding), rounding, -arc1_e, -arc1_b, 3); // TR + draw_list->PathArcTo(ImVec2(x1, p1.y - rounding), rounding, +arc1_b, +arc1_e, 3); // BR + } + } + draw_list->PathFillConvex(col); +} + +void ImGui::RenderRectFilledWithHole(ImDrawList* draw_list, ImRect outer, ImRect inner, ImU32 col, float rounding) +{ + const bool fill_L = (inner.Min.x > outer.Min.x); + const bool fill_R = (inner.Max.x < outer.Max.x); + const bool fill_U = (inner.Min.y > outer.Min.y); + const bool fill_D = (inner.Max.y < outer.Max.y); + if (fill_L) draw_list->AddRectFilled(ImVec2(outer.Min.x, inner.Min.y), ImVec2(inner.Min.x, inner.Max.y), col, rounding, (fill_U ? 0 : ImDrawFlags_RoundCornersTopLeft) | (fill_D ? 0 : ImDrawFlags_RoundCornersBottomLeft)); + if (fill_R) draw_list->AddRectFilled(ImVec2(inner.Max.x, inner.Min.y), ImVec2(outer.Max.x, inner.Max.y), col, rounding, (fill_U ? 0 : ImDrawFlags_RoundCornersTopRight) | (fill_D ? 0 : ImDrawFlags_RoundCornersBottomRight)); + if (fill_U) draw_list->AddRectFilled(ImVec2(inner.Min.x, outer.Min.y), ImVec2(inner.Max.x, inner.Min.y), col, rounding, (fill_L ? 0 : ImDrawFlags_RoundCornersTopLeft) | (fill_R ? 0 : ImDrawFlags_RoundCornersTopRight)); + if (fill_D) draw_list->AddRectFilled(ImVec2(inner.Min.x, inner.Max.y), ImVec2(inner.Max.x, outer.Max.y), col, rounding, (fill_L ? 0 : ImDrawFlags_RoundCornersBottomLeft) | (fill_R ? 0 : ImDrawFlags_RoundCornersBottomRight)); + if (fill_L && fill_U) draw_list->AddRectFilled(ImVec2(outer.Min.x, outer.Min.y), ImVec2(inner.Min.x, inner.Min.y), col, rounding, ImDrawFlags_RoundCornersTopLeft); + if (fill_R && fill_U) draw_list->AddRectFilled(ImVec2(inner.Max.x, outer.Min.y), ImVec2(outer.Max.x, inner.Min.y), col, rounding, ImDrawFlags_RoundCornersTopRight); + if (fill_L && fill_D) draw_list->AddRectFilled(ImVec2(outer.Min.x, inner.Max.y), ImVec2(inner.Min.x, outer.Max.y), col, rounding, ImDrawFlags_RoundCornersBottomLeft); + if (fill_R && fill_D) draw_list->AddRectFilled(ImVec2(inner.Max.x, inner.Max.y), ImVec2(outer.Max.x, outer.Max.y), col, rounding, ImDrawFlags_RoundCornersBottomRight); +} + +// Helper for ColorPicker4() +// NB: This is rather brittle and will show artifact when rounding this enabled if rounded corners overlap multiple cells. Caller currently responsible for avoiding that. +// Spent a non reasonable amount of time trying to getting this right for ColorButton with rounding+anti-aliasing+ImGuiColorEditFlags_HalfAlphaPreview flag + various grid sizes and offsets, and eventually gave up... probably more reasonable to disable rounding altogether. +// FIXME: uses ImGui::GetColorU32 +void ImGui::RenderColorRectWithAlphaCheckerboard(ImDrawList* draw_list, ImVec2 p_min, ImVec2 p_max, ImU32 col, float grid_step, ImVec2 grid_off, float rounding, ImDrawFlags flags) +{ + if ((flags & ImDrawFlags_RoundCornersMask_) == 0) + flags = ImDrawFlags_RoundCornersDefault_; + if (((col & IM_COL32_A_MASK) >> IM_COL32_A_SHIFT) < 0xFF) + { + ImU32 col_bg1 = GetColorU32(ImAlphaBlendColors(IM_COL32(204, 204, 204, 255), col)); + ImU32 col_bg2 = GetColorU32(ImAlphaBlendColors(IM_COL32(128, 128, 128, 255), col)); + draw_list->AddRectFilled(p_min, p_max, col_bg1, rounding, flags); + + int yi = 0; + for (float y = p_min.y + grid_off.y; y < p_max.y; y += grid_step, yi++) + { + float y1 = ImClamp(y, p_min.y, p_max.y), y2 = ImMin(y + grid_step, p_max.y); + if (y2 <= y1) + continue; + for (float x = p_min.x + grid_off.x + (yi & 1) * grid_step; x < p_max.x; x += grid_step * 2.0f) + { + float x1 = ImClamp(x, p_min.x, p_max.x), x2 = ImMin(x + grid_step, p_max.x); + if (x2 <= x1) + continue; + ImDrawFlags cell_flags = ImDrawFlags_RoundCornersNone; + if (y1 <= p_min.y) { if (x1 <= p_min.x) cell_flags |= ImDrawFlags_RoundCornersTopLeft; if (x2 >= p_max.x) cell_flags |= ImDrawFlags_RoundCornersTopRight; } + if (y2 >= p_max.y) { if (x1 <= p_min.x) cell_flags |= ImDrawFlags_RoundCornersBottomLeft; if (x2 >= p_max.x) cell_flags |= ImDrawFlags_RoundCornersBottomRight; } + + // Combine flags + cell_flags = (flags == ImDrawFlags_RoundCornersNone || cell_flags == ImDrawFlags_RoundCornersNone) ? ImDrawFlags_RoundCornersNone : (cell_flags & flags); + draw_list->AddRectFilled(ImVec2(x1, y1), ImVec2(x2, y2), col_bg2, rounding, cell_flags); + } + } + } + else + { + draw_list->AddRectFilled(p_min, p_max, col, rounding, flags); + } +} + +//----------------------------------------------------------------------------- +// [SECTION] Decompression code +//----------------------------------------------------------------------------- +// Compressed with stb_compress() then converted to a C array and encoded as base85. +// Use the program in misc/fonts/binary_to_compressed_c.cpp to create the array from a TTF file. +// The purpose of encoding as base85 instead of "0x00,0x01,..." style is only save on _source code_ size. +// Decompression from stb.h (public domain) by Sean Barrett https://github.com/nothings/stb/blob/master/stb.h +//----------------------------------------------------------------------------- + +static unsigned int stb_decompress_length(const unsigned char *input) +{ + return (input[8] << 24) + (input[9] << 16) + (input[10] << 8) + input[11]; +} + +static unsigned char *stb__barrier_out_e, *stb__barrier_out_b; +static const unsigned char *stb__barrier_in_b; +static unsigned char *stb__dout; +static void stb__match(const unsigned char *data, unsigned int length) +{ + // INVERSE of memmove... write each byte before copying the next... + IM_ASSERT(stb__dout + length <= stb__barrier_out_e); + if (stb__dout + length > stb__barrier_out_e) { stb__dout += length; return; } + if (data < stb__barrier_out_b) { stb__dout = stb__barrier_out_e+1; return; } + while (length--) *stb__dout++ = *data++; +} + +static void stb__lit(const unsigned char *data, unsigned int length) +{ + IM_ASSERT(stb__dout + length <= stb__barrier_out_e); + if (stb__dout + length > stb__barrier_out_e) { stb__dout += length; return; } + if (data < stb__barrier_in_b) { stb__dout = stb__barrier_out_e+1; return; } + memcpy(stb__dout, data, length); + stb__dout += length; +} + +#define stb__in2(x) ((i[x] << 8) + i[(x)+1]) +#define stb__in3(x) ((i[x] << 16) + stb__in2((x)+1)) +#define stb__in4(x) ((i[x] << 24) + stb__in3((x)+1)) + +static const unsigned char *stb_decompress_token(const unsigned char *i) +{ + if (*i >= 0x20) { // use fewer if's for cases that expand small + if (*i >= 0x80) stb__match(stb__dout-i[1]-1, i[0] - 0x80 + 1), i += 2; + else if (*i >= 0x40) stb__match(stb__dout-(stb__in2(0) - 0x4000 + 1), i[2]+1), i += 3; + else /* *i >= 0x20 */ stb__lit(i+1, i[0] - 0x20 + 1), i += 1 + (i[0] - 0x20 + 1); + } else { // more ifs for cases that expand large, since overhead is amortized + if (*i >= 0x18) stb__match(stb__dout-(stb__in3(0) - 0x180000 + 1), i[3]+1), i += 4; + else if (*i >= 0x10) stb__match(stb__dout-(stb__in3(0) - 0x100000 + 1), stb__in2(3)+1), i += 5; + else if (*i >= 0x08) stb__lit(i+2, stb__in2(0) - 0x0800 + 1), i += 2 + (stb__in2(0) - 0x0800 + 1); + else if (*i == 0x07) stb__lit(i+3, stb__in2(1) + 1), i += 3 + (stb__in2(1) + 1); + else if (*i == 0x06) stb__match(stb__dout-(stb__in3(1)+1), i[4]+1), i += 5; + else if (*i == 0x04) stb__match(stb__dout-(stb__in3(1)+1), stb__in2(4)+1), i += 6; + } + return i; +} + +static unsigned int stb_adler32(unsigned int adler32, unsigned char *buffer, unsigned int buflen) +{ + const unsigned long ADLER_MOD = 65521; + unsigned long s1 = adler32 & 0xffff, s2 = adler32 >> 16; + unsigned long blocklen = buflen % 5552; + + unsigned long i; + while (buflen) { + for (i=0; i + 7 < blocklen; i += 8) { + s1 += buffer[0], s2 += s1; + s1 += buffer[1], s2 += s1; + s1 += buffer[2], s2 += s1; + s1 += buffer[3], s2 += s1; + s1 += buffer[4], s2 += s1; + s1 += buffer[5], s2 += s1; + s1 += buffer[6], s2 += s1; + s1 += buffer[7], s2 += s1; + + buffer += 8; + } + + for (; i < blocklen; ++i) + s1 += *buffer++, s2 += s1; + + s1 %= ADLER_MOD, s2 %= ADLER_MOD; + buflen -= blocklen; + blocklen = 5552; + } + return (unsigned int)(s2 << 16) + (unsigned int)s1; +} + +static unsigned int stb_decompress(unsigned char *output, const unsigned char *i, unsigned int /*length*/) +{ + if (stb__in4(0) != 0x57bC0000) return 0; + if (stb__in4(4) != 0) return 0; // error! stream is > 4GB + const unsigned int olen = stb_decompress_length(i); + stb__barrier_in_b = i; + stb__barrier_out_e = output + olen; + stb__barrier_out_b = output; + i += 16; + + stb__dout = output; + for (;;) { + const unsigned char *old_i = i; + i = stb_decompress_token(i); + if (i == old_i) { + if (*i == 0x05 && i[1] == 0xfa) { + IM_ASSERT(stb__dout == output + olen); + if (stb__dout != output + olen) return 0; + if (stb_adler32(1, output, olen) != (unsigned int) stb__in4(2)) + return 0; + return olen; + } else { + IM_ASSERT(0); /* NOTREACHED */ + return 0; + } + } + IM_ASSERT(stb__dout <= output + olen); + if (stb__dout > output + olen) + return 0; + } +} + +//----------------------------------------------------------------------------- +// [SECTION] Default font data (ProggyClean.ttf) +//----------------------------------------------------------------------------- +// ProggyClean.ttf +// Copyright (c) 2004, 2005 Tristan Grimmer +// MIT license (see License.txt in http://www.upperbounds.net/download/ProggyClean.ttf.zip) +// Download and more information at http://upperbounds.net +//----------------------------------------------------------------------------- +// File: 'ProggyClean.ttf' (41208 bytes) +// Exported using misc/fonts/binary_to_compressed_c.cpp (with compression + base85 string encoding). +// The purpose of encoding as base85 instead of "0x00,0x01,..." style is only save on _source code_ size. +//----------------------------------------------------------------------------- +static const char proggy_clean_ttf_compressed_data_base85[11980 + 1] = + "7])#######hV0qs'/###[),##/l:$#Q6>##5[n42>c-TH`->>#/e>11NNV=Bv(*:.F?uu#(gRU.o0XGH`$vhLG1hxt9?W`#,5LsCp#-i>.r$<$6pD>Lb';9Crc6tgXmKVeU2cD4Eo3R/" + "2*>]b(MC;$jPfY.;h^`IWM9Qo#t'X#(v#Y9w0#1D$CIf;W'#pWUPXOuxXuU(H9M(1=Ke$$'5F%)]0^#0X@U.a$FBjVQTSDgEKnIS7EM9>ZY9w0#L;>>#Mx&4Mvt//L[MkA#W@lK.N'[0#7RL_&#w+F%HtG9M#XL`N&.,GM4Pg;--VsM.M0rJfLH2eTM`*oJMHRC`N" + "kfimM2J,W-jXS:)r0wK#@Fge$U>`w'N7G#$#fB#$E^$#:9:hk+eOe--6x)F7*E%?76%^GMHePW-Z5l'&GiF#$956:rS?dA#fiK:)Yr+`�j@'DbG&#^$PG.Ll+DNa&VZ>1i%h1S9u5o@YaaW$e+bROPOpxTO7Stwi1::iB1q)C_=dV26J;2,]7op$]uQr@_V7$q^%lQwtuHY]=DX,n3L#0PHDO4f9>dC@O>HBuKPpP*E,N+b3L#lpR/MrTEH.IAQk.a>D[.e;mc." + "x]Ip.PH^'/aqUO/$1WxLoW0[iLAw=4h(9.`G" + "CRUxHPeR`5Mjol(dUWxZa(>STrPkrJiWx`5U7F#.g*jrohGg`cg:lSTvEY/EV_7H4Q9[Z%cnv;JQYZ5q.l7Zeas:HOIZOB?Ggv:[7MI2k).'2($5FNP&EQ(,)" + "U]W]+fh18.vsai00);D3@4ku5P?DP8aJt+;qUM]=+b'8@;mViBKx0DE[-auGl8:PJ&Dj+M6OC]O^((##]`0i)drT;-7X`=-H3[igUnPG-NZlo.#k@h#=Ork$m>a>$-?Tm$UV(?#P6YY#" + "'/###xe7q.73rI3*pP/$1>s9)W,JrM7SN]'/4C#v$U`0#V.[0>xQsH$fEmPMgY2u7Kh(G%siIfLSoS+MK2eTM$=5,M8p`A.;_R%#u[K#$x4AG8.kK/HSB==-'Ie/QTtG?-.*^N-4B/ZM" + "_3YlQC7(p7q)&](`6_c)$/*JL(L-^(]$wIM`dPtOdGA,U3:w2M-0+WomX2u7lqM2iEumMTcsF?-aT=Z-97UEnXglEn1K-bnEO`gu" + "Ft(c%=;Am_Qs@jLooI&NX;]0#j4#F14;gl8-GQpgwhrq8'=l_f-b49'UOqkLu7-##oDY2L(te+Mch&gLYtJ,MEtJfLh'x'M=$CS-ZZ%P]8bZ>#S?YY#%Q&q'3^Fw&?D)UDNrocM3A76/" + "/oL?#h7gl85[qW/NDOk%16ij;+:1a'iNIdb-ou8.P*w,v5#EI$TWS>Pot-R*H'-SEpA:g)f+O$%%`kA#G=8RMmG1&O`>to8bC]T&$,n.LoO>29sp3dt-52U%VM#q7'DHpg+#Z9%H[Ket`e;)f#Km8&+DC$I46>#Kr]]u-[=99tts1.qb#q72g1WJO81q+eN'03'eM>&1XxY-caEnO" + "j%2n8)),?ILR5^.Ibn<-X-Mq7[a82Lq:F&#ce+S9wsCK*x`569E8ew'He]h:sI[2LM$[guka3ZRd6:t%IG:;$%YiJ:Nq=?eAw;/:nnDq0(CYcMpG)qLN4$##&J-XTt,%OVU4)S1+R-#dg0/Nn?Ku1^0f$B*P:Rowwm-`0PKjYDDM'3]d39VZHEl4,.j']Pk-M.h^&:0FACm$maq-&sgw0t7/6(^xtk%" + "LuH88Fj-ekm>GA#_>568x6(OFRl-IZp`&b,_P'$MhLbxfc$mj`,O;&%W2m`Zh:/)Uetw:aJ%]K9h:TcF]u_-Sj9,VK3M.*'&0D[Ca]J9gp8,kAW]" + "%(?A%R$f<->Zts'^kn=-^@c4%-pY6qI%J%1IGxfLU9CP8cbPlXv);C=b),<2mOvP8up,UVf3839acAWAW-W?#ao/^#%KYo8fRULNd2.>%m]UK:n%r$'sw]J;5pAoO_#2mO3n,'=H5(et" + "Hg*`+RLgv>=4U8guD$I%D:W>-r5V*%j*W:Kvej.Lp$'?;++O'>()jLR-^u68PHm8ZFWe+ej8h:9r6L*0//c&iH&R8pRbA#Kjm%upV1g:" + "a_#Ur7FuA#(tRh#.Y5K+@?3<-8m0$PEn;J:rh6?I6uG<-`wMU'ircp0LaE_OtlMb&1#6T.#FDKu#1Lw%u%+GM+X'e?YLfjM[VO0MbuFp7;>Q&#WIo)0@F%q7c#4XAXN-U&VBpqB>0ie&jhZ[?iLR@@_AvA-iQC(=ksRZRVp7`.=+NpBC%rh&3]R:8XDmE5^V8O(x<-+k?'(^](H.aREZSi,#1:[IXaZFOm<-ui#qUq2$##Ri;u75OK#(RtaW-K-F`S+cF]uN`-KMQ%rP/Xri.LRcB##=YL3BgM/3M" + "D?@f&1'BW-)Ju#bmmWCMkk&#TR`C,5d>g)F;t,4:@_l8G/5h4vUd%&%950:VXD'QdWoY-F$BtUwmfe$YqL'8(PWX(" + "P?^@Po3$##`MSs?DWBZ/S>+4%>fX,VWv/w'KD`LP5IbH;rTV>n3cEK8U#bX]l-/V+^lj3;vlMb&[5YQ8#pekX9JP3XUC72L,,?+Ni&co7ApnO*5NK,((W-i:$,kp'UDAO(G0Sq7MVjJs" + "bIu)'Z,*[>br5fX^:FPAWr-m2KgLQ_nN6'8uTGT5g)uLv:873UpTLgH+#FgpH'_o1780Ph8KmxQJ8#H72L4@768@Tm&Q" + "h4CB/5OvmA&,Q&QbUoi$a_%3M01H)4x7I^&KQVgtFnV+;[Pc>[m4k//,]1?#`VY[Jr*3&&slRfLiVZJ:]?=K3Sw=[$=uRB?3xk48@aege0jT6'N#(q%.O=?2S]u*(m<-" + "V8J'(1)G][68hW$5'q[GC&5j`TE?m'esFGNRM)j,ffZ?-qx8;->g4t*:CIP/[Qap7/9'#(1sao7w-.qNUdkJ)tCF&#B^;xGvn2r9FEPFFFcL@.iFNkTve$m%#QvQS8U@)2Z+3K:AKM5i" + "sZ88+dKQ)W6>J%CL`.d*(B`-n8D9oK-XV1q['-5k'cAZ69e;D_?$ZPP&s^+7])$*$#@QYi9,5P r+$%CE=68>K8r0=dSC%%(@p7" + ".m7jilQ02'0-VWAgTlGW'b)Tq7VT9q^*^$$.:&N@@" + "$&)WHtPm*5_rO0&e%K&#-30j(E4#'Zb.o/(Tpm$>K'f@[PvFl,hfINTNU6u'0pao7%XUp9]5.>%h`8_=VYbxuel.NTSsJfLacFu3B'lQSu/m6-Oqem8T+oE--$0a/k]uj9EwsG>%veR*" + "hv^BFpQj:K'#SJ,sB-'#](j.Lg92rTw-*n%@/;39rrJF,l#qV%OrtBeC6/,;qB3ebNW[?,Hqj2L.1NP&GjUR=1D8QaS3Up&@*9wP?+lo7b?@%'k4`p0Z$22%K3+iCZj?XJN4Nm&+YF]u" + "@-W$U%VEQ/,,>>#)D#%8cY#YZ?=,`Wdxu/ae&#" + "w6)R89tI#6@s'(6Bf7a&?S=^ZI_kS&ai`&=tE72L_D,;^R)7[$so8lKN%5/$(vdfq7+ebA#" + "u1p]ovUKW&Y%q]'>$1@-[xfn$7ZTp7mM,G,Ko7a&Gu%G[RMxJs[0MM%wci.LFDK)(%:_i2B5CsR8&9Z&#=mPEnm0f`<&c)QL5uJ#%u%lJj+D-r;BoFDoS97h5g)E#o:&S4weDF,9^Hoe`h*L+_a*NrLW-1pG_&2UdB8" + "6e%B/:=>)N4xeW.*wft-;$'58-ESqr#U`'6AQ]m&6/`Z>#S?YY#Vc;r7U2&326d=w&H####?TZ`*4?&.MK?LP8Vxg>$[QXc%QJv92.(Db*B)gb*BM9dM*hJMAo*c&#" + "b0v=Pjer]$gG&JXDf->'StvU7505l9$AFvgYRI^&<^b68?j#q9QX4SM'RO#&sL1IM.rJfLUAj221]d##DW=m83u5;'bYx,*Sl0hL(W;;$doB&O/TQ:(Z^xBdLjLV#*8U_72Lh+2Q8Cj0i:6hp&$C/:p(HK>T8Y[gHQ4`4)'$Ab(Nof%V'8hL&#SfD07&6D@M.*J:;$-rv29'M]8qMv-tLp,'886iaC=Hb*YJoKJ,(j%K=H`K.v9HggqBIiZu'QvBT.#=)0ukruV&.)3=(^1`o*Pj4<-#MJ+gLq9-##@HuZPN0]u:h7.T..G:;$/Usj(T7`Q8tT72LnYl<-qx8;-HV7Q-&Xdx%1a,hC=0u+HlsV>nuIQL-5" + "_>@kXQtMacfD.m-VAb8;IReM3$wf0''hra*so568'Ip&vRs849'MRYSp%:t:h5qSgwpEr$B>Q,;s(C#$)`svQuF$##-D,##,g68@2[T;.XSdN9Qe)rpt._K-#5wF)sP'##p#C0c%-Gb%" + "hd+<-j'Ai*x&&HMkT]C'OSl##5RG[JXaHN;d'uA#x._U;.`PU@(Z3dt4r152@:v,'R.Sj'w#0<-;kPI)FfJ&#AYJ&#//)>-k=m=*XnK$>=)72L]0I%>.G690a:$##<,);?;72#?x9+d;" + "^V'9;jY@;)br#q^YQpx:X#Te$Z^'=-=bGhLf:D6&bNwZ9-ZD#n^9HhLMr5G;']d&6'wYmTFmLq9wI>P(9mI[>kC-ekLC/R&CH+s'B;K-M6$EB%is00:" + "+A4[7xks.LrNk0&E)wILYF@2L'0Nb$+pv<(2.768/FrY&h$^3i&@+G%JT'<-,v`3;_)I9M^AE]CN?Cl2AZg+%4iTpT3$U4O]GKx'm9)b@p7YsvK3w^YR-" + "CdQ*:Ir<($u&)#(&?L9Rg3H)4fiEp^iI9O8KnTj,]H?D*r7'M;PwZ9K0E^k&-cpI;.p/6_vwoFMV<->#%Xi.LxVnrU(4&8/P+:hLSKj$#U%]49t'I:rgMi'FL@a:0Y-uA[39',(vbma*" + "hU%<-SRF`Tt:542R_VV$p@[p8DV[A,?1839FWdFTi1O*H&#(AL8[_P%.M>v^-))qOT*F5Cq0`Ye%+$B6i:7@0IXSsDiWP,##P`%/L-" + "S(qw%sf/@%#B6;/U7K]uZbi^Oc^2n%t<)'mEVE''n`WnJra$^TKvX5B>;_aSEK',(hwa0:i4G?.Bci.(X[?b*($,=-n<.Q%`(X=?+@Am*Js0&=3bh8K]mL69=Lb,OcZV/);TTm8VI;?%OtJ<(b4mq7M6:u?KRdFl*:xP?Yb.5)%w_I?7uk5JC+FS(m#i'k.'a0i)9<7b'fs'59hq$*5Uhv##pi^8+hIEBF`nvo`;'l0.^S1<-wUK2/Coh58KKhLj" + "M=SO*rfO`+qC`W-On.=AJ56>>i2@2LH6A:&5q`?9I3@@'04&p2/LVa*T-4<-i3;M9UvZd+N7>b*eIwg:CC)c<>nO&#$(>.Z-I&J(Q0Hd5Q%7Co-b`-cP)hI;*_F]u`Rb[.j8_Q/<&>uu+VsH$sM9TA%?)(vmJ80),P7E>)tjD%2L=-t#fK[%`v=Q8WlA2);Sa" + ">gXm8YB`1d@K#n]76-a$U,mF%Ul:#/'xoFM9QX-$.QN'>" + "[%$Z$uF6pA6Ki2O5:8w*vP1<-1`[G,)-m#>0`P&#eb#.3i)rtB61(o'$?X3B2Qft^ae_5tKL9MUe9b*sLEQ95C&`=G?@Mj=wh*'3E>=-<)Gt*Iw)'QG:`@I" + "wOf7&]1i'S01B+Ev/Nac#9S;=;YQpg_6U`*kVY39xK,[/6Aj7:'1Bm-_1EYfa1+o&o4hp7KN_Q(OlIo@S%;jVdn0'1h19w,WQhLI)3S#f$2(eb,jr*b;3Vw]*7NH%$c4Vs,eD9>XW8?N]o+(*pgC%/72LV-uW%iewS8W6m2rtCpo'RS1R84=@paTKt)>=%&1[)*vp'u+x,VrwN;&]kuO9JDbg=pO$J*.jVe;u'm0dr9l,<*wMK*Oe=g8lV_KEBFkO'oU]^=[-792#ok,)" + "i]lR8qQ2oA8wcRCZ^7w/Njh;?.stX?Q1>S1q4Bn$)K1<-rGdO'$Wr.Lc.CG)$/*JL4tNR/,SVO3,aUw'DJN:)Ss;wGn9A32ijw%FL+Z0Fn.U9;reSq)bmI32U==5ALuG&#Vf1398/pVo" + "1*c-(aY168o<`JsSbk-,1N;$>0:OUas(3:8Z972LSfF8eb=c-;>SPw7.6hn3m`9^Xkn(r.qS[0;T%&Qc=+STRxX'q1BNk3&*eu2;&8q$&x>Q#Q7^Tf+6<(d%ZVmj2bDi%.3L2n+4W'$P" + "iDDG)g,r%+?,$@?uou5tSe2aN_AQU*'IAO" + "URQ##V^Fv-XFbGM7Fl(N<3DhLGF%q.1rC$#:T__&Pi68%0xi_&[qFJ(77j_&JWoF.V735&T,[R*:xFR*K5>>#`bW-?4Ne_&6Ne_&6Ne_&n`kr-#GJcM6X;uM6X;uM(.a..^2TkL%oR(#" + ";u.T%fAr%4tJ8&><1=GHZ_+m9/#H1F^R#SC#*N=BA9(D?v[UiFY>>^8p,KKF.W]L29uLkLlu/+4T" + "w$)F./^n3+rlo+DB;5sIYGNk+i1t-69Jg--0pao7Sm#K)pdHW&;LuDNH@H>#/X-TI(;P>#,Gc>#0Su>#4`1?#8lC?#xL$#B.`$#F:r$#JF.%#NR@%#R_R%#Vke%#Zww%#_-4^Rh%Sflr-k'MS.o?.5/sWel/wpEM0%3'/1)K^f1-d>G21&v(35>V`39V7A4=onx4" + "A1OY5EI0;6Ibgr6M$HS7Q<)58C5w,;WoA*#[%T*#`1g*#d=#+#hI5+#lUG+#pbY+#tnl+#x$),#&1;,#*=M,#.I`,#2Ur,#6b.-#;w[H#iQtA#m^0B#qjBB#uvTB##-hB#'9$C#+E6C#" + "/QHC#3^ZC#7jmC#;v)D#?,)4kMYD4lVu`4m`:&5niUA5@(A5BA1]PBB:xlBCC=2CDLXMCEUtiCf&0g2'tN?PGT4CPGT4CPGT4CPGT4CPGT4CPGT4CPGT4CP" + "GT4CPGT4CPGT4CPGT4CPGT4CPGT4CP-qekC`.9kEg^+F$kwViFJTB&5KTB&5KTB&5KTB&5KTB&5KTB&5KTB&5KTB&5KTB&5KTB&5KTB&5KTB&5KTB&5KTB&5KTB&5o,^<-28ZI'O?;xp" + "O?;xpO?;xpO?;xpO?;xpO?;xpO?;xpO?;xpO?;xpO?;xpO?;xpO?;xpO?;xpO?;xp;7q-#lLYI:xvD=#"; + +static const char* GetDefaultCompressedFontDataTTFBase85() +{ + return proggy_clean_ttf_compressed_data_base85; +} + +#endif // #ifndef IMGUI_DISABLE diff --git a/source/editor/imgui/imgui_internal.h b/source/editor/imgui/imgui_internal.h new file mode 100644 index 0000000..66f31a8 --- /dev/null +++ b/source/editor/imgui/imgui_internal.h @@ -0,0 +1,2758 @@ +// dear imgui, v1.85 WIP +// (internal structures/api) + +// You may use this file to debug, understand or extend ImGui features but we don't provide any guarantee of forward compatibility! +// Set: +// #define IMGUI_DEFINE_MATH_OPERATORS +// To implement maths operators for ImVec2 (disabled by default to not collide with using IM_VEC2_CLASS_EXTRA along with your own math types+operators) + +/* + +Index of this file: + +// [SECTION] Header mess +// [SECTION] Forward declarations +// [SECTION] Context pointer +// [SECTION] STB libraries includes +// [SECTION] Macros +// [SECTION] Generic helpers +// [SECTION] ImDrawList support +// [SECTION] Widgets support: flags, enums, data structures +// [SECTION] Navigation support +// [SECTION] Columns support +// [SECTION] Multi-select support +// [SECTION] Docking support +// [SECTION] Viewport support +// [SECTION] Settings support +// [SECTION] Metrics, Debug +// [SECTION] Generic context hooks +// [SECTION] ImGuiContext (main imgui context) +// [SECTION] ImGuiWindowTempData, ImGuiWindow +// [SECTION] Tab bar, Tab item support +// [SECTION] Table support +// [SECTION] ImGui internal API +// [SECTION] ImFontAtlas internal API +// [SECTION] Test Engine specific hooks (imgui_test_engine) + +*/ + +#pragma once +#ifndef IMGUI_DISABLE + +//----------------------------------------------------------------------------- +// [SECTION] Header mess +//----------------------------------------------------------------------------- + +#ifndef IMGUI_VERSION +#include "imgui.h" +#endif + +#include // FILE*, sscanf +#include // NULL, malloc, free, qsort, atoi, atof +#include // sqrtf, fabsf, fmodf, powf, floorf, ceilf, cosf, sinf +#include // INT_MIN, INT_MAX + +// Enable SSE intrinsics if available +#if (defined __SSE__ || defined __x86_64__ || defined _M_X64) && !defined(IMGUI_DISABLE_SSE) +#define IMGUI_ENABLE_SSE +#include +#endif + +// Visual Studio warnings +#ifdef _MSC_VER +#pragma warning (push) +#pragma warning (disable: 4251) // class 'xxx' needs to have dll-interface to be used by clients of struct 'xxx' // when IMGUI_API is set to__declspec(dllexport) +#pragma warning (disable: 26812) // The enum type 'xxx' is unscoped. Prefer 'enum class' over 'enum' (Enum.3). [MSVC Static Analyzer) +#pragma warning (disable: 26495) // [Static Analyzer] Variable 'XXX' is uninitialized. Always initialize a member variable (type.6). +#if defined(_MSC_VER) && _MSC_VER >= 1922 // MSVC 2019 16.2 or later +#pragma warning (disable: 5054) // operator '|': deprecated between enumerations of different types +#endif +#endif + +// Clang/GCC warnings with -Weverything +#if defined(__clang__) +#pragma clang diagnostic push +#if __has_warning("-Wunknown-warning-option") +#pragma clang diagnostic ignored "-Wunknown-warning-option" // warning: unknown warning group 'xxx' +#endif +#pragma clang diagnostic ignored "-Wunknown-pragmas" // warning: unknown warning group 'xxx' +#pragma clang diagnostic ignored "-Wfloat-equal" // warning: comparing floating point with == or != is unsafe // storing and comparing against same constants ok, for ImFloorSigned() +#pragma clang diagnostic ignored "-Wunused-function" // for stb_textedit.h +#pragma clang diagnostic ignored "-Wmissing-prototypes" // for stb_textedit.h +#pragma clang diagnostic ignored "-Wold-style-cast" +#pragma clang diagnostic ignored "-Wzero-as-null-pointer-constant" +#pragma clang diagnostic ignored "-Wdouble-promotion" +#pragma clang diagnostic ignored "-Wimplicit-int-float-conversion" // warning: implicit conversion from 'xxx' to 'float' may lose precision +#pragma clang diagnostic ignored "-Wmissing-noreturn" // warning: function 'xxx' could be declared with attribute 'noreturn' +#elif defined(__GNUC__) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wpragmas" // warning: unknown option after '#pragma GCC diagnostic' kind +#pragma GCC diagnostic ignored "-Wclass-memaccess" // [__GNUC__ >= 8] warning: 'memset/memcpy' clearing/writing an object of type 'xxxx' with no trivial copy-assignment; use assignment or value-initialization instead +#endif + +// Legacy defines +#ifdef IMGUI_DISABLE_FORMAT_STRING_FUNCTIONS // Renamed in 1.74 +#error Use IMGUI_DISABLE_DEFAULT_FORMAT_FUNCTIONS +#endif +#ifdef IMGUI_DISABLE_MATH_FUNCTIONS // Renamed in 1.74 +#error Use IMGUI_DISABLE_DEFAULT_MATH_FUNCTIONS +#endif + +// Enable stb_truetype by default unless FreeType is enabled. +// You can compile with both by defining both IMGUI_ENABLE_FREETYPE and IMGUI_ENABLE_STB_TRUETYPE together. +#ifndef IMGUI_ENABLE_FREETYPE +#define IMGUI_ENABLE_STB_TRUETYPE +#endif + +//----------------------------------------------------------------------------- +// [SECTION] Forward declarations +//----------------------------------------------------------------------------- + +struct ImBitVector; // Store 1-bit per value +struct ImRect; // An axis-aligned rectangle (2 points) +struct ImDrawDataBuilder; // Helper to build a ImDrawData instance +struct ImDrawListSharedData; // Data shared between all ImDrawList instances +struct ImGuiColorMod; // Stacked color modifier, backup of modified data so we can restore it +struct ImGuiContext; // Main Dear ImGui context +struct ImGuiContextHook; // Hook for extensions like ImGuiTestEngine +struct ImGuiDataTypeInfo; // Type information associated to a ImGuiDataType enum +struct ImGuiGroupData; // Stacked storage data for BeginGroup()/EndGroup() +struct ImGuiInputTextState; // Internal state of the currently focused/edited text input box +struct ImGuiLastItemData; // Status storage for last submitted items +struct ImGuiMenuColumns; // Simple column measurement, currently used for MenuItem() only +struct ImGuiNavItemData; // Result of a gamepad/keyboard directional navigation move query result +struct ImGuiMetricsConfig; // Storage for ShowMetricsWindow() and DebugNodeXXX() functions +struct ImGuiNextWindowData; // Storage for SetNextWindow** functions +struct ImGuiNextItemData; // Storage for SetNextItem** functions +struct ImGuiOldColumnData; // Storage data for a single column for legacy Columns() api +struct ImGuiOldColumns; // Storage data for a columns set for legacy Columns() api +struct ImGuiPopupData; // Storage for current popup stack +struct ImGuiSettingsHandler; // Storage for one type registered in the .ini file +struct ImGuiStackSizes; // Storage of stack sizes for debugging/asserting +struct ImGuiStyleMod; // Stacked style modifier, backup of modified data so we can restore it +struct ImGuiTabBar; // Storage for a tab bar +struct ImGuiTabItem; // Storage for a tab item (within a tab bar) +struct ImGuiTable; // Storage for a table +struct ImGuiTableColumn; // Storage for one column of a table +struct ImGuiTableTempData; // Temporary storage for one table (one per table in the stack), shared between tables. +struct ImGuiTableSettings; // Storage for a table .ini settings +struct ImGuiTableColumnsSettings; // Storage for a column .ini settings +struct ImGuiWindow; // Storage for one window +struct ImGuiWindowTempData; // Temporary storage for one window (that's the data which in theory we could ditch at the end of the frame, in practice we currently keep it for each window) +struct ImGuiWindowSettings; // Storage for a window .ini settings (we keep one of those even if the actual window wasn't instanced during this session) + +// Use your programming IDE "Go to definition" facility on the names of the center columns to find the actual flags/enum lists. +typedef int ImGuiLayoutType; // -> enum ImGuiLayoutType_ // Enum: Horizontal or vertical +typedef int ImGuiActivateFlags; // -> enum ImGuiActivateFlags_ // Flags: for navigation/focus function (will be for ActivateItem() later) +typedef int ImGuiItemFlags; // -> enum ImGuiItemFlags_ // Flags: for PushItemFlag() +typedef int ImGuiItemStatusFlags; // -> enum ImGuiItemStatusFlags_ // Flags: for DC.LastItemStatusFlags +typedef int ImGuiOldColumnFlags; // -> enum ImGuiOldColumnFlags_ // Flags: for BeginColumns() +typedef int ImGuiNavHighlightFlags; // -> enum ImGuiNavHighlightFlags_ // Flags: for RenderNavHighlight() +typedef int ImGuiNavDirSourceFlags; // -> enum ImGuiNavDirSourceFlags_ // Flags: for GetNavInputAmount2d() +typedef int ImGuiNavMoveFlags; // -> enum ImGuiNavMoveFlags_ // Flags: for navigation requests +typedef int ImGuiNextItemDataFlags; // -> enum ImGuiNextItemDataFlags_ // Flags: for SetNextItemXXX() functions +typedef int ImGuiNextWindowDataFlags; // -> enum ImGuiNextWindowDataFlags_// Flags: for SetNextWindowXXX() functions +typedef int ImGuiSeparatorFlags; // -> enum ImGuiSeparatorFlags_ // Flags: for SeparatorEx() +typedef int ImGuiTextFlags; // -> enum ImGuiTextFlags_ // Flags: for TextEx() +typedef int ImGuiTooltipFlags; // -> enum ImGuiTooltipFlags_ // Flags: for BeginTooltipEx() + +typedef void (*ImGuiErrorLogCallback)(void* user_data, const char* fmt, ...); + +//----------------------------------------------------------------------------- +// [SECTION] Context pointer +// See implementation of this variable in imgui.cpp for comments and details. +//----------------------------------------------------------------------------- + +#ifndef GImGui +extern IMGUI_API ImGuiContext* GImGui; // Current implicit context pointer +#endif + +//------------------------------------------------------------------------- +// [SECTION] STB libraries includes +//------------------------------------------------------------------------- + +namespace ImStb +{ + +#undef STB_TEXTEDIT_STRING +#undef STB_TEXTEDIT_CHARTYPE +#define STB_TEXTEDIT_STRING ImGuiInputTextState +#define STB_TEXTEDIT_CHARTYPE ImWchar +#define STB_TEXTEDIT_GETWIDTH_NEWLINE (-1.0f) +#define STB_TEXTEDIT_UNDOSTATECOUNT 99 +#define STB_TEXTEDIT_UNDOCHARCOUNT 999 +#include "imstb_textedit.h" + +} // namespace ImStb + +//----------------------------------------------------------------------------- +// [SECTION] Macros +//----------------------------------------------------------------------------- + +// Debug Logging +#ifndef IMGUI_DEBUG_LOG +#define IMGUI_DEBUG_LOG(_FMT,...) printf("[%05d] " _FMT, GImGui->FrameCount, __VA_ARGS__) +#endif + +// Debug Logging for selected systems. Remove the '((void)0) //' to enable. +//#define IMGUI_DEBUG_LOG_POPUP IMGUI_DEBUG_LOG // Enable log +//#define IMGUI_DEBUG_LOG_NAV IMGUI_DEBUG_LOG // Enable log +#define IMGUI_DEBUG_LOG_POPUP(...) ((void)0) // Disable log +#define IMGUI_DEBUG_LOG_NAV(...) ((void)0) // Disable log + +// Static Asserts +#if (__cplusplus >= 201100) || (defined(_MSVC_LANG) && _MSVC_LANG >= 201100) +#define IM_STATIC_ASSERT(_COND) static_assert(_COND, "") +#else +#define IM_STATIC_ASSERT(_COND) typedef char static_assertion_##__line__[(_COND)?1:-1] +#endif + +// "Paranoid" Debug Asserts are meant to only be enabled during specific debugging/work, otherwise would slow down the code too much. +// We currently don't have many of those so the effect is currently negligible, but onward intent to add more aggressive ones in the code. +//#define IMGUI_DEBUG_PARANOID +#ifdef IMGUI_DEBUG_PARANOID +#define IM_ASSERT_PARANOID(_EXPR) IM_ASSERT(_EXPR) +#else +#define IM_ASSERT_PARANOID(_EXPR) +#endif + +// Error handling +// Down the line in some frameworks/languages we would like to have a way to redirect those to the programmer and recover from more faults. +#ifndef IM_ASSERT_USER_ERROR +#define IM_ASSERT_USER_ERROR(_EXP,_MSG) IM_ASSERT((_EXP) && _MSG) // Recoverable User Error +#endif + +// Misc Macros +#define IM_PI 3.14159265358979323846f +#ifdef _WIN32 +#define IM_NEWLINE "\r\n" // Play it nice with Windows users (Update: since 2018-05, Notepad finally appears to support Unix-style carriage returns!) +#else +#define IM_NEWLINE "\n" +#endif +#define IM_TABSIZE (4) +#define IM_MEMALIGN(_OFF,_ALIGN) (((_OFF) + (_ALIGN - 1)) & ~(_ALIGN - 1)) // Memory align e.g. IM_ALIGN(0,4)=0, IM_ALIGN(1,4)=4, IM_ALIGN(4,4)=4, IM_ALIGN(5,4)=8 +#define IM_F32_TO_INT8_UNBOUND(_VAL) ((int)((_VAL) * 255.0f + ((_VAL)>=0 ? 0.5f : -0.5f))) // Unsaturated, for display purpose +#define IM_F32_TO_INT8_SAT(_VAL) ((int)(ImSaturate(_VAL) * 255.0f + 0.5f)) // Saturated, always output 0..255 +#define IM_FLOOR(_VAL) ((float)(int)(_VAL)) // ImFloor() is not inlined in MSVC debug builds +#define IM_ROUND(_VAL) ((float)(int)((_VAL) + 0.5f)) // + +// Enforce cdecl calling convention for functions called by the standard library, in case compilation settings changed the default to e.g. __vectorcall +#ifdef _MSC_VER +#define IMGUI_CDECL __cdecl +#else +#define IMGUI_CDECL +#endif + +// Warnings +#if defined(_MSC_VER) && !defined(__clang__) +#define IM_MSVC_WARNING_SUPPRESS(XXXX) __pragma(warning(suppress: XXXX)) +#else +#define IM_MSVC_WARNING_SUPPRESS(XXXX) +#endif + +// Debug Tools +// Use 'Metrics->Tools->Item Picker' to break into the call-stack of a specific item. +#ifndef IM_DEBUG_BREAK +#if defined(__clang__) +#define IM_DEBUG_BREAK() __builtin_debugtrap() +#elif defined (_MSC_VER) +#define IM_DEBUG_BREAK() __debugbreak() +#else +#define IM_DEBUG_BREAK() IM_ASSERT(0) // It is expected that you define IM_DEBUG_BREAK() into something that will break nicely in a debugger! +#endif +#endif // #ifndef IM_DEBUG_BREAK + +//----------------------------------------------------------------------------- +// [SECTION] Generic helpers +// Note that the ImXXX helpers functions are lower-level than ImGui functions. +// ImGui functions or the ImGui context are never called/used from other ImXXX functions. +//----------------------------------------------------------------------------- +// - Helpers: Hashing +// - Helpers: Sorting +// - Helpers: Bit manipulation +// - Helpers: String, Formatting +// - Helpers: UTF-8 <> wchar conversions +// - Helpers: ImVec2/ImVec4 operators +// - Helpers: Maths +// - Helpers: Geometry +// - Helper: ImVec1 +// - Helper: ImVec2ih +// - Helper: ImRect +// - Helper: ImBitArray +// - Helper: ImBitVector +// - Helper: ImSpan<>, ImSpanAllocator<> +// - Helper: ImPool<> +// - Helper: ImChunkStream<> +//----------------------------------------------------------------------------- + +// Helpers: Hashing +IMGUI_API ImGuiID ImHashData(const void* data, size_t data_size, ImU32 seed = 0); +IMGUI_API ImGuiID ImHashStr(const char* data, size_t data_size = 0, ImU32 seed = 0); +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS +static inline ImGuiID ImHash(const void* data, int size, ImU32 seed = 0) { return size ? ImHashData(data, (size_t)size, seed) : ImHashStr((const char*)data, 0, seed); } // [moved to ImHashStr/ImHashData in 1.68] +#endif + +// Helpers: Sorting +#define ImQsort qsort + +// Helpers: Color Blending +IMGUI_API ImU32 ImAlphaBlendColors(ImU32 col_a, ImU32 col_b); + +// Helpers: Bit manipulation +static inline bool ImIsPowerOfTwo(int v) { return v != 0 && (v & (v - 1)) == 0; } +static inline bool ImIsPowerOfTwo(ImU64 v) { return v != 0 && (v & (v - 1)) == 0; } +static inline int ImUpperPowerOfTwo(int v) { v--; v |= v >> 1; v |= v >> 2; v |= v >> 4; v |= v >> 8; v |= v >> 16; v++; return v; } + +// Helpers: String, Formatting +IMGUI_API int ImStricmp(const char* str1, const char* str2); +IMGUI_API int ImStrnicmp(const char* str1, const char* str2, size_t count); +IMGUI_API void ImStrncpy(char* dst, const char* src, size_t count); +IMGUI_API char* ImStrdup(const char* str); +IMGUI_API char* ImStrdupcpy(char* dst, size_t* p_dst_size, const char* str); +IMGUI_API const char* ImStrchrRange(const char* str_begin, const char* str_end, char c); +IMGUI_API int ImStrlenW(const ImWchar* str); +IMGUI_API const char* ImStreolRange(const char* str, const char* str_end); // End end-of-line +IMGUI_API const ImWchar*ImStrbolW(const ImWchar* buf_mid_line, const ImWchar* buf_begin); // Find beginning-of-line +IMGUI_API const char* ImStristr(const char* haystack, const char* haystack_end, const char* needle, const char* needle_end); +IMGUI_API void ImStrTrimBlanks(char* str); +IMGUI_API const char* ImStrSkipBlank(const char* str); +IMGUI_API int ImFormatString(char* buf, size_t buf_size, const char* fmt, ...) IM_FMTARGS(3); +IMGUI_API int ImFormatStringV(char* buf, size_t buf_size, const char* fmt, va_list args) IM_FMTLIST(3); +IMGUI_API const char* ImParseFormatFindStart(const char* format); +IMGUI_API const char* ImParseFormatFindEnd(const char* format); +IMGUI_API const char* ImParseFormatTrimDecorations(const char* format, char* buf, size_t buf_size); +IMGUI_API int ImParseFormatPrecision(const char* format, int default_value); +static inline bool ImCharIsBlankA(char c) { return c == ' ' || c == '\t'; } +static inline bool ImCharIsBlankW(unsigned int c) { return c == ' ' || c == '\t' || c == 0x3000; } + +// Helpers: UTF-8 <> wchar conversions +IMGUI_API const char* ImTextCharToUtf8(char out_buf[5], unsigned int c); // return out_buf +IMGUI_API int ImTextStrToUtf8(char* out_buf, int out_buf_size, const ImWchar* in_text, const ImWchar* in_text_end); // return output UTF-8 bytes count +IMGUI_API int ImTextCharFromUtf8(unsigned int* out_char, const char* in_text, const char* in_text_end); // read one character. return input UTF-8 bytes count +IMGUI_API int ImTextStrFromUtf8(ImWchar* out_buf, int out_buf_size, const char* in_text, const char* in_text_end, const char** in_remaining = NULL); // return input UTF-8 bytes count +IMGUI_API int ImTextCountCharsFromUtf8(const char* in_text, const char* in_text_end); // return number of UTF-8 code-points (NOT bytes count) +IMGUI_API int ImTextCountUtf8BytesFromChar(const char* in_text, const char* in_text_end); // return number of bytes to express one char in UTF-8 +IMGUI_API int ImTextCountUtf8BytesFromStr(const ImWchar* in_text, const ImWchar* in_text_end); // return number of bytes to express string in UTF-8 + +// Helpers: ImVec2/ImVec4 operators +// We are keeping those disabled by default so they don't leak in user space, to allow user enabling implicit cast operators between ImVec2 and their own types (using IM_VEC2_CLASS_EXTRA etc.) +// We unfortunately don't have a unary- operator for ImVec2 because this would needs to be defined inside the class itself. +#ifdef IMGUI_DEFINE_MATH_OPERATORS +IM_MSVC_RUNTIME_CHECKS_OFF +static inline ImVec2 operator*(const ImVec2& lhs, const float rhs) { return ImVec2(lhs.x * rhs, lhs.y * rhs); } +static inline ImVec2 operator/(const ImVec2& lhs, const float rhs) { return ImVec2(lhs.x / rhs, lhs.y / rhs); } +static inline ImVec2 operator+(const ImVec2& lhs, const ImVec2& rhs) { return ImVec2(lhs.x + rhs.x, lhs.y + rhs.y); } +static inline ImVec2 operator-(const ImVec2& lhs, const ImVec2& rhs) { return ImVec2(lhs.x - rhs.x, lhs.y - rhs.y); } +static inline ImVec2 operator*(const ImVec2& lhs, const ImVec2& rhs) { return ImVec2(lhs.x * rhs.x, lhs.y * rhs.y); } +static inline ImVec2 operator/(const ImVec2& lhs, const ImVec2& rhs) { return ImVec2(lhs.x / rhs.x, lhs.y / rhs.y); } +static inline ImVec2& operator*=(ImVec2& lhs, const float rhs) { lhs.x *= rhs; lhs.y *= rhs; return lhs; } +static inline ImVec2& operator/=(ImVec2& lhs, const float rhs) { lhs.x /= rhs; lhs.y /= rhs; return lhs; } +static inline ImVec2& operator+=(ImVec2& lhs, const ImVec2& rhs) { lhs.x += rhs.x; lhs.y += rhs.y; return lhs; } +static inline ImVec2& operator-=(ImVec2& lhs, const ImVec2& rhs) { lhs.x -= rhs.x; lhs.y -= rhs.y; return lhs; } +static inline ImVec2& operator*=(ImVec2& lhs, const ImVec2& rhs) { lhs.x *= rhs.x; lhs.y *= rhs.y; return lhs; } +static inline ImVec2& operator/=(ImVec2& lhs, const ImVec2& rhs) { lhs.x /= rhs.x; lhs.y /= rhs.y; return lhs; } +static inline ImVec4 operator+(const ImVec4& lhs, const ImVec4& rhs) { return ImVec4(lhs.x + rhs.x, lhs.y + rhs.y, lhs.z + rhs.z, lhs.w + rhs.w); } +static inline ImVec4 operator-(const ImVec4& lhs, const ImVec4& rhs) { return ImVec4(lhs.x - rhs.x, lhs.y - rhs.y, lhs.z - rhs.z, lhs.w - rhs.w); } +static inline ImVec4 operator*(const ImVec4& lhs, const ImVec4& rhs) { return ImVec4(lhs.x * rhs.x, lhs.y * rhs.y, lhs.z * rhs.z, lhs.w * rhs.w); } +IM_MSVC_RUNTIME_CHECKS_RESTORE +#endif + +// Helpers: File System +#ifdef IMGUI_DISABLE_FILE_FUNCTIONS +#define IMGUI_DISABLE_DEFAULT_FILE_FUNCTIONS +typedef void* ImFileHandle; +static inline ImFileHandle ImFileOpen(const char*, const char*) { return NULL; } +static inline bool ImFileClose(ImFileHandle) { return false; } +static inline ImU64 ImFileGetSize(ImFileHandle) { return (ImU64)-1; } +static inline ImU64 ImFileRead(void*, ImU64, ImU64, ImFileHandle) { return 0; } +static inline ImU64 ImFileWrite(const void*, ImU64, ImU64, ImFileHandle) { return 0; } +#endif +#ifndef IMGUI_DISABLE_DEFAULT_FILE_FUNCTIONS +typedef FILE* ImFileHandle; +IMGUI_API ImFileHandle ImFileOpen(const char* filename, const char* mode); +IMGUI_API bool ImFileClose(ImFileHandle file); +IMGUI_API ImU64 ImFileGetSize(ImFileHandle file); +IMGUI_API ImU64 ImFileRead(void* data, ImU64 size, ImU64 count, ImFileHandle file); +IMGUI_API ImU64 ImFileWrite(const void* data, ImU64 size, ImU64 count, ImFileHandle file); +#else +#define IMGUI_DISABLE_TTY_FUNCTIONS // Can't use stdout, fflush if we are not using default file functions +#endif +IMGUI_API void* ImFileLoadToMemory(const char* filename, const char* mode, size_t* out_file_size = NULL, int padding_bytes = 0); + +// Helpers: Maths +IM_MSVC_RUNTIME_CHECKS_OFF +// - Wrapper for standard libs functions. (Note that imgui_demo.cpp does _not_ use them to keep the code easy to copy) +#ifndef IMGUI_DISABLE_DEFAULT_MATH_FUNCTIONS +#define ImFabs(X) fabsf(X) +#define ImSqrt(X) sqrtf(X) +#define ImFmod(X, Y) fmodf((X), (Y)) +#define ImCos(X) cosf(X) +#define ImSin(X) sinf(X) +#define ImAcos(X) acosf(X) +#define ImAtan2(Y, X) atan2f((Y), (X)) +#define ImAtof(STR) atof(STR) +//#define ImFloorStd(X) floorf(X) // We use our own, see ImFloor() and ImFloorSigned() +#define ImCeil(X) ceilf(X) +static inline float ImPow(float x, float y) { return powf(x, y); } // DragBehaviorT/SliderBehaviorT uses ImPow with either float/double and need the precision +static inline double ImPow(double x, double y) { return pow(x, y); } +static inline float ImLog(float x) { return logf(x); } // DragBehaviorT/SliderBehaviorT uses ImLog with either float/double and need the precision +static inline double ImLog(double x) { return log(x); } +static inline int ImAbs(int x) { return x < 0 ? -x : x; } +static inline float ImAbs(float x) { return fabsf(x); } +static inline double ImAbs(double x) { return fabs(x); } +static inline float ImSign(float x) { return (x < 0.0f) ? -1.0f : ((x > 0.0f) ? 1.0f : 0.0f); } // Sign operator - returns -1, 0 or 1 based on sign of argument +static inline double ImSign(double x) { return (x < 0.0) ? -1.0 : ((x > 0.0) ? 1.0 : 0.0); } +#ifdef IMGUI_ENABLE_SSE +static inline float ImRsqrt(float x) { return _mm_cvtss_f32(_mm_rsqrt_ss(_mm_set_ss(x))); } +#else +static inline float ImRsqrt(float x) { return 1.0f / sqrtf(x); } +#endif +static inline double ImRsqrt(double x) { return 1.0 / sqrt(x); } +#endif +// - ImMin/ImMax/ImClamp/ImLerp/ImSwap are used by widgets which support variety of types: signed/unsigned int/long long float/double +// (Exceptionally using templates here but we could also redefine them for those types) +template static inline T ImMin(T lhs, T rhs) { return lhs < rhs ? lhs : rhs; } +template static inline T ImMax(T lhs, T rhs) { return lhs >= rhs ? lhs : rhs; } +template static inline T ImClamp(T v, T mn, T mx) { return (v < mn) ? mn : (v > mx) ? mx : v; } +template static inline T ImLerp(T a, T b, float t) { return (T)(a + (b - a) * t); } +template static inline void ImSwap(T& a, T& b) { T tmp = a; a = b; b = tmp; } +template static inline T ImAddClampOverflow(T a, T b, T mn, T mx) { if (b < 0 && (a < mn - b)) return mn; if (b > 0 && (a > mx - b)) return mx; return a + b; } +template static inline T ImSubClampOverflow(T a, T b, T mn, T mx) { if (b > 0 && (a < mn + b)) return mn; if (b < 0 && (a > mx + b)) return mx; return a - b; } +// - Misc maths helpers +static inline ImVec2 ImMin(const ImVec2& lhs, const ImVec2& rhs) { return ImVec2(lhs.x < rhs.x ? lhs.x : rhs.x, lhs.y < rhs.y ? lhs.y : rhs.y); } +static inline ImVec2 ImMax(const ImVec2& lhs, const ImVec2& rhs) { return ImVec2(lhs.x >= rhs.x ? lhs.x : rhs.x, lhs.y >= rhs.y ? lhs.y : rhs.y); } +static inline ImVec2 ImClamp(const ImVec2& v, const ImVec2& mn, ImVec2 mx) { return ImVec2((v.x < mn.x) ? mn.x : (v.x > mx.x) ? mx.x : v.x, (v.y < mn.y) ? mn.y : (v.y > mx.y) ? mx.y : v.y); } +static inline ImVec2 ImLerp(const ImVec2& a, const ImVec2& b, float t) { return ImVec2(a.x + (b.x - a.x) * t, a.y + (b.y - a.y) * t); } +static inline ImVec2 ImLerp(const ImVec2& a, const ImVec2& b, const ImVec2& t) { return ImVec2(a.x + (b.x - a.x) * t.x, a.y + (b.y - a.y) * t.y); } +static inline ImVec4 ImLerp(const ImVec4& a, const ImVec4& b, float t) { return ImVec4(a.x + (b.x - a.x) * t, a.y + (b.y - a.y) * t, a.z + (b.z - a.z) * t, a.w + (b.w - a.w) * t); } +static inline float ImSaturate(float f) { return (f < 0.0f) ? 0.0f : (f > 1.0f) ? 1.0f : f; } +static inline float ImLengthSqr(const ImVec2& lhs) { return (lhs.x * lhs.x) + (lhs.y * lhs.y); } +static inline float ImLengthSqr(const ImVec4& lhs) { return (lhs.x * lhs.x) + (lhs.y * lhs.y) + (lhs.z * lhs.z) + (lhs.w * lhs.w); } +static inline float ImInvLength(const ImVec2& lhs, float fail_value) { float d = (lhs.x * lhs.x) + (lhs.y * lhs.y); if (d > 0.0f) return ImRsqrt(d); return fail_value; } +static inline float ImFloor(float f) { return (float)(int)(f); } +static inline float ImFloorSigned(float f) { return (float)((f >= 0 || (int)f == f) ? (int)f : (int)f - 1); } // Decent replacement for floorf() +static inline ImVec2 ImFloor(const ImVec2& v) { return ImVec2((float)(int)(v.x), (float)(int)(v.y)); } +static inline int ImModPositive(int a, int b) { return (a + b) % b; } +static inline float ImDot(const ImVec2& a, const ImVec2& b) { return a.x * b.x + a.y * b.y; } +static inline ImVec2 ImRotate(const ImVec2& v, float cos_a, float sin_a) { return ImVec2(v.x * cos_a - v.y * sin_a, v.x * sin_a + v.y * cos_a); } +static inline float ImLinearSweep(float current, float target, float speed) { if (current < target) return ImMin(current + speed, target); if (current > target) return ImMax(current - speed, target); return current; } +static inline ImVec2 ImMul(const ImVec2& lhs, const ImVec2& rhs) { return ImVec2(lhs.x * rhs.x, lhs.y * rhs.y); } +IM_MSVC_RUNTIME_CHECKS_RESTORE + +// Helpers: Geometry +IMGUI_API ImVec2 ImBezierCubicCalc(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, float t); +IMGUI_API ImVec2 ImBezierCubicClosestPoint(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, const ImVec2& p, int num_segments); // For curves with explicit number of segments +IMGUI_API ImVec2 ImBezierCubicClosestPointCasteljau(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, const ImVec2& p4, const ImVec2& p, float tess_tol);// For auto-tessellated curves you can use tess_tol = style.CurveTessellationTol +IMGUI_API ImVec2 ImBezierQuadraticCalc(const ImVec2& p1, const ImVec2& p2, const ImVec2& p3, float t); +IMGUI_API ImVec2 ImLineClosestPoint(const ImVec2& a, const ImVec2& b, const ImVec2& p); +IMGUI_API bool ImTriangleContainsPoint(const ImVec2& a, const ImVec2& b, const ImVec2& c, const ImVec2& p); +IMGUI_API ImVec2 ImTriangleClosestPoint(const ImVec2& a, const ImVec2& b, const ImVec2& c, const ImVec2& p); +IMGUI_API void ImTriangleBarycentricCoords(const ImVec2& a, const ImVec2& b, const ImVec2& c, const ImVec2& p, float& out_u, float& out_v, float& out_w); +inline float ImTriangleArea(const ImVec2& a, const ImVec2& b, const ImVec2& c) { return ImFabs((a.x * (b.y - c.y)) + (b.x * (c.y - a.y)) + (c.x * (a.y - b.y))) * 0.5f; } +IMGUI_API ImGuiDir ImGetDirQuadrantFromDelta(float dx, float dy); + +// Helper: ImVec1 (1D vector) +// (this odd construct is used to facilitate the transition between 1D and 2D, and the maintenance of some branches/patches) +IM_MSVC_RUNTIME_CHECKS_OFF +struct ImVec1 +{ + float x; + ImVec1() { x = 0.0f; } + ImVec1(float _x) { x = _x; } +}; + +// Helper: ImVec2ih (2D vector, half-size integer, for long-term packed storage) +struct ImVec2ih +{ + short x, y; + ImVec2ih() { x = y = 0; } + ImVec2ih(short _x, short _y) { x = _x; y = _y; } + explicit ImVec2ih(const ImVec2& rhs) { x = (short)rhs.x; y = (short)rhs.y; } +}; + +// Helper: ImRect (2D axis aligned bounding-box) +// NB: we can't rely on ImVec2 math operators being available here! +struct IMGUI_API ImRect +{ + ImVec2 Min; // Upper-left + ImVec2 Max; // Lower-right + + ImRect() : Min(0.0f, 0.0f), Max(0.0f, 0.0f) {} + ImRect(const ImVec2& min, const ImVec2& max) : Min(min), Max(max) {} + ImRect(const ImVec4& v) : Min(v.x, v.y), Max(v.z, v.w) {} + ImRect(float x1, float y1, float x2, float y2) : Min(x1, y1), Max(x2, y2) {} + + ImVec2 GetCenter() const { return ImVec2((Min.x + Max.x) * 0.5f, (Min.y + Max.y) * 0.5f); } + ImVec2 GetSize() const { return ImVec2(Max.x - Min.x, Max.y - Min.y); } + float GetWidth() const { return Max.x - Min.x; } + float GetHeight() const { return Max.y - Min.y; } + float GetArea() const { return (Max.x - Min.x) * (Max.y - Min.y); } + ImVec2 GetTL() const { return Min; } // Top-left + ImVec2 GetTR() const { return ImVec2(Max.x, Min.y); } // Top-right + ImVec2 GetBL() const { return ImVec2(Min.x, Max.y); } // Bottom-left + ImVec2 GetBR() const { return Max; } // Bottom-right + bool Contains(const ImVec2& p) const { return p.x >= Min.x && p.y >= Min.y && p.x < Max.x && p.y < Max.y; } + bool Contains(const ImRect& r) const { return r.Min.x >= Min.x && r.Min.y >= Min.y && r.Max.x <= Max.x && r.Max.y <= Max.y; } + bool Overlaps(const ImRect& r) const { return r.Min.y < Max.y && r.Max.y > Min.y && r.Min.x < Max.x && r.Max.x > Min.x; } + void Add(const ImVec2& p) { if (Min.x > p.x) Min.x = p.x; if (Min.y > p.y) Min.y = p.y; if (Max.x < p.x) Max.x = p.x; if (Max.y < p.y) Max.y = p.y; } + void Add(const ImRect& r) { if (Min.x > r.Min.x) Min.x = r.Min.x; if (Min.y > r.Min.y) Min.y = r.Min.y; if (Max.x < r.Max.x) Max.x = r.Max.x; if (Max.y < r.Max.y) Max.y = r.Max.y; } + void Expand(const float amount) { Min.x -= amount; Min.y -= amount; Max.x += amount; Max.y += amount; } + void Expand(const ImVec2& amount) { Min.x -= amount.x; Min.y -= amount.y; Max.x += amount.x; Max.y += amount.y; } + void Translate(const ImVec2& d) { Min.x += d.x; Min.y += d.y; Max.x += d.x; Max.y += d.y; } + void TranslateX(float dx) { Min.x += dx; Max.x += dx; } + void TranslateY(float dy) { Min.y += dy; Max.y += dy; } + void ClipWith(const ImRect& r) { Min = ImMax(Min, r.Min); Max = ImMin(Max, r.Max); } // Simple version, may lead to an inverted rectangle, which is fine for Contains/Overlaps test but not for display. + void ClipWithFull(const ImRect& r) { Min = ImClamp(Min, r.Min, r.Max); Max = ImClamp(Max, r.Min, r.Max); } // Full version, ensure both points are fully clipped. + void Floor() { Min.x = IM_FLOOR(Min.x); Min.y = IM_FLOOR(Min.y); Max.x = IM_FLOOR(Max.x); Max.y = IM_FLOOR(Max.y); } + bool IsInverted() const { return Min.x > Max.x || Min.y > Max.y; } + ImVec4 ToVec4() const { return ImVec4(Min.x, Min.y, Max.x, Max.y); } +}; +IM_MSVC_RUNTIME_CHECKS_RESTORE + +// Helper: ImBitArray +inline bool ImBitArrayTestBit(const ImU32* arr, int n) { ImU32 mask = (ImU32)1 << (n & 31); return (arr[n >> 5] & mask) != 0; } +inline void ImBitArrayClearBit(ImU32* arr, int n) { ImU32 mask = (ImU32)1 << (n & 31); arr[n >> 5] &= ~mask; } +inline void ImBitArraySetBit(ImU32* arr, int n) { ImU32 mask = (ImU32)1 << (n & 31); arr[n >> 5] |= mask; } +inline void ImBitArraySetBitRange(ImU32* arr, int n, int n2) // Works on range [n..n2) +{ + n2--; + while (n <= n2) + { + int a_mod = (n & 31); + int b_mod = (n2 > (n | 31) ? 31 : (n2 & 31)) + 1; + ImU32 mask = (ImU32)(((ImU64)1 << b_mod) - 1) & ~(ImU32)(((ImU64)1 << a_mod) - 1); + arr[n >> 5] |= mask; + n = (n + 32) & ~31; + } +} + +// Helper: ImBitArray class (wrapper over ImBitArray functions) +// Store 1-bit per value. +template +struct IMGUI_API ImBitArray +{ + ImU32 Storage[(BITCOUNT + 31) >> 5]; + ImBitArray() { ClearAllBits(); } + void ClearAllBits() { memset(Storage, 0, sizeof(Storage)); } + void SetAllBits() { memset(Storage, 255, sizeof(Storage)); } + bool TestBit(int n) const { IM_ASSERT(n < BITCOUNT); return ImBitArrayTestBit(Storage, n); } + void SetBit(int n) { IM_ASSERT(n < BITCOUNT); ImBitArraySetBit(Storage, n); } + void ClearBit(int n) { IM_ASSERT(n < BITCOUNT); ImBitArrayClearBit(Storage, n); } + void SetBitRange(int n, int n2) { ImBitArraySetBitRange(Storage, n, n2); } // Works on range [n..n2) +}; + +// Helper: ImBitVector +// Store 1-bit per value. +struct IMGUI_API ImBitVector +{ + ImVector Storage; + void Create(int sz) { Storage.resize((sz + 31) >> 5); memset(Storage.Data, 0, (size_t)Storage.Size * sizeof(Storage.Data[0])); } + void Clear() { Storage.clear(); } + bool TestBit(int n) const { IM_ASSERT(n < (Storage.Size << 5)); return ImBitArrayTestBit(Storage.Data, n); } + void SetBit(int n) { IM_ASSERT(n < (Storage.Size << 5)); ImBitArraySetBit(Storage.Data, n); } + void ClearBit(int n) { IM_ASSERT(n < (Storage.Size << 5)); ImBitArrayClearBit(Storage.Data, n); } +}; + +// Helper: ImSpan<> +// Pointing to a span of data we don't own. +template +struct ImSpan +{ + T* Data; + T* DataEnd; + + // Constructors, destructor + inline ImSpan() { Data = DataEnd = NULL; } + inline ImSpan(T* data, int size) { Data = data; DataEnd = data + size; } + inline ImSpan(T* data, T* data_end) { Data = data; DataEnd = data_end; } + + inline void set(T* data, int size) { Data = data; DataEnd = data + size; } + inline void set(T* data, T* data_end) { Data = data; DataEnd = data_end; } + inline int size() const { return (int)(ptrdiff_t)(DataEnd - Data); } + inline int size_in_bytes() const { return (int)(ptrdiff_t)(DataEnd - Data) * (int)sizeof(T); } + inline T& operator[](int i) { T* p = Data + i; IM_ASSERT(p >= Data && p < DataEnd); return *p; } + inline const T& operator[](int i) const { const T* p = Data + i; IM_ASSERT(p >= Data && p < DataEnd); return *p; } + + inline T* begin() { return Data; } + inline const T* begin() const { return Data; } + inline T* end() { return DataEnd; } + inline const T* end() const { return DataEnd; } + + // Utilities + inline int index_from_ptr(const T* it) const { IM_ASSERT(it >= Data && it < DataEnd); const ptrdiff_t off = it - Data; return (int)off; } +}; + +// Helper: ImSpanAllocator<> +// Facilitate storing multiple chunks into a single large block (the "arena") +// - Usage: call Reserve() N times, allocate GetArenaSizeInBytes() worth, pass it to SetArenaBasePtr(), call GetSpan() N times to retrieve the aligned ranges. +template +struct ImSpanAllocator +{ + char* BasePtr; + int CurrOff; + int CurrIdx; + int Offsets[CHUNKS]; + int Sizes[CHUNKS]; + + ImSpanAllocator() { memset(this, 0, sizeof(*this)); } + inline void Reserve(int n, size_t sz, int a=4) { IM_ASSERT(n == CurrIdx && n < CHUNKS); CurrOff = IM_MEMALIGN(CurrOff, a); Offsets[n] = CurrOff; Sizes[n] = (int)sz; CurrIdx++; CurrOff += (int)sz; } + inline int GetArenaSizeInBytes() { return CurrOff; } + inline void SetArenaBasePtr(void* base_ptr) { BasePtr = (char*)base_ptr; } + inline void* GetSpanPtrBegin(int n) { IM_ASSERT(n >= 0 && n < CHUNKS && CurrIdx == CHUNKS); return (void*)(BasePtr + Offsets[n]); } + inline void* GetSpanPtrEnd(int n) { IM_ASSERT(n >= 0 && n < CHUNKS && CurrIdx == CHUNKS); return (void*)(BasePtr + Offsets[n] + Sizes[n]); } + template + inline void GetSpan(int n, ImSpan* span) { span->set((T*)GetSpanPtrBegin(n), (T*)GetSpanPtrEnd(n)); } +}; + +// Helper: ImPool<> +// Basic keyed storage for contiguous instances, slow/amortized insertion, O(1) indexable, O(Log N) queries by ID over a dense/hot buffer, +// Honor constructor/destructor. Add/remove invalidate all pointers. Indexes have the same lifetime as the associated object. +typedef int ImPoolIdx; +template +struct IMGUI_API ImPool +{ + ImVector Buf; // Contiguous data + ImGuiStorage Map; // ID->Index + ImPoolIdx FreeIdx; // Next free idx to use + ImPoolIdx AliveCount; // Number of active/alive items (for display purpose) + + ImPool() { FreeIdx = AliveCount = 0; } + ~ImPool() { Clear(); } + T* GetByKey(ImGuiID key) { int idx = Map.GetInt(key, -1); return (idx != -1) ? &Buf[idx] : NULL; } + T* GetByIndex(ImPoolIdx n) { return &Buf[n]; } + ImPoolIdx GetIndex(const T* p) const { IM_ASSERT(p >= Buf.Data && p < Buf.Data + Buf.Size); return (ImPoolIdx)(p - Buf.Data); } + T* GetOrAddByKey(ImGuiID key) { int* p_idx = Map.GetIntRef(key, -1); if (*p_idx != -1) return &Buf[*p_idx]; *p_idx = FreeIdx; return Add(); } + bool Contains(const T* p) const { return (p >= Buf.Data && p < Buf.Data + Buf.Size); } + void Clear() { for (int n = 0; n < Map.Data.Size; n++) { int idx = Map.Data[n].val_i; if (idx != -1) Buf[idx].~T(); } Map.Clear(); Buf.clear(); FreeIdx = AliveCount = 0; } + T* Add() { int idx = FreeIdx; if (idx == Buf.Size) { Buf.resize(Buf.Size + 1); FreeIdx++; } else { FreeIdx = *(int*)&Buf[idx]; } IM_PLACEMENT_NEW(&Buf[idx]) T(); AliveCount++; return &Buf[idx]; } + void Remove(ImGuiID key, const T* p) { Remove(key, GetIndex(p)); } + void Remove(ImGuiID key, ImPoolIdx idx) { Buf[idx].~T(); *(int*)&Buf[idx] = FreeIdx; FreeIdx = idx; Map.SetInt(key, -1); AliveCount--; } + void Reserve(int capacity) { Buf.reserve(capacity); Map.Data.reserve(capacity); } + + // To iterate a ImPool: for (int n = 0; n < pool.GetMapSize(); n++) if (T* t = pool.TryGetMapData(n)) { ... } + // Can be avoided if you know .Remove() has never been called on the pool, or AliveCount == GetMapSize() + int GetAliveCount() const { return AliveCount; } // Number of active/alive items in the pool (for display purpose) + int GetBufSize() const { return Buf.Size; } + int GetMapSize() const { return Map.Data.Size; } // It is the map we need iterate to find valid items, since we don't have "alive" storage anywhere + T* TryGetMapData(ImPoolIdx n) { int idx = Map.Data[n].val_i; if (idx == -1) return NULL; return GetByIndex(idx); } +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + int GetSize() { return GetMapSize(); } // For ImPlot: should use GetMapSize() from (IMGUI_VERSION_NUM >= 18304) +#endif +}; + +// Helper: ImChunkStream<> +// Build and iterate a contiguous stream of variable-sized structures. +// This is used by Settings to store persistent data while reducing allocation count. +// We store the chunk size first, and align the final size on 4 bytes boundaries. +// The tedious/zealous amount of casting is to avoid -Wcast-align warnings. +template +struct IMGUI_API ImChunkStream +{ + ImVector Buf; + + void clear() { Buf.clear(); } + bool empty() const { return Buf.Size == 0; } + int size() const { return Buf.Size; } + T* alloc_chunk(size_t sz) { size_t HDR_SZ = 4; sz = IM_MEMALIGN(HDR_SZ + sz, 4u); int off = Buf.Size; Buf.resize(off + (int)sz); ((int*)(void*)(Buf.Data + off))[0] = (int)sz; return (T*)(void*)(Buf.Data + off + (int)HDR_SZ); } + T* begin() { size_t HDR_SZ = 4; if (!Buf.Data) return NULL; return (T*)(void*)(Buf.Data + HDR_SZ); } + T* next_chunk(T* p) { size_t HDR_SZ = 4; IM_ASSERT(p >= begin() && p < end()); p = (T*)(void*)((char*)(void*)p + chunk_size(p)); if (p == (T*)(void*)((char*)end() + HDR_SZ)) return (T*)0; IM_ASSERT(p < end()); return p; } + int chunk_size(const T* p) { return ((const int*)p)[-1]; } + T* end() { return (T*)(void*)(Buf.Data + Buf.Size); } + int offset_from_ptr(const T* p) { IM_ASSERT(p >= begin() && p < end()); const ptrdiff_t off = (const char*)p - Buf.Data; return (int)off; } + T* ptr_from_offset(int off) { IM_ASSERT(off >= 4 && off < Buf.Size); return (T*)(void*)(Buf.Data + off); } + void swap(ImChunkStream& rhs) { rhs.Buf.swap(Buf); } + +}; + +//----------------------------------------------------------------------------- +// [SECTION] ImDrawList support +//----------------------------------------------------------------------------- + +// ImDrawList: Helper function to calculate a circle's segment count given its radius and a "maximum error" value. +// Estimation of number of circle segment based on error is derived using method described in https://stackoverflow.com/a/2244088/15194693 +// Number of segments (N) is calculated using equation: +// N = ceil ( pi / acos(1 - error / r) ) where r > 0, error <= r +// Our equation is significantly simpler that one in the post thanks for choosing segment that is +// perpendicular to X axis. Follow steps in the article from this starting condition and you will +// will get this result. +// +// Rendering circles with an odd number of segments, while mathematically correct will produce +// asymmetrical results on the raster grid. Therefore we're rounding N to next even number (7->8, 8->8, 9->10 etc.) +// +#define IM_ROUNDUP_TO_EVEN(_V) ((((_V) + 1) / 2) * 2) +#define IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_MIN 4 +#define IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_MAX 512 +#define IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_CALC(_RAD,_MAXERROR) ImClamp(IM_ROUNDUP_TO_EVEN((int)ImCeil(IM_PI / ImAcos(1 - ImMin((_MAXERROR), (_RAD)) / (_RAD)))), IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_MIN, IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_MAX) + +// Raw equation from IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_CALC rewritten for 'r' and 'error'. +#define IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_CALC_R(_N,_MAXERROR) ((_MAXERROR) / (1 - ImCos(IM_PI / ImMax((float)(_N), IM_PI)))) +#define IM_DRAWLIST_CIRCLE_AUTO_SEGMENT_CALC_ERROR(_N,_RAD) ((1 - ImCos(IM_PI / ImMax((float)(_N), IM_PI))) / (_RAD)) + +// ImDrawList: Lookup table size for adaptive arc drawing, cover full circle. +#ifndef IM_DRAWLIST_ARCFAST_TABLE_SIZE +#define IM_DRAWLIST_ARCFAST_TABLE_SIZE 48 // Number of samples in lookup table. +#endif +#define IM_DRAWLIST_ARCFAST_SAMPLE_MAX IM_DRAWLIST_ARCFAST_TABLE_SIZE // Sample index _PathArcToFastEx() for 360 angle. + +// Data shared between all ImDrawList instances +// You may want to create your own instance of this if you want to use ImDrawList completely without ImGui. In that case, watch out for future changes to this structure. +struct IMGUI_API ImDrawListSharedData +{ + ImVec2 TexUvWhitePixel; // UV of white pixel in the atlas + ImFont* Font; // Current/default font (optional, for simplified AddText overload) + float FontSize; // Current/default font size (optional, for simplified AddText overload) + float CurveTessellationTol; // Tessellation tolerance when using PathBezierCurveTo() + float CircleSegmentMaxError; // Number of circle segments to use per pixel of radius for AddCircle() etc + ImVec4 ClipRectFullscreen; // Value for PushClipRectFullscreen() + ImDrawListFlags InitialFlags; // Initial flags at the beginning of the frame (it is possible to alter flags on a per-drawlist basis afterwards) + + // [Internal] Lookup tables + ImVec2 ArcFastVtx[IM_DRAWLIST_ARCFAST_TABLE_SIZE]; // Sample points on the quarter of the circle. + float ArcFastRadiusCutoff; // Cutoff radius after which arc drawing will fallback to slower PathArcTo() + ImU8 CircleSegmentCounts[64]; // Precomputed segment count for given radius before we calculate it dynamically (to avoid calculation overhead) + const ImVec4* TexUvLines; // UV of anti-aliased lines in the atlas + + ImDrawListSharedData(); + void SetCircleTessellationMaxError(float max_error); +}; + +struct ImDrawDataBuilder +{ + ImVector Layers[2]; // Global layers for: regular, tooltip + + void Clear() { for (int n = 0; n < IM_ARRAYSIZE(Layers); n++) Layers[n].resize(0); } + void ClearFreeMemory() { for (int n = 0; n < IM_ARRAYSIZE(Layers); n++) Layers[n].clear(); } + int GetDrawListCount() const { int count = 0; for (int n = 0; n < IM_ARRAYSIZE(Layers); n++) count += Layers[n].Size; return count; } + IMGUI_API void FlattenIntoSingleLayer(); +}; + +//----------------------------------------------------------------------------- +// [SECTION] Widgets support: flags, enums, data structures +//----------------------------------------------------------------------------- + +// Transient per-window flags, reset at the beginning of the frame. For child window, inherited from parent on first Begin(). +// This is going to be exposed in imgui.h when stabilized enough. +enum ImGuiItemFlags_ +{ + ImGuiItemFlags_None = 0, + ImGuiItemFlags_NoTabStop = 1 << 0, // false // Disable keyboard tabbing (FIXME: should merge with _NoNav) + ImGuiItemFlags_ButtonRepeat = 1 << 1, // false // Button() will return true multiple times based on io.KeyRepeatDelay and io.KeyRepeatRate settings. + ImGuiItemFlags_Disabled = 1 << 2, // false // Disable interactions but doesn't affect visuals. See BeginDisabled()/EndDisabled(). See github.com/ocornut/imgui/issues/211 + ImGuiItemFlags_NoNav = 1 << 3, // false // Disable keyboard/gamepad directional navigation (FIXME: should merge with _NoTabStop) + ImGuiItemFlags_NoNavDefaultFocus = 1 << 4, // false // Disable item being a candidate for default focus (e.g. used by title bar items) + ImGuiItemFlags_SelectableDontClosePopup = 1 << 5, // false // Disable MenuItem/Selectable() automatically closing their popup window + ImGuiItemFlags_MixedValue = 1 << 6, // false // [BETA] Represent a mixed/indeterminate value, generally multi-selection where values differ. Currently only supported by Checkbox() (later should support all sorts of widgets) + ImGuiItemFlags_ReadOnly = 1 << 7, // false // [ALPHA] Allow hovering interactions but underlying value is not changed. + ImGuiItemFlags_Inputable = 1 << 8 // false // [WIP] Auto-activate item when focused. Currently only used and supported by a few items before it becomes a generic feature. +}; + +// Storage for LastItem data +enum ImGuiItemStatusFlags_ +{ + ImGuiItemStatusFlags_None = 0, + ImGuiItemStatusFlags_HoveredRect = 1 << 0, // Mouse position is within item rectangle (does NOT mean that the window is in correct z-order and can be hovered!, this is only one part of the most-common IsItemHovered test) + ImGuiItemStatusFlags_HasDisplayRect = 1 << 1, // g.LastItemData.DisplayRect is valid + ImGuiItemStatusFlags_Edited = 1 << 2, // Value exposed by item was edited in the current frame (should match the bool return value of most widgets) + ImGuiItemStatusFlags_ToggledSelection = 1 << 3, // Set when Selectable(), TreeNode() reports toggling a selection. We can't report "Selected", only state changes, in order to easily handle clipping with less issues. + ImGuiItemStatusFlags_ToggledOpen = 1 << 4, // Set when TreeNode() reports toggling their open state. + ImGuiItemStatusFlags_HasDeactivated = 1 << 5, // Set if the widget/group is able to provide data for the ImGuiItemStatusFlags_Deactivated flag. + ImGuiItemStatusFlags_Deactivated = 1 << 6, // Only valid if ImGuiItemStatusFlags_HasDeactivated is set. + ImGuiItemStatusFlags_HoveredWindow = 1 << 7, // Override the HoveredWindow test to allow cross-window hover testing. + ImGuiItemStatusFlags_FocusedByCode = 1 << 8, // Set when the Focusable item just got focused from code. + ImGuiItemStatusFlags_FocusedByTabbing = 1 << 9, // Set when the Focusable item just got focused by Tabbing. + ImGuiItemStatusFlags_Focused = ImGuiItemStatusFlags_FocusedByCode | ImGuiItemStatusFlags_FocusedByTabbing + +#ifdef IMGUI_ENABLE_TEST_ENGINE + , // [imgui_tests only] + ImGuiItemStatusFlags_Openable = 1 << 20, // + ImGuiItemStatusFlags_Opened = 1 << 21, // + ImGuiItemStatusFlags_Checkable = 1 << 22, // + ImGuiItemStatusFlags_Checked = 1 << 23 // +#endif +}; + +// Extend ImGuiInputTextFlags_ +enum ImGuiInputTextFlagsPrivate_ +{ + // [Internal] + ImGuiInputTextFlags_Multiline = 1 << 26, // For internal use by InputTextMultiline() + ImGuiInputTextFlags_NoMarkEdited = 1 << 27, // For internal use by functions using InputText() before reformatting data + ImGuiInputTextFlags_MergedItem = 1 << 28 // For internal use by TempInputText(), will skip calling ItemAdd(). Require bounding-box to strictly match. +}; + +// Extend ImGuiButtonFlags_ +enum ImGuiButtonFlagsPrivate_ +{ + ImGuiButtonFlags_PressedOnClick = 1 << 4, // return true on click (mouse down event) + ImGuiButtonFlags_PressedOnClickRelease = 1 << 5, // [Default] return true on click + release on same item <-- this is what the majority of Button are using + ImGuiButtonFlags_PressedOnClickReleaseAnywhere = 1 << 6, // return true on click + release even if the release event is not done while hovering the item + ImGuiButtonFlags_PressedOnRelease = 1 << 7, // return true on release (default requires click+release) + ImGuiButtonFlags_PressedOnDoubleClick = 1 << 8, // return true on double-click (default requires click+release) + ImGuiButtonFlags_PressedOnDragDropHold = 1 << 9, // return true when held into while we are drag and dropping another item (used by e.g. tree nodes, collapsing headers) + ImGuiButtonFlags_Repeat = 1 << 10, // hold to repeat + ImGuiButtonFlags_FlattenChildren = 1 << 11, // allow interactions even if a child window is overlapping + ImGuiButtonFlags_AllowItemOverlap = 1 << 12, // require previous frame HoveredId to either match id or be null before being usable, use along with SetItemAllowOverlap() + ImGuiButtonFlags_DontClosePopups = 1 << 13, // disable automatically closing parent popup on press // [UNUSED] + //ImGuiButtonFlags_Disabled = 1 << 14, // disable interactions -> use BeginDisabled() or ImGuiItemFlags_Disabled + ImGuiButtonFlags_AlignTextBaseLine = 1 << 15, // vertically align button to match text baseline - ButtonEx() only // FIXME: Should be removed and handled by SmallButton(), not possible currently because of DC.CursorPosPrevLine + ImGuiButtonFlags_NoKeyModifiers = 1 << 16, // disable mouse interaction if a key modifier is held + ImGuiButtonFlags_NoHoldingActiveId = 1 << 17, // don't set ActiveId while holding the mouse (ImGuiButtonFlags_PressedOnClick only) + ImGuiButtonFlags_NoNavFocus = 1 << 18, // don't override navigation focus when activated + ImGuiButtonFlags_NoHoveredOnFocus = 1 << 19, // don't report as hovered when nav focus is on this item + ImGuiButtonFlags_PressedOnMask_ = ImGuiButtonFlags_PressedOnClick | ImGuiButtonFlags_PressedOnClickRelease | ImGuiButtonFlags_PressedOnClickReleaseAnywhere | ImGuiButtonFlags_PressedOnRelease | ImGuiButtonFlags_PressedOnDoubleClick | ImGuiButtonFlags_PressedOnDragDropHold, + ImGuiButtonFlags_PressedOnDefault_ = ImGuiButtonFlags_PressedOnClickRelease +}; + +// Extend ImGuiComboFlags_ +enum ImGuiComboFlagsPrivate_ +{ + ImGuiComboFlags_CustomPreview = 1 << 20 // enable BeginComboPreview() +}; + +// Extend ImGuiSliderFlags_ +enum ImGuiSliderFlagsPrivate_ +{ + ImGuiSliderFlags_Vertical = 1 << 20, // Should this slider be orientated vertically? + ImGuiSliderFlags_ReadOnly = 1 << 21 +}; + +// Extend ImGuiSelectableFlags_ +enum ImGuiSelectableFlagsPrivate_ +{ + // NB: need to be in sync with last value of ImGuiSelectableFlags_ + ImGuiSelectableFlags_NoHoldingActiveID = 1 << 20, + ImGuiSelectableFlags_SelectOnNav = 1 << 21, // (WIP) Auto-select when moved into. This is not exposed in public API as to handle multi-select and modifiers we will need user to explicitly control focus scope. May be replaced with a BeginSelection() API. + ImGuiSelectableFlags_SelectOnClick = 1 << 22, // Override button behavior to react on Click (default is Click+Release) + ImGuiSelectableFlags_SelectOnRelease = 1 << 23, // Override button behavior to react on Release (default is Click+Release) + ImGuiSelectableFlags_SpanAvailWidth = 1 << 24, // Span all avail width even if we declared less for layout purpose. FIXME: We may be able to remove this (added in 6251d379, 2bcafc86 for menus) + ImGuiSelectableFlags_DrawHoveredWhenHeld = 1 << 25, // Always show active when held, even is not hovered. This concept could probably be renamed/formalized somehow. + ImGuiSelectableFlags_SetNavIdOnHover = 1 << 26, // Set Nav/Focus ID on mouse hover (used by MenuItem) + ImGuiSelectableFlags_NoPadWithHalfSpacing = 1 << 27 // Disable padding each side with ItemSpacing * 0.5f +}; + +// Extend ImGuiTreeNodeFlags_ +enum ImGuiTreeNodeFlagsPrivate_ +{ + ImGuiTreeNodeFlags_ClipLabelForTrailingButton = 1 << 20 +}; + +enum ImGuiSeparatorFlags_ +{ + ImGuiSeparatorFlags_None = 0, + ImGuiSeparatorFlags_Horizontal = 1 << 0, // Axis default to current layout type, so generally Horizontal unless e.g. in a menu bar + ImGuiSeparatorFlags_Vertical = 1 << 1, + ImGuiSeparatorFlags_SpanAllColumns = 1 << 2 +}; + +enum ImGuiTextFlags_ +{ + ImGuiTextFlags_None = 0, + ImGuiTextFlags_NoWidthForLargeClippedText = 1 << 0 +}; + +enum ImGuiTooltipFlags_ +{ + ImGuiTooltipFlags_None = 0, + ImGuiTooltipFlags_OverridePreviousTooltip = 1 << 0 // Override will clear/ignore previously submitted tooltip (defaults to append) +}; + +// FIXME: this is in development, not exposed/functional as a generic feature yet. +// Horizontal/Vertical enums are fixed to 0/1 so they may be used to index ImVec2 +enum ImGuiLayoutType_ +{ + ImGuiLayoutType_Horizontal = 0, + ImGuiLayoutType_Vertical = 1 +}; + +enum ImGuiLogType +{ + ImGuiLogType_None = 0, + ImGuiLogType_TTY, + ImGuiLogType_File, + ImGuiLogType_Buffer, + ImGuiLogType_Clipboard +}; + +// X/Y enums are fixed to 0/1 so they may be used to index ImVec2 +enum ImGuiAxis +{ + ImGuiAxis_None = -1, + ImGuiAxis_X = 0, + ImGuiAxis_Y = 1 +}; + +enum ImGuiPlotType +{ + ImGuiPlotType_Lines, + ImGuiPlotType_Histogram +}; + +enum ImGuiInputSource +{ + ImGuiInputSource_None = 0, + ImGuiInputSource_Mouse, + ImGuiInputSource_Keyboard, + ImGuiInputSource_Gamepad, + ImGuiInputSource_Nav, // Stored in g.ActiveIdSource only + ImGuiInputSource_Clipboard, // Currently only used by InputText() + ImGuiInputSource_COUNT +}; + +// FIXME-NAV: Clarify/expose various repeat delay/rate +enum ImGuiInputReadMode +{ + ImGuiInputReadMode_Down, + ImGuiInputReadMode_Pressed, + ImGuiInputReadMode_Released, + ImGuiInputReadMode_Repeat, + ImGuiInputReadMode_RepeatSlow, + ImGuiInputReadMode_RepeatFast +}; + +enum ImGuiPopupPositionPolicy +{ + ImGuiPopupPositionPolicy_Default, + ImGuiPopupPositionPolicy_ComboBox, + ImGuiPopupPositionPolicy_Tooltip +}; + +struct ImGuiDataTypeTempStorage +{ + ImU8 Data[8]; // Can fit any data up to ImGuiDataType_COUNT +}; + +// Type information associated to one ImGuiDataType. Retrieve with DataTypeGetInfo(). +struct ImGuiDataTypeInfo +{ + size_t Size; // Size in bytes + const char* Name; // Short descriptive name for the type, for debugging + const char* PrintFmt; // Default printf format for the type + const char* ScanFmt; // Default scanf format for the type +}; + +// Extend ImGuiDataType_ +enum ImGuiDataTypePrivate_ +{ + ImGuiDataType_String = ImGuiDataType_COUNT + 1, + ImGuiDataType_Pointer, + ImGuiDataType_ID +}; + +// Stacked color modifier, backup of modified data so we can restore it +struct ImGuiColorMod +{ + ImGuiCol Col; + ImVec4 BackupValue; +}; + +// Stacked style modifier, backup of modified data so we can restore it. Data type inferred from the variable. +struct ImGuiStyleMod +{ + ImGuiStyleVar VarIdx; + union { int BackupInt[2]; float BackupFloat[2]; }; + ImGuiStyleMod(ImGuiStyleVar idx, int v) { VarIdx = idx; BackupInt[0] = v; } + ImGuiStyleMod(ImGuiStyleVar idx, float v) { VarIdx = idx; BackupFloat[0] = v; } + ImGuiStyleMod(ImGuiStyleVar idx, ImVec2 v) { VarIdx = idx; BackupFloat[0] = v.x; BackupFloat[1] = v.y; } +}; + +// Storage data for BeginComboPreview()/EndComboPreview() +struct IMGUI_API ImGuiComboPreviewData +{ + ImRect PreviewRect; + ImVec2 BackupCursorPos; + ImVec2 BackupCursorMaxPos; + ImVec2 BackupCursorPosPrevLine; + float BackupPrevLineTextBaseOffset; + ImGuiLayoutType BackupLayout; + + ImGuiComboPreviewData() { memset(this, 0, sizeof(*this)); } +}; + +// Stacked storage data for BeginGroup()/EndGroup() +struct IMGUI_API ImGuiGroupData +{ + ImGuiID WindowID; + ImVec2 BackupCursorPos; + ImVec2 BackupCursorMaxPos; + ImVec1 BackupIndent; + ImVec1 BackupGroupOffset; + ImVec2 BackupCurrLineSize; + float BackupCurrLineTextBaseOffset; + ImGuiID BackupActiveIdIsAlive; + bool BackupActiveIdPreviousFrameIsAlive; + bool BackupHoveredIdIsAlive; + bool EmitItem; +}; + +// Simple column measurement, currently used for MenuItem() only.. This is very short-sighted/throw-away code and NOT a generic helper. +struct IMGUI_API ImGuiMenuColumns +{ + ImU32 TotalWidth; + ImU32 NextTotalWidth; + ImU16 Spacing; + ImU16 OffsetIcon; // Always zero for now + ImU16 OffsetLabel; // Offsets are locked in Update() + ImU16 OffsetShortcut; + ImU16 OffsetMark; + ImU16 Widths[4]; // Width of: Icon, Label, Shortcut, Mark (accumulators for current frame) + + ImGuiMenuColumns() { memset(this, 0, sizeof(*this)); } + void Update(float spacing, bool window_reappearing); + float DeclColumns(float w_icon, float w_label, float w_shortcut, float w_mark); + void CalcNextTotalWidth(bool update_offsets); +}; + +// Internal state of the currently focused/edited text input box +// For a given item ID, access with ImGui::GetInputTextState() +struct IMGUI_API ImGuiInputTextState +{ + ImGuiID ID; // widget id owning the text state + int CurLenW, CurLenA; // we need to maintain our buffer length in both UTF-8 and wchar format. UTF-8 length is valid even if TextA is not. + ImVector TextW; // edit buffer, we need to persist but can't guarantee the persistence of the user-provided buffer. so we copy into own buffer. + ImVector TextA; // temporary UTF8 buffer for callbacks and other operations. this is not updated in every code-path! size=capacity. + ImVector InitialTextA; // backup of end-user buffer at the time of focus (in UTF-8, unaltered) + bool TextAIsValid; // temporary UTF8 buffer is not initially valid before we make the widget active (until then we pull the data from user argument) + int BufCapacityA; // end-user buffer capacity + float ScrollX; // horizontal scrolling/offset + ImStb::STB_TexteditState Stb; // state for stb_textedit.h + float CursorAnim; // timer for cursor blink, reset on every user action so the cursor reappears immediately + bool CursorFollow; // set when we want scrolling to follow the current cursor position (not always!) + bool SelectedAllMouseLock; // after a double-click to select all, we ignore further mouse drags to update selection + bool Edited; // edited this frame + ImGuiInputTextFlags Flags; // copy of InputText() flags + ImGuiInputTextCallback UserCallback; // " + void* UserCallbackData; // " + + ImGuiInputTextState() { memset(this, 0, sizeof(*this)); } + void ClearText() { CurLenW = CurLenA = 0; TextW[0] = 0; TextA[0] = 0; CursorClamp(); } + void ClearFreeMemory() { TextW.clear(); TextA.clear(); InitialTextA.clear(); } + int GetUndoAvailCount() const { return Stb.undostate.undo_point; } + int GetRedoAvailCount() const { return STB_TEXTEDIT_UNDOSTATECOUNT - Stb.undostate.redo_point; } + void OnKeyPressed(int key); // Cannot be inline because we call in code in stb_textedit.h implementation + + // Cursor & Selection + void CursorAnimReset() { CursorAnim = -0.30f; } // After a user-input the cursor stays on for a while without blinking + void CursorClamp() { Stb.cursor = ImMin(Stb.cursor, CurLenW); Stb.select_start = ImMin(Stb.select_start, CurLenW); Stb.select_end = ImMin(Stb.select_end, CurLenW); } + bool HasSelection() const { return Stb.select_start != Stb.select_end; } + void ClearSelection() { Stb.select_start = Stb.select_end = Stb.cursor; } + int GetCursorPos() const { return Stb.cursor; } + int GetSelectionStart() const { return Stb.select_start; } + int GetSelectionEnd() const { return Stb.select_end; } + void SelectAll() { Stb.select_start = 0; Stb.cursor = Stb.select_end = CurLenW; Stb.has_preferred_x = 0; } +}; + +// Storage for current popup stack +struct ImGuiPopupData +{ + ImGuiID PopupId; // Set on OpenPopup() + ImGuiWindow* Window; // Resolved on BeginPopup() - may stay unresolved if user never calls OpenPopup() + ImGuiWindow* SourceWindow; // Set on OpenPopup() copy of NavWindow at the time of opening the popup + int OpenFrameCount; // Set on OpenPopup() + ImGuiID OpenParentId; // Set on OpenPopup(), we need this to differentiate multiple menu sets from each others (e.g. inside menu bar vs loose menu items) + ImVec2 OpenPopupPos; // Set on OpenPopup(), preferred popup position (typically == OpenMousePos when using mouse) + ImVec2 OpenMousePos; // Set on OpenPopup(), copy of mouse position at the time of opening popup + + ImGuiPopupData() { memset(this, 0, sizeof(*this)); OpenFrameCount = -1; } +}; + +enum ImGuiNextWindowDataFlags_ +{ + ImGuiNextWindowDataFlags_None = 0, + ImGuiNextWindowDataFlags_HasPos = 1 << 0, + ImGuiNextWindowDataFlags_HasSize = 1 << 1, + ImGuiNextWindowDataFlags_HasContentSize = 1 << 2, + ImGuiNextWindowDataFlags_HasCollapsed = 1 << 3, + ImGuiNextWindowDataFlags_HasSizeConstraint = 1 << 4, + ImGuiNextWindowDataFlags_HasFocus = 1 << 5, + ImGuiNextWindowDataFlags_HasBgAlpha = 1 << 6, + ImGuiNextWindowDataFlags_HasScroll = 1 << 7 +}; + +// Storage for SetNexWindow** functions +struct ImGuiNextWindowData +{ + ImGuiNextWindowDataFlags Flags; + ImGuiCond PosCond; + ImGuiCond SizeCond; + ImGuiCond CollapsedCond; + ImVec2 PosVal; + ImVec2 PosPivotVal; + ImVec2 SizeVal; + ImVec2 ContentSizeVal; + ImVec2 ScrollVal; + bool CollapsedVal; + ImRect SizeConstraintRect; + ImGuiSizeCallback SizeCallback; + void* SizeCallbackUserData; + float BgAlphaVal; // Override background alpha + ImVec2 MenuBarOffsetMinVal; // (Always on) This is not exposed publicly, so we don't clear it and it doesn't have a corresponding flag (could we? for consistency?) + + ImGuiNextWindowData() { memset(this, 0, sizeof(*this)); } + inline void ClearFlags() { Flags = ImGuiNextWindowDataFlags_None; } +}; + +enum ImGuiNextItemDataFlags_ +{ + ImGuiNextItemDataFlags_None = 0, + ImGuiNextItemDataFlags_HasWidth = 1 << 0, + ImGuiNextItemDataFlags_HasOpen = 1 << 1 +}; + +struct ImGuiNextItemData +{ + ImGuiNextItemDataFlags Flags; + float Width; // Set by SetNextItemWidth() + ImGuiID FocusScopeId; // Set by SetNextItemMultiSelectData() (!= 0 signify value has been set, so it's an alternate version of HasSelectionData, we don't use Flags for this because they are cleared too early. This is mostly used for debugging) + ImGuiCond OpenCond; + bool OpenVal; // Set by SetNextItemOpen() + + ImGuiNextItemData() { memset(this, 0, sizeof(*this)); } + inline void ClearFlags() { Flags = ImGuiNextItemDataFlags_None; } // Also cleared manually by ItemAdd()! +}; + +// Status storage for the last submitted item +struct ImGuiLastItemData +{ + ImGuiID ID; + ImGuiItemFlags InFlags; // See ImGuiItemFlags_ + ImGuiItemStatusFlags StatusFlags; // See ImGuiItemStatusFlags_ + ImRect Rect; // Full rectangle + ImRect NavRect; // Navigation scoring rectangle (not displayed) + ImRect DisplayRect; // Display rectangle (only if ImGuiItemStatusFlags_HasDisplayRect is set) + + ImGuiLastItemData() { memset(this, 0, sizeof(*this)); } +}; + +struct IMGUI_API ImGuiStackSizes +{ + short SizeOfIDStack; + short SizeOfColorStack; + short SizeOfStyleVarStack; + short SizeOfFontStack; + short SizeOfFocusScopeStack; + short SizeOfGroupStack; + short SizeOfItemFlagsStack; + short SizeOfBeginPopupStack; + short SizeOfDisabledStack; + + ImGuiStackSizes() { memset(this, 0, sizeof(*this)); } + void SetToCurrentState(); + void CompareWithCurrentState(); +}; + +// Data saved for each window pushed into the stack +struct ImGuiWindowStackData +{ + ImGuiWindow* Window; + ImGuiLastItemData ParentLastItemDataBackup; + ImGuiStackSizes StackSizesOnBegin; // Store size of various stacks for asserting +}; + +struct ImGuiShrinkWidthItem +{ + int Index; + float Width; +}; + +struct ImGuiPtrOrIndex +{ + void* Ptr; // Either field can be set, not both. e.g. Dock node tab bars are loose while BeginTabBar() ones are in a pool. + int Index; // Usually index in a main pool. + + ImGuiPtrOrIndex(void* ptr) { Ptr = ptr; Index = -1; } + ImGuiPtrOrIndex(int index) { Ptr = NULL; Index = index; } +}; + +//----------------------------------------------------------------------------- +// [SECTION] Navigation support +//----------------------------------------------------------------------------- + +enum ImGuiActivateFlags_ +{ + ImGuiActivateFlags_None = 0, + ImGuiActivateFlags_PreferInput = 1 << 0, // Favor activation that requires keyboard text input (e.g. for Slider/Drag). Default if keyboard is available. + ImGuiActivateFlags_PreferTweak = 1 << 1, // Favor activation for tweaking with arrows or gamepad (e.g. for Slider/Drag). Default if keyboard is not available. + ImGuiActivateFlags_TryToPreserveState = 1 << 2 // Request widget to preserve state if it can (e.g. InputText will try to preserve cursor/selection) +}; + +enum ImGuiNavHighlightFlags_ +{ + ImGuiNavHighlightFlags_None = 0, + ImGuiNavHighlightFlags_TypeDefault = 1 << 0, + ImGuiNavHighlightFlags_TypeThin = 1 << 1, + ImGuiNavHighlightFlags_AlwaysDraw = 1 << 2, // Draw rectangular highlight if (g.NavId == id) _even_ when using the mouse. + ImGuiNavHighlightFlags_NoRounding = 1 << 3 +}; + +enum ImGuiNavDirSourceFlags_ +{ + ImGuiNavDirSourceFlags_None = 0, + ImGuiNavDirSourceFlags_Keyboard = 1 << 0, + ImGuiNavDirSourceFlags_PadDPad = 1 << 1, + ImGuiNavDirSourceFlags_PadLStick = 1 << 2 +}; + +enum ImGuiNavMoveFlags_ +{ + ImGuiNavMoveFlags_None = 0, + ImGuiNavMoveFlags_LoopX = 1 << 0, // On failed request, restart from opposite side + ImGuiNavMoveFlags_LoopY = 1 << 1, + ImGuiNavMoveFlags_WrapX = 1 << 2, // On failed request, request from opposite side one line down (when NavDir==right) or one line up (when NavDir==left) + ImGuiNavMoveFlags_WrapY = 1 << 3, // This is not super useful but provided for completeness + ImGuiNavMoveFlags_AllowCurrentNavId = 1 << 4, // Allow scoring and considering the current NavId as a move target candidate. This is used when the move source is offset (e.g. pressing PageDown actually needs to send a Up move request, if we are pressing PageDown from the bottom-most item we need to stay in place) + ImGuiNavMoveFlags_AlsoScoreVisibleSet = 1 << 5, // Store alternate result in NavMoveResultLocalVisible that only comprise elements that are already fully visible (used by PageUp/PageDown) + ImGuiNavMoveFlags_ScrollToEdge = 1 << 6, + ImGuiNavMoveFlags_Forwarded = 1 << 7, + ImGuiNavMoveFlags_DebugNoResult = 1 << 8 +}; + +enum ImGuiNavLayer +{ + ImGuiNavLayer_Main = 0, // Main scrolling layer + ImGuiNavLayer_Menu = 1, // Menu layer (access with Alt/ImGuiNavInput_Menu) + ImGuiNavLayer_COUNT +}; + +struct ImGuiNavItemData +{ + ImGuiWindow* Window; // Init,Move // Best candidate window (result->ItemWindow->RootWindowForNav == request->Window) + ImGuiID ID; // Init,Move // Best candidate item ID + ImGuiID FocusScopeId; // Init,Move // Best candidate focus scope ID + ImRect RectRel; // Init,Move // Best candidate bounding box in window relative space + float DistBox; // Move // Best candidate box distance to current NavId + float DistCenter; // Move // Best candidate center distance to current NavId + float DistAxial; // Move // Best candidate axial distance to current NavId + + ImGuiNavItemData() { Clear(); } + void Clear() { Window = NULL; ID = FocusScopeId = 0; RectRel = ImRect(); DistBox = DistCenter = DistAxial = FLT_MAX; } +}; + +//----------------------------------------------------------------------------- +// [SECTION] Columns support +//----------------------------------------------------------------------------- + +// Flags for internal's BeginColumns(). Prefix using BeginTable() nowadays! +enum ImGuiOldColumnFlags_ +{ + ImGuiOldColumnFlags_None = 0, + ImGuiOldColumnFlags_NoBorder = 1 << 0, // Disable column dividers + ImGuiOldColumnFlags_NoResize = 1 << 1, // Disable resizing columns when clicking on the dividers + ImGuiOldColumnFlags_NoPreserveWidths = 1 << 2, // Disable column width preservation when adjusting columns + ImGuiOldColumnFlags_NoForceWithinWindow = 1 << 3, // Disable forcing columns to fit within window + ImGuiOldColumnFlags_GrowParentContentsSize = 1 << 4 // (WIP) Restore pre-1.51 behavior of extending the parent window contents size but _without affecting the columns width at all_. Will eventually remove. + + // Obsolete names (will be removed) +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + , ImGuiColumnsFlags_None = ImGuiOldColumnFlags_None, + ImGuiColumnsFlags_NoBorder = ImGuiOldColumnFlags_NoBorder, + ImGuiColumnsFlags_NoResize = ImGuiOldColumnFlags_NoResize, + ImGuiColumnsFlags_NoPreserveWidths = ImGuiOldColumnFlags_NoPreserveWidths, + ImGuiColumnsFlags_NoForceWithinWindow = ImGuiOldColumnFlags_NoForceWithinWindow, + ImGuiColumnsFlags_GrowParentContentsSize = ImGuiOldColumnFlags_GrowParentContentsSize +#endif +}; + +struct ImGuiOldColumnData +{ + float OffsetNorm; // Column start offset, normalized 0.0 (far left) -> 1.0 (far right) + float OffsetNormBeforeResize; + ImGuiOldColumnFlags Flags; // Not exposed + ImRect ClipRect; + + ImGuiOldColumnData() { memset(this, 0, sizeof(*this)); } +}; + +struct ImGuiOldColumns +{ + ImGuiID ID; + ImGuiOldColumnFlags Flags; + bool IsFirstFrame; + bool IsBeingResized; + int Current; + int Count; + float OffMinX, OffMaxX; // Offsets from HostWorkRect.Min.x + float LineMinY, LineMaxY; + float HostCursorPosY; // Backup of CursorPos at the time of BeginColumns() + float HostCursorMaxPosX; // Backup of CursorMaxPos at the time of BeginColumns() + ImRect HostInitialClipRect; // Backup of ClipRect at the time of BeginColumns() + ImRect HostBackupClipRect; // Backup of ClipRect during PushColumnsBackground()/PopColumnsBackground() + ImRect HostBackupParentWorkRect;//Backup of WorkRect at the time of BeginColumns() + ImVector Columns; + ImDrawListSplitter Splitter; + + ImGuiOldColumns() { memset(this, 0, sizeof(*this)); } +}; + +//----------------------------------------------------------------------------- +// [SECTION] Multi-select support +//----------------------------------------------------------------------------- + +#ifdef IMGUI_HAS_MULTI_SELECT +// +#endif // #ifdef IMGUI_HAS_MULTI_SELECT + +//----------------------------------------------------------------------------- +// [SECTION] Docking support +//----------------------------------------------------------------------------- + +#ifdef IMGUI_HAS_DOCK +// +#endif // #ifdef IMGUI_HAS_DOCK + +//----------------------------------------------------------------------------- +// [SECTION] Viewport support +//----------------------------------------------------------------------------- + +// ImGuiViewport Private/Internals fields (cardinal sin: we are using inheritance!) +// Every instance of ImGuiViewport is in fact a ImGuiViewportP. +struct ImGuiViewportP : public ImGuiViewport +{ + int DrawListsLastFrame[2]; // Last frame number the background (0) and foreground (1) draw lists were used + ImDrawList* DrawLists[2]; // Convenience background (0) and foreground (1) draw lists. We use them to draw software mouser cursor when io.MouseDrawCursor is set and to draw most debug overlays. + ImDrawData DrawDataP; + ImDrawDataBuilder DrawDataBuilder; + + ImVec2 WorkOffsetMin; // Work Area: Offset from Pos to top-left corner of Work Area. Generally (0,0) or (0,+main_menu_bar_height). Work Area is Full Area but without menu-bars/status-bars (so WorkArea always fit inside Pos/Size!) + ImVec2 WorkOffsetMax; // Work Area: Offset from Pos+Size to bottom-right corner of Work Area. Generally (0,0) or (0,-status_bar_height). + ImVec2 BuildWorkOffsetMin; // Work Area: Offset being built during current frame. Generally >= 0.0f. + ImVec2 BuildWorkOffsetMax; // Work Area: Offset being built during current frame. Generally <= 0.0f. + + ImGuiViewportP() { DrawListsLastFrame[0] = DrawListsLastFrame[1] = -1; DrawLists[0] = DrawLists[1] = NULL; } + ~ImGuiViewportP() { if (DrawLists[0]) IM_DELETE(DrawLists[0]); if (DrawLists[1]) IM_DELETE(DrawLists[1]); } + + // Calculate work rect pos/size given a set of offset (we have 1 pair of offset for rect locked from last frame data, and 1 pair for currently building rect) + ImVec2 CalcWorkRectPos(const ImVec2& off_min) const { return ImVec2(Pos.x + off_min.x, Pos.y + off_min.y); } + ImVec2 CalcWorkRectSize(const ImVec2& off_min, const ImVec2& off_max) const { return ImVec2(ImMax(0.0f, Size.x - off_min.x + off_max.x), ImMax(0.0f, Size.y - off_min.y + off_max.y)); } + void UpdateWorkRect() { WorkPos = CalcWorkRectPos(WorkOffsetMin); WorkSize = CalcWorkRectSize(WorkOffsetMin, WorkOffsetMax); } // Update public fields + + // Helpers to retrieve ImRect (we don't need to store BuildWorkRect as every access tend to change it, hence the code asymmetry) + ImRect GetMainRect() const { return ImRect(Pos.x, Pos.y, Pos.x + Size.x, Pos.y + Size.y); } + ImRect GetWorkRect() const { return ImRect(WorkPos.x, WorkPos.y, WorkPos.x + WorkSize.x, WorkPos.y + WorkSize.y); } + ImRect GetBuildWorkRect() const { ImVec2 pos = CalcWorkRectPos(BuildWorkOffsetMin); ImVec2 size = CalcWorkRectSize(BuildWorkOffsetMin, BuildWorkOffsetMax); return ImRect(pos.x, pos.y, pos.x + size.x, pos.y + size.y); } +}; + +//----------------------------------------------------------------------------- +// [SECTION] Settings support +//----------------------------------------------------------------------------- + +// Windows data saved in imgui.ini file +// Because we never destroy or rename ImGuiWindowSettings, we can store the names in a separate buffer easily. +// (this is designed to be stored in a ImChunkStream buffer, with the variable-length Name following our structure) +struct ImGuiWindowSettings +{ + ImGuiID ID; + ImVec2ih Pos; + ImVec2ih Size; + bool Collapsed; + bool WantApply; // Set when loaded from .ini data (to enable merging/loading .ini data into an already running context) + + ImGuiWindowSettings() { memset(this, 0, sizeof(*this)); } + char* GetName() { return (char*)(this + 1); } +}; + +struct ImGuiSettingsHandler +{ + const char* TypeName; // Short description stored in .ini file. Disallowed characters: '[' ']' + ImGuiID TypeHash; // == ImHashStr(TypeName) + void (*ClearAllFn)(ImGuiContext* ctx, ImGuiSettingsHandler* handler); // Clear all settings data + void (*ReadInitFn)(ImGuiContext* ctx, ImGuiSettingsHandler* handler); // Read: Called before reading (in registration order) + void* (*ReadOpenFn)(ImGuiContext* ctx, ImGuiSettingsHandler* handler, const char* name); // Read: Called when entering into a new ini entry e.g. "[Window][Name]" + void (*ReadLineFn)(ImGuiContext* ctx, ImGuiSettingsHandler* handler, void* entry, const char* line); // Read: Called for every line of text within an ini entry + void (*ApplyAllFn)(ImGuiContext* ctx, ImGuiSettingsHandler* handler); // Read: Called after reading (in registration order) + void (*WriteAllFn)(ImGuiContext* ctx, ImGuiSettingsHandler* handler, ImGuiTextBuffer* out_buf); // Write: Output every entries into 'out_buf' + void* UserData; + + ImGuiSettingsHandler() { memset(this, 0, sizeof(*this)); } +}; + +//----------------------------------------------------------------------------- +// [SECTION] Metrics, Debug +//----------------------------------------------------------------------------- + +struct ImGuiMetricsConfig +{ + bool ShowWindowsRects; + bool ShowWindowsBeginOrder; + bool ShowTablesRects; + bool ShowDrawCmdMesh; + bool ShowDrawCmdBoundingBoxes; + int ShowWindowsRectsType; + int ShowTablesRectsType; + + ImGuiMetricsConfig() + { + ShowWindowsRects = false; + ShowWindowsBeginOrder = false; + ShowTablesRects = false; + ShowDrawCmdMesh = true; + ShowDrawCmdBoundingBoxes = true; + ShowWindowsRectsType = -1; + ShowTablesRectsType = -1; + } +}; + +//----------------------------------------------------------------------------- +// [SECTION] Generic context hooks +//----------------------------------------------------------------------------- + +typedef void (*ImGuiContextHookCallback)(ImGuiContext* ctx, ImGuiContextHook* hook); +enum ImGuiContextHookType { ImGuiContextHookType_NewFramePre, ImGuiContextHookType_NewFramePost, ImGuiContextHookType_EndFramePre, ImGuiContextHookType_EndFramePost, ImGuiContextHookType_RenderPre, ImGuiContextHookType_RenderPost, ImGuiContextHookType_Shutdown, ImGuiContextHookType_PendingRemoval_ }; + +struct ImGuiContextHook +{ + ImGuiID HookId; // A unique ID assigned by AddContextHook() + ImGuiContextHookType Type; + ImGuiID Owner; + ImGuiContextHookCallback Callback; + void* UserData; + + ImGuiContextHook() { memset(this, 0, sizeof(*this)); } +}; + +//----------------------------------------------------------------------------- +// [SECTION] ImGuiContext (main imgui context) +//----------------------------------------------------------------------------- + +struct ImGuiContext +{ + bool Initialized; + bool FontAtlasOwnedByContext; // IO.Fonts-> is owned by the ImGuiContext and will be destructed along with it. + ImGuiIO IO; + ImGuiStyle Style; + ImFont* Font; // (Shortcut) == FontStack.empty() ? IO.Font : FontStack.back() + float FontSize; // (Shortcut) == FontBaseSize * g.CurrentWindow->FontWindowScale == window->FontSize(). Text height for current window. + float FontBaseSize; // (Shortcut) == IO.FontGlobalScale * Font->Scale * Font->FontSize. Base text height. + ImDrawListSharedData DrawListSharedData; + double Time; + int FrameCount; + int FrameCountEnded; + int FrameCountRendered; + bool WithinFrameScope; // Set by NewFrame(), cleared by EndFrame() + bool WithinFrameScopeWithImplicitWindow; // Set by NewFrame(), cleared by EndFrame() when the implicit debug window has been pushed + bool WithinEndChild; // Set within EndChild() + bool GcCompactAll; // Request full GC + bool TestEngineHookItems; // Will call test engine hooks: ImGuiTestEngineHook_ItemAdd(), ImGuiTestEngineHook_ItemInfo(), ImGuiTestEngineHook_Log() + ImGuiID TestEngineHookIdInfo; // Will call test engine hooks: ImGuiTestEngineHook_IdInfo() from GetID() + void* TestEngine; // Test engine user data + + // Windows state + ImVector Windows; // Windows, sorted in display order, back to front + ImVector WindowsFocusOrder; // Root windows, sorted in focus order, back to front. + ImVector WindowsTempSortBuffer; // Temporary buffer used in EndFrame() to reorder windows so parents are kept before their child + ImVector CurrentWindowStack; + ImGuiStorage WindowsById; // Map window's ImGuiID to ImGuiWindow* + int WindowsActiveCount; // Number of unique windows submitted by frame + ImVec2 WindowsHoverPadding; // Padding around resizable windows for which hovering on counts as hovering the window == ImMax(style.TouchExtraPadding, WINDOWS_HOVER_PADDING) + ImGuiWindow* CurrentWindow; // Window being drawn into + ImGuiWindow* HoveredWindow; // Window the mouse is hovering. Will typically catch mouse inputs. + ImGuiWindow* HoveredWindowUnderMovingWindow; // Hovered window ignoring MovingWindow. Only set if MovingWindow is set. + ImGuiWindow* MovingWindow; // Track the window we clicked on (in order to preserve focus). The actual window that is moved is generally MovingWindow->RootWindow. + ImGuiWindow* WheelingWindow; // Track the window we started mouse-wheeling on. Until a timer elapse or mouse has moved, generally keep scrolling the same window even if during the course of scrolling the mouse ends up hovering a child window. + ImVec2 WheelingWindowRefMousePos; + float WheelingWindowTimer; + + // Item/widgets state and tracking information + ImGuiID HoveredId; // Hovered widget, filled during the frame + ImGuiID HoveredIdPreviousFrame; + bool HoveredIdAllowOverlap; + bool HoveredIdUsingMouseWheel; // Hovered widget will use mouse wheel. Blocks scrolling the underlying window. + bool HoveredIdPreviousFrameUsingMouseWheel; + bool HoveredIdDisabled; // At least one widget passed the rect test, but has been discarded by disabled flag or popup inhibit. May be true even if HoveredId == 0. + float HoveredIdTimer; // Measure contiguous hovering time + float HoveredIdNotActiveTimer; // Measure contiguous hovering time where the item has not been active + ImGuiID ActiveId; // Active widget + ImGuiID ActiveIdIsAlive; // Active widget has been seen this frame (we can't use a bool as the ActiveId may change within the frame) + float ActiveIdTimer; + bool ActiveIdIsJustActivated; // Set at the time of activation for one frame + bool ActiveIdAllowOverlap; // Active widget allows another widget to steal active id (generally for overlapping widgets, but not always) + bool ActiveIdNoClearOnFocusLoss; // Disable losing active id if the active id window gets unfocused. + bool ActiveIdHasBeenPressedBefore; // Track whether the active id led to a press (this is to allow changing between PressOnClick and PressOnRelease without pressing twice). Used by range_select branch. + bool ActiveIdHasBeenEditedBefore; // Was the value associated to the widget Edited over the course of the Active state. + bool ActiveIdHasBeenEditedThisFrame; + bool ActiveIdUsingMouseWheel; // Active widget will want to read mouse wheel. Blocks scrolling the underlying window. + ImU32 ActiveIdUsingNavDirMask; // Active widget will want to read those nav move requests (e.g. can activate a button and move away from it) + ImU32 ActiveIdUsingNavInputMask; // Active widget will want to read those nav inputs. + ImU64 ActiveIdUsingKeyInputMask; // Active widget will want to read those key inputs. When we grow the ImGuiKey enum we'll need to either to order the enum to make useful keys come first, either redesign this into e.g. a small array. + ImVec2 ActiveIdClickOffset; // Clicked offset from upper-left corner, if applicable (currently only set by ButtonBehavior) + ImGuiWindow* ActiveIdWindow; + ImGuiInputSource ActiveIdSource; // Activating with mouse or nav (gamepad/keyboard) + int ActiveIdMouseButton; + ImGuiID ActiveIdPreviousFrame; + bool ActiveIdPreviousFrameIsAlive; + bool ActiveIdPreviousFrameHasBeenEditedBefore; + ImGuiWindow* ActiveIdPreviousFrameWindow; + ImGuiID LastActiveId; // Store the last non-zero ActiveId, useful for animation. + float LastActiveIdTimer; // Store the last non-zero ActiveId timer since the beginning of activation, useful for animation. + + // Next window/item data + ImGuiItemFlags CurrentItemFlags; // == g.ItemFlagsStack.back() + ImGuiNextItemData NextItemData; // Storage for SetNextItem** functions + ImGuiLastItemData LastItemData; // Storage for last submitted item (setup by ItemAdd) + ImGuiNextWindowData NextWindowData; // Storage for SetNextWindow** functions + + // Shared stacks + ImVector ColorStack; // Stack for PushStyleColor()/PopStyleColor() - inherited by Begin() + ImVector StyleVarStack; // Stack for PushStyleVar()/PopStyleVar() - inherited by Begin() + ImVector FontStack; // Stack for PushFont()/PopFont() - inherited by Begin() + ImVector FocusScopeStack; // Stack for PushFocusScope()/PopFocusScope() - not inherited by Begin(), unless child window + ImVectorItemFlagsStack; // Stack for PushItemFlag()/PopItemFlag() - inherited by Begin() + ImVectorGroupStack; // Stack for BeginGroup()/EndGroup() - not inherited by Begin() + ImVectorOpenPopupStack; // Which popups are open (persistent) + ImVectorBeginPopupStack; // Which level of BeginPopup() we are in (reset every frame) + + // Viewports + ImVector Viewports; // Active viewports (Size==1 in 'master' branch). Each viewports hold their copy of ImDrawData. + + // Gamepad/keyboard Navigation + ImGuiWindow* NavWindow; // Focused window for navigation. Could be called 'FocusWindow' + ImGuiID NavId; // Focused item for navigation + ImGuiID NavFocusScopeId; // Identify a selection scope (selection code often wants to "clear other items" when landing on an item of the selection set) + ImGuiID NavActivateId; // ~~ (g.ActiveId == 0) && IsNavInputPressed(ImGuiNavInput_Activate) ? NavId : 0, also set when calling ActivateItem() + ImGuiID NavActivateDownId; // ~~ IsNavInputDown(ImGuiNavInput_Activate) ? NavId : 0 + ImGuiID NavActivatePressedId; // ~~ IsNavInputPressed(ImGuiNavInput_Activate) ? NavId : 0 + ImGuiID NavActivateInputId; // ~~ IsNavInputPressed(ImGuiNavInput_Input) ? NavId : 0; ImGuiActivateFlags_PreferInput will be set and NavActivateId will be 0. + ImGuiActivateFlags NavActivateFlags; + ImGuiID NavJustTabbedId; // Just tabbed to this id. + ImGuiID NavJustMovedToId; // Just navigated to this id (result of a successfully MoveRequest). + ImGuiID NavJustMovedToFocusScopeId; // Just navigated to this focus scope id (result of a successfully MoveRequest). + ImGuiKeyModFlags NavJustMovedToKeyMods; + ImGuiID NavNextActivateId; // Set by ActivateItem(), queued until next frame. + ImGuiActivateFlags NavNextActivateFlags; + ImGuiInputSource NavInputSource; // Keyboard or Gamepad mode? THIS WILL ONLY BE None or NavGamepad or NavKeyboard. + ImGuiNavLayer NavLayer; // Layer we are navigating on. For now the system is hard-coded for 0=main contents and 1=menu/title bar, may expose layers later. + int NavIdTabCounter; // == NavWindow->DC.FocusIdxTabCounter at time of NavId processing + bool NavIdIsAlive; // Nav widget has been seen this frame ~~ NavRectRel is valid + bool NavMousePosDirty; // When set we will update mouse position if (io.ConfigFlags & ImGuiConfigFlags_NavEnableSetMousePos) if set (NB: this not enabled by default) + bool NavDisableHighlight; // When user starts using mouse, we hide gamepad/keyboard highlight (NB: but they are still available, which is why NavDisableHighlight isn't always != NavDisableMouseHover) + bool NavDisableMouseHover; // When user starts using gamepad/keyboard, we hide mouse hovering highlight until mouse is touched again. + + // Navigation: Init & Move Requests + bool NavAnyRequest; // ~~ NavMoveRequest || NavInitRequest this is to perform early out in ItemAdd() + bool NavInitRequest; // Init request for appearing window to select first item + bool NavInitRequestFromMove; + ImGuiID NavInitResultId; // Init request result (first item of the window, or one for which SetItemDefaultFocus() was called) + ImRect NavInitResultRectRel; // Init request result rectangle (relative to parent window) + bool NavMoveSubmitted; // Move request submitted, will process result on next NewFrame() + bool NavMoveScoringItems; // Move request submitted, still scoring incoming items + bool NavMoveForwardToNextFrame; + ImGuiNavMoveFlags NavMoveFlags; + ImGuiKeyModFlags NavMoveKeyMods; + ImGuiDir NavMoveDir; // Direction of the move request (left/right/up/down) + ImGuiDir NavMoveDirForDebug; + ImGuiDir NavMoveClipDir; // FIXME-NAV: Describe the purpose of this better. Might want to rename? + ImRect NavScoringRect; // Rectangle used for scoring, in screen space. Based of window->NavRectRel[], modified for directional navigation scoring. + int NavScoringDebugCount; // Metrics for debugging + ImGuiNavItemData NavMoveResultLocal; // Best move request candidate within NavWindow + ImGuiNavItemData NavMoveResultLocalVisible; // Best move request candidate within NavWindow that are mostly visible (when using ImGuiNavMoveFlags_AlsoScoreVisibleSet flag) + ImGuiNavItemData NavMoveResultOther; // Best move request candidate within NavWindow's flattened hierarchy (when using ImGuiWindowFlags_NavFlattened flag) + + // Navigation: Windowing (CTRL+TAB for list, or Menu button + keys or directional pads to move/resize) + ImGuiWindow* NavWindowingTarget; // Target window when doing CTRL+Tab (or Pad Menu + FocusPrev/Next), this window is temporarily displayed top-most! + ImGuiWindow* NavWindowingTargetAnim; // Record of last valid NavWindowingTarget until DimBgRatio and NavWindowingHighlightAlpha becomes 0.0f, so the fade-out can stay on it. + ImGuiWindow* NavWindowingListWindow; // Internal window actually listing the CTRL+Tab contents + float NavWindowingTimer; + float NavWindowingHighlightAlpha; + bool NavWindowingToggleLayer; + + // Legacy Focus/Tabbing system (older than Nav, active even if Nav is disabled, misnamed. FIXME-NAV: This needs a redesign!) + ImGuiWindow* TabFocusRequestCurrWindow; // + ImGuiWindow* TabFocusRequestNextWindow; // + int TabFocusRequestCurrCounterRegular; // Any item being requested for focus, stored as an index (we on layout to be stable between the frame pressing TAB and the next frame, semi-ouch) + int TabFocusRequestCurrCounterTabStop; // Tab item being requested for focus, stored as an index + int TabFocusRequestNextCounterRegular; // Stored for next frame + int TabFocusRequestNextCounterTabStop; // " + bool TabFocusPressed; // Set in NewFrame() when user pressed Tab + + // Render + float DimBgRatio; // 0.0..1.0 animation when fading in a dimming background (for modal window and CTRL+TAB list) + ImGuiMouseCursor MouseCursor; + + // Drag and Drop + bool DragDropActive; + bool DragDropWithinSource; // Set when within a BeginDragDropXXX/EndDragDropXXX block for a drag source. + bool DragDropWithinTarget; // Set when within a BeginDragDropXXX/EndDragDropXXX block for a drag target. + ImGuiDragDropFlags DragDropSourceFlags; + int DragDropSourceFrameCount; + int DragDropMouseButton; + ImGuiPayload DragDropPayload; + ImRect DragDropTargetRect; // Store rectangle of current target candidate (we favor small targets when overlapping) + ImGuiID DragDropTargetId; + ImGuiDragDropFlags DragDropAcceptFlags; + float DragDropAcceptIdCurrRectSurface; // Target item surface (we resolve overlapping targets by prioritizing the smaller surface) + ImGuiID DragDropAcceptIdCurr; // Target item id (set at the time of accepting the payload) + ImGuiID DragDropAcceptIdPrev; // Target item id from previous frame (we need to store this to allow for overlapping drag and drop targets) + int DragDropAcceptFrameCount; // Last time a target expressed a desire to accept the source + ImGuiID DragDropHoldJustPressedId; // Set when holding a payload just made ButtonBehavior() return a press. + ImVector DragDropPayloadBufHeap; // We don't expose the ImVector<> directly, ImGuiPayload only holds pointer+size + unsigned char DragDropPayloadBufLocal[16]; // Local buffer for small payloads + + // Table + ImGuiTable* CurrentTable; + int CurrentTableStackIdx; + ImPool Tables; + ImVector TablesTempDataStack; + ImVector TablesLastTimeActive; // Last used timestamp of each tables (SOA, for efficient GC) + ImVector DrawChannelsTempMergeBuffer; + + // Tab bars + ImGuiTabBar* CurrentTabBar; + ImPool TabBars; + ImVector CurrentTabBarStack; + ImVector ShrinkWidthBuffer; + + // Widget state + ImVec2 MouseLastValidPos; + ImGuiInputTextState InputTextState; + ImFont InputTextPasswordFont; + ImGuiID TempInputId; // Temporary text input when CTRL+clicking on a slider, etc. + ImGuiColorEditFlags ColorEditOptions; // Store user options for color edit widgets + float ColorEditLastHue; // Backup of last Hue associated to LastColor[3], so we can restore Hue in lossy RGB<>HSV round trips + float ColorEditLastSat; // Backup of last Saturation associated to LastColor[3], so we can restore Saturation in lossy RGB<>HSV round trips + float ColorEditLastColor[3]; + ImVec4 ColorPickerRef; // Initial/reference color at the time of opening the color picker. + ImGuiComboPreviewData ComboPreviewData; + float SliderCurrentAccum; // Accumulated slider delta when using navigation controls. + bool SliderCurrentAccumDirty; // Has the accumulated slider delta changed since last time we tried to apply it? + bool DragCurrentAccumDirty; + float DragCurrentAccum; // Accumulator for dragging modification. Always high-precision, not rounded by end-user precision settings + float DragSpeedDefaultRatio; // If speed == 0.0f, uses (max-min) * DragSpeedDefaultRatio + float ScrollbarClickDeltaToGrabCenter; // Distance between mouse and center of grab box, normalized in parent space. Use storage? + float DisabledAlphaBackup; // Backup for style.Alpha for BeginDisabled() + short DisabledStackSize; + short TooltipOverrideCount; + float TooltipSlowDelay; // Time before slow tooltips appears (FIXME: This is temporary until we merge in tooltip timer+priority work) + ImVector ClipboardHandlerData; // If no custom clipboard handler is defined + ImVector MenusIdSubmittedThisFrame; // A list of menu IDs that were rendered at least once + + // Platform support + ImVec2 PlatformImePos; // Cursor position request & last passed to the OS Input Method Editor + ImVec2 PlatformImeLastPos; + char PlatformLocaleDecimalPoint; // '.' or *localeconv()->decimal_point + + // Settings + bool SettingsLoaded; + float SettingsDirtyTimer; // Save .ini Settings to memory when time reaches zero + ImGuiTextBuffer SettingsIniData; // In memory .ini settings + ImVector SettingsHandlers; // List of .ini settings handlers + ImChunkStream SettingsWindows; // ImGuiWindow .ini settings entries + ImChunkStream SettingsTables; // ImGuiTable .ini settings entries + ImVector Hooks; // Hooks for extensions (e.g. test engine) + ImGuiID HookIdNext; // Next available HookId + + // Capture/Logging + bool LogEnabled; // Currently capturing + ImGuiLogType LogType; // Capture target + ImFileHandle LogFile; // If != NULL log to stdout/ file + ImGuiTextBuffer LogBuffer; // Accumulation buffer when log to clipboard. This is pointer so our GImGui static constructor doesn't call heap allocators. + const char* LogNextPrefix; + const char* LogNextSuffix; + float LogLinePosY; + bool LogLineFirstItem; + int LogDepthRef; + int LogDepthToExpand; + int LogDepthToExpandDefault; // Default/stored value for LogDepthMaxExpand if not specified in the LogXXX function call. + + // Debug Tools + bool DebugItemPickerActive; // Item picker is active (started with DebugStartItemPicker()) + ImGuiID DebugItemPickerBreakId; // Will call IM_DEBUG_BREAK() when encountering this id + ImGuiMetricsConfig DebugMetricsConfig; + + // Misc + float FramerateSecPerFrame[120]; // Calculate estimate of framerate for user over the last 2 seconds. + int FramerateSecPerFrameIdx; + int FramerateSecPerFrameCount; + float FramerateSecPerFrameAccum; + int WantCaptureMouseNextFrame; // Explicit capture via CaptureKeyboardFromApp()/CaptureMouseFromApp() sets those flags + int WantCaptureKeyboardNextFrame; + int WantTextInputNextFrame; + char TempBuffer[1024 * 3 + 1]; // Temporary text buffer + + ImGuiContext(ImFontAtlas* shared_font_atlas) + { + Initialized = false; + FontAtlasOwnedByContext = shared_font_atlas ? false : true; + Font = NULL; + FontSize = FontBaseSize = 0.0f; + IO.Fonts = shared_font_atlas ? shared_font_atlas : IM_NEW(ImFontAtlas)(); + Time = 0.0f; + FrameCount = 0; + FrameCountEnded = FrameCountRendered = -1; + WithinFrameScope = WithinFrameScopeWithImplicitWindow = WithinEndChild = false; + GcCompactAll = false; + TestEngineHookItems = false; + TestEngineHookIdInfo = 0; + TestEngine = NULL; + + WindowsActiveCount = 0; + CurrentWindow = NULL; + HoveredWindow = NULL; + HoveredWindowUnderMovingWindow = NULL; + MovingWindow = NULL; + WheelingWindow = NULL; + WheelingWindowTimer = 0.0f; + + HoveredId = HoveredIdPreviousFrame = 0; + HoveredIdAllowOverlap = false; + HoveredIdUsingMouseWheel = HoveredIdPreviousFrameUsingMouseWheel = false; + HoveredIdDisabled = false; + HoveredIdTimer = HoveredIdNotActiveTimer = 0.0f; + ActiveId = 0; + ActiveIdIsAlive = 0; + ActiveIdTimer = 0.0f; + ActiveIdIsJustActivated = false; + ActiveIdAllowOverlap = false; + ActiveIdNoClearOnFocusLoss = false; + ActiveIdHasBeenPressedBefore = false; + ActiveIdHasBeenEditedBefore = false; + ActiveIdHasBeenEditedThisFrame = false; + ActiveIdUsingMouseWheel = false; + ActiveIdUsingNavDirMask = 0x00; + ActiveIdUsingNavInputMask = 0x00; + ActiveIdUsingKeyInputMask = 0x00; + ActiveIdClickOffset = ImVec2(-1, -1); + ActiveIdWindow = NULL; + ActiveIdSource = ImGuiInputSource_None; + ActiveIdMouseButton = -1; + ActiveIdPreviousFrame = 0; + ActiveIdPreviousFrameIsAlive = false; + ActiveIdPreviousFrameHasBeenEditedBefore = false; + ActiveIdPreviousFrameWindow = NULL; + LastActiveId = 0; + LastActiveIdTimer = 0.0f; + + CurrentItemFlags = ImGuiItemFlags_None; + + NavWindow = NULL; + NavId = NavFocusScopeId = NavActivateId = NavActivateDownId = NavActivatePressedId = NavActivateInputId = 0; + NavJustTabbedId = NavJustMovedToId = NavJustMovedToFocusScopeId = NavNextActivateId = 0; + NavActivateFlags = NavNextActivateFlags = ImGuiActivateFlags_None; + NavJustMovedToKeyMods = ImGuiKeyModFlags_None; + NavInputSource = ImGuiInputSource_None; + NavLayer = ImGuiNavLayer_Main; + NavIdTabCounter = INT_MAX; + NavIdIsAlive = false; + NavMousePosDirty = false; + NavDisableHighlight = true; + NavDisableMouseHover = false; + NavAnyRequest = false; + NavInitRequest = false; + NavInitRequestFromMove = false; + NavInitResultId = 0; + NavMoveSubmitted = false; + NavMoveScoringItems = false; + NavMoveForwardToNextFrame = false; + NavMoveFlags = ImGuiNavMoveFlags_None; + NavMoveKeyMods = ImGuiKeyModFlags_None; + NavMoveDir = NavMoveDirForDebug = NavMoveClipDir = ImGuiDir_None; + NavScoringDebugCount = 0; + + NavWindowingTarget = NavWindowingTargetAnim = NavWindowingListWindow = NULL; + NavWindowingTimer = NavWindowingHighlightAlpha = 0.0f; + NavWindowingToggleLayer = false; + + TabFocusRequestCurrWindow = TabFocusRequestNextWindow = NULL; + TabFocusRequestCurrCounterRegular = TabFocusRequestCurrCounterTabStop = INT_MAX; + TabFocusRequestNextCounterRegular = TabFocusRequestNextCounterTabStop = INT_MAX; + TabFocusPressed = false; + + DimBgRatio = 0.0f; + MouseCursor = ImGuiMouseCursor_Arrow; + + DragDropActive = DragDropWithinSource = DragDropWithinTarget = false; + DragDropSourceFlags = ImGuiDragDropFlags_None; + DragDropSourceFrameCount = -1; + DragDropMouseButton = -1; + DragDropTargetId = 0; + DragDropAcceptFlags = ImGuiDragDropFlags_None; + DragDropAcceptIdCurrRectSurface = 0.0f; + DragDropAcceptIdPrev = DragDropAcceptIdCurr = 0; + DragDropAcceptFrameCount = -1; + DragDropHoldJustPressedId = 0; + memset(DragDropPayloadBufLocal, 0, sizeof(DragDropPayloadBufLocal)); + + CurrentTable = NULL; + CurrentTableStackIdx = -1; + CurrentTabBar = NULL; + + TempInputId = 0; + ColorEditOptions = ImGuiColorEditFlags_DefaultOptions_; + ColorEditLastHue = ColorEditLastSat = 0.0f; + ColorEditLastColor[0] = ColorEditLastColor[1] = ColorEditLastColor[2] = FLT_MAX; + SliderCurrentAccum = 0.0f; + SliderCurrentAccumDirty = false; + DragCurrentAccumDirty = false; + DragCurrentAccum = 0.0f; + DragSpeedDefaultRatio = 1.0f / 100.0f; + DisabledAlphaBackup = 0.0f; + DisabledStackSize = 0; + ScrollbarClickDeltaToGrabCenter = 0.0f; + TooltipOverrideCount = 0; + TooltipSlowDelay = 0.50f; + + PlatformImePos = PlatformImeLastPos = ImVec2(FLT_MAX, FLT_MAX); + PlatformLocaleDecimalPoint = '.'; + + SettingsLoaded = false; + SettingsDirtyTimer = 0.0f; + HookIdNext = 0; + + LogEnabled = false; + LogType = ImGuiLogType_None; + LogNextPrefix = LogNextSuffix = NULL; + LogFile = NULL; + LogLinePosY = FLT_MAX; + LogLineFirstItem = false; + LogDepthRef = 0; + LogDepthToExpand = LogDepthToExpandDefault = 2; + + DebugItemPickerActive = false; + DebugItemPickerBreakId = 0; + + memset(FramerateSecPerFrame, 0, sizeof(FramerateSecPerFrame)); + FramerateSecPerFrameIdx = FramerateSecPerFrameCount = 0; + FramerateSecPerFrameAccum = 0.0f; + WantCaptureMouseNextFrame = WantCaptureKeyboardNextFrame = WantTextInputNextFrame = -1; + memset(TempBuffer, 0, sizeof(TempBuffer)); + } +}; + +//----------------------------------------------------------------------------- +// [SECTION] ImGuiWindowTempData, ImGuiWindow +//----------------------------------------------------------------------------- + +// Transient per-window data, reset at the beginning of the frame. This used to be called ImGuiDrawContext, hence the DC variable name in ImGuiWindow. +// (That's theory, in practice the delimitation between ImGuiWindow and ImGuiWindowTempData is quite tenuous and could be reconsidered..) +// (This doesn't need a constructor because we zero-clear it as part of ImGuiWindow and all frame-temporary data are setup on Begin) +struct IMGUI_API ImGuiWindowTempData +{ + // Layout + ImVec2 CursorPos; // Current emitting position, in absolute coordinates. + ImVec2 CursorPosPrevLine; + ImVec2 CursorStartPos; // Initial position after Begin(), generally ~ window position + WindowPadding. + ImVec2 CursorMaxPos; // Used to implicitly calculate ContentSize at the beginning of next frame, for scrolling range and auto-resize. Always growing during the frame. + ImVec2 IdealMaxPos; // Used to implicitly calculate ContentSizeIdeal at the beginning of next frame, for auto-resize only. Always growing during the frame. + ImVec2 CurrLineSize; + ImVec2 PrevLineSize; + float CurrLineTextBaseOffset; // Baseline offset (0.0f by default on a new line, generally == style.FramePadding.y when a framed item has been added). + float PrevLineTextBaseOffset; + ImVec1 Indent; // Indentation / start position from left of window (increased by TreePush/TreePop, etc.) + ImVec1 ColumnsOffset; // Offset to the current column (if ColumnsCurrent > 0). FIXME: This and the above should be a stack to allow use cases like Tree->Column->Tree. Need revamp columns API. + ImVec1 GroupOffset; + + // Keyboard/Gamepad navigation + ImGuiNavLayer NavLayerCurrent; // Current layer, 0..31 (we currently only use 0..1) + short NavLayersActiveMask; // Which layers have been written to (result from previous frame) + short NavLayersActiveMaskNext;// Which layers have been written to (accumulator for current frame) + ImGuiID NavFocusScopeIdCurrent; // Current focus scope ID while appending + bool NavHideHighlightOneFrame; + bool NavHasScroll; // Set when scrolling can be used (ScrollMax > 0.0f) + + // Miscellaneous + bool MenuBarAppending; // FIXME: Remove this + ImVec2 MenuBarOffset; // MenuBarOffset.x is sort of equivalent of a per-layer CursorPos.x, saved/restored as we switch to the menu bar. The only situation when MenuBarOffset.y is > 0 if when (SafeAreaPadding.y > FramePadding.y), often used on TVs. + ImGuiMenuColumns MenuColumns; // Simplified columns storage for menu items measurement + int TreeDepth; // Current tree depth. + ImU32 TreeJumpToParentOnPopMask; // Store a copy of !g.NavIdIsAlive for TreeDepth 0..31.. Could be turned into a ImU64 if necessary. + ImVector ChildWindows; + ImGuiStorage* StateStorage; // Current persistent per-window storage (store e.g. tree node open/close state) + ImGuiOldColumns* CurrentColumns; // Current columns set + int CurrentTableIdx; // Current table index (into g.Tables) + ImGuiLayoutType LayoutType; + ImGuiLayoutType ParentLayoutType; // Layout type of parent window at the time of Begin() + int FocusCounterRegular; // (Legacy Focus/Tabbing system) Sequential counter, start at -1 and increase when ImGuiItemFlags_Inputable (FIXME-NAV: Needs redesign) + int FocusCounterTabStop; // (Legacy Focus/Tabbing system) Same, but only count widgets which you can Tab through. + + // Local parameters stacks + // We store the current settings outside of the vectors to increase memory locality (reduce cache misses). The vectors are rarely modified. Also it allows us to not heap allocate for short-lived windows which are not using those settings. + float ItemWidth; // Current item width (>0.0: width in pixels, <0.0: align xx pixels to the right of window). + float TextWrapPos; // Current text wrap pos. + ImVector ItemWidthStack; // Store item widths to restore (attention: .back() is not == ItemWidth) + ImVector TextWrapPosStack; // Store text wrap pos to restore (attention: .back() is not == TextWrapPos) +}; + +// Storage for one window +struct IMGUI_API ImGuiWindow +{ + char* Name; // Window name, owned by the window. + ImGuiID ID; // == ImHashStr(Name) + ImGuiWindowFlags Flags; // See enum ImGuiWindowFlags_ + ImVec2 Pos; // Position (always rounded-up to nearest pixel) + ImVec2 Size; // Current size (==SizeFull or collapsed title bar size) + ImVec2 SizeFull; // Size when non collapsed + ImVec2 ContentSize; // Size of contents/scrollable client area (calculated from the extents reach of the cursor) from previous frame. Does not include window decoration or window padding. + ImVec2 ContentSizeIdeal; + ImVec2 ContentSizeExplicit; // Size of contents/scrollable client area explicitly request by the user via SetNextWindowContentSize(). + ImVec2 WindowPadding; // Window padding at the time of Begin(). + float WindowRounding; // Window rounding at the time of Begin(). May be clamped lower to avoid rendering artifacts with title bar, menu bar etc. + float WindowBorderSize; // Window border size at the time of Begin(). + int NameBufLen; // Size of buffer storing Name. May be larger than strlen(Name)! + ImGuiID MoveId; // == window->GetID("#MOVE") + ImGuiID ChildId; // ID of corresponding item in parent window (for navigation to return from child window to parent window) + ImVec2 Scroll; + ImVec2 ScrollMax; + ImVec2 ScrollTarget; // target scroll position. stored as cursor position with scrolling canceled out, so the highest point is always 0.0f. (FLT_MAX for no change) + ImVec2 ScrollTargetCenterRatio; // 0.0f = scroll so that target position is at top, 0.5f = scroll so that target position is centered + ImVec2 ScrollTargetEdgeSnapDist; // 0.0f = no snapping, >0.0f snapping threshold + ImVec2 ScrollbarSizes; // Size taken by each scrollbars on their smaller axis. Pay attention! ScrollbarSizes.x == width of the vertical scrollbar, ScrollbarSizes.y = height of the horizontal scrollbar. + bool ScrollbarX, ScrollbarY; // Are scrollbars visible? + bool Active; // Set to true on Begin(), unless Collapsed + bool WasActive; + bool WriteAccessed; // Set to true when any widget access the current window + bool Collapsed; // Set when collapsing window to become only title-bar + bool WantCollapseToggle; + bool SkipItems; // Set when items can safely be all clipped (e.g. window not visible or collapsed) + bool Appearing; // Set during the frame where the window is appearing (or re-appearing) + bool Hidden; // Do not display (== HiddenFrames*** > 0) + bool IsFallbackWindow; // Set on the "Debug##Default" window. + bool HasCloseButton; // Set when the window has a close button (p_open != NULL) + signed char ResizeBorderHeld; // Current border being held for resize (-1: none, otherwise 0-3) + short BeginCount; // Number of Begin() during the current frame (generally 0 or 1, 1+ if appending via multiple Begin/End pairs) + short BeginOrderWithinParent; // Begin() order within immediate parent window, if we are a child window. Otherwise 0. + short BeginOrderWithinContext; // Begin() order within entire imgui context. This is mostly used for debugging submission order related issues. + short FocusOrder; // Order within WindowsFocusOrder[], altered when windows are focused. + ImGuiID PopupId; // ID in the popup stack when this window is used as a popup/menu (because we use generic Name/ID for recycling) + ImS8 AutoFitFramesX, AutoFitFramesY; + ImS8 AutoFitChildAxises; + bool AutoFitOnlyGrows; + ImGuiDir AutoPosLastDirection; + ImS8 HiddenFramesCanSkipItems; // Hide the window for N frames + ImS8 HiddenFramesCannotSkipItems; // Hide the window for N frames while allowing items to be submitted so we can measure their size + ImS8 HiddenFramesForRenderOnly; // Hide the window until frame N at Render() time only + ImS8 DisableInputsFrames; // Disable window interactions for N frames + ImGuiCond SetWindowPosAllowFlags : 8; // store acceptable condition flags for SetNextWindowPos() use. + ImGuiCond SetWindowSizeAllowFlags : 8; // store acceptable condition flags for SetNextWindowSize() use. + ImGuiCond SetWindowCollapsedAllowFlags : 8; // store acceptable condition flags for SetNextWindowCollapsed() use. + ImVec2 SetWindowPosVal; // store window position when using a non-zero Pivot (position set needs to be processed when we know the window size) + ImVec2 SetWindowPosPivot; // store window pivot for positioning. ImVec2(0, 0) when positioning from top-left corner; ImVec2(0.5f, 0.5f) for centering; ImVec2(1, 1) for bottom right. + + ImVector IDStack; // ID stack. ID are hashes seeded with the value at the top of the stack. (In theory this should be in the TempData structure) + ImGuiWindowTempData DC; // Temporary per-window data, reset at the beginning of the frame. This used to be called ImGuiDrawContext, hence the "DC" variable name. + + // The best way to understand what those rectangles are is to use the 'Metrics->Tools->Show Windows Rectangles' viewer. + // The main 'OuterRect', omitted as a field, is window->Rect(). + ImRect OuterRectClipped; // == Window->Rect() just after setup in Begin(). == window->Rect() for root window. + ImRect InnerRect; // Inner rectangle (omit title bar, menu bar, scroll bar) + ImRect InnerClipRect; // == InnerRect shrunk by WindowPadding*0.5f on each side, clipped within viewport or parent clip rect. + ImRect WorkRect; // Initially covers the whole scrolling region. Reduced by containers e.g columns/tables when active. Shrunk by WindowPadding*1.0f on each side. This is meant to replace ContentRegionRect over time (from 1.71+ onward). + ImRect ParentWorkRect; // Backup of WorkRect before entering a container such as columns/tables. Used by e.g. SpanAllColumns functions to easily access. Stacked containers are responsible for maintaining this. // FIXME-WORKRECT: Could be a stack? + ImRect ClipRect; // Current clipping/scissoring rectangle, evolve as we are using PushClipRect(), etc. == DrawList->clip_rect_stack.back(). + ImRect ContentRegionRect; // FIXME: This is currently confusing/misleading. It is essentially WorkRect but not handling of scrolling. We currently rely on it as right/bottom aligned sizing operation need some size to rely on. + ImVec2ih HitTestHoleSize; // Define an optional rectangular hole where mouse will pass-through the window. + ImVec2ih HitTestHoleOffset; + + int LastFrameActive; // Last frame number the window was Active. + float LastTimeActive; // Last timestamp the window was Active (using float as we don't need high precision there) + float ItemWidthDefault; + ImGuiStorage StateStorage; + ImVector ColumnsStorage; + float FontWindowScale; // User scale multiplier per-window, via SetWindowFontScale() + int SettingsOffset; // Offset into SettingsWindows[] (offsets are always valid as we only grow the array from the back) + + ImDrawList* DrawList; // == &DrawListInst (for backward compatibility reason with code using imgui_internal.h we keep this a pointer) + ImDrawList DrawListInst; + ImGuiWindow* ParentWindow; // If we are a child _or_ popup window, this is pointing to our parent. Otherwise NULL. + ImGuiWindow* RootWindow; // Point to ourself or first ancestor that is not a child window == Top-level window. + ImGuiWindow* RootWindowForTitleBarHighlight; // Point to ourself or first ancestor which will display TitleBgActive color when this window is active. + ImGuiWindow* RootWindowForNav; // Point to ourself or first ancestor which doesn't have the NavFlattened flag. + + ImGuiWindow* NavLastChildNavWindow; // When going to the menu bar, we remember the child window we came from. (This could probably be made implicit if we kept g.Windows sorted by last focused including child window.) + ImGuiID NavLastIds[ImGuiNavLayer_COUNT]; // Last known NavId for this window, per layer (0/1) + ImRect NavRectRel[ImGuiNavLayer_COUNT]; // Reference rectangle, in window relative space + + int MemoryDrawListIdxCapacity; // Backup of last idx/vtx count, so when waking up the window we can preallocate and avoid iterative alloc/copy + int MemoryDrawListVtxCapacity; + bool MemoryCompacted; // Set when window extraneous data have been garbage collected + +public: + ImGuiWindow(ImGuiContext* context, const char* name); + ~ImGuiWindow(); + + ImGuiID GetID(const char* str, const char* str_end = NULL); + ImGuiID GetID(const void* ptr); + ImGuiID GetID(int n); + ImGuiID GetIDNoKeepAlive(const char* str, const char* str_end = NULL); + ImGuiID GetIDNoKeepAlive(const void* ptr); + ImGuiID GetIDNoKeepAlive(int n); + ImGuiID GetIDFromRectangle(const ImRect& r_abs); + + // We don't use g.FontSize because the window may be != g.CurrentWidow. + ImRect Rect() const { return ImRect(Pos.x, Pos.y, Pos.x + Size.x, Pos.y + Size.y); } + float CalcFontSize() const { ImGuiContext& g = *GImGui; float scale = g.FontBaseSize * FontWindowScale; if (ParentWindow) scale *= ParentWindow->FontWindowScale; return scale; } + float TitleBarHeight() const { ImGuiContext& g = *GImGui; return (Flags & ImGuiWindowFlags_NoTitleBar) ? 0.0f : CalcFontSize() + g.Style.FramePadding.y * 2.0f; } + ImRect TitleBarRect() const { return ImRect(Pos, ImVec2(Pos.x + SizeFull.x, Pos.y + TitleBarHeight())); } + float MenuBarHeight() const { ImGuiContext& g = *GImGui; return (Flags & ImGuiWindowFlags_MenuBar) ? DC.MenuBarOffset.y + CalcFontSize() + g.Style.FramePadding.y * 2.0f : 0.0f; } + ImRect MenuBarRect() const { float y1 = Pos.y + TitleBarHeight(); return ImRect(Pos.x, y1, Pos.x + SizeFull.x, y1 + MenuBarHeight()); } +}; + +//----------------------------------------------------------------------------- +// [SECTION] Tab bar, Tab item support +//----------------------------------------------------------------------------- + +// Extend ImGuiTabBarFlags_ +enum ImGuiTabBarFlagsPrivate_ +{ + ImGuiTabBarFlags_DockNode = 1 << 20, // Part of a dock node [we don't use this in the master branch but it facilitate branch syncing to keep this around] + ImGuiTabBarFlags_IsFocused = 1 << 21, + ImGuiTabBarFlags_SaveSettings = 1 << 22 // FIXME: Settings are handled by the docking system, this only request the tab bar to mark settings dirty when reordering tabs +}; + +// Extend ImGuiTabItemFlags_ +enum ImGuiTabItemFlagsPrivate_ +{ + ImGuiTabItemFlags_SectionMask_ = ImGuiTabItemFlags_Leading | ImGuiTabItemFlags_Trailing, + ImGuiTabItemFlags_NoCloseButton = 1 << 20, // Track whether p_open was set or not (we'll need this info on the next frame to recompute ContentWidth during layout) + ImGuiTabItemFlags_Button = 1 << 21 // Used by TabItemButton, change the tab item behavior to mimic a button +}; + +// Storage for one active tab item (sizeof() 40 bytes) +struct ImGuiTabItem +{ + ImGuiID ID; + ImGuiTabItemFlags Flags; + int LastFrameVisible; + int LastFrameSelected; // This allows us to infer an ordered list of the last activated tabs with little maintenance + float Offset; // Position relative to beginning of tab + float Width; // Width currently displayed + float ContentWidth; // Width of label, stored during BeginTabItem() call + ImS32 NameOffset; // When Window==NULL, offset to name within parent ImGuiTabBar::TabsNames + ImS16 BeginOrder; // BeginTabItem() order, used to re-order tabs after toggling ImGuiTabBarFlags_Reorderable + ImS16 IndexDuringLayout; // Index only used during TabBarLayout() + bool WantClose; // Marked as closed by SetTabItemClosed() + + ImGuiTabItem() { memset(this, 0, sizeof(*this)); LastFrameVisible = LastFrameSelected = -1; NameOffset = -1; BeginOrder = IndexDuringLayout = -1; } +}; + +// Storage for a tab bar (sizeof() 152 bytes) +struct ImGuiTabBar +{ + ImVector Tabs; + ImGuiTabBarFlags Flags; + ImGuiID ID; // Zero for tab-bars used by docking + ImGuiID SelectedTabId; // Selected tab/window + ImGuiID NextSelectedTabId; // Next selected tab/window. Will also trigger a scrolling animation + ImGuiID VisibleTabId; // Can occasionally be != SelectedTabId (e.g. when previewing contents for CTRL+TAB preview) + int CurrFrameVisible; + int PrevFrameVisible; + ImRect BarRect; + float CurrTabsContentsHeight; + float PrevTabsContentsHeight; // Record the height of contents submitted below the tab bar + float WidthAllTabs; // Actual width of all tabs (locked during layout) + float WidthAllTabsIdeal; // Ideal width if all tabs were visible and not clipped + float ScrollingAnim; + float ScrollingTarget; + float ScrollingTargetDistToVisibility; + float ScrollingSpeed; + float ScrollingRectMinX; + float ScrollingRectMaxX; + ImGuiID ReorderRequestTabId; + ImS16 ReorderRequestOffset; + ImS8 BeginCount; + bool WantLayout; + bool VisibleTabWasSubmitted; + bool TabsAddedNew; // Set to true when a new tab item or button has been added to the tab bar during last frame + ImS16 TabsActiveCount; // Number of tabs submitted this frame. + ImS16 LastTabItemIdx; // Index of last BeginTabItem() tab for use by EndTabItem() + float ItemSpacingY; + ImVec2 FramePadding; // style.FramePadding locked at the time of BeginTabBar() + ImVec2 BackupCursorPos; + ImGuiTextBuffer TabsNames; // For non-docking tab bar we re-append names in a contiguous buffer. + + ImGuiTabBar(); + int GetTabOrder(const ImGuiTabItem* tab) const { return Tabs.index_from_ptr(tab); } + const char* GetTabName(const ImGuiTabItem* tab) const + { + IM_ASSERT(tab->NameOffset != -1 && tab->NameOffset < TabsNames.Buf.Size); + return TabsNames.Buf.Data + tab->NameOffset; + } +}; + +//----------------------------------------------------------------------------- +// [SECTION] Table support +//----------------------------------------------------------------------------- + +#define IM_COL32_DISABLE IM_COL32(0,0,0,1) // Special sentinel code which cannot be used as a regular color. +#define IMGUI_TABLE_MAX_COLUMNS 64 // sizeof(ImU64) * 8. This is solely because we frequently encode columns set in a ImU64. +#define IMGUI_TABLE_MAX_DRAW_CHANNELS (4 + 64 * 2) // See TableSetupDrawChannels() + +// Our current column maximum is 64 but we may raise that in the future. +typedef ImS8 ImGuiTableColumnIdx; +typedef ImU8 ImGuiTableDrawChannelIdx; + +// [Internal] sizeof() ~ 104 +// We use the terminology "Enabled" to refer to a column that is not Hidden by user/api. +// We use the terminology "Clipped" to refer to a column that is out of sight because of scrolling/clipping. +// This is in contrast with some user-facing api such as IsItemVisible() / IsRectVisible() which use "Visible" to mean "not clipped". +struct ImGuiTableColumn +{ + ImGuiTableColumnFlags Flags; // Flags after some patching (not directly same as provided by user). See ImGuiTableColumnFlags_ + float WidthGiven; // Final/actual width visible == (MaxX - MinX), locked in TableUpdateLayout(). May be > WidthRequest to honor minimum width, may be < WidthRequest to honor shrinking columns down in tight space. + float MinX; // Absolute positions + float MaxX; + float WidthRequest; // Master width absolute value when !(Flags & _WidthStretch). When Stretch this is derived every frame from StretchWeight in TableUpdateLayout() + float WidthAuto; // Automatic width + float StretchWeight; // Master width weight when (Flags & _WidthStretch). Often around ~1.0f initially. + float InitStretchWeightOrWidth; // Value passed to TableSetupColumn(). For Width it is a content width (_without padding_). + ImRect ClipRect; // Clipping rectangle for the column + ImGuiID UserID; // Optional, value passed to TableSetupColumn() + float WorkMinX; // Contents region min ~(MinX + CellPaddingX + CellSpacingX1) == cursor start position when entering column + float WorkMaxX; // Contents region max ~(MaxX - CellPaddingX - CellSpacingX2) + float ItemWidth; // Current item width for the column, preserved across rows + float ContentMaxXFrozen; // Contents maximum position for frozen rows (apart from headers), from which we can infer content width. + float ContentMaxXUnfrozen; + float ContentMaxXHeadersUsed; // Contents maximum position for headers rows (regardless of freezing). TableHeader() automatically softclip itself + report ideal desired size, to avoid creating extraneous draw calls + float ContentMaxXHeadersIdeal; + ImS16 NameOffset; // Offset into parent ColumnsNames[] + ImGuiTableColumnIdx DisplayOrder; // Index within Table's IndexToDisplayOrder[] (column may be reordered by users) + ImGuiTableColumnIdx IndexWithinEnabledSet; // Index within enabled/visible set (<= IndexToDisplayOrder) + ImGuiTableColumnIdx PrevEnabledColumn; // Index of prev enabled/visible column within Columns[], -1 if first enabled/visible column + ImGuiTableColumnIdx NextEnabledColumn; // Index of next enabled/visible column within Columns[], -1 if last enabled/visible column + ImGuiTableColumnIdx SortOrder; // Index of this column within sort specs, -1 if not sorting on this column, 0 for single-sort, may be >0 on multi-sort + ImGuiTableDrawChannelIdx DrawChannelCurrent; // Index within DrawSplitter.Channels[] + ImGuiTableDrawChannelIdx DrawChannelFrozen; // Draw channels for frozen rows (often headers) + ImGuiTableDrawChannelIdx DrawChannelUnfrozen; // Draw channels for unfrozen rows + bool IsEnabled; // IsUserEnabled && (Flags & ImGuiTableColumnFlags_Disabled) == 0 + bool IsUserEnabled; // Is the column not marked Hidden by the user? (unrelated to being off view, e.g. clipped by scrolling). + bool IsUserEnabledNextFrame; + bool IsVisibleX; // Is actually in view (e.g. overlapping the host window clipping rectangle, not scrolled). + bool IsVisibleY; + bool IsRequestOutput; // Return value for TableSetColumnIndex() / TableNextColumn(): whether we request user to output contents or not. + bool IsSkipItems; // Do we want item submissions to this column to be completely ignored (no layout will happen). + bool IsPreserveWidthAuto; + ImS8 NavLayerCurrent; // ImGuiNavLayer in 1 byte + ImU8 AutoFitQueue; // Queue of 8 values for the next 8 frames to request auto-fit + ImU8 CannotSkipItemsQueue; // Queue of 8 values for the next 8 frames to disable Clipped/SkipItem + ImU8 SortDirection : 2; // ImGuiSortDirection_Ascending or ImGuiSortDirection_Descending + ImU8 SortDirectionsAvailCount : 2; // Number of available sort directions (0 to 3) + ImU8 SortDirectionsAvailMask : 4; // Mask of available sort directions (1-bit each) + ImU8 SortDirectionsAvailList; // Ordered of available sort directions (2-bits each) + + ImGuiTableColumn() + { + memset(this, 0, sizeof(*this)); + StretchWeight = WidthRequest = -1.0f; + NameOffset = -1; + DisplayOrder = IndexWithinEnabledSet = -1; + PrevEnabledColumn = NextEnabledColumn = -1; + SortOrder = -1; + SortDirection = ImGuiSortDirection_None; + DrawChannelCurrent = DrawChannelFrozen = DrawChannelUnfrozen = (ImU8)-1; + } +}; + +// Transient cell data stored per row. +// sizeof() ~ 6 +struct ImGuiTableCellData +{ + ImU32 BgColor; // Actual color + ImGuiTableColumnIdx Column; // Column number +}; + +// FIXME-TABLE: more transient data could be stored in a per-stacked table structure: DrawSplitter, SortSpecs, incoming RowData +struct ImGuiTable +{ + ImGuiID ID; + ImGuiTableFlags Flags; + void* RawData; // Single allocation to hold Columns[], DisplayOrderToIndex[] and RowCellData[] + ImGuiTableTempData* TempData; // Transient data while table is active. Point within g.CurrentTableStack[] + ImSpan Columns; // Point within RawData[] + ImSpan DisplayOrderToIndex; // Point within RawData[]. Store display order of columns (when not reordered, the values are 0...Count-1) + ImSpan RowCellData; // Point within RawData[]. Store cells background requests for current row. + ImU64 EnabledMaskByDisplayOrder; // Column DisplayOrder -> IsEnabled map + ImU64 EnabledMaskByIndex; // Column Index -> IsEnabled map (== not hidden by user/api) in a format adequate for iterating column without touching cold data + ImU64 VisibleMaskByIndex; // Column Index -> IsVisibleX|IsVisibleY map (== not hidden by user/api && not hidden by scrolling/cliprect) + ImU64 RequestOutputMaskByIndex; // Column Index -> IsVisible || AutoFit (== expect user to submit items) + ImGuiTableFlags SettingsLoadedFlags; // Which data were loaded from the .ini file (e.g. when order is not altered we won't save order) + int SettingsOffset; // Offset in g.SettingsTables + int LastFrameActive; + int ColumnsCount; // Number of columns declared in BeginTable() + int CurrentRow; + int CurrentColumn; + ImS16 InstanceCurrent; // Count of BeginTable() calls with same ID in the same frame (generally 0). This is a little bit similar to BeginCount for a window, but multiple table with same ID look are multiple tables, they are just synched. + ImS16 InstanceInteracted; // Mark which instance (generally 0) of the same ID is being interacted with + float RowPosY1; + float RowPosY2; + float RowMinHeight; // Height submitted to TableNextRow() + float RowTextBaseline; + float RowIndentOffsetX; + ImGuiTableRowFlags RowFlags : 16; // Current row flags, see ImGuiTableRowFlags_ + ImGuiTableRowFlags LastRowFlags : 16; + int RowBgColorCounter; // Counter for alternating background colors (can be fast-forwarded by e.g clipper), not same as CurrentRow because header rows typically don't increase this. + ImU32 RowBgColor[2]; // Background color override for current row. + ImU32 BorderColorStrong; + ImU32 BorderColorLight; + float BorderX1; + float BorderX2; + float HostIndentX; + float MinColumnWidth; + float OuterPaddingX; + float CellPaddingX; // Padding from each borders + float CellPaddingY; + float CellSpacingX1; // Spacing between non-bordered cells + float CellSpacingX2; + float LastOuterHeight; // Outer height from last frame + float LastFirstRowHeight; // Height of first row from last frame + float InnerWidth; // User value passed to BeginTable(), see comments at the top of BeginTable() for details. + float ColumnsGivenWidth; // Sum of current column width + float ColumnsAutoFitWidth; // Sum of ideal column width in order nothing to be clipped, used for auto-fitting and content width submission in outer window + float ResizedColumnNextWidth; + float ResizeLockMinContentsX2; // Lock minimum contents width while resizing down in order to not create feedback loops. But we allow growing the table. + float RefScale; // Reference scale to be able to rescale columns on font/dpi changes. + ImRect OuterRect; // Note: for non-scrolling table, OuterRect.Max.y is often FLT_MAX until EndTable(), unless a height has been specified in BeginTable(). + ImRect InnerRect; // InnerRect but without decoration. As with OuterRect, for non-scrolling tables, InnerRect.Max.y is + ImRect WorkRect; + ImRect InnerClipRect; + ImRect BgClipRect; // We use this to cpu-clip cell background color fill + ImRect Bg0ClipRectForDrawCmd; // Actual ImDrawCmd clip rect for BG0/1 channel. This tends to be == OuterWindow->ClipRect at BeginTable() because output in BG0/BG1 is cpu-clipped + ImRect Bg2ClipRectForDrawCmd; // Actual ImDrawCmd clip rect for BG2 channel. This tends to be a correct, tight-fit, because output to BG2 are done by widgets relying on regular ClipRect. + ImRect HostClipRect; // This is used to check if we can eventually merge our columns draw calls into the current draw call of the current window. + ImRect HostBackupInnerClipRect; // Backup of InnerWindow->ClipRect during PushTableBackground()/PopTableBackground() + ImGuiWindow* OuterWindow; // Parent window for the table + ImGuiWindow* InnerWindow; // Window holding the table data (== OuterWindow or a child window) + ImGuiTextBuffer ColumnsNames; // Contiguous buffer holding columns names + ImDrawListSplitter* DrawSplitter; // Shortcut to TempData->DrawSplitter while in table. Isolate draw commands per columns to avoid switching clip rect constantly + ImGuiTableColumnSortSpecs SortSpecsSingle; + ImVector SortSpecsMulti; // FIXME-OPT: Using a small-vector pattern would be good. + ImGuiTableSortSpecs SortSpecs; // Public facing sorts specs, this is what we return in TableGetSortSpecs() + ImGuiTableColumnIdx SortSpecsCount; + ImGuiTableColumnIdx ColumnsEnabledCount; // Number of enabled columns (<= ColumnsCount) + ImGuiTableColumnIdx ColumnsEnabledFixedCount; // Number of enabled columns (<= ColumnsCount) + ImGuiTableColumnIdx DeclColumnsCount; // Count calls to TableSetupColumn() + ImGuiTableColumnIdx HoveredColumnBody; // Index of column whose visible region is being hovered. Important: == ColumnsCount when hovering empty region after the right-most column! + ImGuiTableColumnIdx HoveredColumnBorder; // Index of column whose right-border is being hovered (for resizing). + ImGuiTableColumnIdx AutoFitSingleColumn; // Index of single column requesting auto-fit. + ImGuiTableColumnIdx ResizedColumn; // Index of column being resized. Reset when InstanceCurrent==0. + ImGuiTableColumnIdx LastResizedColumn; // Index of column being resized from previous frame. + ImGuiTableColumnIdx HeldHeaderColumn; // Index of column header being held. + ImGuiTableColumnIdx ReorderColumn; // Index of column being reordered. (not cleared) + ImGuiTableColumnIdx ReorderColumnDir; // -1 or +1 + ImGuiTableColumnIdx LeftMostEnabledColumn; // Index of left-most non-hidden column. + ImGuiTableColumnIdx RightMostEnabledColumn; // Index of right-most non-hidden column. + ImGuiTableColumnIdx LeftMostStretchedColumn; // Index of left-most stretched column. + ImGuiTableColumnIdx RightMostStretchedColumn; // Index of right-most stretched column. + ImGuiTableColumnIdx ContextPopupColumn; // Column right-clicked on, of -1 if opening context menu from a neutral/empty spot + ImGuiTableColumnIdx FreezeRowsRequest; // Requested frozen rows count + ImGuiTableColumnIdx FreezeRowsCount; // Actual frozen row count (== FreezeRowsRequest, or == 0 when no scrolling offset) + ImGuiTableColumnIdx FreezeColumnsRequest; // Requested frozen columns count + ImGuiTableColumnIdx FreezeColumnsCount; // Actual frozen columns count (== FreezeColumnsRequest, or == 0 when no scrolling offset) + ImGuiTableColumnIdx RowCellDataCurrent; // Index of current RowCellData[] entry in current row + ImGuiTableDrawChannelIdx DummyDrawChannel; // Redirect non-visible columns here. + ImGuiTableDrawChannelIdx Bg2DrawChannelCurrent; // For Selectable() and other widgets drawing across columns after the freezing line. Index within DrawSplitter.Channels[] + ImGuiTableDrawChannelIdx Bg2DrawChannelUnfrozen; + bool IsLayoutLocked; // Set by TableUpdateLayout() which is called when beginning the first row. + bool IsInsideRow; // Set when inside TableBeginRow()/TableEndRow(). + bool IsInitializing; + bool IsSortSpecsDirty; + bool IsUsingHeaders; // Set when the first row had the ImGuiTableRowFlags_Headers flag. + bool IsContextPopupOpen; // Set when default context menu is open (also see: ContextPopupColumn, InstanceInteracted). + bool IsSettingsRequestLoad; + bool IsSettingsDirty; // Set when table settings have changed and needs to be reported into ImGuiTableSetttings data. + bool IsDefaultDisplayOrder; // Set when display order is unchanged from default (DisplayOrder contains 0...Count-1) + bool IsResetAllRequest; + bool IsResetDisplayOrderRequest; + bool IsUnfrozenRows; // Set when we got past the frozen row. + bool IsDefaultSizingPolicy; // Set if user didn't explicitly set a sizing policy in BeginTable() + bool MemoryCompacted; + bool HostSkipItems; // Backup of InnerWindow->SkipItem at the end of BeginTable(), because we will overwrite InnerWindow->SkipItem on a per-column basis + + IMGUI_API ImGuiTable() { memset(this, 0, sizeof(*this)); LastFrameActive = -1; } + IMGUI_API ~ImGuiTable() { IM_FREE(RawData); } +}; + +// Transient data that are only needed between BeginTable() and EndTable(), those buffers are shared (1 per level of stacked table). +// - Accessing those requires chasing an extra pointer so for very frequently used data we leave them in the main table structure. +// - We also leave out of this structure data that tend to be particularly useful for debugging/metrics. +struct ImGuiTableTempData +{ + int TableIndex; // Index in g.Tables.Buf[] pool + float LastTimeActive; // Last timestamp this structure was used + + ImVec2 UserOuterSize; // outer_size.x passed to BeginTable() + ImDrawListSplitter DrawSplitter; + + ImRect HostBackupWorkRect; // Backup of InnerWindow->WorkRect at the end of BeginTable() + ImRect HostBackupParentWorkRect; // Backup of InnerWindow->ParentWorkRect at the end of BeginTable() + ImVec2 HostBackupPrevLineSize; // Backup of InnerWindow->DC.PrevLineSize at the end of BeginTable() + ImVec2 HostBackupCurrLineSize; // Backup of InnerWindow->DC.CurrLineSize at the end of BeginTable() + ImVec2 HostBackupCursorMaxPos; // Backup of InnerWindow->DC.CursorMaxPos at the end of BeginTable() + ImVec1 HostBackupColumnsOffset; // Backup of OuterWindow->DC.ColumnsOffset at the end of BeginTable() + float HostBackupItemWidth; // Backup of OuterWindow->DC.ItemWidth at the end of BeginTable() + int HostBackupItemWidthStackSize;//Backup of OuterWindow->DC.ItemWidthStack.Size at the end of BeginTable() + + IMGUI_API ImGuiTableTempData() { memset(this, 0, sizeof(*this)); LastTimeActive = -1.0f; } +}; + +// sizeof() ~ 12 +struct ImGuiTableColumnSettings +{ + float WidthOrWeight; + ImGuiID UserID; + ImGuiTableColumnIdx Index; + ImGuiTableColumnIdx DisplayOrder; + ImGuiTableColumnIdx SortOrder; + ImU8 SortDirection : 2; + ImU8 IsEnabled : 1; // "Visible" in ini file + ImU8 IsStretch : 1; + + ImGuiTableColumnSettings() + { + WidthOrWeight = 0.0f; + UserID = 0; + Index = -1; + DisplayOrder = SortOrder = -1; + SortDirection = ImGuiSortDirection_None; + IsEnabled = 1; + IsStretch = 0; + } +}; + +// This is designed to be stored in a single ImChunkStream (1 header followed by N ImGuiTableColumnSettings, etc.) +struct ImGuiTableSettings +{ + ImGuiID ID; // Set to 0 to invalidate/delete the setting + ImGuiTableFlags SaveFlags; // Indicate data we want to save using the Resizable/Reorderable/Sortable/Hideable flags (could be using its own flags..) + float RefScale; // Reference scale to be able to rescale columns on font/dpi changes. + ImGuiTableColumnIdx ColumnsCount; + ImGuiTableColumnIdx ColumnsCountMax; // Maximum number of columns this settings instance can store, we can recycle a settings instance with lower number of columns but not higher + bool WantApply; // Set when loaded from .ini data (to enable merging/loading .ini data into an already running context) + + ImGuiTableSettings() { memset(this, 0, sizeof(*this)); } + ImGuiTableColumnSettings* GetColumnSettings() { return (ImGuiTableColumnSettings*)(this + 1); } +}; + +//----------------------------------------------------------------------------- +// [SECTION] ImGui internal API +// No guarantee of forward compatibility here! +//----------------------------------------------------------------------------- + +namespace ImGui +{ + // Windows + // We should always have a CurrentWindow in the stack (there is an implicit "Debug" window) + // If this ever crash because g.CurrentWindow is NULL it means that either + // - ImGui::NewFrame() has never been called, which is illegal. + // - You are calling ImGui functions after ImGui::EndFrame()/ImGui::Render() and before the next ImGui::NewFrame(), which is also illegal. + inline ImGuiWindow* GetCurrentWindowRead() { ImGuiContext& g = *GImGui; return g.CurrentWindow; } + inline ImGuiWindow* GetCurrentWindow() { ImGuiContext& g = *GImGui; g.CurrentWindow->WriteAccessed = true; return g.CurrentWindow; } + IMGUI_API ImGuiWindow* FindWindowByID(ImGuiID id); + IMGUI_API ImGuiWindow* FindWindowByName(const char* name); + IMGUI_API void UpdateWindowParentAndRootLinks(ImGuiWindow* window, ImGuiWindowFlags flags, ImGuiWindow* parent_window); + IMGUI_API ImVec2 CalcWindowNextAutoFitSize(ImGuiWindow* window); + IMGUI_API bool IsWindowChildOf(ImGuiWindow* window, ImGuiWindow* potential_parent); + IMGUI_API bool IsWindowAbove(ImGuiWindow* potential_above, ImGuiWindow* potential_below); + IMGUI_API bool IsWindowNavFocusable(ImGuiWindow* window); + IMGUI_API void SetWindowPos(ImGuiWindow* window, const ImVec2& pos, ImGuiCond cond = 0); + IMGUI_API void SetWindowSize(ImGuiWindow* window, const ImVec2& size, ImGuiCond cond = 0); + IMGUI_API void SetWindowCollapsed(ImGuiWindow* window, bool collapsed, ImGuiCond cond = 0); + IMGUI_API void SetWindowHitTestHole(ImGuiWindow* window, const ImVec2& pos, const ImVec2& size); + + // Windows: Display Order and Focus Order + IMGUI_API void FocusWindow(ImGuiWindow* window); + IMGUI_API void FocusTopMostWindowUnderOne(ImGuiWindow* under_this_window, ImGuiWindow* ignore_window); + IMGUI_API void BringWindowToFocusFront(ImGuiWindow* window); + IMGUI_API void BringWindowToDisplayFront(ImGuiWindow* window); + IMGUI_API void BringWindowToDisplayBack(ImGuiWindow* window); + + // Fonts, drawing + IMGUI_API void SetCurrentFont(ImFont* font); + inline ImFont* GetDefaultFont() { ImGuiContext& g = *GImGui; return g.IO.FontDefault ? g.IO.FontDefault : g.IO.Fonts->Fonts[0]; } + inline ImDrawList* GetForegroundDrawList(ImGuiWindow* window) { IM_UNUSED(window); return GetForegroundDrawList(); } // This seemingly unnecessary wrapper simplifies compatibility between the 'master' and 'docking' branches. + IMGUI_API ImDrawList* GetBackgroundDrawList(ImGuiViewport* viewport); // get background draw list for the given viewport. this draw list will be the first rendering one. Useful to quickly draw shapes/text behind dear imgui contents. + IMGUI_API ImDrawList* GetForegroundDrawList(ImGuiViewport* viewport); // get foreground draw list for the given viewport. this draw list will be the last rendered one. Useful to quickly draw shapes/text over dear imgui contents. + + // Init + IMGUI_API void Initialize(ImGuiContext* context); + IMGUI_API void Shutdown(ImGuiContext* context); // Since 1.60 this is a _private_ function. You can call DestroyContext() to destroy the context created by CreateContext(). + + // NewFrame + IMGUI_API void UpdateHoveredWindowAndCaptureFlags(); + IMGUI_API void StartMouseMovingWindow(ImGuiWindow* window); + IMGUI_API void UpdateMouseMovingWindowNewFrame(); + IMGUI_API void UpdateMouseMovingWindowEndFrame(); + + // Generic context hooks + IMGUI_API ImGuiID AddContextHook(ImGuiContext* context, const ImGuiContextHook* hook); + IMGUI_API void RemoveContextHook(ImGuiContext* context, ImGuiID hook_to_remove); + IMGUI_API void CallContextHooks(ImGuiContext* context, ImGuiContextHookType type); + + // Settings + IMGUI_API void MarkIniSettingsDirty(); + IMGUI_API void MarkIniSettingsDirty(ImGuiWindow* window); + IMGUI_API void ClearIniSettings(); + IMGUI_API ImGuiWindowSettings* CreateNewWindowSettings(const char* name); + IMGUI_API ImGuiWindowSettings* FindWindowSettings(ImGuiID id); + IMGUI_API ImGuiWindowSettings* FindOrCreateWindowSettings(const char* name); + IMGUI_API ImGuiSettingsHandler* FindSettingsHandler(const char* type_name); + + // Scrolling + IMGUI_API void SetNextWindowScroll(const ImVec2& scroll); // Use -1.0f on one axis to leave as-is + IMGUI_API void SetScrollX(ImGuiWindow* window, float scroll_x); + IMGUI_API void SetScrollY(ImGuiWindow* window, float scroll_y); + IMGUI_API void SetScrollFromPosX(ImGuiWindow* window, float local_x, float center_x_ratio); + IMGUI_API void SetScrollFromPosY(ImGuiWindow* window, float local_y, float center_y_ratio); + IMGUI_API ImVec2 ScrollToBringRectIntoView(ImGuiWindow* window, const ImRect& item_rect); + + // Basic Accessors + inline ImGuiID GetItemID() { ImGuiContext& g = *GImGui; return g.LastItemData.ID; } // Get ID of last item (~~ often same ImGui::GetID(label) beforehand) + inline ImGuiItemStatusFlags GetItemStatusFlags(){ ImGuiContext& g = *GImGui; return g.LastItemData.StatusFlags; } + inline ImGuiItemFlags GetItemFlags() { ImGuiContext& g = *GImGui; return g.LastItemData.InFlags; } + inline ImGuiID GetActiveID() { ImGuiContext& g = *GImGui; return g.ActiveId; } + inline ImGuiID GetFocusID() { ImGuiContext& g = *GImGui; return g.NavId; } + IMGUI_API void SetActiveID(ImGuiID id, ImGuiWindow* window); + IMGUI_API void SetFocusID(ImGuiID id, ImGuiWindow* window); + IMGUI_API void ClearActiveID(); + IMGUI_API ImGuiID GetHoveredID(); + IMGUI_API void SetHoveredID(ImGuiID id); + IMGUI_API void KeepAliveID(ImGuiID id); + IMGUI_API void MarkItemEdited(ImGuiID id); // Mark data associated to given item as "edited", used by IsItemDeactivatedAfterEdit() function. + IMGUI_API void PushOverrideID(ImGuiID id); // Push given value as-is at the top of the ID stack (whereas PushID combines old and new hashes) + IMGUI_API ImGuiID GetIDWithSeed(const char* str_id_begin, const char* str_id_end, ImGuiID seed); + + // Basic Helpers for widget code + IMGUI_API void ItemSize(const ImVec2& size, float text_baseline_y = -1.0f); + IMGUI_API void ItemSize(const ImRect& bb, float text_baseline_y = -1.0f); + IMGUI_API bool ItemAdd(const ImRect& bb, ImGuiID id, const ImRect* nav_bb = NULL, ImGuiItemFlags extra_flags = 0); + IMGUI_API bool ItemHoverable(const ImRect& bb, ImGuiID id); + IMGUI_API void ItemInputable(ImGuiWindow* window, ImGuiID id); + IMGUI_API bool IsClippedEx(const ImRect& bb, ImGuiID id); + IMGUI_API ImVec2 CalcItemSize(ImVec2 size, float default_w, float default_h); + IMGUI_API float CalcWrapWidthForPos(const ImVec2& pos, float wrap_pos_x); + IMGUI_API void PushMultiItemsWidths(int components, float width_full); + IMGUI_API bool IsItemToggledSelection(); // Was the last item selection toggled? (after Selectable(), TreeNode() etc. We only returns toggle _event_ in order to handle clipping correctly) + IMGUI_API ImVec2 GetContentRegionMaxAbs(); + IMGUI_API void ShrinkWidths(ImGuiShrinkWidthItem* items, int count, float width_excess); + + // Parameter stacks + IMGUI_API void PushItemFlag(ImGuiItemFlags option, bool enabled); + IMGUI_API void PopItemFlag(); + +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + // Currently refactoring focus/nav/tabbing system + // If you have old/custom copy-and-pasted widgets that used FocusableItemRegister(): + // (Old) IMGUI_VERSION_NUM < 18209: using 'ItemAdd(....)' and 'bool focused = FocusableItemRegister(...)' + // (Old) IMGUI_VERSION_NUM >= 18209: using 'ItemAdd(..., ImGuiItemAddFlags_Focusable)' and 'bool focused = (GetItemStatusFlags() & ImGuiItemStatusFlags_Focused) != 0' + // (New) IMGUI_VERSION_NUM >= 18411: using 'ItemAdd(..., ImGuiItemAddFlags_Inputable)' and 'bool focused = (GetItemStatusFlags() & ImGuiItemStatusFlags_Focused) != 0' + // Widget code are simplified as there's no need to call FocusableItemUnregister() while managing the transition from regular widget to TempInputText() + inline bool FocusableItemRegister(ImGuiWindow* window, ImGuiID id) { IM_ASSERT(0); IM_UNUSED(window); IM_UNUSED(id); return false; } // -> pass ImGuiItemAddFlags_Inputable flag to ItemAdd() + inline void FocusableItemUnregister(ImGuiWindow* window) { IM_ASSERT(0); IM_UNUSED(window); } // -> unnecessary: TempInputText() uses ImGuiInputTextFlags_MergedItem +#endif + + // Logging/Capture + IMGUI_API void LogBegin(ImGuiLogType type, int auto_open_depth); // -> BeginCapture() when we design v2 api, for now stay under the radar by using the old name. + IMGUI_API void LogToBuffer(int auto_open_depth = -1); // Start logging/capturing to internal buffer + IMGUI_API void LogRenderedText(const ImVec2* ref_pos, const char* text, const char* text_end = NULL); + IMGUI_API void LogSetNextTextDecoration(const char* prefix, const char* suffix); + + // Popups, Modals, Tooltips + IMGUI_API bool BeginChildEx(const char* name, ImGuiID id, const ImVec2& size_arg, bool border, ImGuiWindowFlags flags); + IMGUI_API void OpenPopupEx(ImGuiID id, ImGuiPopupFlags popup_flags = ImGuiPopupFlags_None); + IMGUI_API void ClosePopupToLevel(int remaining, bool restore_focus_to_window_under_popup); + IMGUI_API void ClosePopupsOverWindow(ImGuiWindow* ref_window, bool restore_focus_to_window_under_popup); + IMGUI_API bool IsPopupOpen(ImGuiID id, ImGuiPopupFlags popup_flags); + IMGUI_API bool BeginPopupEx(ImGuiID id, ImGuiWindowFlags extra_flags); + IMGUI_API void BeginTooltipEx(ImGuiWindowFlags extra_flags, ImGuiTooltipFlags tooltip_flags); + IMGUI_API ImRect GetPopupAllowedExtentRect(ImGuiWindow* window); + IMGUI_API ImGuiWindow* GetTopMostPopupModal(); + IMGUI_API ImVec2 FindBestWindowPosForPopup(ImGuiWindow* window); + IMGUI_API ImVec2 FindBestWindowPosForPopupEx(const ImVec2& ref_pos, const ImVec2& size, ImGuiDir* last_dir, const ImRect& r_outer, const ImRect& r_avoid, ImGuiPopupPositionPolicy policy); + IMGUI_API bool BeginViewportSideBar(const char* name, ImGuiViewport* viewport, ImGuiDir dir, float size, ImGuiWindowFlags window_flags); + + // Menus + IMGUI_API bool BeginMenuEx(const char* label, const char* icon, bool enabled = true); + IMGUI_API bool MenuItemEx(const char* label, const char* icon, const char* shortcut = NULL, bool selected = false, bool enabled = true); + + // Combos + IMGUI_API bool BeginComboPopup(ImGuiID popup_id, const ImRect& bb, ImGuiComboFlags flags); + IMGUI_API bool BeginComboPreview(); + IMGUI_API void EndComboPreview(); + + // Gamepad/Keyboard Navigation + IMGUI_API void NavInitWindow(ImGuiWindow* window, bool force_reinit); + IMGUI_API void NavInitRequestApplyResult(); + IMGUI_API bool NavMoveRequestButNoResultYet(); + IMGUI_API void NavMoveRequestSubmit(ImGuiDir move_dir, ImGuiDir clip_dir, ImGuiNavMoveFlags move_flags); + IMGUI_API void NavMoveRequestForward(ImGuiDir move_dir, ImGuiDir clip_dir, ImGuiNavMoveFlags move_flags); + IMGUI_API void NavMoveRequestCancel(); + IMGUI_API void NavMoveRequestApplyResult(); + IMGUI_API void NavMoveRequestTryWrapping(ImGuiWindow* window, ImGuiNavMoveFlags move_flags); + IMGUI_API float GetNavInputAmount(ImGuiNavInput n, ImGuiInputReadMode mode); + IMGUI_API ImVec2 GetNavInputAmount2d(ImGuiNavDirSourceFlags dir_sources, ImGuiInputReadMode mode, float slow_factor = 0.0f, float fast_factor = 0.0f); + IMGUI_API int CalcTypematicRepeatAmount(float t0, float t1, float repeat_delay, float repeat_rate); + IMGUI_API void ActivateItem(ImGuiID id); // Remotely activate a button, checkbox, tree node etc. given its unique ID. activation is queued and processed on the next frame when the item is encountered again. + IMGUI_API void SetNavID(ImGuiID id, ImGuiNavLayer nav_layer, ImGuiID focus_scope_id, const ImRect& rect_rel); + + // Focus Scope (WIP) + // This is generally used to identify a selection set (multiple of which may be in the same window), as selection + // patterns generally need to react (e.g. clear selection) when landing on an item of the set. + IMGUI_API void PushFocusScope(ImGuiID id); + IMGUI_API void PopFocusScope(); + inline ImGuiID GetFocusedFocusScope() { ImGuiContext& g = *GImGui; return g.NavFocusScopeId; } // Focus scope which is actually active + inline ImGuiID GetFocusScope() { ImGuiContext& g = *GImGui; return g.CurrentWindow->DC.NavFocusScopeIdCurrent; } // Focus scope we are outputting into, set by PushFocusScope() + + // Inputs + // FIXME: Eventually we should aim to move e.g. IsActiveIdUsingKey() into IsKeyXXX functions. + IMGUI_API void SetItemUsingMouseWheel(); + IMGUI_API void SetActiveIdUsingNavAndKeys(); + inline bool IsActiveIdUsingNavDir(ImGuiDir dir) { ImGuiContext& g = *GImGui; return (g.ActiveIdUsingNavDirMask & (1 << dir)) != 0; } + inline bool IsActiveIdUsingNavInput(ImGuiNavInput input) { ImGuiContext& g = *GImGui; return (g.ActiveIdUsingNavInputMask & (1 << input)) != 0; } + inline bool IsActiveIdUsingKey(ImGuiKey key) { ImGuiContext& g = *GImGui; IM_ASSERT(key < 64); return (g.ActiveIdUsingKeyInputMask & ((ImU64)1 << key)) != 0; } + IMGUI_API bool IsMouseDragPastThreshold(ImGuiMouseButton button, float lock_threshold = -1.0f); + inline bool IsKeyPressedMap(ImGuiKey key, bool repeat = true) { ImGuiContext& g = *GImGui; const int key_index = g.IO.KeyMap[key]; return (key_index >= 0) ? IsKeyPressed(key_index, repeat) : false; } + inline bool IsNavInputDown(ImGuiNavInput n) { ImGuiContext& g = *GImGui; return g.IO.NavInputs[n] > 0.0f; } + inline bool IsNavInputTest(ImGuiNavInput n, ImGuiInputReadMode rm) { return (GetNavInputAmount(n, rm) > 0.0f); } + IMGUI_API ImGuiKeyModFlags GetMergedKeyModFlags(); + + // Drag and Drop + IMGUI_API bool BeginDragDropTargetCustom(const ImRect& bb, ImGuiID id); + IMGUI_API void ClearDragDrop(); + IMGUI_API bool IsDragDropPayloadBeingAccepted(); + + // Internal Columns API (this is not exposed because we will encourage transitioning to the Tables API) + IMGUI_API void SetWindowClipRectBeforeSetChannel(ImGuiWindow* window, const ImRect& clip_rect); + IMGUI_API void BeginColumns(const char* str_id, int count, ImGuiOldColumnFlags flags = 0); // setup number of columns. use an identifier to distinguish multiple column sets. close with EndColumns(). + IMGUI_API void EndColumns(); // close columns + IMGUI_API void PushColumnClipRect(int column_index); + IMGUI_API void PushColumnsBackground(); + IMGUI_API void PopColumnsBackground(); + IMGUI_API ImGuiID GetColumnsID(const char* str_id, int count); + IMGUI_API ImGuiOldColumns* FindOrCreateColumns(ImGuiWindow* window, ImGuiID id); + IMGUI_API float GetColumnOffsetFromNorm(const ImGuiOldColumns* columns, float offset_norm); + IMGUI_API float GetColumnNormFromOffset(const ImGuiOldColumns* columns, float offset); + + // Tables: Candidates for public API + IMGUI_API void TableOpenContextMenu(int column_n = -1); + IMGUI_API void TableSetColumnWidth(int column_n, float width); + IMGUI_API void TableSetColumnSortDirection(int column_n, ImGuiSortDirection sort_direction, bool append_to_sort_specs); + IMGUI_API int TableGetHoveredColumn(); // May use (TableGetColumnFlags() & ImGuiTableColumnFlags_IsHovered) instead. Return hovered column. return -1 when table is not hovered. return columns_count if the unused space at the right of visible columns is hovered. + IMGUI_API float TableGetHeaderRowHeight(); + IMGUI_API void TablePushBackgroundChannel(); + IMGUI_API void TablePopBackgroundChannel(); + + // Tables: Internals + inline ImGuiTable* GetCurrentTable() { ImGuiContext& g = *GImGui; return g.CurrentTable; } + IMGUI_API ImGuiTable* TableFindByID(ImGuiID id); + IMGUI_API bool BeginTableEx(const char* name, ImGuiID id, int columns_count, ImGuiTableFlags flags = 0, const ImVec2& outer_size = ImVec2(0, 0), float inner_width = 0.0f); + IMGUI_API void TableBeginInitMemory(ImGuiTable* table, int columns_count); + IMGUI_API void TableBeginApplyRequests(ImGuiTable* table); + IMGUI_API void TableSetupDrawChannels(ImGuiTable* table); + IMGUI_API void TableUpdateLayout(ImGuiTable* table); + IMGUI_API void TableUpdateBorders(ImGuiTable* table); + IMGUI_API void TableUpdateColumnsWeightFromWidth(ImGuiTable* table); + IMGUI_API void TableDrawBorders(ImGuiTable* table); + IMGUI_API void TableDrawContextMenu(ImGuiTable* table); + IMGUI_API void TableMergeDrawChannels(ImGuiTable* table); + IMGUI_API void TableSortSpecsSanitize(ImGuiTable* table); + IMGUI_API void TableSortSpecsBuild(ImGuiTable* table); + IMGUI_API ImGuiSortDirection TableGetColumnNextSortDirection(ImGuiTableColumn* column); + IMGUI_API void TableFixColumnSortDirection(ImGuiTable* table, ImGuiTableColumn* column); + IMGUI_API float TableGetColumnWidthAuto(ImGuiTable* table, ImGuiTableColumn* column); + IMGUI_API void TableBeginRow(ImGuiTable* table); + IMGUI_API void TableEndRow(ImGuiTable* table); + IMGUI_API void TableBeginCell(ImGuiTable* table, int column_n); + IMGUI_API void TableEndCell(ImGuiTable* table); + IMGUI_API ImRect TableGetCellBgRect(const ImGuiTable* table, int column_n); + IMGUI_API const char* TableGetColumnName(const ImGuiTable* table, int column_n); + IMGUI_API ImGuiID TableGetColumnResizeID(const ImGuiTable* table, int column_n, int instance_no = 0); + IMGUI_API float TableGetMaxColumnWidth(const ImGuiTable* table, int column_n); + IMGUI_API void TableSetColumnWidthAutoSingle(ImGuiTable* table, int column_n); + IMGUI_API void TableSetColumnWidthAutoAll(ImGuiTable* table); + IMGUI_API void TableRemove(ImGuiTable* table); + IMGUI_API void TableGcCompactTransientBuffers(ImGuiTable* table); + IMGUI_API void TableGcCompactTransientBuffers(ImGuiTableTempData* table); + IMGUI_API void TableGcCompactSettings(); + + // Tables: Settings + IMGUI_API void TableLoadSettings(ImGuiTable* table); + IMGUI_API void TableSaveSettings(ImGuiTable* table); + IMGUI_API void TableResetSettings(ImGuiTable* table); + IMGUI_API ImGuiTableSettings* TableGetBoundSettings(ImGuiTable* table); + IMGUI_API void TableSettingsInstallHandler(ImGuiContext* context); + IMGUI_API ImGuiTableSettings* TableSettingsCreate(ImGuiID id, int columns_count); + IMGUI_API ImGuiTableSettings* TableSettingsFindByID(ImGuiID id); + + // Tab Bars + IMGUI_API bool BeginTabBarEx(ImGuiTabBar* tab_bar, const ImRect& bb, ImGuiTabBarFlags flags); + IMGUI_API ImGuiTabItem* TabBarFindTabByID(ImGuiTabBar* tab_bar, ImGuiID tab_id); + IMGUI_API void TabBarRemoveTab(ImGuiTabBar* tab_bar, ImGuiID tab_id); + IMGUI_API void TabBarCloseTab(ImGuiTabBar* tab_bar, ImGuiTabItem* tab); + IMGUI_API void TabBarQueueReorder(ImGuiTabBar* tab_bar, const ImGuiTabItem* tab, int offset); + IMGUI_API void TabBarQueueReorderFromMousePos(ImGuiTabBar* tab_bar, const ImGuiTabItem* tab, ImVec2 mouse_pos); + IMGUI_API bool TabBarProcessReorder(ImGuiTabBar* tab_bar); + IMGUI_API bool TabItemEx(ImGuiTabBar* tab_bar, const char* label, bool* p_open, ImGuiTabItemFlags flags); + IMGUI_API ImVec2 TabItemCalcSize(const char* label, bool has_close_button); + IMGUI_API void TabItemBackground(ImDrawList* draw_list, const ImRect& bb, ImGuiTabItemFlags flags, ImU32 col); + IMGUI_API void TabItemLabelAndCloseButton(ImDrawList* draw_list, const ImRect& bb, ImGuiTabItemFlags flags, ImVec2 frame_padding, const char* label, ImGuiID tab_id, ImGuiID close_button_id, bool is_contents_visible, bool* out_just_closed, bool* out_text_clipped); + + // Render helpers + // AVOID USING OUTSIDE OF IMGUI.CPP! NOT FOR PUBLIC CONSUMPTION. THOSE FUNCTIONS ARE A MESS. THEIR SIGNATURE AND BEHAVIOR WILL CHANGE, THEY NEED TO BE REFACTORED INTO SOMETHING DECENT. + // NB: All position are in absolute pixels coordinates (we are never using window coordinates internally) + IMGUI_API void RenderText(ImVec2 pos, const char* text, const char* text_end = NULL, bool hide_text_after_hash = true); + IMGUI_API void RenderTextWrapped(ImVec2 pos, const char* text, const char* text_end, float wrap_width); + IMGUI_API void RenderTextClipped(const ImVec2& pos_min, const ImVec2& pos_max, const char* text, const char* text_end, const ImVec2* text_size_if_known, const ImVec2& align = ImVec2(0, 0), const ImRect* clip_rect = NULL); + IMGUI_API void RenderTextClippedEx(ImDrawList* draw_list, const ImVec2& pos_min, const ImVec2& pos_max, const char* text, const char* text_end, const ImVec2* text_size_if_known, const ImVec2& align = ImVec2(0, 0), const ImRect* clip_rect = NULL); + IMGUI_API void RenderTextEllipsis(ImDrawList* draw_list, const ImVec2& pos_min, const ImVec2& pos_max, float clip_max_x, float ellipsis_max_x, const char* text, const char* text_end, const ImVec2* text_size_if_known); + IMGUI_API void RenderFrame(ImVec2 p_min, ImVec2 p_max, ImU32 fill_col, bool border = true, float rounding = 0.0f); + IMGUI_API void RenderFrameBorder(ImVec2 p_min, ImVec2 p_max, float rounding = 0.0f); + IMGUI_API void RenderColorRectWithAlphaCheckerboard(ImDrawList* draw_list, ImVec2 p_min, ImVec2 p_max, ImU32 fill_col, float grid_step, ImVec2 grid_off, float rounding = 0.0f, ImDrawFlags flags = 0); + IMGUI_API void RenderNavHighlight(const ImRect& bb, ImGuiID id, ImGuiNavHighlightFlags flags = ImGuiNavHighlightFlags_TypeDefault); // Navigation highlight + IMGUI_API const char* FindRenderedTextEnd(const char* text, const char* text_end = NULL); // Find the optional ## from which we stop displaying text. + + // Render helpers (those functions don't access any ImGui state!) + IMGUI_API void RenderArrow(ImDrawList* draw_list, ImVec2 pos, ImU32 col, ImGuiDir dir, float scale = 1.0f); + IMGUI_API void RenderBullet(ImDrawList* draw_list, ImVec2 pos, ImU32 col); + IMGUI_API void RenderCheckMark(ImDrawList* draw_list, ImVec2 pos, ImU32 col, float sz); + IMGUI_API void RenderMouseCursor(ImDrawList* draw_list, ImVec2 pos, float scale, ImGuiMouseCursor mouse_cursor, ImU32 col_fill, ImU32 col_border, ImU32 col_shadow); + IMGUI_API void RenderArrowPointingAt(ImDrawList* draw_list, ImVec2 pos, ImVec2 half_sz, ImGuiDir direction, ImU32 col); + IMGUI_API void RenderRectFilledRangeH(ImDrawList* draw_list, const ImRect& rect, ImU32 col, float x_start_norm, float x_end_norm, float rounding); + IMGUI_API void RenderRectFilledWithHole(ImDrawList* draw_list, ImRect outer, ImRect inner, ImU32 col, float rounding); + +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + // [1.71: 2019/06/07: Updating prototypes of some of the internal functions. Leaving those for reference for a short while] + inline void RenderArrow(ImVec2 pos, ImGuiDir dir, float scale=1.0f) { ImGuiWindow* window = GetCurrentWindow(); RenderArrow(window->DrawList, pos, GetColorU32(ImGuiCol_Text), dir, scale); } + inline void RenderBullet(ImVec2 pos) { ImGuiWindow* window = GetCurrentWindow(); RenderBullet(window->DrawList, pos, GetColorU32(ImGuiCol_Text)); } +#endif + + // Widgets + IMGUI_API void TextEx(const char* text, const char* text_end = NULL, ImGuiTextFlags flags = 0); + IMGUI_API bool ButtonEx(const char* label, const ImVec2& size_arg = ImVec2(0, 0), ImGuiButtonFlags flags = 0); + IMGUI_API bool CloseButton(ImGuiID id, const ImVec2& pos); + IMGUI_API bool CollapseButton(ImGuiID id, const ImVec2& pos); + IMGUI_API bool ArrowButtonEx(const char* str_id, ImGuiDir dir, ImVec2 size_arg, ImGuiButtonFlags flags = 0); + IMGUI_API void Scrollbar(ImGuiAxis axis); + IMGUI_API bool ScrollbarEx(const ImRect& bb, ImGuiID id, ImGuiAxis axis, float* p_scroll_v, float avail_v, float contents_v, ImDrawFlags flags); + IMGUI_API bool ImageButtonEx(ImGuiID id, ImTextureID texture_id, const ImVec2& size, const ImVec2& uv0, const ImVec2& uv1, const ImVec2& padding, const ImVec4& bg_col, const ImVec4& tint_col); + IMGUI_API ImRect GetWindowScrollbarRect(ImGuiWindow* window, ImGuiAxis axis); + IMGUI_API ImGuiID GetWindowScrollbarID(ImGuiWindow* window, ImGuiAxis axis); + IMGUI_API ImGuiID GetWindowResizeCornerID(ImGuiWindow* window, int n); // 0..3: corners + IMGUI_API ImGuiID GetWindowResizeBorderID(ImGuiWindow* window, ImGuiDir dir); + IMGUI_API void SeparatorEx(ImGuiSeparatorFlags flags); + IMGUI_API bool CheckboxFlags(const char* label, ImS64* flags, ImS64 flags_value); + IMGUI_API bool CheckboxFlags(const char* label, ImU64* flags, ImU64 flags_value); + + // Widgets low-level behaviors + IMGUI_API bool ButtonBehavior(const ImRect& bb, ImGuiID id, bool* out_hovered, bool* out_held, ImGuiButtonFlags flags = 0); + IMGUI_API bool DragBehavior(ImGuiID id, ImGuiDataType data_type, void* p_v, float v_speed, const void* p_min, const void* p_max, const char* format, ImGuiSliderFlags flags); + IMGUI_API bool SliderBehavior(const ImRect& bb, ImGuiID id, ImGuiDataType data_type, void* p_v, const void* p_min, const void* p_max, const char* format, ImGuiSliderFlags flags, ImRect* out_grab_bb); + IMGUI_API bool SplitterBehavior(const ImRect& bb, ImGuiID id, ImGuiAxis axis, float* size1, float* size2, float min_size1, float min_size2, float hover_extend = 0.0f, float hover_visibility_delay = 0.0f); + IMGUI_API bool TreeNodeBehavior(ImGuiID id, ImGuiTreeNodeFlags flags, const char* label, const char* label_end = NULL); + IMGUI_API bool TreeNodeBehaviorIsOpen(ImGuiID id, ImGuiTreeNodeFlags flags = 0); // Consume previous SetNextItemOpen() data, if any. May return true when logging + IMGUI_API void TreePushOverrideID(ImGuiID id); + + // Template functions are instantiated in imgui_widgets.cpp for a finite number of types. + // To use them externally (for custom widget) you may need an "extern template" statement in your code in order to link to existing instances and silence Clang warnings (see #2036). + // e.g. " extern template IMGUI_API float RoundScalarWithFormatT(const char* format, ImGuiDataType data_type, float v); " + template IMGUI_API float ScaleRatioFromValueT(ImGuiDataType data_type, T v, T v_min, T v_max, bool is_logarithmic, float logarithmic_zero_epsilon, float zero_deadzone_size); + template IMGUI_API T ScaleValueFromRatioT(ImGuiDataType data_type, float t, T v_min, T v_max, bool is_logarithmic, float logarithmic_zero_epsilon, float zero_deadzone_size); + template IMGUI_API bool DragBehaviorT(ImGuiDataType data_type, T* v, float v_speed, T v_min, T v_max, const char* format, ImGuiSliderFlags flags); + template IMGUI_API bool SliderBehaviorT(const ImRect& bb, ImGuiID id, ImGuiDataType data_type, T* v, T v_min, T v_max, const char* format, ImGuiSliderFlags flags, ImRect* out_grab_bb); + template IMGUI_API T RoundScalarWithFormatT(const char* format, ImGuiDataType data_type, T v); + template IMGUI_API bool CheckboxFlagsT(const char* label, T* flags, T flags_value); + + // Data type helpers + IMGUI_API const ImGuiDataTypeInfo* DataTypeGetInfo(ImGuiDataType data_type); + IMGUI_API int DataTypeFormatString(char* buf, int buf_size, ImGuiDataType data_type, const void* p_data, const char* format); + IMGUI_API void DataTypeApplyOp(ImGuiDataType data_type, int op, void* output, const void* arg_1, const void* arg_2); + IMGUI_API bool DataTypeApplyOpFromText(const char* buf, const char* initial_value_buf, ImGuiDataType data_type, void* p_data, const char* format); + IMGUI_API int DataTypeCompare(ImGuiDataType data_type, const void* arg_1, const void* arg_2); + IMGUI_API bool DataTypeClamp(ImGuiDataType data_type, void* p_data, const void* p_min, const void* p_max); + + // InputText + IMGUI_API bool InputTextEx(const char* label, const char* hint, char* buf, int buf_size, const ImVec2& size_arg, ImGuiInputTextFlags flags, ImGuiInputTextCallback callback = NULL, void* user_data = NULL); + IMGUI_API bool TempInputText(const ImRect& bb, ImGuiID id, const char* label, char* buf, int buf_size, ImGuiInputTextFlags flags); + IMGUI_API bool TempInputScalar(const ImRect& bb, ImGuiID id, const char* label, ImGuiDataType data_type, void* p_data, const char* format, const void* p_clamp_min = NULL, const void* p_clamp_max = NULL); + inline bool TempInputIsActive(ImGuiID id) { ImGuiContext& g = *GImGui; return (g.ActiveId == id && g.TempInputId == id); } + inline ImGuiInputTextState* GetInputTextState(ImGuiID id) { ImGuiContext& g = *GImGui; return (g.InputTextState.ID == id) ? &g.InputTextState : NULL; } // Get input text state if active + + // Color + IMGUI_API void ColorTooltip(const char* text, const float* col, ImGuiColorEditFlags flags); + IMGUI_API void ColorEditOptionsPopup(const float* col, ImGuiColorEditFlags flags); + IMGUI_API void ColorPickerOptionsPopup(const float* ref_col, ImGuiColorEditFlags flags); + + // Plot + IMGUI_API int PlotEx(ImGuiPlotType plot_type, const char* label, float (*values_getter)(void* data, int idx), void* data, int values_count, int values_offset, const char* overlay_text, float scale_min, float scale_max, ImVec2 frame_size); + + // Shade functions (write over already created vertices) + IMGUI_API void ShadeVertsLinearColorGradientKeepAlpha(ImDrawList* draw_list, int vert_start_idx, int vert_end_idx, ImVec2 gradient_p0, ImVec2 gradient_p1, ImU32 col0, ImU32 col1); + IMGUI_API void ShadeVertsLinearUV(ImDrawList* draw_list, int vert_start_idx, int vert_end_idx, const ImVec2& a, const ImVec2& b, const ImVec2& uv_a, const ImVec2& uv_b, bool clamp); + + // Garbage collection + IMGUI_API void GcCompactTransientMiscBuffers(); + IMGUI_API void GcCompactTransientWindowBuffers(ImGuiWindow* window); + IMGUI_API void GcAwakeTransientWindowBuffers(ImGuiWindow* window); + + // Debug Tools + IMGUI_API void ErrorCheckEndFrameRecover(ImGuiErrorLogCallback log_callback, void* user_data = NULL); + IMGUI_API void ErrorCheckEndWindowRecover(ImGuiErrorLogCallback log_callback, void* user_data = NULL); + inline void DebugDrawItemRect(ImU32 col = IM_COL32(255,0,0,255)) { ImGuiContext& g = *GImGui; ImGuiWindow* window = g.CurrentWindow; GetForegroundDrawList(window)->AddRect(g.LastItemData.Rect.Min, g.LastItemData.Rect.Max, col); } + inline void DebugStartItemPicker() { ImGuiContext& g = *GImGui; g.DebugItemPickerActive = true; } + + IMGUI_API void ShowFontAtlas(ImFontAtlas* atlas); + IMGUI_API void DebugNodeColumns(ImGuiOldColumns* columns); + IMGUI_API void DebugNodeDrawList(ImGuiWindow* window, const ImDrawList* draw_list, const char* label); + IMGUI_API void DebugNodeDrawCmdShowMeshAndBoundingBox(ImDrawList* out_draw_list, const ImDrawList* draw_list, const ImDrawCmd* draw_cmd, bool show_mesh, bool show_aabb); + IMGUI_API void DebugNodeFont(ImFont* font); + IMGUI_API void DebugNodeStorage(ImGuiStorage* storage, const char* label); + IMGUI_API void DebugNodeTabBar(ImGuiTabBar* tab_bar, const char* label); + IMGUI_API void DebugNodeTable(ImGuiTable* table); + IMGUI_API void DebugNodeTableSettings(ImGuiTableSettings* settings); + IMGUI_API void DebugNodeWindow(ImGuiWindow* window, const char* label); + IMGUI_API void DebugNodeWindowSettings(ImGuiWindowSettings* settings); + IMGUI_API void DebugNodeWindowsList(ImVector* windows, const char* label); + IMGUI_API void DebugNodeViewport(ImGuiViewportP* viewport); + IMGUI_API void DebugRenderViewportThumbnail(ImDrawList* draw_list, ImGuiViewportP* viewport, const ImRect& bb); + +} // namespace ImGui + + +//----------------------------------------------------------------------------- +// [SECTION] ImFontAtlas internal API +//----------------------------------------------------------------------------- + +// This structure is likely to evolve as we add support for incremental atlas updates +struct ImFontBuilderIO +{ + bool (*FontBuilder_Build)(ImFontAtlas* atlas); +}; + +// Helper for font builder +IMGUI_API const ImFontBuilderIO* ImFontAtlasGetBuilderForStbTruetype(); +IMGUI_API void ImFontAtlasBuildInit(ImFontAtlas* atlas); +IMGUI_API void ImFontAtlasBuildSetupFont(ImFontAtlas* atlas, ImFont* font, ImFontConfig* font_config, float ascent, float descent); +IMGUI_API void ImFontAtlasBuildPackCustomRects(ImFontAtlas* atlas, void* stbrp_context_opaque); +IMGUI_API void ImFontAtlasBuildFinish(ImFontAtlas* atlas); +IMGUI_API void ImFontAtlasBuildRender8bppRectFromString(ImFontAtlas* atlas, int x, int y, int w, int h, const char* in_str, char in_marker_char, unsigned char in_marker_pixel_value); +IMGUI_API void ImFontAtlasBuildRender32bppRectFromString(ImFontAtlas* atlas, int x, int y, int w, int h, const char* in_str, char in_marker_char, unsigned int in_marker_pixel_value); +IMGUI_API void ImFontAtlasBuildMultiplyCalcLookupTable(unsigned char out_table[256], float in_multiply_factor); +IMGUI_API void ImFontAtlasBuildMultiplyRectAlpha8(const unsigned char table[256], unsigned char* pixels, int x, int y, int w, int h, int stride); + +//----------------------------------------------------------------------------- +// [SECTION] Test Engine specific hooks (imgui_test_engine) +//----------------------------------------------------------------------------- + +#ifdef IMGUI_ENABLE_TEST_ENGINE +extern void ImGuiTestEngineHook_ItemAdd(ImGuiContext* ctx, const ImRect& bb, ImGuiID id); +extern void ImGuiTestEngineHook_ItemInfo(ImGuiContext* ctx, ImGuiID id, const char* label, ImGuiItemStatusFlags flags); +extern void ImGuiTestEngineHook_IdInfo(ImGuiContext* ctx, ImGuiDataType data_type, ImGuiID id, const void* data_id); +extern void ImGuiTestEngineHook_IdInfo(ImGuiContext* ctx, ImGuiDataType data_type, ImGuiID id, const void* data_id, const void* data_id_end); +extern void ImGuiTestEngineHook_Log(ImGuiContext* ctx, const char* fmt, ...); +#define IMGUI_TEST_ENGINE_ITEM_ADD(_BB,_ID) if (g.TestEngineHookItems) ImGuiTestEngineHook_ItemAdd(&g, _BB, _ID) // Register item bounding box +#define IMGUI_TEST_ENGINE_ITEM_INFO(_ID,_LABEL,_FLAGS) if (g.TestEngineHookItems) ImGuiTestEngineHook_ItemInfo(&g, _ID, _LABEL, _FLAGS) // Register item label and status flags (optional) +#define IMGUI_TEST_ENGINE_LOG(_FMT,...) if (g.TestEngineHookItems) ImGuiTestEngineHook_Log(&g, _FMT, __VA_ARGS__) // Custom log entry from user land into test log +#define IMGUI_TEST_ENGINE_ID_INFO(_ID,_TYPE,_DATA) if (g.TestEngineHookIdInfo == _ID) ImGuiTestEngineHook_IdInfo(&g, _TYPE, _ID, (const void*)(_DATA)); +#define IMGUI_TEST_ENGINE_ID_INFO2(_ID,_TYPE,_DATA,_DATA2) if (g.TestEngineHookIdInfo == _ID) ImGuiTestEngineHook_IdInfo(&g, _TYPE, _ID, (const void*)(_DATA), (const void*)(_DATA2)); +#else +#define IMGUI_TEST_ENGINE_ITEM_INFO(_ID,_LABEL,_FLAGS) ((void)0) +#endif + +//----------------------------------------------------------------------------- + +#if defined(__clang__) +#pragma clang diagnostic pop +#elif defined(__GNUC__) +#pragma GCC diagnostic pop +#endif + +#ifdef _MSC_VER +#pragma warning (pop) +#endif + +#endif // #ifndef IMGUI_DISABLE diff --git a/source/editor/imgui/imgui_tables.cpp b/source/editor/imgui/imgui_tables.cpp new file mode 100644 index 0000000..945e739 --- /dev/null +++ b/source/editor/imgui/imgui_tables.cpp @@ -0,0 +1,4050 @@ +// dear imgui, v1.85 WIP +// (tables and columns code) + +/* + +Index of this file: + +// [SECTION] Commentary +// [SECTION] Header mess +// [SECTION] Tables: Main code +// [SECTION] Tables: Simple accessors +// [SECTION] Tables: Row changes +// [SECTION] Tables: Columns changes +// [SECTION] Tables: Columns width management +// [SECTION] Tables: Drawing +// [SECTION] Tables: Sorting +// [SECTION] Tables: Headers +// [SECTION] Tables: Context Menu +// [SECTION] Tables: Settings (.ini data) +// [SECTION] Tables: Garbage Collection +// [SECTION] Tables: Debugging +// [SECTION] Columns, BeginColumns, EndColumns, etc. + +*/ + +// Navigating this file: +// - In Visual Studio IDE: CTRL+comma ("Edit.NavigateTo") can follow symbols in comments, whereas CTRL+F12 ("Edit.GoToImplementation") cannot. +// - With Visual Assist installed: ALT+G ("VAssistX.GoToImplementation") can also follow symbols in comments. + +//----------------------------------------------------------------------------- +// [SECTION] Commentary +//----------------------------------------------------------------------------- + +//----------------------------------------------------------------------------- +// Typical tables call flow: (root level is generally public API): +//----------------------------------------------------------------------------- +// - BeginTable() user begin into a table +// | BeginChild() - (if ScrollX/ScrollY is set) +// | TableBeginInitMemory() - first time table is used +// | TableResetSettings() - on settings reset +// | TableLoadSettings() - on settings load +// | TableBeginApplyRequests() - apply queued resizing/reordering/hiding requests +// | - TableSetColumnWidth() - apply resizing width (for mouse resize, often requested by previous frame) +// | - TableUpdateColumnsWeightFromWidth()- recompute columns weights (of stretch columns) from their respective width +// - TableSetupColumn() user submit columns details (optional) +// - TableSetupScrollFreeze() user submit scroll freeze information (optional) +//----------------------------------------------------------------------------- +// - TableUpdateLayout() [Internal] followup to BeginTable(): setup everything: widths, columns positions, clipping rectangles. Automatically called by the FIRST call to TableNextRow() or TableHeadersRow(). +// | TableSetupDrawChannels() - setup ImDrawList channels +// | TableUpdateBorders() - detect hovering columns for resize, ahead of contents submission +// | TableDrawContextMenu() - draw right-click context menu +//----------------------------------------------------------------------------- +// - TableHeadersRow() or TableHeader() user submit a headers row (optional) +// | TableSortSpecsClickColumn() - when left-clicked: alter sort order and sort direction +// | TableOpenContextMenu() - when right-clicked: trigger opening of the default context menu +// - TableGetSortSpecs() user queries updated sort specs (optional, generally after submitting headers) +// - TableNextRow() user begin into a new row (also automatically called by TableHeadersRow()) +// | TableEndRow() - finish existing row +// | TableBeginRow() - add a new row +// - TableSetColumnIndex() / TableNextColumn() user begin into a cell +// | TableEndCell() - close existing column/cell +// | TableBeginCell() - enter into current column/cell +// - [...] user emit contents +//----------------------------------------------------------------------------- +// - EndTable() user ends the table +// | TableDrawBorders() - draw outer borders, inner vertical borders +// | TableMergeDrawChannels() - merge draw channels if clipping isn't required +// | EndChild() - (if ScrollX/ScrollY is set) +//----------------------------------------------------------------------------- + +//----------------------------------------------------------------------------- +// TABLE SIZING +//----------------------------------------------------------------------------- +// (Read carefully because this is subtle but it does make sense!) +//----------------------------------------------------------------------------- +// About 'outer_size': +// Its meaning needs to differ slightly depending on if we are using ScrollX/ScrollY flags. +// Default value is ImVec2(0.0f, 0.0f). +// X +// - outer_size.x <= 0.0f -> Right-align from window/work-rect right-most edge. With -FLT_MIN or 0.0f will align exactly on right-most edge. +// - outer_size.x > 0.0f -> Set Fixed width. +// Y with ScrollX/ScrollY disabled: we output table directly in current window +// - outer_size.y < 0.0f -> Bottom-align (but will auto extend, unless _NoHostExtendY is set). Not meaningful is parent window can vertically scroll. +// - outer_size.y = 0.0f -> No minimum height (but will auto extend, unless _NoHostExtendY is set) +// - outer_size.y > 0.0f -> Set Minimum height (but will auto extend, unless _NoHostExtenY is set) +// Y with ScrollX/ScrollY enabled: using a child window for scrolling +// - outer_size.y < 0.0f -> Bottom-align. Not meaningful is parent window can vertically scroll. +// - outer_size.y = 0.0f -> Bottom-align, consistent with BeginChild(). Not recommended unless table is last item in parent window. +// - outer_size.y > 0.0f -> Set Exact height. Recommended when using Scrolling on any axis. +//----------------------------------------------------------------------------- +// Outer size is also affected by the NoHostExtendX/NoHostExtendY flags. +// Important to that note how the two flags have slightly different behaviors! +// - ImGuiTableFlags_NoHostExtendX -> Make outer width auto-fit to columns (overriding outer_size.x value). Only available when ScrollX/ScrollY are disabled and Stretch columns are not used. +// - ImGuiTableFlags_NoHostExtendY -> Make outer height stop exactly at outer_size.y (prevent auto-extending table past the limit). Only available when ScrollX/ScrollY is disabled. Data below the limit will be clipped and not visible. +// In theory ImGuiTableFlags_NoHostExtendY could be the default and any non-scrolling tables with outer_size.y != 0.0f would use exact height. +// This would be consistent but perhaps less useful and more confusing (as vertically clipped items are not easily noticeable) +//----------------------------------------------------------------------------- +// About 'inner_width': +// With ScrollX disabled: +// - inner_width -> *ignored* +// With ScrollX enabled: +// - inner_width < 0.0f -> *illegal* fit in known width (right align from outer_size.x) <-- weird +// - inner_width = 0.0f -> fit in outer_width: Fixed size columns will take space they need (if avail, otherwise shrink down), Stretch columns becomes Fixed columns. +// - inner_width > 0.0f -> override scrolling width, generally to be larger than outer_size.x. Fixed column take space they need (if avail, otherwise shrink down), Stretch columns share remaining space! +//----------------------------------------------------------------------------- +// Details: +// - If you want to use Stretch columns with ScrollX, you generally need to specify 'inner_width' otherwise the concept +// of "available space" doesn't make sense. +// - Even if not really useful, we allow 'inner_width < outer_size.x' for consistency and to facilitate understanding +// of what the value does. +//----------------------------------------------------------------------------- + +//----------------------------------------------------------------------------- +// COLUMNS SIZING POLICIES +//----------------------------------------------------------------------------- +// About overriding column sizing policy and width/weight with TableSetupColumn(): +// We use a default parameter of 'init_width_or_weight == -1'. +// - with ImGuiTableColumnFlags_WidthFixed, init_width <= 0 (default) --> width is automatic +// - with ImGuiTableColumnFlags_WidthFixed, init_width > 0 (explicit) --> width is custom +// - with ImGuiTableColumnFlags_WidthStretch, init_weight <= 0 (default) --> weight is 1.0f +// - with ImGuiTableColumnFlags_WidthStretch, init_weight > 0 (explicit) --> weight is custom +// Widths are specified _without_ CellPadding. If you specify a width of 100.0f, the column will be cover (100.0f + Padding * 2.0f) +// and you can fit a 100.0f wide item in it without clipping and with full padding. +//----------------------------------------------------------------------------- +// About default sizing policy (if you don't specify a ImGuiTableColumnFlags_WidthXXXX flag) +// - with Table policy ImGuiTableFlags_SizingFixedFit --> default Column policy is ImGuiTableColumnFlags_WidthFixed, default Width is equal to contents width +// - with Table policy ImGuiTableFlags_SizingFixedSame --> default Column policy is ImGuiTableColumnFlags_WidthFixed, default Width is max of all contents width +// - with Table policy ImGuiTableFlags_SizingStretchSame --> default Column policy is ImGuiTableColumnFlags_WidthStretch, default Weight is 1.0f +// - with Table policy ImGuiTableFlags_SizingStretchWeight --> default Column policy is ImGuiTableColumnFlags_WidthStretch, default Weight is proportional to contents +// Default Width and default Weight can be overridden when calling TableSetupColumn(). +//----------------------------------------------------------------------------- +// About mixing Fixed/Auto and Stretch columns together: +// - the typical use of mixing sizing policies is: any number of LEADING Fixed columns, followed by one or two TRAILING Stretch columns. +// - using mixed policies with ScrollX does not make much sense, as using Stretch columns with ScrollX does not make much sense in the first place! +// that is, unless 'inner_width' is passed to BeginTable() to explicitly provide a total width to layout columns in. +// - when using ImGuiTableFlags_SizingFixedSame with mixed columns, only the Fixed/Auto columns will match their widths to the width of the maximum contents. +// - when using ImGuiTableFlags_SizingStretchSame with mixed columns, only the Stretch columns will match their weight/widths. +//----------------------------------------------------------------------------- +// About using column width: +// If a column is manual resizable or has a width specified with TableSetupColumn(): +// - you may use GetContentRegionAvail().x to query the width available in a given column. +// - right-side alignment features such as SetNextItemWidth(-x) or PushItemWidth(-x) will rely on this width. +// If the column is not resizable and has no width specified with TableSetupColumn(): +// - its width will be automatic and be set to the max of items submitted. +// - therefore you generally cannot have ALL items of the columns use e.g. SetNextItemWidth(-FLT_MIN). +// - but if the column has one or more items of known/fixed size, this will become the reference width used by SetNextItemWidth(-FLT_MIN). +//----------------------------------------------------------------------------- + + +//----------------------------------------------------------------------------- +// TABLES CLIPPING/CULLING +//----------------------------------------------------------------------------- +// About clipping/culling of Rows in Tables: +// - For large numbers of rows, it is recommended you use ImGuiListClipper to only submit visible rows. +// ImGuiListClipper is reliant on the fact that rows are of equal height. +// See 'Demo->Tables->Vertical Scrolling' or 'Demo->Tables->Advanced' for a demo of using the clipper. +// - Note that auto-resizing columns don't play well with using the clipper. +// By default a table with _ScrollX but without _Resizable will have column auto-resize. +// So, if you want to use the clipper, make sure to either enable _Resizable, either setup columns width explicitly with _WidthFixed. +//----------------------------------------------------------------------------- +// About clipping/culling of Columns in Tables: +// - Both TableSetColumnIndex() and TableNextColumn() return true when the column is visible or performing +// width measurements. Otherwise, you may skip submitting the contents of a cell/column, BUT ONLY if you know +// it is not going to contribute to row height. +// In many situations, you may skip submitting contents for every column but one (e.g. the first one). +// - Case A: column is not hidden by user, and at least partially in sight (most common case). +// - Case B: column is clipped / out of sight (because of scrolling or parent ClipRect): TableNextColumn() return false as a hint but we still allow layout output. +// - Case C: column is hidden explicitly by the user (e.g. via the context menu, or _DefaultHide column flag, etc.). +// +// [A] [B] [C] +// TableNextColumn(): true false false -> [userland] when TableNextColumn() / TableSetColumnIndex() return false, user can skip submitting items but only if the column doesn't contribute to row height. +// SkipItems: false false true -> [internal] when SkipItems is true, most widgets will early out if submitted, resulting is no layout output. +// ClipRect: normal zero-width zero-width -> [internal] when ClipRect is zero, ItemAdd() will return false and most widgets will early out mid-way. +// ImDrawList output: normal dummy dummy -> [internal] when using the dummy channel, ImDrawList submissions (if any) will be wasted (because cliprect is zero-width anyway). +// +// - We need to distinguish those cases because non-hidden columns that are clipped outside of scrolling bounds should still contribute their height to the row. +// However, in the majority of cases, the contribution to row height is the same for all columns, or the tallest cells are known by the programmer. +//----------------------------------------------------------------------------- +// About clipping/culling of whole Tables: +// - Scrolling tables with a known outer size can be clipped earlier as BeginTable() will return false. +//----------------------------------------------------------------------------- + +//----------------------------------------------------------------------------- +// [SECTION] Header mess +//----------------------------------------------------------------------------- + +#if defined(_MSC_VER) && !defined(_CRT_SECURE_NO_WARNINGS) +#define _CRT_SECURE_NO_WARNINGS +#endif + +#include "imgui.h" +#ifndef IMGUI_DISABLE + +#ifndef IMGUI_DEFINE_MATH_OPERATORS +#define IMGUI_DEFINE_MATH_OPERATORS +#endif +#include "imgui_internal.h" + +// System includes +#if defined(_MSC_VER) && _MSC_VER <= 1500 // MSVC 2008 or earlier +#include // intptr_t +#else +#include // intptr_t +#endif + +// Visual Studio warnings +#ifdef _MSC_VER +#pragma warning (disable: 4127) // condition expression is constant +#pragma warning (disable: 4996) // 'This function or variable may be unsafe': strcpy, strdup, sprintf, vsnprintf, sscanf, fopen +#if defined(_MSC_VER) && _MSC_VER >= 1922 // MSVC 2019 16.2 or later +#pragma warning (disable: 5054) // operator '|': deprecated between enumerations of different types +#endif +#pragma warning (disable: 26451) // [Static Analyzer] Arithmetic overflow : Using operator 'xxx' on a 4 byte value and then casting the result to a 8 byte value. Cast the value to the wider type before calling operator 'xxx' to avoid overflow(io.2). +#pragma warning (disable: 26812) // [Static Analyzer] The enum type 'xxx' is unscoped. Prefer 'enum class' over 'enum' (Enum.3). +#endif + +// Clang/GCC warnings with -Weverything +#if defined(__clang__) +#if __has_warning("-Wunknown-warning-option") +#pragma clang diagnostic ignored "-Wunknown-warning-option" // warning: unknown warning group 'xxx' // not all warnings are known by all Clang versions and they tend to be rename-happy.. so ignoring warnings triggers new warnings on some configuration. Great! +#endif +#pragma clang diagnostic ignored "-Wunknown-pragmas" // warning: unknown warning group 'xxx' +#pragma clang diagnostic ignored "-Wold-style-cast" // warning: use of old-style cast // yes, they are more terse. +#pragma clang diagnostic ignored "-Wfloat-equal" // warning: comparing floating point with == or != is unsafe // storing and comparing against same constants (typically 0.0f) is ok. +#pragma clang diagnostic ignored "-Wformat-nonliteral" // warning: format string is not a string literal // passing non-literal to vsnformat(). yes, user passing incorrect format strings can crash the code. +#pragma clang diagnostic ignored "-Wsign-conversion" // warning: implicit conversion changes signedness +#pragma clang diagnostic ignored "-Wzero-as-null-pointer-constant" // warning: zero as null pointer constant // some standard header variations use #define NULL 0 +#pragma clang diagnostic ignored "-Wdouble-promotion" // warning: implicit conversion from 'float' to 'double' when passing argument to function // using printf() is a misery with this as C++ va_arg ellipsis changes float to double. +#pragma clang diagnostic ignored "-Wenum-enum-conversion" // warning: bitwise operation between different enumeration types ('XXXFlags_' and 'XXXFlagsPrivate_') +#pragma clang diagnostic ignored "-Wdeprecated-enum-enum-conversion"// warning: bitwise operation between different enumeration types ('XXXFlags_' and 'XXXFlagsPrivate_') is deprecated +#pragma clang diagnostic ignored "-Wimplicit-int-float-conversion" // warning: implicit conversion from 'xxx' to 'float' may lose precision +#elif defined(__GNUC__) +#pragma GCC diagnostic ignored "-Wpragmas" // warning: unknown option after '#pragma GCC diagnostic' kind +#pragma GCC diagnostic ignored "-Wformat-nonliteral" // warning: format not a string literal, format string not checked +#pragma GCC diagnostic ignored "-Wclass-memaccess" // [__GNUC__ >= 8] warning: 'memset/memcpy' clearing/writing an object of type 'xxxx' with no trivial copy-assignment; use assignment or value-initialization instead +#endif + +//----------------------------------------------------------------------------- +// [SECTION] Tables: Main code +//----------------------------------------------------------------------------- +// - TableFixFlags() [Internal] +// - TableFindByID() [Internal] +// - BeginTable() +// - BeginTableEx() [Internal] +// - TableBeginInitMemory() [Internal] +// - TableBeginApplyRequests() [Internal] +// - TableSetupColumnFlags() [Internal] +// - TableUpdateLayout() [Internal] +// - TableUpdateBorders() [Internal] +// - EndTable() +// - TableSetupColumn() +// - TableSetupScrollFreeze() +//----------------------------------------------------------------------------- + +// Configuration +static const int TABLE_DRAW_CHANNEL_BG0 = 0; +static const int TABLE_DRAW_CHANNEL_BG2_FROZEN = 1; +static const int TABLE_DRAW_CHANNEL_NOCLIP = 2; // When using ImGuiTableFlags_NoClip (this becomes the last visible channel) +static const float TABLE_BORDER_SIZE = 1.0f; // FIXME-TABLE: Currently hard-coded because of clipping assumptions with outer borders rendering. +static const float TABLE_RESIZE_SEPARATOR_HALF_THICKNESS = 4.0f; // Extend outside inner borders. +static const float TABLE_RESIZE_SEPARATOR_FEEDBACK_TIMER = 0.06f; // Delay/timer before making the hover feedback (color+cursor) visible because tables/columns tends to be more cramped. + +// Helper +inline ImGuiTableFlags TableFixFlags(ImGuiTableFlags flags, ImGuiWindow* outer_window) +{ + // Adjust flags: set default sizing policy + if ((flags & ImGuiTableFlags_SizingMask_) == 0) + flags |= ((flags & ImGuiTableFlags_ScrollX) || (outer_window->Flags & ImGuiWindowFlags_AlwaysAutoResize)) ? ImGuiTableFlags_SizingFixedFit : ImGuiTableFlags_SizingStretchSame; + + // Adjust flags: enable NoKeepColumnsVisible when using ImGuiTableFlags_SizingFixedSame + if ((flags & ImGuiTableFlags_SizingMask_) == ImGuiTableFlags_SizingFixedSame) + flags |= ImGuiTableFlags_NoKeepColumnsVisible; + + // Adjust flags: enforce borders when resizable + if (flags & ImGuiTableFlags_Resizable) + flags |= ImGuiTableFlags_BordersInnerV; + + // Adjust flags: disable NoHostExtendX/NoHostExtendY if we have any scrolling going on + if (flags & (ImGuiTableFlags_ScrollX | ImGuiTableFlags_ScrollY)) + flags &= ~(ImGuiTableFlags_NoHostExtendX | ImGuiTableFlags_NoHostExtendY); + + // Adjust flags: NoBordersInBodyUntilResize takes priority over NoBordersInBody + if (flags & ImGuiTableFlags_NoBordersInBodyUntilResize) + flags &= ~ImGuiTableFlags_NoBordersInBody; + + // Adjust flags: disable saved settings if there's nothing to save + if ((flags & (ImGuiTableFlags_Resizable | ImGuiTableFlags_Hideable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Sortable)) == 0) + flags |= ImGuiTableFlags_NoSavedSettings; + + // Inherit _NoSavedSettings from top-level window (child windows always have _NoSavedSettings set) + if (outer_window->RootWindow->Flags & ImGuiWindowFlags_NoSavedSettings) + flags |= ImGuiTableFlags_NoSavedSettings; + + return flags; +} + +ImGuiTable* ImGui::TableFindByID(ImGuiID id) +{ + ImGuiContext& g = *GImGui; + return g.Tables.GetByKey(id); +} + +// Read about "TABLE SIZING" at the top of this file. +bool ImGui::BeginTable(const char* str_id, int columns_count, ImGuiTableFlags flags, const ImVec2& outer_size, float inner_width) +{ + ImGuiID id = GetID(str_id); + return BeginTableEx(str_id, id, columns_count, flags, outer_size, inner_width); +} + +bool ImGui::BeginTableEx(const char* name, ImGuiID id, int columns_count, ImGuiTableFlags flags, const ImVec2& outer_size, float inner_width) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* outer_window = GetCurrentWindow(); + if (outer_window->SkipItems) // Consistent with other tables + beneficial side effect that assert on miscalling EndTable() will be more visible. + return false; + + // Sanity checks + IM_ASSERT(columns_count > 0 && columns_count <= IMGUI_TABLE_MAX_COLUMNS && "Only 1..64 columns allowed!"); + if (flags & ImGuiTableFlags_ScrollX) + IM_ASSERT(inner_width >= 0.0f); + + // If an outer size is specified ahead we will be able to early out when not visible. Exact clipping rules may evolve. + const bool use_child_window = (flags & (ImGuiTableFlags_ScrollX | ImGuiTableFlags_ScrollY)) != 0; + const ImVec2 avail_size = GetContentRegionAvail(); + ImVec2 actual_outer_size = CalcItemSize(outer_size, ImMax(avail_size.x, 1.0f), use_child_window ? ImMax(avail_size.y, 1.0f) : 0.0f); + ImRect outer_rect(outer_window->DC.CursorPos, outer_window->DC.CursorPos + actual_outer_size); + if (use_child_window && IsClippedEx(outer_rect, 0)) + { + ItemSize(outer_rect); + return false; + } + + // Acquire storage for the table + ImGuiTable* table = g.Tables.GetOrAddByKey(id); + const int instance_no = (table->LastFrameActive != g.FrameCount) ? 0 : table->InstanceCurrent + 1; + const ImGuiID instance_id = id + instance_no; + const ImGuiTableFlags table_last_flags = table->Flags; + if (instance_no > 0) + IM_ASSERT(table->ColumnsCount == columns_count && "BeginTable(): Cannot change columns count mid-frame while preserving same ID"); + + // Acquire temporary buffers + const int table_idx = g.Tables.GetIndex(table); + g.CurrentTableStackIdx++; + if (g.CurrentTableStackIdx + 1 > g.TablesTempDataStack.Size) + g.TablesTempDataStack.resize(g.CurrentTableStackIdx + 1, ImGuiTableTempData()); + ImGuiTableTempData* temp_data = table->TempData = &g.TablesTempDataStack[g.CurrentTableStackIdx]; + temp_data->TableIndex = table_idx; + table->DrawSplitter = &table->TempData->DrawSplitter; + table->DrawSplitter->Clear(); + + // Fix flags + table->IsDefaultSizingPolicy = (flags & ImGuiTableFlags_SizingMask_) == 0; + flags = TableFixFlags(flags, outer_window); + + // Initialize + table->ID = id; + table->Flags = flags; + table->InstanceCurrent = (ImS16)instance_no; + table->LastFrameActive = g.FrameCount; + table->OuterWindow = table->InnerWindow = outer_window; + table->ColumnsCount = columns_count; + table->IsLayoutLocked = false; + table->InnerWidth = inner_width; + temp_data->UserOuterSize = outer_size; + + // When not using a child window, WorkRect.Max will grow as we append contents. + if (use_child_window) + { + // Ensure no vertical scrollbar appears if we only want horizontal one, to make flag consistent + // (we have no other way to disable vertical scrollbar of a window while keeping the horizontal one showing) + ImVec2 override_content_size(FLT_MAX, FLT_MAX); + if ((flags & ImGuiTableFlags_ScrollX) && !(flags & ImGuiTableFlags_ScrollY)) + override_content_size.y = FLT_MIN; + + // Ensure specified width (when not specified, Stretched columns will act as if the width == OuterWidth and + // never lead to any scrolling). We don't handle inner_width < 0.0f, we could potentially use it to right-align + // based on the right side of the child window work rect, which would require knowing ahead if we are going to + // have decoration taking horizontal spaces (typically a vertical scrollbar). + if ((flags & ImGuiTableFlags_ScrollX) && inner_width > 0.0f) + override_content_size.x = inner_width; + + if (override_content_size.x != FLT_MAX || override_content_size.y != FLT_MAX) + SetNextWindowContentSize(ImVec2(override_content_size.x != FLT_MAX ? override_content_size.x : 0.0f, override_content_size.y != FLT_MAX ? override_content_size.y : 0.0f)); + + // Reset scroll if we are reactivating it + if ((table_last_flags & (ImGuiTableFlags_ScrollX | ImGuiTableFlags_ScrollY)) == 0) + SetNextWindowScroll(ImVec2(0.0f, 0.0f)); + + // Create scrolling region (without border and zero window padding) + ImGuiWindowFlags child_flags = (flags & ImGuiTableFlags_ScrollX) ? ImGuiWindowFlags_HorizontalScrollbar : ImGuiWindowFlags_None; + BeginChildEx(name, instance_id, outer_rect.GetSize(), false, child_flags); + table->InnerWindow = g.CurrentWindow; + table->WorkRect = table->InnerWindow->WorkRect; + table->OuterRect = table->InnerWindow->Rect(); + table->InnerRect = table->InnerWindow->InnerRect; + IM_ASSERT(table->InnerWindow->WindowPadding.x == 0.0f && table->InnerWindow->WindowPadding.y == 0.0f && table->InnerWindow->WindowBorderSize == 0.0f); + } + else + { + // For non-scrolling tables, WorkRect == OuterRect == InnerRect. + // But at this point we do NOT have a correct value for .Max.y (unless a height has been explicitly passed in). It will only be updated in EndTable(). + table->WorkRect = table->OuterRect = table->InnerRect = outer_rect; + } + + // Push a standardized ID for both child-using and not-child-using tables + PushOverrideID(instance_id); + + // Backup a copy of host window members we will modify + ImGuiWindow* inner_window = table->InnerWindow; + table->HostIndentX = inner_window->DC.Indent.x; + table->HostClipRect = inner_window->ClipRect; + table->HostSkipItems = inner_window->SkipItems; + temp_data->HostBackupWorkRect = inner_window->WorkRect; + temp_data->HostBackupParentWorkRect = inner_window->ParentWorkRect; + temp_data->HostBackupColumnsOffset = outer_window->DC.ColumnsOffset; + temp_data->HostBackupPrevLineSize = inner_window->DC.PrevLineSize; + temp_data->HostBackupCurrLineSize = inner_window->DC.CurrLineSize; + temp_data->HostBackupCursorMaxPos = inner_window->DC.CursorMaxPos; + temp_data->HostBackupItemWidth = outer_window->DC.ItemWidth; + temp_data->HostBackupItemWidthStackSize = outer_window->DC.ItemWidthStack.Size; + inner_window->DC.PrevLineSize = inner_window->DC.CurrLineSize = ImVec2(0.0f, 0.0f); + + // Padding and Spacing + // - None ........Content..... Pad .....Content........ + // - PadOuter | Pad ..Content..... Pad .....Content.. Pad | + // - PadInner ........Content.. Pad | Pad ..Content........ + // - PadOuter+PadInner | Pad ..Content.. Pad | Pad ..Content.. Pad | + const bool pad_outer_x = (flags & ImGuiTableFlags_NoPadOuterX) ? false : (flags & ImGuiTableFlags_PadOuterX) ? true : (flags & ImGuiTableFlags_BordersOuterV) != 0; + const bool pad_inner_x = (flags & ImGuiTableFlags_NoPadInnerX) ? false : true; + const float inner_spacing_for_border = (flags & ImGuiTableFlags_BordersInnerV) ? TABLE_BORDER_SIZE : 0.0f; + const float inner_spacing_explicit = (pad_inner_x && (flags & ImGuiTableFlags_BordersInnerV) == 0) ? g.Style.CellPadding.x : 0.0f; + const float inner_padding_explicit = (pad_inner_x && (flags & ImGuiTableFlags_BordersInnerV) != 0) ? g.Style.CellPadding.x : 0.0f; + table->CellSpacingX1 = inner_spacing_explicit + inner_spacing_for_border; + table->CellSpacingX2 = inner_spacing_explicit; + table->CellPaddingX = inner_padding_explicit; + table->CellPaddingY = g.Style.CellPadding.y; + + const float outer_padding_for_border = (flags & ImGuiTableFlags_BordersOuterV) ? TABLE_BORDER_SIZE : 0.0f; + const float outer_padding_explicit = pad_outer_x ? g.Style.CellPadding.x : 0.0f; + table->OuterPaddingX = (outer_padding_for_border + outer_padding_explicit) - table->CellPaddingX; + + table->CurrentColumn = -1; + table->CurrentRow = -1; + table->RowBgColorCounter = 0; + table->LastRowFlags = ImGuiTableRowFlags_None; + table->InnerClipRect = (inner_window == outer_window) ? table->WorkRect : inner_window->ClipRect; + table->InnerClipRect.ClipWith(table->WorkRect); // We need this to honor inner_width + table->InnerClipRect.ClipWithFull(table->HostClipRect); + table->InnerClipRect.Max.y = (flags & ImGuiTableFlags_NoHostExtendY) ? ImMin(table->InnerClipRect.Max.y, inner_window->WorkRect.Max.y) : inner_window->ClipRect.Max.y; + + table->RowPosY1 = table->RowPosY2 = table->WorkRect.Min.y; // This is needed somehow + table->RowTextBaseline = 0.0f; // This will be cleared again by TableBeginRow() + table->FreezeRowsRequest = table->FreezeRowsCount = 0; // This will be setup by TableSetupScrollFreeze(), if any + table->FreezeColumnsRequest = table->FreezeColumnsCount = 0; + table->IsUnfrozenRows = true; + table->DeclColumnsCount = 0; + + // Using opaque colors facilitate overlapping elements of the grid + table->BorderColorStrong = GetColorU32(ImGuiCol_TableBorderStrong); + table->BorderColorLight = GetColorU32(ImGuiCol_TableBorderLight); + + // Make table current + g.CurrentTable = table; + outer_window->DC.CurrentTableIdx = table_idx; + if (inner_window != outer_window) // So EndChild() within the inner window can restore the table properly. + inner_window->DC.CurrentTableIdx = table_idx; + + if ((table_last_flags & ImGuiTableFlags_Reorderable) && (flags & ImGuiTableFlags_Reorderable) == 0) + table->IsResetDisplayOrderRequest = true; + + // Mark as used + if (table_idx >= g.TablesLastTimeActive.Size) + g.TablesLastTimeActive.resize(table_idx + 1, -1.0f); + g.TablesLastTimeActive[table_idx] = (float)g.Time; + temp_data->LastTimeActive = (float)g.Time; + table->MemoryCompacted = false; + + // Setup memory buffer (clear data if columns count changed) + ImGuiTableColumn* old_columns_to_preserve = NULL; + void* old_columns_raw_data = NULL; + const int old_columns_count = table->Columns.size(); + if (old_columns_count != 0 && old_columns_count != columns_count) + { + // Attempt to preserve width on column count change (#4046) + old_columns_to_preserve = table->Columns.Data; + old_columns_raw_data = table->RawData; + table->RawData = NULL; + } + if (table->RawData == NULL) + { + TableBeginInitMemory(table, columns_count); + table->IsInitializing = table->IsSettingsRequestLoad = true; + } + if (table->IsResetAllRequest) + TableResetSettings(table); + if (table->IsInitializing) + { + // Initialize + table->SettingsOffset = -1; + table->IsSortSpecsDirty = true; + table->InstanceInteracted = -1; + table->ContextPopupColumn = -1; + table->ReorderColumn = table->ResizedColumn = table->LastResizedColumn = -1; + table->AutoFitSingleColumn = -1; + table->HoveredColumnBody = table->HoveredColumnBorder = -1; + for (int n = 0; n < columns_count; n++) + { + ImGuiTableColumn* column = &table->Columns[n]; + if (old_columns_to_preserve && n < old_columns_count) + { + // FIXME: We don't attempt to preserve column order in this path. + *column = old_columns_to_preserve[n]; + } + else + { + float width_auto = column->WidthAuto; + *column = ImGuiTableColumn(); + column->WidthAuto = width_auto; + column->IsPreserveWidthAuto = true; // Preserve WidthAuto when reinitializing a live table: not technically necessary but remove a visible flicker + column->IsEnabled = column->IsUserEnabled = column->IsUserEnabledNextFrame = true; + } + column->DisplayOrder = table->DisplayOrderToIndex[n] = (ImGuiTableColumnIdx)n; + } + } + if (old_columns_raw_data) + IM_FREE(old_columns_raw_data); + + // Load settings + if (table->IsSettingsRequestLoad) + TableLoadSettings(table); + + // Handle DPI/font resize + // This is designed to facilitate DPI changes with the assumption that e.g. style.CellPadding has been scaled as well. + // It will also react to changing fonts with mixed results. It doesn't need to be perfect but merely provide a decent transition. + // FIXME-DPI: Provide consistent standards for reference size. Perhaps using g.CurrentDpiScale would be more self explanatory. + // This is will lead us to non-rounded WidthRequest in columns, which should work but is a poorly tested path. + const float new_ref_scale_unit = g.FontSize; // g.Font->GetCharAdvance('A') ? + if (table->RefScale != 0.0f && table->RefScale != new_ref_scale_unit) + { + const float scale_factor = new_ref_scale_unit / table->RefScale; + //IMGUI_DEBUG_LOG("[table] %08X RefScaleUnit %.3f -> %.3f, scaling width by %.3f\n", table->ID, table->RefScaleUnit, new_ref_scale_unit, scale_factor); + for (int n = 0; n < columns_count; n++) + table->Columns[n].WidthRequest = table->Columns[n].WidthRequest * scale_factor; + } + table->RefScale = new_ref_scale_unit; + + // Disable output until user calls TableNextRow() or TableNextColumn() leading to the TableUpdateLayout() call.. + // This is not strictly necessary but will reduce cases were "out of table" output will be misleading to the user. + // Because we cannot safely assert in EndTable() when no rows have been created, this seems like our best option. + inner_window->SkipItems = true; + + // Clear names + // At this point the ->NameOffset field of each column will be invalid until TableUpdateLayout() or the first call to TableSetupColumn() + if (table->ColumnsNames.Buf.Size > 0) + table->ColumnsNames.Buf.resize(0); + + // Apply queued resizing/reordering/hiding requests + TableBeginApplyRequests(table); + + return true; +} + +// For reference, the average total _allocation count_ for a table is: +// + 0 (for ImGuiTable instance, we are pooling allocations in g.Tables) +// + 1 (for table->RawData allocated below) +// + 1 (for table->ColumnsNames, if names are used) +// + 1 (for table->Splitter._Channels) +// + 2 * active_channels_count (for ImDrawCmd and ImDrawIdx buffers inside channels) +// Where active_channels_count is variable but often == columns_count or columns_count + 1, see TableSetupDrawChannels() for details. +// Unused channels don't perform their +2 allocations. +void ImGui::TableBeginInitMemory(ImGuiTable* table, int columns_count) +{ + // Allocate single buffer for our arrays + ImSpanAllocator<3> span_allocator; + span_allocator.Reserve(0, columns_count * sizeof(ImGuiTableColumn)); + span_allocator.Reserve(1, columns_count * sizeof(ImGuiTableColumnIdx)); + span_allocator.Reserve(2, columns_count * sizeof(ImGuiTableCellData), 4); + table->RawData = IM_ALLOC(span_allocator.GetArenaSizeInBytes()); + memset(table->RawData, 0, span_allocator.GetArenaSizeInBytes()); + span_allocator.SetArenaBasePtr(table->RawData); + span_allocator.GetSpan(0, &table->Columns); + span_allocator.GetSpan(1, &table->DisplayOrderToIndex); + span_allocator.GetSpan(2, &table->RowCellData); +} + +// Apply queued resizing/reordering/hiding requests +void ImGui::TableBeginApplyRequests(ImGuiTable* table) +{ + // Handle resizing request + // (We process this at the first TableBegin of the frame) + // FIXME-TABLE: Contains columns if our work area doesn't allow for scrolling? + if (table->InstanceCurrent == 0) + { + if (table->ResizedColumn != -1 && table->ResizedColumnNextWidth != FLT_MAX) + TableSetColumnWidth(table->ResizedColumn, table->ResizedColumnNextWidth); + table->LastResizedColumn = table->ResizedColumn; + table->ResizedColumnNextWidth = FLT_MAX; + table->ResizedColumn = -1; + + // Process auto-fit for single column, which is a special case for stretch columns and fixed columns with FixedSame policy. + // FIXME-TABLE: Would be nice to redistribute available stretch space accordingly to other weights, instead of giving it all to siblings. + if (table->AutoFitSingleColumn != -1) + { + TableSetColumnWidth(table->AutoFitSingleColumn, table->Columns[table->AutoFitSingleColumn].WidthAuto); + table->AutoFitSingleColumn = -1; + } + } + + // Handle reordering request + // Note: we don't clear ReorderColumn after handling the request. + if (table->InstanceCurrent == 0) + { + if (table->HeldHeaderColumn == -1 && table->ReorderColumn != -1) + table->ReorderColumn = -1; + table->HeldHeaderColumn = -1; + if (table->ReorderColumn != -1 && table->ReorderColumnDir != 0) + { + // We need to handle reordering across hidden columns. + // In the configuration below, moving C to the right of E will lead to: + // ... C [D] E ---> ... [D] E C (Column name/index) + // ... 2 3 4 ... 2 3 4 (Display order) + const int reorder_dir = table->ReorderColumnDir; + IM_ASSERT(reorder_dir == -1 || reorder_dir == +1); + IM_ASSERT(table->Flags & ImGuiTableFlags_Reorderable); + ImGuiTableColumn* src_column = &table->Columns[table->ReorderColumn]; + ImGuiTableColumn* dst_column = &table->Columns[(reorder_dir == -1) ? src_column->PrevEnabledColumn : src_column->NextEnabledColumn]; + IM_UNUSED(dst_column); + const int src_order = src_column->DisplayOrder; + const int dst_order = dst_column->DisplayOrder; + src_column->DisplayOrder = (ImGuiTableColumnIdx)dst_order; + for (int order_n = src_order + reorder_dir; order_n != dst_order + reorder_dir; order_n += reorder_dir) + table->Columns[table->DisplayOrderToIndex[order_n]].DisplayOrder -= (ImGuiTableColumnIdx)reorder_dir; + IM_ASSERT(dst_column->DisplayOrder == dst_order - reorder_dir); + + // Display order is stored in both columns->IndexDisplayOrder and table->DisplayOrder[], + // rebuild the later from the former. + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + table->DisplayOrderToIndex[table->Columns[column_n].DisplayOrder] = (ImGuiTableColumnIdx)column_n; + table->ReorderColumnDir = 0; + table->IsSettingsDirty = true; + } + } + + // Handle display order reset request + if (table->IsResetDisplayOrderRequest) + { + for (int n = 0; n < table->ColumnsCount; n++) + table->DisplayOrderToIndex[n] = table->Columns[n].DisplayOrder = (ImGuiTableColumnIdx)n; + table->IsResetDisplayOrderRequest = false; + table->IsSettingsDirty = true; + } +} + +// Adjust flags: default width mode + stretch columns are not allowed when auto extending +static void TableSetupColumnFlags(ImGuiTable* table, ImGuiTableColumn* column, ImGuiTableColumnFlags flags_in) +{ + ImGuiTableColumnFlags flags = flags_in; + + // Sizing Policy + if ((flags & ImGuiTableColumnFlags_WidthMask_) == 0) + { + const ImGuiTableFlags table_sizing_policy = (table->Flags & ImGuiTableFlags_SizingMask_); + if (table_sizing_policy == ImGuiTableFlags_SizingFixedFit || table_sizing_policy == ImGuiTableFlags_SizingFixedSame) + flags |= ImGuiTableColumnFlags_WidthFixed; + else + flags |= ImGuiTableColumnFlags_WidthStretch; + } + else + { + IM_ASSERT(ImIsPowerOfTwo(flags & ImGuiTableColumnFlags_WidthMask_)); // Check that only 1 of each set is used. + } + + // Resize + if ((table->Flags & ImGuiTableFlags_Resizable) == 0) + flags |= ImGuiTableColumnFlags_NoResize; + + // Sorting + if ((flags & ImGuiTableColumnFlags_NoSortAscending) && (flags & ImGuiTableColumnFlags_NoSortDescending)) + flags |= ImGuiTableColumnFlags_NoSort; + + // Indentation + if ((flags & ImGuiTableColumnFlags_IndentMask_) == 0) + flags |= (table->Columns.index_from_ptr(column) == 0) ? ImGuiTableColumnFlags_IndentEnable : ImGuiTableColumnFlags_IndentDisable; + + // Alignment + //if ((flags & ImGuiTableColumnFlags_AlignMask_) == 0) + // flags |= ImGuiTableColumnFlags_AlignCenter; + //IM_ASSERT(ImIsPowerOfTwo(flags & ImGuiTableColumnFlags_AlignMask_)); // Check that only 1 of each set is used. + + // Preserve status flags + column->Flags = flags | (column->Flags & ImGuiTableColumnFlags_StatusMask_); + + // Build an ordered list of available sort directions + column->SortDirectionsAvailCount = column->SortDirectionsAvailMask = column->SortDirectionsAvailList = 0; + if (table->Flags & ImGuiTableFlags_Sortable) + { + int count = 0, mask = 0, list = 0; + if ((flags & ImGuiTableColumnFlags_PreferSortAscending) != 0 && (flags & ImGuiTableColumnFlags_NoSortAscending) == 0) { mask |= 1 << ImGuiSortDirection_Ascending; list |= ImGuiSortDirection_Ascending << (count << 1); count++; } + if ((flags & ImGuiTableColumnFlags_PreferSortDescending) != 0 && (flags & ImGuiTableColumnFlags_NoSortDescending) == 0) { mask |= 1 << ImGuiSortDirection_Descending; list |= ImGuiSortDirection_Descending << (count << 1); count++; } + if ((flags & ImGuiTableColumnFlags_PreferSortAscending) == 0 && (flags & ImGuiTableColumnFlags_NoSortAscending) == 0) { mask |= 1 << ImGuiSortDirection_Ascending; list |= ImGuiSortDirection_Ascending << (count << 1); count++; } + if ((flags & ImGuiTableColumnFlags_PreferSortDescending) == 0 && (flags & ImGuiTableColumnFlags_NoSortDescending) == 0) { mask |= 1 << ImGuiSortDirection_Descending; list |= ImGuiSortDirection_Descending << (count << 1); count++; } + if ((table->Flags & ImGuiTableFlags_SortTristate) || count == 0) { mask |= 1 << ImGuiSortDirection_None; count++; } + column->SortDirectionsAvailList = (ImU8)list; + column->SortDirectionsAvailMask = (ImU8)mask; + column->SortDirectionsAvailCount = (ImU8)count; + ImGui::TableFixColumnSortDirection(table, column); + } +} + +// Layout columns for the frame. This is in essence the followup to BeginTable(). +// Runs on the first call to TableNextRow(), to give a chance for TableSetupColumn() to be called first. +// FIXME-TABLE: Our width (and therefore our WorkRect) will be minimal in the first frame for _WidthAuto columns. +// Increase feedback side-effect with widgets relying on WorkRect.Max.x... Maybe provide a default distribution for _WidthAuto columns? +void ImGui::TableUpdateLayout(ImGuiTable* table) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(table->IsLayoutLocked == false); + + const ImGuiTableFlags table_sizing_policy = (table->Flags & ImGuiTableFlags_SizingMask_); + table->IsDefaultDisplayOrder = true; + table->ColumnsEnabledCount = 0; + table->EnabledMaskByIndex = 0x00; + table->EnabledMaskByDisplayOrder = 0x00; + table->LeftMostEnabledColumn = -1; + table->MinColumnWidth = ImMax(1.0f, g.Style.FramePadding.x * 1.0f); // g.Style.ColumnsMinSpacing; // FIXME-TABLE + + // [Part 1] Apply/lock Enabled and Order states. Calculate auto/ideal width for columns. Count fixed/stretch columns. + // Process columns in their visible orders as we are building the Prev/Next indices. + int count_fixed = 0; // Number of columns that have fixed sizing policies + int count_stretch = 0; // Number of columns that have stretch sizing policies + int prev_visible_column_idx = -1; + bool has_auto_fit_request = false; + bool has_resizable = false; + float stretch_sum_width_auto = 0.0f; + float fixed_max_width_auto = 0.0f; + for (int order_n = 0; order_n < table->ColumnsCount; order_n++) + { + const int column_n = table->DisplayOrderToIndex[order_n]; + if (column_n != order_n) + table->IsDefaultDisplayOrder = false; + ImGuiTableColumn* column = &table->Columns[column_n]; + + // Clear column setup if not submitted by user. Currently we make it mandatory to call TableSetupColumn() every frame. + // It would easily work without but we're not ready to guarantee it since e.g. names need resubmission anyway. + // We take a slight shortcut but in theory we could be calling TableSetupColumn() here with dummy values, it should yield the same effect. + if (table->DeclColumnsCount <= column_n) + { + TableSetupColumnFlags(table, column, ImGuiTableColumnFlags_None); + column->NameOffset = -1; + column->UserID = 0; + column->InitStretchWeightOrWidth = -1.0f; + } + + // Update Enabled state, mark settings and sort specs dirty + if (!(table->Flags & ImGuiTableFlags_Hideable) || (column->Flags & ImGuiTableColumnFlags_NoHide)) + column->IsUserEnabledNextFrame = true; + if (column->IsUserEnabled != column->IsUserEnabledNextFrame) + { + column->IsUserEnabled = column->IsUserEnabledNextFrame; + table->IsSettingsDirty = true; + } + column->IsEnabled = column->IsUserEnabled && (column->Flags & ImGuiTableColumnFlags_Disabled) == 0; + + if (column->SortOrder != -1 && !column->IsEnabled) + table->IsSortSpecsDirty = true; + if (column->SortOrder > 0 && !(table->Flags & ImGuiTableFlags_SortMulti)) + table->IsSortSpecsDirty = true; + + // Auto-fit unsized columns + const bool start_auto_fit = (column->Flags & ImGuiTableColumnFlags_WidthFixed) ? (column->WidthRequest < 0.0f) : (column->StretchWeight < 0.0f); + if (start_auto_fit) + column->AutoFitQueue = column->CannotSkipItemsQueue = (1 << 3) - 1; // Fit for three frames + + if (!column->IsEnabled) + { + column->IndexWithinEnabledSet = -1; + continue; + } + + // Mark as enabled and link to previous/next enabled column + column->PrevEnabledColumn = (ImGuiTableColumnIdx)prev_visible_column_idx; + column->NextEnabledColumn = -1; + if (prev_visible_column_idx != -1) + table->Columns[prev_visible_column_idx].NextEnabledColumn = (ImGuiTableColumnIdx)column_n; + else + table->LeftMostEnabledColumn = (ImGuiTableColumnIdx)column_n; + column->IndexWithinEnabledSet = table->ColumnsEnabledCount++; + table->EnabledMaskByIndex |= (ImU64)1 << column_n; + table->EnabledMaskByDisplayOrder |= (ImU64)1 << column->DisplayOrder; + prev_visible_column_idx = column_n; + IM_ASSERT(column->IndexWithinEnabledSet <= column->DisplayOrder); + + // Calculate ideal/auto column width (that's the width required for all contents to be visible without clipping) + // Combine width from regular rows + width from headers unless requested not to. + if (!column->IsPreserveWidthAuto) + column->WidthAuto = TableGetColumnWidthAuto(table, column); + + // Non-resizable columns keep their requested width (apply user value regardless of IsPreserveWidthAuto) + const bool column_is_resizable = (column->Flags & ImGuiTableColumnFlags_NoResize) == 0; + if (column_is_resizable) + has_resizable = true; + if ((column->Flags & ImGuiTableColumnFlags_WidthFixed) && column->InitStretchWeightOrWidth > 0.0f && !column_is_resizable) + column->WidthAuto = column->InitStretchWeightOrWidth; + + if (column->AutoFitQueue != 0x00) + has_auto_fit_request = true; + if (column->Flags & ImGuiTableColumnFlags_WidthStretch) + { + stretch_sum_width_auto += column->WidthAuto; + count_stretch++; + } + else + { + fixed_max_width_auto = ImMax(fixed_max_width_auto, column->WidthAuto); + count_fixed++; + } + } + if ((table->Flags & ImGuiTableFlags_Sortable) && table->SortSpecsCount == 0 && !(table->Flags & ImGuiTableFlags_SortTristate)) + table->IsSortSpecsDirty = true; + table->RightMostEnabledColumn = (ImGuiTableColumnIdx)prev_visible_column_idx; + IM_ASSERT(table->LeftMostEnabledColumn >= 0 && table->RightMostEnabledColumn >= 0); + + // [Part 2] Disable child window clipping while fitting columns. This is not strictly necessary but makes it possible + // to avoid the column fitting having to wait until the first visible frame of the child container (may or not be a good thing). + // FIXME-TABLE: for always auto-resizing columns may not want to do that all the time. + if (has_auto_fit_request && table->OuterWindow != table->InnerWindow) + table->InnerWindow->SkipItems = false; + if (has_auto_fit_request) + table->IsSettingsDirty = true; + + // [Part 3] Fix column flags and record a few extra information. + float sum_width_requests = 0.0f; // Sum of all width for fixed and auto-resize columns, excluding width contributed by Stretch columns but including spacing/padding. + float stretch_sum_weights = 0.0f; // Sum of all weights for stretch columns. + table->LeftMostStretchedColumn = table->RightMostStretchedColumn = -1; + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + if (!(table->EnabledMaskByIndex & ((ImU64)1 << column_n))) + continue; + ImGuiTableColumn* column = &table->Columns[column_n]; + + const bool column_is_resizable = (column->Flags & ImGuiTableColumnFlags_NoResize) == 0; + if (column->Flags & ImGuiTableColumnFlags_WidthFixed) + { + // Apply same widths policy + float width_auto = column->WidthAuto; + if (table_sizing_policy == ImGuiTableFlags_SizingFixedSame && (column->AutoFitQueue != 0x00 || !column_is_resizable)) + width_auto = fixed_max_width_auto; + + // Apply automatic width + // Latch initial size for fixed columns and update it constantly for auto-resizing column (unless clipped!) + if (column->AutoFitQueue != 0x00) + column->WidthRequest = width_auto; + else if ((column->Flags & ImGuiTableColumnFlags_WidthFixed) && !column_is_resizable && (table->RequestOutputMaskByIndex & ((ImU64)1 << column_n))) + column->WidthRequest = width_auto; + + // FIXME-TABLE: Increase minimum size during init frame to avoid biasing auto-fitting widgets + // (e.g. TextWrapped) too much. Otherwise what tends to happen is that TextWrapped would output a very + // large height (= first frame scrollbar display very off + clipper would skip lots of items). + // This is merely making the side-effect less extreme, but doesn't properly fixes it. + // FIXME: Move this to ->WidthGiven to avoid temporary lossyless? + // FIXME: This break IsPreserveWidthAuto from not flickering if the stored WidthAuto was smaller. + if (column->AutoFitQueue > 0x01 && table->IsInitializing && !column->IsPreserveWidthAuto) + column->WidthRequest = ImMax(column->WidthRequest, table->MinColumnWidth * 4.0f); // FIXME-TABLE: Another constant/scale? + sum_width_requests += column->WidthRequest; + } + else + { + // Initialize stretch weight + if (column->AutoFitQueue != 0x00 || column->StretchWeight < 0.0f || !column_is_resizable) + { + if (column->InitStretchWeightOrWidth > 0.0f) + column->StretchWeight = column->InitStretchWeightOrWidth; + else if (table_sizing_policy == ImGuiTableFlags_SizingStretchProp) + column->StretchWeight = (column->WidthAuto / stretch_sum_width_auto) * count_stretch; + else + column->StretchWeight = 1.0f; + } + + stretch_sum_weights += column->StretchWeight; + if (table->LeftMostStretchedColumn == -1 || table->Columns[table->LeftMostStretchedColumn].DisplayOrder > column->DisplayOrder) + table->LeftMostStretchedColumn = (ImGuiTableColumnIdx)column_n; + if (table->RightMostStretchedColumn == -1 || table->Columns[table->RightMostStretchedColumn].DisplayOrder < column->DisplayOrder) + table->RightMostStretchedColumn = (ImGuiTableColumnIdx)column_n; + } + column->IsPreserveWidthAuto = false; + sum_width_requests += table->CellPaddingX * 2.0f; + } + table->ColumnsEnabledFixedCount = (ImGuiTableColumnIdx)count_fixed; + + // [Part 4] Apply final widths based on requested widths + const ImRect work_rect = table->WorkRect; + const float width_spacings = (table->OuterPaddingX * 2.0f) + (table->CellSpacingX1 + table->CellSpacingX2) * (table->ColumnsEnabledCount - 1); + const float width_avail = ((table->Flags & ImGuiTableFlags_ScrollX) && table->InnerWidth == 0.0f) ? table->InnerClipRect.GetWidth() : work_rect.GetWidth(); + const float width_avail_for_stretched_columns = width_avail - width_spacings - sum_width_requests; + float width_remaining_for_stretched_columns = width_avail_for_stretched_columns; + table->ColumnsGivenWidth = width_spacings + (table->CellPaddingX * 2.0f) * table->ColumnsEnabledCount; + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + if (!(table->EnabledMaskByIndex & ((ImU64)1 << column_n))) + continue; + ImGuiTableColumn* column = &table->Columns[column_n]; + + // Allocate width for stretched/weighted columns (StretchWeight gets converted into WidthRequest) + if (column->Flags & ImGuiTableColumnFlags_WidthStretch) + { + float weight_ratio = column->StretchWeight / stretch_sum_weights; + column->WidthRequest = IM_FLOOR(ImMax(width_avail_for_stretched_columns * weight_ratio, table->MinColumnWidth) + 0.01f); + width_remaining_for_stretched_columns -= column->WidthRequest; + } + + // [Resize Rule 1] The right-most Visible column is not resizable if there is at least one Stretch column + // See additional comments in TableSetColumnWidth(). + if (column->NextEnabledColumn == -1 && table->LeftMostStretchedColumn != -1) + column->Flags |= ImGuiTableColumnFlags_NoDirectResize_; + + // Assign final width, record width in case we will need to shrink + column->WidthGiven = ImFloor(ImMax(column->WidthRequest, table->MinColumnWidth)); + table->ColumnsGivenWidth += column->WidthGiven; + } + + // [Part 5] Redistribute stretch remainder width due to rounding (remainder width is < 1.0f * number of Stretch column). + // Using right-to-left distribution (more likely to match resizing cursor). + if (width_remaining_for_stretched_columns >= 1.0f && !(table->Flags & ImGuiTableFlags_PreciseWidths)) + for (int order_n = table->ColumnsCount - 1; stretch_sum_weights > 0.0f && width_remaining_for_stretched_columns >= 1.0f && order_n >= 0; order_n--) + { + if (!(table->EnabledMaskByDisplayOrder & ((ImU64)1 << order_n))) + continue; + ImGuiTableColumn* column = &table->Columns[table->DisplayOrderToIndex[order_n]]; + if (!(column->Flags & ImGuiTableColumnFlags_WidthStretch)) + continue; + column->WidthRequest += 1.0f; + column->WidthGiven += 1.0f; + width_remaining_for_stretched_columns -= 1.0f; + } + + table->HoveredColumnBody = -1; + table->HoveredColumnBorder = -1; + const ImRect mouse_hit_rect(table->OuterRect.Min.x, table->OuterRect.Min.y, table->OuterRect.Max.x, ImMax(table->OuterRect.Max.y, table->OuterRect.Min.y + table->LastOuterHeight)); + const bool is_hovering_table = ItemHoverable(mouse_hit_rect, 0); + + // [Part 6] Setup final position, offset, skip/clip states and clipping rectangles, detect hovered column + // Process columns in their visible orders as we are comparing the visible order and adjusting host_clip_rect while looping. + int visible_n = 0; + bool offset_x_frozen = (table->FreezeColumnsCount > 0); + float offset_x = ((table->FreezeColumnsCount > 0) ? table->OuterRect.Min.x : work_rect.Min.x) + table->OuterPaddingX - table->CellSpacingX1; + ImRect host_clip_rect = table->InnerClipRect; + //host_clip_rect.Max.x += table->CellPaddingX + table->CellSpacingX2; + table->VisibleMaskByIndex = 0x00; + table->RequestOutputMaskByIndex = 0x00; + for (int order_n = 0; order_n < table->ColumnsCount; order_n++) + { + const int column_n = table->DisplayOrderToIndex[order_n]; + ImGuiTableColumn* column = &table->Columns[column_n]; + + column->NavLayerCurrent = (ImS8)((table->FreezeRowsCount > 0 || column_n < table->FreezeColumnsCount) ? ImGuiNavLayer_Menu : ImGuiNavLayer_Main); + + if (offset_x_frozen && table->FreezeColumnsCount == visible_n) + { + offset_x += work_rect.Min.x - table->OuterRect.Min.x; + offset_x_frozen = false; + } + + // Clear status flags + column->Flags &= ~ImGuiTableColumnFlags_StatusMask_; + + if ((table->EnabledMaskByDisplayOrder & ((ImU64)1 << order_n)) == 0) + { + // Hidden column: clear a few fields and we are done with it for the remainder of the function. + // We set a zero-width clip rect but set Min.y/Max.y properly to not interfere with the clipper. + column->MinX = column->MaxX = column->WorkMinX = column->ClipRect.Min.x = column->ClipRect.Max.x = offset_x; + column->WidthGiven = 0.0f; + column->ClipRect.Min.y = work_rect.Min.y; + column->ClipRect.Max.y = FLT_MAX; + column->ClipRect.ClipWithFull(host_clip_rect); + column->IsVisibleX = column->IsVisibleY = column->IsRequestOutput = false; + column->IsSkipItems = true; + column->ItemWidth = 1.0f; + continue; + } + + // Detect hovered column + if (is_hovering_table && g.IO.MousePos.x >= column->ClipRect.Min.x && g.IO.MousePos.x < column->ClipRect.Max.x) + table->HoveredColumnBody = (ImGuiTableColumnIdx)column_n; + + // Lock start position + column->MinX = offset_x; + + // Lock width based on start position and minimum/maximum width for this position + float max_width = TableGetMaxColumnWidth(table, column_n); + column->WidthGiven = ImMin(column->WidthGiven, max_width); + column->WidthGiven = ImMax(column->WidthGiven, ImMin(column->WidthRequest, table->MinColumnWidth)); + column->MaxX = offset_x + column->WidthGiven + table->CellSpacingX1 + table->CellSpacingX2 + table->CellPaddingX * 2.0f; + + // Lock other positions + // - ClipRect.Min.x: Because merging draw commands doesn't compare min boundaries, we make ClipRect.Min.x match left bounds to be consistent regardless of merging. + // - ClipRect.Max.x: using WorkMaxX instead of MaxX (aka including padding) makes things more consistent when resizing down, tho slightly detrimental to visibility in very-small column. + // - ClipRect.Max.x: using MaxX makes it easier for header to receive hover highlight with no discontinuity and display sorting arrow. + // - FIXME-TABLE: We want equal width columns to have equal (ClipRect.Max.x - WorkMinX) width, which means ClipRect.max.x cannot stray off host_clip_rect.Max.x else right-most column may appear shorter. + column->WorkMinX = column->MinX + table->CellPaddingX + table->CellSpacingX1; + column->WorkMaxX = column->MaxX - table->CellPaddingX - table->CellSpacingX2; // Expected max + column->ItemWidth = ImFloor(column->WidthGiven * 0.65f); + column->ClipRect.Min.x = column->MinX; + column->ClipRect.Min.y = work_rect.Min.y; + column->ClipRect.Max.x = column->MaxX; //column->WorkMaxX; + column->ClipRect.Max.y = FLT_MAX; + column->ClipRect.ClipWithFull(host_clip_rect); + + // Mark column as Clipped (not in sight) + // Note that scrolling tables (where inner_window != outer_window) handle Y clipped earlier in BeginTable() so IsVisibleY really only applies to non-scrolling tables. + // FIXME-TABLE: Because InnerClipRect.Max.y is conservatively ==outer_window->ClipRect.Max.y, we never can mark columns _Above_ the scroll line as not IsVisibleY. + // Taking advantage of LastOuterHeight would yield good results there... + // FIXME-TABLE: Y clipping is disabled because it effectively means not submitting will reduce contents width which is fed to outer_window->DC.CursorMaxPos.x, + // and this may be used (e.g. typically by outer_window using AlwaysAutoResize or outer_window's horizontal scrollbar, but could be something else). + // Possible solution to preserve last known content width for clipped column. Test 'table_reported_size' fails when enabling Y clipping and window is resized small. + column->IsVisibleX = (column->ClipRect.Max.x > column->ClipRect.Min.x); + column->IsVisibleY = true; // (column->ClipRect.Max.y > column->ClipRect.Min.y); + const bool is_visible = column->IsVisibleX; //&& column->IsVisibleY; + if (is_visible) + table->VisibleMaskByIndex |= ((ImU64)1 << column_n); + + // Mark column as requesting output from user. Note that fixed + non-resizable sets are auto-fitting at all times and therefore always request output. + column->IsRequestOutput = is_visible || column->AutoFitQueue != 0 || column->CannotSkipItemsQueue != 0; + if (column->IsRequestOutput) + table->RequestOutputMaskByIndex |= ((ImU64)1 << column_n); + + // Mark column as SkipItems (ignoring all items/layout) + column->IsSkipItems = !column->IsEnabled || table->HostSkipItems; + if (column->IsSkipItems) + IM_ASSERT(!is_visible); + + // Update status flags + column->Flags |= ImGuiTableColumnFlags_IsEnabled; + if (is_visible) + column->Flags |= ImGuiTableColumnFlags_IsVisible; + if (column->SortOrder != -1) + column->Flags |= ImGuiTableColumnFlags_IsSorted; + if (table->HoveredColumnBody == column_n) + column->Flags |= ImGuiTableColumnFlags_IsHovered; + + // Alignment + // FIXME-TABLE: This align based on the whole column width, not per-cell, and therefore isn't useful in + // many cases (to be able to honor this we might be able to store a log of cells width, per row, for + // visible rows, but nav/programmatic scroll would have visible artifacts.) + //if (column->Flags & ImGuiTableColumnFlags_AlignRight) + // column->WorkMinX = ImMax(column->WorkMinX, column->MaxX - column->ContentWidthRowsUnfrozen); + //else if (column->Flags & ImGuiTableColumnFlags_AlignCenter) + // column->WorkMinX = ImLerp(column->WorkMinX, ImMax(column->StartX, column->MaxX - column->ContentWidthRowsUnfrozen), 0.5f); + + // Reset content width variables + column->ContentMaxXFrozen = column->ContentMaxXUnfrozen = column->WorkMinX; + column->ContentMaxXHeadersUsed = column->ContentMaxXHeadersIdeal = column->WorkMinX; + + // Don't decrement auto-fit counters until container window got a chance to submit its items + if (table->HostSkipItems == false) + { + column->AutoFitQueue >>= 1; + column->CannotSkipItemsQueue >>= 1; + } + + if (visible_n < table->FreezeColumnsCount) + host_clip_rect.Min.x = ImClamp(column->MaxX + TABLE_BORDER_SIZE, host_clip_rect.Min.x, host_clip_rect.Max.x); + + offset_x += column->WidthGiven + table->CellSpacingX1 + table->CellSpacingX2 + table->CellPaddingX * 2.0f; + visible_n++; + } + + // [Part 7] Detect/store when we are hovering the unused space after the right-most column (so e.g. context menus can react on it) + // Clear Resizable flag if none of our column are actually resizable (either via an explicit _NoResize flag, either + // because of using _WidthAuto/_WidthStretch). This will hide the resizing option from the context menu. + const float unused_x1 = ImMax(table->WorkRect.Min.x, table->Columns[table->RightMostEnabledColumn].ClipRect.Max.x); + if (is_hovering_table && table->HoveredColumnBody == -1) + { + if (g.IO.MousePos.x >= unused_x1) + table->HoveredColumnBody = (ImGuiTableColumnIdx)table->ColumnsCount; + } + if (has_resizable == false && (table->Flags & ImGuiTableFlags_Resizable)) + table->Flags &= ~ImGuiTableFlags_Resizable; + + // [Part 8] Lock actual OuterRect/WorkRect right-most position. + // This is done late to handle the case of fixed-columns tables not claiming more widths that they need. + // Because of this we are careful with uses of WorkRect and InnerClipRect before this point. + if (table->RightMostStretchedColumn != -1) + table->Flags &= ~ImGuiTableFlags_NoHostExtendX; + if (table->Flags & ImGuiTableFlags_NoHostExtendX) + { + table->OuterRect.Max.x = table->WorkRect.Max.x = unused_x1; + table->InnerClipRect.Max.x = ImMin(table->InnerClipRect.Max.x, unused_x1); + } + table->InnerWindow->ParentWorkRect = table->WorkRect; + table->BorderX1 = table->InnerClipRect.Min.x;// +((table->Flags & ImGuiTableFlags_BordersOuter) ? 0.0f : -1.0f); + table->BorderX2 = table->InnerClipRect.Max.x;// +((table->Flags & ImGuiTableFlags_BordersOuter) ? 0.0f : +1.0f); + + // [Part 9] Allocate draw channels and setup background cliprect + TableSetupDrawChannels(table); + + // [Part 10] Hit testing on borders + if (table->Flags & ImGuiTableFlags_Resizable) + TableUpdateBorders(table); + table->LastFirstRowHeight = 0.0f; + table->IsLayoutLocked = true; + table->IsUsingHeaders = false; + + // [Part 11] Context menu + if (table->IsContextPopupOpen && table->InstanceCurrent == table->InstanceInteracted) + { + const ImGuiID context_menu_id = ImHashStr("##ContextMenu", 0, table->ID); + if (BeginPopupEx(context_menu_id, ImGuiWindowFlags_AlwaysAutoResize | ImGuiWindowFlags_NoTitleBar | ImGuiWindowFlags_NoSavedSettings)) + { + TableDrawContextMenu(table); + EndPopup(); + } + else + { + table->IsContextPopupOpen = false; + } + } + + // [Part 13] Sanitize and build sort specs before we have a change to use them for display. + // This path will only be exercised when sort specs are modified before header rows (e.g. init or visibility change) + if (table->IsSortSpecsDirty && (table->Flags & ImGuiTableFlags_Sortable)) + TableSortSpecsBuild(table); + + // Initial state + ImGuiWindow* inner_window = table->InnerWindow; + if (table->Flags & ImGuiTableFlags_NoClip) + table->DrawSplitter->SetCurrentChannel(inner_window->DrawList, TABLE_DRAW_CHANNEL_NOCLIP); + else + inner_window->DrawList->PushClipRect(inner_window->ClipRect.Min, inner_window->ClipRect.Max, false); +} + +// Process hit-testing on resizing borders. Actual size change will be applied in EndTable() +// - Set table->HoveredColumnBorder with a short delay/timer to reduce feedback noise +// - Submit ahead of table contents and header, use ImGuiButtonFlags_AllowItemOverlap to prioritize widgets +// overlapping the same area. +void ImGui::TableUpdateBorders(ImGuiTable* table) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(table->Flags & ImGuiTableFlags_Resizable); + + // At this point OuterRect height may be zero or under actual final height, so we rely on temporal coherency and + // use the final height from last frame. Because this is only affecting _interaction_ with columns, it is not + // really problematic (whereas the actual visual will be displayed in EndTable() and using the current frame height). + // Actual columns highlight/render will be performed in EndTable() and not be affected. + const float hit_half_width = TABLE_RESIZE_SEPARATOR_HALF_THICKNESS; + const float hit_y1 = table->OuterRect.Min.y; + const float hit_y2_body = ImMax(table->OuterRect.Max.y, hit_y1 + table->LastOuterHeight); + const float hit_y2_head = hit_y1 + table->LastFirstRowHeight; + + for (int order_n = 0; order_n < table->ColumnsCount; order_n++) + { + if (!(table->EnabledMaskByDisplayOrder & ((ImU64)1 << order_n))) + continue; + + const int column_n = table->DisplayOrderToIndex[order_n]; + ImGuiTableColumn* column = &table->Columns[column_n]; + if (column->Flags & (ImGuiTableColumnFlags_NoResize | ImGuiTableColumnFlags_NoDirectResize_)) + continue; + + // ImGuiTableFlags_NoBordersInBodyUntilResize will be honored in TableDrawBorders() + const float border_y2_hit = (table->Flags & ImGuiTableFlags_NoBordersInBody) ? hit_y2_head : hit_y2_body; + if ((table->Flags & ImGuiTableFlags_NoBordersInBody) && table->IsUsingHeaders == false) + continue; + + if (!column->IsVisibleX && table->LastResizedColumn != column_n) + continue; + + ImGuiID column_id = TableGetColumnResizeID(table, column_n, table->InstanceCurrent); + ImRect hit_rect(column->MaxX - hit_half_width, hit_y1, column->MaxX + hit_half_width, border_y2_hit); + //GetForegroundDrawList()->AddRect(hit_rect.Min, hit_rect.Max, IM_COL32(255, 0, 0, 100)); + KeepAliveID(column_id); + + bool hovered = false, held = false; + bool pressed = ButtonBehavior(hit_rect, column_id, &hovered, &held, ImGuiButtonFlags_FlattenChildren | ImGuiButtonFlags_AllowItemOverlap | ImGuiButtonFlags_PressedOnClick | ImGuiButtonFlags_PressedOnDoubleClick | ImGuiButtonFlags_NoNavFocus); + if (pressed && IsMouseDoubleClicked(0)) + { + TableSetColumnWidthAutoSingle(table, column_n); + ClearActiveID(); + held = hovered = false; + } + if (held) + { + if (table->LastResizedColumn == -1) + table->ResizeLockMinContentsX2 = table->RightMostEnabledColumn != -1 ? table->Columns[table->RightMostEnabledColumn].MaxX : -FLT_MAX; + table->ResizedColumn = (ImGuiTableColumnIdx)column_n; + table->InstanceInteracted = table->InstanceCurrent; + } + if ((hovered && g.HoveredIdTimer > TABLE_RESIZE_SEPARATOR_FEEDBACK_TIMER) || held) + { + table->HoveredColumnBorder = (ImGuiTableColumnIdx)column_n; + SetMouseCursor(ImGuiMouseCursor_ResizeEW); + } + } +} + +void ImGui::EndTable() +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + IM_ASSERT(table != NULL && "Only call EndTable() if BeginTable() returns true!"); + + // This assert would be very useful to catch a common error... unfortunately it would probably trigger in some + // cases, and for consistency user may sometimes output empty tables (and still benefit from e.g. outer border) + //IM_ASSERT(table->IsLayoutLocked && "Table unused: never called TableNextRow(), is that the intent?"); + + // If the user never got to call TableNextRow() or TableNextColumn(), we call layout ourselves to ensure all our + // code paths are consistent (instead of just hoping that TableBegin/TableEnd will work), get borders drawn, etc. + if (!table->IsLayoutLocked) + TableUpdateLayout(table); + + const ImGuiTableFlags flags = table->Flags; + ImGuiWindow* inner_window = table->InnerWindow; + ImGuiWindow* outer_window = table->OuterWindow; + ImGuiTableTempData* temp_data = table->TempData; + IM_ASSERT(inner_window == g.CurrentWindow); + IM_ASSERT(outer_window == inner_window || outer_window == inner_window->ParentWindow); + + if (table->IsInsideRow) + TableEndRow(table); + + // Context menu in columns body + if (flags & ImGuiTableFlags_ContextMenuInBody) + if (table->HoveredColumnBody != -1 && !IsAnyItemHovered() && IsMouseReleased(ImGuiMouseButton_Right)) + TableOpenContextMenu((int)table->HoveredColumnBody); + + // Finalize table height + inner_window->DC.PrevLineSize = temp_data->HostBackupPrevLineSize; + inner_window->DC.CurrLineSize = temp_data->HostBackupCurrLineSize; + inner_window->DC.CursorMaxPos = temp_data->HostBackupCursorMaxPos; + const float inner_content_max_y = table->RowPosY2; + IM_ASSERT(table->RowPosY2 == inner_window->DC.CursorPos.y); + if (inner_window != outer_window) + inner_window->DC.CursorMaxPos.y = inner_content_max_y; + else if (!(flags & ImGuiTableFlags_NoHostExtendY)) + table->OuterRect.Max.y = table->InnerRect.Max.y = ImMax(table->OuterRect.Max.y, inner_content_max_y); // Patch OuterRect/InnerRect height + table->WorkRect.Max.y = ImMax(table->WorkRect.Max.y, table->OuterRect.Max.y); + table->LastOuterHeight = table->OuterRect.GetHeight(); + + // Setup inner scrolling range + // FIXME: This ideally should be done earlier, in BeginTable() SetNextWindowContentSize call, just like writing to inner_window->DC.CursorMaxPos.y, + // but since the later is likely to be impossible to do we'd rather update both axises together. + if (table->Flags & ImGuiTableFlags_ScrollX) + { + const float outer_padding_for_border = (table->Flags & ImGuiTableFlags_BordersOuterV) ? TABLE_BORDER_SIZE : 0.0f; + float max_pos_x = table->InnerWindow->DC.CursorMaxPos.x; + if (table->RightMostEnabledColumn != -1) + max_pos_x = ImMax(max_pos_x, table->Columns[table->RightMostEnabledColumn].WorkMaxX + table->CellPaddingX + table->OuterPaddingX - outer_padding_for_border); + if (table->ResizedColumn != -1) + max_pos_x = ImMax(max_pos_x, table->ResizeLockMinContentsX2); + table->InnerWindow->DC.CursorMaxPos.x = max_pos_x; + } + + // Pop clipping rect + if (!(flags & ImGuiTableFlags_NoClip)) + inner_window->DrawList->PopClipRect(); + inner_window->ClipRect = inner_window->DrawList->_ClipRectStack.back(); + + // Draw borders + if ((flags & ImGuiTableFlags_Borders) != 0) + TableDrawBorders(table); + +#if 0 + // Strip out dummy channel draw calls + // We have no way to prevent user submitting direct ImDrawList calls into a hidden column (but ImGui:: calls will be clipped out) + // Pros: remove draw calls which will have no effect. since they'll have zero-size cliprect they may be early out anyway. + // Cons: making it harder for users watching metrics/debugger to spot the wasted vertices. + if (table->DummyDrawChannel != (ImGuiTableColumnIdx)-1) + { + ImDrawChannel* dummy_channel = &table->DrawSplitter._Channels[table->DummyDrawChannel]; + dummy_channel->_CmdBuffer.resize(0); + dummy_channel->_IdxBuffer.resize(0); + } +#endif + + // Flatten channels and merge draw calls + ImDrawListSplitter* splitter = table->DrawSplitter; + splitter->SetCurrentChannel(inner_window->DrawList, 0); + if ((table->Flags & ImGuiTableFlags_NoClip) == 0) + TableMergeDrawChannels(table); + splitter->Merge(inner_window->DrawList); + + // Update ColumnsAutoFitWidth to get us ahead for host using our size to auto-resize without waiting for next BeginTable() + const float width_spacings = (table->OuterPaddingX * 2.0f) + (table->CellSpacingX1 + table->CellSpacingX2) * (table->ColumnsEnabledCount - 1); + table->ColumnsAutoFitWidth = width_spacings + (table->CellPaddingX * 2.0f) * table->ColumnsEnabledCount; + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + if (table->EnabledMaskByIndex & ((ImU64)1 << column_n)) + { + ImGuiTableColumn* column = &table->Columns[column_n]; + if ((column->Flags & ImGuiTableColumnFlags_WidthFixed) && !(column->Flags & ImGuiTableColumnFlags_NoResize)) + table->ColumnsAutoFitWidth += column->WidthRequest; + else + table->ColumnsAutoFitWidth += TableGetColumnWidthAuto(table, column); + } + + // Update scroll + if ((table->Flags & ImGuiTableFlags_ScrollX) == 0 && inner_window != outer_window) + { + inner_window->Scroll.x = 0.0f; + } + else if (table->LastResizedColumn != -1 && table->ResizedColumn == -1 && inner_window->ScrollbarX && table->InstanceInteracted == table->InstanceCurrent) + { + // When releasing a column being resized, scroll to keep the resulting column in sight + const float neighbor_width_to_keep_visible = table->MinColumnWidth + table->CellPaddingX * 2.0f; + ImGuiTableColumn* column = &table->Columns[table->LastResizedColumn]; + if (column->MaxX < table->InnerClipRect.Min.x) + SetScrollFromPosX(inner_window, column->MaxX - inner_window->Pos.x - neighbor_width_to_keep_visible, 1.0f); + else if (column->MaxX > table->InnerClipRect.Max.x) + SetScrollFromPosX(inner_window, column->MaxX - inner_window->Pos.x + neighbor_width_to_keep_visible, 1.0f); + } + + // Apply resizing/dragging at the end of the frame + if (table->ResizedColumn != -1 && table->InstanceCurrent == table->InstanceInteracted) + { + ImGuiTableColumn* column = &table->Columns[table->ResizedColumn]; + const float new_x2 = (g.IO.MousePos.x - g.ActiveIdClickOffset.x + TABLE_RESIZE_SEPARATOR_HALF_THICKNESS); + const float new_width = ImFloor(new_x2 - column->MinX - table->CellSpacingX1 - table->CellPaddingX * 2.0f); + table->ResizedColumnNextWidth = new_width; + } + + // Pop from id stack + IM_ASSERT_USER_ERROR(inner_window->IDStack.back() == table->ID + table->InstanceCurrent, "Mismatching PushID/PopID!"); + IM_ASSERT_USER_ERROR(outer_window->DC.ItemWidthStack.Size >= temp_data->HostBackupItemWidthStackSize, "Too many PopItemWidth!"); + PopID(); + + // Restore window data that we modified + const ImVec2 backup_outer_max_pos = outer_window->DC.CursorMaxPos; + inner_window->WorkRect = temp_data->HostBackupWorkRect; + inner_window->ParentWorkRect = temp_data->HostBackupParentWorkRect; + inner_window->SkipItems = table->HostSkipItems; + outer_window->DC.CursorPos = table->OuterRect.Min; + outer_window->DC.ItemWidth = temp_data->HostBackupItemWidth; + outer_window->DC.ItemWidthStack.Size = temp_data->HostBackupItemWidthStackSize; + outer_window->DC.ColumnsOffset = temp_data->HostBackupColumnsOffset; + + // Layout in outer window + // (FIXME: To allow auto-fit and allow desirable effect of SameLine() we dissociate 'used' vs 'ideal' size by overriding + // CursorPosPrevLine and CursorMaxPos manually. That should be a more general layout feature, see same problem e.g. #3414) + if (inner_window != outer_window) + { + EndChild(); + } + else + { + ItemSize(table->OuterRect.GetSize()); + ItemAdd(table->OuterRect, 0); + } + + // Override declared contents width/height to enable auto-resize while not needlessly adding a scrollbar + if (table->Flags & ImGuiTableFlags_NoHostExtendX) + { + // FIXME-TABLE: Could we remove this section? + // ColumnsAutoFitWidth may be one frame ahead here since for Fixed+NoResize is calculated from latest contents + IM_ASSERT((table->Flags & ImGuiTableFlags_ScrollX) == 0); + outer_window->DC.CursorMaxPos.x = ImMax(backup_outer_max_pos.x, table->OuterRect.Min.x + table->ColumnsAutoFitWidth); + } + else if (temp_data->UserOuterSize.x <= 0.0f) + { + const float decoration_size = (table->Flags & ImGuiTableFlags_ScrollX) ? inner_window->ScrollbarSizes.x : 0.0f; + outer_window->DC.IdealMaxPos.x = ImMax(outer_window->DC.IdealMaxPos.x, table->OuterRect.Min.x + table->ColumnsAutoFitWidth + decoration_size - temp_data->UserOuterSize.x); + outer_window->DC.CursorMaxPos.x = ImMax(backup_outer_max_pos.x, ImMin(table->OuterRect.Max.x, table->OuterRect.Min.x + table->ColumnsAutoFitWidth)); + } + else + { + outer_window->DC.CursorMaxPos.x = ImMax(backup_outer_max_pos.x, table->OuterRect.Max.x); + } + if (temp_data->UserOuterSize.y <= 0.0f) + { + const float decoration_size = (table->Flags & ImGuiTableFlags_ScrollY) ? inner_window->ScrollbarSizes.y : 0.0f; + outer_window->DC.IdealMaxPos.y = ImMax(outer_window->DC.IdealMaxPos.y, inner_content_max_y + decoration_size - temp_data->UserOuterSize.y); + outer_window->DC.CursorMaxPos.y = ImMax(backup_outer_max_pos.y, ImMin(table->OuterRect.Max.y, inner_content_max_y)); + } + else + { + // OuterRect.Max.y may already have been pushed downward from the initial value (unless ImGuiTableFlags_NoHostExtendY is set) + outer_window->DC.CursorMaxPos.y = ImMax(backup_outer_max_pos.y, table->OuterRect.Max.y); + } + + // Save settings + if (table->IsSettingsDirty) + TableSaveSettings(table); + table->IsInitializing = false; + + // Clear or restore current table, if any + IM_ASSERT(g.CurrentWindow == outer_window && g.CurrentTable == table); + IM_ASSERT(g.CurrentTableStackIdx >= 0); + g.CurrentTableStackIdx--; + temp_data = g.CurrentTableStackIdx >= 0 ? &g.TablesTempDataStack[g.CurrentTableStackIdx] : NULL; + g.CurrentTable = temp_data ? g.Tables.GetByIndex(temp_data->TableIndex) : NULL; + if (g.CurrentTable) + { + g.CurrentTable->TempData = temp_data; + g.CurrentTable->DrawSplitter = &temp_data->DrawSplitter; + } + outer_window->DC.CurrentTableIdx = g.CurrentTable ? g.Tables.GetIndex(g.CurrentTable) : -1; +} + +// See "COLUMN SIZING POLICIES" comments at the top of this file +// If (init_width_or_weight <= 0.0f) it is ignored +void ImGui::TableSetupColumn(const char* label, ImGuiTableColumnFlags flags, float init_width_or_weight, ImGuiID user_id) +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + IM_ASSERT(table != NULL && "Need to call TableSetupColumn() after BeginTable()!"); + IM_ASSERT(table->IsLayoutLocked == false && "Need to call call TableSetupColumn() before first row!"); + IM_ASSERT((flags & ImGuiTableColumnFlags_StatusMask_) == 0 && "Illegal to pass StatusMask values to TableSetupColumn()"); + if (table->DeclColumnsCount >= table->ColumnsCount) + { + IM_ASSERT_USER_ERROR(table->DeclColumnsCount < table->ColumnsCount, "Called TableSetupColumn() too many times!"); + return; + } + + ImGuiTableColumn* column = &table->Columns[table->DeclColumnsCount]; + table->DeclColumnsCount++; + + // Assert when passing a width or weight if policy is entirely left to default, to avoid storing width into weight and vice-versa. + // Give a grace to users of ImGuiTableFlags_ScrollX. + if (table->IsDefaultSizingPolicy && (flags & ImGuiTableColumnFlags_WidthMask_) == 0 && (flags & ImGuiTableFlags_ScrollX) == 0) + IM_ASSERT(init_width_or_weight <= 0.0f && "Can only specify width/weight if sizing policy is set explicitly in either Table or Column."); + + // When passing a width automatically enforce WidthFixed policy + // (whereas TableSetupColumnFlags would default to WidthAuto if table is not Resizable) + if ((flags & ImGuiTableColumnFlags_WidthMask_) == 0 && init_width_or_weight > 0.0f) + if ((table->Flags & ImGuiTableFlags_SizingMask_) == ImGuiTableFlags_SizingFixedFit || (table->Flags & ImGuiTableFlags_SizingMask_) == ImGuiTableFlags_SizingFixedSame) + flags |= ImGuiTableColumnFlags_WidthFixed; + + TableSetupColumnFlags(table, column, flags); + column->UserID = user_id; + flags = column->Flags; + + // Initialize defaults + column->InitStretchWeightOrWidth = init_width_or_weight; + if (table->IsInitializing) + { + // Init width or weight + if (column->WidthRequest < 0.0f && column->StretchWeight < 0.0f) + { + if ((flags & ImGuiTableColumnFlags_WidthFixed) && init_width_or_weight > 0.0f) + column->WidthRequest = init_width_or_weight; + if (flags & ImGuiTableColumnFlags_WidthStretch) + column->StretchWeight = (init_width_or_weight > 0.0f) ? init_width_or_weight : -1.0f; + + // Disable auto-fit if an explicit width/weight has been specified + if (init_width_or_weight > 0.0f) + column->AutoFitQueue = 0x00; + } + + // Init default visibility/sort state + if ((flags & ImGuiTableColumnFlags_DefaultHide) && (table->SettingsLoadedFlags & ImGuiTableFlags_Hideable) == 0) + column->IsUserEnabled = column->IsUserEnabledNextFrame = false; + if (flags & ImGuiTableColumnFlags_DefaultSort && (table->SettingsLoadedFlags & ImGuiTableFlags_Sortable) == 0) + { + column->SortOrder = 0; // Multiple columns using _DefaultSort will be reassigned unique SortOrder values when building the sort specs. + column->SortDirection = (column->Flags & ImGuiTableColumnFlags_PreferSortDescending) ? (ImS8)ImGuiSortDirection_Descending : (ImU8)(ImGuiSortDirection_Ascending); + } + } + + // Store name (append with zero-terminator in contiguous buffer) + column->NameOffset = -1; + if (label != NULL && label[0] != 0) + { + column->NameOffset = (ImS16)table->ColumnsNames.size(); + table->ColumnsNames.append(label, label + strlen(label) + 1); + } +} + +// [Public] +void ImGui::TableSetupScrollFreeze(int columns, int rows) +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + IM_ASSERT(table != NULL && "Need to call TableSetupColumn() after BeginTable()!"); + IM_ASSERT(table->IsLayoutLocked == false && "Need to call TableSetupColumn() before first row!"); + IM_ASSERT(columns >= 0 && columns < IMGUI_TABLE_MAX_COLUMNS); + IM_ASSERT(rows >= 0 && rows < 128); // Arbitrary limit + + table->FreezeColumnsRequest = (table->Flags & ImGuiTableFlags_ScrollX) ? (ImGuiTableColumnIdx)ImMin(columns, table->ColumnsCount) : 0; + table->FreezeColumnsCount = (table->InnerWindow->Scroll.x != 0.0f) ? table->FreezeColumnsRequest : 0; + table->FreezeRowsRequest = (table->Flags & ImGuiTableFlags_ScrollY) ? (ImGuiTableColumnIdx)rows : 0; + table->FreezeRowsCount = (table->InnerWindow->Scroll.y != 0.0f) ? table->FreezeRowsRequest : 0; + table->IsUnfrozenRows = (table->FreezeRowsCount == 0); // Make sure this is set before TableUpdateLayout() so ImGuiListClipper can benefit from it.b + + // Ensure frozen columns are ordered in their section. We still allow multiple frozen columns to be reordered. + // FIXME-TABLE: This work for preserving 2143 into 21|43. How about 4321 turning into 21|43? (preserve relative order in each section) + for (int column_n = 0; column_n < table->FreezeColumnsRequest; column_n++) + { + int order_n = table->DisplayOrderToIndex[column_n]; + if (order_n != column_n && order_n >= table->FreezeColumnsRequest) + { + ImSwap(table->Columns[table->DisplayOrderToIndex[order_n]].DisplayOrder, table->Columns[table->DisplayOrderToIndex[column_n]].DisplayOrder); + ImSwap(table->DisplayOrderToIndex[order_n], table->DisplayOrderToIndex[column_n]); + } + } +} + +//----------------------------------------------------------------------------- +// [SECTION] Tables: Simple accessors +//----------------------------------------------------------------------------- +// - TableGetColumnCount() +// - TableGetColumnName() +// - TableGetColumnName() [Internal] +// - TableSetColumnEnabled() +// - TableGetColumnFlags() +// - TableGetCellBgRect() [Internal] +// - TableGetColumnResizeID() [Internal] +// - TableGetHoveredColumn() [Internal] +// - TableSetBgColor() +//----------------------------------------------------------------------------- + +int ImGui::TableGetColumnCount() +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + return table ? table->ColumnsCount : 0; +} + +const char* ImGui::TableGetColumnName(int column_n) +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + if (!table) + return NULL; + if (column_n < 0) + column_n = table->CurrentColumn; + return TableGetColumnName(table, column_n); +} + +const char* ImGui::TableGetColumnName(const ImGuiTable* table, int column_n) +{ + if (table->IsLayoutLocked == false && column_n >= table->DeclColumnsCount) + return ""; // NameOffset is invalid at this point + const ImGuiTableColumn* column = &table->Columns[column_n]; + if (column->NameOffset == -1) + return ""; + return &table->ColumnsNames.Buf[column->NameOffset]; +} + +// Change user accessible enabled/disabled state of a column (often perceived as "showing/hiding" from users point of view) +// Note that end-user can use the context menu to change this themselves (right-click in headers, or right-click in columns body with ImGuiTableFlags_ContextMenuInBody) +// - Require table to have the ImGuiTableFlags_Hideable flag because we are manipulating user accessible state. +// - Request will be applied during next layout, which happens on the first call to TableNextRow() after BeginTable(). +// - For the getter you can test (TableGetColumnFlags() & ImGuiTableColumnFlags_IsEnabled) != 0. +// - Alternative: the ImGuiTableColumnFlags_Disabled is an overriding/master disable flag which will also hide the column from context menu. +void ImGui::TableSetColumnEnabled(int column_n, bool enabled) +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + IM_ASSERT(table != NULL); + if (!table) + return; + IM_ASSERT(table->Flags & ImGuiTableFlags_Hideable); // See comments above + if (column_n < 0) + column_n = table->CurrentColumn; + IM_ASSERT(column_n >= 0 && column_n < table->ColumnsCount); + ImGuiTableColumn* column = &table->Columns[column_n]; + column->IsUserEnabledNextFrame = enabled; +} + +// We allow querying for an extra column in order to poll the IsHovered state of the right-most section +ImGuiTableColumnFlags ImGui::TableGetColumnFlags(int column_n) +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + if (!table) + return ImGuiTableColumnFlags_None; + if (column_n < 0) + column_n = table->CurrentColumn; + if (column_n == table->ColumnsCount) + return (table->HoveredColumnBody == column_n) ? ImGuiTableColumnFlags_IsHovered : ImGuiTableColumnFlags_None; + return table->Columns[column_n].Flags; +} + +// Return the cell rectangle based on currently known height. +// - Important: we generally don't know our row height until the end of the row, so Max.y will be incorrect in many situations. +// The only case where this is correct is if we provided a min_row_height to TableNextRow() and don't go below it. +// - Important: if ImGuiTableFlags_PadOuterX is set but ImGuiTableFlags_PadInnerX is not set, the outer-most left and right +// columns report a small offset so their CellBgRect can extend up to the outer border. +ImRect ImGui::TableGetCellBgRect(const ImGuiTable* table, int column_n) +{ + const ImGuiTableColumn* column = &table->Columns[column_n]; + float x1 = column->MinX; + float x2 = column->MaxX; + if (column->PrevEnabledColumn == -1) + x1 -= table->CellSpacingX1; + if (column->NextEnabledColumn == -1) + x2 += table->CellSpacingX2; + return ImRect(x1, table->RowPosY1, x2, table->RowPosY2); +} + +// Return the resizing ID for the right-side of the given column. +ImGuiID ImGui::TableGetColumnResizeID(const ImGuiTable* table, int column_n, int instance_no) +{ + IM_ASSERT(column_n >= 0 && column_n < table->ColumnsCount); + ImGuiID id = table->ID + 1 + (instance_no * table->ColumnsCount) + column_n; + return id; +} + +// Return -1 when table is not hovered. return columns_count if the unused space at the right of visible columns is hovered. +int ImGui::TableGetHoveredColumn() +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + if (!table) + return -1; + return (int)table->HoveredColumnBody; +} + +void ImGui::TableSetBgColor(ImGuiTableBgTarget target, ImU32 color, int column_n) +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + IM_ASSERT(target != ImGuiTableBgTarget_None); + + if (color == IM_COL32_DISABLE) + color = 0; + + // We cannot draw neither the cell or row background immediately as we don't know the row height at this point in time. + switch (target) + { + case ImGuiTableBgTarget_CellBg: + { + if (table->RowPosY1 > table->InnerClipRect.Max.y) // Discard + return; + if (column_n == -1) + column_n = table->CurrentColumn; + if ((table->VisibleMaskByIndex & ((ImU64)1 << column_n)) == 0) + return; + if (table->RowCellDataCurrent < 0 || table->RowCellData[table->RowCellDataCurrent].Column != column_n) + table->RowCellDataCurrent++; + ImGuiTableCellData* cell_data = &table->RowCellData[table->RowCellDataCurrent]; + cell_data->BgColor = color; + cell_data->Column = (ImGuiTableColumnIdx)column_n; + break; + } + case ImGuiTableBgTarget_RowBg0: + case ImGuiTableBgTarget_RowBg1: + { + if (table->RowPosY1 > table->InnerClipRect.Max.y) // Discard + return; + IM_ASSERT(column_n == -1); + int bg_idx = (target == ImGuiTableBgTarget_RowBg1) ? 1 : 0; + table->RowBgColor[bg_idx] = color; + break; + } + default: + IM_ASSERT(0); + } +} + +//------------------------------------------------------------------------- +// [SECTION] Tables: Row changes +//------------------------------------------------------------------------- +// - TableGetRowIndex() +// - TableNextRow() +// - TableBeginRow() [Internal] +// - TableEndRow() [Internal] +//------------------------------------------------------------------------- + +// [Public] Note: for row coloring we use ->RowBgColorCounter which is the same value without counting header rows +int ImGui::TableGetRowIndex() +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + if (!table) + return 0; + return table->CurrentRow; +} + +// [Public] Starts into the first cell of a new row +void ImGui::TableNextRow(ImGuiTableRowFlags row_flags, float row_min_height) +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + + if (!table->IsLayoutLocked) + TableUpdateLayout(table); + if (table->IsInsideRow) + TableEndRow(table); + + table->LastRowFlags = table->RowFlags; + table->RowFlags = row_flags; + table->RowMinHeight = row_min_height; + TableBeginRow(table); + + // We honor min_row_height requested by user, but cannot guarantee per-row maximum height, + // because that would essentially require a unique clipping rectangle per-cell. + table->RowPosY2 += table->CellPaddingY * 2.0f; + table->RowPosY2 = ImMax(table->RowPosY2, table->RowPosY1 + row_min_height); + + // Disable output until user calls TableNextColumn() + table->InnerWindow->SkipItems = true; +} + +// [Internal] Called by TableNextRow() +void ImGui::TableBeginRow(ImGuiTable* table) +{ + ImGuiWindow* window = table->InnerWindow; + IM_ASSERT(!table->IsInsideRow); + + // New row + table->CurrentRow++; + table->CurrentColumn = -1; + table->RowBgColor[0] = table->RowBgColor[1] = IM_COL32_DISABLE; + table->RowCellDataCurrent = -1; + table->IsInsideRow = true; + + // Begin frozen rows + float next_y1 = table->RowPosY2; + if (table->CurrentRow == 0 && table->FreezeRowsCount > 0) + next_y1 = window->DC.CursorPos.y = table->OuterRect.Min.y; + + table->RowPosY1 = table->RowPosY2 = next_y1; + table->RowTextBaseline = 0.0f; + table->RowIndentOffsetX = window->DC.Indent.x - table->HostIndentX; // Lock indent + window->DC.PrevLineTextBaseOffset = 0.0f; + window->DC.CursorMaxPos.y = next_y1; + + // Making the header BG color non-transparent will allow us to overlay it multiple times when handling smooth dragging. + if (table->RowFlags & ImGuiTableRowFlags_Headers) + { + TableSetBgColor(ImGuiTableBgTarget_RowBg0, GetColorU32(ImGuiCol_TableHeaderBg)); + if (table->CurrentRow == 0) + table->IsUsingHeaders = true; + } +} + +// [Internal] Called by TableNextRow() +void ImGui::TableEndRow(ImGuiTable* table) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + IM_ASSERT(window == table->InnerWindow); + IM_ASSERT(table->IsInsideRow); + + if (table->CurrentColumn != -1) + TableEndCell(table); + + // Logging + if (g.LogEnabled) + LogRenderedText(NULL, "|"); + + // Position cursor at the bottom of our row so it can be used for e.g. clipping calculation. However it is + // likely that the next call to TableBeginCell() will reposition the cursor to take account of vertical padding. + window->DC.CursorPos.y = table->RowPosY2; + + // Row background fill + const float bg_y1 = table->RowPosY1; + const float bg_y2 = table->RowPosY2; + const bool unfreeze_rows_actual = (table->CurrentRow + 1 == table->FreezeRowsCount); + const bool unfreeze_rows_request = (table->CurrentRow + 1 == table->FreezeRowsRequest); + if (table->CurrentRow == 0) + table->LastFirstRowHeight = bg_y2 - bg_y1; + + const bool is_visible = (bg_y2 >= table->InnerClipRect.Min.y && bg_y1 <= table->InnerClipRect.Max.y); + if (is_visible) + { + // Decide of background color for the row + ImU32 bg_col0 = 0; + ImU32 bg_col1 = 0; + if (table->RowBgColor[0] != IM_COL32_DISABLE) + bg_col0 = table->RowBgColor[0]; + else if (table->Flags & ImGuiTableFlags_RowBg) + bg_col0 = GetColorU32((table->RowBgColorCounter & 1) ? ImGuiCol_TableRowBgAlt : ImGuiCol_TableRowBg); + if (table->RowBgColor[1] != IM_COL32_DISABLE) + bg_col1 = table->RowBgColor[1]; + + // Decide of top border color + ImU32 border_col = 0; + const float border_size = TABLE_BORDER_SIZE; + if (table->CurrentRow > 0 || table->InnerWindow == table->OuterWindow) + if (table->Flags & ImGuiTableFlags_BordersInnerH) + border_col = (table->LastRowFlags & ImGuiTableRowFlags_Headers) ? table->BorderColorStrong : table->BorderColorLight; + + const bool draw_cell_bg_color = table->RowCellDataCurrent >= 0; + const bool draw_strong_bottom_border = unfreeze_rows_actual; + if ((bg_col0 | bg_col1 | border_col) != 0 || draw_strong_bottom_border || draw_cell_bg_color) + { + // In theory we could call SetWindowClipRectBeforeSetChannel() but since we know TableEndRow() is + // always followed by a change of clipping rectangle we perform the smallest overwrite possible here. + if ((table->Flags & ImGuiTableFlags_NoClip) == 0) + window->DrawList->_CmdHeader.ClipRect = table->Bg0ClipRectForDrawCmd.ToVec4(); + table->DrawSplitter->SetCurrentChannel(window->DrawList, TABLE_DRAW_CHANNEL_BG0); + } + + // Draw row background + // We soft/cpu clip this so all backgrounds and borders can share the same clipping rectangle + if (bg_col0 || bg_col1) + { + ImRect row_rect(table->WorkRect.Min.x, bg_y1, table->WorkRect.Max.x, bg_y2); + row_rect.ClipWith(table->BgClipRect); + if (bg_col0 != 0 && row_rect.Min.y < row_rect.Max.y) + window->DrawList->AddRectFilled(row_rect.Min, row_rect.Max, bg_col0); + if (bg_col1 != 0 && row_rect.Min.y < row_rect.Max.y) + window->DrawList->AddRectFilled(row_rect.Min, row_rect.Max, bg_col1); + } + + // Draw cell background color + if (draw_cell_bg_color) + { + ImGuiTableCellData* cell_data_end = &table->RowCellData[table->RowCellDataCurrent]; + for (ImGuiTableCellData* cell_data = &table->RowCellData[0]; cell_data <= cell_data_end; cell_data++) + { + const ImGuiTableColumn* column = &table->Columns[cell_data->Column]; + ImRect cell_bg_rect = TableGetCellBgRect(table, cell_data->Column); + cell_bg_rect.ClipWith(table->BgClipRect); + cell_bg_rect.Min.x = ImMax(cell_bg_rect.Min.x, column->ClipRect.Min.x); // So that first column after frozen one gets clipped + cell_bg_rect.Max.x = ImMin(cell_bg_rect.Max.x, column->MaxX); + window->DrawList->AddRectFilled(cell_bg_rect.Min, cell_bg_rect.Max, cell_data->BgColor); + } + } + + // Draw top border + if (border_col && bg_y1 >= table->BgClipRect.Min.y && bg_y1 < table->BgClipRect.Max.y) + window->DrawList->AddLine(ImVec2(table->BorderX1, bg_y1), ImVec2(table->BorderX2, bg_y1), border_col, border_size); + + // Draw bottom border at the row unfreezing mark (always strong) + if (draw_strong_bottom_border && bg_y2 >= table->BgClipRect.Min.y && bg_y2 < table->BgClipRect.Max.y) + window->DrawList->AddLine(ImVec2(table->BorderX1, bg_y2), ImVec2(table->BorderX2, bg_y2), table->BorderColorStrong, border_size); + } + + // End frozen rows (when we are past the last frozen row line, teleport cursor and alter clipping rectangle) + // We need to do that in TableEndRow() instead of TableBeginRow() so the list clipper can mark end of row and + // get the new cursor position. + if (unfreeze_rows_request) + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + ImGuiTableColumn* column = &table->Columns[column_n]; + column->NavLayerCurrent = (ImS8)((column_n < table->FreezeColumnsCount) ? ImGuiNavLayer_Menu : ImGuiNavLayer_Main); + } + if (unfreeze_rows_actual) + { + IM_ASSERT(table->IsUnfrozenRows == false); + table->IsUnfrozenRows = true; + + // BgClipRect starts as table->InnerClipRect, reduce it now and make BgClipRectForDrawCmd == BgClipRect + float y0 = ImMax(table->RowPosY2 + 1, window->InnerClipRect.Min.y); + table->BgClipRect.Min.y = table->Bg2ClipRectForDrawCmd.Min.y = ImMin(y0, window->InnerClipRect.Max.y); + table->BgClipRect.Max.y = table->Bg2ClipRectForDrawCmd.Max.y = window->InnerClipRect.Max.y; + table->Bg2DrawChannelCurrent = table->Bg2DrawChannelUnfrozen; + IM_ASSERT(table->Bg2ClipRectForDrawCmd.Min.y <= table->Bg2ClipRectForDrawCmd.Max.y); + + float row_height = table->RowPosY2 - table->RowPosY1; + table->RowPosY2 = window->DC.CursorPos.y = table->WorkRect.Min.y + table->RowPosY2 - table->OuterRect.Min.y; + table->RowPosY1 = table->RowPosY2 - row_height; + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + ImGuiTableColumn* column = &table->Columns[column_n]; + column->DrawChannelCurrent = column->DrawChannelUnfrozen; + column->ClipRect.Min.y = table->Bg2ClipRectForDrawCmd.Min.y; + } + + // Update cliprect ahead of TableBeginCell() so clipper can access to new ClipRect->Min.y + SetWindowClipRectBeforeSetChannel(window, table->Columns[0].ClipRect); + table->DrawSplitter->SetCurrentChannel(window->DrawList, table->Columns[0].DrawChannelCurrent); + } + + if (!(table->RowFlags & ImGuiTableRowFlags_Headers)) + table->RowBgColorCounter++; + table->IsInsideRow = false; +} + +//------------------------------------------------------------------------- +// [SECTION] Tables: Columns changes +//------------------------------------------------------------------------- +// - TableGetColumnIndex() +// - TableSetColumnIndex() +// - TableNextColumn() +// - TableBeginCell() [Internal] +// - TableEndCell() [Internal] +//------------------------------------------------------------------------- + +int ImGui::TableGetColumnIndex() +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + if (!table) + return 0; + return table->CurrentColumn; +} + +// [Public] Append into a specific column +bool ImGui::TableSetColumnIndex(int column_n) +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + if (!table) + return false; + + if (table->CurrentColumn != column_n) + { + if (table->CurrentColumn != -1) + TableEndCell(table); + IM_ASSERT(column_n >= 0 && table->ColumnsCount); + TableBeginCell(table, column_n); + } + + // Return whether the column is visible. User may choose to skip submitting items based on this return value, + // however they shouldn't skip submitting for columns that may have the tallest contribution to row height. + return (table->RequestOutputMaskByIndex & ((ImU64)1 << column_n)) != 0; +} + +// [Public] Append into the next column, wrap and create a new row when already on last column +bool ImGui::TableNextColumn() +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + if (!table) + return false; + + if (table->IsInsideRow && table->CurrentColumn + 1 < table->ColumnsCount) + { + if (table->CurrentColumn != -1) + TableEndCell(table); + TableBeginCell(table, table->CurrentColumn + 1); + } + else + { + TableNextRow(); + TableBeginCell(table, 0); + } + + // Return whether the column is visible. User may choose to skip submitting items based on this return value, + // however they shouldn't skip submitting for columns that may have the tallest contribution to row height. + int column_n = table->CurrentColumn; + return (table->RequestOutputMaskByIndex & ((ImU64)1 << column_n)) != 0; +} + + +// [Internal] Called by TableSetColumnIndex()/TableNextColumn() +// This is called very frequently, so we need to be mindful of unnecessary overhead. +// FIXME-TABLE FIXME-OPT: Could probably shortcut some things for non-active or clipped columns. +void ImGui::TableBeginCell(ImGuiTable* table, int column_n) +{ + ImGuiTableColumn* column = &table->Columns[column_n]; + ImGuiWindow* window = table->InnerWindow; + table->CurrentColumn = column_n; + + // Start position is roughly ~~ CellRect.Min + CellPadding + Indent + float start_x = column->WorkMinX; + if (column->Flags & ImGuiTableColumnFlags_IndentEnable) + start_x += table->RowIndentOffsetX; // ~~ += window.DC.Indent.x - table->HostIndentX, except we locked it for the row. + + window->DC.CursorPos.x = start_x; + window->DC.CursorPos.y = table->RowPosY1 + table->CellPaddingY; + window->DC.CursorMaxPos.x = window->DC.CursorPos.x; + window->DC.ColumnsOffset.x = start_x - window->Pos.x - window->DC.Indent.x; // FIXME-WORKRECT + window->DC.CurrLineTextBaseOffset = table->RowTextBaseline; + window->DC.NavLayerCurrent = (ImGuiNavLayer)column->NavLayerCurrent; + + window->WorkRect.Min.y = window->DC.CursorPos.y; + window->WorkRect.Min.x = column->WorkMinX; + window->WorkRect.Max.x = column->WorkMaxX; + window->DC.ItemWidth = column->ItemWidth; + + // To allow ImGuiListClipper to function we propagate our row height + if (!column->IsEnabled) + window->DC.CursorPos.y = ImMax(window->DC.CursorPos.y, table->RowPosY2); + + window->SkipItems = column->IsSkipItems; + if (column->IsSkipItems) + { + ImGuiContext& g = *GImGui; + g.LastItemData.ID = 0; + g.LastItemData.StatusFlags = 0; + } + + if (table->Flags & ImGuiTableFlags_NoClip) + { + // FIXME: if we end up drawing all borders/bg in EndTable, could remove this and just assert that channel hasn't changed. + table->DrawSplitter->SetCurrentChannel(window->DrawList, TABLE_DRAW_CHANNEL_NOCLIP); + //IM_ASSERT(table->DrawSplitter._Current == TABLE_DRAW_CHANNEL_NOCLIP); + } + else + { + // FIXME-TABLE: Could avoid this if draw channel is dummy channel? + SetWindowClipRectBeforeSetChannel(window, column->ClipRect); + table->DrawSplitter->SetCurrentChannel(window->DrawList, column->DrawChannelCurrent); + } + + // Logging + ImGuiContext& g = *GImGui; + if (g.LogEnabled && !column->IsSkipItems) + { + LogRenderedText(&window->DC.CursorPos, "|"); + g.LogLinePosY = FLT_MAX; + } +} + +// [Internal] Called by TableNextRow()/TableSetColumnIndex()/TableNextColumn() +void ImGui::TableEndCell(ImGuiTable* table) +{ + ImGuiTableColumn* column = &table->Columns[table->CurrentColumn]; + ImGuiWindow* window = table->InnerWindow; + + // Report maximum position so we can infer content size per column. + float* p_max_pos_x; + if (table->RowFlags & ImGuiTableRowFlags_Headers) + p_max_pos_x = &column->ContentMaxXHeadersUsed; // Useful in case user submit contents in header row that is not a TableHeader() call + else + p_max_pos_x = table->IsUnfrozenRows ? &column->ContentMaxXUnfrozen : &column->ContentMaxXFrozen; + *p_max_pos_x = ImMax(*p_max_pos_x, window->DC.CursorMaxPos.x); + table->RowPosY2 = ImMax(table->RowPosY2, window->DC.CursorMaxPos.y + table->CellPaddingY); + column->ItemWidth = window->DC.ItemWidth; + + // Propagate text baseline for the entire row + // FIXME-TABLE: Here we propagate text baseline from the last line of the cell.. instead of the first one. + table->RowTextBaseline = ImMax(table->RowTextBaseline, window->DC.PrevLineTextBaseOffset); +} + +//------------------------------------------------------------------------- +// [SECTION] Tables: Columns width management +//------------------------------------------------------------------------- +// - TableGetMaxColumnWidth() [Internal] +// - TableGetColumnWidthAuto() [Internal] +// - TableSetColumnWidth() +// - TableSetColumnWidthAutoSingle() [Internal] +// - TableSetColumnWidthAutoAll() [Internal] +// - TableUpdateColumnsWeightFromWidth() [Internal] +//------------------------------------------------------------------------- + +// Maximum column content width given current layout. Use column->MinX so this value on a per-column basis. +float ImGui::TableGetMaxColumnWidth(const ImGuiTable* table, int column_n) +{ + const ImGuiTableColumn* column = &table->Columns[column_n]; + float max_width = FLT_MAX; + const float min_column_distance = table->MinColumnWidth + table->CellPaddingX * 2.0f + table->CellSpacingX1 + table->CellSpacingX2; + if (table->Flags & ImGuiTableFlags_ScrollX) + { + // Frozen columns can't reach beyond visible width else scrolling will naturally break. + // (we use DisplayOrder as within a set of multiple frozen column reordering is possible) + if (column->DisplayOrder < table->FreezeColumnsRequest) + { + max_width = (table->InnerClipRect.Max.x - (table->FreezeColumnsRequest - column->DisplayOrder) * min_column_distance) - column->MinX; + max_width = max_width - table->OuterPaddingX - table->CellPaddingX - table->CellSpacingX2; + } + } + else if ((table->Flags & ImGuiTableFlags_NoKeepColumnsVisible) == 0) + { + // If horizontal scrolling if disabled, we apply a final lossless shrinking of columns in order to make + // sure they are all visible. Because of this we also know that all of the columns will always fit in + // table->WorkRect and therefore in table->InnerRect (because ScrollX is off) + // FIXME-TABLE: This is solved incorrectly but also quite a difficult problem to fix as we also want ClipRect width to match. + // See "table_width_distrib" and "table_width_keep_visible" tests + max_width = table->WorkRect.Max.x - (table->ColumnsEnabledCount - column->IndexWithinEnabledSet - 1) * min_column_distance - column->MinX; + //max_width -= table->CellSpacingX1; + max_width -= table->CellSpacingX2; + max_width -= table->CellPaddingX * 2.0f; + max_width -= table->OuterPaddingX; + } + return max_width; +} + +// Note this is meant to be stored in column->WidthAuto, please generally use the WidthAuto field +float ImGui::TableGetColumnWidthAuto(ImGuiTable* table, ImGuiTableColumn* column) +{ + const float content_width_body = ImMax(column->ContentMaxXFrozen, column->ContentMaxXUnfrozen) - column->WorkMinX; + const float content_width_headers = column->ContentMaxXHeadersIdeal - column->WorkMinX; + float width_auto = content_width_body; + if (!(column->Flags & ImGuiTableColumnFlags_NoHeaderWidth)) + width_auto = ImMax(width_auto, content_width_headers); + + // Non-resizable fixed columns preserve their requested width + if ((column->Flags & ImGuiTableColumnFlags_WidthFixed) && column->InitStretchWeightOrWidth > 0.0f) + if (!(table->Flags & ImGuiTableFlags_Resizable) || (column->Flags & ImGuiTableColumnFlags_NoResize)) + width_auto = column->InitStretchWeightOrWidth; + + return ImMax(width_auto, table->MinColumnWidth); +} + +// 'width' = inner column width, without padding +void ImGui::TableSetColumnWidth(int column_n, float width) +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + IM_ASSERT(table != NULL && table->IsLayoutLocked == false); + IM_ASSERT(column_n >= 0 && column_n < table->ColumnsCount); + ImGuiTableColumn* column_0 = &table->Columns[column_n]; + float column_0_width = width; + + // Apply constraints early + // Compare both requested and actual given width to avoid overwriting requested width when column is stuck (minimum size, bounded) + IM_ASSERT(table->MinColumnWidth > 0.0f); + const float min_width = table->MinColumnWidth; + const float max_width = ImMax(min_width, TableGetMaxColumnWidth(table, column_n)); + column_0_width = ImClamp(column_0_width, min_width, max_width); + if (column_0->WidthGiven == column_0_width || column_0->WidthRequest == column_0_width) + return; + + //IMGUI_DEBUG_LOG("TableSetColumnWidth(%d, %.1f->%.1f)\n", column_0_idx, column_0->WidthGiven, column_0_width); + ImGuiTableColumn* column_1 = (column_0->NextEnabledColumn != -1) ? &table->Columns[column_0->NextEnabledColumn] : NULL; + + // In this surprisingly not simple because of how we support mixing Fixed and multiple Stretch columns. + // - All fixed: easy. + // - All stretch: easy. + // - One or more fixed + one stretch: easy. + // - One or more fixed + more than one stretch: tricky. + // Qt when manual resize is enabled only support a single _trailing_ stretch column. + + // When forwarding resize from Wn| to Fn+1| we need to be considerate of the _NoResize flag on Fn+1. + // FIXME-TABLE: Find a way to rewrite all of this so interactions feel more consistent for the user. + // Scenarios: + // - F1 F2 F3 resize from F1| or F2| --> ok: alter ->WidthRequested of Fixed column. Subsequent columns will be offset. + // - F1 F2 F3 resize from F3| --> ok: alter ->WidthRequested of Fixed column. If active, ScrollX extent can be altered. + // - F1 F2 W3 resize from F1| or F2| --> ok: alter ->WidthRequested of Fixed column. If active, ScrollX extent can be altered, but it doesn't make much sense as the Stretch column will always be minimal size. + // - F1 F2 W3 resize from W3| --> ok: no-op (disabled by Resize Rule 1) + // - W1 W2 W3 resize from W1| or W2| --> ok + // - W1 W2 W3 resize from W3| --> ok: no-op (disabled by Resize Rule 1) + // - W1 F2 F3 resize from F3| --> ok: no-op (disabled by Resize Rule 1) + // - W1 F2 resize from F2| --> ok: no-op (disabled by Resize Rule 1) + // - W1 W2 F3 resize from W1| or W2| --> ok + // - W1 F2 W3 resize from W1| or F2| --> ok + // - F1 W2 F3 resize from W2| --> ok + // - F1 W3 F2 resize from W3| --> ok + // - W1 F2 F3 resize from W1| --> ok: equivalent to resizing |F2. F3 will not move. + // - W1 F2 F3 resize from F2| --> ok + // All resizes from a Wx columns are locking other columns. + + // Possible improvements: + // - W1 W2 W3 resize W1| --> to not be stuck, both W2 and W3 would stretch down. Seems possible to fix. Would be most beneficial to simplify resize of all-weighted columns. + // - W3 F1 F2 resize W3| --> to not be stuck past F1|, both F1 and F2 would need to stretch down, which would be lossy or ambiguous. Seems hard to fix. + + // [Resize Rule 1] Can't resize from right of right-most visible column if there is any Stretch column. Implemented in TableUpdateLayout(). + + // If we have all Fixed columns OR resizing a Fixed column that doesn't come after a Stretch one, we can do an offsetting resize. + // This is the preferred resize path + if (column_0->Flags & ImGuiTableColumnFlags_WidthFixed) + if (!column_1 || table->LeftMostStretchedColumn == -1 || table->Columns[table->LeftMostStretchedColumn].DisplayOrder >= column_0->DisplayOrder) + { + column_0->WidthRequest = column_0_width; + table->IsSettingsDirty = true; + return; + } + + // We can also use previous column if there's no next one (this is used when doing an auto-fit on the right-most stretch column) + if (column_1 == NULL) + column_1 = (column_0->PrevEnabledColumn != -1) ? &table->Columns[column_0->PrevEnabledColumn] : NULL; + if (column_1 == NULL) + return; + + // Resizing from right-side of a Stretch column before a Fixed column forward sizing to left-side of fixed column. + // (old_a + old_b == new_a + new_b) --> (new_a == old_a + old_b - new_b) + float column_1_width = ImMax(column_1->WidthRequest - (column_0_width - column_0->WidthRequest), min_width); + column_0_width = column_0->WidthRequest + column_1->WidthRequest - column_1_width; + IM_ASSERT(column_0_width > 0.0f && column_1_width > 0.0f); + column_0->WidthRequest = column_0_width; + column_1->WidthRequest = column_1_width; + if ((column_0->Flags | column_1->Flags) & ImGuiTableColumnFlags_WidthStretch) + TableUpdateColumnsWeightFromWidth(table); + table->IsSettingsDirty = true; +} + +// Disable clipping then auto-fit, will take 2 frames +// (we don't take a shortcut for unclipped columns to reduce inconsistencies when e.g. resizing multiple columns) +void ImGui::TableSetColumnWidthAutoSingle(ImGuiTable* table, int column_n) +{ + // Single auto width uses auto-fit + ImGuiTableColumn* column = &table->Columns[column_n]; + if (!column->IsEnabled) + return; + column->CannotSkipItemsQueue = (1 << 0); + table->AutoFitSingleColumn = (ImGuiTableColumnIdx)column_n; +} + +void ImGui::TableSetColumnWidthAutoAll(ImGuiTable* table) +{ + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + ImGuiTableColumn* column = &table->Columns[column_n]; + if (!column->IsEnabled && !(column->Flags & ImGuiTableColumnFlags_WidthStretch)) // Cannot reset weight of hidden stretch column + continue; + column->CannotSkipItemsQueue = (1 << 0); + column->AutoFitQueue = (1 << 1); + } +} + +void ImGui::TableUpdateColumnsWeightFromWidth(ImGuiTable* table) +{ + IM_ASSERT(table->LeftMostStretchedColumn != -1 && table->RightMostStretchedColumn != -1); + + // Measure existing quantity + float visible_weight = 0.0f; + float visible_width = 0.0f; + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + ImGuiTableColumn* column = &table->Columns[column_n]; + if (!column->IsEnabled || !(column->Flags & ImGuiTableColumnFlags_WidthStretch)) + continue; + IM_ASSERT(column->StretchWeight > 0.0f); + visible_weight += column->StretchWeight; + visible_width += column->WidthRequest; + } + IM_ASSERT(visible_weight > 0.0f && visible_width > 0.0f); + + // Apply new weights + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + ImGuiTableColumn* column = &table->Columns[column_n]; + if (!column->IsEnabled || !(column->Flags & ImGuiTableColumnFlags_WidthStretch)) + continue; + column->StretchWeight = (column->WidthRequest / visible_width) * visible_weight; + IM_ASSERT(column->StretchWeight > 0.0f); + } +} + +//------------------------------------------------------------------------- +// [SECTION] Tables: Drawing +//------------------------------------------------------------------------- +// - TablePushBackgroundChannel() [Internal] +// - TablePopBackgroundChannel() [Internal] +// - TableSetupDrawChannels() [Internal] +// - TableMergeDrawChannels() [Internal] +// - TableDrawBorders() [Internal] +//------------------------------------------------------------------------- + +// Bg2 is used by Selectable (and possibly other widgets) to render to the background. +// Unlike our Bg0/1 channel which we uses for RowBg/CellBg/Borders and where we guarantee all shapes to be CPU-clipped, the Bg2 channel being widgets-facing will rely on regular ClipRect. +void ImGui::TablePushBackgroundChannel() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImGuiTable* table = g.CurrentTable; + + // Optimization: avoid SetCurrentChannel() + PushClipRect() + table->HostBackupInnerClipRect = window->ClipRect; + SetWindowClipRectBeforeSetChannel(window, table->Bg2ClipRectForDrawCmd); + table->DrawSplitter->SetCurrentChannel(window->DrawList, table->Bg2DrawChannelCurrent); +} + +void ImGui::TablePopBackgroundChannel() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImGuiTable* table = g.CurrentTable; + ImGuiTableColumn* column = &table->Columns[table->CurrentColumn]; + + // Optimization: avoid PopClipRect() + SetCurrentChannel() + SetWindowClipRectBeforeSetChannel(window, table->HostBackupInnerClipRect); + table->DrawSplitter->SetCurrentChannel(window->DrawList, column->DrawChannelCurrent); +} + +// Allocate draw channels. Called by TableUpdateLayout() +// - We allocate them following storage order instead of display order so reordering columns won't needlessly +// increase overall dormant memory cost. +// - We isolate headers draw commands in their own channels instead of just altering clip rects. +// This is in order to facilitate merging of draw commands. +// - After crossing FreezeRowsCount, all columns see their current draw channel changed to a second set of channels. +// - We only use the dummy draw channel so we can push a null clipping rectangle into it without affecting other +// channels, while simplifying per-row/per-cell overhead. It will be empty and discarded when merged. +// - We allocate 1 or 2 background draw channels. This is because we know TablePushBackgroundChannel() is only used for +// horizontal spanning. If we allowed vertical spanning we'd need one background draw channel per merge group (1-4). +// Draw channel allocation (before merging): +// - NoClip --> 2+D+1 channels: bg0/1 + bg2 + foreground (same clip rect == always 1 draw call) +// - Clip --> 2+D+N channels +// - FreezeRows --> 2+D+N*2 (unless scrolling value is zero) +// - FreezeRows || FreezeColunns --> 3+D+N*2 (unless scrolling value is zero) +// Where D is 1 if any column is clipped or hidden (dummy channel) otherwise 0. +void ImGui::TableSetupDrawChannels(ImGuiTable* table) +{ + const int freeze_row_multiplier = (table->FreezeRowsCount > 0) ? 2 : 1; + const int channels_for_row = (table->Flags & ImGuiTableFlags_NoClip) ? 1 : table->ColumnsEnabledCount; + const int channels_for_bg = 1 + 1 * freeze_row_multiplier; + const int channels_for_dummy = (table->ColumnsEnabledCount < table->ColumnsCount || table->VisibleMaskByIndex != table->EnabledMaskByIndex) ? +1 : 0; + const int channels_total = channels_for_bg + (channels_for_row * freeze_row_multiplier) + channels_for_dummy; + table->DrawSplitter->Split(table->InnerWindow->DrawList, channels_total); + table->DummyDrawChannel = (ImGuiTableDrawChannelIdx)((channels_for_dummy > 0) ? channels_total - 1 : -1); + table->Bg2DrawChannelCurrent = TABLE_DRAW_CHANNEL_BG2_FROZEN; + table->Bg2DrawChannelUnfrozen = (ImGuiTableDrawChannelIdx)((table->FreezeRowsCount > 0) ? 2 + channels_for_row : TABLE_DRAW_CHANNEL_BG2_FROZEN); + + int draw_channel_current = 2; + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + ImGuiTableColumn* column = &table->Columns[column_n]; + if (column->IsVisibleX && column->IsVisibleY) + { + column->DrawChannelFrozen = (ImGuiTableDrawChannelIdx)(draw_channel_current); + column->DrawChannelUnfrozen = (ImGuiTableDrawChannelIdx)(draw_channel_current + (table->FreezeRowsCount > 0 ? channels_for_row + 1 : 0)); + if (!(table->Flags & ImGuiTableFlags_NoClip)) + draw_channel_current++; + } + else + { + column->DrawChannelFrozen = column->DrawChannelUnfrozen = table->DummyDrawChannel; + } + column->DrawChannelCurrent = column->DrawChannelFrozen; + } + + // Initial draw cmd starts with a BgClipRect that matches the one of its host, to facilitate merge draw commands by default. + // All our cell highlight are manually clipped with BgClipRect. When unfreezing it will be made smaller to fit scrolling rect. + // (This technically isn't part of setting up draw channels, but is reasonably related to be done here) + table->BgClipRect = table->InnerClipRect; + table->Bg0ClipRectForDrawCmd = table->OuterWindow->ClipRect; + table->Bg2ClipRectForDrawCmd = table->HostClipRect; + IM_ASSERT(table->BgClipRect.Min.y <= table->BgClipRect.Max.y); +} + +// This function reorder draw channels based on matching clip rectangle, to facilitate merging them. Called by EndTable(). +// For simplicity we call it TableMergeDrawChannels() but in fact it only reorder channels + overwrite ClipRect, +// actual merging is done by table->DrawSplitter.Merge() which is called right after TableMergeDrawChannels(). +// +// Columns where the contents didn't stray off their local clip rectangle can be merged. To achieve +// this we merge their clip rect and make them contiguous in the channel list, so they can be merged +// by the call to DrawSplitter.Merge() following to the call to this function. +// We reorder draw commands by arranging them into a maximum of 4 distinct groups: +// +// 1 group: 2 groups: 2 groups: 4 groups: +// [ 0. ] no freeze [ 0. ] row freeze [ 01 ] col freeze [ 01 ] row+col freeze +// [ .. ] or no scroll [ 2. ] and v-scroll [ .. ] and h-scroll [ 23 ] and v+h-scroll +// +// Each column itself can use 1 channel (row freeze disabled) or 2 channels (row freeze enabled). +// When the contents of a column didn't stray off its limit, we move its channels into the corresponding group +// based on its position (within frozen rows/columns groups or not). +// At the end of the operation our 1-4 groups will each have a ImDrawCmd using the same ClipRect. +// This function assume that each column are pointing to a distinct draw channel, +// otherwise merge_group->ChannelsCount will not match set bit count of merge_group->ChannelsMask. +// +// Column channels will not be merged into one of the 1-4 groups in the following cases: +// - The contents stray off its clipping rectangle (we only compare the MaxX value, not the MinX value). +// Direct ImDrawList calls won't be taken into account by default, if you use them make sure the ImGui:: bounds +// matches, by e.g. calling SetCursorScreenPos(). +// - The channel uses more than one draw command itself. We drop all our attempt at merging stuff here.. +// we could do better but it's going to be rare and probably not worth the hassle. +// Columns for which the draw channel(s) haven't been merged with other will use their own ImDrawCmd. +// +// This function is particularly tricky to understand.. take a breath. +void ImGui::TableMergeDrawChannels(ImGuiTable* table) +{ + ImGuiContext& g = *GImGui; + ImDrawListSplitter* splitter = table->DrawSplitter; + const bool has_freeze_v = (table->FreezeRowsCount > 0); + const bool has_freeze_h = (table->FreezeColumnsCount > 0); + IM_ASSERT(splitter->_Current == 0); + + // Track which groups we are going to attempt to merge, and which channels goes into each group. + struct MergeGroup + { + ImRect ClipRect; + int ChannelsCount; + ImBitArray ChannelsMask; + + MergeGroup() { ChannelsCount = 0; } + }; + int merge_group_mask = 0x00; + MergeGroup merge_groups[4]; + + // 1. Scan channels and take note of those which can be merged + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + if ((table->VisibleMaskByIndex & ((ImU64)1 << column_n)) == 0) + continue; + ImGuiTableColumn* column = &table->Columns[column_n]; + + const int merge_group_sub_count = has_freeze_v ? 2 : 1; + for (int merge_group_sub_n = 0; merge_group_sub_n < merge_group_sub_count; merge_group_sub_n++) + { + const int channel_no = (merge_group_sub_n == 0) ? column->DrawChannelFrozen : column->DrawChannelUnfrozen; + + // Don't attempt to merge if there are multiple draw calls within the column + ImDrawChannel* src_channel = &splitter->_Channels[channel_no]; + if (src_channel->_CmdBuffer.Size > 0 && src_channel->_CmdBuffer.back().ElemCount == 0) + src_channel->_CmdBuffer.pop_back(); + if (src_channel->_CmdBuffer.Size != 1) + continue; + + // Find out the width of this merge group and check if it will fit in our column + // (note that we assume that rendering didn't stray on the left direction. we should need a CursorMinPos to detect it) + if (!(column->Flags & ImGuiTableColumnFlags_NoClip)) + { + float content_max_x; + if (!has_freeze_v) + content_max_x = ImMax(column->ContentMaxXUnfrozen, column->ContentMaxXHeadersUsed); // No row freeze + else if (merge_group_sub_n == 0) + content_max_x = ImMax(column->ContentMaxXFrozen, column->ContentMaxXHeadersUsed); // Row freeze: use width before freeze + else + content_max_x = column->ContentMaxXUnfrozen; // Row freeze: use width after freeze + if (content_max_x > column->ClipRect.Max.x) + continue; + } + + const int merge_group_n = (has_freeze_h && column_n < table->FreezeColumnsCount ? 0 : 1) + (has_freeze_v && merge_group_sub_n == 0 ? 0 : 2); + IM_ASSERT(channel_no < IMGUI_TABLE_MAX_DRAW_CHANNELS); + MergeGroup* merge_group = &merge_groups[merge_group_n]; + if (merge_group->ChannelsCount == 0) + merge_group->ClipRect = ImRect(+FLT_MAX, +FLT_MAX, -FLT_MAX, -FLT_MAX); + merge_group->ChannelsMask.SetBit(channel_no); + merge_group->ChannelsCount++; + merge_group->ClipRect.Add(src_channel->_CmdBuffer[0].ClipRect); + merge_group_mask |= (1 << merge_group_n); + } + + // Invalidate current draw channel + // (we don't clear DrawChannelFrozen/DrawChannelUnfrozen solely to facilitate debugging/later inspection of data) + column->DrawChannelCurrent = (ImGuiTableDrawChannelIdx)-1; + } + + // [DEBUG] Display merge groups +#if 0 + if (g.IO.KeyShift) + for (int merge_group_n = 0; merge_group_n < IM_ARRAYSIZE(merge_groups); merge_group_n++) + { + MergeGroup* merge_group = &merge_groups[merge_group_n]; + if (merge_group->ChannelsCount == 0) + continue; + char buf[32]; + ImFormatString(buf, 32, "MG%d:%d", merge_group_n, merge_group->ChannelsCount); + ImVec2 text_pos = merge_group->ClipRect.Min + ImVec2(4, 4); + ImVec2 text_size = CalcTextSize(buf, NULL); + GetForegroundDrawList()->AddRectFilled(text_pos, text_pos + text_size, IM_COL32(0, 0, 0, 255)); + GetForegroundDrawList()->AddText(text_pos, IM_COL32(255, 255, 0, 255), buf, NULL); + GetForegroundDrawList()->AddRect(merge_group->ClipRect.Min, merge_group->ClipRect.Max, IM_COL32(255, 255, 0, 255)); + } +#endif + + // 2. Rewrite channel list in our preferred order + if (merge_group_mask != 0) + { + // We skip channel 0 (Bg0/Bg1) and 1 (Bg2 frozen) from the shuffling since they won't move - see channels allocation in TableSetupDrawChannels(). + const int LEADING_DRAW_CHANNELS = 2; + g.DrawChannelsTempMergeBuffer.resize(splitter->_Count - LEADING_DRAW_CHANNELS); // Use shared temporary storage so the allocation gets amortized + ImDrawChannel* dst_tmp = g.DrawChannelsTempMergeBuffer.Data; + ImBitArray remaining_mask; // We need 132-bit of storage + remaining_mask.SetBitRange(LEADING_DRAW_CHANNELS, splitter->_Count); + remaining_mask.ClearBit(table->Bg2DrawChannelUnfrozen); + IM_ASSERT(has_freeze_v == false || table->Bg2DrawChannelUnfrozen != TABLE_DRAW_CHANNEL_BG2_FROZEN); + int remaining_count = splitter->_Count - (has_freeze_v ? LEADING_DRAW_CHANNELS + 1 : LEADING_DRAW_CHANNELS); + //ImRect host_rect = (table->InnerWindow == table->OuterWindow) ? table->InnerClipRect : table->HostClipRect; + ImRect host_rect = table->HostClipRect; + for (int merge_group_n = 0; merge_group_n < IM_ARRAYSIZE(merge_groups); merge_group_n++) + { + if (int merge_channels_count = merge_groups[merge_group_n].ChannelsCount) + { + MergeGroup* merge_group = &merge_groups[merge_group_n]; + ImRect merge_clip_rect = merge_group->ClipRect; + + // Extend outer-most clip limits to match those of host, so draw calls can be merged even if + // outer-most columns have some outer padding offsetting them from their parent ClipRect. + // The principal cases this is dealing with are: + // - On a same-window table (not scrolling = single group), all fitting columns ClipRect -> will extend and match host ClipRect -> will merge + // - Columns can use padding and have left-most ClipRect.Min.x and right-most ClipRect.Max.x != from host ClipRect -> will extend and match host ClipRect -> will merge + // FIXME-TABLE FIXME-WORKRECT: We are wasting a merge opportunity on tables without scrolling if column doesn't fit + // within host clip rect, solely because of the half-padding difference between window->WorkRect and window->InnerClipRect. + if ((merge_group_n & 1) == 0 || !has_freeze_h) + merge_clip_rect.Min.x = ImMin(merge_clip_rect.Min.x, host_rect.Min.x); + if ((merge_group_n & 2) == 0 || !has_freeze_v) + merge_clip_rect.Min.y = ImMin(merge_clip_rect.Min.y, host_rect.Min.y); + if ((merge_group_n & 1) != 0) + merge_clip_rect.Max.x = ImMax(merge_clip_rect.Max.x, host_rect.Max.x); + if ((merge_group_n & 2) != 0 && (table->Flags & ImGuiTableFlags_NoHostExtendY) == 0) + merge_clip_rect.Max.y = ImMax(merge_clip_rect.Max.y, host_rect.Max.y); +#if 0 + GetOverlayDrawList()->AddRect(merge_group->ClipRect.Min, merge_group->ClipRect.Max, IM_COL32(255, 0, 0, 200), 0.0f, 0, 1.0f); + GetOverlayDrawList()->AddLine(merge_group->ClipRect.Min, merge_clip_rect.Min, IM_COL32(255, 100, 0, 200)); + GetOverlayDrawList()->AddLine(merge_group->ClipRect.Max, merge_clip_rect.Max, IM_COL32(255, 100, 0, 200)); +#endif + remaining_count -= merge_group->ChannelsCount; + for (int n = 0; n < IM_ARRAYSIZE(remaining_mask.Storage); n++) + remaining_mask.Storage[n] &= ~merge_group->ChannelsMask.Storage[n]; + for (int n = 0; n < splitter->_Count && merge_channels_count != 0; n++) + { + // Copy + overwrite new clip rect + if (!merge_group->ChannelsMask.TestBit(n)) + continue; + merge_group->ChannelsMask.ClearBit(n); + merge_channels_count--; + + ImDrawChannel* channel = &splitter->_Channels[n]; + IM_ASSERT(channel->_CmdBuffer.Size == 1 && merge_clip_rect.Contains(ImRect(channel->_CmdBuffer[0].ClipRect))); + channel->_CmdBuffer[0].ClipRect = merge_clip_rect.ToVec4(); + memcpy(dst_tmp++, channel, sizeof(ImDrawChannel)); + } + } + + // Make sure Bg2DrawChannelUnfrozen appears in the middle of our groups (whereas Bg0/Bg1 and Bg2 frozen are fixed to 0 and 1) + if (merge_group_n == 1 && has_freeze_v) + memcpy(dst_tmp++, &splitter->_Channels[table->Bg2DrawChannelUnfrozen], sizeof(ImDrawChannel)); + } + + // Append unmergeable channels that we didn't reorder at the end of the list + for (int n = 0; n < splitter->_Count && remaining_count != 0; n++) + { + if (!remaining_mask.TestBit(n)) + continue; + ImDrawChannel* channel = &splitter->_Channels[n]; + memcpy(dst_tmp++, channel, sizeof(ImDrawChannel)); + remaining_count--; + } + IM_ASSERT(dst_tmp == g.DrawChannelsTempMergeBuffer.Data + g.DrawChannelsTempMergeBuffer.Size); + memcpy(splitter->_Channels.Data + LEADING_DRAW_CHANNELS, g.DrawChannelsTempMergeBuffer.Data, (splitter->_Count - LEADING_DRAW_CHANNELS) * sizeof(ImDrawChannel)); + } +} + +// FIXME-TABLE: This is a mess, need to redesign how we render borders (as some are also done in TableEndRow) +void ImGui::TableDrawBorders(ImGuiTable* table) +{ + ImGuiWindow* inner_window = table->InnerWindow; + if (!table->OuterWindow->ClipRect.Overlaps(table->OuterRect)) + return; + + ImDrawList* inner_drawlist = inner_window->DrawList; + table->DrawSplitter->SetCurrentChannel(inner_drawlist, TABLE_DRAW_CHANNEL_BG0); + inner_drawlist->PushClipRect(table->Bg0ClipRectForDrawCmd.Min, table->Bg0ClipRectForDrawCmd.Max, false); + + // Draw inner border and resizing feedback + const float border_size = TABLE_BORDER_SIZE; + const float draw_y1 = table->InnerRect.Min.y; + const float draw_y2_body = table->InnerRect.Max.y; + const float draw_y2_head = table->IsUsingHeaders ? ImMin(table->InnerRect.Max.y, (table->FreezeRowsCount >= 1 ? table->InnerRect.Min.y : table->WorkRect.Min.y) + table->LastFirstRowHeight) : draw_y1; + if (table->Flags & ImGuiTableFlags_BordersInnerV) + { + for (int order_n = 0; order_n < table->ColumnsCount; order_n++) + { + if (!(table->EnabledMaskByDisplayOrder & ((ImU64)1 << order_n))) + continue; + + const int column_n = table->DisplayOrderToIndex[order_n]; + ImGuiTableColumn* column = &table->Columns[column_n]; + const bool is_hovered = (table->HoveredColumnBorder == column_n); + const bool is_resized = (table->ResizedColumn == column_n) && (table->InstanceInteracted == table->InstanceCurrent); + const bool is_resizable = (column->Flags & (ImGuiTableColumnFlags_NoResize | ImGuiTableColumnFlags_NoDirectResize_)) == 0; + const bool is_frozen_separator = (table->FreezeColumnsCount == order_n + 1); + if (column->MaxX > table->InnerClipRect.Max.x && !is_resized) + continue; + + // Decide whether right-most column is visible + if (column->NextEnabledColumn == -1 && !is_resizable) + if ((table->Flags & ImGuiTableFlags_SizingMask_) != ImGuiTableFlags_SizingFixedSame || (table->Flags & ImGuiTableFlags_NoHostExtendX)) + continue; + if (column->MaxX <= column->ClipRect.Min.x) // FIXME-TABLE FIXME-STYLE: Assume BorderSize==1, this is problematic if we want to increase the border size.. + continue; + + // Draw in outer window so right-most column won't be clipped + // Always draw full height border when being resized/hovered, or on the delimitation of frozen column scrolling. + ImU32 col; + float draw_y2; + if (is_hovered || is_resized || is_frozen_separator) + { + draw_y2 = draw_y2_body; + col = is_resized ? GetColorU32(ImGuiCol_SeparatorActive) : is_hovered ? GetColorU32(ImGuiCol_SeparatorHovered) : table->BorderColorStrong; + } + else + { + draw_y2 = (table->Flags & (ImGuiTableFlags_NoBordersInBody | ImGuiTableFlags_NoBordersInBodyUntilResize)) ? draw_y2_head : draw_y2_body; + col = (table->Flags & (ImGuiTableFlags_NoBordersInBody | ImGuiTableFlags_NoBordersInBodyUntilResize)) ? table->BorderColorStrong : table->BorderColorLight; + } + + if (draw_y2 > draw_y1) + inner_drawlist->AddLine(ImVec2(column->MaxX, draw_y1), ImVec2(column->MaxX, draw_y2), col, border_size); + } + } + + // Draw outer border + // FIXME: could use AddRect or explicit VLine/HLine helper? + if (table->Flags & ImGuiTableFlags_BordersOuter) + { + // Display outer border offset by 1 which is a simple way to display it without adding an extra draw call + // (Without the offset, in outer_window it would be rendered behind cells, because child windows are above their + // parent. In inner_window, it won't reach out over scrollbars. Another weird solution would be to display part + // of it in inner window, and the part that's over scrollbars in the outer window..) + // Either solution currently won't allow us to use a larger border size: the border would clipped. + const ImRect outer_border = table->OuterRect; + const ImU32 outer_col = table->BorderColorStrong; + if ((table->Flags & ImGuiTableFlags_BordersOuter) == ImGuiTableFlags_BordersOuter) + { + inner_drawlist->AddRect(outer_border.Min, outer_border.Max, outer_col, 0.0f, 0, border_size); + } + else if (table->Flags & ImGuiTableFlags_BordersOuterV) + { + inner_drawlist->AddLine(outer_border.Min, ImVec2(outer_border.Min.x, outer_border.Max.y), outer_col, border_size); + inner_drawlist->AddLine(ImVec2(outer_border.Max.x, outer_border.Min.y), outer_border.Max, outer_col, border_size); + } + else if (table->Flags & ImGuiTableFlags_BordersOuterH) + { + inner_drawlist->AddLine(outer_border.Min, ImVec2(outer_border.Max.x, outer_border.Min.y), outer_col, border_size); + inner_drawlist->AddLine(ImVec2(outer_border.Min.x, outer_border.Max.y), outer_border.Max, outer_col, border_size); + } + } + if ((table->Flags & ImGuiTableFlags_BordersInnerH) && table->RowPosY2 < table->OuterRect.Max.y) + { + // Draw bottom-most row border + const float border_y = table->RowPosY2; + if (border_y >= table->BgClipRect.Min.y && border_y < table->BgClipRect.Max.y) + inner_drawlist->AddLine(ImVec2(table->BorderX1, border_y), ImVec2(table->BorderX2, border_y), table->BorderColorLight, border_size); + } + + inner_drawlist->PopClipRect(); +} + +//------------------------------------------------------------------------- +// [SECTION] Tables: Sorting +//------------------------------------------------------------------------- +// - TableGetSortSpecs() +// - TableFixColumnSortDirection() [Internal] +// - TableGetColumnNextSortDirection() [Internal] +// - TableSetColumnSortDirection() [Internal] +// - TableSortSpecsSanitize() [Internal] +// - TableSortSpecsBuild() [Internal] +//------------------------------------------------------------------------- + +// Return NULL if no sort specs (most often when ImGuiTableFlags_Sortable is not set) +// You can sort your data again when 'SpecsChanged == true'. It will be true with sorting specs have changed since +// last call, or the first time. +// Lifetime: don't hold on this pointer over multiple frames or past any subsequent call to BeginTable()! +ImGuiTableSortSpecs* ImGui::TableGetSortSpecs() +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + IM_ASSERT(table != NULL); + + if (!(table->Flags & ImGuiTableFlags_Sortable)) + return NULL; + + // Require layout (in case TableHeadersRow() hasn't been called) as it may alter IsSortSpecsDirty in some paths. + if (!table->IsLayoutLocked) + TableUpdateLayout(table); + + TableSortSpecsBuild(table); + + return &table->SortSpecs; +} + +static inline ImGuiSortDirection TableGetColumnAvailSortDirection(ImGuiTableColumn* column, int n) +{ + IM_ASSERT(n < column->SortDirectionsAvailCount); + return (column->SortDirectionsAvailList >> (n << 1)) & 0x03; +} + +// Fix sort direction if currently set on a value which is unavailable (e.g. activating NoSortAscending/NoSortDescending) +void ImGui::TableFixColumnSortDirection(ImGuiTable* table, ImGuiTableColumn* column) +{ + if (column->SortOrder == -1 || (column->SortDirectionsAvailMask & (1 << column->SortDirection)) != 0) + return; + column->SortDirection = (ImU8)TableGetColumnAvailSortDirection(column, 0); + table->IsSortSpecsDirty = true; +} + +// Calculate next sort direction that would be set after clicking the column +// - If the PreferSortDescending flag is set, we will default to a Descending direction on the first click. +// - Note that the PreferSortAscending flag is never checked, it is essentially the default and therefore a no-op. +IM_STATIC_ASSERT(ImGuiSortDirection_None == 0 && ImGuiSortDirection_Ascending == 1 && ImGuiSortDirection_Descending == 2); +ImGuiSortDirection ImGui::TableGetColumnNextSortDirection(ImGuiTableColumn* column) +{ + IM_ASSERT(column->SortDirectionsAvailCount > 0); + if (column->SortOrder == -1) + return TableGetColumnAvailSortDirection(column, 0); + for (int n = 0; n < 3; n++) + if (column->SortDirection == TableGetColumnAvailSortDirection(column, n)) + return TableGetColumnAvailSortDirection(column, (n + 1) % column->SortDirectionsAvailCount); + IM_ASSERT(0); + return ImGuiSortDirection_None; +} + +// Note that the NoSortAscending/NoSortDescending flags are processed in TableSortSpecsSanitize(), and they may change/revert +// the value of SortDirection. We could technically also do it here but it would be unnecessary and duplicate code. +void ImGui::TableSetColumnSortDirection(int column_n, ImGuiSortDirection sort_direction, bool append_to_sort_specs) +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + + if (!(table->Flags & ImGuiTableFlags_SortMulti)) + append_to_sort_specs = false; + if (!(table->Flags & ImGuiTableFlags_SortTristate)) + IM_ASSERT(sort_direction != ImGuiSortDirection_None); + + ImGuiTableColumnIdx sort_order_max = 0; + if (append_to_sort_specs) + for (int other_column_n = 0; other_column_n < table->ColumnsCount; other_column_n++) + sort_order_max = ImMax(sort_order_max, table->Columns[other_column_n].SortOrder); + + ImGuiTableColumn* column = &table->Columns[column_n]; + column->SortDirection = (ImU8)sort_direction; + if (column->SortDirection == ImGuiSortDirection_None) + column->SortOrder = -1; + else if (column->SortOrder == -1 || !append_to_sort_specs) + column->SortOrder = append_to_sort_specs ? sort_order_max + 1 : 0; + + for (int other_column_n = 0; other_column_n < table->ColumnsCount; other_column_n++) + { + ImGuiTableColumn* other_column = &table->Columns[other_column_n]; + if (other_column != column && !append_to_sort_specs) + other_column->SortOrder = -1; + TableFixColumnSortDirection(table, other_column); + } + table->IsSettingsDirty = true; + table->IsSortSpecsDirty = true; +} + +void ImGui::TableSortSpecsSanitize(ImGuiTable* table) +{ + IM_ASSERT(table->Flags & ImGuiTableFlags_Sortable); + + // Clear SortOrder from hidden column and verify that there's no gap or duplicate. + int sort_order_count = 0; + ImU64 sort_order_mask = 0x00; + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + ImGuiTableColumn* column = &table->Columns[column_n]; + if (column->SortOrder != -1 && !column->IsEnabled) + column->SortOrder = -1; + if (column->SortOrder == -1) + continue; + sort_order_count++; + sort_order_mask |= ((ImU64)1 << column->SortOrder); + IM_ASSERT(sort_order_count < (int)sizeof(sort_order_mask) * 8); + } + + const bool need_fix_linearize = ((ImU64)1 << sort_order_count) != (sort_order_mask + 1); + const bool need_fix_single_sort_order = (sort_order_count > 1) && !(table->Flags & ImGuiTableFlags_SortMulti); + if (need_fix_linearize || need_fix_single_sort_order) + { + ImU64 fixed_mask = 0x00; + for (int sort_n = 0; sort_n < sort_order_count; sort_n++) + { + // Fix: Rewrite sort order fields if needed so they have no gap or duplicate. + // (e.g. SortOrder 0 disappeared, SortOrder 1..2 exists --> rewrite then as SortOrder 0..1) + int column_with_smallest_sort_order = -1; + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + if ((fixed_mask & ((ImU64)1 << (ImU64)column_n)) == 0 && table->Columns[column_n].SortOrder != -1) + if (column_with_smallest_sort_order == -1 || table->Columns[column_n].SortOrder < table->Columns[column_with_smallest_sort_order].SortOrder) + column_with_smallest_sort_order = column_n; + IM_ASSERT(column_with_smallest_sort_order != -1); + fixed_mask |= ((ImU64)1 << column_with_smallest_sort_order); + table->Columns[column_with_smallest_sort_order].SortOrder = (ImGuiTableColumnIdx)sort_n; + + // Fix: Make sure only one column has a SortOrder if ImGuiTableFlags_MultiSortable is not set. + if (need_fix_single_sort_order) + { + sort_order_count = 1; + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + if (column_n != column_with_smallest_sort_order) + table->Columns[column_n].SortOrder = -1; + break; + } + } + } + + // Fallback default sort order (if no column had the ImGuiTableColumnFlags_DefaultSort flag) + if (sort_order_count == 0 && !(table->Flags & ImGuiTableFlags_SortTristate)) + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + ImGuiTableColumn* column = &table->Columns[column_n]; + if (column->IsEnabled && !(column->Flags & ImGuiTableColumnFlags_NoSort)) + { + sort_order_count = 1; + column->SortOrder = 0; + column->SortDirection = (ImU8)TableGetColumnAvailSortDirection(column, 0); + break; + } + } + + table->SortSpecsCount = (ImGuiTableColumnIdx)sort_order_count; +} + +void ImGui::TableSortSpecsBuild(ImGuiTable* table) +{ + bool dirty = table->IsSortSpecsDirty; + if (dirty) + { + TableSortSpecsSanitize(table); + table->SortSpecsMulti.resize(table->SortSpecsCount <= 1 ? 0 : table->SortSpecsCount); + table->SortSpecs.SpecsDirty = true; // Mark as dirty for user + table->IsSortSpecsDirty = false; // Mark as not dirty for us + } + + // Write output + ImGuiTableColumnSortSpecs* sort_specs = (table->SortSpecsCount == 0) ? NULL : (table->SortSpecsCount == 1) ? &table->SortSpecsSingle : table->SortSpecsMulti.Data; + if (dirty && sort_specs != NULL) + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + { + ImGuiTableColumn* column = &table->Columns[column_n]; + if (column->SortOrder == -1) + continue; + IM_ASSERT(column->SortOrder < table->SortSpecsCount); + ImGuiTableColumnSortSpecs* sort_spec = &sort_specs[column->SortOrder]; + sort_spec->ColumnUserID = column->UserID; + sort_spec->ColumnIndex = (ImGuiTableColumnIdx)column_n; + sort_spec->SortOrder = (ImGuiTableColumnIdx)column->SortOrder; + sort_spec->SortDirection = column->SortDirection; + } + + table->SortSpecs.Specs = sort_specs; + table->SortSpecs.SpecsCount = table->SortSpecsCount; +} + +//------------------------------------------------------------------------- +// [SECTION] Tables: Headers +//------------------------------------------------------------------------- +// - TableGetHeaderRowHeight() [Internal] +// - TableHeadersRow() +// - TableHeader() +//------------------------------------------------------------------------- + +float ImGui::TableGetHeaderRowHeight() +{ + // Caring for a minor edge case: + // Calculate row height, for the unlikely case that some labels may be taller than others. + // If we didn't do that, uneven header height would highlight but smaller one before the tallest wouldn't catch input for all height. + // In your custom header row you may omit this all together and just call TableNextRow() without a height... + float row_height = GetTextLineHeight(); + int columns_count = TableGetColumnCount(); + for (int column_n = 0; column_n < columns_count; column_n++) + { + ImGuiTableColumnFlags flags = TableGetColumnFlags(column_n); + if ((flags & ImGuiTableColumnFlags_IsEnabled) && !(flags & ImGuiTableColumnFlags_NoHeaderLabel)) + row_height = ImMax(row_height, CalcTextSize(TableGetColumnName(column_n)).y); + } + row_height += GetStyle().CellPadding.y * 2.0f; + return row_height; +} + +// [Public] This is a helper to output TableHeader() calls based on the column names declared in TableSetupColumn(). +// The intent is that advanced users willing to create customized headers would not need to use this helper +// and can create their own! For example: TableHeader() may be preceeded by Checkbox() or other custom widgets. +// See 'Demo->Tables->Custom headers' for a demonstration of implementing a custom version of this. +// This code is constructed to not make much use of internal functions, as it is intended to be a template to copy. +// FIXME-TABLE: TableOpenContextMenu() and TableGetHeaderRowHeight() are not public. +void ImGui::TableHeadersRow() +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + IM_ASSERT(table != NULL && "Need to call TableHeadersRow() after BeginTable()!"); + + // Layout if not already done (this is automatically done by TableNextRow, we do it here solely to facilitate stepping in debugger as it is frequent to step in TableUpdateLayout) + if (!table->IsLayoutLocked) + TableUpdateLayout(table); + + // Open row + const float row_y1 = GetCursorScreenPos().y; + const float row_height = TableGetHeaderRowHeight(); + TableNextRow(ImGuiTableRowFlags_Headers, row_height); + if (table->HostSkipItems) // Merely an optimization, you may skip in your own code. + return; + + const int columns_count = TableGetColumnCount(); + for (int column_n = 0; column_n < columns_count; column_n++) + { + if (!TableSetColumnIndex(column_n)) + continue; + + // Push an id to allow unnamed labels (generally accidental, but let's behave nicely with them) + // - in your own code you may omit the PushID/PopID all-together, provided you know they won't collide + // - table->InstanceCurrent is only >0 when we use multiple BeginTable/EndTable calls with same identifier. + const char* name = (TableGetColumnFlags(column_n) & ImGuiTableColumnFlags_NoHeaderLabel) ? "" : TableGetColumnName(column_n); + PushID(table->InstanceCurrent * table->ColumnsCount + column_n); + TableHeader(name); + PopID(); + } + + // Allow opening popup from the right-most section after the last column. + ImVec2 mouse_pos = ImGui::GetMousePos(); + if (IsMouseReleased(1) && TableGetHoveredColumn() == columns_count) + if (mouse_pos.y >= row_y1 && mouse_pos.y < row_y1 + row_height) + TableOpenContextMenu(-1); // Will open a non-column-specific popup. +} + +// Emit a column header (text + optional sort order) +// We cpu-clip text here so that all columns headers can be merged into a same draw call. +// Note that because of how we cpu-clip and display sorting indicators, you _cannot_ use SameLine() after a TableHeader() +void ImGui::TableHeader(const char* label) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return; + + ImGuiTable* table = g.CurrentTable; + IM_ASSERT(table != NULL && "Need to call TableHeader() after BeginTable()!"); + IM_ASSERT(table->CurrentColumn != -1); + const int column_n = table->CurrentColumn; + ImGuiTableColumn* column = &table->Columns[column_n]; + + // Label + if (label == NULL) + label = ""; + const char* label_end = FindRenderedTextEnd(label); + ImVec2 label_size = CalcTextSize(label, label_end, true); + ImVec2 label_pos = window->DC.CursorPos; + + // If we already got a row height, there's use that. + // FIXME-TABLE: Padding problem if the correct outer-padding CellBgRect strays off our ClipRect? + ImRect cell_r = TableGetCellBgRect(table, column_n); + float label_height = ImMax(label_size.y, table->RowMinHeight - table->CellPaddingY * 2.0f); + + // Calculate ideal size for sort order arrow + float w_arrow = 0.0f; + float w_sort_text = 0.0f; + char sort_order_suf[4] = ""; + const float ARROW_SCALE = 0.65f; + if ((table->Flags & ImGuiTableFlags_Sortable) && !(column->Flags & ImGuiTableColumnFlags_NoSort)) + { + w_arrow = ImFloor(g.FontSize * ARROW_SCALE + g.Style.FramePadding.x); + if (column->SortOrder > 0) + { + ImFormatString(sort_order_suf, IM_ARRAYSIZE(sort_order_suf), "%d", column->SortOrder + 1); + w_sort_text = g.Style.ItemInnerSpacing.x + CalcTextSize(sort_order_suf).x; + } + } + + // We feed our unclipped width to the column without writing on CursorMaxPos, so that column is still considering for merging. + float max_pos_x = label_pos.x + label_size.x + w_sort_text + w_arrow; + column->ContentMaxXHeadersUsed = ImMax(column->ContentMaxXHeadersUsed, column->WorkMaxX); + column->ContentMaxXHeadersIdeal = ImMax(column->ContentMaxXHeadersIdeal, max_pos_x); + + // Keep header highlighted when context menu is open. + const bool selected = (table->IsContextPopupOpen && table->ContextPopupColumn == column_n && table->InstanceInteracted == table->InstanceCurrent); + ImGuiID id = window->GetID(label); + ImRect bb(cell_r.Min.x, cell_r.Min.y, cell_r.Max.x, ImMax(cell_r.Max.y, cell_r.Min.y + label_height + g.Style.CellPadding.y * 2.0f)); + ItemSize(ImVec2(0.0f, label_height)); // Don't declare unclipped width, it'll be fed ContentMaxPosHeadersIdeal + if (!ItemAdd(bb, id)) + return; + + //GetForegroundDrawList()->AddRect(cell_r.Min, cell_r.Max, IM_COL32(255, 0, 0, 255)); // [DEBUG] + //GetForegroundDrawList()->AddRect(bb.Min, bb.Max, IM_COL32(255, 0, 0, 255)); // [DEBUG] + + // Using AllowItemOverlap mode because we cover the whole cell, and we want user to be able to submit subsequent items. + bool hovered, held; + bool pressed = ButtonBehavior(bb, id, &hovered, &held, ImGuiButtonFlags_AllowItemOverlap); + if (g.ActiveId != id) + SetItemAllowOverlap(); + if (held || hovered || selected) + { + const ImU32 col = GetColorU32(held ? ImGuiCol_HeaderActive : hovered ? ImGuiCol_HeaderHovered : ImGuiCol_Header); + //RenderFrame(bb.Min, bb.Max, col, false, 0.0f); + TableSetBgColor(ImGuiTableBgTarget_CellBg, col, table->CurrentColumn); + } + else + { + // Submit single cell bg color in the case we didn't submit a full header row + if ((table->RowFlags & ImGuiTableRowFlags_Headers) == 0) + TableSetBgColor(ImGuiTableBgTarget_CellBg, GetColorU32(ImGuiCol_TableHeaderBg), table->CurrentColumn); + } + RenderNavHighlight(bb, id, ImGuiNavHighlightFlags_TypeThin | ImGuiNavHighlightFlags_NoRounding); + if (held) + table->HeldHeaderColumn = (ImGuiTableColumnIdx)column_n; + window->DC.CursorPos.y -= g.Style.ItemSpacing.y * 0.5f; + + // Drag and drop to re-order columns. + // FIXME-TABLE: Scroll request while reordering a column and it lands out of the scrolling zone. + if (held && (table->Flags & ImGuiTableFlags_Reorderable) && IsMouseDragging(0) && !g.DragDropActive) + { + // While moving a column it will jump on the other side of the mouse, so we also test for MouseDelta.x + table->ReorderColumn = (ImGuiTableColumnIdx)column_n; + table->InstanceInteracted = table->InstanceCurrent; + + // We don't reorder: through the frozen<>unfrozen line, or through a column that is marked with ImGuiTableColumnFlags_NoReorder. + if (g.IO.MouseDelta.x < 0.0f && g.IO.MousePos.x < cell_r.Min.x) + if (ImGuiTableColumn* prev_column = (column->PrevEnabledColumn != -1) ? &table->Columns[column->PrevEnabledColumn] : NULL) + if (!((column->Flags | prev_column->Flags) & ImGuiTableColumnFlags_NoReorder)) + if ((column->IndexWithinEnabledSet < table->FreezeColumnsRequest) == (prev_column->IndexWithinEnabledSet < table->FreezeColumnsRequest)) + table->ReorderColumnDir = -1; + if (g.IO.MouseDelta.x > 0.0f && g.IO.MousePos.x > cell_r.Max.x) + if (ImGuiTableColumn* next_column = (column->NextEnabledColumn != -1) ? &table->Columns[column->NextEnabledColumn] : NULL) + if (!((column->Flags | next_column->Flags) & ImGuiTableColumnFlags_NoReorder)) + if ((column->IndexWithinEnabledSet < table->FreezeColumnsRequest) == (next_column->IndexWithinEnabledSet < table->FreezeColumnsRequest)) + table->ReorderColumnDir = +1; + } + + // Sort order arrow + const float ellipsis_max = cell_r.Max.x - w_arrow - w_sort_text; + if ((table->Flags & ImGuiTableFlags_Sortable) && !(column->Flags & ImGuiTableColumnFlags_NoSort)) + { + if (column->SortOrder != -1) + { + float x = ImMax(cell_r.Min.x, cell_r.Max.x - w_arrow - w_sort_text); + float y = label_pos.y; + if (column->SortOrder > 0) + { + PushStyleColor(ImGuiCol_Text, GetColorU32(ImGuiCol_Text, 0.70f)); + RenderText(ImVec2(x + g.Style.ItemInnerSpacing.x, y), sort_order_suf); + PopStyleColor(); + x += w_sort_text; + } + RenderArrow(window->DrawList, ImVec2(x, y), GetColorU32(ImGuiCol_Text), column->SortDirection == ImGuiSortDirection_Ascending ? ImGuiDir_Up : ImGuiDir_Down, ARROW_SCALE); + } + + // Handle clicking on column header to adjust Sort Order + if (pressed && table->ReorderColumn != column_n) + { + ImGuiSortDirection sort_direction = TableGetColumnNextSortDirection(column); + TableSetColumnSortDirection(column_n, sort_direction, g.IO.KeyShift); + } + } + + // Render clipped label. Clipping here ensure that in the majority of situations, all our header cells will + // be merged into a single draw call. + //window->DrawList->AddCircleFilled(ImVec2(ellipsis_max, label_pos.y), 40, IM_COL32_WHITE); + RenderTextEllipsis(window->DrawList, label_pos, ImVec2(ellipsis_max, label_pos.y + label_height + g.Style.FramePadding.y), ellipsis_max, ellipsis_max, label, label_end, &label_size); + + const bool text_clipped = label_size.x > (ellipsis_max - label_pos.x); + if (text_clipped && hovered && g.HoveredIdNotActiveTimer > g.TooltipSlowDelay) + SetTooltip("%.*s", (int)(label_end - label), label); + + // We don't use BeginPopupContextItem() because we want the popup to stay up even after the column is hidden + if (IsMouseReleased(1) && IsItemHovered()) + TableOpenContextMenu(column_n); +} + +//------------------------------------------------------------------------- +// [SECTION] Tables: Context Menu +//------------------------------------------------------------------------- +// - TableOpenContextMenu() [Internal] +// - TableDrawContextMenu() [Internal] +//------------------------------------------------------------------------- + +// Use -1 to open menu not specific to a given column. +void ImGui::TableOpenContextMenu(int column_n) +{ + ImGuiContext& g = *GImGui; + ImGuiTable* table = g.CurrentTable; + if (column_n == -1 && table->CurrentColumn != -1) // When called within a column automatically use this one (for consistency) + column_n = table->CurrentColumn; + if (column_n == table->ColumnsCount) // To facilitate using with TableGetHoveredColumn() + column_n = -1; + IM_ASSERT(column_n >= -1 && column_n < table->ColumnsCount); + if (table->Flags & (ImGuiTableFlags_Resizable | ImGuiTableFlags_Reorderable | ImGuiTableFlags_Hideable)) + { + table->IsContextPopupOpen = true; + table->ContextPopupColumn = (ImGuiTableColumnIdx)column_n; + table->InstanceInteracted = table->InstanceCurrent; + const ImGuiID context_menu_id = ImHashStr("##ContextMenu", 0, table->ID); + OpenPopupEx(context_menu_id, ImGuiPopupFlags_None); + } +} + +// Output context menu into current window (generally a popup) +// FIXME-TABLE: Ideally this should be writable by the user. Full programmatic access to that data? +void ImGui::TableDrawContextMenu(ImGuiTable* table) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return; + + bool want_separator = false; + const int column_n = (table->ContextPopupColumn >= 0 && table->ContextPopupColumn < table->ColumnsCount) ? table->ContextPopupColumn : -1; + ImGuiTableColumn* column = (column_n != -1) ? &table->Columns[column_n] : NULL; + + // Sizing + if (table->Flags & ImGuiTableFlags_Resizable) + { + if (column != NULL) + { + const bool can_resize = !(column->Flags & ImGuiTableColumnFlags_NoResize) && column->IsEnabled; + if (MenuItem("Size column to fit###SizeOne", NULL, false, can_resize)) + TableSetColumnWidthAutoSingle(table, column_n); + } + + const char* size_all_desc; + if (table->ColumnsEnabledFixedCount == table->ColumnsEnabledCount && (table->Flags & ImGuiTableFlags_SizingMask_) != ImGuiTableFlags_SizingFixedSame) + size_all_desc = "Size all columns to fit###SizeAll"; // All fixed + else + size_all_desc = "Size all columns to default###SizeAll"; // All stretch or mixed + if (MenuItem(size_all_desc, NULL)) + TableSetColumnWidthAutoAll(table); + want_separator = true; + } + + // Ordering + if (table->Flags & ImGuiTableFlags_Reorderable) + { + if (MenuItem("Reset order", NULL, false, !table->IsDefaultDisplayOrder)) + table->IsResetDisplayOrderRequest = true; + want_separator = true; + } + + // Reset all (should work but seems unnecessary/noisy to expose?) + //if (MenuItem("Reset all")) + // table->IsResetAllRequest = true; + + // Sorting + // (modify TableOpenContextMenu() to add _Sortable flag if enabling this) +#if 0 + if ((table->Flags & ImGuiTableFlags_Sortable) && column != NULL && (column->Flags & ImGuiTableColumnFlags_NoSort) == 0) + { + if (want_separator) + Separator(); + want_separator = true; + + bool append_to_sort_specs = g.IO.KeyShift; + if (MenuItem("Sort in Ascending Order", NULL, column->SortOrder != -1 && column->SortDirection == ImGuiSortDirection_Ascending, (column->Flags & ImGuiTableColumnFlags_NoSortAscending) == 0)) + TableSetColumnSortDirection(table, column_n, ImGuiSortDirection_Ascending, append_to_sort_specs); + if (MenuItem("Sort in Descending Order", NULL, column->SortOrder != -1 && column->SortDirection == ImGuiSortDirection_Descending, (column->Flags & ImGuiTableColumnFlags_NoSortDescending) == 0)) + TableSetColumnSortDirection(table, column_n, ImGuiSortDirection_Descending, append_to_sort_specs); + } +#endif + + // Hiding / Visibility + if (table->Flags & ImGuiTableFlags_Hideable) + { + if (want_separator) + Separator(); + want_separator = true; + + PushItemFlag(ImGuiItemFlags_SelectableDontClosePopup, true); + for (int other_column_n = 0; other_column_n < table->ColumnsCount; other_column_n++) + { + ImGuiTableColumn* other_column = &table->Columns[other_column_n]; + if (other_column->Flags & ImGuiTableColumnFlags_Disabled) + continue; + + const char* name = TableGetColumnName(table, other_column_n); + if (name == NULL || name[0] == 0) + name = ""; + + // Make sure we can't hide the last active column + bool menu_item_active = (other_column->Flags & ImGuiTableColumnFlags_NoHide) ? false : true; + if (other_column->IsUserEnabled && table->ColumnsEnabledCount <= 1) + menu_item_active = false; + if (MenuItem(name, NULL, other_column->IsUserEnabled, menu_item_active)) + other_column->IsUserEnabledNextFrame = !other_column->IsUserEnabled; + } + PopItemFlag(); + } +} + +//------------------------------------------------------------------------- +// [SECTION] Tables: Settings (.ini data) +//------------------------------------------------------------------------- +// FIXME: The binding/finding/creating flow are too confusing. +//------------------------------------------------------------------------- +// - TableSettingsInit() [Internal] +// - TableSettingsCalcChunkSize() [Internal] +// - TableSettingsCreate() [Internal] +// - TableSettingsFindByID() [Internal] +// - TableGetBoundSettings() [Internal] +// - TableResetSettings() +// - TableSaveSettings() [Internal] +// - TableLoadSettings() [Internal] +// - TableSettingsHandler_ClearAll() [Internal] +// - TableSettingsHandler_ApplyAll() [Internal] +// - TableSettingsHandler_ReadOpen() [Internal] +// - TableSettingsHandler_ReadLine() [Internal] +// - TableSettingsHandler_WriteAll() [Internal] +// - TableSettingsInstallHandler() [Internal] +//------------------------------------------------------------------------- +// [Init] 1: TableSettingsHandler_ReadXXXX() Load and parse .ini file into TableSettings. +// [Main] 2: TableLoadSettings() When table is created, bind Table to TableSettings, serialize TableSettings data into Table. +// [Main] 3: TableSaveSettings() When table properties are modified, serialize Table data into bound or new TableSettings, mark .ini as dirty. +// [Main] 4: TableSettingsHandler_WriteAll() When .ini file is dirty (which can come from other source), save TableSettings into .ini file. +//------------------------------------------------------------------------- + +// Clear and initialize empty settings instance +static void TableSettingsInit(ImGuiTableSettings* settings, ImGuiID id, int columns_count, int columns_count_max) +{ + IM_PLACEMENT_NEW(settings) ImGuiTableSettings(); + ImGuiTableColumnSettings* settings_column = settings->GetColumnSettings(); + for (int n = 0; n < columns_count_max; n++, settings_column++) + IM_PLACEMENT_NEW(settings_column) ImGuiTableColumnSettings(); + settings->ID = id; + settings->ColumnsCount = (ImGuiTableColumnIdx)columns_count; + settings->ColumnsCountMax = (ImGuiTableColumnIdx)columns_count_max; + settings->WantApply = true; +} + +static size_t TableSettingsCalcChunkSize(int columns_count) +{ + return sizeof(ImGuiTableSettings) + (size_t)columns_count * sizeof(ImGuiTableColumnSettings); +} + +ImGuiTableSettings* ImGui::TableSettingsCreate(ImGuiID id, int columns_count) +{ + ImGuiContext& g = *GImGui; + ImGuiTableSettings* settings = g.SettingsTables.alloc_chunk(TableSettingsCalcChunkSize(columns_count)); + TableSettingsInit(settings, id, columns_count, columns_count); + return settings; +} + +// Find existing settings +ImGuiTableSettings* ImGui::TableSettingsFindByID(ImGuiID id) +{ + // FIXME-OPT: Might want to store a lookup map for this? + ImGuiContext& g = *GImGui; + for (ImGuiTableSettings* settings = g.SettingsTables.begin(); settings != NULL; settings = g.SettingsTables.next_chunk(settings)) + if (settings->ID == id) + return settings; + return NULL; +} + +// Get settings for a given table, NULL if none +ImGuiTableSettings* ImGui::TableGetBoundSettings(ImGuiTable* table) +{ + if (table->SettingsOffset != -1) + { + ImGuiContext& g = *GImGui; + ImGuiTableSettings* settings = g.SettingsTables.ptr_from_offset(table->SettingsOffset); + IM_ASSERT(settings->ID == table->ID); + if (settings->ColumnsCountMax >= table->ColumnsCount) + return settings; // OK + settings->ID = 0; // Invalidate storage, we won't fit because of a count change + } + return NULL; +} + +// Restore initial state of table (with or without saved settings) +void ImGui::TableResetSettings(ImGuiTable* table) +{ + table->IsInitializing = table->IsSettingsDirty = true; + table->IsResetAllRequest = false; + table->IsSettingsRequestLoad = false; // Don't reload from ini + table->SettingsLoadedFlags = ImGuiTableFlags_None; // Mark as nothing loaded so our initialized data becomes authoritative +} + +void ImGui::TableSaveSettings(ImGuiTable* table) +{ + table->IsSettingsDirty = false; + if (table->Flags & ImGuiTableFlags_NoSavedSettings) + return; + + // Bind or create settings data + ImGuiContext& g = *GImGui; + ImGuiTableSettings* settings = TableGetBoundSettings(table); + if (settings == NULL) + { + settings = TableSettingsCreate(table->ID, table->ColumnsCount); + table->SettingsOffset = g.SettingsTables.offset_from_ptr(settings); + } + settings->ColumnsCount = (ImGuiTableColumnIdx)table->ColumnsCount; + + // Serialize ImGuiTable/ImGuiTableColumn into ImGuiTableSettings/ImGuiTableColumnSettings + IM_ASSERT(settings->ID == table->ID); + IM_ASSERT(settings->ColumnsCount == table->ColumnsCount && settings->ColumnsCountMax >= settings->ColumnsCount); + ImGuiTableColumn* column = table->Columns.Data; + ImGuiTableColumnSettings* column_settings = settings->GetColumnSettings(); + + bool save_ref_scale = false; + settings->SaveFlags = ImGuiTableFlags_None; + for (int n = 0; n < table->ColumnsCount; n++, column++, column_settings++) + { + const float width_or_weight = (column->Flags & ImGuiTableColumnFlags_WidthStretch) ? column->StretchWeight : column->WidthRequest; + column_settings->WidthOrWeight = width_or_weight; + column_settings->Index = (ImGuiTableColumnIdx)n; + column_settings->DisplayOrder = column->DisplayOrder; + column_settings->SortOrder = column->SortOrder; + column_settings->SortDirection = column->SortDirection; + column_settings->IsEnabled = column->IsUserEnabled; + column_settings->IsStretch = (column->Flags & ImGuiTableColumnFlags_WidthStretch) ? 1 : 0; + if ((column->Flags & ImGuiTableColumnFlags_WidthStretch) == 0) + save_ref_scale = true; + + // We skip saving some data in the .ini file when they are unnecessary to restore our state. + // Note that fixed width where initial width was derived from auto-fit will always be saved as InitStretchWeightOrWidth will be 0.0f. + // FIXME-TABLE: We don't have logic to easily compare SortOrder to DefaultSortOrder yet so it's always saved when present. + if (width_or_weight != column->InitStretchWeightOrWidth) + settings->SaveFlags |= ImGuiTableFlags_Resizable; + if (column->DisplayOrder != n) + settings->SaveFlags |= ImGuiTableFlags_Reorderable; + if (column->SortOrder != -1) + settings->SaveFlags |= ImGuiTableFlags_Sortable; + if (column->IsUserEnabled != ((column->Flags & ImGuiTableColumnFlags_DefaultHide) == 0)) + settings->SaveFlags |= ImGuiTableFlags_Hideable; + } + settings->SaveFlags &= table->Flags; + settings->RefScale = save_ref_scale ? table->RefScale : 0.0f; + + MarkIniSettingsDirty(); +} + +void ImGui::TableLoadSettings(ImGuiTable* table) +{ + ImGuiContext& g = *GImGui; + table->IsSettingsRequestLoad = false; + if (table->Flags & ImGuiTableFlags_NoSavedSettings) + return; + + // Bind settings + ImGuiTableSettings* settings; + if (table->SettingsOffset == -1) + { + settings = TableSettingsFindByID(table->ID); + if (settings == NULL) + return; + if (settings->ColumnsCount != table->ColumnsCount) // Allow settings if columns count changed. We could otherwise decide to return... + table->IsSettingsDirty = true; + table->SettingsOffset = g.SettingsTables.offset_from_ptr(settings); + } + else + { + settings = TableGetBoundSettings(table); + } + + table->SettingsLoadedFlags = settings->SaveFlags; + table->RefScale = settings->RefScale; + + // Serialize ImGuiTableSettings/ImGuiTableColumnSettings into ImGuiTable/ImGuiTableColumn + ImGuiTableColumnSettings* column_settings = settings->GetColumnSettings(); + ImU64 display_order_mask = 0; + for (int data_n = 0; data_n < settings->ColumnsCount; data_n++, column_settings++) + { + int column_n = column_settings->Index; + if (column_n < 0 || column_n >= table->ColumnsCount) + continue; + + ImGuiTableColumn* column = &table->Columns[column_n]; + if (settings->SaveFlags & ImGuiTableFlags_Resizable) + { + if (column_settings->IsStretch) + column->StretchWeight = column_settings->WidthOrWeight; + else + column->WidthRequest = column_settings->WidthOrWeight; + column->AutoFitQueue = 0x00; + } + if (settings->SaveFlags & ImGuiTableFlags_Reorderable) + column->DisplayOrder = column_settings->DisplayOrder; + else + column->DisplayOrder = (ImGuiTableColumnIdx)column_n; + display_order_mask |= (ImU64)1 << column->DisplayOrder; + column->IsUserEnabled = column->IsUserEnabledNextFrame = column_settings->IsEnabled; + column->SortOrder = column_settings->SortOrder; + column->SortDirection = column_settings->SortDirection; + } + + // Validate and fix invalid display order data + const ImU64 expected_display_order_mask = (settings->ColumnsCount == 64) ? ~0 : ((ImU64)1 << settings->ColumnsCount) - 1; + if (display_order_mask != expected_display_order_mask) + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + table->Columns[column_n].DisplayOrder = (ImGuiTableColumnIdx)column_n; + + // Rebuild index + for (int column_n = 0; column_n < table->ColumnsCount; column_n++) + table->DisplayOrderToIndex[table->Columns[column_n].DisplayOrder] = (ImGuiTableColumnIdx)column_n; +} + +static void TableSettingsHandler_ClearAll(ImGuiContext* ctx, ImGuiSettingsHandler*) +{ + ImGuiContext& g = *ctx; + for (int i = 0; i != g.Tables.GetMapSize(); i++) + if (ImGuiTable* table = g.Tables.TryGetMapData(i)) + table->SettingsOffset = -1; + g.SettingsTables.clear(); +} + +// Apply to existing windows (if any) +static void TableSettingsHandler_ApplyAll(ImGuiContext* ctx, ImGuiSettingsHandler*) +{ + ImGuiContext& g = *ctx; + for (int i = 0; i != g.Tables.GetMapSize(); i++) + if (ImGuiTable* table = g.Tables.TryGetMapData(i)) + { + table->IsSettingsRequestLoad = true; + table->SettingsOffset = -1; + } +} + +static void* TableSettingsHandler_ReadOpen(ImGuiContext*, ImGuiSettingsHandler*, const char* name) +{ + ImGuiID id = 0; + int columns_count = 0; + if (sscanf(name, "0x%08X,%d", &id, &columns_count) < 2) + return NULL; + + if (ImGuiTableSettings* settings = ImGui::TableSettingsFindByID(id)) + { + if (settings->ColumnsCountMax >= columns_count) + { + TableSettingsInit(settings, id, columns_count, settings->ColumnsCountMax); // Recycle + return settings; + } + settings->ID = 0; // Invalidate storage, we won't fit because of a count change + } + return ImGui::TableSettingsCreate(id, columns_count); +} + +static void TableSettingsHandler_ReadLine(ImGuiContext*, ImGuiSettingsHandler*, void* entry, const char* line) +{ + // "Column 0 UserID=0x42AD2D21 Width=100 Visible=1 Order=0 Sort=0v" + ImGuiTableSettings* settings = (ImGuiTableSettings*)entry; + float f = 0.0f; + int column_n = 0, r = 0, n = 0; + + if (sscanf(line, "RefScale=%f", &f) == 1) { settings->RefScale = f; return; } + + if (sscanf(line, "Column %d%n", &column_n, &r) == 1) + { + if (column_n < 0 || column_n >= settings->ColumnsCount) + return; + line = ImStrSkipBlank(line + r); + char c = 0; + ImGuiTableColumnSettings* column = settings->GetColumnSettings() + column_n; + column->Index = (ImGuiTableColumnIdx)column_n; + if (sscanf(line, "UserID=0x%08X%n", (ImU32*)&n, &r)==1) { line = ImStrSkipBlank(line + r); column->UserID = (ImGuiID)n; } + if (sscanf(line, "Width=%d%n", &n, &r) == 1) { line = ImStrSkipBlank(line + r); column->WidthOrWeight = (float)n; column->IsStretch = 0; settings->SaveFlags |= ImGuiTableFlags_Resizable; } + if (sscanf(line, "Weight=%f%n", &f, &r) == 1) { line = ImStrSkipBlank(line + r); column->WidthOrWeight = f; column->IsStretch = 1; settings->SaveFlags |= ImGuiTableFlags_Resizable; } + if (sscanf(line, "Visible=%d%n", &n, &r) == 1) { line = ImStrSkipBlank(line + r); column->IsEnabled = (ImU8)n; settings->SaveFlags |= ImGuiTableFlags_Hideable; } + if (sscanf(line, "Order=%d%n", &n, &r) == 1) { line = ImStrSkipBlank(line + r); column->DisplayOrder = (ImGuiTableColumnIdx)n; settings->SaveFlags |= ImGuiTableFlags_Reorderable; } + if (sscanf(line, "Sort=%d%c%n", &n, &c, &r) == 2) { line = ImStrSkipBlank(line + r); column->SortOrder = (ImGuiTableColumnIdx)n; column->SortDirection = (c == '^') ? ImGuiSortDirection_Descending : ImGuiSortDirection_Ascending; settings->SaveFlags |= ImGuiTableFlags_Sortable; } + } +} + +static void TableSettingsHandler_WriteAll(ImGuiContext* ctx, ImGuiSettingsHandler* handler, ImGuiTextBuffer* buf) +{ + ImGuiContext& g = *ctx; + for (ImGuiTableSettings* settings = g.SettingsTables.begin(); settings != NULL; settings = g.SettingsTables.next_chunk(settings)) + { + if (settings->ID == 0) // Skip ditched settings + continue; + + // TableSaveSettings() may clear some of those flags when we establish that the data can be stripped + // (e.g. Order was unchanged) + const bool save_size = (settings->SaveFlags & ImGuiTableFlags_Resizable) != 0; + const bool save_visible = (settings->SaveFlags & ImGuiTableFlags_Hideable) != 0; + const bool save_order = (settings->SaveFlags & ImGuiTableFlags_Reorderable) != 0; + const bool save_sort = (settings->SaveFlags & ImGuiTableFlags_Sortable) != 0; + if (!save_size && !save_visible && !save_order && !save_sort) + continue; + + buf->reserve(buf->size() + 30 + settings->ColumnsCount * 50); // ballpark reserve + buf->appendf("[%s][0x%08X,%d]\n", handler->TypeName, settings->ID, settings->ColumnsCount); + if (settings->RefScale != 0.0f) + buf->appendf("RefScale=%g\n", settings->RefScale); + ImGuiTableColumnSettings* column = settings->GetColumnSettings(); + for (int column_n = 0; column_n < settings->ColumnsCount; column_n++, column++) + { + // "Column 0 UserID=0x42AD2D21 Width=100 Visible=1 Order=0 Sort=0v" + bool save_column = column->UserID != 0 || save_size || save_visible || save_order || (save_sort && column->SortOrder != -1); + if (!save_column) + continue; + buf->appendf("Column %-2d", column_n); + if (column->UserID != 0) buf->appendf(" UserID=%08X", column->UserID); + if (save_size && column->IsStretch) buf->appendf(" Weight=%.4f", column->WidthOrWeight); + if (save_size && !column->IsStretch) buf->appendf(" Width=%d", (int)column->WidthOrWeight); + if (save_visible) buf->appendf(" Visible=%d", column->IsEnabled); + if (save_order) buf->appendf(" Order=%d", column->DisplayOrder); + if (save_sort && column->SortOrder != -1) buf->appendf(" Sort=%d%c", column->SortOrder, (column->SortDirection == ImGuiSortDirection_Ascending) ? 'v' : '^'); + buf->append("\n"); + } + buf->append("\n"); + } +} + +void ImGui::TableSettingsInstallHandler(ImGuiContext* context) +{ + ImGuiContext& g = *context; + ImGuiSettingsHandler ini_handler; + ini_handler.TypeName = "Table"; + ini_handler.TypeHash = ImHashStr("Table"); + ini_handler.ClearAllFn = TableSettingsHandler_ClearAll; + ini_handler.ReadOpenFn = TableSettingsHandler_ReadOpen; + ini_handler.ReadLineFn = TableSettingsHandler_ReadLine; + ini_handler.ApplyAllFn = TableSettingsHandler_ApplyAll; + ini_handler.WriteAllFn = TableSettingsHandler_WriteAll; + g.SettingsHandlers.push_back(ini_handler); +} + +//------------------------------------------------------------------------- +// [SECTION] Tables: Garbage Collection +//------------------------------------------------------------------------- +// - TableRemove() [Internal] +// - TableGcCompactTransientBuffers() [Internal] +// - TableGcCompactSettings() [Internal] +//------------------------------------------------------------------------- + +// Remove Table (currently only used by TestEngine) +void ImGui::TableRemove(ImGuiTable* table) +{ + //IMGUI_DEBUG_LOG("TableRemove() id=0x%08X\n", table->ID); + ImGuiContext& g = *GImGui; + int table_idx = g.Tables.GetIndex(table); + //memset(table->RawData.Data, 0, table->RawData.size_in_bytes()); + //memset(table, 0, sizeof(ImGuiTable)); + g.Tables.Remove(table->ID, table); + g.TablesLastTimeActive[table_idx] = -1.0f; +} + +// Free up/compact internal Table buffers for when it gets unused +void ImGui::TableGcCompactTransientBuffers(ImGuiTable* table) +{ + //IMGUI_DEBUG_LOG("TableGcCompactTransientBuffers() id=0x%08X\n", table->ID); + ImGuiContext& g = *GImGui; + IM_ASSERT(table->MemoryCompacted == false); + table->SortSpecs.Specs = NULL; + table->SortSpecsMulti.clear(); + table->IsSortSpecsDirty = true; // FIXME: shouldn't have to leak into user performing a sort + table->ColumnsNames.clear(); + table->MemoryCompacted = true; + for (int n = 0; n < table->ColumnsCount; n++) + table->Columns[n].NameOffset = -1; + g.TablesLastTimeActive[g.Tables.GetIndex(table)] = -1.0f; +} + +void ImGui::TableGcCompactTransientBuffers(ImGuiTableTempData* temp_data) +{ + temp_data->DrawSplitter.ClearFreeMemory(); + temp_data->LastTimeActive = -1.0f; +} + +// Compact and remove unused settings data (currently only used by TestEngine) +void ImGui::TableGcCompactSettings() +{ + ImGuiContext& g = *GImGui; + int required_memory = 0; + for (ImGuiTableSettings* settings = g.SettingsTables.begin(); settings != NULL; settings = g.SettingsTables.next_chunk(settings)) + if (settings->ID != 0) + required_memory += (int)TableSettingsCalcChunkSize(settings->ColumnsCount); + if (required_memory == g.SettingsTables.Buf.Size) + return; + ImChunkStream new_chunk_stream; + new_chunk_stream.Buf.reserve(required_memory); + for (ImGuiTableSettings* settings = g.SettingsTables.begin(); settings != NULL; settings = g.SettingsTables.next_chunk(settings)) + if (settings->ID != 0) + memcpy(new_chunk_stream.alloc_chunk(TableSettingsCalcChunkSize(settings->ColumnsCount)), settings, TableSettingsCalcChunkSize(settings->ColumnsCount)); + g.SettingsTables.swap(new_chunk_stream); +} + + +//------------------------------------------------------------------------- +// [SECTION] Tables: Debugging +//------------------------------------------------------------------------- +// - DebugNodeTable() [Internal] +//------------------------------------------------------------------------- + +#ifndef IMGUI_DISABLE_METRICS_WINDOW + +static const char* DebugNodeTableGetSizingPolicyDesc(ImGuiTableFlags sizing_policy) +{ + sizing_policy &= ImGuiTableFlags_SizingMask_; + if (sizing_policy == ImGuiTableFlags_SizingFixedFit) { return "FixedFit"; } + if (sizing_policy == ImGuiTableFlags_SizingFixedSame) { return "FixedSame"; } + if (sizing_policy == ImGuiTableFlags_SizingStretchProp) { return "StretchProp"; } + if (sizing_policy == ImGuiTableFlags_SizingStretchSame) { return "StretchSame"; } + return "N/A"; +} + +void ImGui::DebugNodeTable(ImGuiTable* table) +{ + char buf[512]; + char* p = buf; + const char* buf_end = buf + IM_ARRAYSIZE(buf); + const bool is_active = (table->LastFrameActive >= ImGui::GetFrameCount() - 2); // Note that fully clipped early out scrolling tables will appear as inactive here. + ImFormatString(p, buf_end - p, "Table 0x%08X (%d columns, in '%s')%s", table->ID, table->ColumnsCount, table->OuterWindow->Name, is_active ? "" : " *Inactive*"); + if (!is_active) { PushStyleColor(ImGuiCol_Text, GetStyleColorVec4(ImGuiCol_TextDisabled)); } + bool open = TreeNode(table, "%s", buf); + if (!is_active) { PopStyleColor(); } + if (IsItemHovered()) + GetForegroundDrawList()->AddRect(table->OuterRect.Min, table->OuterRect.Max, IM_COL32(255, 255, 0, 255)); + if (IsItemVisible() && table->HoveredColumnBody != -1) + GetForegroundDrawList()->AddRect(GetItemRectMin(), GetItemRectMax(), IM_COL32(255, 255, 0, 255)); + if (!open) + return; + bool clear_settings = SmallButton("Clear settings"); + BulletText("OuterRect: Pos: (%.1f,%.1f) Size: (%.1f,%.1f) Sizing: '%s'", table->OuterRect.Min.x, table->OuterRect.Min.y, table->OuterRect.GetWidth(), table->OuterRect.GetHeight(), DebugNodeTableGetSizingPolicyDesc(table->Flags)); + BulletText("ColumnsGivenWidth: %.1f, ColumnsAutoFitWidth: %.1f, InnerWidth: %.1f%s", table->ColumnsGivenWidth, table->ColumnsAutoFitWidth, table->InnerWidth, table->InnerWidth == 0.0f ? " (auto)" : ""); + BulletText("CellPaddingX: %.1f, CellSpacingX: %.1f/%.1f, OuterPaddingX: %.1f", table->CellPaddingX, table->CellSpacingX1, table->CellSpacingX2, table->OuterPaddingX); + BulletText("HoveredColumnBody: %d, HoveredColumnBorder: %d", table->HoveredColumnBody, table->HoveredColumnBorder); + BulletText("ResizedColumn: %d, ReorderColumn: %d, HeldHeaderColumn: %d", table->ResizedColumn, table->ReorderColumn, table->HeldHeaderColumn); + //BulletText("BgDrawChannels: %d/%d", 0, table->BgDrawChannelUnfrozen); + float sum_weights = 0.0f; + for (int n = 0; n < table->ColumnsCount; n++) + if (table->Columns[n].Flags & ImGuiTableColumnFlags_WidthStretch) + sum_weights += table->Columns[n].StretchWeight; + for (int n = 0; n < table->ColumnsCount; n++) + { + ImGuiTableColumn* column = &table->Columns[n]; + const char* name = TableGetColumnName(table, n); + ImFormatString(buf, IM_ARRAYSIZE(buf), + "Column %d order %d '%s': offset %+.2f to %+.2f%s\n" + "Enabled: %d, VisibleX/Y: %d/%d, RequestOutput: %d, SkipItems: %d, DrawChannels: %d,%d\n" + "WidthGiven: %.1f, Request/Auto: %.1f/%.1f, StretchWeight: %.3f (%.1f%%)\n" + "MinX: %.1f, MaxX: %.1f (%+.1f), ClipRect: %.1f to %.1f (+%.1f)\n" + "ContentWidth: %.1f,%.1f, HeadersUsed/Ideal %.1f/%.1f\n" + "Sort: %d%s, UserID: 0x%08X, Flags: 0x%04X: %s%s%s..", + n, column->DisplayOrder, name, column->MinX - table->WorkRect.Min.x, column->MaxX - table->WorkRect.Min.x, (n < table->FreezeColumnsRequest) ? " (Frozen)" : "", + column->IsEnabled, column->IsVisibleX, column->IsVisibleY, column->IsRequestOutput, column->IsSkipItems, column->DrawChannelFrozen, column->DrawChannelUnfrozen, + column->WidthGiven, column->WidthRequest, column->WidthAuto, column->StretchWeight, column->StretchWeight > 0.0f ? (column->StretchWeight / sum_weights) * 100.0f : 0.0f, + column->MinX, column->MaxX, column->MaxX - column->MinX, column->ClipRect.Min.x, column->ClipRect.Max.x, column->ClipRect.Max.x - column->ClipRect.Min.x, + column->ContentMaxXFrozen - column->WorkMinX, column->ContentMaxXUnfrozen - column->WorkMinX, column->ContentMaxXHeadersUsed - column->WorkMinX, column->ContentMaxXHeadersIdeal - column->WorkMinX, + column->SortOrder, (column->SortDirection == ImGuiSortDirection_Ascending) ? " (Asc)" : (column->SortDirection == ImGuiSortDirection_Descending) ? " (Des)" : "", column->UserID, column->Flags, + (column->Flags & ImGuiTableColumnFlags_WidthStretch) ? "WidthStretch " : "", + (column->Flags & ImGuiTableColumnFlags_WidthFixed) ? "WidthFixed " : "", + (column->Flags & ImGuiTableColumnFlags_NoResize) ? "NoResize " : ""); + Bullet(); + Selectable(buf); + if (IsItemHovered()) + { + ImRect r(column->MinX, table->OuterRect.Min.y, column->MaxX, table->OuterRect.Max.y); + GetForegroundDrawList()->AddRect(r.Min, r.Max, IM_COL32(255, 255, 0, 255)); + } + } + if (ImGuiTableSettings* settings = TableGetBoundSettings(table)) + DebugNodeTableSettings(settings); + if (clear_settings) + table->IsResetAllRequest = true; + TreePop(); +} + +void ImGui::DebugNodeTableSettings(ImGuiTableSettings* settings) +{ + if (!TreeNode((void*)(intptr_t)settings->ID, "Settings 0x%08X (%d columns)", settings->ID, settings->ColumnsCount)) + return; + BulletText("SaveFlags: 0x%08X", settings->SaveFlags); + BulletText("ColumnsCount: %d (max %d)", settings->ColumnsCount, settings->ColumnsCountMax); + for (int n = 0; n < settings->ColumnsCount; n++) + { + ImGuiTableColumnSettings* column_settings = &settings->GetColumnSettings()[n]; + ImGuiSortDirection sort_dir = (column_settings->SortOrder != -1) ? (ImGuiSortDirection)column_settings->SortDirection : ImGuiSortDirection_None; + BulletText("Column %d Order %d SortOrder %d %s Vis %d %s %7.3f UserID 0x%08X", + n, column_settings->DisplayOrder, column_settings->SortOrder, + (sort_dir == ImGuiSortDirection_Ascending) ? "Asc" : (sort_dir == ImGuiSortDirection_Descending) ? "Des" : "---", + column_settings->IsEnabled, column_settings->IsStretch ? "Weight" : "Width ", column_settings->WidthOrWeight, column_settings->UserID); + } + TreePop(); +} + +#else // #ifndef IMGUI_DISABLE_METRICS_WINDOW + +void ImGui::DebugNodeTable(ImGuiTable*) {} +void ImGui::DebugNodeTableSettings(ImGuiTableSettings*) {} + +#endif + + +//------------------------------------------------------------------------- +// [SECTION] Columns, BeginColumns, EndColumns, etc. +// (This is a legacy API, prefer using BeginTable/EndTable!) +//------------------------------------------------------------------------- +// FIXME: sizing is lossy when columns width is very small (default width may turn negative etc.) +//------------------------------------------------------------------------- +// - SetWindowClipRectBeforeSetChannel() [Internal] +// - GetColumnIndex() +// - GetColumnsCount() +// - GetColumnOffset() +// - GetColumnWidth() +// - SetColumnOffset() +// - SetColumnWidth() +// - PushColumnClipRect() [Internal] +// - PushColumnsBackground() [Internal] +// - PopColumnsBackground() [Internal] +// - FindOrCreateColumns() [Internal] +// - GetColumnsID() [Internal] +// - BeginColumns() +// - NextColumn() +// - EndColumns() +// - Columns() +//------------------------------------------------------------------------- + +// [Internal] Small optimization to avoid calls to PopClipRect/SetCurrentChannel/PushClipRect in sequences, +// they would meddle many times with the underlying ImDrawCmd. +// Instead, we do a preemptive overwrite of clipping rectangle _without_ altering the command-buffer and let +// the subsequent single call to SetCurrentChannel() does it things once. +void ImGui::SetWindowClipRectBeforeSetChannel(ImGuiWindow* window, const ImRect& clip_rect) +{ + ImVec4 clip_rect_vec4 = clip_rect.ToVec4(); + window->ClipRect = clip_rect; + window->DrawList->_CmdHeader.ClipRect = clip_rect_vec4; + window->DrawList->_ClipRectStack.Data[window->DrawList->_ClipRectStack.Size - 1] = clip_rect_vec4; +} + +int ImGui::GetColumnIndex() +{ + ImGuiWindow* window = GetCurrentWindowRead(); + return window->DC.CurrentColumns ? window->DC.CurrentColumns->Current : 0; +} + +int ImGui::GetColumnsCount() +{ + ImGuiWindow* window = GetCurrentWindowRead(); + return window->DC.CurrentColumns ? window->DC.CurrentColumns->Count : 1; +} + +float ImGui::GetColumnOffsetFromNorm(const ImGuiOldColumns* columns, float offset_norm) +{ + return offset_norm * (columns->OffMaxX - columns->OffMinX); +} + +float ImGui::GetColumnNormFromOffset(const ImGuiOldColumns* columns, float offset) +{ + return offset / (columns->OffMaxX - columns->OffMinX); +} + +static const float COLUMNS_HIT_RECT_HALF_WIDTH = 4.0f; + +static float GetDraggedColumnOffset(ImGuiOldColumns* columns, int column_index) +{ + // Active (dragged) column always follow mouse. The reason we need this is that dragging a column to the right edge of an auto-resizing + // window creates a feedback loop because we store normalized positions. So while dragging we enforce absolute positioning. + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + IM_ASSERT(column_index > 0); // We are not supposed to drag column 0. + IM_ASSERT(g.ActiveId == columns->ID + ImGuiID(column_index)); + + float x = g.IO.MousePos.x - g.ActiveIdClickOffset.x + COLUMNS_HIT_RECT_HALF_WIDTH - window->Pos.x; + x = ImMax(x, ImGui::GetColumnOffset(column_index - 1) + g.Style.ColumnsMinSpacing); + if ((columns->Flags & ImGuiOldColumnFlags_NoPreserveWidths)) + x = ImMin(x, ImGui::GetColumnOffset(column_index + 1) - g.Style.ColumnsMinSpacing); + + return x; +} + +float ImGui::GetColumnOffset(int column_index) +{ + ImGuiWindow* window = GetCurrentWindowRead(); + ImGuiOldColumns* columns = window->DC.CurrentColumns; + if (columns == NULL) + return 0.0f; + + if (column_index < 0) + column_index = columns->Current; + IM_ASSERT(column_index < columns->Columns.Size); + + const float t = columns->Columns[column_index].OffsetNorm; + const float x_offset = ImLerp(columns->OffMinX, columns->OffMaxX, t); + return x_offset; +} + +static float GetColumnWidthEx(ImGuiOldColumns* columns, int column_index, bool before_resize = false) +{ + if (column_index < 0) + column_index = columns->Current; + + float offset_norm; + if (before_resize) + offset_norm = columns->Columns[column_index + 1].OffsetNormBeforeResize - columns->Columns[column_index].OffsetNormBeforeResize; + else + offset_norm = columns->Columns[column_index + 1].OffsetNorm - columns->Columns[column_index].OffsetNorm; + return ImGui::GetColumnOffsetFromNorm(columns, offset_norm); +} + +float ImGui::GetColumnWidth(int column_index) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImGuiOldColumns* columns = window->DC.CurrentColumns; + if (columns == NULL) + return GetContentRegionAvail().x; + + if (column_index < 0) + column_index = columns->Current; + return GetColumnOffsetFromNorm(columns, columns->Columns[column_index + 1].OffsetNorm - columns->Columns[column_index].OffsetNorm); +} + +void ImGui::SetColumnOffset(int column_index, float offset) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImGuiOldColumns* columns = window->DC.CurrentColumns; + IM_ASSERT(columns != NULL); + + if (column_index < 0) + column_index = columns->Current; + IM_ASSERT(column_index < columns->Columns.Size); + + const bool preserve_width = !(columns->Flags & ImGuiOldColumnFlags_NoPreserveWidths) && (column_index < columns->Count - 1); + const float width = preserve_width ? GetColumnWidthEx(columns, column_index, columns->IsBeingResized) : 0.0f; + + if (!(columns->Flags & ImGuiOldColumnFlags_NoForceWithinWindow)) + offset = ImMin(offset, columns->OffMaxX - g.Style.ColumnsMinSpacing * (columns->Count - column_index)); + columns->Columns[column_index].OffsetNorm = GetColumnNormFromOffset(columns, offset - columns->OffMinX); + + if (preserve_width) + SetColumnOffset(column_index + 1, offset + ImMax(g.Style.ColumnsMinSpacing, width)); +} + +void ImGui::SetColumnWidth(int column_index, float width) +{ + ImGuiWindow* window = GetCurrentWindowRead(); + ImGuiOldColumns* columns = window->DC.CurrentColumns; + IM_ASSERT(columns != NULL); + + if (column_index < 0) + column_index = columns->Current; + SetColumnOffset(column_index + 1, GetColumnOffset(column_index) + width); +} + +void ImGui::PushColumnClipRect(int column_index) +{ + ImGuiWindow* window = GetCurrentWindowRead(); + ImGuiOldColumns* columns = window->DC.CurrentColumns; + if (column_index < 0) + column_index = columns->Current; + + ImGuiOldColumnData* column = &columns->Columns[column_index]; + PushClipRect(column->ClipRect.Min, column->ClipRect.Max, false); +} + +// Get into the columns background draw command (which is generally the same draw command as before we called BeginColumns) +void ImGui::PushColumnsBackground() +{ + ImGuiWindow* window = GetCurrentWindowRead(); + ImGuiOldColumns* columns = window->DC.CurrentColumns; + if (columns->Count == 1) + return; + + // Optimization: avoid SetCurrentChannel() + PushClipRect() + columns->HostBackupClipRect = window->ClipRect; + SetWindowClipRectBeforeSetChannel(window, columns->HostInitialClipRect); + columns->Splitter.SetCurrentChannel(window->DrawList, 0); +} + +void ImGui::PopColumnsBackground() +{ + ImGuiWindow* window = GetCurrentWindowRead(); + ImGuiOldColumns* columns = window->DC.CurrentColumns; + if (columns->Count == 1) + return; + + // Optimization: avoid PopClipRect() + SetCurrentChannel() + SetWindowClipRectBeforeSetChannel(window, columns->HostBackupClipRect); + columns->Splitter.SetCurrentChannel(window->DrawList, columns->Current + 1); +} + +ImGuiOldColumns* ImGui::FindOrCreateColumns(ImGuiWindow* window, ImGuiID id) +{ + // We have few columns per window so for now we don't need bother much with turning this into a faster lookup. + for (int n = 0; n < window->ColumnsStorage.Size; n++) + if (window->ColumnsStorage[n].ID == id) + return &window->ColumnsStorage[n]; + + window->ColumnsStorage.push_back(ImGuiOldColumns()); + ImGuiOldColumns* columns = &window->ColumnsStorage.back(); + columns->ID = id; + return columns; +} + +ImGuiID ImGui::GetColumnsID(const char* str_id, int columns_count) +{ + ImGuiWindow* window = GetCurrentWindow(); + + // Differentiate column ID with an arbitrary prefix for cases where users name their columns set the same as another widget. + // In addition, when an identifier isn't explicitly provided we include the number of columns in the hash to make it uniquer. + PushID(0x11223347 + (str_id ? 0 : columns_count)); + ImGuiID id = window->GetID(str_id ? str_id : "columns"); + PopID(); + + return id; +} + +void ImGui::BeginColumns(const char* str_id, int columns_count, ImGuiOldColumnFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = GetCurrentWindow(); + + IM_ASSERT(columns_count >= 1); + IM_ASSERT(window->DC.CurrentColumns == NULL); // Nested columns are currently not supported + + // Acquire storage for the columns set + ImGuiID id = GetColumnsID(str_id, columns_count); + ImGuiOldColumns* columns = FindOrCreateColumns(window, id); + IM_ASSERT(columns->ID == id); + columns->Current = 0; + columns->Count = columns_count; + columns->Flags = flags; + window->DC.CurrentColumns = columns; + + columns->HostCursorPosY = window->DC.CursorPos.y; + columns->HostCursorMaxPosX = window->DC.CursorMaxPos.x; + columns->HostInitialClipRect = window->ClipRect; + columns->HostBackupParentWorkRect = window->ParentWorkRect; + window->ParentWorkRect = window->WorkRect; + + // Set state for first column + // We aim so that the right-most column will have the same clipping width as other after being clipped by parent ClipRect + const float column_padding = g.Style.ItemSpacing.x; + const float half_clip_extend_x = ImFloor(ImMax(window->WindowPadding.x * 0.5f, window->WindowBorderSize)); + const float max_1 = window->WorkRect.Max.x + column_padding - ImMax(column_padding - window->WindowPadding.x, 0.0f); + const float max_2 = window->WorkRect.Max.x + half_clip_extend_x; + columns->OffMinX = window->DC.Indent.x - column_padding + ImMax(column_padding - window->WindowPadding.x, 0.0f); + columns->OffMaxX = ImMax(ImMin(max_1, max_2) - window->Pos.x, columns->OffMinX + 1.0f); + columns->LineMinY = columns->LineMaxY = window->DC.CursorPos.y; + + // Clear data if columns count changed + if (columns->Columns.Size != 0 && columns->Columns.Size != columns_count + 1) + columns->Columns.resize(0); + + // Initialize default widths + columns->IsFirstFrame = (columns->Columns.Size == 0); + if (columns->Columns.Size == 0) + { + columns->Columns.reserve(columns_count + 1); + for (int n = 0; n < columns_count + 1; n++) + { + ImGuiOldColumnData column; + column.OffsetNorm = n / (float)columns_count; + columns->Columns.push_back(column); + } + } + + for (int n = 0; n < columns_count; n++) + { + // Compute clipping rectangle + ImGuiOldColumnData* column = &columns->Columns[n]; + float clip_x1 = IM_ROUND(window->Pos.x + GetColumnOffset(n)); + float clip_x2 = IM_ROUND(window->Pos.x + GetColumnOffset(n + 1) - 1.0f); + column->ClipRect = ImRect(clip_x1, -FLT_MAX, clip_x2, +FLT_MAX); + column->ClipRect.ClipWithFull(window->ClipRect); + } + + if (columns->Count > 1) + { + columns->Splitter.Split(window->DrawList, 1 + columns->Count); + columns->Splitter.SetCurrentChannel(window->DrawList, 1); + PushColumnClipRect(0); + } + + // We don't generally store Indent.x inside ColumnsOffset because it may be manipulated by the user. + float offset_0 = GetColumnOffset(columns->Current); + float offset_1 = GetColumnOffset(columns->Current + 1); + float width = offset_1 - offset_0; + PushItemWidth(width * 0.65f); + window->DC.ColumnsOffset.x = ImMax(column_padding - window->WindowPadding.x, 0.0f); + window->DC.CursorPos.x = IM_FLOOR(window->Pos.x + window->DC.Indent.x + window->DC.ColumnsOffset.x); + window->WorkRect.Max.x = window->Pos.x + offset_1 - column_padding; +} + +void ImGui::NextColumn() +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems || window->DC.CurrentColumns == NULL) + return; + + ImGuiContext& g = *GImGui; + ImGuiOldColumns* columns = window->DC.CurrentColumns; + + if (columns->Count == 1) + { + window->DC.CursorPos.x = IM_FLOOR(window->Pos.x + window->DC.Indent.x + window->DC.ColumnsOffset.x); + IM_ASSERT(columns->Current == 0); + return; + } + + // Next column + if (++columns->Current == columns->Count) + columns->Current = 0; + + PopItemWidth(); + + // Optimization: avoid PopClipRect() + SetCurrentChannel() + PushClipRect() + // (which would needlessly attempt to update commands in the wrong channel, then pop or overwrite them), + ImGuiOldColumnData* column = &columns->Columns[columns->Current]; + SetWindowClipRectBeforeSetChannel(window, column->ClipRect); + columns->Splitter.SetCurrentChannel(window->DrawList, columns->Current + 1); + + const float column_padding = g.Style.ItemSpacing.x; + columns->LineMaxY = ImMax(columns->LineMaxY, window->DC.CursorPos.y); + if (columns->Current > 0) + { + // Columns 1+ ignore IndentX (by canceling it out) + // FIXME-COLUMNS: Unnecessary, could be locked? + window->DC.ColumnsOffset.x = GetColumnOffset(columns->Current) - window->DC.Indent.x + column_padding; + } + else + { + // New row/line: column 0 honor IndentX. + window->DC.ColumnsOffset.x = ImMax(column_padding - window->WindowPadding.x, 0.0f); + columns->LineMinY = columns->LineMaxY; + } + window->DC.CursorPos.x = IM_FLOOR(window->Pos.x + window->DC.Indent.x + window->DC.ColumnsOffset.x); + window->DC.CursorPos.y = columns->LineMinY; + window->DC.CurrLineSize = ImVec2(0.0f, 0.0f); + window->DC.CurrLineTextBaseOffset = 0.0f; + + // FIXME-COLUMNS: Share code with BeginColumns() - move code on columns setup. + float offset_0 = GetColumnOffset(columns->Current); + float offset_1 = GetColumnOffset(columns->Current + 1); + float width = offset_1 - offset_0; + PushItemWidth(width * 0.65f); + window->WorkRect.Max.x = window->Pos.x + offset_1 - column_padding; +} + +void ImGui::EndColumns() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = GetCurrentWindow(); + ImGuiOldColumns* columns = window->DC.CurrentColumns; + IM_ASSERT(columns != NULL); + + PopItemWidth(); + if (columns->Count > 1) + { + PopClipRect(); + columns->Splitter.Merge(window->DrawList); + } + + const ImGuiOldColumnFlags flags = columns->Flags; + columns->LineMaxY = ImMax(columns->LineMaxY, window->DC.CursorPos.y); + window->DC.CursorPos.y = columns->LineMaxY; + if (!(flags & ImGuiOldColumnFlags_GrowParentContentsSize)) + window->DC.CursorMaxPos.x = columns->HostCursorMaxPosX; // Restore cursor max pos, as columns don't grow parent + + // Draw columns borders and handle resize + // The IsBeingResized flag ensure we preserve pre-resize columns width so back-and-forth are not lossy + bool is_being_resized = false; + if (!(flags & ImGuiOldColumnFlags_NoBorder) && !window->SkipItems) + { + // We clip Y boundaries CPU side because very long triangles are mishandled by some GPU drivers. + const float y1 = ImMax(columns->HostCursorPosY, window->ClipRect.Min.y); + const float y2 = ImMin(window->DC.CursorPos.y, window->ClipRect.Max.y); + int dragging_column = -1; + for (int n = 1; n < columns->Count; n++) + { + ImGuiOldColumnData* column = &columns->Columns[n]; + float x = window->Pos.x + GetColumnOffset(n); + const ImGuiID column_id = columns->ID + ImGuiID(n); + const float column_hit_hw = COLUMNS_HIT_RECT_HALF_WIDTH; + const ImRect column_hit_rect(ImVec2(x - column_hit_hw, y1), ImVec2(x + column_hit_hw, y2)); + KeepAliveID(column_id); + if (IsClippedEx(column_hit_rect, column_id)) // FIXME: Can be removed or replaced with a lower-level test + continue; + + bool hovered = false, held = false; + if (!(flags & ImGuiOldColumnFlags_NoResize)) + { + ButtonBehavior(column_hit_rect, column_id, &hovered, &held); + if (hovered || held) + g.MouseCursor = ImGuiMouseCursor_ResizeEW; + if (held && !(column->Flags & ImGuiOldColumnFlags_NoResize)) + dragging_column = n; + } + + // Draw column + const ImU32 col = GetColorU32(held ? ImGuiCol_SeparatorActive : hovered ? ImGuiCol_SeparatorHovered : ImGuiCol_Separator); + const float xi = IM_FLOOR(x); + window->DrawList->AddLine(ImVec2(xi, y1 + 1.0f), ImVec2(xi, y2), col); + } + + // Apply dragging after drawing the column lines, so our rendered lines are in sync with how items were displayed during the frame. + if (dragging_column != -1) + { + if (!columns->IsBeingResized) + for (int n = 0; n < columns->Count + 1; n++) + columns->Columns[n].OffsetNormBeforeResize = columns->Columns[n].OffsetNorm; + columns->IsBeingResized = is_being_resized = true; + float x = GetDraggedColumnOffset(columns, dragging_column); + SetColumnOffset(dragging_column, x); + } + } + columns->IsBeingResized = is_being_resized; + + window->WorkRect = window->ParentWorkRect; + window->ParentWorkRect = columns->HostBackupParentWorkRect; + window->DC.CurrentColumns = NULL; + window->DC.ColumnsOffset.x = 0.0f; + window->DC.CursorPos.x = IM_FLOOR(window->Pos.x + window->DC.Indent.x + window->DC.ColumnsOffset.x); +} + +void ImGui::Columns(int columns_count, const char* id, bool border) +{ + ImGuiWindow* window = GetCurrentWindow(); + IM_ASSERT(columns_count >= 1); + + ImGuiOldColumnFlags flags = (border ? 0 : ImGuiOldColumnFlags_NoBorder); + //flags |= ImGuiOldColumnFlags_NoPreserveWidths; // NB: Legacy behavior + ImGuiOldColumns* columns = window->DC.CurrentColumns; + if (columns != NULL && columns->Count == columns_count && columns->Flags == flags) + return; + + if (columns != NULL) + EndColumns(); + + if (columns_count != 1) + BeginColumns(id, columns_count, flags); +} + +//------------------------------------------------------------------------- + +#endif // #ifndef IMGUI_DISABLE diff --git a/source/editor/imgui/imgui_widgets.cpp b/source/editor/imgui/imgui_widgets.cpp new file mode 100644 index 0000000..3aef1a4 --- /dev/null +++ b/source/editor/imgui/imgui_widgets.cpp @@ -0,0 +1,8200 @@ +// dear imgui, v1.85 WIP +// (widgets code) + +/* + +Index of this file: + +// [SECTION] Forward Declarations +// [SECTION] Widgets: Text, etc. +// [SECTION] Widgets: Main (Button, Image, Checkbox, RadioButton, ProgressBar, Bullet, etc.) +// [SECTION] Widgets: Low-level Layout helpers (Spacing, Dummy, NewLine, Separator, etc.) +// [SECTION] Widgets: ComboBox +// [SECTION] Data Type and Data Formatting Helpers +// [SECTION] Widgets: DragScalar, DragFloat, DragInt, etc. +// [SECTION] Widgets: SliderScalar, SliderFloat, SliderInt, etc. +// [SECTION] Widgets: InputScalar, InputFloat, InputInt, etc. +// [SECTION] Widgets: InputText, InputTextMultiline +// [SECTION] Widgets: ColorEdit, ColorPicker, ColorButton, etc. +// [SECTION] Widgets: TreeNode, CollapsingHeader, etc. +// [SECTION] Widgets: Selectable +// [SECTION] Widgets: ListBox +// [SECTION] Widgets: PlotLines, PlotHistogram +// [SECTION] Widgets: Value helpers +// [SECTION] Widgets: MenuItem, BeginMenu, EndMenu, etc. +// [SECTION] Widgets: BeginTabBar, EndTabBar, etc. +// [SECTION] Widgets: BeginTabItem, EndTabItem, etc. +// [SECTION] Widgets: Columns, BeginColumns, EndColumns, etc. + +*/ + +#if defined(_MSC_VER) && !defined(_CRT_SECURE_NO_WARNINGS) +#define _CRT_SECURE_NO_WARNINGS +#endif + +#include "imgui.h" +#ifndef IMGUI_DISABLE + +#ifndef IMGUI_DEFINE_MATH_OPERATORS +#define IMGUI_DEFINE_MATH_OPERATORS +#endif +#include "imgui_internal.h" + +// System includes +#include // toupper +#if defined(_MSC_VER) && _MSC_VER <= 1500 // MSVC 2008 or earlier +#include // intptr_t +#else +#include // intptr_t +#endif + +//------------------------------------------------------------------------- +// Warnings +//------------------------------------------------------------------------- + +// Visual Studio warnings +#ifdef _MSC_VER +#pragma warning (disable: 4127) // condition expression is constant +#pragma warning (disable: 4996) // 'This function or variable may be unsafe': strcpy, strdup, sprintf, vsnprintf, sscanf, fopen +#if defined(_MSC_VER) && _MSC_VER >= 1922 // MSVC 2019 16.2 or later +#pragma warning (disable: 5054) // operator '|': deprecated between enumerations of different types +#endif +#pragma warning (disable: 26451) // [Static Analyzer] Arithmetic overflow : Using operator 'xxx' on a 4 byte value and then casting the result to a 8 byte value. Cast the value to the wider type before calling operator 'xxx' to avoid overflow(io.2). +#pragma warning (disable: 26812) // [Static Analyzer] The enum type 'xxx' is unscoped. Prefer 'enum class' over 'enum' (Enum.3). +#endif + +// Clang/GCC warnings with -Weverything +#if defined(__clang__) +#if __has_warning("-Wunknown-warning-option") +#pragma clang diagnostic ignored "-Wunknown-warning-option" // warning: unknown warning group 'xxx' // not all warnings are known by all Clang versions and they tend to be rename-happy.. so ignoring warnings triggers new warnings on some configuration. Great! +#endif +#pragma clang diagnostic ignored "-Wunknown-pragmas" // warning: unknown warning group 'xxx' +#pragma clang diagnostic ignored "-Wold-style-cast" // warning: use of old-style cast // yes, they are more terse. +#pragma clang diagnostic ignored "-Wfloat-equal" // warning: comparing floating point with == or != is unsafe // storing and comparing against same constants (typically 0.0f) is ok. +#pragma clang diagnostic ignored "-Wformat-nonliteral" // warning: format string is not a string literal // passing non-literal to vsnformat(). yes, user passing incorrect format strings can crash the code. +#pragma clang diagnostic ignored "-Wsign-conversion" // warning: implicit conversion changes signedness +#pragma clang diagnostic ignored "-Wzero-as-null-pointer-constant" // warning: zero as null pointer constant // some standard header variations use #define NULL 0 +#pragma clang diagnostic ignored "-Wdouble-promotion" // warning: implicit conversion from 'float' to 'double' when passing argument to function // using printf() is a misery with this as C++ va_arg ellipsis changes float to double. +#pragma clang diagnostic ignored "-Wenum-enum-conversion" // warning: bitwise operation between different enumeration types ('XXXFlags_' and 'XXXFlagsPrivate_') +#pragma clang diagnostic ignored "-Wdeprecated-enum-enum-conversion"// warning: bitwise operation between different enumeration types ('XXXFlags_' and 'XXXFlagsPrivate_') is deprecated +#pragma clang diagnostic ignored "-Wimplicit-int-float-conversion" // warning: implicit conversion from 'xxx' to 'float' may lose precision +#elif defined(__GNUC__) +#pragma GCC diagnostic ignored "-Wpragmas" // warning: unknown option after '#pragma GCC diagnostic' kind +#pragma GCC diagnostic ignored "-Wformat-nonliteral" // warning: format not a string literal, format string not checked +#pragma GCC diagnostic ignored "-Wclass-memaccess" // [__GNUC__ >= 8] warning: 'memset/memcpy' clearing/writing an object of type 'xxxx' with no trivial copy-assignment; use assignment or value-initialization instead +#endif + +//------------------------------------------------------------------------- +// Data +//------------------------------------------------------------------------- + +// Widgets +static const float DRAGDROP_HOLD_TO_OPEN_TIMER = 0.70f; // Time for drag-hold to activate items accepting the ImGuiButtonFlags_PressedOnDragDropHold button behavior. +static const float DRAG_MOUSE_THRESHOLD_FACTOR = 0.50f; // Multiplier for the default value of io.MouseDragThreshold to make DragFloat/DragInt react faster to mouse drags. + +// Those MIN/MAX values are not define because we need to point to them +static const signed char IM_S8_MIN = -128; +static const signed char IM_S8_MAX = 127; +static const unsigned char IM_U8_MIN = 0; +static const unsigned char IM_U8_MAX = 0xFF; +static const signed short IM_S16_MIN = -32768; +static const signed short IM_S16_MAX = 32767; +static const unsigned short IM_U16_MIN = 0; +static const unsigned short IM_U16_MAX = 0xFFFF; +static const ImS32 IM_S32_MIN = INT_MIN; // (-2147483647 - 1), (0x80000000); +static const ImS32 IM_S32_MAX = INT_MAX; // (2147483647), (0x7FFFFFFF) +static const ImU32 IM_U32_MIN = 0; +static const ImU32 IM_U32_MAX = UINT_MAX; // (0xFFFFFFFF) +#ifdef LLONG_MIN +static const ImS64 IM_S64_MIN = LLONG_MIN; // (-9223372036854775807ll - 1ll); +static const ImS64 IM_S64_MAX = LLONG_MAX; // (9223372036854775807ll); +#else +static const ImS64 IM_S64_MIN = -9223372036854775807LL - 1; +static const ImS64 IM_S64_MAX = 9223372036854775807LL; +#endif +static const ImU64 IM_U64_MIN = 0; +#ifdef ULLONG_MAX +static const ImU64 IM_U64_MAX = ULLONG_MAX; // (0xFFFFFFFFFFFFFFFFull); +#else +static const ImU64 IM_U64_MAX = (2ULL * 9223372036854775807LL + 1); +#endif + +//------------------------------------------------------------------------- +// [SECTION] Forward Declarations +//------------------------------------------------------------------------- + +// For InputTextEx() +static bool InputTextFilterCharacter(unsigned int* p_char, ImGuiInputTextFlags flags, ImGuiInputTextCallback callback, void* user_data, ImGuiInputSource input_source); +static int InputTextCalcTextLenAndLineCount(const char* text_begin, const char** out_text_end); +static ImVec2 InputTextCalcTextSizeW(const ImWchar* text_begin, const ImWchar* text_end, const ImWchar** remaining = NULL, ImVec2* out_offset = NULL, bool stop_on_new_line = false); + +//------------------------------------------------------------------------- +// [SECTION] Widgets: Text, etc. +//------------------------------------------------------------------------- +// - TextEx() [Internal] +// - TextUnformatted() +// - Text() +// - TextV() +// - TextColored() +// - TextColoredV() +// - TextDisabled() +// - TextDisabledV() +// - TextWrapped() +// - TextWrappedV() +// - LabelText() +// - LabelTextV() +// - BulletText() +// - BulletTextV() +//------------------------------------------------------------------------- + +void ImGui::TextEx(const char* text, const char* text_end, ImGuiTextFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + ImGuiContext& g = *GImGui; + + // Accept null ranges + if (text == text_end) + text = text_end = ""; + + // Calculate length + const char* text_begin = text; + if (text_end == NULL) + text_end = text + strlen(text); // FIXME-OPT + + const ImVec2 text_pos(window->DC.CursorPos.x, window->DC.CursorPos.y + window->DC.CurrLineTextBaseOffset); + const float wrap_pos_x = window->DC.TextWrapPos; + const bool wrap_enabled = (wrap_pos_x >= 0.0f); + if (text_end - text > 2000 && !wrap_enabled) + { + // Long text! + // Perform manual coarse clipping to optimize for long multi-line text + // - From this point we will only compute the width of lines that are visible. Optimization only available when word-wrapping is disabled. + // - We also don't vertically center the text within the line full height, which is unlikely to matter because we are likely the biggest and only item on the line. + // - We use memchr(), pay attention that well optimized versions of those str/mem functions are much faster than a casually written loop. + const char* line = text; + const float line_height = GetTextLineHeight(); + ImVec2 text_size(0, 0); + + // Lines to skip (can't skip when logging text) + ImVec2 pos = text_pos; + if (!g.LogEnabled) + { + int lines_skippable = (int)((window->ClipRect.Min.y - text_pos.y) / line_height); + if (lines_skippable > 0) + { + int lines_skipped = 0; + while (line < text_end && lines_skipped < lines_skippable) + { + const char* line_end = (const char*)memchr(line, '\n', text_end - line); + if (!line_end) + line_end = text_end; + if ((flags & ImGuiTextFlags_NoWidthForLargeClippedText) == 0) + text_size.x = ImMax(text_size.x, CalcTextSize(line, line_end).x); + line = line_end + 1; + lines_skipped++; + } + pos.y += lines_skipped * line_height; + } + } + + // Lines to render + if (line < text_end) + { + ImRect line_rect(pos, pos + ImVec2(FLT_MAX, line_height)); + while (line < text_end) + { + if (IsClippedEx(line_rect, 0)) + break; + + const char* line_end = (const char*)memchr(line, '\n', text_end - line); + if (!line_end) + line_end = text_end; + text_size.x = ImMax(text_size.x, CalcTextSize(line, line_end).x); + RenderText(pos, line, line_end, false); + line = line_end + 1; + line_rect.Min.y += line_height; + line_rect.Max.y += line_height; + pos.y += line_height; + } + + // Count remaining lines + int lines_skipped = 0; + while (line < text_end) + { + const char* line_end = (const char*)memchr(line, '\n', text_end - line); + if (!line_end) + line_end = text_end; + if ((flags & ImGuiTextFlags_NoWidthForLargeClippedText) == 0) + text_size.x = ImMax(text_size.x, CalcTextSize(line, line_end).x); + line = line_end + 1; + lines_skipped++; + } + pos.y += lines_skipped * line_height; + } + text_size.y = (pos - text_pos).y; + + ImRect bb(text_pos, text_pos + text_size); + ItemSize(text_size, 0.0f); + ItemAdd(bb, 0); + } + else + { + const float wrap_width = wrap_enabled ? CalcWrapWidthForPos(window->DC.CursorPos, wrap_pos_x) : 0.0f; + const ImVec2 text_size = CalcTextSize(text_begin, text_end, false, wrap_width); + + ImRect bb(text_pos, text_pos + text_size); + ItemSize(text_size, 0.0f); + if (!ItemAdd(bb, 0)) + return; + + // Render (we don't hide text after ## in this end-user function) + RenderTextWrapped(bb.Min, text_begin, text_end, wrap_width); + } +} + +void ImGui::TextUnformatted(const char* text, const char* text_end) +{ + TextEx(text, text_end, ImGuiTextFlags_NoWidthForLargeClippedText); +} + +void ImGui::Text(const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); + TextV(fmt, args); + va_end(args); +} + +void ImGui::TextV(const char* fmt, va_list args) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + + // FIXME-OPT: Handle the %s shortcut? + ImGuiContext& g = *GImGui; + const char* text_end = g.TempBuffer + ImFormatStringV(g.TempBuffer, IM_ARRAYSIZE(g.TempBuffer), fmt, args); + TextEx(g.TempBuffer, text_end, ImGuiTextFlags_NoWidthForLargeClippedText); +} + +void ImGui::TextColored(const ImVec4& col, const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); + TextColoredV(col, fmt, args); + va_end(args); +} + +void ImGui::TextColoredV(const ImVec4& col, const char* fmt, va_list args) +{ + PushStyleColor(ImGuiCol_Text, col); + if (fmt[0] == '%' && fmt[1] == 's' && fmt[2] == 0) + TextEx(va_arg(args, const char*), NULL, ImGuiTextFlags_NoWidthForLargeClippedText); // Skip formatting + else + TextV(fmt, args); + PopStyleColor(); +} + +void ImGui::TextDisabled(const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); + TextDisabledV(fmt, args); + va_end(args); +} + +void ImGui::TextDisabledV(const char* fmt, va_list args) +{ + ImGuiContext& g = *GImGui; + PushStyleColor(ImGuiCol_Text, g.Style.Colors[ImGuiCol_TextDisabled]); + if (fmt[0] == '%' && fmt[1] == 's' && fmt[2] == 0) + TextEx(va_arg(args, const char*), NULL, ImGuiTextFlags_NoWidthForLargeClippedText); // Skip formatting + else + TextV(fmt, args); + PopStyleColor(); +} + +void ImGui::TextWrapped(const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); + TextWrappedV(fmt, args); + va_end(args); +} + +void ImGui::TextWrappedV(const char* fmt, va_list args) +{ + ImGuiContext& g = *GImGui; + bool need_backup = (g.CurrentWindow->DC.TextWrapPos < 0.0f); // Keep existing wrap position if one is already set + if (need_backup) + PushTextWrapPos(0.0f); + if (fmt[0] == '%' && fmt[1] == 's' && fmt[2] == 0) + TextEx(va_arg(args, const char*), NULL, ImGuiTextFlags_NoWidthForLargeClippedText); // Skip formatting + else + TextV(fmt, args); + if (need_backup) + PopTextWrapPos(); +} + +void ImGui::LabelText(const char* label, const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); + LabelTextV(label, fmt, args); + va_end(args); +} + +// Add a label+text combo aligned to other label+value widgets +void ImGui::LabelTextV(const char* label, const char* fmt, va_list args) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + const float w = CalcItemWidth(); + + const char* value_text_begin = &g.TempBuffer[0]; + const char* value_text_end = value_text_begin + ImFormatStringV(g.TempBuffer, IM_ARRAYSIZE(g.TempBuffer), fmt, args); + const ImVec2 value_size = CalcTextSize(value_text_begin, value_text_end, false); + const ImVec2 label_size = CalcTextSize(label, NULL, true); + + const ImVec2 pos = window->DC.CursorPos; + const ImRect value_bb(pos, pos + ImVec2(w, value_size.y + style.FramePadding.y * 2)); + const ImRect total_bb(pos, pos + ImVec2(w + (label_size.x > 0.0f ? style.ItemInnerSpacing.x + label_size.x : 0.0f), ImMax(value_size.y, label_size.y) + style.FramePadding.y * 2)); + ItemSize(total_bb, style.FramePadding.y); + if (!ItemAdd(total_bb, 0)) + return; + + // Render + RenderTextClipped(value_bb.Min + style.FramePadding, value_bb.Max, value_text_begin, value_text_end, &value_size, ImVec2(0.0f, 0.0f)); + if (label_size.x > 0.0f) + RenderText(ImVec2(value_bb.Max.x + style.ItemInnerSpacing.x, value_bb.Min.y + style.FramePadding.y), label); +} + +void ImGui::BulletText(const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); + BulletTextV(fmt, args); + va_end(args); +} + +// Text with a little bullet aligned to the typical tree node. +void ImGui::BulletTextV(const char* fmt, va_list args) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + + const char* text_begin = g.TempBuffer; + const char* text_end = text_begin + ImFormatStringV(g.TempBuffer, IM_ARRAYSIZE(g.TempBuffer), fmt, args); + const ImVec2 label_size = CalcTextSize(text_begin, text_end, false); + const ImVec2 total_size = ImVec2(g.FontSize + (label_size.x > 0.0f ? (label_size.x + style.FramePadding.x * 2) : 0.0f), label_size.y); // Empty text doesn't add padding + ImVec2 pos = window->DC.CursorPos; + pos.y += window->DC.CurrLineTextBaseOffset; + ItemSize(total_size, 0.0f); + const ImRect bb(pos, pos + total_size); + if (!ItemAdd(bb, 0)) + return; + + // Render + ImU32 text_col = GetColorU32(ImGuiCol_Text); + RenderBullet(window->DrawList, bb.Min + ImVec2(style.FramePadding.x + g.FontSize * 0.5f, g.FontSize * 0.5f), text_col); + RenderText(bb.Min + ImVec2(g.FontSize + style.FramePadding.x * 2, 0.0f), text_begin, text_end, false); +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: Main +//------------------------------------------------------------------------- +// - ButtonBehavior() [Internal] +// - Button() +// - SmallButton() +// - InvisibleButton() +// - ArrowButton() +// - CloseButton() [Internal] +// - CollapseButton() [Internal] +// - GetWindowScrollbarID() [Internal] +// - GetWindowScrollbarRect() [Internal] +// - Scrollbar() [Internal] +// - ScrollbarEx() [Internal] +// - Image() +// - ImageButton() +// - Checkbox() +// - CheckboxFlagsT() [Internal] +// - CheckboxFlags() +// - RadioButton() +// - ProgressBar() +// - Bullet() +//------------------------------------------------------------------------- + +// The ButtonBehavior() function is key to many interactions and used by many/most widgets. +// Because we handle so many cases (keyboard/gamepad navigation, drag and drop) and many specific behavior (via ImGuiButtonFlags_), +// this code is a little complex. +// By far the most common path is interacting with the Mouse using the default ImGuiButtonFlags_PressedOnClickRelease button behavior. +// See the series of events below and the corresponding state reported by dear imgui: +//------------------------------------------------------------------------------------------------------------------------------------------------ +// with PressedOnClickRelease: return-value IsItemHovered() IsItemActive() IsItemActivated() IsItemDeactivated() IsItemClicked() +// Frame N+0 (mouse is outside bb) - - - - - - +// Frame N+1 (mouse moves inside bb) - true - - - - +// Frame N+2 (mouse button is down) - true true true - true +// Frame N+3 (mouse button is down) - true true - - - +// Frame N+4 (mouse moves outside bb) - - true - - - +// Frame N+5 (mouse moves inside bb) - true true - - - +// Frame N+6 (mouse button is released) true true - - true - +// Frame N+7 (mouse button is released) - true - - - - +// Frame N+8 (mouse moves outside bb) - - - - - - +//------------------------------------------------------------------------------------------------------------------------------------------------ +// with PressedOnClick: return-value IsItemHovered() IsItemActive() IsItemActivated() IsItemDeactivated() IsItemClicked() +// Frame N+2 (mouse button is down) true true true true - true +// Frame N+3 (mouse button is down) - true true - - - +// Frame N+6 (mouse button is released) - true - - true - +// Frame N+7 (mouse button is released) - true - - - - +//------------------------------------------------------------------------------------------------------------------------------------------------ +// with PressedOnRelease: return-value IsItemHovered() IsItemActive() IsItemActivated() IsItemDeactivated() IsItemClicked() +// Frame N+2 (mouse button is down) - true - - - true +// Frame N+3 (mouse button is down) - true - - - - +// Frame N+6 (mouse button is released) true true - - - - +// Frame N+7 (mouse button is released) - true - - - - +//------------------------------------------------------------------------------------------------------------------------------------------------ +// with PressedOnDoubleClick: return-value IsItemHovered() IsItemActive() IsItemActivated() IsItemDeactivated() IsItemClicked() +// Frame N+0 (mouse button is down) - true - - - true +// Frame N+1 (mouse button is down) - true - - - - +// Frame N+2 (mouse button is released) - true - - - - +// Frame N+3 (mouse button is released) - true - - - - +// Frame N+4 (mouse button is down) true true true true - true +// Frame N+5 (mouse button is down) - true true - - - +// Frame N+6 (mouse button is released) - true - - true - +// Frame N+7 (mouse button is released) - true - - - - +//------------------------------------------------------------------------------------------------------------------------------------------------ +// Note that some combinations are supported, +// - PressedOnDragDropHold can generally be associated with any flag. +// - PressedOnDoubleClick can be associated by PressedOnClickRelease/PressedOnRelease, in which case the second release event won't be reported. +//------------------------------------------------------------------------------------------------------------------------------------------------ +// The behavior of the return-value changes when ImGuiButtonFlags_Repeat is set: +// Repeat+ Repeat+ Repeat+ Repeat+ +// PressedOnClickRelease PressedOnClick PressedOnRelease PressedOnDoubleClick +//------------------------------------------------------------------------------------------------------------------------------------------------- +// Frame N+0 (mouse button is down) - true - true +// ... - - - - +// Frame N + RepeatDelay true true - true +// ... - - - - +// Frame N + RepeatDelay + RepeatRate*N true true - true +//------------------------------------------------------------------------------------------------------------------------------------------------- + +bool ImGui::ButtonBehavior(const ImRect& bb, ImGuiID id, bool* out_hovered, bool* out_held, ImGuiButtonFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = GetCurrentWindow(); + + // Default only reacts to left mouse button + if ((flags & ImGuiButtonFlags_MouseButtonMask_) == 0) + flags |= ImGuiButtonFlags_MouseButtonDefault_; + + // Default behavior requires click + release inside bounding box + if ((flags & ImGuiButtonFlags_PressedOnMask_) == 0) + flags |= ImGuiButtonFlags_PressedOnDefault_; + + ImGuiWindow* backup_hovered_window = g.HoveredWindow; + const bool flatten_hovered_children = (flags & ImGuiButtonFlags_FlattenChildren) && g.HoveredWindow && g.HoveredWindow->RootWindow == window; + if (flatten_hovered_children) + g.HoveredWindow = window; + +#ifdef IMGUI_ENABLE_TEST_ENGINE + if (id != 0 && g.LastItemData.ID != id) + IMGUI_TEST_ENGINE_ITEM_ADD(bb, id); +#endif + + bool pressed = false; + bool hovered = ItemHoverable(bb, id); + + // Drag source doesn't report as hovered + if (hovered && g.DragDropActive && g.DragDropPayload.SourceId == id && !(g.DragDropSourceFlags & ImGuiDragDropFlags_SourceNoDisableHover)) + hovered = false; + + // Special mode for Drag and Drop where holding button pressed for a long time while dragging another item triggers the button + if (g.DragDropActive && (flags & ImGuiButtonFlags_PressedOnDragDropHold) && !(g.DragDropSourceFlags & ImGuiDragDropFlags_SourceNoHoldToOpenOthers)) + if (IsItemHovered(ImGuiHoveredFlags_AllowWhenBlockedByActiveItem)) + { + hovered = true; + SetHoveredID(id); + if (g.HoveredIdTimer - g.IO.DeltaTime <= DRAGDROP_HOLD_TO_OPEN_TIMER && g.HoveredIdTimer >= DRAGDROP_HOLD_TO_OPEN_TIMER) + { + pressed = true; + g.DragDropHoldJustPressedId = id; + FocusWindow(window); + } + } + + if (flatten_hovered_children) + g.HoveredWindow = backup_hovered_window; + + // AllowOverlap mode (rarely used) requires previous frame HoveredId to be null or to match. This allows using patterns where a later submitted widget overlaps a previous one. + if (hovered && (flags & ImGuiButtonFlags_AllowItemOverlap) && (g.HoveredIdPreviousFrame != id && g.HoveredIdPreviousFrame != 0)) + hovered = false; + + // Mouse handling + if (hovered) + { + if (!(flags & ImGuiButtonFlags_NoKeyModifiers) || (!g.IO.KeyCtrl && !g.IO.KeyShift && !g.IO.KeyAlt)) + { + // Poll buttons + int mouse_button_clicked = -1; + int mouse_button_released = -1; + if ((flags & ImGuiButtonFlags_MouseButtonLeft) && g.IO.MouseClicked[0]) { mouse_button_clicked = 0; } + else if ((flags & ImGuiButtonFlags_MouseButtonRight) && g.IO.MouseClicked[1]) { mouse_button_clicked = 1; } + else if ((flags & ImGuiButtonFlags_MouseButtonMiddle) && g.IO.MouseClicked[2]) { mouse_button_clicked = 2; } + if ((flags & ImGuiButtonFlags_MouseButtonLeft) && g.IO.MouseReleased[0]) { mouse_button_released = 0; } + else if ((flags & ImGuiButtonFlags_MouseButtonRight) && g.IO.MouseReleased[1]) { mouse_button_released = 1; } + else if ((flags & ImGuiButtonFlags_MouseButtonMiddle) && g.IO.MouseReleased[2]) { mouse_button_released = 2; } + + if (mouse_button_clicked != -1 && g.ActiveId != id) + { + if (flags & (ImGuiButtonFlags_PressedOnClickRelease | ImGuiButtonFlags_PressedOnClickReleaseAnywhere)) + { + SetActiveID(id, window); + g.ActiveIdMouseButton = mouse_button_clicked; + if (!(flags & ImGuiButtonFlags_NoNavFocus)) + SetFocusID(id, window); + FocusWindow(window); + } + if ((flags & ImGuiButtonFlags_PressedOnClick) || ((flags & ImGuiButtonFlags_PressedOnDoubleClick) && g.IO.MouseDoubleClicked[mouse_button_clicked])) + { + pressed = true; + if (flags & ImGuiButtonFlags_NoHoldingActiveId) + ClearActiveID(); + else + SetActiveID(id, window); // Hold on ID + if (!(flags & ImGuiButtonFlags_NoNavFocus)) + SetFocusID(id, window); + g.ActiveIdMouseButton = mouse_button_clicked; + FocusWindow(window); + } + } + if ((flags & ImGuiButtonFlags_PressedOnRelease) && mouse_button_released != -1) + { + // Repeat mode trumps on release behavior + const bool has_repeated_at_least_once = (flags & ImGuiButtonFlags_Repeat) && g.IO.MouseDownDurationPrev[mouse_button_released] >= g.IO.KeyRepeatDelay; + if (!has_repeated_at_least_once) + pressed = true; + if (!(flags & ImGuiButtonFlags_NoNavFocus)) + SetFocusID(id, window); + ClearActiveID(); + } + + // 'Repeat' mode acts when held regardless of _PressedOn flags (see table above). + // Relies on repeat logic of IsMouseClicked() but we may as well do it ourselves if we end up exposing finer RepeatDelay/RepeatRate settings. + if (g.ActiveId == id && (flags & ImGuiButtonFlags_Repeat)) + if (g.IO.MouseDownDuration[g.ActiveIdMouseButton] > 0.0f && IsMouseClicked(g.ActiveIdMouseButton, true)) + pressed = true; + } + + if (pressed) + g.NavDisableHighlight = true; + } + + // Gamepad/Keyboard navigation + // We report navigated item as hovered but we don't set g.HoveredId to not interfere with mouse. + if (g.NavId == id && !g.NavDisableHighlight && g.NavDisableMouseHover && (g.ActiveId == 0 || g.ActiveId == id || g.ActiveId == window->MoveId)) + if (!(flags & ImGuiButtonFlags_NoHoveredOnFocus)) + hovered = true; + if (g.NavActivateDownId == id) + { + bool nav_activated_by_code = (g.NavActivateId == id); + bool nav_activated_by_inputs = IsNavInputTest(ImGuiNavInput_Activate, (flags & ImGuiButtonFlags_Repeat) ? ImGuiInputReadMode_Repeat : ImGuiInputReadMode_Pressed); + if (nav_activated_by_code || nav_activated_by_inputs) + { + // Set active id so it can be queried by user via IsItemActive(), equivalent of holding the mouse button. + pressed = true; + SetActiveID(id, window); + g.ActiveIdSource = ImGuiInputSource_Nav; + if (!(flags & ImGuiButtonFlags_NoNavFocus)) + SetFocusID(id, window); + } + } + + // Process while held + bool held = false; + if (g.ActiveId == id) + { + if (g.ActiveIdSource == ImGuiInputSource_Mouse) + { + if (g.ActiveIdIsJustActivated) + g.ActiveIdClickOffset = g.IO.MousePos - bb.Min; + + const int mouse_button = g.ActiveIdMouseButton; + IM_ASSERT(mouse_button >= 0 && mouse_button < ImGuiMouseButton_COUNT); + if (g.IO.MouseDown[mouse_button]) + { + held = true; + } + else + { + bool release_in = hovered && (flags & ImGuiButtonFlags_PressedOnClickRelease) != 0; + bool release_anywhere = (flags & ImGuiButtonFlags_PressedOnClickReleaseAnywhere) != 0; + if ((release_in || release_anywhere) && !g.DragDropActive) + { + // Report as pressed when releasing the mouse (this is the most common path) + bool is_double_click_release = (flags & ImGuiButtonFlags_PressedOnDoubleClick) && g.IO.MouseDownWasDoubleClick[mouse_button]; + bool is_repeating_already = (flags & ImGuiButtonFlags_Repeat) && g.IO.MouseDownDurationPrev[mouse_button] >= g.IO.KeyRepeatDelay; // Repeat mode trumps + if (!is_double_click_release && !is_repeating_already) + pressed = true; + } + ClearActiveID(); + } + if (!(flags & ImGuiButtonFlags_NoNavFocus)) + g.NavDisableHighlight = true; + } + else if (g.ActiveIdSource == ImGuiInputSource_Nav) + { + // When activated using Nav, we hold on the ActiveID until activation button is released + if (g.NavActivateDownId != id) + ClearActiveID(); + } + if (pressed) + g.ActiveIdHasBeenPressedBefore = true; + } + + if (out_hovered) *out_hovered = hovered; + if (out_held) *out_held = held; + + return pressed; +} + +bool ImGui::ButtonEx(const char* label, const ImVec2& size_arg, ImGuiButtonFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + const ImGuiID id = window->GetID(label); + const ImVec2 label_size = CalcTextSize(label, NULL, true); + + ImVec2 pos = window->DC.CursorPos; + if ((flags & ImGuiButtonFlags_AlignTextBaseLine) && style.FramePadding.y < window->DC.CurrLineTextBaseOffset) // Try to vertically align buttons that are smaller/have no padding so that text baseline matches (bit hacky, since it shouldn't be a flag) + pos.y += window->DC.CurrLineTextBaseOffset - style.FramePadding.y; + ImVec2 size = CalcItemSize(size_arg, label_size.x + style.FramePadding.x * 2.0f, label_size.y + style.FramePadding.y * 2.0f); + + const ImRect bb(pos, pos + size); + ItemSize(size, style.FramePadding.y); + if (!ItemAdd(bb, id)) + return false; + + if (g.LastItemData.InFlags & ImGuiItemFlags_ButtonRepeat) + flags |= ImGuiButtonFlags_Repeat; + + bool hovered, held; + bool pressed = ButtonBehavior(bb, id, &hovered, &held, flags); + + // Render + const ImU32 col = GetColorU32((held && hovered) ? ImGuiCol_ButtonActive : hovered ? ImGuiCol_ButtonHovered : ImGuiCol_Button); + RenderNavHighlight(bb, id); + RenderFrame(bb.Min, bb.Max, col, true, style.FrameRounding); + + if (g.LogEnabled) + LogSetNextTextDecoration("[", "]"); + RenderTextClipped(bb.Min + style.FramePadding, bb.Max - style.FramePadding, label, NULL, &label_size, style.ButtonTextAlign, &bb); + + // Automatically close popups + //if (pressed && !(flags & ImGuiButtonFlags_DontClosePopups) && (window->Flags & ImGuiWindowFlags_Popup)) + // CloseCurrentPopup(); + + IMGUI_TEST_ENGINE_ITEM_INFO(id, label, g.LastItemData.StatusFlags); + return pressed; +} + +bool ImGui::Button(const char* label, const ImVec2& size_arg) +{ + return ButtonEx(label, size_arg, ImGuiButtonFlags_None); +} + +// Small buttons fits within text without additional vertical spacing. +bool ImGui::SmallButton(const char* label) +{ + ImGuiContext& g = *GImGui; + float backup_padding_y = g.Style.FramePadding.y; + g.Style.FramePadding.y = 0.0f; + bool pressed = ButtonEx(label, ImVec2(0, 0), ImGuiButtonFlags_AlignTextBaseLine); + g.Style.FramePadding.y = backup_padding_y; + return pressed; +} + +// Tip: use ImGui::PushID()/PopID() to push indices or pointers in the ID stack. +// Then you can keep 'str_id' empty or the same for all your buttons (instead of creating a string based on a non-string id) +bool ImGui::InvisibleButton(const char* str_id, const ImVec2& size_arg, ImGuiButtonFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + // Cannot use zero-size for InvisibleButton(). Unlike Button() there is not way to fallback using the label size. + IM_ASSERT(size_arg.x != 0.0f && size_arg.y != 0.0f); + + const ImGuiID id = window->GetID(str_id); + ImVec2 size = CalcItemSize(size_arg, 0.0f, 0.0f); + const ImRect bb(window->DC.CursorPos, window->DC.CursorPos + size); + ItemSize(size); + if (!ItemAdd(bb, id)) + return false; + + bool hovered, held; + bool pressed = ButtonBehavior(bb, id, &hovered, &held, flags); + + return pressed; +} + +bool ImGui::ArrowButtonEx(const char* str_id, ImGuiDir dir, ImVec2 size, ImGuiButtonFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const ImGuiID id = window->GetID(str_id); + const ImRect bb(window->DC.CursorPos, window->DC.CursorPos + size); + const float default_size = GetFrameHeight(); + ItemSize(size, (size.y >= default_size) ? g.Style.FramePadding.y : -1.0f); + if (!ItemAdd(bb, id)) + return false; + + if (g.LastItemData.InFlags & ImGuiItemFlags_ButtonRepeat) + flags |= ImGuiButtonFlags_Repeat; + + bool hovered, held; + bool pressed = ButtonBehavior(bb, id, &hovered, &held, flags); + + // Render + const ImU32 bg_col = GetColorU32((held && hovered) ? ImGuiCol_ButtonActive : hovered ? ImGuiCol_ButtonHovered : ImGuiCol_Button); + const ImU32 text_col = GetColorU32(ImGuiCol_Text); + RenderNavHighlight(bb, id); + RenderFrame(bb.Min, bb.Max, bg_col, true, g.Style.FrameRounding); + RenderArrow(window->DrawList, bb.Min + ImVec2(ImMax(0.0f, (size.x - g.FontSize) * 0.5f), ImMax(0.0f, (size.y - g.FontSize) * 0.5f)), text_col, dir); + + return pressed; +} + +bool ImGui::ArrowButton(const char* str_id, ImGuiDir dir) +{ + float sz = GetFrameHeight(); + return ArrowButtonEx(str_id, dir, ImVec2(sz, sz), ImGuiButtonFlags_None); +} + +// Button to close a window +bool ImGui::CloseButton(ImGuiID id, const ImVec2& pos) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + // Tweak 1: Shrink hit-testing area if button covers an abnormally large proportion of the visible region. That's in order to facilitate moving the window away. (#3825) + // This may better be applied as a general hit-rect reduction mechanism for all widgets to ensure the area to move window is always accessible? + const ImRect bb(pos, pos + ImVec2(g.FontSize, g.FontSize) + g.Style.FramePadding * 2.0f); + ImRect bb_interact = bb; + const float area_to_visible_ratio = window->OuterRectClipped.GetArea() / bb.GetArea(); + if (area_to_visible_ratio < 1.5f) + bb_interact.Expand(ImFloor(bb_interact.GetSize() * -0.25f)); + + // Tweak 2: We intentionally allow interaction when clipped so that a mechanical Alt,Right,Activate sequence can always close a window. + // (this isn't the regular behavior of buttons, but it doesn't affect the user much because navigation tends to keep items visible). + bool is_clipped = !ItemAdd(bb_interact, id); + + bool hovered, held; + bool pressed = ButtonBehavior(bb_interact, id, &hovered, &held); + if (is_clipped) + return pressed; + + // Render + // FIXME: Clarify this mess + ImU32 col = GetColorU32(held ? ImGuiCol_ButtonActive : ImGuiCol_ButtonHovered); + ImVec2 center = bb.GetCenter(); + if (hovered) + window->DrawList->AddCircleFilled(center, ImMax(2.0f, g.FontSize * 0.5f + 1.0f), col, 12); + + float cross_extent = g.FontSize * 0.5f * 0.7071f - 1.0f; + ImU32 cross_col = GetColorU32(ImGuiCol_Text); + center -= ImVec2(0.5f, 0.5f); + window->DrawList->AddLine(center + ImVec2(+cross_extent, +cross_extent), center + ImVec2(-cross_extent, -cross_extent), cross_col, 1.0f); + window->DrawList->AddLine(center + ImVec2(+cross_extent, -cross_extent), center + ImVec2(-cross_extent, +cross_extent), cross_col, 1.0f); + + return pressed; +} + +bool ImGui::CollapseButton(ImGuiID id, const ImVec2& pos) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + ImRect bb(pos, pos + ImVec2(g.FontSize, g.FontSize) + g.Style.FramePadding * 2.0f); + ItemAdd(bb, id); + bool hovered, held; + bool pressed = ButtonBehavior(bb, id, &hovered, &held, ImGuiButtonFlags_None); + + // Render + ImU32 bg_col = GetColorU32((held && hovered) ? ImGuiCol_ButtonActive : hovered ? ImGuiCol_ButtonHovered : ImGuiCol_Button); + ImU32 text_col = GetColorU32(ImGuiCol_Text); + ImVec2 center = bb.GetCenter(); + if (hovered || held) + window->DrawList->AddCircleFilled(center/*+ ImVec2(0.0f, -0.5f)*/, g.FontSize * 0.5f + 1.0f, bg_col, 12); + RenderArrow(window->DrawList, bb.Min + g.Style.FramePadding, text_col, window->Collapsed ? ImGuiDir_Right : ImGuiDir_Down, 1.0f); + + // Switch to moving the window after mouse is moved beyond the initial drag threshold + if (IsItemActive() && IsMouseDragging(0)) + StartMouseMovingWindow(window); + + return pressed; +} + +ImGuiID ImGui::GetWindowScrollbarID(ImGuiWindow* window, ImGuiAxis axis) +{ + return window->GetIDNoKeepAlive(axis == ImGuiAxis_X ? "#SCROLLX" : "#SCROLLY"); +} + +// Return scrollbar rectangle, must only be called for corresponding axis if window->ScrollbarX/Y is set. +ImRect ImGui::GetWindowScrollbarRect(ImGuiWindow* window, ImGuiAxis axis) +{ + const ImRect outer_rect = window->Rect(); + const ImRect inner_rect = window->InnerRect; + const float border_size = window->WindowBorderSize; + const float scrollbar_size = window->ScrollbarSizes[axis ^ 1]; // (ScrollbarSizes.x = width of Y scrollbar; ScrollbarSizes.y = height of X scrollbar) + IM_ASSERT(scrollbar_size > 0.0f); + if (axis == ImGuiAxis_X) + return ImRect(inner_rect.Min.x, ImMax(outer_rect.Min.y, outer_rect.Max.y - border_size - scrollbar_size), inner_rect.Max.x, outer_rect.Max.y); + else + return ImRect(ImMax(outer_rect.Min.x, outer_rect.Max.x - border_size - scrollbar_size), inner_rect.Min.y, outer_rect.Max.x, inner_rect.Max.y); +} + +void ImGui::Scrollbar(ImGuiAxis axis) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + const ImGuiID id = GetWindowScrollbarID(window, axis); + KeepAliveID(id); + + // Calculate scrollbar bounding box + ImRect bb = GetWindowScrollbarRect(window, axis); + ImDrawFlags rounding_corners = ImDrawFlags_RoundCornersNone; + if (axis == ImGuiAxis_X) + { + rounding_corners |= ImDrawFlags_RoundCornersBottomLeft; + if (!window->ScrollbarY) + rounding_corners |= ImDrawFlags_RoundCornersBottomRight; + } + else + { + if ((window->Flags & ImGuiWindowFlags_NoTitleBar) && !(window->Flags & ImGuiWindowFlags_MenuBar)) + rounding_corners |= ImDrawFlags_RoundCornersTopRight; + if (!window->ScrollbarX) + rounding_corners |= ImDrawFlags_RoundCornersBottomRight; + } + float size_avail = window->InnerRect.Max[axis] - window->InnerRect.Min[axis]; + float size_contents = window->ContentSize[axis] + window->WindowPadding[axis] * 2.0f; + ScrollbarEx(bb, id, axis, &window->Scroll[axis], size_avail, size_contents, rounding_corners); +} + +// Vertical/Horizontal scrollbar +// The entire piece of code below is rather confusing because: +// - We handle absolute seeking (when first clicking outside the grab) and relative manipulation (afterward or when clicking inside the grab) +// - We store values as normalized ratio and in a form that allows the window content to change while we are holding on a scrollbar +// - We handle both horizontal and vertical scrollbars, which makes the terminology not ideal. +// Still, the code should probably be made simpler.. +bool ImGui::ScrollbarEx(const ImRect& bb_frame, ImGuiID id, ImGuiAxis axis, float* p_scroll_v, float size_avail_v, float size_contents_v, ImDrawFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return false; + + const float bb_frame_width = bb_frame.GetWidth(); + const float bb_frame_height = bb_frame.GetHeight(); + if (bb_frame_width <= 0.0f || bb_frame_height <= 0.0f) + return false; + + // When we are too small, start hiding and disabling the grab (this reduce visual noise on very small window and facilitate using the window resize grab) + float alpha = 1.0f; + if ((axis == ImGuiAxis_Y) && bb_frame_height < g.FontSize + g.Style.FramePadding.y * 2.0f) + alpha = ImSaturate((bb_frame_height - g.FontSize) / (g.Style.FramePadding.y * 2.0f)); + if (alpha <= 0.0f) + return false; + + const ImGuiStyle& style = g.Style; + const bool allow_interaction = (alpha >= 1.0f); + + ImRect bb = bb_frame; + bb.Expand(ImVec2(-ImClamp(IM_FLOOR((bb_frame_width - 2.0f) * 0.5f), 0.0f, 3.0f), -ImClamp(IM_FLOOR((bb_frame_height - 2.0f) * 0.5f), 0.0f, 3.0f))); + + // V denote the main, longer axis of the scrollbar (= height for a vertical scrollbar) + const float scrollbar_size_v = (axis == ImGuiAxis_X) ? bb.GetWidth() : bb.GetHeight(); + + // Calculate the height of our grabbable box. It generally represent the amount visible (vs the total scrollable amount) + // But we maintain a minimum size in pixel to allow for the user to still aim inside. + IM_ASSERT(ImMax(size_contents_v, size_avail_v) > 0.0f); // Adding this assert to check if the ImMax(XXX,1.0f) is still needed. PLEASE CONTACT ME if this triggers. + const float win_size_v = ImMax(ImMax(size_contents_v, size_avail_v), 1.0f); + const float grab_h_pixels = ImClamp(scrollbar_size_v * (size_avail_v / win_size_v), style.GrabMinSize, scrollbar_size_v); + const float grab_h_norm = grab_h_pixels / scrollbar_size_v; + + // Handle input right away. None of the code of Begin() is relying on scrolling position before calling Scrollbar(). + bool held = false; + bool hovered = false; + ButtonBehavior(bb, id, &hovered, &held, ImGuiButtonFlags_NoNavFocus); + + float scroll_max = ImMax(1.0f, size_contents_v - size_avail_v); + float scroll_ratio = ImSaturate(*p_scroll_v / scroll_max); + float grab_v_norm = scroll_ratio * (scrollbar_size_v - grab_h_pixels) / scrollbar_size_v; // Grab position in normalized space + if (held && allow_interaction && grab_h_norm < 1.0f) + { + float scrollbar_pos_v = bb.Min[axis]; + float mouse_pos_v = g.IO.MousePos[axis]; + + // Click position in scrollbar normalized space (0.0f->1.0f) + const float clicked_v_norm = ImSaturate((mouse_pos_v - scrollbar_pos_v) / scrollbar_size_v); + SetHoveredID(id); + + bool seek_absolute = false; + if (g.ActiveIdIsJustActivated) + { + // On initial click calculate the distance between mouse and the center of the grab + seek_absolute = (clicked_v_norm < grab_v_norm || clicked_v_norm > grab_v_norm + grab_h_norm); + if (seek_absolute) + g.ScrollbarClickDeltaToGrabCenter = 0.0f; + else + g.ScrollbarClickDeltaToGrabCenter = clicked_v_norm - grab_v_norm - grab_h_norm * 0.5f; + } + + // Apply scroll (p_scroll_v will generally point on one member of window->Scroll) + // It is ok to modify Scroll here because we are being called in Begin() after the calculation of ContentSize and before setting up our starting position + const float scroll_v_norm = ImSaturate((clicked_v_norm - g.ScrollbarClickDeltaToGrabCenter - grab_h_norm * 0.5f) / (1.0f - grab_h_norm)); + *p_scroll_v = IM_ROUND(scroll_v_norm * scroll_max);//(win_size_contents_v - win_size_v)); + + // Update values for rendering + scroll_ratio = ImSaturate(*p_scroll_v / scroll_max); + grab_v_norm = scroll_ratio * (scrollbar_size_v - grab_h_pixels) / scrollbar_size_v; + + // Update distance to grab now that we have seeked and saturated + if (seek_absolute) + g.ScrollbarClickDeltaToGrabCenter = clicked_v_norm - grab_v_norm - grab_h_norm * 0.5f; + } + + // Render + const ImU32 bg_col = GetColorU32(ImGuiCol_ScrollbarBg); + const ImU32 grab_col = GetColorU32(held ? ImGuiCol_ScrollbarGrabActive : hovered ? ImGuiCol_ScrollbarGrabHovered : ImGuiCol_ScrollbarGrab, alpha); + window->DrawList->AddRectFilled(bb_frame.Min, bb_frame.Max, bg_col, window->WindowRounding, flags); + ImRect grab_rect; + if (axis == ImGuiAxis_X) + grab_rect = ImRect(ImLerp(bb.Min.x, bb.Max.x, grab_v_norm), bb.Min.y, ImLerp(bb.Min.x, bb.Max.x, grab_v_norm) + grab_h_pixels, bb.Max.y); + else + grab_rect = ImRect(bb.Min.x, ImLerp(bb.Min.y, bb.Max.y, grab_v_norm), bb.Max.x, ImLerp(bb.Min.y, bb.Max.y, grab_v_norm) + grab_h_pixels); + window->DrawList->AddRectFilled(grab_rect.Min, grab_rect.Max, grab_col, style.ScrollbarRounding); + + return held; +} + +void ImGui::Image(ImTextureID user_texture_id, const ImVec2& size, const ImVec2& uv0, const ImVec2& uv1, const ImVec4& tint_col, const ImVec4& border_col) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + + ImRect bb(window->DC.CursorPos, window->DC.CursorPos + size); + if (border_col.w > 0.0f) + bb.Max += ImVec2(2, 2); + ItemSize(bb); + if (!ItemAdd(bb, 0)) + return; + + if (border_col.w > 0.0f) + { + window->DrawList->AddRect(bb.Min, bb.Max, GetColorU32(border_col), 0.0f); + window->DrawList->AddImage(user_texture_id, bb.Min + ImVec2(1, 1), bb.Max - ImVec2(1, 1), uv0, uv1, GetColorU32(tint_col)); + } + else + { + window->DrawList->AddImage(user_texture_id, bb.Min, bb.Max, uv0, uv1, GetColorU32(tint_col)); + } +} + +// ImageButton() is flawed as 'id' is always derived from 'texture_id' (see #2464 #1390) +// We provide this internal helper to write your own variant while we figure out how to redesign the public ImageButton() API. +bool ImGui::ImageButtonEx(ImGuiID id, ImTextureID texture_id, const ImVec2& size, const ImVec2& uv0, const ImVec2& uv1, const ImVec2& padding, const ImVec4& bg_col, const ImVec4& tint_col) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + const ImRect bb(window->DC.CursorPos, window->DC.CursorPos + size + padding * 2); + ItemSize(bb); + if (!ItemAdd(bb, id)) + return false; + + bool hovered, held; + bool pressed = ButtonBehavior(bb, id, &hovered, &held); + + // Render + const ImU32 col = GetColorU32((held && hovered) ? ImGuiCol_ButtonActive : hovered ? ImGuiCol_ButtonHovered : ImGuiCol_Button); + RenderNavHighlight(bb, id); + RenderFrame(bb.Min, bb.Max, col, true, ImClamp((float)ImMin(padding.x, padding.y), 0.0f, g.Style.FrameRounding)); + if (bg_col.w > 0.0f) + window->DrawList->AddRectFilled(bb.Min + padding, bb.Max - padding, GetColorU32(bg_col)); + window->DrawList->AddImage(texture_id, bb.Min + padding, bb.Max - padding, uv0, uv1, GetColorU32(tint_col)); + + return pressed; +} + +// frame_padding < 0: uses FramePadding from style (default) +// frame_padding = 0: no framing +// frame_padding > 0: set framing size +bool ImGui::ImageButton(ImTextureID user_texture_id, const ImVec2& size, const ImVec2& uv0, const ImVec2& uv1, int frame_padding, const ImVec4& bg_col, const ImVec4& tint_col) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return false; + + // Default to using texture ID as ID. User can still push string/integer prefixes. + PushID((void*)(intptr_t)user_texture_id); + const ImGuiID id = window->GetID("#image"); + PopID(); + + const ImVec2 padding = (frame_padding >= 0) ? ImVec2((float)frame_padding, (float)frame_padding) : g.Style.FramePadding; + return ImageButtonEx(id, user_texture_id, size, uv0, uv1, padding, bg_col, tint_col); +} + +bool ImGui::Checkbox(const char* label, bool* v) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + const ImGuiID id = window->GetID(label); + const ImVec2 label_size = CalcTextSize(label, NULL, true); + + const float square_sz = GetFrameHeight(); + const ImVec2 pos = window->DC.CursorPos; + const ImRect total_bb(pos, pos + ImVec2(square_sz + (label_size.x > 0.0f ? style.ItemInnerSpacing.x + label_size.x : 0.0f), label_size.y + style.FramePadding.y * 2.0f)); + ItemSize(total_bb, style.FramePadding.y); + if (!ItemAdd(total_bb, id)) + { + IMGUI_TEST_ENGINE_ITEM_INFO(id, label, g.LastItemData.StatusFlags | ImGuiItemStatusFlags_Checkable | (*v ? ImGuiItemStatusFlags_Checked : 0)); + return false; + } + + bool hovered, held; + bool pressed = ButtonBehavior(total_bb, id, &hovered, &held); + if (pressed) + { + *v = !(*v); + MarkItemEdited(id); + } + + const ImRect check_bb(pos, pos + ImVec2(square_sz, square_sz)); + RenderNavHighlight(total_bb, id); + RenderFrame(check_bb.Min, check_bb.Max, GetColorU32((held && hovered) ? ImGuiCol_FrameBgActive : hovered ? ImGuiCol_FrameBgHovered : ImGuiCol_FrameBg), true, style.FrameRounding); + ImU32 check_col = GetColorU32(ImGuiCol_CheckMark); + bool mixed_value = (g.LastItemData.InFlags & ImGuiItemFlags_MixedValue) != 0; + if (mixed_value) + { + // Undocumented tristate/mixed/indeterminate checkbox (#2644) + // This may seem awkwardly designed because the aim is to make ImGuiItemFlags_MixedValue supported by all widgets (not just checkbox) + ImVec2 pad(ImMax(1.0f, IM_FLOOR(square_sz / 3.6f)), ImMax(1.0f, IM_FLOOR(square_sz / 3.6f))); + window->DrawList->AddRectFilled(check_bb.Min + pad, check_bb.Max - pad, check_col, style.FrameRounding); + } + else if (*v) + { + const float pad = ImMax(1.0f, IM_FLOOR(square_sz / 6.0f)); + RenderCheckMark(window->DrawList, check_bb.Min + ImVec2(pad, pad), check_col, square_sz - pad * 2.0f); + } + + ImVec2 label_pos = ImVec2(check_bb.Max.x + style.ItemInnerSpacing.x, check_bb.Min.y + style.FramePadding.y); + if (g.LogEnabled) + LogRenderedText(&label_pos, mixed_value ? "[~]" : *v ? "[x]" : "[ ]"); + if (label_size.x > 0.0f) + RenderText(label_pos, label); + + IMGUI_TEST_ENGINE_ITEM_INFO(id, label, g.LastItemData.StatusFlags | ImGuiItemStatusFlags_Checkable | (*v ? ImGuiItemStatusFlags_Checked : 0)); + return pressed; +} + +template +bool ImGui::CheckboxFlagsT(const char* label, T* flags, T flags_value) +{ + bool all_on = (*flags & flags_value) == flags_value; + bool any_on = (*flags & flags_value) != 0; + bool pressed; + if (!all_on && any_on) + { + ImGuiContext& g = *GImGui; + ImGuiItemFlags backup_item_flags = g.CurrentItemFlags; + g.CurrentItemFlags |= ImGuiItemFlags_MixedValue; + pressed = Checkbox(label, &all_on); + g.CurrentItemFlags = backup_item_flags; + } + else + { + pressed = Checkbox(label, &all_on); + + } + if (pressed) + { + if (all_on) + *flags |= flags_value; + else + *flags &= ~flags_value; + } + return pressed; +} + +bool ImGui::CheckboxFlags(const char* label, int* flags, int flags_value) +{ + return CheckboxFlagsT(label, flags, flags_value); +} + +bool ImGui::CheckboxFlags(const char* label, unsigned int* flags, unsigned int flags_value) +{ + return CheckboxFlagsT(label, flags, flags_value); +} + +bool ImGui::CheckboxFlags(const char* label, ImS64* flags, ImS64 flags_value) +{ + return CheckboxFlagsT(label, flags, flags_value); +} + +bool ImGui::CheckboxFlags(const char* label, ImU64* flags, ImU64 flags_value) +{ + return CheckboxFlagsT(label, flags, flags_value); +} + +bool ImGui::RadioButton(const char* label, bool active) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + const ImGuiID id = window->GetID(label); + const ImVec2 label_size = CalcTextSize(label, NULL, true); + + const float square_sz = GetFrameHeight(); + const ImVec2 pos = window->DC.CursorPos; + const ImRect check_bb(pos, pos + ImVec2(square_sz, square_sz)); + const ImRect total_bb(pos, pos + ImVec2(square_sz + (label_size.x > 0.0f ? style.ItemInnerSpacing.x + label_size.x : 0.0f), label_size.y + style.FramePadding.y * 2.0f)); + ItemSize(total_bb, style.FramePadding.y); + if (!ItemAdd(total_bb, id)) + return false; + + ImVec2 center = check_bb.GetCenter(); + center.x = IM_ROUND(center.x); + center.y = IM_ROUND(center.y); + const float radius = (square_sz - 1.0f) * 0.5f; + + bool hovered, held; + bool pressed = ButtonBehavior(total_bb, id, &hovered, &held); + if (pressed) + MarkItemEdited(id); + + RenderNavHighlight(total_bb, id); + window->DrawList->AddCircleFilled(center, radius, GetColorU32((held && hovered) ? ImGuiCol_FrameBgActive : hovered ? ImGuiCol_FrameBgHovered : ImGuiCol_FrameBg), 16); + if (active) + { + const float pad = ImMax(1.0f, IM_FLOOR(square_sz / 6.0f)); + window->DrawList->AddCircleFilled(center, radius - pad, GetColorU32(ImGuiCol_CheckMark), 16); + } + + if (style.FrameBorderSize > 0.0f) + { + window->DrawList->AddCircle(center + ImVec2(1, 1), radius, GetColorU32(ImGuiCol_BorderShadow), 16, style.FrameBorderSize); + window->DrawList->AddCircle(center, radius, GetColorU32(ImGuiCol_Border), 16, style.FrameBorderSize); + } + + ImVec2 label_pos = ImVec2(check_bb.Max.x + style.ItemInnerSpacing.x, check_bb.Min.y + style.FramePadding.y); + if (g.LogEnabled) + LogRenderedText(&label_pos, active ? "(x)" : "( )"); + if (label_size.x > 0.0f) + RenderText(label_pos, label); + + IMGUI_TEST_ENGINE_ITEM_INFO(id, label, g.LastItemData.StatusFlags); + return pressed; +} + +// FIXME: This would work nicely if it was a public template, e.g. 'template RadioButton(const char* label, T* v, T v_button)', but I'm not sure how we would expose it.. +bool ImGui::RadioButton(const char* label, int* v, int v_button) +{ + const bool pressed = RadioButton(label, *v == v_button); + if (pressed) + *v = v_button; + return pressed; +} + +// size_arg (for each axis) < 0.0f: align to end, 0.0f: auto, > 0.0f: specified size +void ImGui::ProgressBar(float fraction, const ImVec2& size_arg, const char* overlay) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + + ImVec2 pos = window->DC.CursorPos; + ImVec2 size = CalcItemSize(size_arg, CalcItemWidth(), g.FontSize + style.FramePadding.y * 2.0f); + ImRect bb(pos, pos + size); + ItemSize(size, style.FramePadding.y); + if (!ItemAdd(bb, 0)) + return; + + // Render + fraction = ImSaturate(fraction); + RenderFrame(bb.Min, bb.Max, GetColorU32(ImGuiCol_FrameBg), true, style.FrameRounding); + bb.Expand(ImVec2(-style.FrameBorderSize, -style.FrameBorderSize)); + const ImVec2 fill_br = ImVec2(ImLerp(bb.Min.x, bb.Max.x, fraction), bb.Max.y); + RenderRectFilledRangeH(window->DrawList, bb, GetColorU32(ImGuiCol_PlotHistogram), 0.0f, fraction, style.FrameRounding); + + // Default displaying the fraction as percentage string, but user can override it + char overlay_buf[32]; + if (!overlay) + { + ImFormatString(overlay_buf, IM_ARRAYSIZE(overlay_buf), "%.0f%%", fraction * 100 + 0.01f); + overlay = overlay_buf; + } + + ImVec2 overlay_size = CalcTextSize(overlay, NULL); + if (overlay_size.x > 0.0f) + RenderTextClipped(ImVec2(ImClamp(fill_br.x + style.ItemSpacing.x, bb.Min.x, bb.Max.x - overlay_size.x - style.ItemInnerSpacing.x), bb.Min.y), bb.Max, overlay, NULL, &overlay_size, ImVec2(0.0f, 0.5f), &bb); +} + +void ImGui::Bullet() +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + const float line_height = ImMax(ImMin(window->DC.CurrLineSize.y, g.FontSize + g.Style.FramePadding.y * 2), g.FontSize); + const ImRect bb(window->DC.CursorPos, window->DC.CursorPos + ImVec2(g.FontSize, line_height)); + ItemSize(bb); + if (!ItemAdd(bb, 0)) + { + SameLine(0, style.FramePadding.x * 2); + return; + } + + // Render and stay on same line + ImU32 text_col = GetColorU32(ImGuiCol_Text); + RenderBullet(window->DrawList, bb.Min + ImVec2(style.FramePadding.x + g.FontSize * 0.5f, line_height * 0.5f), text_col); + SameLine(0, style.FramePadding.x * 2.0f); +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: Low-level Layout helpers +//------------------------------------------------------------------------- +// - Spacing() +// - Dummy() +// - NewLine() +// - AlignTextToFramePadding() +// - SeparatorEx() [Internal] +// - Separator() +// - SplitterBehavior() [Internal] +// - ShrinkWidths() [Internal] +//------------------------------------------------------------------------- + +void ImGui::Spacing() +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + ItemSize(ImVec2(0, 0)); +} + +void ImGui::Dummy(const ImVec2& size) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + + const ImRect bb(window->DC.CursorPos, window->DC.CursorPos + size); + ItemSize(size); + ItemAdd(bb, 0); +} + +void ImGui::NewLine() +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + + ImGuiContext& g = *GImGui; + const ImGuiLayoutType backup_layout_type = window->DC.LayoutType; + window->DC.LayoutType = ImGuiLayoutType_Vertical; + if (window->DC.CurrLineSize.y > 0.0f) // In the event that we are on a line with items that is smaller that FontSize high, we will preserve its height. + ItemSize(ImVec2(0, 0)); + else + ItemSize(ImVec2(0.0f, g.FontSize)); + window->DC.LayoutType = backup_layout_type; +} + +void ImGui::AlignTextToFramePadding() +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + + ImGuiContext& g = *GImGui; + window->DC.CurrLineSize.y = ImMax(window->DC.CurrLineSize.y, g.FontSize + g.Style.FramePadding.y * 2); + window->DC.CurrLineTextBaseOffset = ImMax(window->DC.CurrLineTextBaseOffset, g.Style.FramePadding.y); +} + +// Horizontal/vertical separating line +void ImGui::SeparatorEx(ImGuiSeparatorFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + + ImGuiContext& g = *GImGui; + IM_ASSERT(ImIsPowerOfTwo(flags & (ImGuiSeparatorFlags_Horizontal | ImGuiSeparatorFlags_Vertical))); // Check that only 1 option is selected + + float thickness_draw = 1.0f; + float thickness_layout = 0.0f; + if (flags & ImGuiSeparatorFlags_Vertical) + { + // Vertical separator, for menu bars (use current line height). Not exposed because it is misleading and it doesn't have an effect on regular layout. + float y1 = window->DC.CursorPos.y; + float y2 = window->DC.CursorPos.y + window->DC.CurrLineSize.y; + const ImRect bb(ImVec2(window->DC.CursorPos.x, y1), ImVec2(window->DC.CursorPos.x + thickness_draw, y2)); + ItemSize(ImVec2(thickness_layout, 0.0f)); + if (!ItemAdd(bb, 0)) + return; + + // Draw + window->DrawList->AddLine(ImVec2(bb.Min.x, bb.Min.y), ImVec2(bb.Min.x, bb.Max.y), GetColorU32(ImGuiCol_Separator)); + if (g.LogEnabled) + LogText(" |"); + } + else if (flags & ImGuiSeparatorFlags_Horizontal) + { + // Horizontal Separator + float x1 = window->Pos.x; + float x2 = window->Pos.x + window->Size.x; + + // FIXME-WORKRECT: old hack (#205) until we decide of consistent behavior with WorkRect/Indent and Separator + if (g.GroupStack.Size > 0 && g.GroupStack.back().WindowID == window->ID) + x1 += window->DC.Indent.x; + + ImGuiOldColumns* columns = (flags & ImGuiSeparatorFlags_SpanAllColumns) ? window->DC.CurrentColumns : NULL; + if (columns) + PushColumnsBackground(); + + // We don't provide our width to the layout so that it doesn't get feed back into AutoFit + const ImRect bb(ImVec2(x1, window->DC.CursorPos.y), ImVec2(x2, window->DC.CursorPos.y + thickness_draw)); + ItemSize(ImVec2(0.0f, thickness_layout)); + const bool item_visible = ItemAdd(bb, 0); + if (item_visible) + { + // Draw + window->DrawList->AddLine(bb.Min, ImVec2(bb.Max.x, bb.Min.y), GetColorU32(ImGuiCol_Separator)); + if (g.LogEnabled) + LogRenderedText(&bb.Min, "--------------------------------\n"); + + } + if (columns) + { + PopColumnsBackground(); + columns->LineMinY = window->DC.CursorPos.y; + } + } +} + +void ImGui::Separator() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return; + + // Those flags should eventually be overridable by the user + ImGuiSeparatorFlags flags = (window->DC.LayoutType == ImGuiLayoutType_Horizontal) ? ImGuiSeparatorFlags_Vertical : ImGuiSeparatorFlags_Horizontal; + flags |= ImGuiSeparatorFlags_SpanAllColumns; + SeparatorEx(flags); +} + +// Using 'hover_visibility_delay' allows us to hide the highlight and mouse cursor for a short time, which can be convenient to reduce visual noise. +bool ImGui::SplitterBehavior(const ImRect& bb, ImGuiID id, ImGuiAxis axis, float* size1, float* size2, float min_size1, float min_size2, float hover_extend, float hover_visibility_delay) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + const ImGuiItemFlags item_flags_backup = g.CurrentItemFlags; + g.CurrentItemFlags |= ImGuiItemFlags_NoNav | ImGuiItemFlags_NoNavDefaultFocus; + bool item_add = ItemAdd(bb, id); + g.CurrentItemFlags = item_flags_backup; + if (!item_add) + return false; + + bool hovered, held; + ImRect bb_interact = bb; + bb_interact.Expand(axis == ImGuiAxis_Y ? ImVec2(0.0f, hover_extend) : ImVec2(hover_extend, 0.0f)); + ButtonBehavior(bb_interact, id, &hovered, &held, ImGuiButtonFlags_FlattenChildren | ImGuiButtonFlags_AllowItemOverlap); + if (hovered) + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_HoveredRect; // for IsItemHovered(), because bb_interact is larger than bb + if (g.ActiveId != id) + SetItemAllowOverlap(); + + if (held || (hovered && g.HoveredIdPreviousFrame == id && g.HoveredIdTimer >= hover_visibility_delay)) + SetMouseCursor(axis == ImGuiAxis_Y ? ImGuiMouseCursor_ResizeNS : ImGuiMouseCursor_ResizeEW); + + ImRect bb_render = bb; + if (held) + { + ImVec2 mouse_delta_2d = g.IO.MousePos - g.ActiveIdClickOffset - bb_interact.Min; + float mouse_delta = (axis == ImGuiAxis_Y) ? mouse_delta_2d.y : mouse_delta_2d.x; + + // Minimum pane size + float size_1_maximum_delta = ImMax(0.0f, *size1 - min_size1); + float size_2_maximum_delta = ImMax(0.0f, *size2 - min_size2); + if (mouse_delta < -size_1_maximum_delta) + mouse_delta = -size_1_maximum_delta; + if (mouse_delta > size_2_maximum_delta) + mouse_delta = size_2_maximum_delta; + + // Apply resize + if (mouse_delta != 0.0f) + { + if (mouse_delta < 0.0f) + IM_ASSERT(*size1 + mouse_delta >= min_size1); + if (mouse_delta > 0.0f) + IM_ASSERT(*size2 - mouse_delta >= min_size2); + *size1 += mouse_delta; + *size2 -= mouse_delta; + bb_render.Translate((axis == ImGuiAxis_X) ? ImVec2(mouse_delta, 0.0f) : ImVec2(0.0f, mouse_delta)); + MarkItemEdited(id); + } + } + + // Render + const ImU32 col = GetColorU32(held ? ImGuiCol_SeparatorActive : (hovered && g.HoveredIdTimer >= hover_visibility_delay) ? ImGuiCol_SeparatorHovered : ImGuiCol_Separator); + window->DrawList->AddRectFilled(bb_render.Min, bb_render.Max, col, 0.0f); + + return held; +} + +static int IMGUI_CDECL ShrinkWidthItemComparer(const void* lhs, const void* rhs) +{ + const ImGuiShrinkWidthItem* a = (const ImGuiShrinkWidthItem*)lhs; + const ImGuiShrinkWidthItem* b = (const ImGuiShrinkWidthItem*)rhs; + if (int d = (int)(b->Width - a->Width)) + return d; + return (b->Index - a->Index); +} + +// Shrink excess width from a set of item, by removing width from the larger items first. +// Set items Width to -1.0f to disable shrinking this item. +void ImGui::ShrinkWidths(ImGuiShrinkWidthItem* items, int count, float width_excess) +{ + if (count == 1) + { + if (items[0].Width >= 0.0f) + items[0].Width = ImMax(items[0].Width - width_excess, 1.0f); + return; + } + ImQsort(items, (size_t)count, sizeof(ImGuiShrinkWidthItem), ShrinkWidthItemComparer); + int count_same_width = 1; + while (width_excess > 0.0f && count_same_width < count) + { + while (count_same_width < count && items[0].Width <= items[count_same_width].Width) + count_same_width++; + float max_width_to_remove_per_item = (count_same_width < count && items[count_same_width].Width >= 0.0f) ? (items[0].Width - items[count_same_width].Width) : (items[0].Width - 1.0f); + if (max_width_to_remove_per_item <= 0.0f) + break; + float width_to_remove_per_item = ImMin(width_excess / count_same_width, max_width_to_remove_per_item); + for (int item_n = 0; item_n < count_same_width; item_n++) + items[item_n].Width -= width_to_remove_per_item; + width_excess -= width_to_remove_per_item * count_same_width; + } + + // Round width and redistribute remainder left-to-right (could make it an option of the function?) + // Ensure that e.g. the right-most tab of a shrunk tab-bar always reaches exactly at the same distance from the right-most edge of the tab bar separator. + width_excess = 0.0f; + for (int n = 0; n < count; n++) + { + float width_rounded = ImFloor(items[n].Width); + width_excess += items[n].Width - width_rounded; + items[n].Width = width_rounded; + } + if (width_excess > 0.0f) + for (int n = 0; n < count; n++) + if (items[n].Index < (int)(width_excess + 0.01f)) + items[n].Width += 1.0f; +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: ComboBox +//------------------------------------------------------------------------- +// - CalcMaxPopupHeightFromItemCount() [Internal] +// - BeginCombo() +// - BeginComboPopup() [Internal] +// - EndCombo() +// - BeginComboPreview() [Internal] +// - EndComboPreview() [Internal] +// - Combo() +//------------------------------------------------------------------------- + +static float CalcMaxPopupHeightFromItemCount(int items_count) +{ + ImGuiContext& g = *GImGui; + if (items_count <= 0) + return FLT_MAX; + return (g.FontSize + g.Style.ItemSpacing.y) * items_count - g.Style.ItemSpacing.y + (g.Style.WindowPadding.y * 2); +} + +bool ImGui::BeginCombo(const char* label, const char* preview_value, ImGuiComboFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = GetCurrentWindow(); + + ImGuiNextWindowDataFlags backup_next_window_data_flags = g.NextWindowData.Flags; + g.NextWindowData.ClearFlags(); // We behave like Begin() and need to consume those values + if (window->SkipItems) + return false; + + const ImGuiStyle& style = g.Style; + const ImGuiID id = window->GetID(label); + IM_ASSERT((flags & (ImGuiComboFlags_NoArrowButton | ImGuiComboFlags_NoPreview)) != (ImGuiComboFlags_NoArrowButton | ImGuiComboFlags_NoPreview)); // Can't use both flags together + + const float arrow_size = (flags & ImGuiComboFlags_NoArrowButton) ? 0.0f : GetFrameHeight(); + const ImVec2 label_size = CalcTextSize(label, NULL, true); + const float w = (flags & ImGuiComboFlags_NoPreview) ? arrow_size : CalcItemWidth(); + const ImRect bb(window->DC.CursorPos, window->DC.CursorPos + ImVec2(w, label_size.y + style.FramePadding.y * 2.0f)); + const ImRect total_bb(bb.Min, bb.Max + ImVec2(label_size.x > 0.0f ? style.ItemInnerSpacing.x + label_size.x : 0.0f, 0.0f)); + ItemSize(total_bb, style.FramePadding.y); + if (!ItemAdd(total_bb, id, &bb)) + return false; + + // Open on click + bool hovered, held; + bool pressed = ButtonBehavior(bb, id, &hovered, &held); + const ImGuiID popup_id = ImHashStr("##ComboPopup", 0, id); + bool popup_open = IsPopupOpen(popup_id, ImGuiPopupFlags_None); + if (pressed && !popup_open) + { + OpenPopupEx(popup_id, ImGuiPopupFlags_None); + popup_open = true; + } + + // Render shape + const ImU32 frame_col = GetColorU32(hovered ? ImGuiCol_FrameBgHovered : ImGuiCol_FrameBg); + const float value_x2 = ImMax(bb.Min.x, bb.Max.x - arrow_size); + RenderNavHighlight(bb, id); + if (!(flags & ImGuiComboFlags_NoPreview)) + window->DrawList->AddRectFilled(bb.Min, ImVec2(value_x2, bb.Max.y), frame_col, style.FrameRounding, (flags & ImGuiComboFlags_NoArrowButton) ? ImDrawFlags_RoundCornersAll : ImDrawFlags_RoundCornersLeft); + if (!(flags & ImGuiComboFlags_NoArrowButton)) + { + ImU32 bg_col = GetColorU32((popup_open || hovered) ? ImGuiCol_ButtonHovered : ImGuiCol_Button); + ImU32 text_col = GetColorU32(ImGuiCol_Text); + window->DrawList->AddRectFilled(ImVec2(value_x2, bb.Min.y), bb.Max, bg_col, style.FrameRounding, (w <= arrow_size) ? ImDrawFlags_RoundCornersAll : ImDrawFlags_RoundCornersRight); + if (value_x2 + arrow_size - style.FramePadding.x <= bb.Max.x) + RenderArrow(window->DrawList, ImVec2(value_x2 + style.FramePadding.y, bb.Min.y + style.FramePadding.y), text_col, ImGuiDir_Down, 1.0f); + } + RenderFrameBorder(bb.Min, bb.Max, style.FrameRounding); + + // Custom preview + if (flags & ImGuiComboFlags_CustomPreview) + { + g.ComboPreviewData.PreviewRect = ImRect(bb.Min.x, bb.Min.y, value_x2, bb.Max.y); + IM_ASSERT(preview_value == NULL || preview_value[0] == 0); + preview_value = NULL; + } + + // Render preview and label + if (preview_value != NULL && !(flags & ImGuiComboFlags_NoPreview)) + { + if (g.LogEnabled) + LogSetNextTextDecoration("{", "}"); + RenderTextClipped(bb.Min + style.FramePadding, ImVec2(value_x2, bb.Max.y), preview_value, NULL, NULL); + } + if (label_size.x > 0) + RenderText(ImVec2(bb.Max.x + style.ItemInnerSpacing.x, bb.Min.y + style.FramePadding.y), label); + + if (!popup_open) + return false; + + g.NextWindowData.Flags = backup_next_window_data_flags; + return BeginComboPopup(popup_id, bb, flags); +} + +bool ImGui::BeginComboPopup(ImGuiID popup_id, const ImRect& bb, ImGuiComboFlags flags) +{ + ImGuiContext& g = *GImGui; + if (!IsPopupOpen(popup_id, ImGuiPopupFlags_None)) + { + g.NextWindowData.ClearFlags(); + return false; + } + + // Set popup size + float w = bb.GetWidth(); + if (g.NextWindowData.Flags & ImGuiNextWindowDataFlags_HasSizeConstraint) + { + g.NextWindowData.SizeConstraintRect.Min.x = ImMax(g.NextWindowData.SizeConstraintRect.Min.x, w); + } + else + { + if ((flags & ImGuiComboFlags_HeightMask_) == 0) + flags |= ImGuiComboFlags_HeightRegular; + IM_ASSERT(ImIsPowerOfTwo(flags & ImGuiComboFlags_HeightMask_)); // Only one + int popup_max_height_in_items = -1; + if (flags & ImGuiComboFlags_HeightRegular) popup_max_height_in_items = 8; + else if (flags & ImGuiComboFlags_HeightSmall) popup_max_height_in_items = 4; + else if (flags & ImGuiComboFlags_HeightLarge) popup_max_height_in_items = 20; + SetNextWindowSizeConstraints(ImVec2(w, 0.0f), ImVec2(FLT_MAX, CalcMaxPopupHeightFromItemCount(popup_max_height_in_items))); + } + + // This is essentially a specialized version of BeginPopupEx() + char name[16]; + ImFormatString(name, IM_ARRAYSIZE(name), "##Combo_%02d", g.BeginPopupStack.Size); // Recycle windows based on depth + + // Set position given a custom constraint (peak into expected window size so we can position it) + // FIXME: This might be easier to express with an hypothetical SetNextWindowPosConstraints() function? + // FIXME: This might be moved to Begin() or at least around the same spot where Tooltips and other Popups are calling FindBestWindowPosForPopupEx()? + if (ImGuiWindow* popup_window = FindWindowByName(name)) + if (popup_window->WasActive) + { + // Always override 'AutoPosLastDirection' to not leave a chance for a past value to affect us. + ImVec2 size_expected = CalcWindowNextAutoFitSize(popup_window); + popup_window->AutoPosLastDirection = (flags & ImGuiComboFlags_PopupAlignLeft) ? ImGuiDir_Left : ImGuiDir_Down; // Left = "Below, Toward Left", Down = "Below, Toward Right (default)" + ImRect r_outer = GetPopupAllowedExtentRect(popup_window); + ImVec2 pos = FindBestWindowPosForPopupEx(bb.GetBL(), size_expected, &popup_window->AutoPosLastDirection, r_outer, bb, ImGuiPopupPositionPolicy_ComboBox); + SetNextWindowPos(pos); + } + + // We don't use BeginPopupEx() solely because we have a custom name string, which we could make an argument to BeginPopupEx() + ImGuiWindowFlags window_flags = ImGuiWindowFlags_AlwaysAutoResize | ImGuiWindowFlags_Popup | ImGuiWindowFlags_NoTitleBar | ImGuiWindowFlags_NoResize | ImGuiWindowFlags_NoSavedSettings | ImGuiWindowFlags_NoMove; + PushStyleVar(ImGuiStyleVar_WindowPadding, ImVec2(g.Style.FramePadding.x, g.Style.WindowPadding.y)); // Horizontally align ourselves with the framed text + bool ret = Begin(name, NULL, window_flags); + PopStyleVar(); + if (!ret) + { + EndPopup(); + IM_ASSERT(0); // This should never happen as we tested for IsPopupOpen() above + return false; + } + return true; +} + +void ImGui::EndCombo() +{ + EndPopup(); +} + +// Call directly after the BeginCombo/EndCombo block. The preview is designed to only host non-interactive elements +// (Experimental, see GitHub issues: #1658, #4168) +bool ImGui::BeginComboPreview() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImGuiComboPreviewData* preview_data = &g.ComboPreviewData; + + if (window->SkipItems || !window->ClipRect.Overlaps(g.LastItemData.Rect)) // FIXME: Because we don't have a ImGuiItemStatusFlags_Visible flag to test last ItemAdd() result + return false; + IM_ASSERT(g.LastItemData.Rect.Min.x == preview_data->PreviewRect.Min.x && g.LastItemData.Rect.Min.y == preview_data->PreviewRect.Min.y); // Didn't call after BeginCombo/EndCombo block or forgot to pass ImGuiComboFlags_CustomPreview flag? + if (!window->ClipRect.Contains(preview_data->PreviewRect)) // Narrower test (optional) + return false; + + // FIXME: This could be contained in a PushWorkRect() api + preview_data->BackupCursorPos = window->DC.CursorPos; + preview_data->BackupCursorMaxPos = window->DC.CursorMaxPos; + preview_data->BackupCursorPosPrevLine = window->DC.CursorPosPrevLine; + preview_data->BackupPrevLineTextBaseOffset = window->DC.PrevLineTextBaseOffset; + preview_data->BackupLayout = window->DC.LayoutType; + window->DC.CursorPos = preview_data->PreviewRect.Min + g.Style.FramePadding; + window->DC.CursorMaxPos = window->DC.CursorPos; + window->DC.LayoutType = ImGuiLayoutType_Horizontal; + PushClipRect(preview_data->PreviewRect.Min, preview_data->PreviewRect.Max, true); + + return true; +} + +void ImGui::EndComboPreview() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImGuiComboPreviewData* preview_data = &g.ComboPreviewData; + + // FIXME: Using CursorMaxPos approximation instead of correct AABB which we will store in ImDrawCmd in the future + ImDrawList* draw_list = window->DrawList; + if (window->DC.CursorMaxPos.x < preview_data->PreviewRect.Max.x && window->DC.CursorMaxPos.y < preview_data->PreviewRect.Max.y) + if (draw_list->CmdBuffer.Size > 1) // Unlikely case that the PushClipRect() didn't create a command + { + draw_list->_CmdHeader.ClipRect = draw_list->CmdBuffer[draw_list->CmdBuffer.Size - 1].ClipRect = draw_list->CmdBuffer[draw_list->CmdBuffer.Size - 2].ClipRect; + draw_list->_TryMergeDrawCmds(); + } + PopClipRect(); + window->DC.CursorPos = preview_data->BackupCursorPos; + window->DC.CursorMaxPos = ImMax(window->DC.CursorMaxPos, preview_data->BackupCursorMaxPos); + window->DC.CursorPosPrevLine = preview_data->BackupCursorPosPrevLine; + window->DC.PrevLineTextBaseOffset = preview_data->BackupPrevLineTextBaseOffset; + window->DC.LayoutType = preview_data->BackupLayout; + preview_data->PreviewRect = ImRect(); +} + +// Getter for the old Combo() API: const char*[] +static bool Items_ArrayGetter(void* data, int idx, const char** out_text) +{ + const char* const* items = (const char* const*)data; + if (out_text) + *out_text = items[idx]; + return true; +} + +// Getter for the old Combo() API: "item1\0item2\0item3\0" +static bool Items_SingleStringGetter(void* data, int idx, const char** out_text) +{ + // FIXME-OPT: we could pre-compute the indices to fasten this. But only 1 active combo means the waste is limited. + const char* items_separated_by_zeros = (const char*)data; + int items_count = 0; + const char* p = items_separated_by_zeros; + while (*p) + { + if (idx == items_count) + break; + p += strlen(p) + 1; + items_count++; + } + if (!*p) + return false; + if (out_text) + *out_text = p; + return true; +} + +// Old API, prefer using BeginCombo() nowadays if you can. +bool ImGui::Combo(const char* label, int* current_item, bool (*items_getter)(void*, int, const char**), void* data, int items_count, int popup_max_height_in_items) +{ + ImGuiContext& g = *GImGui; + + // Call the getter to obtain the preview string which is a parameter to BeginCombo() + const char* preview_value = NULL; + if (*current_item >= 0 && *current_item < items_count) + items_getter(data, *current_item, &preview_value); + + // The old Combo() API exposed "popup_max_height_in_items". The new more general BeginCombo() API doesn't have/need it, but we emulate it here. + if (popup_max_height_in_items != -1 && !(g.NextWindowData.Flags & ImGuiNextWindowDataFlags_HasSizeConstraint)) + SetNextWindowSizeConstraints(ImVec2(0, 0), ImVec2(FLT_MAX, CalcMaxPopupHeightFromItemCount(popup_max_height_in_items))); + + if (!BeginCombo(label, preview_value, ImGuiComboFlags_None)) + return false; + + // Display items + // FIXME-OPT: Use clipper (but we need to disable it on the appearing frame to make sure our call to SetItemDefaultFocus() is processed) + bool value_changed = false; + for (int i = 0; i < items_count; i++) + { + PushID((void*)(intptr_t)i); + const bool item_selected = (i == *current_item); + const char* item_text; + if (!items_getter(data, i, &item_text)) + item_text = "*Unknown item*"; + if (Selectable(item_text, item_selected)) + { + value_changed = true; + *current_item = i; + } + if (item_selected) + SetItemDefaultFocus(); + PopID(); + } + + EndCombo(); + + if (value_changed) + MarkItemEdited(g.LastItemData.ID); + + return value_changed; +} + +// Combo box helper allowing to pass an array of strings. +bool ImGui::Combo(const char* label, int* current_item, const char* const items[], int items_count, int height_in_items) +{ + const bool value_changed = Combo(label, current_item, Items_ArrayGetter, (void*)items, items_count, height_in_items); + return value_changed; +} + +// Combo box helper allowing to pass all items in a single string literal holding multiple zero-terminated items "item1\0item2\0" +bool ImGui::Combo(const char* label, int* current_item, const char* items_separated_by_zeros, int height_in_items) +{ + int items_count = 0; + const char* p = items_separated_by_zeros; // FIXME-OPT: Avoid computing this, or at least only when combo is open + while (*p) + { + p += strlen(p) + 1; + items_count++; + } + bool value_changed = Combo(label, current_item, Items_SingleStringGetter, (void*)items_separated_by_zeros, items_count, height_in_items); + return value_changed; +} + +//------------------------------------------------------------------------- +// [SECTION] Data Type and Data Formatting Helpers [Internal] +//------------------------------------------------------------------------- +// - PatchFormatStringFloatToInt() +// - DataTypeGetInfo() +// - DataTypeFormatString() +// - DataTypeApplyOp() +// - DataTypeApplyOpFromText() +// - DataTypeClamp() +// - GetMinimumStepAtDecimalPrecision +// - RoundScalarWithFormat<>() +//------------------------------------------------------------------------- + +static const ImGuiDataTypeInfo GDataTypeInfo[] = +{ + { sizeof(char), "S8", "%d", "%d" }, // ImGuiDataType_S8 + { sizeof(unsigned char), "U8", "%u", "%u" }, + { sizeof(short), "S16", "%d", "%d" }, // ImGuiDataType_S16 + { sizeof(unsigned short), "U16", "%u", "%u" }, + { sizeof(int), "S32", "%d", "%d" }, // ImGuiDataType_S32 + { sizeof(unsigned int), "U32", "%u", "%u" }, +#ifdef _MSC_VER + { sizeof(ImS64), "S64", "%I64d","%I64d" }, // ImGuiDataType_S64 + { sizeof(ImU64), "U64", "%I64u","%I64u" }, +#else + { sizeof(ImS64), "S64", "%lld", "%lld" }, // ImGuiDataType_S64 + { sizeof(ImU64), "U64", "%llu", "%llu" }, +#endif + { sizeof(float), "float", "%.3f","%f" }, // ImGuiDataType_Float (float are promoted to double in va_arg) + { sizeof(double), "double","%f", "%lf" }, // ImGuiDataType_Double +}; +IM_STATIC_ASSERT(IM_ARRAYSIZE(GDataTypeInfo) == ImGuiDataType_COUNT); + +// FIXME-LEGACY: Prior to 1.61 our DragInt() function internally used floats and because of this the compile-time default value for format was "%.0f". +// Even though we changed the compile-time default, we expect users to have carried %f around, which would break the display of DragInt() calls. +// To honor backward compatibility we are rewriting the format string, unless IMGUI_DISABLE_OBSOLETE_FUNCTIONS is enabled. What could possibly go wrong?! +static const char* PatchFormatStringFloatToInt(const char* fmt) +{ + if (fmt[0] == '%' && fmt[1] == '.' && fmt[2] == '0' && fmt[3] == 'f' && fmt[4] == 0) // Fast legacy path for "%.0f" which is expected to be the most common case. + return "%d"; + const char* fmt_start = ImParseFormatFindStart(fmt); // Find % (if any, and ignore %%) + const char* fmt_end = ImParseFormatFindEnd(fmt_start); // Find end of format specifier, which itself is an exercise of confidence/recklessness (because snprintf is dependent on libc or user). + if (fmt_end > fmt_start && fmt_end[-1] == 'f') + { +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + if (fmt_start == fmt && fmt_end[0] == 0) + return "%d"; + ImGuiContext& g = *GImGui; + ImFormatString(g.TempBuffer, IM_ARRAYSIZE(g.TempBuffer), "%.*s%%d%s", (int)(fmt_start - fmt), fmt, fmt_end); // Honor leading and trailing decorations, but lose alignment/precision. + return g.TempBuffer; +#else + IM_ASSERT(0 && "DragInt(): Invalid format string!"); // Old versions used a default parameter of "%.0f", please replace with e.g. "%d" +#endif + } + return fmt; +} + +const ImGuiDataTypeInfo* ImGui::DataTypeGetInfo(ImGuiDataType data_type) +{ + IM_ASSERT(data_type >= 0 && data_type < ImGuiDataType_COUNT); + return &GDataTypeInfo[data_type]; +} + +int ImGui::DataTypeFormatString(char* buf, int buf_size, ImGuiDataType data_type, const void* p_data, const char* format) +{ + // Signedness doesn't matter when pushing integer arguments + if (data_type == ImGuiDataType_S32 || data_type == ImGuiDataType_U32) + return ImFormatString(buf, buf_size, format, *(const ImU32*)p_data); + if (data_type == ImGuiDataType_S64 || data_type == ImGuiDataType_U64) + return ImFormatString(buf, buf_size, format, *(const ImU64*)p_data); + if (data_type == ImGuiDataType_Float) + return ImFormatString(buf, buf_size, format, *(const float*)p_data); + if (data_type == ImGuiDataType_Double) + return ImFormatString(buf, buf_size, format, *(const double*)p_data); + if (data_type == ImGuiDataType_S8) + return ImFormatString(buf, buf_size, format, *(const ImS8*)p_data); + if (data_type == ImGuiDataType_U8) + return ImFormatString(buf, buf_size, format, *(const ImU8*)p_data); + if (data_type == ImGuiDataType_S16) + return ImFormatString(buf, buf_size, format, *(const ImS16*)p_data); + if (data_type == ImGuiDataType_U16) + return ImFormatString(buf, buf_size, format, *(const ImU16*)p_data); + IM_ASSERT(0); + return 0; +} + +void ImGui::DataTypeApplyOp(ImGuiDataType data_type, int op, void* output, const void* arg1, const void* arg2) +{ + IM_ASSERT(op == '+' || op == '-'); + switch (data_type) + { + case ImGuiDataType_S8: + if (op == '+') { *(ImS8*)output = ImAddClampOverflow(*(const ImS8*)arg1, *(const ImS8*)arg2, IM_S8_MIN, IM_S8_MAX); } + if (op == '-') { *(ImS8*)output = ImSubClampOverflow(*(const ImS8*)arg1, *(const ImS8*)arg2, IM_S8_MIN, IM_S8_MAX); } + return; + case ImGuiDataType_U8: + if (op == '+') { *(ImU8*)output = ImAddClampOverflow(*(const ImU8*)arg1, *(const ImU8*)arg2, IM_U8_MIN, IM_U8_MAX); } + if (op == '-') { *(ImU8*)output = ImSubClampOverflow(*(const ImU8*)arg1, *(const ImU8*)arg2, IM_U8_MIN, IM_U8_MAX); } + return; + case ImGuiDataType_S16: + if (op == '+') { *(ImS16*)output = ImAddClampOverflow(*(const ImS16*)arg1, *(const ImS16*)arg2, IM_S16_MIN, IM_S16_MAX); } + if (op == '-') { *(ImS16*)output = ImSubClampOverflow(*(const ImS16*)arg1, *(const ImS16*)arg2, IM_S16_MIN, IM_S16_MAX); } + return; + case ImGuiDataType_U16: + if (op == '+') { *(ImU16*)output = ImAddClampOverflow(*(const ImU16*)arg1, *(const ImU16*)arg2, IM_U16_MIN, IM_U16_MAX); } + if (op == '-') { *(ImU16*)output = ImSubClampOverflow(*(const ImU16*)arg1, *(const ImU16*)arg2, IM_U16_MIN, IM_U16_MAX); } + return; + case ImGuiDataType_S32: + if (op == '+') { *(ImS32*)output = ImAddClampOverflow(*(const ImS32*)arg1, *(const ImS32*)arg2, IM_S32_MIN, IM_S32_MAX); } + if (op == '-') { *(ImS32*)output = ImSubClampOverflow(*(const ImS32*)arg1, *(const ImS32*)arg2, IM_S32_MIN, IM_S32_MAX); } + return; + case ImGuiDataType_U32: + if (op == '+') { *(ImU32*)output = ImAddClampOverflow(*(const ImU32*)arg1, *(const ImU32*)arg2, IM_U32_MIN, IM_U32_MAX); } + if (op == '-') { *(ImU32*)output = ImSubClampOverflow(*(const ImU32*)arg1, *(const ImU32*)arg2, IM_U32_MIN, IM_U32_MAX); } + return; + case ImGuiDataType_S64: + if (op == '+') { *(ImS64*)output = ImAddClampOverflow(*(const ImS64*)arg1, *(const ImS64*)arg2, IM_S64_MIN, IM_S64_MAX); } + if (op == '-') { *(ImS64*)output = ImSubClampOverflow(*(const ImS64*)arg1, *(const ImS64*)arg2, IM_S64_MIN, IM_S64_MAX); } + return; + case ImGuiDataType_U64: + if (op == '+') { *(ImU64*)output = ImAddClampOverflow(*(const ImU64*)arg1, *(const ImU64*)arg2, IM_U64_MIN, IM_U64_MAX); } + if (op == '-') { *(ImU64*)output = ImSubClampOverflow(*(const ImU64*)arg1, *(const ImU64*)arg2, IM_U64_MIN, IM_U64_MAX); } + return; + case ImGuiDataType_Float: + if (op == '+') { *(float*)output = *(const float*)arg1 + *(const float*)arg2; } + if (op == '-') { *(float*)output = *(const float*)arg1 - *(const float*)arg2; } + return; + case ImGuiDataType_Double: + if (op == '+') { *(double*)output = *(const double*)arg1 + *(const double*)arg2; } + if (op == '-') { *(double*)output = *(const double*)arg1 - *(const double*)arg2; } + return; + case ImGuiDataType_COUNT: break; + } + IM_ASSERT(0); +} + +// User can input math operators (e.g. +100) to edit a numerical values. +// NB: This is _not_ a full expression evaluator. We should probably add one and replace this dumb mess.. +bool ImGui::DataTypeApplyOpFromText(const char* buf, const char* initial_value_buf, ImGuiDataType data_type, void* p_data, const char* format) +{ + while (ImCharIsBlankA(*buf)) + buf++; + + // We don't support '-' op because it would conflict with inputing negative value. + // Instead you can use +-100 to subtract from an existing value + char op = buf[0]; + if (op == '+' || op == '*' || op == '/') + { + buf++; + while (ImCharIsBlankA(*buf)) + buf++; + } + else + { + op = 0; + } + if (!buf[0]) + return false; + + // Copy the value in an opaque buffer so we can compare at the end of the function if it changed at all. + const ImGuiDataTypeInfo* type_info = DataTypeGetInfo(data_type); + ImGuiDataTypeTempStorage data_backup; + memcpy(&data_backup, p_data, type_info->Size); + + if (format == NULL) + format = type_info->ScanFmt; + + // FIXME-LEGACY: The aim is to remove those operators and write a proper expression evaluator at some point.. + int arg1i = 0; + if (data_type == ImGuiDataType_S32) + { + int* v = (int*)p_data; + int arg0i = *v; + float arg1f = 0.0f; + if (op && sscanf(initial_value_buf, format, &arg0i) < 1) + return false; + // Store operand in a float so we can use fractional value for multipliers (*1.1), but constant always parsed as integer so we can fit big integers (e.g. 2000000003) past float precision + if (op == '+') { if (sscanf(buf, "%d", &arg1i)) *v = (int)(arg0i + arg1i); } // Add (use "+-" to subtract) + else if (op == '*') { if (sscanf(buf, "%f", &arg1f)) *v = (int)(arg0i * arg1f); } // Multiply + else if (op == '/') { if (sscanf(buf, "%f", &arg1f) && arg1f != 0.0f) *v = (int)(arg0i / arg1f); } // Divide + else { if (sscanf(buf, format, &arg1i) == 1) *v = arg1i; } // Assign constant + } + else if (data_type == ImGuiDataType_Float) + { + // For floats we have to ignore format with precision (e.g. "%.2f") because sscanf doesn't take them in + format = "%f"; + float* v = (float*)p_data; + float arg0f = *v, arg1f = 0.0f; + if (op && sscanf(initial_value_buf, format, &arg0f) < 1) + return false; + if (sscanf(buf, format, &arg1f) < 1) + return false; + if (op == '+') { *v = arg0f + arg1f; } // Add (use "+-" to subtract) + else if (op == '*') { *v = arg0f * arg1f; } // Multiply + else if (op == '/') { if (arg1f != 0.0f) *v = arg0f / arg1f; } // Divide + else { *v = arg1f; } // Assign constant + } + else if (data_type == ImGuiDataType_Double) + { + format = "%lf"; // scanf differentiate float/double unlike printf which forces everything to double because of ellipsis + double* v = (double*)p_data; + double arg0f = *v, arg1f = 0.0; + if (op && sscanf(initial_value_buf, format, &arg0f) < 1) + return false; + if (sscanf(buf, format, &arg1f) < 1) + return false; + if (op == '+') { *v = arg0f + arg1f; } // Add (use "+-" to subtract) + else if (op == '*') { *v = arg0f * arg1f; } // Multiply + else if (op == '/') { if (arg1f != 0.0f) *v = arg0f / arg1f; } // Divide + else { *v = arg1f; } // Assign constant + } + else if (data_type == ImGuiDataType_U32 || data_type == ImGuiDataType_S64 || data_type == ImGuiDataType_U64) + { + // All other types assign constant + // We don't bother handling support for legacy operators since they are a little too crappy. Instead we will later implement a proper expression evaluator in the future. + if (sscanf(buf, format, p_data) < 1) + return false; + } + else + { + // Small types need a 32-bit buffer to receive the result from scanf() + int v32; + if (sscanf(buf, format, &v32) < 1) + return false; + if (data_type == ImGuiDataType_S8) + *(ImS8*)p_data = (ImS8)ImClamp(v32, (int)IM_S8_MIN, (int)IM_S8_MAX); + else if (data_type == ImGuiDataType_U8) + *(ImU8*)p_data = (ImU8)ImClamp(v32, (int)IM_U8_MIN, (int)IM_U8_MAX); + else if (data_type == ImGuiDataType_S16) + *(ImS16*)p_data = (ImS16)ImClamp(v32, (int)IM_S16_MIN, (int)IM_S16_MAX); + else if (data_type == ImGuiDataType_U16) + *(ImU16*)p_data = (ImU16)ImClamp(v32, (int)IM_U16_MIN, (int)IM_U16_MAX); + else + IM_ASSERT(0); + } + + return memcmp(&data_backup, p_data, type_info->Size) != 0; +} + +template +static int DataTypeCompareT(const T* lhs, const T* rhs) +{ + if (*lhs < *rhs) return -1; + if (*lhs > *rhs) return +1; + return 0; +} + +int ImGui::DataTypeCompare(ImGuiDataType data_type, const void* arg_1, const void* arg_2) +{ + switch (data_type) + { + case ImGuiDataType_S8: return DataTypeCompareT((const ImS8* )arg_1, (const ImS8* )arg_2); + case ImGuiDataType_U8: return DataTypeCompareT((const ImU8* )arg_1, (const ImU8* )arg_2); + case ImGuiDataType_S16: return DataTypeCompareT((const ImS16* )arg_1, (const ImS16* )arg_2); + case ImGuiDataType_U16: return DataTypeCompareT((const ImU16* )arg_1, (const ImU16* )arg_2); + case ImGuiDataType_S32: return DataTypeCompareT((const ImS32* )arg_1, (const ImS32* )arg_2); + case ImGuiDataType_U32: return DataTypeCompareT((const ImU32* )arg_1, (const ImU32* )arg_2); + case ImGuiDataType_S64: return DataTypeCompareT((const ImS64* )arg_1, (const ImS64* )arg_2); + case ImGuiDataType_U64: return DataTypeCompareT((const ImU64* )arg_1, (const ImU64* )arg_2); + case ImGuiDataType_Float: return DataTypeCompareT((const float* )arg_1, (const float* )arg_2); + case ImGuiDataType_Double: return DataTypeCompareT((const double*)arg_1, (const double*)arg_2); + case ImGuiDataType_COUNT: break; + } + IM_ASSERT(0); + return 0; +} + +template +static bool DataTypeClampT(T* v, const T* v_min, const T* v_max) +{ + // Clamp, both sides are optional, return true if modified + if (v_min && *v < *v_min) { *v = *v_min; return true; } + if (v_max && *v > *v_max) { *v = *v_max; return true; } + return false; +} + +bool ImGui::DataTypeClamp(ImGuiDataType data_type, void* p_data, const void* p_min, const void* p_max) +{ + switch (data_type) + { + case ImGuiDataType_S8: return DataTypeClampT((ImS8* )p_data, (const ImS8* )p_min, (const ImS8* )p_max); + case ImGuiDataType_U8: return DataTypeClampT((ImU8* )p_data, (const ImU8* )p_min, (const ImU8* )p_max); + case ImGuiDataType_S16: return DataTypeClampT((ImS16* )p_data, (const ImS16* )p_min, (const ImS16* )p_max); + case ImGuiDataType_U16: return DataTypeClampT((ImU16* )p_data, (const ImU16* )p_min, (const ImU16* )p_max); + case ImGuiDataType_S32: return DataTypeClampT((ImS32* )p_data, (const ImS32* )p_min, (const ImS32* )p_max); + case ImGuiDataType_U32: return DataTypeClampT((ImU32* )p_data, (const ImU32* )p_min, (const ImU32* )p_max); + case ImGuiDataType_S64: return DataTypeClampT((ImS64* )p_data, (const ImS64* )p_min, (const ImS64* )p_max); + case ImGuiDataType_U64: return DataTypeClampT((ImU64* )p_data, (const ImU64* )p_min, (const ImU64* )p_max); + case ImGuiDataType_Float: return DataTypeClampT((float* )p_data, (const float* )p_min, (const float* )p_max); + case ImGuiDataType_Double: return DataTypeClampT((double*)p_data, (const double*)p_min, (const double*)p_max); + case ImGuiDataType_COUNT: break; + } + IM_ASSERT(0); + return false; +} + +static float GetMinimumStepAtDecimalPrecision(int decimal_precision) +{ + static const float min_steps[10] = { 1.0f, 0.1f, 0.01f, 0.001f, 0.0001f, 0.00001f, 0.000001f, 0.0000001f, 0.00000001f, 0.000000001f }; + if (decimal_precision < 0) + return FLT_MIN; + return (decimal_precision < IM_ARRAYSIZE(min_steps)) ? min_steps[decimal_precision] : ImPow(10.0f, (float)-decimal_precision); +} + +template +static const char* ImAtoi(const char* src, TYPE* output) +{ + int negative = 0; + if (*src == '-') { negative = 1; src++; } + if (*src == '+') { src++; } + TYPE v = 0; + while (*src >= '0' && *src <= '9') + v = (v * 10) + (*src++ - '0'); + *output = negative ? -v : v; + return src; +} + +// Sanitize format +// - Zero terminate so extra characters after format (e.g. "%f123") don't confuse atof/atoi +// - stb_sprintf.h supports several new modifiers which format numbers in a way that also makes them incompatible atof/atoi. +static void SanitizeFormatString(const char* fmt, char* fmt_out, size_t fmt_out_size) +{ + IM_UNUSED(fmt_out_size); + const char* fmt_end = ImParseFormatFindEnd(fmt); + IM_ASSERT((size_t)(fmt_end - fmt + 1) < fmt_out_size); // Format is too long, let us know if this happens to you! + while (fmt < fmt_end) + { + char c = *(fmt++); + if (c != '\'' && c != '$' && c != '_') // Custom flags provided by stb_sprintf.h. POSIX 2008 also supports '. + *(fmt_out++) = c; + } + *fmt_out = 0; // Zero-terminate +} + +template +TYPE ImGui::RoundScalarWithFormatT(const char* format, ImGuiDataType data_type, TYPE v) +{ + const char* fmt_start = ImParseFormatFindStart(format); + if (fmt_start[0] != '%' || fmt_start[1] == '%') // Don't apply if the value is not visible in the format string + return v; + + // Sanitize format + char fmt_sanitized[32]; + SanitizeFormatString(fmt_start, fmt_sanitized, IM_ARRAYSIZE(fmt_sanitized)); + fmt_start = fmt_sanitized; + + // Format value with our rounding, and read back + char v_str[64]; + ImFormatString(v_str, IM_ARRAYSIZE(v_str), fmt_start, v); + const char* p = v_str; + while (*p == ' ') + p++; + if (data_type == ImGuiDataType_Float || data_type == ImGuiDataType_Double) + v = (TYPE)ImAtof(p); + else + ImAtoi(p, (SIGNEDTYPE*)&v); + return v; +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: DragScalar, DragFloat, DragInt, etc. +//------------------------------------------------------------------------- +// - DragBehaviorT<>() [Internal] +// - DragBehavior() [Internal] +// - DragScalar() +// - DragScalarN() +// - DragFloat() +// - DragFloat2() +// - DragFloat3() +// - DragFloat4() +// - DragFloatRange2() +// - DragInt() +// - DragInt2() +// - DragInt3() +// - DragInt4() +// - DragIntRange2() +//------------------------------------------------------------------------- + +// This is called by DragBehavior() when the widget is active (held by mouse or being manipulated with Nav controls) +template +bool ImGui::DragBehaviorT(ImGuiDataType data_type, TYPE* v, float v_speed, const TYPE v_min, const TYPE v_max, const char* format, ImGuiSliderFlags flags) +{ + ImGuiContext& g = *GImGui; + const ImGuiAxis axis = (flags & ImGuiSliderFlags_Vertical) ? ImGuiAxis_Y : ImGuiAxis_X; + const bool is_clamped = (v_min < v_max); + const bool is_logarithmic = (flags & ImGuiSliderFlags_Logarithmic) != 0; + const bool is_floating_point = (data_type == ImGuiDataType_Float) || (data_type == ImGuiDataType_Double); + + // Default tweak speed + if (v_speed == 0.0f && is_clamped && (v_max - v_min < FLT_MAX)) + v_speed = (float)((v_max - v_min) * g.DragSpeedDefaultRatio); + + // Inputs accumulates into g.DragCurrentAccum, which is flushed into the current value as soon as it makes a difference with our precision settings + float adjust_delta = 0.0f; + if (g.ActiveIdSource == ImGuiInputSource_Mouse && IsMousePosValid() && IsMouseDragPastThreshold(0, g.IO.MouseDragThreshold * DRAG_MOUSE_THRESHOLD_FACTOR)) + { + adjust_delta = g.IO.MouseDelta[axis]; + if (g.IO.KeyAlt) + adjust_delta *= 1.0f / 100.0f; + if (g.IO.KeyShift) + adjust_delta *= 10.0f; + } + else if (g.ActiveIdSource == ImGuiInputSource_Nav) + { + const int decimal_precision = is_floating_point ? ImParseFormatPrecision(format, 3) : 0; + adjust_delta = GetNavInputAmount2d(ImGuiNavDirSourceFlags_Keyboard | ImGuiNavDirSourceFlags_PadDPad, ImGuiInputReadMode_RepeatFast, 1.0f / 10.0f, 10.0f)[axis]; + v_speed = ImMax(v_speed, GetMinimumStepAtDecimalPrecision(decimal_precision)); + } + adjust_delta *= v_speed; + + // For vertical drag we currently assume that Up=higher value (like we do with vertical sliders). This may become a parameter. + if (axis == ImGuiAxis_Y) + adjust_delta = -adjust_delta; + + // For logarithmic use our range is effectively 0..1 so scale the delta into that range + if (is_logarithmic && (v_max - v_min < FLT_MAX) && ((v_max - v_min) > 0.000001f)) // Epsilon to avoid /0 + adjust_delta /= (float)(v_max - v_min); + + // Clear current value on activation + // Avoid altering values and clamping when we are _already_ past the limits and heading in the same direction, so e.g. if range is 0..255, current value is 300 and we are pushing to the right side, keep the 300. + bool is_just_activated = g.ActiveIdIsJustActivated; + bool is_already_past_limits_and_pushing_outward = is_clamped && ((*v >= v_max && adjust_delta > 0.0f) || (*v <= v_min && adjust_delta < 0.0f)); + if (is_just_activated || is_already_past_limits_and_pushing_outward) + { + g.DragCurrentAccum = 0.0f; + g.DragCurrentAccumDirty = false; + } + else if (adjust_delta != 0.0f) + { + g.DragCurrentAccum += adjust_delta; + g.DragCurrentAccumDirty = true; + } + + if (!g.DragCurrentAccumDirty) + return false; + + TYPE v_cur = *v; + FLOATTYPE v_old_ref_for_accum_remainder = (FLOATTYPE)0.0f; + + float logarithmic_zero_epsilon = 0.0f; // Only valid when is_logarithmic is true + const float zero_deadzone_halfsize = 0.0f; // Drag widgets have no deadzone (as it doesn't make sense) + if (is_logarithmic) + { + // When using logarithmic sliders, we need to clamp to avoid hitting zero, but our choice of clamp value greatly affects slider precision. We attempt to use the specified precision to estimate a good lower bound. + const int decimal_precision = is_floating_point ? ImParseFormatPrecision(format, 3) : 1; + logarithmic_zero_epsilon = ImPow(0.1f, (float)decimal_precision); + + // Convert to parametric space, apply delta, convert back + float v_old_parametric = ScaleRatioFromValueT(data_type, v_cur, v_min, v_max, is_logarithmic, logarithmic_zero_epsilon, zero_deadzone_halfsize); + float v_new_parametric = v_old_parametric + g.DragCurrentAccum; + v_cur = ScaleValueFromRatioT(data_type, v_new_parametric, v_min, v_max, is_logarithmic, logarithmic_zero_epsilon, zero_deadzone_halfsize); + v_old_ref_for_accum_remainder = v_old_parametric; + } + else + { + v_cur += (SIGNEDTYPE)g.DragCurrentAccum; + } + + // Round to user desired precision based on format string + if (!(flags & ImGuiSliderFlags_NoRoundToFormat)) + v_cur = RoundScalarWithFormatT(format, data_type, v_cur); + + // Preserve remainder after rounding has been applied. This also allow slow tweaking of values. + g.DragCurrentAccumDirty = false; + if (is_logarithmic) + { + // Convert to parametric space, apply delta, convert back + float v_new_parametric = ScaleRatioFromValueT(data_type, v_cur, v_min, v_max, is_logarithmic, logarithmic_zero_epsilon, zero_deadzone_halfsize); + g.DragCurrentAccum -= (float)(v_new_parametric - v_old_ref_for_accum_remainder); + } + else + { + g.DragCurrentAccum -= (float)((SIGNEDTYPE)v_cur - (SIGNEDTYPE)*v); + } + + // Lose zero sign for float/double + if (v_cur == (TYPE)-0) + v_cur = (TYPE)0; + + // Clamp values (+ handle overflow/wrap-around for integer types) + if (*v != v_cur && is_clamped) + { + if (v_cur < v_min || (v_cur > *v && adjust_delta < 0.0f && !is_floating_point)) + v_cur = v_min; + if (v_cur > v_max || (v_cur < *v && adjust_delta > 0.0f && !is_floating_point)) + v_cur = v_max; + } + + // Apply result + if (*v == v_cur) + return false; + *v = v_cur; + return true; +} + +bool ImGui::DragBehavior(ImGuiID id, ImGuiDataType data_type, void* p_v, float v_speed, const void* p_min, const void* p_max, const char* format, ImGuiSliderFlags flags) +{ + // Read imgui.cpp "API BREAKING CHANGES" section for 1.78 if you hit this assert. + IM_ASSERT((flags == 1 || (flags & ImGuiSliderFlags_InvalidMask_) == 0) && "Invalid ImGuiSliderFlags flags! Has the 'float power' argument been mistakenly cast to flags? Call function with ImGuiSliderFlags_Logarithmic flags instead."); + + ImGuiContext& g = *GImGui; + if (g.ActiveId == id) + { + if (g.ActiveIdSource == ImGuiInputSource_Mouse && !g.IO.MouseDown[0]) + ClearActiveID(); + else if (g.ActiveIdSource == ImGuiInputSource_Nav && g.NavActivatePressedId == id && !g.ActiveIdIsJustActivated) + ClearActiveID(); + } + if (g.ActiveId != id) + return false; + if ((g.LastItemData.InFlags & ImGuiItemFlags_ReadOnly) || (flags & ImGuiSliderFlags_ReadOnly)) + return false; + + switch (data_type) + { + case ImGuiDataType_S8: { ImS32 v32 = (ImS32)*(ImS8*)p_v; bool r = DragBehaviorT(ImGuiDataType_S32, &v32, v_speed, p_min ? *(const ImS8*) p_min : IM_S8_MIN, p_max ? *(const ImS8*)p_max : IM_S8_MAX, format, flags); if (r) *(ImS8*)p_v = (ImS8)v32; return r; } + case ImGuiDataType_U8: { ImU32 v32 = (ImU32)*(ImU8*)p_v; bool r = DragBehaviorT(ImGuiDataType_U32, &v32, v_speed, p_min ? *(const ImU8*) p_min : IM_U8_MIN, p_max ? *(const ImU8*)p_max : IM_U8_MAX, format, flags); if (r) *(ImU8*)p_v = (ImU8)v32; return r; } + case ImGuiDataType_S16: { ImS32 v32 = (ImS32)*(ImS16*)p_v; bool r = DragBehaviorT(ImGuiDataType_S32, &v32, v_speed, p_min ? *(const ImS16*)p_min : IM_S16_MIN, p_max ? *(const ImS16*)p_max : IM_S16_MAX, format, flags); if (r) *(ImS16*)p_v = (ImS16)v32; return r; } + case ImGuiDataType_U16: { ImU32 v32 = (ImU32)*(ImU16*)p_v; bool r = DragBehaviorT(ImGuiDataType_U32, &v32, v_speed, p_min ? *(const ImU16*)p_min : IM_U16_MIN, p_max ? *(const ImU16*)p_max : IM_U16_MAX, format, flags); if (r) *(ImU16*)p_v = (ImU16)v32; return r; } + case ImGuiDataType_S32: return DragBehaviorT(data_type, (ImS32*)p_v, v_speed, p_min ? *(const ImS32* )p_min : IM_S32_MIN, p_max ? *(const ImS32* )p_max : IM_S32_MAX, format, flags); + case ImGuiDataType_U32: return DragBehaviorT(data_type, (ImU32*)p_v, v_speed, p_min ? *(const ImU32* )p_min : IM_U32_MIN, p_max ? *(const ImU32* )p_max : IM_U32_MAX, format, flags); + case ImGuiDataType_S64: return DragBehaviorT(data_type, (ImS64*)p_v, v_speed, p_min ? *(const ImS64* )p_min : IM_S64_MIN, p_max ? *(const ImS64* )p_max : IM_S64_MAX, format, flags); + case ImGuiDataType_U64: return DragBehaviorT(data_type, (ImU64*)p_v, v_speed, p_min ? *(const ImU64* )p_min : IM_U64_MIN, p_max ? *(const ImU64* )p_max : IM_U64_MAX, format, flags); + case ImGuiDataType_Float: return DragBehaviorT(data_type, (float*)p_v, v_speed, p_min ? *(const float* )p_min : -FLT_MAX, p_max ? *(const float* )p_max : FLT_MAX, format, flags); + case ImGuiDataType_Double: return DragBehaviorT(data_type, (double*)p_v, v_speed, p_min ? *(const double*)p_min : -DBL_MAX, p_max ? *(const double*)p_max : DBL_MAX, format, flags); + case ImGuiDataType_COUNT: break; + } + IM_ASSERT(0); + return false; +} + +// Note: p_data, p_min and p_max are _pointers_ to a memory address holding the data. For a Drag widget, p_min and p_max are optional. +// Read code of e.g. DragFloat(), DragInt() etc. or examples in 'Demo->Widgets->Data Types' to understand how to use this function directly. +bool ImGui::DragScalar(const char* label, ImGuiDataType data_type, void* p_data, float v_speed, const void* p_min, const void* p_max, const char* format, ImGuiSliderFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + const ImGuiID id = window->GetID(label); + const float w = CalcItemWidth(); + + const ImVec2 label_size = CalcTextSize(label, NULL, true); + const ImRect frame_bb(window->DC.CursorPos, window->DC.CursorPos + ImVec2(w, label_size.y + style.FramePadding.y * 2.0f)); + const ImRect total_bb(frame_bb.Min, frame_bb.Max + ImVec2(label_size.x > 0.0f ? style.ItemInnerSpacing.x + label_size.x : 0.0f, 0.0f)); + + const bool temp_input_allowed = (flags & ImGuiSliderFlags_NoInput) == 0; + ItemSize(total_bb, style.FramePadding.y); + if (!ItemAdd(total_bb, id, &frame_bb, temp_input_allowed ? ImGuiItemFlags_Inputable : 0)) + return false; + + // Default format string when passing NULL + if (format == NULL) + format = DataTypeGetInfo(data_type)->PrintFmt; + else if (data_type == ImGuiDataType_S32 && strcmp(format, "%d") != 0) // (FIXME-LEGACY: Patch old "%.0f" format string to use "%d", read function more details.) + format = PatchFormatStringFloatToInt(format); + + // Tabbing or CTRL-clicking on Drag turns it into an InputText + const bool hovered = ItemHoverable(frame_bb, id); + bool temp_input_is_active = temp_input_allowed && TempInputIsActive(id); + if (!temp_input_is_active) + { + const bool focus_requested = temp_input_allowed && (g.LastItemData.StatusFlags & ImGuiItemStatusFlags_Focused) != 0; + const bool clicked = (hovered && g.IO.MouseClicked[0]); + const bool double_clicked = (hovered && g.IO.MouseDoubleClicked[0]); + if (focus_requested || clicked || double_clicked || g.NavActivateId == id || g.NavActivateInputId == id) + { + SetActiveID(id, window); + SetFocusID(id, window); + FocusWindow(window); + g.ActiveIdUsingNavDirMask = (1 << ImGuiDir_Left) | (1 << ImGuiDir_Right); + if (temp_input_allowed) + if (focus_requested || (clicked && g.IO.KeyCtrl) || double_clicked || g.NavActivateInputId == id) + temp_input_is_active = true; + } + + // Experimental: simple click (without moving) turns Drag into an InputText + if (g.IO.ConfigDragClickToInputText && temp_input_allowed && !temp_input_is_active) + if (g.ActiveId == id && hovered && g.IO.MouseReleased[0] && !IsMouseDragPastThreshold(0, g.IO.MouseDragThreshold * DRAG_MOUSE_THRESHOLD_FACTOR)) + { + g.NavActivateId = g.NavActivateInputId = id; + g.NavActivateFlags = ImGuiActivateFlags_PreferInput; + temp_input_is_active = true; + } + } + + if (temp_input_is_active) + { + // Only clamp CTRL+Click input when ImGuiSliderFlags_AlwaysClamp is set + const bool is_clamp_input = (flags & ImGuiSliderFlags_AlwaysClamp) != 0 && (p_min == NULL || p_max == NULL || DataTypeCompare(data_type, p_min, p_max) < 0); + return TempInputScalar(frame_bb, id, label, data_type, p_data, format, is_clamp_input ? p_min : NULL, is_clamp_input ? p_max : NULL); + } + + // Draw frame + const ImU32 frame_col = GetColorU32(g.ActiveId == id ? ImGuiCol_FrameBgActive : hovered ? ImGuiCol_FrameBgHovered : ImGuiCol_FrameBg); + RenderNavHighlight(frame_bb, id); + RenderFrame(frame_bb.Min, frame_bb.Max, frame_col, true, style.FrameRounding); + + // Drag behavior + const bool value_changed = DragBehavior(id, data_type, p_data, v_speed, p_min, p_max, format, flags); + if (value_changed) + MarkItemEdited(id); + + // Display value using user-provided display format so user can add prefix/suffix/decorations to the value. + char value_buf[64]; + const char* value_buf_end = value_buf + DataTypeFormatString(value_buf, IM_ARRAYSIZE(value_buf), data_type, p_data, format); + if (g.LogEnabled) + LogSetNextTextDecoration("{", "}"); + RenderTextClipped(frame_bb.Min, frame_bb.Max, value_buf, value_buf_end, NULL, ImVec2(0.5f, 0.5f)); + + if (label_size.x > 0.0f) + RenderText(ImVec2(frame_bb.Max.x + style.ItemInnerSpacing.x, frame_bb.Min.y + style.FramePadding.y), label); + + IMGUI_TEST_ENGINE_ITEM_INFO(id, label, g.LastItemData.StatusFlags); + return value_changed; +} + +bool ImGui::DragScalarN(const char* label, ImGuiDataType data_type, void* p_data, int components, float v_speed, const void* p_min, const void* p_max, const char* format, ImGuiSliderFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + bool value_changed = false; + BeginGroup(); + PushID(label); + PushMultiItemsWidths(components, CalcItemWidth()); + size_t type_size = GDataTypeInfo[data_type].Size; + for (int i = 0; i < components; i++) + { + PushID(i); + if (i > 0) + SameLine(0, g.Style.ItemInnerSpacing.x); + value_changed |= DragScalar("", data_type, p_data, v_speed, p_min, p_max, format, flags); + PopID(); + PopItemWidth(); + p_data = (void*)((char*)p_data + type_size); + } + PopID(); + + const char* label_end = FindRenderedTextEnd(label); + if (label != label_end) + { + SameLine(0, g.Style.ItemInnerSpacing.x); + TextEx(label, label_end); + } + + EndGroup(); + return value_changed; +} + +bool ImGui::DragFloat(const char* label, float* v, float v_speed, float v_min, float v_max, const char* format, ImGuiSliderFlags flags) +{ + return DragScalar(label, ImGuiDataType_Float, v, v_speed, &v_min, &v_max, format, flags); +} + +bool ImGui::DragFloat2(const char* label, float v[2], float v_speed, float v_min, float v_max, const char* format, ImGuiSliderFlags flags) +{ + return DragScalarN(label, ImGuiDataType_Float, v, 2, v_speed, &v_min, &v_max, format, flags); +} + +bool ImGui::DragFloat3(const char* label, float v[3], float v_speed, float v_min, float v_max, const char* format, ImGuiSliderFlags flags) +{ + return DragScalarN(label, ImGuiDataType_Float, v, 3, v_speed, &v_min, &v_max, format, flags); +} + +bool ImGui::DragFloat4(const char* label, float v[4], float v_speed, float v_min, float v_max, const char* format, ImGuiSliderFlags flags) +{ + return DragScalarN(label, ImGuiDataType_Float, v, 4, v_speed, &v_min, &v_max, format, flags); +} + +// NB: You likely want to specify the ImGuiSliderFlags_AlwaysClamp when using this. +bool ImGui::DragFloatRange2(const char* label, float* v_current_min, float* v_current_max, float v_speed, float v_min, float v_max, const char* format, const char* format_max, ImGuiSliderFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + PushID(label); + BeginGroup(); + PushMultiItemsWidths(2, CalcItemWidth()); + + float min_min = (v_min >= v_max) ? -FLT_MAX : v_min; + float min_max = (v_min >= v_max) ? *v_current_max : ImMin(v_max, *v_current_max); + ImGuiSliderFlags min_flags = flags | ((min_min == min_max) ? ImGuiSliderFlags_ReadOnly : 0); + bool value_changed = DragScalar("##min", ImGuiDataType_Float, v_current_min, v_speed, &min_min, &min_max, format, min_flags); + PopItemWidth(); + SameLine(0, g.Style.ItemInnerSpacing.x); + + float max_min = (v_min >= v_max) ? *v_current_min : ImMax(v_min, *v_current_min); + float max_max = (v_min >= v_max) ? FLT_MAX : v_max; + ImGuiSliderFlags max_flags = flags | ((max_min == max_max) ? ImGuiSliderFlags_ReadOnly : 0); + value_changed |= DragScalar("##max", ImGuiDataType_Float, v_current_max, v_speed, &max_min, &max_max, format_max ? format_max : format, max_flags); + PopItemWidth(); + SameLine(0, g.Style.ItemInnerSpacing.x); + + TextEx(label, FindRenderedTextEnd(label)); + EndGroup(); + PopID(); + + return value_changed; +} + +// NB: v_speed is float to allow adjusting the drag speed with more precision +bool ImGui::DragInt(const char* label, int* v, float v_speed, int v_min, int v_max, const char* format, ImGuiSliderFlags flags) +{ + return DragScalar(label, ImGuiDataType_S32, v, v_speed, &v_min, &v_max, format, flags); +} + +bool ImGui::DragInt2(const char* label, int v[2], float v_speed, int v_min, int v_max, const char* format, ImGuiSliderFlags flags) +{ + return DragScalarN(label, ImGuiDataType_S32, v, 2, v_speed, &v_min, &v_max, format, flags); +} + +bool ImGui::DragInt3(const char* label, int v[3], float v_speed, int v_min, int v_max, const char* format, ImGuiSliderFlags flags) +{ + return DragScalarN(label, ImGuiDataType_S32, v, 3, v_speed, &v_min, &v_max, format, flags); +} + +bool ImGui::DragInt4(const char* label, int v[4], float v_speed, int v_min, int v_max, const char* format, ImGuiSliderFlags flags) +{ + return DragScalarN(label, ImGuiDataType_S32, v, 4, v_speed, &v_min, &v_max, format, flags); +} + +// NB: You likely want to specify the ImGuiSliderFlags_AlwaysClamp when using this. +bool ImGui::DragIntRange2(const char* label, int* v_current_min, int* v_current_max, float v_speed, int v_min, int v_max, const char* format, const char* format_max, ImGuiSliderFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + PushID(label); + BeginGroup(); + PushMultiItemsWidths(2, CalcItemWidth()); + + int min_min = (v_min >= v_max) ? INT_MIN : v_min; + int min_max = (v_min >= v_max) ? *v_current_max : ImMin(v_max, *v_current_max); + ImGuiSliderFlags min_flags = flags | ((min_min == min_max) ? ImGuiSliderFlags_ReadOnly : 0); + bool value_changed = DragInt("##min", v_current_min, v_speed, min_min, min_max, format, min_flags); + PopItemWidth(); + SameLine(0, g.Style.ItemInnerSpacing.x); + + int max_min = (v_min >= v_max) ? *v_current_min : ImMax(v_min, *v_current_min); + int max_max = (v_min >= v_max) ? INT_MAX : v_max; + ImGuiSliderFlags max_flags = flags | ((max_min == max_max) ? ImGuiSliderFlags_ReadOnly : 0); + value_changed |= DragInt("##max", v_current_max, v_speed, max_min, max_max, format_max ? format_max : format, max_flags); + PopItemWidth(); + SameLine(0, g.Style.ItemInnerSpacing.x); + + TextEx(label, FindRenderedTextEnd(label)); + EndGroup(); + PopID(); + + return value_changed; +} + +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + +// Obsolete versions with power parameter. See https://github.com/ocornut/imgui/issues/3361 for details. +bool ImGui::DragScalar(const char* label, ImGuiDataType data_type, void* p_data, float v_speed, const void* p_min, const void* p_max, const char* format, float power) +{ + ImGuiSliderFlags drag_flags = ImGuiSliderFlags_None; + if (power != 1.0f) + { + IM_ASSERT(power == 1.0f && "Call function with ImGuiSliderFlags_Logarithmic flags instead of using the old 'float power' function!"); + IM_ASSERT(p_min != NULL && p_max != NULL); // When using a power curve the drag needs to have known bounds + drag_flags |= ImGuiSliderFlags_Logarithmic; // Fallback for non-asserting paths + } + return DragScalar(label, data_type, p_data, v_speed, p_min, p_max, format, drag_flags); +} + +bool ImGui::DragScalarN(const char* label, ImGuiDataType data_type, void* p_data, int components, float v_speed, const void* p_min, const void* p_max, const char* format, float power) +{ + ImGuiSliderFlags drag_flags = ImGuiSliderFlags_None; + if (power != 1.0f) + { + IM_ASSERT(power == 1.0f && "Call function with ImGuiSliderFlags_Logarithmic flags instead of using the old 'float power' function!"); + IM_ASSERT(p_min != NULL && p_max != NULL); // When using a power curve the drag needs to have known bounds + drag_flags |= ImGuiSliderFlags_Logarithmic; // Fallback for non-asserting paths + } + return DragScalarN(label, data_type, p_data, components, v_speed, p_min, p_max, format, drag_flags); +} + +#endif // IMGUI_DISABLE_OBSOLETE_FUNCTIONS + +//------------------------------------------------------------------------- +// [SECTION] Widgets: SliderScalar, SliderFloat, SliderInt, etc. +//------------------------------------------------------------------------- +// - ScaleRatioFromValueT<> [Internal] +// - ScaleValueFromRatioT<> [Internal] +// - SliderBehaviorT<>() [Internal] +// - SliderBehavior() [Internal] +// - SliderScalar() +// - SliderScalarN() +// - SliderFloat() +// - SliderFloat2() +// - SliderFloat3() +// - SliderFloat4() +// - SliderAngle() +// - SliderInt() +// - SliderInt2() +// - SliderInt3() +// - SliderInt4() +// - VSliderScalar() +// - VSliderFloat() +// - VSliderInt() +//------------------------------------------------------------------------- + +// Convert a value v in the output space of a slider into a parametric position on the slider itself (the logical opposite of ScaleValueFromRatioT) +template +float ImGui::ScaleRatioFromValueT(ImGuiDataType data_type, TYPE v, TYPE v_min, TYPE v_max, bool is_logarithmic, float logarithmic_zero_epsilon, float zero_deadzone_halfsize) +{ + if (v_min == v_max) + return 0.0f; + IM_UNUSED(data_type); + + const TYPE v_clamped = (v_min < v_max) ? ImClamp(v, v_min, v_max) : ImClamp(v, v_max, v_min); + if (is_logarithmic) + { + bool flipped = v_max < v_min; + + if (flipped) // Handle the case where the range is backwards + ImSwap(v_min, v_max); + + // Fudge min/max to avoid getting close to log(0) + FLOATTYPE v_min_fudged = (ImAbs((FLOATTYPE)v_min) < logarithmic_zero_epsilon) ? ((v_min < 0.0f) ? -logarithmic_zero_epsilon : logarithmic_zero_epsilon) : (FLOATTYPE)v_min; + FLOATTYPE v_max_fudged = (ImAbs((FLOATTYPE)v_max) < logarithmic_zero_epsilon) ? ((v_max < 0.0f) ? -logarithmic_zero_epsilon : logarithmic_zero_epsilon) : (FLOATTYPE)v_max; + + // Awkward special cases - we need ranges of the form (-100 .. 0) to convert to (-100 .. -epsilon), not (-100 .. epsilon) + if ((v_min == 0.0f) && (v_max < 0.0f)) + v_min_fudged = -logarithmic_zero_epsilon; + else if ((v_max == 0.0f) && (v_min < 0.0f)) + v_max_fudged = -logarithmic_zero_epsilon; + + float result; + + if (v_clamped <= v_min_fudged) + result = 0.0f; // Workaround for values that are in-range but below our fudge + else if (v_clamped >= v_max_fudged) + result = 1.0f; // Workaround for values that are in-range but above our fudge + else if ((v_min * v_max) < 0.0f) // Range crosses zero, so split into two portions + { + float zero_point_center = (-(float)v_min) / ((float)v_max - (float)v_min); // The zero point in parametric space. There's an argument we should take the logarithmic nature into account when calculating this, but for now this should do (and the most common case of a symmetrical range works fine) + float zero_point_snap_L = zero_point_center - zero_deadzone_halfsize; + float zero_point_snap_R = zero_point_center + zero_deadzone_halfsize; + if (v == 0.0f) + result = zero_point_center; // Special case for exactly zero + else if (v < 0.0f) + result = (1.0f - (float)(ImLog(-(FLOATTYPE)v_clamped / logarithmic_zero_epsilon) / ImLog(-v_min_fudged / logarithmic_zero_epsilon))) * zero_point_snap_L; + else + result = zero_point_snap_R + ((float)(ImLog((FLOATTYPE)v_clamped / logarithmic_zero_epsilon) / ImLog(v_max_fudged / logarithmic_zero_epsilon)) * (1.0f - zero_point_snap_R)); + } + else if ((v_min < 0.0f) || (v_max < 0.0f)) // Entirely negative slider + result = 1.0f - (float)(ImLog(-(FLOATTYPE)v_clamped / -v_max_fudged) / ImLog(-v_min_fudged / -v_max_fudged)); + else + result = (float)(ImLog((FLOATTYPE)v_clamped / v_min_fudged) / ImLog(v_max_fudged / v_min_fudged)); + + return flipped ? (1.0f - result) : result; + } + + // Linear slider + return (float)((FLOATTYPE)(SIGNEDTYPE)(v_clamped - v_min) / (FLOATTYPE)(SIGNEDTYPE)(v_max - v_min)); +} + +// Convert a parametric position on a slider into a value v in the output space (the logical opposite of ScaleRatioFromValueT) +template +TYPE ImGui::ScaleValueFromRatioT(ImGuiDataType data_type, float t, TYPE v_min, TYPE v_max, bool is_logarithmic, float logarithmic_zero_epsilon, float zero_deadzone_halfsize) +{ + if (v_min == v_max) + return v_min; + const bool is_floating_point = (data_type == ImGuiDataType_Float) || (data_type == ImGuiDataType_Double); + + TYPE result; + if (is_logarithmic) + { + // We special-case the extents because otherwise our fudging can lead to "mathematically correct" but non-intuitive behaviors like a fully-left slider not actually reaching the minimum value + if (t <= 0.0f) + result = v_min; + else if (t >= 1.0f) + result = v_max; + else + { + bool flipped = v_max < v_min; // Check if range is "backwards" + + // Fudge min/max to avoid getting silly results close to zero + FLOATTYPE v_min_fudged = (ImAbs((FLOATTYPE)v_min) < logarithmic_zero_epsilon) ? ((v_min < 0.0f) ? -logarithmic_zero_epsilon : logarithmic_zero_epsilon) : (FLOATTYPE)v_min; + FLOATTYPE v_max_fudged = (ImAbs((FLOATTYPE)v_max) < logarithmic_zero_epsilon) ? ((v_max < 0.0f) ? -logarithmic_zero_epsilon : logarithmic_zero_epsilon) : (FLOATTYPE)v_max; + + if (flipped) + ImSwap(v_min_fudged, v_max_fudged); + + // Awkward special case - we need ranges of the form (-100 .. 0) to convert to (-100 .. -epsilon), not (-100 .. epsilon) + if ((v_max == 0.0f) && (v_min < 0.0f)) + v_max_fudged = -logarithmic_zero_epsilon; + + float t_with_flip = flipped ? (1.0f - t) : t; // t, but flipped if necessary to account for us flipping the range + + if ((v_min * v_max) < 0.0f) // Range crosses zero, so we have to do this in two parts + { + float zero_point_center = (-(float)ImMin(v_min, v_max)) / ImAbs((float)v_max - (float)v_min); // The zero point in parametric space + float zero_point_snap_L = zero_point_center - zero_deadzone_halfsize; + float zero_point_snap_R = zero_point_center + zero_deadzone_halfsize; + if (t_with_flip >= zero_point_snap_L && t_with_flip <= zero_point_snap_R) + result = (TYPE)0.0f; // Special case to make getting exactly zero possible (the epsilon prevents it otherwise) + else if (t_with_flip < zero_point_center) + result = (TYPE)-(logarithmic_zero_epsilon * ImPow(-v_min_fudged / logarithmic_zero_epsilon, (FLOATTYPE)(1.0f - (t_with_flip / zero_point_snap_L)))); + else + result = (TYPE)(logarithmic_zero_epsilon * ImPow(v_max_fudged / logarithmic_zero_epsilon, (FLOATTYPE)((t_with_flip - zero_point_snap_R) / (1.0f - zero_point_snap_R)))); + } + else if ((v_min < 0.0f) || (v_max < 0.0f)) // Entirely negative slider + result = (TYPE)-(-v_max_fudged * ImPow(-v_min_fudged / -v_max_fudged, (FLOATTYPE)(1.0f - t_with_flip))); + else + result = (TYPE)(v_min_fudged * ImPow(v_max_fudged / v_min_fudged, (FLOATTYPE)t_with_flip)); + } + } + else + { + // Linear slider + if (is_floating_point) + { + result = ImLerp(v_min, v_max, t); + } + else + { + // - For integer values we want the clicking position to match the grab box so we round above + // This code is carefully tuned to work with large values (e.g. high ranges of U64) while preserving this property.. + // - Not doing a *1.0 multiply at the end of a range as it tends to be lossy. While absolute aiming at a large s64/u64 + // range is going to be imprecise anyway, with this check we at least make the edge values matches expected limits. + if (t < 1.0) + { + FLOATTYPE v_new_off_f = (SIGNEDTYPE)(v_max - v_min) * t; + result = (TYPE)((SIGNEDTYPE)v_min + (SIGNEDTYPE)(v_new_off_f + (FLOATTYPE)(v_min > v_max ? -0.5 : 0.5))); + } + else + { + result = v_max; + } + } + } + + return result; +} + +// FIXME: Move more of the code into SliderBehavior() +template +bool ImGui::SliderBehaviorT(const ImRect& bb, ImGuiID id, ImGuiDataType data_type, TYPE* v, const TYPE v_min, const TYPE v_max, const char* format, ImGuiSliderFlags flags, ImRect* out_grab_bb) +{ + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + + const ImGuiAxis axis = (flags & ImGuiSliderFlags_Vertical) ? ImGuiAxis_Y : ImGuiAxis_X; + const bool is_logarithmic = (flags & ImGuiSliderFlags_Logarithmic) != 0; + const bool is_floating_point = (data_type == ImGuiDataType_Float) || (data_type == ImGuiDataType_Double); + + const float grab_padding = 2.0f; + const float slider_sz = (bb.Max[axis] - bb.Min[axis]) - grab_padding * 2.0f; + float grab_sz = style.GrabMinSize; + SIGNEDTYPE v_range = (v_min < v_max ? v_max - v_min : v_min - v_max); + if (!is_floating_point && v_range >= 0) // v_range < 0 may happen on integer overflows + grab_sz = ImMax((float)(slider_sz / (v_range + 1)), style.GrabMinSize); // For integer sliders: if possible have the grab size represent 1 unit + grab_sz = ImMin(grab_sz, slider_sz); + const float slider_usable_sz = slider_sz - grab_sz; + const float slider_usable_pos_min = bb.Min[axis] + grab_padding + grab_sz * 0.5f; + const float slider_usable_pos_max = bb.Max[axis] - grab_padding - grab_sz * 0.5f; + + float logarithmic_zero_epsilon = 0.0f; // Only valid when is_logarithmic is true + float zero_deadzone_halfsize = 0.0f; // Only valid when is_logarithmic is true + if (is_logarithmic) + { + // When using logarithmic sliders, we need to clamp to avoid hitting zero, but our choice of clamp value greatly affects slider precision. We attempt to use the specified precision to estimate a good lower bound. + const int decimal_precision = is_floating_point ? ImParseFormatPrecision(format, 3) : 1; + logarithmic_zero_epsilon = ImPow(0.1f, (float)decimal_precision); + zero_deadzone_halfsize = (style.LogSliderDeadzone * 0.5f) / ImMax(slider_usable_sz, 1.0f); + } + + // Process interacting with the slider + bool value_changed = false; + if (g.ActiveId == id) + { + bool set_new_value = false; + float clicked_t = 0.0f; + if (g.ActiveIdSource == ImGuiInputSource_Mouse) + { + if (!g.IO.MouseDown[0]) + { + ClearActiveID(); + } + else + { + const float mouse_abs_pos = g.IO.MousePos[axis]; + clicked_t = (slider_usable_sz > 0.0f) ? ImClamp((mouse_abs_pos - slider_usable_pos_min) / slider_usable_sz, 0.0f, 1.0f) : 0.0f; + if (axis == ImGuiAxis_Y) + clicked_t = 1.0f - clicked_t; + set_new_value = true; + } + } + else if (g.ActiveIdSource == ImGuiInputSource_Nav) + { + if (g.ActiveIdIsJustActivated) + { + g.SliderCurrentAccum = 0.0f; // Reset any stored nav delta upon activation + g.SliderCurrentAccumDirty = false; + } + + const ImVec2 input_delta2 = GetNavInputAmount2d(ImGuiNavDirSourceFlags_Keyboard | ImGuiNavDirSourceFlags_PadDPad, ImGuiInputReadMode_RepeatFast, 0.0f, 0.0f); + float input_delta = (axis == ImGuiAxis_X) ? input_delta2.x : -input_delta2.y; + if (input_delta != 0.0f) + { + const int decimal_precision = is_floating_point ? ImParseFormatPrecision(format, 3) : 0; + if (decimal_precision > 0) + { + input_delta /= 100.0f; // Gamepad/keyboard tweak speeds in % of slider bounds + if (IsNavInputDown(ImGuiNavInput_TweakSlow)) + input_delta /= 10.0f; + } + else + { + if ((v_range >= -100.0f && v_range <= 100.0f) || IsNavInputDown(ImGuiNavInput_TweakSlow)) + input_delta = ((input_delta < 0.0f) ? -1.0f : +1.0f) / (float)v_range; // Gamepad/keyboard tweak speeds in integer steps + else + input_delta /= 100.0f; + } + if (IsNavInputDown(ImGuiNavInput_TweakFast)) + input_delta *= 10.0f; + + g.SliderCurrentAccum += input_delta; + g.SliderCurrentAccumDirty = true; + } + + float delta = g.SliderCurrentAccum; + if (g.NavActivatePressedId == id && !g.ActiveIdIsJustActivated) + { + ClearActiveID(); + } + else if (g.SliderCurrentAccumDirty) + { + clicked_t = ScaleRatioFromValueT(data_type, *v, v_min, v_max, is_logarithmic, logarithmic_zero_epsilon, zero_deadzone_halfsize); + + if ((clicked_t >= 1.0f && delta > 0.0f) || (clicked_t <= 0.0f && delta < 0.0f)) // This is to avoid applying the saturation when already past the limits + { + set_new_value = false; + g.SliderCurrentAccum = 0.0f; // If pushing up against the limits, don't continue to accumulate + } + else + { + set_new_value = true; + float old_clicked_t = clicked_t; + clicked_t = ImSaturate(clicked_t + delta); + + // Calculate what our "new" clicked_t will be, and thus how far we actually moved the slider, and subtract this from the accumulator + TYPE v_new = ScaleValueFromRatioT(data_type, clicked_t, v_min, v_max, is_logarithmic, logarithmic_zero_epsilon, zero_deadzone_halfsize); + if (!(flags & ImGuiSliderFlags_NoRoundToFormat)) + v_new = RoundScalarWithFormatT(format, data_type, v_new); + float new_clicked_t = ScaleRatioFromValueT(data_type, v_new, v_min, v_max, is_logarithmic, logarithmic_zero_epsilon, zero_deadzone_halfsize); + + if (delta > 0) + g.SliderCurrentAccum -= ImMin(new_clicked_t - old_clicked_t, delta); + else + g.SliderCurrentAccum -= ImMax(new_clicked_t - old_clicked_t, delta); + } + + g.SliderCurrentAccumDirty = false; + } + } + + if (set_new_value) + { + TYPE v_new = ScaleValueFromRatioT(data_type, clicked_t, v_min, v_max, is_logarithmic, logarithmic_zero_epsilon, zero_deadzone_halfsize); + + // Round to user desired precision based on format string + if (!(flags & ImGuiSliderFlags_NoRoundToFormat)) + v_new = RoundScalarWithFormatT(format, data_type, v_new); + + // Apply result + if (*v != v_new) + { + *v = v_new; + value_changed = true; + } + } + } + + if (slider_sz < 1.0f) + { + *out_grab_bb = ImRect(bb.Min, bb.Min); + } + else + { + // Output grab position so it can be displayed by the caller + float grab_t = ScaleRatioFromValueT(data_type, *v, v_min, v_max, is_logarithmic, logarithmic_zero_epsilon, zero_deadzone_halfsize); + if (axis == ImGuiAxis_Y) + grab_t = 1.0f - grab_t; + const float grab_pos = ImLerp(slider_usable_pos_min, slider_usable_pos_max, grab_t); + if (axis == ImGuiAxis_X) + *out_grab_bb = ImRect(grab_pos - grab_sz * 0.5f, bb.Min.y + grab_padding, grab_pos + grab_sz * 0.5f, bb.Max.y - grab_padding); + else + *out_grab_bb = ImRect(bb.Min.x + grab_padding, grab_pos - grab_sz * 0.5f, bb.Max.x - grab_padding, grab_pos + grab_sz * 0.5f); + } + + return value_changed; +} + +// For 32-bit and larger types, slider bounds are limited to half the natural type range. +// So e.g. an integer Slider between INT_MAX-10 and INT_MAX will fail, but an integer Slider between INT_MAX/2-10 and INT_MAX/2 will be ok. +// It would be possible to lift that limitation with some work but it doesn't seem to be worth it for sliders. +bool ImGui::SliderBehavior(const ImRect& bb, ImGuiID id, ImGuiDataType data_type, void* p_v, const void* p_min, const void* p_max, const char* format, ImGuiSliderFlags flags, ImRect* out_grab_bb) +{ + // Read imgui.cpp "API BREAKING CHANGES" section for 1.78 if you hit this assert. + IM_ASSERT((flags == 1 || (flags & ImGuiSliderFlags_InvalidMask_) == 0) && "Invalid ImGuiSliderFlags flag! Has the 'float power' argument been mistakenly cast to flags? Call function with ImGuiSliderFlags_Logarithmic flags instead."); + + ImGuiContext& g = *GImGui; + if ((g.LastItemData.InFlags & ImGuiItemFlags_ReadOnly) || (flags & ImGuiSliderFlags_ReadOnly)) + return false; + + switch (data_type) + { + case ImGuiDataType_S8: { ImS32 v32 = (ImS32)*(ImS8*)p_v; bool r = SliderBehaviorT(bb, id, ImGuiDataType_S32, &v32, *(const ImS8*)p_min, *(const ImS8*)p_max, format, flags, out_grab_bb); if (r) *(ImS8*)p_v = (ImS8)v32; return r; } + case ImGuiDataType_U8: { ImU32 v32 = (ImU32)*(ImU8*)p_v; bool r = SliderBehaviorT(bb, id, ImGuiDataType_U32, &v32, *(const ImU8*)p_min, *(const ImU8*)p_max, format, flags, out_grab_bb); if (r) *(ImU8*)p_v = (ImU8)v32; return r; } + case ImGuiDataType_S16: { ImS32 v32 = (ImS32)*(ImS16*)p_v; bool r = SliderBehaviorT(bb, id, ImGuiDataType_S32, &v32, *(const ImS16*)p_min, *(const ImS16*)p_max, format, flags, out_grab_bb); if (r) *(ImS16*)p_v = (ImS16)v32; return r; } + case ImGuiDataType_U16: { ImU32 v32 = (ImU32)*(ImU16*)p_v; bool r = SliderBehaviorT(bb, id, ImGuiDataType_U32, &v32, *(const ImU16*)p_min, *(const ImU16*)p_max, format, flags, out_grab_bb); if (r) *(ImU16*)p_v = (ImU16)v32; return r; } + case ImGuiDataType_S32: + IM_ASSERT(*(const ImS32*)p_min >= IM_S32_MIN / 2 && *(const ImS32*)p_max <= IM_S32_MAX / 2); + return SliderBehaviorT(bb, id, data_type, (ImS32*)p_v, *(const ImS32*)p_min, *(const ImS32*)p_max, format, flags, out_grab_bb); + case ImGuiDataType_U32: + IM_ASSERT(*(const ImU32*)p_max <= IM_U32_MAX / 2); + return SliderBehaviorT(bb, id, data_type, (ImU32*)p_v, *(const ImU32*)p_min, *(const ImU32*)p_max, format, flags, out_grab_bb); + case ImGuiDataType_S64: + IM_ASSERT(*(const ImS64*)p_min >= IM_S64_MIN / 2 && *(const ImS64*)p_max <= IM_S64_MAX / 2); + return SliderBehaviorT(bb, id, data_type, (ImS64*)p_v, *(const ImS64*)p_min, *(const ImS64*)p_max, format, flags, out_grab_bb); + case ImGuiDataType_U64: + IM_ASSERT(*(const ImU64*)p_max <= IM_U64_MAX / 2); + return SliderBehaviorT(bb, id, data_type, (ImU64*)p_v, *(const ImU64*)p_min, *(const ImU64*)p_max, format, flags, out_grab_bb); + case ImGuiDataType_Float: + IM_ASSERT(*(const float*)p_min >= -FLT_MAX / 2.0f && *(const float*)p_max <= FLT_MAX / 2.0f); + return SliderBehaviorT(bb, id, data_type, (float*)p_v, *(const float*)p_min, *(const float*)p_max, format, flags, out_grab_bb); + case ImGuiDataType_Double: + IM_ASSERT(*(const double*)p_min >= -DBL_MAX / 2.0f && *(const double*)p_max <= DBL_MAX / 2.0f); + return SliderBehaviorT(bb, id, data_type, (double*)p_v, *(const double*)p_min, *(const double*)p_max, format, flags, out_grab_bb); + case ImGuiDataType_COUNT: break; + } + IM_ASSERT(0); + return false; +} + +// Note: p_data, p_min and p_max are _pointers_ to a memory address holding the data. For a slider, they are all required. +// Read code of e.g. SliderFloat(), SliderInt() etc. or examples in 'Demo->Widgets->Data Types' to understand how to use this function directly. +bool ImGui::SliderScalar(const char* label, ImGuiDataType data_type, void* p_data, const void* p_min, const void* p_max, const char* format, ImGuiSliderFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + const ImGuiID id = window->GetID(label); + const float w = CalcItemWidth(); + + const ImVec2 label_size = CalcTextSize(label, NULL, true); + const ImRect frame_bb(window->DC.CursorPos, window->DC.CursorPos + ImVec2(w, label_size.y + style.FramePadding.y * 2.0f)); + const ImRect total_bb(frame_bb.Min, frame_bb.Max + ImVec2(label_size.x > 0.0f ? style.ItemInnerSpacing.x + label_size.x : 0.0f, 0.0f)); + + const bool temp_input_allowed = (flags & ImGuiSliderFlags_NoInput) == 0; + ItemSize(total_bb, style.FramePadding.y); + if (!ItemAdd(total_bb, id, &frame_bb, temp_input_allowed ? ImGuiItemFlags_Inputable : 0)) + return false; + + // Default format string when passing NULL + if (format == NULL) + format = DataTypeGetInfo(data_type)->PrintFmt; + else if (data_type == ImGuiDataType_S32 && strcmp(format, "%d") != 0) // (FIXME-LEGACY: Patch old "%.0f" format string to use "%d", read function more details.) + format = PatchFormatStringFloatToInt(format); + + // Tabbing or CTRL-clicking on Slider turns it into an input box + const bool hovered = ItemHoverable(frame_bb, id); + bool temp_input_is_active = temp_input_allowed && TempInputIsActive(id); + if (!temp_input_is_active) + { + const bool focus_requested = temp_input_allowed && (g.LastItemData.StatusFlags & ImGuiItemStatusFlags_Focused) != 0; + const bool clicked = (hovered && g.IO.MouseClicked[0]); + if (focus_requested || clicked || g.NavActivateId == id || g.NavActivateInputId == id) + { + SetActiveID(id, window); + SetFocusID(id, window); + FocusWindow(window); + g.ActiveIdUsingNavDirMask |= (1 << ImGuiDir_Left) | (1 << ImGuiDir_Right); + if (temp_input_allowed && (focus_requested || (clicked && g.IO.KeyCtrl) || g.NavActivateInputId == id)) + temp_input_is_active = true; + } + } + + if (temp_input_is_active) + { + // Only clamp CTRL+Click input when ImGuiSliderFlags_AlwaysClamp is set + const bool is_clamp_input = (flags & ImGuiSliderFlags_AlwaysClamp) != 0; + return TempInputScalar(frame_bb, id, label, data_type, p_data, format, is_clamp_input ? p_min : NULL, is_clamp_input ? p_max : NULL); + } + + // Draw frame + const ImU32 frame_col = GetColorU32(g.ActiveId == id ? ImGuiCol_FrameBgActive : hovered ? ImGuiCol_FrameBgHovered : ImGuiCol_FrameBg); + RenderNavHighlight(frame_bb, id); + RenderFrame(frame_bb.Min, frame_bb.Max, frame_col, true, g.Style.FrameRounding); + + // Slider behavior + ImRect grab_bb; + const bool value_changed = SliderBehavior(frame_bb, id, data_type, p_data, p_min, p_max, format, flags, &grab_bb); + if (value_changed) + MarkItemEdited(id); + + // Render grab + if (grab_bb.Max.x > grab_bb.Min.x) + window->DrawList->AddRectFilled(grab_bb.Min, grab_bb.Max, GetColorU32(g.ActiveId == id ? ImGuiCol_SliderGrabActive : ImGuiCol_SliderGrab), style.GrabRounding); + + // Display value using user-provided display format so user can add prefix/suffix/decorations to the value. + char value_buf[64]; + const char* value_buf_end = value_buf + DataTypeFormatString(value_buf, IM_ARRAYSIZE(value_buf), data_type, p_data, format); + if (g.LogEnabled) + LogSetNextTextDecoration("{", "}"); + RenderTextClipped(frame_bb.Min, frame_bb.Max, value_buf, value_buf_end, NULL, ImVec2(0.5f, 0.5f)); + + if (label_size.x > 0.0f) + RenderText(ImVec2(frame_bb.Max.x + style.ItemInnerSpacing.x, frame_bb.Min.y + style.FramePadding.y), label); + + IMGUI_TEST_ENGINE_ITEM_INFO(id, label, g.LastItemData.StatusFlags); + return value_changed; +} + +// Add multiple sliders on 1 line for compact edition of multiple components +bool ImGui::SliderScalarN(const char* label, ImGuiDataType data_type, void* v, int components, const void* v_min, const void* v_max, const char* format, ImGuiSliderFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + bool value_changed = false; + BeginGroup(); + PushID(label); + PushMultiItemsWidths(components, CalcItemWidth()); + size_t type_size = GDataTypeInfo[data_type].Size; + for (int i = 0; i < components; i++) + { + PushID(i); + if (i > 0) + SameLine(0, g.Style.ItemInnerSpacing.x); + value_changed |= SliderScalar("", data_type, v, v_min, v_max, format, flags); + PopID(); + PopItemWidth(); + v = (void*)((char*)v + type_size); + } + PopID(); + + const char* label_end = FindRenderedTextEnd(label); + if (label != label_end) + { + SameLine(0, g.Style.ItemInnerSpacing.x); + TextEx(label, label_end); + } + + EndGroup(); + return value_changed; +} + +bool ImGui::SliderFloat(const char* label, float* v, float v_min, float v_max, const char* format, ImGuiSliderFlags flags) +{ + return SliderScalar(label, ImGuiDataType_Float, v, &v_min, &v_max, format, flags); +} + +bool ImGui::SliderFloat2(const char* label, float v[2], float v_min, float v_max, const char* format, ImGuiSliderFlags flags) +{ + return SliderScalarN(label, ImGuiDataType_Float, v, 2, &v_min, &v_max, format, flags); +} + +bool ImGui::SliderFloat3(const char* label, float v[3], float v_min, float v_max, const char* format, ImGuiSliderFlags flags) +{ + return SliderScalarN(label, ImGuiDataType_Float, v, 3, &v_min, &v_max, format, flags); +} + +bool ImGui::SliderFloat4(const char* label, float v[4], float v_min, float v_max, const char* format, ImGuiSliderFlags flags) +{ + return SliderScalarN(label, ImGuiDataType_Float, v, 4, &v_min, &v_max, format, flags); +} + +bool ImGui::SliderAngle(const char* label, float* v_rad, float v_degrees_min, float v_degrees_max, const char* format, ImGuiSliderFlags flags) +{ + if (format == NULL) + format = "%.0f deg"; + float v_deg = (*v_rad) * 360.0f / (2 * IM_PI); + bool value_changed = SliderFloat(label, &v_deg, v_degrees_min, v_degrees_max, format, flags); + *v_rad = v_deg * (2 * IM_PI) / 360.0f; + return value_changed; +} + +bool ImGui::SliderInt(const char* label, int* v, int v_min, int v_max, const char* format, ImGuiSliderFlags flags) +{ + return SliderScalar(label, ImGuiDataType_S32, v, &v_min, &v_max, format, flags); +} + +bool ImGui::SliderInt2(const char* label, int v[2], int v_min, int v_max, const char* format, ImGuiSliderFlags flags) +{ + return SliderScalarN(label, ImGuiDataType_S32, v, 2, &v_min, &v_max, format, flags); +} + +bool ImGui::SliderInt3(const char* label, int v[3], int v_min, int v_max, const char* format, ImGuiSliderFlags flags) +{ + return SliderScalarN(label, ImGuiDataType_S32, v, 3, &v_min, &v_max, format, flags); +} + +bool ImGui::SliderInt4(const char* label, int v[4], int v_min, int v_max, const char* format, ImGuiSliderFlags flags) +{ + return SliderScalarN(label, ImGuiDataType_S32, v, 4, &v_min, &v_max, format, flags); +} + +bool ImGui::VSliderScalar(const char* label, const ImVec2& size, ImGuiDataType data_type, void* p_data, const void* p_min, const void* p_max, const char* format, ImGuiSliderFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + const ImGuiID id = window->GetID(label); + + const ImVec2 label_size = CalcTextSize(label, NULL, true); + const ImRect frame_bb(window->DC.CursorPos, window->DC.CursorPos + size); + const ImRect bb(frame_bb.Min, frame_bb.Max + ImVec2(label_size.x > 0.0f ? style.ItemInnerSpacing.x + label_size.x : 0.0f, 0.0f)); + + ItemSize(bb, style.FramePadding.y); + if (!ItemAdd(frame_bb, id)) + return false; + + // Default format string when passing NULL + if (format == NULL) + format = DataTypeGetInfo(data_type)->PrintFmt; + else if (data_type == ImGuiDataType_S32 && strcmp(format, "%d") != 0) // (FIXME-LEGACY: Patch old "%.0f" format string to use "%d", read function more details.) + format = PatchFormatStringFloatToInt(format); + + const bool hovered = ItemHoverable(frame_bb, id); + if ((hovered && g.IO.MouseClicked[0]) || g.NavActivateId == id || g.NavActivateInputId == id) + { + SetActiveID(id, window); + SetFocusID(id, window); + FocusWindow(window); + g.ActiveIdUsingNavDirMask |= (1 << ImGuiDir_Up) | (1 << ImGuiDir_Down); + } + + // Draw frame + const ImU32 frame_col = GetColorU32(g.ActiveId == id ? ImGuiCol_FrameBgActive : hovered ? ImGuiCol_FrameBgHovered : ImGuiCol_FrameBg); + RenderNavHighlight(frame_bb, id); + RenderFrame(frame_bb.Min, frame_bb.Max, frame_col, true, g.Style.FrameRounding); + + // Slider behavior + ImRect grab_bb; + const bool value_changed = SliderBehavior(frame_bb, id, data_type, p_data, p_min, p_max, format, flags | ImGuiSliderFlags_Vertical, &grab_bb); + if (value_changed) + MarkItemEdited(id); + + // Render grab + if (grab_bb.Max.y > grab_bb.Min.y) + window->DrawList->AddRectFilled(grab_bb.Min, grab_bb.Max, GetColorU32(g.ActiveId == id ? ImGuiCol_SliderGrabActive : ImGuiCol_SliderGrab), style.GrabRounding); + + // Display value using user-provided display format so user can add prefix/suffix/decorations to the value. + // For the vertical slider we allow centered text to overlap the frame padding + char value_buf[64]; + const char* value_buf_end = value_buf + DataTypeFormatString(value_buf, IM_ARRAYSIZE(value_buf), data_type, p_data, format); + RenderTextClipped(ImVec2(frame_bb.Min.x, frame_bb.Min.y + style.FramePadding.y), frame_bb.Max, value_buf, value_buf_end, NULL, ImVec2(0.5f, 0.0f)); + if (label_size.x > 0.0f) + RenderText(ImVec2(frame_bb.Max.x + style.ItemInnerSpacing.x, frame_bb.Min.y + style.FramePadding.y), label); + + return value_changed; +} + +bool ImGui::VSliderFloat(const char* label, const ImVec2& size, float* v, float v_min, float v_max, const char* format, ImGuiSliderFlags flags) +{ + return VSliderScalar(label, size, ImGuiDataType_Float, v, &v_min, &v_max, format, flags); +} + +bool ImGui::VSliderInt(const char* label, const ImVec2& size, int* v, int v_min, int v_max, const char* format, ImGuiSliderFlags flags) +{ + return VSliderScalar(label, size, ImGuiDataType_S32, v, &v_min, &v_max, format, flags); +} + +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS + +// Obsolete versions with power parameter. See https://github.com/ocornut/imgui/issues/3361 for details. +bool ImGui::SliderScalar(const char* label, ImGuiDataType data_type, void* p_data, const void* p_min, const void* p_max, const char* format, float power) +{ + ImGuiSliderFlags slider_flags = ImGuiSliderFlags_None; + if (power != 1.0f) + { + IM_ASSERT(power == 1.0f && "Call function with ImGuiSliderFlags_Logarithmic flags instead of using the old 'float power' function!"); + slider_flags |= ImGuiSliderFlags_Logarithmic; // Fallback for non-asserting paths + } + return SliderScalar(label, data_type, p_data, p_min, p_max, format, slider_flags); +} + +bool ImGui::SliderScalarN(const char* label, ImGuiDataType data_type, void* v, int components, const void* v_min, const void* v_max, const char* format, float power) +{ + ImGuiSliderFlags slider_flags = ImGuiSliderFlags_None; + if (power != 1.0f) + { + IM_ASSERT(power == 1.0f && "Call function with ImGuiSliderFlags_Logarithmic flags instead of using the old 'float power' function!"); + slider_flags |= ImGuiSliderFlags_Logarithmic; // Fallback for non-asserting paths + } + return SliderScalarN(label, data_type, v, components, v_min, v_max, format, slider_flags); +} + +#endif // IMGUI_DISABLE_OBSOLETE_FUNCTIONS + +//------------------------------------------------------------------------- +// [SECTION] Widgets: InputScalar, InputFloat, InputInt, etc. +//------------------------------------------------------------------------- +// - ImParseFormatFindStart() [Internal] +// - ImParseFormatFindEnd() [Internal] +// - ImParseFormatTrimDecorations() [Internal] +// - ImParseFormatPrecision() [Internal] +// - TempInputTextScalar() [Internal] +// - InputScalar() +// - InputScalarN() +// - InputFloat() +// - InputFloat2() +// - InputFloat3() +// - InputFloat4() +// - InputInt() +// - InputInt2() +// - InputInt3() +// - InputInt4() +// - InputDouble() +//------------------------------------------------------------------------- + +// We don't use strchr() because our strings are usually very short and often start with '%' +const char* ImParseFormatFindStart(const char* fmt) +{ + while (char c = fmt[0]) + { + if (c == '%' && fmt[1] != '%') + return fmt; + else if (c == '%') + fmt++; + fmt++; + } + return fmt; +} + +const char* ImParseFormatFindEnd(const char* fmt) +{ + // Printf/scanf types modifiers: I/L/h/j/l/t/w/z. Other uppercase letters qualify as types aka end of the format. + if (fmt[0] != '%') + return fmt; + const unsigned int ignored_uppercase_mask = (1 << ('I'-'A')) | (1 << ('L'-'A')); + const unsigned int ignored_lowercase_mask = (1 << ('h'-'a')) | (1 << ('j'-'a')) | (1 << ('l'-'a')) | (1 << ('t'-'a')) | (1 << ('w'-'a')) | (1 << ('z'-'a')); + for (char c; (c = *fmt) != 0; fmt++) + { + if (c >= 'A' && c <= 'Z' && ((1 << (c - 'A')) & ignored_uppercase_mask) == 0) + return fmt + 1; + if (c >= 'a' && c <= 'z' && ((1 << (c - 'a')) & ignored_lowercase_mask) == 0) + return fmt + 1; + } + return fmt; +} + +// Extract the format out of a format string with leading or trailing decorations +// fmt = "blah blah" -> return fmt +// fmt = "%.3f" -> return fmt +// fmt = "hello %.3f" -> return fmt + 6 +// fmt = "%.3f hello" -> return buf written with "%.3f" +const char* ImParseFormatTrimDecorations(const char* fmt, char* buf, size_t buf_size) +{ + const char* fmt_start = ImParseFormatFindStart(fmt); + if (fmt_start[0] != '%') + return fmt; + const char* fmt_end = ImParseFormatFindEnd(fmt_start); + if (fmt_end[0] == 0) // If we only have leading decoration, we don't need to copy the data. + return fmt_start; + ImStrncpy(buf, fmt_start, ImMin((size_t)(fmt_end - fmt_start) + 1, buf_size)); + return buf; +} + +// Parse display precision back from the display format string +// FIXME: This is still used by some navigation code path to infer a minimum tweak step, but we should aim to rework widgets so it isn't needed. +int ImParseFormatPrecision(const char* fmt, int default_precision) +{ + fmt = ImParseFormatFindStart(fmt); + if (fmt[0] != '%') + return default_precision; + fmt++; + while (*fmt >= '0' && *fmt <= '9') + fmt++; + int precision = INT_MAX; + if (*fmt == '.') + { + fmt = ImAtoi(fmt + 1, &precision); + if (precision < 0 || precision > 99) + precision = default_precision; + } + if (*fmt == 'e' || *fmt == 'E') // Maximum precision with scientific notation + precision = -1; + if ((*fmt == 'g' || *fmt == 'G') && precision == INT_MAX) + precision = -1; + return (precision == INT_MAX) ? default_precision : precision; +} + +// Create text input in place of another active widget (e.g. used when doing a CTRL+Click on drag/slider widgets) +// FIXME: Facilitate using this in variety of other situations. +bool ImGui::TempInputText(const ImRect& bb, ImGuiID id, const char* label, char* buf, int buf_size, ImGuiInputTextFlags flags) +{ + // On the first frame, g.TempInputTextId == 0, then on subsequent frames it becomes == id. + // We clear ActiveID on the first frame to allow the InputText() taking it back. + ImGuiContext& g = *GImGui; + const bool init = (g.TempInputId != id); + if (init) + ClearActiveID(); + + g.CurrentWindow->DC.CursorPos = bb.Min; + bool value_changed = InputTextEx(label, NULL, buf, buf_size, bb.GetSize(), flags | ImGuiInputTextFlags_MergedItem); + if (init) + { + // First frame we started displaying the InputText widget, we expect it to take the active id. + IM_ASSERT(g.ActiveId == id); + g.TempInputId = g.ActiveId; + } + return value_changed; +} + +// Note that Drag/Slider functions are only forwarding the min/max values clamping values if the ImGuiSliderFlags_AlwaysClamp flag is set! +// This is intended: this way we allow CTRL+Click manual input to set a value out of bounds, for maximum flexibility. +// However this may not be ideal for all uses, as some user code may break on out of bound values. +bool ImGui::TempInputScalar(const ImRect& bb, ImGuiID id, const char* label, ImGuiDataType data_type, void* p_data, const char* format, const void* p_clamp_min, const void* p_clamp_max) +{ + ImGuiContext& g = *GImGui; + + char fmt_buf[32]; + char data_buf[32]; + format = ImParseFormatTrimDecorations(format, fmt_buf, IM_ARRAYSIZE(fmt_buf)); + DataTypeFormatString(data_buf, IM_ARRAYSIZE(data_buf), data_type, p_data, format); + ImStrTrimBlanks(data_buf); + + ImGuiInputTextFlags flags = ImGuiInputTextFlags_AutoSelectAll | ImGuiInputTextFlags_NoMarkEdited; + flags |= ((data_type == ImGuiDataType_Float || data_type == ImGuiDataType_Double) ? ImGuiInputTextFlags_CharsScientific : ImGuiInputTextFlags_CharsDecimal); + bool value_changed = false; + if (TempInputText(bb, id, label, data_buf, IM_ARRAYSIZE(data_buf), flags)) + { + // Backup old value + size_t data_type_size = DataTypeGetInfo(data_type)->Size; + ImGuiDataTypeTempStorage data_backup; + memcpy(&data_backup, p_data, data_type_size); + + // Apply new value (or operations) then clamp + DataTypeApplyOpFromText(data_buf, g.InputTextState.InitialTextA.Data, data_type, p_data, NULL); + if (p_clamp_min || p_clamp_max) + { + if (p_clamp_min && p_clamp_max && DataTypeCompare(data_type, p_clamp_min, p_clamp_max) > 0) + ImSwap(p_clamp_min, p_clamp_max); + DataTypeClamp(data_type, p_data, p_clamp_min, p_clamp_max); + } + + // Only mark as edited if new value is different + value_changed = memcmp(&data_backup, p_data, data_type_size) != 0; + if (value_changed) + MarkItemEdited(id); + } + return value_changed; +} + +// Note: p_data, p_step, p_step_fast are _pointers_ to a memory address holding the data. For an Input widget, p_step and p_step_fast are optional. +// Read code of e.g. InputFloat(), InputInt() etc. or examples in 'Demo->Widgets->Data Types' to understand how to use this function directly. +bool ImGui::InputScalar(const char* label, ImGuiDataType data_type, void* p_data, const void* p_step, const void* p_step_fast, const char* format, ImGuiInputTextFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + ImGuiStyle& style = g.Style; + + if (format == NULL) + format = DataTypeGetInfo(data_type)->PrintFmt; + + char buf[64]; + DataTypeFormatString(buf, IM_ARRAYSIZE(buf), data_type, p_data, format); + + bool value_changed = false; + if ((flags & (ImGuiInputTextFlags_CharsHexadecimal | ImGuiInputTextFlags_CharsScientific)) == 0) + flags |= ImGuiInputTextFlags_CharsDecimal; + flags |= ImGuiInputTextFlags_AutoSelectAll; + flags |= ImGuiInputTextFlags_NoMarkEdited; // We call MarkItemEdited() ourselves by comparing the actual data rather than the string. + + if (p_step != NULL) + { + const float button_size = GetFrameHeight(); + + BeginGroup(); // The only purpose of the group here is to allow the caller to query item data e.g. IsItemActive() + PushID(label); + SetNextItemWidth(ImMax(1.0f, CalcItemWidth() - (button_size + style.ItemInnerSpacing.x) * 2)); + if (InputText("", buf, IM_ARRAYSIZE(buf), flags)) // PushId(label) + "" gives us the expected ID from outside point of view + value_changed = DataTypeApplyOpFromText(buf, g.InputTextState.InitialTextA.Data, data_type, p_data, format); + + // Step buttons + const ImVec2 backup_frame_padding = style.FramePadding; + style.FramePadding.x = style.FramePadding.y; + ImGuiButtonFlags button_flags = ImGuiButtonFlags_Repeat | ImGuiButtonFlags_DontClosePopups; + if (flags & ImGuiInputTextFlags_ReadOnly) + BeginDisabled(); + SameLine(0, style.ItemInnerSpacing.x); + if (ButtonEx("-", ImVec2(button_size, button_size), button_flags)) + { + DataTypeApplyOp(data_type, '-', p_data, p_data, g.IO.KeyCtrl && p_step_fast ? p_step_fast : p_step); + value_changed = true; + } + SameLine(0, style.ItemInnerSpacing.x); + if (ButtonEx("+", ImVec2(button_size, button_size), button_flags)) + { + DataTypeApplyOp(data_type, '+', p_data, p_data, g.IO.KeyCtrl && p_step_fast ? p_step_fast : p_step); + value_changed = true; + } + if (flags & ImGuiInputTextFlags_ReadOnly) + EndDisabled(); + + const char* label_end = FindRenderedTextEnd(label); + if (label != label_end) + { + SameLine(0, style.ItemInnerSpacing.x); + TextEx(label, label_end); + } + style.FramePadding = backup_frame_padding; + + PopID(); + EndGroup(); + } + else + { + if (InputText(label, buf, IM_ARRAYSIZE(buf), flags)) + value_changed = DataTypeApplyOpFromText(buf, g.InputTextState.InitialTextA.Data, data_type, p_data, format); + } + if (value_changed) + MarkItemEdited(g.LastItemData.ID); + + return value_changed; +} + +bool ImGui::InputScalarN(const char* label, ImGuiDataType data_type, void* p_data, int components, const void* p_step, const void* p_step_fast, const char* format, ImGuiInputTextFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + bool value_changed = false; + BeginGroup(); + PushID(label); + PushMultiItemsWidths(components, CalcItemWidth()); + size_t type_size = GDataTypeInfo[data_type].Size; + for (int i = 0; i < components; i++) + { + PushID(i); + if (i > 0) + SameLine(0, g.Style.ItemInnerSpacing.x); + value_changed |= InputScalar("", data_type, p_data, p_step, p_step_fast, format, flags); + PopID(); + PopItemWidth(); + p_data = (void*)((char*)p_data + type_size); + } + PopID(); + + const char* label_end = FindRenderedTextEnd(label); + if (label != label_end) + { + SameLine(0.0f, g.Style.ItemInnerSpacing.x); + TextEx(label, label_end); + } + + EndGroup(); + return value_changed; +} + +bool ImGui::InputFloat(const char* label, float* v, float step, float step_fast, const char* format, ImGuiInputTextFlags flags) +{ + flags |= ImGuiInputTextFlags_CharsScientific; + return InputScalar(label, ImGuiDataType_Float, (void*)v, (void*)(step > 0.0f ? &step : NULL), (void*)(step_fast > 0.0f ? &step_fast : NULL), format, flags); +} + +bool ImGui::InputFloat2(const char* label, float v[2], const char* format, ImGuiInputTextFlags flags) +{ + return InputScalarN(label, ImGuiDataType_Float, v, 2, NULL, NULL, format, flags); +} + +bool ImGui::InputFloat3(const char* label, float v[3], const char* format, ImGuiInputTextFlags flags) +{ + return InputScalarN(label, ImGuiDataType_Float, v, 3, NULL, NULL, format, flags); +} + +bool ImGui::InputFloat4(const char* label, float v[4], const char* format, ImGuiInputTextFlags flags) +{ + return InputScalarN(label, ImGuiDataType_Float, v, 4, NULL, NULL, format, flags); +} + +bool ImGui::InputInt(const char* label, int* v, int step, int step_fast, ImGuiInputTextFlags flags) +{ + // Hexadecimal input provided as a convenience but the flag name is awkward. Typically you'd use InputText() to parse your own data, if you want to handle prefixes. + const char* format = (flags & ImGuiInputTextFlags_CharsHexadecimal) ? "%08X" : "%d"; + return InputScalar(label, ImGuiDataType_S32, (void*)v, (void*)(step > 0 ? &step : NULL), (void*)(step_fast > 0 ? &step_fast : NULL), format, flags); +} + +bool ImGui::InputInt2(const char* label, int v[2], ImGuiInputTextFlags flags) +{ + return InputScalarN(label, ImGuiDataType_S32, v, 2, NULL, NULL, "%d", flags); +} + +bool ImGui::InputInt3(const char* label, int v[3], ImGuiInputTextFlags flags) +{ + return InputScalarN(label, ImGuiDataType_S32, v, 3, NULL, NULL, "%d", flags); +} + +bool ImGui::InputInt4(const char* label, int v[4], ImGuiInputTextFlags flags) +{ + return InputScalarN(label, ImGuiDataType_S32, v, 4, NULL, NULL, "%d", flags); +} + +bool ImGui::InputDouble(const char* label, double* v, double step, double step_fast, const char* format, ImGuiInputTextFlags flags) +{ + flags |= ImGuiInputTextFlags_CharsScientific; + return InputScalar(label, ImGuiDataType_Double, (void*)v, (void*)(step > 0.0 ? &step : NULL), (void*)(step_fast > 0.0 ? &step_fast : NULL), format, flags); +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: InputText, InputTextMultiline, InputTextWithHint +//------------------------------------------------------------------------- +// - InputText() +// - InputTextWithHint() +// - InputTextMultiline() +// - InputTextEx() [Internal] +//------------------------------------------------------------------------- + +bool ImGui::InputText(const char* label, char* buf, size_t buf_size, ImGuiInputTextFlags flags, ImGuiInputTextCallback callback, void* user_data) +{ + IM_ASSERT(!(flags & ImGuiInputTextFlags_Multiline)); // call InputTextMultiline() + return InputTextEx(label, NULL, buf, (int)buf_size, ImVec2(0, 0), flags, callback, user_data); +} + +bool ImGui::InputTextMultiline(const char* label, char* buf, size_t buf_size, const ImVec2& size, ImGuiInputTextFlags flags, ImGuiInputTextCallback callback, void* user_data) +{ + return InputTextEx(label, NULL, buf, (int)buf_size, size, flags | ImGuiInputTextFlags_Multiline, callback, user_data); +} + +bool ImGui::InputTextWithHint(const char* label, const char* hint, char* buf, size_t buf_size, ImGuiInputTextFlags flags, ImGuiInputTextCallback callback, void* user_data) +{ + IM_ASSERT(!(flags & ImGuiInputTextFlags_Multiline)); // call InputTextMultiline() + return InputTextEx(label, hint, buf, (int)buf_size, ImVec2(0, 0), flags, callback, user_data); +} + +static int InputTextCalcTextLenAndLineCount(const char* text_begin, const char** out_text_end) +{ + int line_count = 0; + const char* s = text_begin; + while (char c = *s++) // We are only matching for \n so we can ignore UTF-8 decoding + if (c == '\n') + line_count++; + s--; + if (s[0] != '\n' && s[0] != '\r') + line_count++; + *out_text_end = s; + return line_count; +} + +static ImVec2 InputTextCalcTextSizeW(const ImWchar* text_begin, const ImWchar* text_end, const ImWchar** remaining, ImVec2* out_offset, bool stop_on_new_line) +{ + ImGuiContext& g = *GImGui; + ImFont* font = g.Font; + const float line_height = g.FontSize; + const float scale = line_height / font->FontSize; + + ImVec2 text_size = ImVec2(0, 0); + float line_width = 0.0f; + + const ImWchar* s = text_begin; + while (s < text_end) + { + unsigned int c = (unsigned int)(*s++); + if (c == '\n') + { + text_size.x = ImMax(text_size.x, line_width); + text_size.y += line_height; + line_width = 0.0f; + if (stop_on_new_line) + break; + continue; + } + if (c == '\r') + continue; + + const float char_width = font->GetCharAdvance((ImWchar)c) * scale; + line_width += char_width; + } + + if (text_size.x < line_width) + text_size.x = line_width; + + if (out_offset) + *out_offset = ImVec2(line_width, text_size.y + line_height); // offset allow for the possibility of sitting after a trailing \n + + if (line_width > 0 || text_size.y == 0.0f) // whereas size.y will ignore the trailing \n + text_size.y += line_height; + + if (remaining) + *remaining = s; + + return text_size; +} + +// Wrapper for stb_textedit.h to edit text (our wrapper is for: statically sized buffer, single-line, wchar characters. InputText converts between UTF-8 and wchar) +namespace ImStb +{ + +static int STB_TEXTEDIT_STRINGLEN(const ImGuiInputTextState* obj) { return obj->CurLenW; } +static ImWchar STB_TEXTEDIT_GETCHAR(const ImGuiInputTextState* obj, int idx) { return obj->TextW[idx]; } +static float STB_TEXTEDIT_GETWIDTH(ImGuiInputTextState* obj, int line_start_idx, int char_idx) { ImWchar c = obj->TextW[line_start_idx + char_idx]; if (c == '\n') return STB_TEXTEDIT_GETWIDTH_NEWLINE; ImGuiContext& g = *GImGui; return g.Font->GetCharAdvance(c) * (g.FontSize / g.Font->FontSize); } +static int STB_TEXTEDIT_KEYTOTEXT(int key) { return key >= 0x200000 ? 0 : key; } +static ImWchar STB_TEXTEDIT_NEWLINE = '\n'; +static void STB_TEXTEDIT_LAYOUTROW(StbTexteditRow* r, ImGuiInputTextState* obj, int line_start_idx) +{ + const ImWchar* text = obj->TextW.Data; + const ImWchar* text_remaining = NULL; + const ImVec2 size = InputTextCalcTextSizeW(text + line_start_idx, text + obj->CurLenW, &text_remaining, NULL, true); + r->x0 = 0.0f; + r->x1 = size.x; + r->baseline_y_delta = size.y; + r->ymin = 0.0f; + r->ymax = size.y; + r->num_chars = (int)(text_remaining - (text + line_start_idx)); +} + +// When ImGuiInputTextFlags_Password is set, we don't want actions such as CTRL+Arrow to leak the fact that underlying data are blanks or separators. +static bool is_separator(unsigned int c) { return ImCharIsBlankW(c) || c==',' || c==';' || c=='(' || c==')' || c=='{' || c=='}' || c=='[' || c==']' || c=='|'; } +static int is_word_boundary_from_right(ImGuiInputTextState* obj, int idx) { if (obj->Flags & ImGuiInputTextFlags_Password) return 0; return idx > 0 ? (is_separator(obj->TextW[idx - 1]) && !is_separator(obj->TextW[idx]) ) : 1; } +static int STB_TEXTEDIT_MOVEWORDLEFT_IMPL(ImGuiInputTextState* obj, int idx) { idx--; while (idx >= 0 && !is_word_boundary_from_right(obj, idx)) idx--; return idx < 0 ? 0 : idx; } +#ifdef __APPLE__ // FIXME: Move setting to IO structure +static int is_word_boundary_from_left(ImGuiInputTextState* obj, int idx) { if (obj->Flags & ImGuiInputTextFlags_Password) return 0; return idx > 0 ? (!is_separator(obj->TextW[idx - 1]) && is_separator(obj->TextW[idx]) ) : 1; } +static int STB_TEXTEDIT_MOVEWORDRIGHT_IMPL(ImGuiInputTextState* obj, int idx) { idx++; int len = obj->CurLenW; while (idx < len && !is_word_boundary_from_left(obj, idx)) idx++; return idx > len ? len : idx; } +#else +static int STB_TEXTEDIT_MOVEWORDRIGHT_IMPL(ImGuiInputTextState* obj, int idx) { idx++; int len = obj->CurLenW; while (idx < len && !is_word_boundary_from_right(obj, idx)) idx++; return idx > len ? len : idx; } +#endif +#define STB_TEXTEDIT_MOVEWORDLEFT STB_TEXTEDIT_MOVEWORDLEFT_IMPL // They need to be #define for stb_textedit.h +#define STB_TEXTEDIT_MOVEWORDRIGHT STB_TEXTEDIT_MOVEWORDRIGHT_IMPL + +static void STB_TEXTEDIT_DELETECHARS(ImGuiInputTextState* obj, int pos, int n) +{ + ImWchar* dst = obj->TextW.Data + pos; + + // We maintain our buffer length in both UTF-8 and wchar formats + obj->Edited = true; + obj->CurLenA -= ImTextCountUtf8BytesFromStr(dst, dst + n); + obj->CurLenW -= n; + + // Offset remaining text (FIXME-OPT: Use memmove) + const ImWchar* src = obj->TextW.Data + pos + n; + while (ImWchar c = *src++) + *dst++ = c; + *dst = '\0'; +} + +static bool STB_TEXTEDIT_INSERTCHARS(ImGuiInputTextState* obj, int pos, const ImWchar* new_text, int new_text_len) +{ + const bool is_resizable = (obj->Flags & ImGuiInputTextFlags_CallbackResize) != 0; + const int text_len = obj->CurLenW; + IM_ASSERT(pos <= text_len); + + const int new_text_len_utf8 = ImTextCountUtf8BytesFromStr(new_text, new_text + new_text_len); + if (!is_resizable && (new_text_len_utf8 + obj->CurLenA + 1 > obj->BufCapacityA)) + return false; + + // Grow internal buffer if needed + if (new_text_len + text_len + 1 > obj->TextW.Size) + { + if (!is_resizable) + return false; + IM_ASSERT(text_len < obj->TextW.Size); + obj->TextW.resize(text_len + ImClamp(new_text_len * 4, 32, ImMax(256, new_text_len)) + 1); + } + + ImWchar* text = obj->TextW.Data; + if (pos != text_len) + memmove(text + pos + new_text_len, text + pos, (size_t)(text_len - pos) * sizeof(ImWchar)); + memcpy(text + pos, new_text, (size_t)new_text_len * sizeof(ImWchar)); + + obj->Edited = true; + obj->CurLenW += new_text_len; + obj->CurLenA += new_text_len_utf8; + obj->TextW[obj->CurLenW] = '\0'; + + return true; +} + +// We don't use an enum so we can build even with conflicting symbols (if another user of stb_textedit.h leak their STB_TEXTEDIT_K_* symbols) +#define STB_TEXTEDIT_K_LEFT 0x200000 // keyboard input to move cursor left +#define STB_TEXTEDIT_K_RIGHT 0x200001 // keyboard input to move cursor right +#define STB_TEXTEDIT_K_UP 0x200002 // keyboard input to move cursor up +#define STB_TEXTEDIT_K_DOWN 0x200003 // keyboard input to move cursor down +#define STB_TEXTEDIT_K_LINESTART 0x200004 // keyboard input to move cursor to start of line +#define STB_TEXTEDIT_K_LINEEND 0x200005 // keyboard input to move cursor to end of line +#define STB_TEXTEDIT_K_TEXTSTART 0x200006 // keyboard input to move cursor to start of text +#define STB_TEXTEDIT_K_TEXTEND 0x200007 // keyboard input to move cursor to end of text +#define STB_TEXTEDIT_K_DELETE 0x200008 // keyboard input to delete selection or character under cursor +#define STB_TEXTEDIT_K_BACKSPACE 0x200009 // keyboard input to delete selection or character left of cursor +#define STB_TEXTEDIT_K_UNDO 0x20000A // keyboard input to perform undo +#define STB_TEXTEDIT_K_REDO 0x20000B // keyboard input to perform redo +#define STB_TEXTEDIT_K_WORDLEFT 0x20000C // keyboard input to move cursor left one word +#define STB_TEXTEDIT_K_WORDRIGHT 0x20000D // keyboard input to move cursor right one word +#define STB_TEXTEDIT_K_PGUP 0x20000E // keyboard input to move cursor up a page +#define STB_TEXTEDIT_K_PGDOWN 0x20000F // keyboard input to move cursor down a page +#define STB_TEXTEDIT_K_SHIFT 0x400000 + +#define STB_TEXTEDIT_IMPLEMENTATION +#include "imstb_textedit.h" + +// stb_textedit internally allows for a single undo record to do addition and deletion, but somehow, calling +// the stb_textedit_paste() function creates two separate records, so we perform it manually. (FIXME: Report to nothings/stb?) +static void stb_textedit_replace(ImGuiInputTextState* str, STB_TexteditState* state, const STB_TEXTEDIT_CHARTYPE* text, int text_len) +{ + stb_text_makeundo_replace(str, state, 0, str->CurLenW, text_len); + ImStb::STB_TEXTEDIT_DELETECHARS(str, 0, str->CurLenW); + if (text_len <= 0) + return; + if (ImStb::STB_TEXTEDIT_INSERTCHARS(str, 0, text, text_len)) + { + state->cursor = text_len; + state->has_preferred_x = 0; + return; + } + IM_ASSERT(0); // Failed to insert character, normally shouldn't happen because of how we currently use stb_textedit_replace() +} + +} // namespace ImStb + +void ImGuiInputTextState::OnKeyPressed(int key) +{ + stb_textedit_key(this, &Stb, key); + CursorFollow = true; + CursorAnimReset(); +} + +ImGuiInputTextCallbackData::ImGuiInputTextCallbackData() +{ + memset(this, 0, sizeof(*this)); +} + +// Public API to manipulate UTF-8 text +// We expose UTF-8 to the user (unlike the STB_TEXTEDIT_* functions which are manipulating wchar) +// FIXME: The existence of this rarely exercised code path is a bit of a nuisance. +void ImGuiInputTextCallbackData::DeleteChars(int pos, int bytes_count) +{ + IM_ASSERT(pos + bytes_count <= BufTextLen); + char* dst = Buf + pos; + const char* src = Buf + pos + bytes_count; + while (char c = *src++) + *dst++ = c; + *dst = '\0'; + + if (CursorPos >= pos + bytes_count) + CursorPos -= bytes_count; + else if (CursorPos >= pos) + CursorPos = pos; + SelectionStart = SelectionEnd = CursorPos; + BufDirty = true; + BufTextLen -= bytes_count; +} + +void ImGuiInputTextCallbackData::InsertChars(int pos, const char* new_text, const char* new_text_end) +{ + const bool is_resizable = (Flags & ImGuiInputTextFlags_CallbackResize) != 0; + const int new_text_len = new_text_end ? (int)(new_text_end - new_text) : (int)strlen(new_text); + if (new_text_len + BufTextLen >= BufSize) + { + if (!is_resizable) + return; + + // Contrary to STB_TEXTEDIT_INSERTCHARS() this is working in the UTF8 buffer, hence the mildly similar code (until we remove the U16 buffer altogether!) + ImGuiContext& g = *GImGui; + ImGuiInputTextState* edit_state = &g.InputTextState; + IM_ASSERT(edit_state->ID != 0 && g.ActiveId == edit_state->ID); + IM_ASSERT(Buf == edit_state->TextA.Data); + int new_buf_size = BufTextLen + ImClamp(new_text_len * 4, 32, ImMax(256, new_text_len)) + 1; + edit_state->TextA.reserve(new_buf_size + 1); + Buf = edit_state->TextA.Data; + BufSize = edit_state->BufCapacityA = new_buf_size; + } + + if (BufTextLen != pos) + memmove(Buf + pos + new_text_len, Buf + pos, (size_t)(BufTextLen - pos)); + memcpy(Buf + pos, new_text, (size_t)new_text_len * sizeof(char)); + Buf[BufTextLen + new_text_len] = '\0'; + + if (CursorPos >= pos) + CursorPos += new_text_len; + SelectionStart = SelectionEnd = CursorPos; + BufDirty = true; + BufTextLen += new_text_len; +} + +// Return false to discard a character. +static bool InputTextFilterCharacter(unsigned int* p_char, ImGuiInputTextFlags flags, ImGuiInputTextCallback callback, void* user_data, ImGuiInputSource input_source) +{ + IM_ASSERT(input_source == ImGuiInputSource_Keyboard || input_source == ImGuiInputSource_Clipboard); + unsigned int c = *p_char; + + // Filter non-printable (NB: isprint is unreliable! see #2467) + bool apply_named_filters = true; + if (c < 0x20) + { + bool pass = false; + pass |= (c == '\n' && (flags & ImGuiInputTextFlags_Multiline)); + pass |= (c == '\t' && (flags & ImGuiInputTextFlags_AllowTabInput)); + if (!pass) + return false; + apply_named_filters = false; // Override named filters below so newline and tabs can still be inserted. + } + + if (input_source != ImGuiInputSource_Clipboard) + { + // We ignore Ascii representation of delete (emitted from Backspace on OSX, see #2578, #2817) + if (c == 127) + return false; + + // Filter private Unicode range. GLFW on OSX seems to send private characters for special keys like arrow keys (FIXME) + if (c >= 0xE000 && c <= 0xF8FF) + return false; + } + + // Filter Unicode ranges we are not handling in this build + if (c > IM_UNICODE_CODEPOINT_MAX) + return false; + + // Generic named filters + if (apply_named_filters && (flags & (ImGuiInputTextFlags_CharsDecimal | ImGuiInputTextFlags_CharsHexadecimal | ImGuiInputTextFlags_CharsUppercase | ImGuiInputTextFlags_CharsNoBlank | ImGuiInputTextFlags_CharsScientific))) + { + // The libc allows overriding locale, with e.g. 'setlocale(LC_NUMERIC, "de_DE.UTF-8");' which affect the output/input of printf/scanf. + // The standard mandate that programs starts in the "C" locale where the decimal point is '.'. + // We don't really intend to provide widespread support for it, but out of empathy for people stuck with using odd API, we support the bare minimum aka overriding the decimal point. + // Change the default decimal_point with: + // ImGui::GetCurrentContext()->PlatformLocaleDecimalPoint = *localeconv()->decimal_point; + ImGuiContext& g = *GImGui; + const unsigned c_decimal_point = (unsigned int)g.PlatformLocaleDecimalPoint; + + // Allow 0-9 . - + * / + if (flags & ImGuiInputTextFlags_CharsDecimal) + if (!(c >= '0' && c <= '9') && (c != c_decimal_point) && (c != '-') && (c != '+') && (c != '*') && (c != '/')) + return false; + + // Allow 0-9 . - + * / e E + if (flags & ImGuiInputTextFlags_CharsScientific) + if (!(c >= '0' && c <= '9') && (c != c_decimal_point) && (c != '-') && (c != '+') && (c != '*') && (c != '/') && (c != 'e') && (c != 'E')) + return false; + + // Allow 0-9 a-F A-F + if (flags & ImGuiInputTextFlags_CharsHexadecimal) + if (!(c >= '0' && c <= '9') && !(c >= 'a' && c <= 'f') && !(c >= 'A' && c <= 'F')) + return false; + + // Turn a-z into A-Z + if (flags & ImGuiInputTextFlags_CharsUppercase) + if (c >= 'a' && c <= 'z') + *p_char = (c += (unsigned int)('A' - 'a')); + + if (flags & ImGuiInputTextFlags_CharsNoBlank) + if (ImCharIsBlankW(c)) + return false; + } + + // Custom callback filter + if (flags & ImGuiInputTextFlags_CallbackCharFilter) + { + ImGuiInputTextCallbackData callback_data; + memset(&callback_data, 0, sizeof(ImGuiInputTextCallbackData)); + callback_data.EventFlag = ImGuiInputTextFlags_CallbackCharFilter; + callback_data.EventChar = (ImWchar)c; + callback_data.Flags = flags; + callback_data.UserData = user_data; + if (callback(&callback_data) != 0) + return false; + *p_char = callback_data.EventChar; + if (!callback_data.EventChar) + return false; + } + + return true; +} + +// Edit a string of text +// - buf_size account for the zero-terminator, so a buf_size of 6 can hold "Hello" but not "Hello!". +// This is so we can easily call InputText() on static arrays using ARRAYSIZE() and to match +// Note that in std::string world, capacity() would omit 1 byte used by the zero-terminator. +// - When active, hold on a privately held copy of the text (and apply back to 'buf'). So changing 'buf' while the InputText is active has no effect. +// - If you want to use ImGui::InputText() with std::string, see misc/cpp/imgui_stdlib.h +// (FIXME: Rather confusing and messy function, among the worse part of our codebase, expecting to rewrite a V2 at some point.. Partly because we are +// doing UTF8 > U16 > UTF8 conversions on the go to easily interface with stb_textedit. Ideally should stay in UTF-8 all the time. See https://github.com/nothings/stb/issues/188) +bool ImGui::InputTextEx(const char* label, const char* hint, char* buf, int buf_size, const ImVec2& size_arg, ImGuiInputTextFlags flags, ImGuiInputTextCallback callback, void* callback_user_data) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + IM_ASSERT(buf != NULL && buf_size >= 0); + IM_ASSERT(!((flags & ImGuiInputTextFlags_CallbackHistory) && (flags & ImGuiInputTextFlags_Multiline))); // Can't use both together (they both use up/down keys) + IM_ASSERT(!((flags & ImGuiInputTextFlags_CallbackCompletion) && (flags & ImGuiInputTextFlags_AllowTabInput))); // Can't use both together (they both use tab key) + + ImGuiContext& g = *GImGui; + ImGuiIO& io = g.IO; + const ImGuiStyle& style = g.Style; + + const bool RENDER_SELECTION_WHEN_INACTIVE = false; + const bool is_multiline = (flags & ImGuiInputTextFlags_Multiline) != 0; + const bool is_readonly = (flags & ImGuiInputTextFlags_ReadOnly) != 0; + const bool is_password = (flags & ImGuiInputTextFlags_Password) != 0; + const bool is_undoable = (flags & ImGuiInputTextFlags_NoUndoRedo) == 0; + const bool is_resizable = (flags & ImGuiInputTextFlags_CallbackResize) != 0; + if (is_resizable) + IM_ASSERT(callback != NULL); // Must provide a callback if you set the ImGuiInputTextFlags_CallbackResize flag! + + if (is_multiline) // Open group before calling GetID() because groups tracks id created within their scope, + BeginGroup(); + const ImGuiID id = window->GetID(label); + const ImVec2 label_size = CalcTextSize(label, NULL, true); + const ImVec2 frame_size = CalcItemSize(size_arg, CalcItemWidth(), (is_multiline ? g.FontSize * 8.0f : label_size.y) + style.FramePadding.y * 2.0f); // Arbitrary default of 8 lines high for multi-line + const ImVec2 total_size = ImVec2(frame_size.x + (label_size.x > 0.0f ? style.ItemInnerSpacing.x + label_size.x : 0.0f), frame_size.y); + + const ImRect frame_bb(window->DC.CursorPos, window->DC.CursorPos + frame_size); + const ImRect total_bb(frame_bb.Min, frame_bb.Min + total_size); + + ImGuiWindow* draw_window = window; + ImVec2 inner_size = frame_size; + ImGuiItemStatusFlags item_status_flags = 0; + if (is_multiline) + { + ImVec2 backup_pos = window->DC.CursorPos; + ItemSize(total_bb, style.FramePadding.y); + if (!ItemAdd(total_bb, id, &frame_bb, ImGuiItemFlags_Inputable)) + { + EndGroup(); + return false; + } + item_status_flags = g.LastItemData.StatusFlags; + window->DC.CursorPos = backup_pos; + + // We reproduce the contents of BeginChildFrame() in order to provide 'label' so our window internal data are easier to read/debug. + PushStyleColor(ImGuiCol_ChildBg, style.Colors[ImGuiCol_FrameBg]); + PushStyleVar(ImGuiStyleVar_ChildRounding, style.FrameRounding); + PushStyleVar(ImGuiStyleVar_ChildBorderSize, style.FrameBorderSize); + bool child_visible = BeginChildEx(label, id, frame_bb.GetSize(), true, ImGuiWindowFlags_NoMove); + PopStyleVar(2); + PopStyleColor(); + if (!child_visible) + { + EndChild(); + EndGroup(); + return false; + } + draw_window = g.CurrentWindow; // Child window + draw_window->DC.NavLayersActiveMaskNext |= (1 << draw_window->DC.NavLayerCurrent); // This is to ensure that EndChild() will display a navigation highlight so we can "enter" into it. + draw_window->DC.CursorPos += style.FramePadding; + inner_size.x -= draw_window->ScrollbarSizes.x; + } + else + { + // Support for internal ImGuiInputTextFlags_MergedItem flag, which could be redesigned as an ItemFlags if needed (with test performed in ItemAdd) + ItemSize(total_bb, style.FramePadding.y); + if (!(flags & ImGuiInputTextFlags_MergedItem)) + if (!ItemAdd(total_bb, id, &frame_bb, ImGuiItemFlags_Inputable)) + return false; + item_status_flags = g.LastItemData.StatusFlags; + } + const bool hovered = ItemHoverable(frame_bb, id); + if (hovered) + g.MouseCursor = ImGuiMouseCursor_TextInput; + + // We are only allowed to access the state if we are already the active widget. + ImGuiInputTextState* state = GetInputTextState(id); + + const bool focus_requested_by_code = (item_status_flags & ImGuiItemStatusFlags_FocusedByCode) != 0; + const bool focus_requested_by_tabbing = (item_status_flags & ImGuiItemStatusFlags_FocusedByTabbing) != 0; + + const bool user_clicked = hovered && io.MouseClicked[0]; + const bool user_nav_input_start = (g.ActiveId != id) && ((g.NavActivateInputId == id) || (g.NavActivateId == id && g.NavInputSource == ImGuiInputSource_Keyboard)); + const bool user_scroll_finish = is_multiline && state != NULL && g.ActiveId == 0 && g.ActiveIdPreviousFrame == GetWindowScrollbarID(draw_window, ImGuiAxis_Y); + const bool user_scroll_active = is_multiline && state != NULL && g.ActiveId == GetWindowScrollbarID(draw_window, ImGuiAxis_Y); + + bool clear_active_id = false; + bool select_all = (g.ActiveId != id) && ((flags & ImGuiInputTextFlags_AutoSelectAll) != 0 || user_nav_input_start) && (!is_multiline); + + float scroll_y = is_multiline ? draw_window->Scroll.y : FLT_MAX; + + const bool init_changed_specs = (state != NULL && state->Stb.single_line != !is_multiline); + const bool init_make_active = (user_clicked || user_scroll_finish || user_nav_input_start || focus_requested_by_code || focus_requested_by_tabbing); + const bool init_state = (init_make_active || user_scroll_active); + if ((init_state && g.ActiveId != id) || init_changed_specs) + { + // Access state even if we don't own it yet. + state = &g.InputTextState; + state->CursorAnimReset(); + + // Take a copy of the initial buffer value (both in original UTF-8 format and converted to wchar) + // From the moment we focused we are ignoring the content of 'buf' (unless we are in read-only mode) + const int buf_len = (int)strlen(buf); + state->InitialTextA.resize(buf_len + 1); // UTF-8. we use +1 to make sure that .Data is always pointing to at least an empty string. + memcpy(state->InitialTextA.Data, buf, buf_len + 1); + + // Start edition + const char* buf_end = NULL; + state->TextW.resize(buf_size + 1); // wchar count <= UTF-8 count. we use +1 to make sure that .Data is always pointing to at least an empty string. + state->TextA.resize(0); + state->TextAIsValid = false; // TextA is not valid yet (we will display buf until then) + state->CurLenW = ImTextStrFromUtf8(state->TextW.Data, buf_size, buf, NULL, &buf_end); + state->CurLenA = (int)(buf_end - buf); // We can't get the result from ImStrncpy() above because it is not UTF-8 aware. Here we'll cut off malformed UTF-8. + + // Preserve cursor position and undo/redo stack if we come back to same widget + // FIXME: For non-readonly widgets we might be able to require that TextAIsValid && TextA == buf ? (untested) and discard undo stack if user buffer has changed. + const bool recycle_state = (state->ID == id && !init_changed_specs); + if (recycle_state) + { + // Recycle existing cursor/selection/undo stack but clamp position + // Note a single mouse click will override the cursor/position immediately by calling stb_textedit_click handler. + state->CursorClamp(); + } + else + { + state->ID = id; + state->ScrollX = 0.0f; + stb_textedit_initialize_state(&state->Stb, !is_multiline); + if (!is_multiline && focus_requested_by_code) + select_all = true; + } + if (flags & ImGuiInputTextFlags_AlwaysOverwrite) + state->Stb.insert_mode = 1; // stb field name is indeed incorrect (see #2863) + if (!is_multiline && (focus_requested_by_tabbing || (user_clicked && io.KeyCtrl))) + select_all = true; + } + + if (g.ActiveId != id && init_make_active) + { + IM_ASSERT(state && state->ID == id); + SetActiveID(id, window); + SetFocusID(id, window); + FocusWindow(window); + + // Declare our inputs + IM_ASSERT(ImGuiNavInput_COUNT < 32); + g.ActiveIdUsingNavDirMask |= (1 << ImGuiDir_Left) | (1 << ImGuiDir_Right); + if (is_multiline || (flags & ImGuiInputTextFlags_CallbackHistory)) + g.ActiveIdUsingNavDirMask |= (1 << ImGuiDir_Up) | (1 << ImGuiDir_Down); + g.ActiveIdUsingNavInputMask |= (1 << ImGuiNavInput_Cancel); + g.ActiveIdUsingKeyInputMask |= ((ImU64)1 << ImGuiKey_Home) | ((ImU64)1 << ImGuiKey_End); + if (is_multiline) + g.ActiveIdUsingKeyInputMask |= ((ImU64)1 << ImGuiKey_PageUp) | ((ImU64)1 << ImGuiKey_PageDown); + if (flags & (ImGuiInputTextFlags_CallbackCompletion | ImGuiInputTextFlags_AllowTabInput)) // Disable keyboard tabbing out as we will use the \t character. + g.ActiveIdUsingKeyInputMask |= ((ImU64)1 << ImGuiKey_Tab); + } + + // We have an edge case if ActiveId was set through another widget (e.g. widget being swapped), clear id immediately (don't wait until the end of the function) + if (g.ActiveId == id && state == NULL) + ClearActiveID(); + + // Release focus when we click outside + if (g.ActiveId == id && io.MouseClicked[0] && !init_state && !init_make_active) //-V560 + clear_active_id = true; + + // Lock the decision of whether we are going to take the path displaying the cursor or selection + const bool render_cursor = (g.ActiveId == id) || (state && user_scroll_active); + bool render_selection = state && state->HasSelection() && (RENDER_SELECTION_WHEN_INACTIVE || render_cursor); + bool value_changed = false; + bool enter_pressed = false; + + // When read-only we always use the live data passed to the function + // FIXME-OPT: Because our selection/cursor code currently needs the wide text we need to convert it when active, which is not ideal :( + if (is_readonly && state != NULL && (render_cursor || render_selection)) + { + const char* buf_end = NULL; + state->TextW.resize(buf_size + 1); + state->CurLenW = ImTextStrFromUtf8(state->TextW.Data, state->TextW.Size, buf, NULL, &buf_end); + state->CurLenA = (int)(buf_end - buf); + state->CursorClamp(); + render_selection &= state->HasSelection(); + } + + // Select the buffer to render. + const bool buf_display_from_state = (render_cursor || render_selection || g.ActiveId == id) && !is_readonly && state && state->TextAIsValid; + const bool is_displaying_hint = (hint != NULL && (buf_display_from_state ? state->TextA.Data : buf)[0] == 0); + + // Password pushes a temporary font with only a fallback glyph + if (is_password && !is_displaying_hint) + { + const ImFontGlyph* glyph = g.Font->FindGlyph('*'); + ImFont* password_font = &g.InputTextPasswordFont; + password_font->FontSize = g.Font->FontSize; + password_font->Scale = g.Font->Scale; + password_font->Ascent = g.Font->Ascent; + password_font->Descent = g.Font->Descent; + password_font->ContainerAtlas = g.Font->ContainerAtlas; + password_font->FallbackGlyph = glyph; + password_font->FallbackAdvanceX = glyph->AdvanceX; + IM_ASSERT(password_font->Glyphs.empty() && password_font->IndexAdvanceX.empty() && password_font->IndexLookup.empty()); + PushFont(password_font); + } + + // Process mouse inputs and character inputs + int backup_current_text_length = 0; + if (g.ActiveId == id) + { + IM_ASSERT(state != NULL); + backup_current_text_length = state->CurLenA; + state->Edited = false; + state->BufCapacityA = buf_size; + state->Flags = flags; + state->UserCallback = callback; + state->UserCallbackData = callback_user_data; + + // Although we are active we don't prevent mouse from hovering other elements unless we are interacting right now with the widget. + // Down the line we should have a cleaner library-wide concept of Selected vs Active. + g.ActiveIdAllowOverlap = !io.MouseDown[0]; + g.WantTextInputNextFrame = 1; + + // Edit in progress + const float mouse_x = (io.MousePos.x - frame_bb.Min.x - style.FramePadding.x) + state->ScrollX; + const float mouse_y = (is_multiline ? (io.MousePos.y - draw_window->DC.CursorPos.y) : (g.FontSize * 0.5f)); + + const bool is_osx = io.ConfigMacOSXBehaviors; + if (select_all || (hovered && !is_osx && io.MouseDoubleClicked[0])) + { + state->SelectAll(); + state->SelectedAllMouseLock = true; + } + else if (hovered && is_osx && io.MouseDoubleClicked[0]) + { + // Double-click select a word only, OS X style (by simulating keystrokes) + state->OnKeyPressed(STB_TEXTEDIT_K_WORDLEFT); + state->OnKeyPressed(STB_TEXTEDIT_K_WORDRIGHT | STB_TEXTEDIT_K_SHIFT); + } + else if (io.MouseClicked[0] && !state->SelectedAllMouseLock) + { + if (hovered) + { + stb_textedit_click(state, &state->Stb, mouse_x, mouse_y); + state->CursorAnimReset(); + } + } + else if (io.MouseDown[0] && !state->SelectedAllMouseLock && (io.MouseDelta.x != 0.0f || io.MouseDelta.y != 0.0f)) + { + stb_textedit_drag(state, &state->Stb, mouse_x, mouse_y); + state->CursorAnimReset(); + state->CursorFollow = true; + } + if (state->SelectedAllMouseLock && !io.MouseDown[0]) + state->SelectedAllMouseLock = false; + + // It is ill-defined whether the backend needs to send a \t character when pressing the TAB keys. + // Win32 and GLFW naturally do it but not SDL. + const bool ignore_char_inputs = (io.KeyCtrl && !io.KeyAlt) || (is_osx && io.KeySuper); + if ((flags & ImGuiInputTextFlags_AllowTabInput) && IsKeyPressedMap(ImGuiKey_Tab) && !ignore_char_inputs && !io.KeyShift && !is_readonly) + if (!io.InputQueueCharacters.contains('\t')) + { + unsigned int c = '\t'; // Insert TAB + if (InputTextFilterCharacter(&c, flags, callback, callback_user_data, ImGuiInputSource_Keyboard)) + state->OnKeyPressed((int)c); + } + + // Process regular text input (before we check for Return because using some IME will effectively send a Return?) + // We ignore CTRL inputs, but need to allow ALT+CTRL as some keyboards (e.g. German) use AltGR (which _is_ Alt+Ctrl) to input certain characters. + if (io.InputQueueCharacters.Size > 0) + { + if (!ignore_char_inputs && !is_readonly && !user_nav_input_start) + for (int n = 0; n < io.InputQueueCharacters.Size; n++) + { + // Insert character if they pass filtering + unsigned int c = (unsigned int)io.InputQueueCharacters[n]; + if (c == '\t' && io.KeyShift) + continue; + if (InputTextFilterCharacter(&c, flags, callback, callback_user_data, ImGuiInputSource_Keyboard)) + state->OnKeyPressed((int)c); + } + + // Consume characters + io.InputQueueCharacters.resize(0); + } + } + + // Process other shortcuts/key-presses + bool cancel_edit = false; + if (g.ActiveId == id && !g.ActiveIdIsJustActivated && !clear_active_id) + { + IM_ASSERT(state != NULL); + IM_ASSERT(io.KeyMods == GetMergedKeyModFlags() && "Mismatching io.KeyCtrl/io.KeyShift/io.KeyAlt/io.KeySuper vs io.KeyMods"); // We rarely do this check, but if anything let's do it here. + + const int row_count_per_page = ImMax((int)((inner_size.y - style.FramePadding.y) / g.FontSize), 1); + state->Stb.row_count_per_page = row_count_per_page; + + const int k_mask = (io.KeyShift ? STB_TEXTEDIT_K_SHIFT : 0); + const bool is_osx = io.ConfigMacOSXBehaviors; + const bool is_osx_shift_shortcut = is_osx && (io.KeyMods == (ImGuiKeyModFlags_Super | ImGuiKeyModFlags_Shift)); + const bool is_wordmove_key_down = is_osx ? io.KeyAlt : io.KeyCtrl; // OS X style: Text editing cursor movement using Alt instead of Ctrl + const bool is_startend_key_down = is_osx && io.KeySuper && !io.KeyCtrl && !io.KeyAlt; // OS X style: Line/Text Start and End using Cmd+Arrows instead of Home/End + const bool is_ctrl_key_only = (io.KeyMods == ImGuiKeyModFlags_Ctrl); + const bool is_shift_key_only = (io.KeyMods == ImGuiKeyModFlags_Shift); + const bool is_shortcut_key = g.IO.ConfigMacOSXBehaviors ? (io.KeyMods == ImGuiKeyModFlags_Super) : (io.KeyMods == ImGuiKeyModFlags_Ctrl); + + const bool is_cut = ((is_shortcut_key && IsKeyPressedMap(ImGuiKey_X)) || (is_shift_key_only && IsKeyPressedMap(ImGuiKey_Delete))) && !is_readonly && !is_password && (!is_multiline || state->HasSelection()); + const bool is_copy = ((is_shortcut_key && IsKeyPressedMap(ImGuiKey_C)) || (is_ctrl_key_only && IsKeyPressedMap(ImGuiKey_Insert))) && !is_password && (!is_multiline || state->HasSelection()); + const bool is_paste = ((is_shortcut_key && IsKeyPressedMap(ImGuiKey_V)) || (is_shift_key_only && IsKeyPressedMap(ImGuiKey_Insert))) && !is_readonly; + const bool is_undo = ((is_shortcut_key && IsKeyPressedMap(ImGuiKey_Z)) && !is_readonly && is_undoable); + const bool is_redo = ((is_shortcut_key && IsKeyPressedMap(ImGuiKey_Y)) || (is_osx_shift_shortcut && IsKeyPressedMap(ImGuiKey_Z))) && !is_readonly && is_undoable; + + // We allow validate/cancel with Nav source (gamepad) to makes it easier to undo an accidental NavInput press with no keyboard wired, but otherwise it isn't very useful. + const bool is_validate = IsKeyPressedMap(ImGuiKey_Enter) || IsKeyPressedMap(ImGuiKey_KeyPadEnter) || IsNavInputTest(ImGuiNavInput_Activate, ImGuiInputReadMode_Pressed) || IsNavInputTest(ImGuiNavInput_Input, ImGuiInputReadMode_Pressed); + const bool is_cancel = IsKeyPressedMap(ImGuiKey_Escape) || IsNavInputTest(ImGuiNavInput_Cancel, ImGuiInputReadMode_Pressed); + + if (IsKeyPressedMap(ImGuiKey_LeftArrow)) { state->OnKeyPressed((is_startend_key_down ? STB_TEXTEDIT_K_LINESTART : is_wordmove_key_down ? STB_TEXTEDIT_K_WORDLEFT : STB_TEXTEDIT_K_LEFT) | k_mask); } + else if (IsKeyPressedMap(ImGuiKey_RightArrow)) { state->OnKeyPressed((is_startend_key_down ? STB_TEXTEDIT_K_LINEEND : is_wordmove_key_down ? STB_TEXTEDIT_K_WORDRIGHT : STB_TEXTEDIT_K_RIGHT) | k_mask); } + else if (IsKeyPressedMap(ImGuiKey_UpArrow) && is_multiline) { if (io.KeyCtrl) SetScrollY(draw_window, ImMax(draw_window->Scroll.y - g.FontSize, 0.0f)); else state->OnKeyPressed((is_startend_key_down ? STB_TEXTEDIT_K_TEXTSTART : STB_TEXTEDIT_K_UP) | k_mask); } + else if (IsKeyPressedMap(ImGuiKey_DownArrow) && is_multiline) { if (io.KeyCtrl) SetScrollY(draw_window, ImMin(draw_window->Scroll.y + g.FontSize, GetScrollMaxY())); else state->OnKeyPressed((is_startend_key_down ? STB_TEXTEDIT_K_TEXTEND : STB_TEXTEDIT_K_DOWN) | k_mask); } + else if (IsKeyPressedMap(ImGuiKey_PageUp) && is_multiline) { state->OnKeyPressed(STB_TEXTEDIT_K_PGUP | k_mask); scroll_y -= row_count_per_page * g.FontSize; } + else if (IsKeyPressedMap(ImGuiKey_PageDown) && is_multiline) { state->OnKeyPressed(STB_TEXTEDIT_K_PGDOWN | k_mask); scroll_y += row_count_per_page * g.FontSize; } + else if (IsKeyPressedMap(ImGuiKey_Home)) { state->OnKeyPressed(io.KeyCtrl ? STB_TEXTEDIT_K_TEXTSTART | k_mask : STB_TEXTEDIT_K_LINESTART | k_mask); } + else if (IsKeyPressedMap(ImGuiKey_End)) { state->OnKeyPressed(io.KeyCtrl ? STB_TEXTEDIT_K_TEXTEND | k_mask : STB_TEXTEDIT_K_LINEEND | k_mask); } + else if (IsKeyPressedMap(ImGuiKey_Delete) && !is_readonly) { state->OnKeyPressed(STB_TEXTEDIT_K_DELETE | k_mask); } + else if (IsKeyPressedMap(ImGuiKey_Backspace) && !is_readonly) + { + if (!state->HasSelection()) + { + if (is_wordmove_key_down) + state->OnKeyPressed(STB_TEXTEDIT_K_WORDLEFT | STB_TEXTEDIT_K_SHIFT); + else if (is_osx && io.KeySuper && !io.KeyAlt && !io.KeyCtrl) + state->OnKeyPressed(STB_TEXTEDIT_K_LINESTART | STB_TEXTEDIT_K_SHIFT); + } + state->OnKeyPressed(STB_TEXTEDIT_K_BACKSPACE | k_mask); + } + else if (is_validate) + { + bool ctrl_enter_for_new_line = (flags & ImGuiInputTextFlags_CtrlEnterForNewLine) != 0; + if (!is_multiline || (ctrl_enter_for_new_line && !io.KeyCtrl) || (!ctrl_enter_for_new_line && io.KeyCtrl)) + { + enter_pressed = clear_active_id = true; + } + else if (!is_readonly) + { + unsigned int c = '\n'; // Insert new line + if (InputTextFilterCharacter(&c, flags, callback, callback_user_data, ImGuiInputSource_Keyboard)) + state->OnKeyPressed((int)c); + } + } + else if (is_cancel) + { + clear_active_id = cancel_edit = true; + } + else if (is_undo || is_redo) + { + state->OnKeyPressed(is_undo ? STB_TEXTEDIT_K_UNDO : STB_TEXTEDIT_K_REDO); + state->ClearSelection(); + } + else if (is_shortcut_key && IsKeyPressedMap(ImGuiKey_A)) + { + state->SelectAll(); + state->CursorFollow = true; + } + else if (is_cut || is_copy) + { + // Cut, Copy + if (io.SetClipboardTextFn) + { + const int ib = state->HasSelection() ? ImMin(state->Stb.select_start, state->Stb.select_end) : 0; + const int ie = state->HasSelection() ? ImMax(state->Stb.select_start, state->Stb.select_end) : state->CurLenW; + const int clipboard_data_len = ImTextCountUtf8BytesFromStr(state->TextW.Data + ib, state->TextW.Data + ie) + 1; + char* clipboard_data = (char*)IM_ALLOC(clipboard_data_len * sizeof(char)); + ImTextStrToUtf8(clipboard_data, clipboard_data_len, state->TextW.Data + ib, state->TextW.Data + ie); + SetClipboardText(clipboard_data); + MemFree(clipboard_data); + } + if (is_cut) + { + if (!state->HasSelection()) + state->SelectAll(); + state->CursorFollow = true; + stb_textedit_cut(state, &state->Stb); + } + } + else if (is_paste) + { + if (const char* clipboard = GetClipboardText()) + { + // Filter pasted buffer + const int clipboard_len = (int)strlen(clipboard); + ImWchar* clipboard_filtered = (ImWchar*)IM_ALLOC((clipboard_len + 1) * sizeof(ImWchar)); + int clipboard_filtered_len = 0; + for (const char* s = clipboard; *s; ) + { + unsigned int c; + s += ImTextCharFromUtf8(&c, s, NULL); + if (c == 0) + break; + if (!InputTextFilterCharacter(&c, flags, callback, callback_user_data, ImGuiInputSource_Clipboard)) + continue; + clipboard_filtered[clipboard_filtered_len++] = (ImWchar)c; + } + clipboard_filtered[clipboard_filtered_len] = 0; + if (clipboard_filtered_len > 0) // If everything was filtered, ignore the pasting operation + { + stb_textedit_paste(state, &state->Stb, clipboard_filtered, clipboard_filtered_len); + state->CursorFollow = true; + } + MemFree(clipboard_filtered); + } + } + + // Update render selection flag after events have been handled, so selection highlight can be displayed during the same frame. + render_selection |= state->HasSelection() && (RENDER_SELECTION_WHEN_INACTIVE || render_cursor); + } + + // Process callbacks and apply result back to user's buffer. + if (g.ActiveId == id) + { + IM_ASSERT(state != NULL); + const char* apply_new_text = NULL; + int apply_new_text_length = 0; + if (cancel_edit) + { + // Restore initial value. Only return true if restoring to the initial value changes the current buffer contents. + if (!is_readonly && strcmp(buf, state->InitialTextA.Data) != 0) + { + // Push records into the undo stack so we can CTRL+Z the revert operation itself + apply_new_text = state->InitialTextA.Data; + apply_new_text_length = state->InitialTextA.Size - 1; + ImVector w_text; + if (apply_new_text_length > 0) + { + w_text.resize(ImTextCountCharsFromUtf8(apply_new_text, apply_new_text + apply_new_text_length) + 1); + ImTextStrFromUtf8(w_text.Data, w_text.Size, apply_new_text, apply_new_text + apply_new_text_length); + } + stb_textedit_replace(state, &state->Stb, w_text.Data, (apply_new_text_length > 0) ? (w_text.Size - 1) : 0); + } + } + + // When using 'ImGuiInputTextFlags_EnterReturnsTrue' as a special case we reapply the live buffer back to the input buffer before clearing ActiveId, even though strictly speaking it wasn't modified on this frame. + // If we didn't do that, code like InputInt() with ImGuiInputTextFlags_EnterReturnsTrue would fail. + // This also allows the user to use InputText() with ImGuiInputTextFlags_EnterReturnsTrue without maintaining any user-side storage (please note that if you use this property along ImGuiInputTextFlags_CallbackResize you can end up with your temporary string object unnecessarily allocating once a frame, either store your string data, either if you don't then don't use ImGuiInputTextFlags_CallbackResize). + bool apply_edit_back_to_user_buffer = !cancel_edit || (enter_pressed && (flags & ImGuiInputTextFlags_EnterReturnsTrue) != 0); + if (apply_edit_back_to_user_buffer) + { + // Apply new value immediately - copy modified buffer back + // Note that as soon as the input box is active, the in-widget value gets priority over any underlying modification of the input buffer + // FIXME: We actually always render 'buf' when calling DrawList->AddText, making the comment above incorrect. + // FIXME-OPT: CPU waste to do this every time the widget is active, should mark dirty state from the stb_textedit callbacks. + if (!is_readonly) + { + state->TextAIsValid = true; + state->TextA.resize(state->TextW.Size * 4 + 1); + ImTextStrToUtf8(state->TextA.Data, state->TextA.Size, state->TextW.Data, NULL); + } + + // User callback + if ((flags & (ImGuiInputTextFlags_CallbackCompletion | ImGuiInputTextFlags_CallbackHistory | ImGuiInputTextFlags_CallbackEdit | ImGuiInputTextFlags_CallbackAlways)) != 0) + { + IM_ASSERT(callback != NULL); + + // The reason we specify the usage semantic (Completion/History) is that Completion needs to disable keyboard TABBING at the moment. + ImGuiInputTextFlags event_flag = 0; + ImGuiKey event_key = ImGuiKey_COUNT; + if ((flags & ImGuiInputTextFlags_CallbackCompletion) != 0 && IsKeyPressedMap(ImGuiKey_Tab)) + { + event_flag = ImGuiInputTextFlags_CallbackCompletion; + event_key = ImGuiKey_Tab; + } + else if ((flags & ImGuiInputTextFlags_CallbackHistory) != 0 && IsKeyPressedMap(ImGuiKey_UpArrow)) + { + event_flag = ImGuiInputTextFlags_CallbackHistory; + event_key = ImGuiKey_UpArrow; + } + else if ((flags & ImGuiInputTextFlags_CallbackHistory) != 0 && IsKeyPressedMap(ImGuiKey_DownArrow)) + { + event_flag = ImGuiInputTextFlags_CallbackHistory; + event_key = ImGuiKey_DownArrow; + } + else if ((flags & ImGuiInputTextFlags_CallbackEdit) && state->Edited) + { + event_flag = ImGuiInputTextFlags_CallbackEdit; + } + else if (flags & ImGuiInputTextFlags_CallbackAlways) + { + event_flag = ImGuiInputTextFlags_CallbackAlways; + } + + if (event_flag) + { + ImGuiInputTextCallbackData callback_data; + memset(&callback_data, 0, sizeof(ImGuiInputTextCallbackData)); + callback_data.EventFlag = event_flag; + callback_data.Flags = flags; + callback_data.UserData = callback_user_data; + + callback_data.EventKey = event_key; + callback_data.Buf = state->TextA.Data; + callback_data.BufTextLen = state->CurLenA; + callback_data.BufSize = state->BufCapacityA; + callback_data.BufDirty = false; + + // We have to convert from wchar-positions to UTF-8-positions, which can be pretty slow (an incentive to ditch the ImWchar buffer, see https://github.com/nothings/stb/issues/188) + ImWchar* text = state->TextW.Data; + const int utf8_cursor_pos = callback_data.CursorPos = ImTextCountUtf8BytesFromStr(text, text + state->Stb.cursor); + const int utf8_selection_start = callback_data.SelectionStart = ImTextCountUtf8BytesFromStr(text, text + state->Stb.select_start); + const int utf8_selection_end = callback_data.SelectionEnd = ImTextCountUtf8BytesFromStr(text, text + state->Stb.select_end); + + // Call user code + callback(&callback_data); + + // Read back what user may have modified + IM_ASSERT(callback_data.Buf == state->TextA.Data); // Invalid to modify those fields + IM_ASSERT(callback_data.BufSize == state->BufCapacityA); + IM_ASSERT(callback_data.Flags == flags); + const bool buf_dirty = callback_data.BufDirty; + if (callback_data.CursorPos != utf8_cursor_pos || buf_dirty) { state->Stb.cursor = ImTextCountCharsFromUtf8(callback_data.Buf, callback_data.Buf + callback_data.CursorPos); state->CursorFollow = true; } + if (callback_data.SelectionStart != utf8_selection_start || buf_dirty) { state->Stb.select_start = (callback_data.SelectionStart == callback_data.CursorPos) ? state->Stb.cursor : ImTextCountCharsFromUtf8(callback_data.Buf, callback_data.Buf + callback_data.SelectionStart); } + if (callback_data.SelectionEnd != utf8_selection_end || buf_dirty) { state->Stb.select_end = (callback_data.SelectionEnd == callback_data.SelectionStart) ? state->Stb.select_start : ImTextCountCharsFromUtf8(callback_data.Buf, callback_data.Buf + callback_data.SelectionEnd); } + if (buf_dirty) + { + IM_ASSERT(callback_data.BufTextLen == (int)strlen(callback_data.Buf)); // You need to maintain BufTextLen if you change the text! + if (callback_data.BufTextLen > backup_current_text_length && is_resizable) + state->TextW.resize(state->TextW.Size + (callback_data.BufTextLen - backup_current_text_length)); + state->CurLenW = ImTextStrFromUtf8(state->TextW.Data, state->TextW.Size, callback_data.Buf, NULL); + state->CurLenA = callback_data.BufTextLen; // Assume correct length and valid UTF-8 from user, saves us an extra strlen() + state->CursorAnimReset(); + } + } + } + + // Will copy result string if modified + if (!is_readonly && strcmp(state->TextA.Data, buf) != 0) + { + apply_new_text = state->TextA.Data; + apply_new_text_length = state->CurLenA; + } + } + + // Copy result to user buffer + if (apply_new_text) + { + // We cannot test for 'backup_current_text_length != apply_new_text_length' here because we have no guarantee that the size + // of our owned buffer matches the size of the string object held by the user, and by design we allow InputText() to be used + // without any storage on user's side. + IM_ASSERT(apply_new_text_length >= 0); + if (is_resizable) + { + ImGuiInputTextCallbackData callback_data; + callback_data.EventFlag = ImGuiInputTextFlags_CallbackResize; + callback_data.Flags = flags; + callback_data.Buf = buf; + callback_data.BufTextLen = apply_new_text_length; + callback_data.BufSize = ImMax(buf_size, apply_new_text_length + 1); + callback_data.UserData = callback_user_data; + callback(&callback_data); + buf = callback_data.Buf; + buf_size = callback_data.BufSize; + apply_new_text_length = ImMin(callback_data.BufTextLen, buf_size - 1); + IM_ASSERT(apply_new_text_length <= buf_size); + } + //IMGUI_DEBUG_LOG("InputText(\"%s\"): apply_new_text length %d\n", label, apply_new_text_length); + + // If the underlying buffer resize was denied or not carried to the next frame, apply_new_text_length+1 may be >= buf_size. + ImStrncpy(buf, apply_new_text, ImMin(apply_new_text_length + 1, buf_size)); + value_changed = true; + } + + // Clear temporary user storage + state->Flags = ImGuiInputTextFlags_None; + state->UserCallback = NULL; + state->UserCallbackData = NULL; + } + + // Release active ID at the end of the function (so e.g. pressing Return still does a final application of the value) + if (clear_active_id && g.ActiveId == id) + ClearActiveID(); + + // Render frame + if (!is_multiline) + { + RenderNavHighlight(frame_bb, id); + RenderFrame(frame_bb.Min, frame_bb.Max, GetColorU32(ImGuiCol_FrameBg), true, style.FrameRounding); + } + + const ImVec4 clip_rect(frame_bb.Min.x, frame_bb.Min.y, frame_bb.Min.x + inner_size.x, frame_bb.Min.y + inner_size.y); // Not using frame_bb.Max because we have adjusted size + ImVec2 draw_pos = is_multiline ? draw_window->DC.CursorPos : frame_bb.Min + style.FramePadding; + ImVec2 text_size(0.0f, 0.0f); + + // Set upper limit of single-line InputTextEx() at 2 million characters strings. The current pathological worst case is a long line + // without any carriage return, which would makes ImFont::RenderText() reserve too many vertices and probably crash. Avoid it altogether. + // Note that we only use this limit on single-line InputText(), so a pathologically large line on a InputTextMultiline() would still crash. + const int buf_display_max_length = 2 * 1024 * 1024; + const char* buf_display = buf_display_from_state ? state->TextA.Data : buf; //-V595 + const char* buf_display_end = NULL; // We have specialized paths below for setting the length + if (is_displaying_hint) + { + buf_display = hint; + buf_display_end = hint + strlen(hint); + } + + // Render text. We currently only render selection when the widget is active or while scrolling. + // FIXME: We could remove the '&& render_cursor' to keep rendering selection when inactive. + if (render_cursor || render_selection) + { + IM_ASSERT(state != NULL); + if (!is_displaying_hint) + buf_display_end = buf_display + state->CurLenA; + + // Render text (with cursor and selection) + // This is going to be messy. We need to: + // - Display the text (this alone can be more easily clipped) + // - Handle scrolling, highlight selection, display cursor (those all requires some form of 1d->2d cursor position calculation) + // - Measure text height (for scrollbar) + // We are attempting to do most of that in **one main pass** to minimize the computation cost (non-negligible for large amount of text) + 2nd pass for selection rendering (we could merge them by an extra refactoring effort) + // FIXME: This should occur on buf_display but we'd need to maintain cursor/select_start/select_end for UTF-8. + const ImWchar* text_begin = state->TextW.Data; + ImVec2 cursor_offset, select_start_offset; + + { + // Find lines numbers straddling 'cursor' (slot 0) and 'select_start' (slot 1) positions. + const ImWchar* searches_input_ptr[2] = { NULL, NULL }; + int searches_result_line_no[2] = { -1000, -1000 }; + int searches_remaining = 0; + if (render_cursor) + { + searches_input_ptr[0] = text_begin + state->Stb.cursor; + searches_result_line_no[0] = -1; + searches_remaining++; + } + if (render_selection) + { + searches_input_ptr[1] = text_begin + ImMin(state->Stb.select_start, state->Stb.select_end); + searches_result_line_no[1] = -1; + searches_remaining++; + } + + // Iterate all lines to find our line numbers + // In multi-line mode, we never exit the loop until all lines are counted, so add one extra to the searches_remaining counter. + searches_remaining += is_multiline ? 1 : 0; + int line_count = 0; + //for (const ImWchar* s = text_begin; (s = (const ImWchar*)wcschr((const wchar_t*)s, (wchar_t)'\n')) != NULL; s++) // FIXME-OPT: Could use this when wchar_t are 16-bit + for (const ImWchar* s = text_begin; *s != 0; s++) + if (*s == '\n') + { + line_count++; + if (searches_result_line_no[0] == -1 && s >= searches_input_ptr[0]) { searches_result_line_no[0] = line_count; if (--searches_remaining <= 0) break; } + if (searches_result_line_no[1] == -1 && s >= searches_input_ptr[1]) { searches_result_line_no[1] = line_count; if (--searches_remaining <= 0) break; } + } + line_count++; + if (searches_result_line_no[0] == -1) + searches_result_line_no[0] = line_count; + if (searches_result_line_no[1] == -1) + searches_result_line_no[1] = line_count; + + // Calculate 2d position by finding the beginning of the line and measuring distance + cursor_offset.x = InputTextCalcTextSizeW(ImStrbolW(searches_input_ptr[0], text_begin), searches_input_ptr[0]).x; + cursor_offset.y = searches_result_line_no[0] * g.FontSize; + if (searches_result_line_no[1] >= 0) + { + select_start_offset.x = InputTextCalcTextSizeW(ImStrbolW(searches_input_ptr[1], text_begin), searches_input_ptr[1]).x; + select_start_offset.y = searches_result_line_no[1] * g.FontSize; + } + + // Store text height (note that we haven't calculated text width at all, see GitHub issues #383, #1224) + if (is_multiline) + text_size = ImVec2(inner_size.x, line_count * g.FontSize); + } + + // Scroll + if (render_cursor && state->CursorFollow) + { + // Horizontal scroll in chunks of quarter width + if (!(flags & ImGuiInputTextFlags_NoHorizontalScroll)) + { + const float scroll_increment_x = inner_size.x * 0.25f; + const float visible_width = inner_size.x - style.FramePadding.x; + if (cursor_offset.x < state->ScrollX) + state->ScrollX = IM_FLOOR(ImMax(0.0f, cursor_offset.x - scroll_increment_x)); + else if (cursor_offset.x - visible_width >= state->ScrollX) + state->ScrollX = IM_FLOOR(cursor_offset.x - visible_width + scroll_increment_x); + } + else + { + state->ScrollX = 0.0f; + } + + // Vertical scroll + if (is_multiline) + { + // Test if cursor is vertically visible + if (cursor_offset.y - g.FontSize < scroll_y) + scroll_y = ImMax(0.0f, cursor_offset.y - g.FontSize); + else if (cursor_offset.y - inner_size.y >= scroll_y) + scroll_y = cursor_offset.y - inner_size.y + style.FramePadding.y * 2.0f; + const float scroll_max_y = ImMax((text_size.y + style.FramePadding.y * 2.0f) - inner_size.y, 0.0f); + scroll_y = ImClamp(scroll_y, 0.0f, scroll_max_y); + draw_pos.y += (draw_window->Scroll.y - scroll_y); // Manipulate cursor pos immediately avoid a frame of lag + draw_window->Scroll.y = scroll_y; + } + + state->CursorFollow = false; + } + + // Draw selection + const ImVec2 draw_scroll = ImVec2(state->ScrollX, 0.0f); + if (render_selection) + { + const ImWchar* text_selected_begin = text_begin + ImMin(state->Stb.select_start, state->Stb.select_end); + const ImWchar* text_selected_end = text_begin + ImMax(state->Stb.select_start, state->Stb.select_end); + + ImU32 bg_color = GetColorU32(ImGuiCol_TextSelectedBg, render_cursor ? 1.0f : 0.6f); // FIXME: current code flow mandate that render_cursor is always true here, we are leaving the transparent one for tests. + float bg_offy_up = is_multiline ? 0.0f : -1.0f; // FIXME: those offsets should be part of the style? they don't play so well with multi-line selection. + float bg_offy_dn = is_multiline ? 0.0f : 2.0f; + ImVec2 rect_pos = draw_pos + select_start_offset - draw_scroll; + for (const ImWchar* p = text_selected_begin; p < text_selected_end; ) + { + if (rect_pos.y > clip_rect.w + g.FontSize) + break; + if (rect_pos.y < clip_rect.y) + { + //p = (const ImWchar*)wmemchr((const wchar_t*)p, '\n', text_selected_end - p); // FIXME-OPT: Could use this when wchar_t are 16-bit + //p = p ? p + 1 : text_selected_end; + while (p < text_selected_end) + if (*p++ == '\n') + break; + } + else + { + ImVec2 rect_size = InputTextCalcTextSizeW(p, text_selected_end, &p, NULL, true); + if (rect_size.x <= 0.0f) rect_size.x = IM_FLOOR(g.Font->GetCharAdvance((ImWchar)' ') * 0.50f); // So we can see selected empty lines + ImRect rect(rect_pos + ImVec2(0.0f, bg_offy_up - g.FontSize), rect_pos + ImVec2(rect_size.x, bg_offy_dn)); + rect.ClipWith(clip_rect); + if (rect.Overlaps(clip_rect)) + draw_window->DrawList->AddRectFilled(rect.Min, rect.Max, bg_color); + } + rect_pos.x = draw_pos.x - draw_scroll.x; + rect_pos.y += g.FontSize; + } + } + + // We test for 'buf_display_max_length' as a way to avoid some pathological cases (e.g. single-line 1 MB string) which would make ImDrawList crash. + if (is_multiline || (buf_display_end - buf_display) < buf_display_max_length) + { + ImU32 col = GetColorU32(is_displaying_hint ? ImGuiCol_TextDisabled : ImGuiCol_Text); + draw_window->DrawList->AddText(g.Font, g.FontSize, draw_pos - draw_scroll, col, buf_display, buf_display_end, 0.0f, is_multiline ? NULL : &clip_rect); + } + + // Draw blinking cursor + if (render_cursor) + { + state->CursorAnim += io.DeltaTime; + bool cursor_is_visible = (!g.IO.ConfigInputTextCursorBlink) || (state->CursorAnim <= 0.0f) || ImFmod(state->CursorAnim, 1.20f) <= 0.80f; + ImVec2 cursor_screen_pos = ImFloor(draw_pos + cursor_offset - draw_scroll); + ImRect cursor_screen_rect(cursor_screen_pos.x, cursor_screen_pos.y - g.FontSize + 0.5f, cursor_screen_pos.x + 1.0f, cursor_screen_pos.y - 1.5f); + if (cursor_is_visible && cursor_screen_rect.Overlaps(clip_rect)) + draw_window->DrawList->AddLine(cursor_screen_rect.Min, cursor_screen_rect.GetBL(), GetColorU32(ImGuiCol_Text)); + + // Notify OS of text input position for advanced IME (-1 x offset so that Windows IME can cover our cursor. Bit of an extra nicety.) + if (!is_readonly) + g.PlatformImePos = ImVec2(cursor_screen_pos.x - 1.0f, cursor_screen_pos.y - g.FontSize); + } + } + else + { + // Render text only (no selection, no cursor) + if (is_multiline) + text_size = ImVec2(inner_size.x, InputTextCalcTextLenAndLineCount(buf_display, &buf_display_end) * g.FontSize); // We don't need width + else if (!is_displaying_hint && g.ActiveId == id) + buf_display_end = buf_display + state->CurLenA; + else if (!is_displaying_hint) + buf_display_end = buf_display + strlen(buf_display); + + if (is_multiline || (buf_display_end - buf_display) < buf_display_max_length) + { + ImU32 col = GetColorU32(is_displaying_hint ? ImGuiCol_TextDisabled : ImGuiCol_Text); + draw_window->DrawList->AddText(g.Font, g.FontSize, draw_pos, col, buf_display, buf_display_end, 0.0f, is_multiline ? NULL : &clip_rect); + } + } + + if (is_password && !is_displaying_hint) + PopFont(); + + if (is_multiline) + { + Dummy(ImVec2(text_size.x, text_size.y + style.FramePadding.y)); + EndChild(); + EndGroup(); + } + + // Log as text + if (g.LogEnabled && (!is_password || is_displaying_hint)) + { + LogSetNextTextDecoration("{", "}"); + LogRenderedText(&draw_pos, buf_display, buf_display_end); + } + + if (label_size.x > 0) + RenderText(ImVec2(frame_bb.Max.x + style.ItemInnerSpacing.x, frame_bb.Min.y + style.FramePadding.y), label); + + if (value_changed && !(flags & ImGuiInputTextFlags_NoMarkEdited)) + MarkItemEdited(id); + + IMGUI_TEST_ENGINE_ITEM_INFO(id, label, g.LastItemData.StatusFlags); + if ((flags & ImGuiInputTextFlags_EnterReturnsTrue) != 0) + return enter_pressed; + else + return value_changed; +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: ColorEdit, ColorPicker, ColorButton, etc. +//------------------------------------------------------------------------- +// - ColorEdit3() +// - ColorEdit4() +// - ColorPicker3() +// - RenderColorRectWithAlphaCheckerboard() [Internal] +// - ColorPicker4() +// - ColorButton() +// - SetColorEditOptions() +// - ColorTooltip() [Internal] +// - ColorEditOptionsPopup() [Internal] +// - ColorPickerOptionsPopup() [Internal] +//------------------------------------------------------------------------- + +bool ImGui::ColorEdit3(const char* label, float col[3], ImGuiColorEditFlags flags) +{ + return ColorEdit4(label, col, flags | ImGuiColorEditFlags_NoAlpha); +} + +// Edit colors components (each component in 0.0f..1.0f range). +// See enum ImGuiColorEditFlags_ for available options. e.g. Only access 3 floats if ImGuiColorEditFlags_NoAlpha flag is set. +// With typical options: Left-click on color square to open color picker. Right-click to open option menu. CTRL-Click over input fields to edit them and TAB to go to next item. +bool ImGui::ColorEdit4(const char* label, float col[4], ImGuiColorEditFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + const float square_sz = GetFrameHeight(); + const float w_full = CalcItemWidth(); + const float w_button = (flags & ImGuiColorEditFlags_NoSmallPreview) ? 0.0f : (square_sz + style.ItemInnerSpacing.x); + const float w_inputs = w_full - w_button; + const char* label_display_end = FindRenderedTextEnd(label); + g.NextItemData.ClearFlags(); + + BeginGroup(); + PushID(label); + + // If we're not showing any slider there's no point in doing any HSV conversions + const ImGuiColorEditFlags flags_untouched = flags; + if (flags & ImGuiColorEditFlags_NoInputs) + flags = (flags & (~ImGuiColorEditFlags_DisplayMask_)) | ImGuiColorEditFlags_DisplayRGB | ImGuiColorEditFlags_NoOptions; + + // Context menu: display and modify options (before defaults are applied) + if (!(flags & ImGuiColorEditFlags_NoOptions)) + ColorEditOptionsPopup(col, flags); + + // Read stored options + if (!(flags & ImGuiColorEditFlags_DisplayMask_)) + flags |= (g.ColorEditOptions & ImGuiColorEditFlags_DisplayMask_); + if (!(flags & ImGuiColorEditFlags_DataTypeMask_)) + flags |= (g.ColorEditOptions & ImGuiColorEditFlags_DataTypeMask_); + if (!(flags & ImGuiColorEditFlags_PickerMask_)) + flags |= (g.ColorEditOptions & ImGuiColorEditFlags_PickerMask_); + if (!(flags & ImGuiColorEditFlags_InputMask_)) + flags |= (g.ColorEditOptions & ImGuiColorEditFlags_InputMask_); + flags |= (g.ColorEditOptions & ~(ImGuiColorEditFlags_DisplayMask_ | ImGuiColorEditFlags_DataTypeMask_ | ImGuiColorEditFlags_PickerMask_ | ImGuiColorEditFlags_InputMask_)); + IM_ASSERT(ImIsPowerOfTwo(flags & ImGuiColorEditFlags_DisplayMask_)); // Check that only 1 is selected + IM_ASSERT(ImIsPowerOfTwo(flags & ImGuiColorEditFlags_InputMask_)); // Check that only 1 is selected + + const bool alpha = (flags & ImGuiColorEditFlags_NoAlpha) == 0; + const bool hdr = (flags & ImGuiColorEditFlags_HDR) != 0; + const int components = alpha ? 4 : 3; + + // Convert to the formats we need + float f[4] = { col[0], col[1], col[2], alpha ? col[3] : 1.0f }; + if ((flags & ImGuiColorEditFlags_InputHSV) && (flags & ImGuiColorEditFlags_DisplayRGB)) + ColorConvertHSVtoRGB(f[0], f[1], f[2], f[0], f[1], f[2]); + else if ((flags & ImGuiColorEditFlags_InputRGB) && (flags & ImGuiColorEditFlags_DisplayHSV)) + { + // Hue is lost when converting from greyscale rgb (saturation=0). Restore it. + ColorConvertRGBtoHSV(f[0], f[1], f[2], f[0], f[1], f[2]); + if (memcmp(g.ColorEditLastColor, col, sizeof(float) * 3) == 0) + { + if (f[1] == 0) + f[0] = g.ColorEditLastHue; + if (f[2] == 0) + f[1] = g.ColorEditLastSat; + } + } + int i[4] = { IM_F32_TO_INT8_UNBOUND(f[0]), IM_F32_TO_INT8_UNBOUND(f[1]), IM_F32_TO_INT8_UNBOUND(f[2]), IM_F32_TO_INT8_UNBOUND(f[3]) }; + + bool value_changed = false; + bool value_changed_as_float = false; + + const ImVec2 pos = window->DC.CursorPos; + const float inputs_offset_x = (style.ColorButtonPosition == ImGuiDir_Left) ? w_button : 0.0f; + window->DC.CursorPos.x = pos.x + inputs_offset_x; + + if ((flags & (ImGuiColorEditFlags_DisplayRGB | ImGuiColorEditFlags_DisplayHSV)) != 0 && (flags & ImGuiColorEditFlags_NoInputs) == 0) + { + // RGB/HSV 0..255 Sliders + const float w_item_one = ImMax(1.0f, IM_FLOOR((w_inputs - (style.ItemInnerSpacing.x) * (components - 1)) / (float)components)); + const float w_item_last = ImMax(1.0f, IM_FLOOR(w_inputs - (w_item_one + style.ItemInnerSpacing.x) * (components - 1))); + + const bool hide_prefix = (w_item_one <= CalcTextSize((flags & ImGuiColorEditFlags_Float) ? "M:0.000" : "M:000").x); + static const char* ids[4] = { "##X", "##Y", "##Z", "##W" }; + static const char* fmt_table_int[3][4] = + { + { "%3d", "%3d", "%3d", "%3d" }, // Short display + { "R:%3d", "G:%3d", "B:%3d", "A:%3d" }, // Long display for RGBA + { "H:%3d", "S:%3d", "V:%3d", "A:%3d" } // Long display for HSVA + }; + static const char* fmt_table_float[3][4] = + { + { "%0.3f", "%0.3f", "%0.3f", "%0.3f" }, // Short display + { "R:%0.3f", "G:%0.3f", "B:%0.3f", "A:%0.3f" }, // Long display for RGBA + { "H:%0.3f", "S:%0.3f", "V:%0.3f", "A:%0.3f" } // Long display for HSVA + }; + const int fmt_idx = hide_prefix ? 0 : (flags & ImGuiColorEditFlags_DisplayHSV) ? 2 : 1; + + for (int n = 0; n < components; n++) + { + if (n > 0) + SameLine(0, style.ItemInnerSpacing.x); + SetNextItemWidth((n + 1 < components) ? w_item_one : w_item_last); + + // FIXME: When ImGuiColorEditFlags_HDR flag is passed HS values snap in weird ways when SV values go below 0. + if (flags & ImGuiColorEditFlags_Float) + { + value_changed |= DragFloat(ids[n], &f[n], 1.0f / 255.0f, 0.0f, hdr ? 0.0f : 1.0f, fmt_table_float[fmt_idx][n]); + value_changed_as_float |= value_changed; + } + else + { + value_changed |= DragInt(ids[n], &i[n], 1.0f, 0, hdr ? 0 : 255, fmt_table_int[fmt_idx][n]); + } + if (!(flags & ImGuiColorEditFlags_NoOptions)) + OpenPopupOnItemClick("context"); + } + } + else if ((flags & ImGuiColorEditFlags_DisplayHex) != 0 && (flags & ImGuiColorEditFlags_NoInputs) == 0) + { + // RGB Hexadecimal Input + char buf[64]; + if (alpha) + ImFormatString(buf, IM_ARRAYSIZE(buf), "#%02X%02X%02X%02X", ImClamp(i[0], 0, 255), ImClamp(i[1], 0, 255), ImClamp(i[2], 0, 255), ImClamp(i[3], 0, 255)); + else + ImFormatString(buf, IM_ARRAYSIZE(buf), "#%02X%02X%02X", ImClamp(i[0], 0, 255), ImClamp(i[1], 0, 255), ImClamp(i[2], 0, 255)); + SetNextItemWidth(w_inputs); + if (InputText("##Text", buf, IM_ARRAYSIZE(buf), ImGuiInputTextFlags_CharsHexadecimal | ImGuiInputTextFlags_CharsUppercase)) + { + value_changed = true; + char* p = buf; + while (*p == '#' || ImCharIsBlankA(*p)) + p++; + i[0] = i[1] = i[2] = 0; + i[3] = 0xFF; // alpha default to 255 is not parsed by scanf (e.g. inputting #FFFFFF omitting alpha) + int r; + if (alpha) + r = sscanf(p, "%02X%02X%02X%02X", (unsigned int*)&i[0], (unsigned int*)&i[1], (unsigned int*)&i[2], (unsigned int*)&i[3]); // Treat at unsigned (%X is unsigned) + else + r = sscanf(p, "%02X%02X%02X", (unsigned int*)&i[0], (unsigned int*)&i[1], (unsigned int*)&i[2]); + IM_UNUSED(r); // Fixes C6031: Return value ignored: 'sscanf'. + } + if (!(flags & ImGuiColorEditFlags_NoOptions)) + OpenPopupOnItemClick("context"); + } + + ImGuiWindow* picker_active_window = NULL; + if (!(flags & ImGuiColorEditFlags_NoSmallPreview)) + { + const float button_offset_x = ((flags & ImGuiColorEditFlags_NoInputs) || (style.ColorButtonPosition == ImGuiDir_Left)) ? 0.0f : w_inputs + style.ItemInnerSpacing.x; + window->DC.CursorPos = ImVec2(pos.x + button_offset_x, pos.y); + + const ImVec4 col_v4(col[0], col[1], col[2], alpha ? col[3] : 1.0f); + if (ColorButton("##ColorButton", col_v4, flags)) + { + if (!(flags & ImGuiColorEditFlags_NoPicker)) + { + // Store current color and open a picker + g.ColorPickerRef = col_v4; + OpenPopup("picker"); + SetNextWindowPos(g.LastItemData.Rect.GetBL() + ImVec2(-1, style.ItemSpacing.y)); + } + } + if (!(flags & ImGuiColorEditFlags_NoOptions)) + OpenPopupOnItemClick("context"); + + if (BeginPopup("picker")) + { + picker_active_window = g.CurrentWindow; + if (label != label_display_end) + { + TextEx(label, label_display_end); + Spacing(); + } + ImGuiColorEditFlags picker_flags_to_forward = ImGuiColorEditFlags_DataTypeMask_ | ImGuiColorEditFlags_PickerMask_ | ImGuiColorEditFlags_InputMask_ | ImGuiColorEditFlags_HDR | ImGuiColorEditFlags_NoAlpha | ImGuiColorEditFlags_AlphaBar; + ImGuiColorEditFlags picker_flags = (flags_untouched & picker_flags_to_forward) | ImGuiColorEditFlags_DisplayMask_ | ImGuiColorEditFlags_NoLabel | ImGuiColorEditFlags_AlphaPreviewHalf; + SetNextItemWidth(square_sz * 12.0f); // Use 256 + bar sizes? + value_changed |= ColorPicker4("##picker", col, picker_flags, &g.ColorPickerRef.x); + EndPopup(); + } + } + + if (label != label_display_end && !(flags & ImGuiColorEditFlags_NoLabel)) + { + const float text_offset_x = (flags & ImGuiColorEditFlags_NoInputs) ? w_button : w_full + style.ItemInnerSpacing.x; + window->DC.CursorPos = ImVec2(pos.x + text_offset_x, pos.y + style.FramePadding.y); + TextEx(label, label_display_end); + } + + // Convert back + if (value_changed && picker_active_window == NULL) + { + if (!value_changed_as_float) + for (int n = 0; n < 4; n++) + f[n] = i[n] / 255.0f; + if ((flags & ImGuiColorEditFlags_DisplayHSV) && (flags & ImGuiColorEditFlags_InputRGB)) + { + g.ColorEditLastHue = f[0]; + g.ColorEditLastSat = f[1]; + ColorConvertHSVtoRGB(f[0], f[1], f[2], f[0], f[1], f[2]); + memcpy(g.ColorEditLastColor, f, sizeof(float) * 3); + } + if ((flags & ImGuiColorEditFlags_DisplayRGB) && (flags & ImGuiColorEditFlags_InputHSV)) + ColorConvertRGBtoHSV(f[0], f[1], f[2], f[0], f[1], f[2]); + + col[0] = f[0]; + col[1] = f[1]; + col[2] = f[2]; + if (alpha) + col[3] = f[3]; + } + + PopID(); + EndGroup(); + + // Drag and Drop Target + // NB: The flag test is merely an optional micro-optimization, BeginDragDropTarget() does the same test. + if ((g.LastItemData.StatusFlags & ImGuiItemStatusFlags_HoveredRect) && !(flags & ImGuiColorEditFlags_NoDragDrop) && BeginDragDropTarget()) + { + bool accepted_drag_drop = false; + if (const ImGuiPayload* payload = AcceptDragDropPayload(IMGUI_PAYLOAD_TYPE_COLOR_3F)) + { + memcpy((float*)col, payload->Data, sizeof(float) * 3); // Preserve alpha if any //-V512 + value_changed = accepted_drag_drop = true; + } + if (const ImGuiPayload* payload = AcceptDragDropPayload(IMGUI_PAYLOAD_TYPE_COLOR_4F)) + { + memcpy((float*)col, payload->Data, sizeof(float) * components); + value_changed = accepted_drag_drop = true; + } + + // Drag-drop payloads are always RGB + if (accepted_drag_drop && (flags & ImGuiColorEditFlags_InputHSV)) + ColorConvertRGBtoHSV(col[0], col[1], col[2], col[0], col[1], col[2]); + EndDragDropTarget(); + } + + // When picker is being actively used, use its active id so IsItemActive() will function on ColorEdit4(). + if (picker_active_window && g.ActiveId != 0 && g.ActiveIdWindow == picker_active_window) + g.LastItemData.ID = g.ActiveId; + + if (value_changed) + MarkItemEdited(g.LastItemData.ID); + + return value_changed; +} + +bool ImGui::ColorPicker3(const char* label, float col[3], ImGuiColorEditFlags flags) +{ + float col4[4] = { col[0], col[1], col[2], 1.0f }; + if (!ColorPicker4(label, col4, flags | ImGuiColorEditFlags_NoAlpha)) + return false; + col[0] = col4[0]; col[1] = col4[1]; col[2] = col4[2]; + return true; +} + +// Helper for ColorPicker4() +static void RenderArrowsForVerticalBar(ImDrawList* draw_list, ImVec2 pos, ImVec2 half_sz, float bar_w, float alpha) +{ + ImU32 alpha8 = IM_F32_TO_INT8_SAT(alpha); + ImGui::RenderArrowPointingAt(draw_list, ImVec2(pos.x + half_sz.x + 1, pos.y), ImVec2(half_sz.x + 2, half_sz.y + 1), ImGuiDir_Right, IM_COL32(0,0,0,alpha8)); + ImGui::RenderArrowPointingAt(draw_list, ImVec2(pos.x + half_sz.x, pos.y), half_sz, ImGuiDir_Right, IM_COL32(255,255,255,alpha8)); + ImGui::RenderArrowPointingAt(draw_list, ImVec2(pos.x + bar_w - half_sz.x - 1, pos.y), ImVec2(half_sz.x + 2, half_sz.y + 1), ImGuiDir_Left, IM_COL32(0,0,0,alpha8)); + ImGui::RenderArrowPointingAt(draw_list, ImVec2(pos.x + bar_w - half_sz.x, pos.y), half_sz, ImGuiDir_Left, IM_COL32(255,255,255,alpha8)); +} + +// Note: ColorPicker4() only accesses 3 floats if ImGuiColorEditFlags_NoAlpha flag is set. +// (In C++ the 'float col[4]' notation for a function argument is equivalent to 'float* col', we only specify a size to facilitate understanding of the code.) +// FIXME: we adjust the big color square height based on item width, which may cause a flickering feedback loop (if automatic height makes a vertical scrollbar appears, affecting automatic width..) +// FIXME: this is trying to be aware of style.Alpha but not fully correct. Also, the color wheel will have overlapping glitches with (style.Alpha < 1.0) +bool ImGui::ColorPicker4(const char* label, float col[4], ImGuiColorEditFlags flags, const float* ref_col) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImDrawList* draw_list = window->DrawList; + ImGuiStyle& style = g.Style; + ImGuiIO& io = g.IO; + + const float width = CalcItemWidth(); + g.NextItemData.ClearFlags(); + + PushID(label); + BeginGroup(); + + if (!(flags & ImGuiColorEditFlags_NoSidePreview)) + flags |= ImGuiColorEditFlags_NoSmallPreview; + + // Context menu: display and store options. + if (!(flags & ImGuiColorEditFlags_NoOptions)) + ColorPickerOptionsPopup(col, flags); + + // Read stored options + if (!(flags & ImGuiColorEditFlags_PickerMask_)) + flags |= ((g.ColorEditOptions & ImGuiColorEditFlags_PickerMask_) ? g.ColorEditOptions : ImGuiColorEditFlags_DefaultOptions_) & ImGuiColorEditFlags_PickerMask_; + if (!(flags & ImGuiColorEditFlags_InputMask_)) + flags |= ((g.ColorEditOptions & ImGuiColorEditFlags_InputMask_) ? g.ColorEditOptions : ImGuiColorEditFlags_DefaultOptions_) & ImGuiColorEditFlags_InputMask_; + IM_ASSERT(ImIsPowerOfTwo(flags & ImGuiColorEditFlags_PickerMask_)); // Check that only 1 is selected + IM_ASSERT(ImIsPowerOfTwo(flags & ImGuiColorEditFlags_InputMask_)); // Check that only 1 is selected + if (!(flags & ImGuiColorEditFlags_NoOptions)) + flags |= (g.ColorEditOptions & ImGuiColorEditFlags_AlphaBar); + + // Setup + int components = (flags & ImGuiColorEditFlags_NoAlpha) ? 3 : 4; + bool alpha_bar = (flags & ImGuiColorEditFlags_AlphaBar) && !(flags & ImGuiColorEditFlags_NoAlpha); + ImVec2 picker_pos = window->DC.CursorPos; + float square_sz = GetFrameHeight(); + float bars_width = square_sz; // Arbitrary smallish width of Hue/Alpha picking bars + float sv_picker_size = ImMax(bars_width * 1, width - (alpha_bar ? 2 : 1) * (bars_width + style.ItemInnerSpacing.x)); // Saturation/Value picking box + float bar0_pos_x = picker_pos.x + sv_picker_size + style.ItemInnerSpacing.x; + float bar1_pos_x = bar0_pos_x + bars_width + style.ItemInnerSpacing.x; + float bars_triangles_half_sz = IM_FLOOR(bars_width * 0.20f); + + float backup_initial_col[4]; + memcpy(backup_initial_col, col, components * sizeof(float)); + + float wheel_thickness = sv_picker_size * 0.08f; + float wheel_r_outer = sv_picker_size * 0.50f; + float wheel_r_inner = wheel_r_outer - wheel_thickness; + ImVec2 wheel_center(picker_pos.x + (sv_picker_size + bars_width)*0.5f, picker_pos.y + sv_picker_size * 0.5f); + + // Note: the triangle is displayed rotated with triangle_pa pointing to Hue, but most coordinates stays unrotated for logic. + float triangle_r = wheel_r_inner - (int)(sv_picker_size * 0.027f); + ImVec2 triangle_pa = ImVec2(triangle_r, 0.0f); // Hue point. + ImVec2 triangle_pb = ImVec2(triangle_r * -0.5f, triangle_r * -0.866025f); // Black point. + ImVec2 triangle_pc = ImVec2(triangle_r * -0.5f, triangle_r * +0.866025f); // White point. + + float H = col[0], S = col[1], V = col[2]; + float R = col[0], G = col[1], B = col[2]; + if (flags & ImGuiColorEditFlags_InputRGB) + { + // Hue is lost when converting from greyscale rgb (saturation=0). Restore it. + ColorConvertRGBtoHSV(R, G, B, H, S, V); + if (memcmp(g.ColorEditLastColor, col, sizeof(float) * 3) == 0) + { + if (S == 0) + H = g.ColorEditLastHue; + if (V == 0) + S = g.ColorEditLastSat; + } + } + else if (flags & ImGuiColorEditFlags_InputHSV) + { + ColorConvertHSVtoRGB(H, S, V, R, G, B); + } + + bool value_changed = false, value_changed_h = false, value_changed_sv = false; + + PushItemFlag(ImGuiItemFlags_NoNav, true); + if (flags & ImGuiColorEditFlags_PickerHueWheel) + { + // Hue wheel + SV triangle logic + InvisibleButton("hsv", ImVec2(sv_picker_size + style.ItemInnerSpacing.x + bars_width, sv_picker_size)); + if (IsItemActive()) + { + ImVec2 initial_off = g.IO.MouseClickedPos[0] - wheel_center; + ImVec2 current_off = g.IO.MousePos - wheel_center; + float initial_dist2 = ImLengthSqr(initial_off); + if (initial_dist2 >= (wheel_r_inner - 1) * (wheel_r_inner - 1) && initial_dist2 <= (wheel_r_outer + 1) * (wheel_r_outer + 1)) + { + // Interactive with Hue wheel + H = ImAtan2(current_off.y, current_off.x) / IM_PI * 0.5f; + if (H < 0.0f) + H += 1.0f; + value_changed = value_changed_h = true; + } + float cos_hue_angle = ImCos(-H * 2.0f * IM_PI); + float sin_hue_angle = ImSin(-H * 2.0f * IM_PI); + if (ImTriangleContainsPoint(triangle_pa, triangle_pb, triangle_pc, ImRotate(initial_off, cos_hue_angle, sin_hue_angle))) + { + // Interacting with SV triangle + ImVec2 current_off_unrotated = ImRotate(current_off, cos_hue_angle, sin_hue_angle); + if (!ImTriangleContainsPoint(triangle_pa, triangle_pb, triangle_pc, current_off_unrotated)) + current_off_unrotated = ImTriangleClosestPoint(triangle_pa, triangle_pb, triangle_pc, current_off_unrotated); + float uu, vv, ww; + ImTriangleBarycentricCoords(triangle_pa, triangle_pb, triangle_pc, current_off_unrotated, uu, vv, ww); + V = ImClamp(1.0f - vv, 0.0001f, 1.0f); + S = ImClamp(uu / V, 0.0001f, 1.0f); + value_changed = value_changed_sv = true; + } + } + if (!(flags & ImGuiColorEditFlags_NoOptions)) + OpenPopupOnItemClick("context"); + } + else if (flags & ImGuiColorEditFlags_PickerHueBar) + { + // SV rectangle logic + InvisibleButton("sv", ImVec2(sv_picker_size, sv_picker_size)); + if (IsItemActive()) + { + S = ImSaturate((io.MousePos.x - picker_pos.x) / (sv_picker_size - 1)); + V = 1.0f - ImSaturate((io.MousePos.y - picker_pos.y) / (sv_picker_size - 1)); + value_changed = value_changed_sv = true; + } + if (!(flags & ImGuiColorEditFlags_NoOptions)) + OpenPopupOnItemClick("context"); + + // Hue bar logic + SetCursorScreenPos(ImVec2(bar0_pos_x, picker_pos.y)); + InvisibleButton("hue", ImVec2(bars_width, sv_picker_size)); + if (IsItemActive()) + { + H = ImSaturate((io.MousePos.y - picker_pos.y) / (sv_picker_size - 1)); + value_changed = value_changed_h = true; + } + } + + // Alpha bar logic + if (alpha_bar) + { + SetCursorScreenPos(ImVec2(bar1_pos_x, picker_pos.y)); + InvisibleButton("alpha", ImVec2(bars_width, sv_picker_size)); + if (IsItemActive()) + { + col[3] = 1.0f - ImSaturate((io.MousePos.y - picker_pos.y) / (sv_picker_size - 1)); + value_changed = true; + } + } + PopItemFlag(); // ImGuiItemFlags_NoNav + + if (!(flags & ImGuiColorEditFlags_NoSidePreview)) + { + SameLine(0, style.ItemInnerSpacing.x); + BeginGroup(); + } + + if (!(flags & ImGuiColorEditFlags_NoLabel)) + { + const char* label_display_end = FindRenderedTextEnd(label); + if (label != label_display_end) + { + if ((flags & ImGuiColorEditFlags_NoSidePreview)) + SameLine(0, style.ItemInnerSpacing.x); + TextEx(label, label_display_end); + } + } + + if (!(flags & ImGuiColorEditFlags_NoSidePreview)) + { + PushItemFlag(ImGuiItemFlags_NoNavDefaultFocus, true); + ImVec4 col_v4(col[0], col[1], col[2], (flags & ImGuiColorEditFlags_NoAlpha) ? 1.0f : col[3]); + if ((flags & ImGuiColorEditFlags_NoLabel)) + Text("Current"); + + ImGuiColorEditFlags sub_flags_to_forward = ImGuiColorEditFlags_InputMask_ | ImGuiColorEditFlags_HDR | ImGuiColorEditFlags_AlphaPreview | ImGuiColorEditFlags_AlphaPreviewHalf | ImGuiColorEditFlags_NoTooltip; + ColorButton("##current", col_v4, (flags & sub_flags_to_forward), ImVec2(square_sz * 3, square_sz * 2)); + if (ref_col != NULL) + { + Text("Original"); + ImVec4 ref_col_v4(ref_col[0], ref_col[1], ref_col[2], (flags & ImGuiColorEditFlags_NoAlpha) ? 1.0f : ref_col[3]); + if (ColorButton("##original", ref_col_v4, (flags & sub_flags_to_forward), ImVec2(square_sz * 3, square_sz * 2))) + { + memcpy(col, ref_col, components * sizeof(float)); + value_changed = true; + } + } + PopItemFlag(); + EndGroup(); + } + + // Convert back color to RGB + if (value_changed_h || value_changed_sv) + { + if (flags & ImGuiColorEditFlags_InputRGB) + { + ColorConvertHSVtoRGB(H >= 1.0f ? H - 10 * 1e-6f : H, S > 0.0f ? S : 10 * 1e-6f, V > 0.0f ? V : 1e-6f, col[0], col[1], col[2]); + g.ColorEditLastHue = H; + g.ColorEditLastSat = S; + memcpy(g.ColorEditLastColor, col, sizeof(float) * 3); + } + else if (flags & ImGuiColorEditFlags_InputHSV) + { + col[0] = H; + col[1] = S; + col[2] = V; + } + } + + // R,G,B and H,S,V slider color editor + bool value_changed_fix_hue_wrap = false; + if ((flags & ImGuiColorEditFlags_NoInputs) == 0) + { + PushItemWidth((alpha_bar ? bar1_pos_x : bar0_pos_x) + bars_width - picker_pos.x); + ImGuiColorEditFlags sub_flags_to_forward = ImGuiColorEditFlags_DataTypeMask_ | ImGuiColorEditFlags_InputMask_ | ImGuiColorEditFlags_HDR | ImGuiColorEditFlags_NoAlpha | ImGuiColorEditFlags_NoOptions | ImGuiColorEditFlags_NoSmallPreview | ImGuiColorEditFlags_AlphaPreview | ImGuiColorEditFlags_AlphaPreviewHalf; + ImGuiColorEditFlags sub_flags = (flags & sub_flags_to_forward) | ImGuiColorEditFlags_NoPicker; + if (flags & ImGuiColorEditFlags_DisplayRGB || (flags & ImGuiColorEditFlags_DisplayMask_) == 0) + if (ColorEdit4("##rgb", col, sub_flags | ImGuiColorEditFlags_DisplayRGB)) + { + // FIXME: Hackily differentiating using the DragInt (ActiveId != 0 && !ActiveIdAllowOverlap) vs. using the InputText or DropTarget. + // For the later we don't want to run the hue-wrap canceling code. If you are well versed in HSV picker please provide your input! (See #2050) + value_changed_fix_hue_wrap = (g.ActiveId != 0 && !g.ActiveIdAllowOverlap); + value_changed = true; + } + if (flags & ImGuiColorEditFlags_DisplayHSV || (flags & ImGuiColorEditFlags_DisplayMask_) == 0) + value_changed |= ColorEdit4("##hsv", col, sub_flags | ImGuiColorEditFlags_DisplayHSV); + if (flags & ImGuiColorEditFlags_DisplayHex || (flags & ImGuiColorEditFlags_DisplayMask_) == 0) + value_changed |= ColorEdit4("##hex", col, sub_flags | ImGuiColorEditFlags_DisplayHex); + PopItemWidth(); + } + + // Try to cancel hue wrap (after ColorEdit4 call), if any + if (value_changed_fix_hue_wrap && (flags & ImGuiColorEditFlags_InputRGB)) + { + float new_H, new_S, new_V; + ColorConvertRGBtoHSV(col[0], col[1], col[2], new_H, new_S, new_V); + if (new_H <= 0 && H > 0) + { + if (new_V <= 0 && V != new_V) + ColorConvertHSVtoRGB(H, S, new_V <= 0 ? V * 0.5f : new_V, col[0], col[1], col[2]); + else if (new_S <= 0) + ColorConvertHSVtoRGB(H, new_S <= 0 ? S * 0.5f : new_S, new_V, col[0], col[1], col[2]); + } + } + + if (value_changed) + { + if (flags & ImGuiColorEditFlags_InputRGB) + { + R = col[0]; + G = col[1]; + B = col[2]; + ColorConvertRGBtoHSV(R, G, B, H, S, V); + if (memcmp(g.ColorEditLastColor, col, sizeof(float) * 3) == 0) // Fix local Hue as display below will use it immediately. + { + if (S == 0) + H = g.ColorEditLastHue; + if (V == 0) + S = g.ColorEditLastSat; + } + } + else if (flags & ImGuiColorEditFlags_InputHSV) + { + H = col[0]; + S = col[1]; + V = col[2]; + ColorConvertHSVtoRGB(H, S, V, R, G, B); + } + } + + const int style_alpha8 = IM_F32_TO_INT8_SAT(style.Alpha); + const ImU32 col_black = IM_COL32(0,0,0,style_alpha8); + const ImU32 col_white = IM_COL32(255,255,255,style_alpha8); + const ImU32 col_midgrey = IM_COL32(128,128,128,style_alpha8); + const ImU32 col_hues[6 + 1] = { IM_COL32(255,0,0,style_alpha8), IM_COL32(255,255,0,style_alpha8), IM_COL32(0,255,0,style_alpha8), IM_COL32(0,255,255,style_alpha8), IM_COL32(0,0,255,style_alpha8), IM_COL32(255,0,255,style_alpha8), IM_COL32(255,0,0,style_alpha8) }; + + ImVec4 hue_color_f(1, 1, 1, style.Alpha); ColorConvertHSVtoRGB(H, 1, 1, hue_color_f.x, hue_color_f.y, hue_color_f.z); + ImU32 hue_color32 = ColorConvertFloat4ToU32(hue_color_f); + ImU32 user_col32_striped_of_alpha = ColorConvertFloat4ToU32(ImVec4(R, G, B, style.Alpha)); // Important: this is still including the main rendering/style alpha!! + + ImVec2 sv_cursor_pos; + + if (flags & ImGuiColorEditFlags_PickerHueWheel) + { + // Render Hue Wheel + const float aeps = 0.5f / wheel_r_outer; // Half a pixel arc length in radians (2pi cancels out). + const int segment_per_arc = ImMax(4, (int)wheel_r_outer / 12); + for (int n = 0; n < 6; n++) + { + const float a0 = (n) /6.0f * 2.0f * IM_PI - aeps; + const float a1 = (n+1.0f)/6.0f * 2.0f * IM_PI + aeps; + const int vert_start_idx = draw_list->VtxBuffer.Size; + draw_list->PathArcTo(wheel_center, (wheel_r_inner + wheel_r_outer)*0.5f, a0, a1, segment_per_arc); + draw_list->PathStroke(col_white, 0, wheel_thickness); + const int vert_end_idx = draw_list->VtxBuffer.Size; + + // Paint colors over existing vertices + ImVec2 gradient_p0(wheel_center.x + ImCos(a0) * wheel_r_inner, wheel_center.y + ImSin(a0) * wheel_r_inner); + ImVec2 gradient_p1(wheel_center.x + ImCos(a1) * wheel_r_inner, wheel_center.y + ImSin(a1) * wheel_r_inner); + ShadeVertsLinearColorGradientKeepAlpha(draw_list, vert_start_idx, vert_end_idx, gradient_p0, gradient_p1, col_hues[n], col_hues[n + 1]); + } + + // Render Cursor + preview on Hue Wheel + float cos_hue_angle = ImCos(H * 2.0f * IM_PI); + float sin_hue_angle = ImSin(H * 2.0f * IM_PI); + ImVec2 hue_cursor_pos(wheel_center.x + cos_hue_angle * (wheel_r_inner + wheel_r_outer) * 0.5f, wheel_center.y + sin_hue_angle * (wheel_r_inner + wheel_r_outer) * 0.5f); + float hue_cursor_rad = value_changed_h ? wheel_thickness * 0.65f : wheel_thickness * 0.55f; + int hue_cursor_segments = ImClamp((int)(hue_cursor_rad / 1.4f), 9, 32); + draw_list->AddCircleFilled(hue_cursor_pos, hue_cursor_rad, hue_color32, hue_cursor_segments); + draw_list->AddCircle(hue_cursor_pos, hue_cursor_rad + 1, col_midgrey, hue_cursor_segments); + draw_list->AddCircle(hue_cursor_pos, hue_cursor_rad, col_white, hue_cursor_segments); + + // Render SV triangle (rotated according to hue) + ImVec2 tra = wheel_center + ImRotate(triangle_pa, cos_hue_angle, sin_hue_angle); + ImVec2 trb = wheel_center + ImRotate(triangle_pb, cos_hue_angle, sin_hue_angle); + ImVec2 trc = wheel_center + ImRotate(triangle_pc, cos_hue_angle, sin_hue_angle); + ImVec2 uv_white = GetFontTexUvWhitePixel(); + draw_list->PrimReserve(6, 6); + draw_list->PrimVtx(tra, uv_white, hue_color32); + draw_list->PrimVtx(trb, uv_white, hue_color32); + draw_list->PrimVtx(trc, uv_white, col_white); + draw_list->PrimVtx(tra, uv_white, 0); + draw_list->PrimVtx(trb, uv_white, col_black); + draw_list->PrimVtx(trc, uv_white, 0); + draw_list->AddTriangle(tra, trb, trc, col_midgrey, 1.5f); + sv_cursor_pos = ImLerp(ImLerp(trc, tra, ImSaturate(S)), trb, ImSaturate(1 - V)); + } + else if (flags & ImGuiColorEditFlags_PickerHueBar) + { + // Render SV Square + draw_list->AddRectFilledMultiColor(picker_pos, picker_pos + ImVec2(sv_picker_size, sv_picker_size), col_white, hue_color32, hue_color32, col_white); + draw_list->AddRectFilledMultiColor(picker_pos, picker_pos + ImVec2(sv_picker_size, sv_picker_size), 0, 0, col_black, col_black); + RenderFrameBorder(picker_pos, picker_pos + ImVec2(sv_picker_size, sv_picker_size), 0.0f); + sv_cursor_pos.x = ImClamp(IM_ROUND(picker_pos.x + ImSaturate(S) * sv_picker_size), picker_pos.x + 2, picker_pos.x + sv_picker_size - 2); // Sneakily prevent the circle to stick out too much + sv_cursor_pos.y = ImClamp(IM_ROUND(picker_pos.y + ImSaturate(1 - V) * sv_picker_size), picker_pos.y + 2, picker_pos.y + sv_picker_size - 2); + + // Render Hue Bar + for (int i = 0; i < 6; ++i) + draw_list->AddRectFilledMultiColor(ImVec2(bar0_pos_x, picker_pos.y + i * (sv_picker_size / 6)), ImVec2(bar0_pos_x + bars_width, picker_pos.y + (i + 1) * (sv_picker_size / 6)), col_hues[i], col_hues[i], col_hues[i + 1], col_hues[i + 1]); + float bar0_line_y = IM_ROUND(picker_pos.y + H * sv_picker_size); + RenderFrameBorder(ImVec2(bar0_pos_x, picker_pos.y), ImVec2(bar0_pos_x + bars_width, picker_pos.y + sv_picker_size), 0.0f); + RenderArrowsForVerticalBar(draw_list, ImVec2(bar0_pos_x - 1, bar0_line_y), ImVec2(bars_triangles_half_sz + 1, bars_triangles_half_sz), bars_width + 2.0f, style.Alpha); + } + + // Render cursor/preview circle (clamp S/V within 0..1 range because floating points colors may lead HSV values to be out of range) + float sv_cursor_rad = value_changed_sv ? 10.0f : 6.0f; + draw_list->AddCircleFilled(sv_cursor_pos, sv_cursor_rad, user_col32_striped_of_alpha, 12); + draw_list->AddCircle(sv_cursor_pos, sv_cursor_rad + 1, col_midgrey, 12); + draw_list->AddCircle(sv_cursor_pos, sv_cursor_rad, col_white, 12); + + // Render alpha bar + if (alpha_bar) + { + float alpha = ImSaturate(col[3]); + ImRect bar1_bb(bar1_pos_x, picker_pos.y, bar1_pos_x + bars_width, picker_pos.y + sv_picker_size); + RenderColorRectWithAlphaCheckerboard(draw_list, bar1_bb.Min, bar1_bb.Max, 0, bar1_bb.GetWidth() / 2.0f, ImVec2(0.0f, 0.0f)); + draw_list->AddRectFilledMultiColor(bar1_bb.Min, bar1_bb.Max, user_col32_striped_of_alpha, user_col32_striped_of_alpha, user_col32_striped_of_alpha & ~IM_COL32_A_MASK, user_col32_striped_of_alpha & ~IM_COL32_A_MASK); + float bar1_line_y = IM_ROUND(picker_pos.y + (1.0f - alpha) * sv_picker_size); + RenderFrameBorder(bar1_bb.Min, bar1_bb.Max, 0.0f); + RenderArrowsForVerticalBar(draw_list, ImVec2(bar1_pos_x - 1, bar1_line_y), ImVec2(bars_triangles_half_sz + 1, bars_triangles_half_sz), bars_width + 2.0f, style.Alpha); + } + + EndGroup(); + + if (value_changed && memcmp(backup_initial_col, col, components * sizeof(float)) == 0) + value_changed = false; + if (value_changed) + MarkItemEdited(g.LastItemData.ID); + + PopID(); + + return value_changed; +} + +// A little color square. Return true when clicked. +// FIXME: May want to display/ignore the alpha component in the color display? Yet show it in the tooltip. +// 'desc_id' is not called 'label' because we don't display it next to the button, but only in the tooltip. +// Note that 'col' may be encoded in HSV if ImGuiColorEditFlags_InputHSV is set. +bool ImGui::ColorButton(const char* desc_id, const ImVec4& col, ImGuiColorEditFlags flags, ImVec2 size) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const ImGuiID id = window->GetID(desc_id); + float default_size = GetFrameHeight(); + if (size.x == 0.0f) + size.x = default_size; + if (size.y == 0.0f) + size.y = default_size; + const ImRect bb(window->DC.CursorPos, window->DC.CursorPos + size); + ItemSize(bb, (size.y >= default_size) ? g.Style.FramePadding.y : 0.0f); + if (!ItemAdd(bb, id)) + return false; + + bool hovered, held; + bool pressed = ButtonBehavior(bb, id, &hovered, &held); + + if (flags & ImGuiColorEditFlags_NoAlpha) + flags &= ~(ImGuiColorEditFlags_AlphaPreview | ImGuiColorEditFlags_AlphaPreviewHalf); + + ImVec4 col_rgb = col; + if (flags & ImGuiColorEditFlags_InputHSV) + ColorConvertHSVtoRGB(col_rgb.x, col_rgb.y, col_rgb.z, col_rgb.x, col_rgb.y, col_rgb.z); + + ImVec4 col_rgb_without_alpha(col_rgb.x, col_rgb.y, col_rgb.z, 1.0f); + float grid_step = ImMin(size.x, size.y) / 2.99f; + float rounding = ImMin(g.Style.FrameRounding, grid_step * 0.5f); + ImRect bb_inner = bb; + float off = 0.0f; + if ((flags & ImGuiColorEditFlags_NoBorder) == 0) + { + off = -0.75f; // The border (using Col_FrameBg) tends to look off when color is near-opaque and rounding is enabled. This offset seemed like a good middle ground to reduce those artifacts. + bb_inner.Expand(off); + } + if ((flags & ImGuiColorEditFlags_AlphaPreviewHalf) && col_rgb.w < 1.0f) + { + float mid_x = IM_ROUND((bb_inner.Min.x + bb_inner.Max.x) * 0.5f); + RenderColorRectWithAlphaCheckerboard(window->DrawList, ImVec2(bb_inner.Min.x + grid_step, bb_inner.Min.y), bb_inner.Max, GetColorU32(col_rgb), grid_step, ImVec2(-grid_step + off, off), rounding, ImDrawFlags_RoundCornersRight); + window->DrawList->AddRectFilled(bb_inner.Min, ImVec2(mid_x, bb_inner.Max.y), GetColorU32(col_rgb_without_alpha), rounding, ImDrawFlags_RoundCornersLeft); + } + else + { + // Because GetColorU32() multiplies by the global style Alpha and we don't want to display a checkerboard if the source code had no alpha + ImVec4 col_source = (flags & ImGuiColorEditFlags_AlphaPreview) ? col_rgb : col_rgb_without_alpha; + if (col_source.w < 1.0f) + RenderColorRectWithAlphaCheckerboard(window->DrawList, bb_inner.Min, bb_inner.Max, GetColorU32(col_source), grid_step, ImVec2(off, off), rounding); + else + window->DrawList->AddRectFilled(bb_inner.Min, bb_inner.Max, GetColorU32(col_source), rounding); + } + RenderNavHighlight(bb, id); + if ((flags & ImGuiColorEditFlags_NoBorder) == 0) + { + if (g.Style.FrameBorderSize > 0.0f) + RenderFrameBorder(bb.Min, bb.Max, rounding); + else + window->DrawList->AddRect(bb.Min, bb.Max, GetColorU32(ImGuiCol_FrameBg), rounding); // Color button are often in need of some sort of border + } + + // Drag and Drop Source + // NB: The ActiveId test is merely an optional micro-optimization, BeginDragDropSource() does the same test. + if (g.ActiveId == id && !(flags & ImGuiColorEditFlags_NoDragDrop) && BeginDragDropSource()) + { + if (flags & ImGuiColorEditFlags_NoAlpha) + SetDragDropPayload(IMGUI_PAYLOAD_TYPE_COLOR_3F, &col_rgb, sizeof(float) * 3, ImGuiCond_Once); + else + SetDragDropPayload(IMGUI_PAYLOAD_TYPE_COLOR_4F, &col_rgb, sizeof(float) * 4, ImGuiCond_Once); + ColorButton(desc_id, col, flags); + SameLine(); + TextEx("Color"); + EndDragDropSource(); + } + + // Tooltip + if (!(flags & ImGuiColorEditFlags_NoTooltip) && hovered) + ColorTooltip(desc_id, &col.x, flags & (ImGuiColorEditFlags_InputMask_ | ImGuiColorEditFlags_NoAlpha | ImGuiColorEditFlags_AlphaPreview | ImGuiColorEditFlags_AlphaPreviewHalf)); + + return pressed; +} + +// Initialize/override default color options +void ImGui::SetColorEditOptions(ImGuiColorEditFlags flags) +{ + ImGuiContext& g = *GImGui; + if ((flags & ImGuiColorEditFlags_DisplayMask_) == 0) + flags |= ImGuiColorEditFlags_DefaultOptions_ & ImGuiColorEditFlags_DisplayMask_; + if ((flags & ImGuiColorEditFlags_DataTypeMask_) == 0) + flags |= ImGuiColorEditFlags_DefaultOptions_ & ImGuiColorEditFlags_DataTypeMask_; + if ((flags & ImGuiColorEditFlags_PickerMask_) == 0) + flags |= ImGuiColorEditFlags_DefaultOptions_ & ImGuiColorEditFlags_PickerMask_; + if ((flags & ImGuiColorEditFlags_InputMask_) == 0) + flags |= ImGuiColorEditFlags_DefaultOptions_ & ImGuiColorEditFlags_InputMask_; + IM_ASSERT(ImIsPowerOfTwo(flags & ImGuiColorEditFlags_DisplayMask_)); // Check only 1 option is selected + IM_ASSERT(ImIsPowerOfTwo(flags & ImGuiColorEditFlags_DataTypeMask_)); // Check only 1 option is selected + IM_ASSERT(ImIsPowerOfTwo(flags & ImGuiColorEditFlags_PickerMask_)); // Check only 1 option is selected + IM_ASSERT(ImIsPowerOfTwo(flags & ImGuiColorEditFlags_InputMask_)); // Check only 1 option is selected + g.ColorEditOptions = flags; +} + +// Note: only access 3 floats if ImGuiColorEditFlags_NoAlpha flag is set. +void ImGui::ColorTooltip(const char* text, const float* col, ImGuiColorEditFlags flags) +{ + ImGuiContext& g = *GImGui; + + BeginTooltipEx(0, ImGuiTooltipFlags_OverridePreviousTooltip); + const char* text_end = text ? FindRenderedTextEnd(text, NULL) : text; + if (text_end > text) + { + TextEx(text, text_end); + Separator(); + } + + ImVec2 sz(g.FontSize * 3 + g.Style.FramePadding.y * 2, g.FontSize * 3 + g.Style.FramePadding.y * 2); + ImVec4 cf(col[0], col[1], col[2], (flags & ImGuiColorEditFlags_NoAlpha) ? 1.0f : col[3]); + int cr = IM_F32_TO_INT8_SAT(col[0]), cg = IM_F32_TO_INT8_SAT(col[1]), cb = IM_F32_TO_INT8_SAT(col[2]), ca = (flags & ImGuiColorEditFlags_NoAlpha) ? 255 : IM_F32_TO_INT8_SAT(col[3]); + ColorButton("##preview", cf, (flags & (ImGuiColorEditFlags_InputMask_ | ImGuiColorEditFlags_NoAlpha | ImGuiColorEditFlags_AlphaPreview | ImGuiColorEditFlags_AlphaPreviewHalf)) | ImGuiColorEditFlags_NoTooltip, sz); + SameLine(); + if ((flags & ImGuiColorEditFlags_InputRGB) || !(flags & ImGuiColorEditFlags_InputMask_)) + { + if (flags & ImGuiColorEditFlags_NoAlpha) + Text("#%02X%02X%02X\nR: %d, G: %d, B: %d\n(%.3f, %.3f, %.3f)", cr, cg, cb, cr, cg, cb, col[0], col[1], col[2]); + else + Text("#%02X%02X%02X%02X\nR:%d, G:%d, B:%d, A:%d\n(%.3f, %.3f, %.3f, %.3f)", cr, cg, cb, ca, cr, cg, cb, ca, col[0], col[1], col[2], col[3]); + } + else if (flags & ImGuiColorEditFlags_InputHSV) + { + if (flags & ImGuiColorEditFlags_NoAlpha) + Text("H: %.3f, S: %.3f, V: %.3f", col[0], col[1], col[2]); + else + Text("H: %.3f, S: %.3f, V: %.3f, A: %.3f", col[0], col[1], col[2], col[3]); + } + EndTooltip(); +} + +void ImGui::ColorEditOptionsPopup(const float* col, ImGuiColorEditFlags flags) +{ + bool allow_opt_inputs = !(flags & ImGuiColorEditFlags_DisplayMask_); + bool allow_opt_datatype = !(flags & ImGuiColorEditFlags_DataTypeMask_); + if ((!allow_opt_inputs && !allow_opt_datatype) || !BeginPopup("context")) + return; + ImGuiContext& g = *GImGui; + ImGuiColorEditFlags opts = g.ColorEditOptions; + if (allow_opt_inputs) + { + if (RadioButton("RGB", (opts & ImGuiColorEditFlags_DisplayRGB) != 0)) opts = (opts & ~ImGuiColorEditFlags_DisplayMask_) | ImGuiColorEditFlags_DisplayRGB; + if (RadioButton("HSV", (opts & ImGuiColorEditFlags_DisplayHSV) != 0)) opts = (opts & ~ImGuiColorEditFlags_DisplayMask_) | ImGuiColorEditFlags_DisplayHSV; + if (RadioButton("Hex", (opts & ImGuiColorEditFlags_DisplayHex) != 0)) opts = (opts & ~ImGuiColorEditFlags_DisplayMask_) | ImGuiColorEditFlags_DisplayHex; + } + if (allow_opt_datatype) + { + if (allow_opt_inputs) Separator(); + if (RadioButton("0..255", (opts & ImGuiColorEditFlags_Uint8) != 0)) opts = (opts & ~ImGuiColorEditFlags_DataTypeMask_) | ImGuiColorEditFlags_Uint8; + if (RadioButton("0.00..1.00", (opts & ImGuiColorEditFlags_Float) != 0)) opts = (opts & ~ImGuiColorEditFlags_DataTypeMask_) | ImGuiColorEditFlags_Float; + } + + if (allow_opt_inputs || allow_opt_datatype) + Separator(); + if (Button("Copy as..", ImVec2(-1, 0))) + OpenPopup("Copy"); + if (BeginPopup("Copy")) + { + int cr = IM_F32_TO_INT8_SAT(col[0]), cg = IM_F32_TO_INT8_SAT(col[1]), cb = IM_F32_TO_INT8_SAT(col[2]), ca = (flags & ImGuiColorEditFlags_NoAlpha) ? 255 : IM_F32_TO_INT8_SAT(col[3]); + char buf[64]; + ImFormatString(buf, IM_ARRAYSIZE(buf), "(%.3ff, %.3ff, %.3ff, %.3ff)", col[0], col[1], col[2], (flags & ImGuiColorEditFlags_NoAlpha) ? 1.0f : col[3]); + if (Selectable(buf)) + SetClipboardText(buf); + ImFormatString(buf, IM_ARRAYSIZE(buf), "(%d,%d,%d,%d)", cr, cg, cb, ca); + if (Selectable(buf)) + SetClipboardText(buf); + ImFormatString(buf, IM_ARRAYSIZE(buf), "#%02X%02X%02X", cr, cg, cb); + if (Selectable(buf)) + SetClipboardText(buf); + if (!(flags & ImGuiColorEditFlags_NoAlpha)) + { + ImFormatString(buf, IM_ARRAYSIZE(buf), "#%02X%02X%02X%02X", cr, cg, cb, ca); + if (Selectable(buf)) + SetClipboardText(buf); + } + EndPopup(); + } + + g.ColorEditOptions = opts; + EndPopup(); +} + +void ImGui::ColorPickerOptionsPopup(const float* ref_col, ImGuiColorEditFlags flags) +{ + bool allow_opt_picker = !(flags & ImGuiColorEditFlags_PickerMask_); + bool allow_opt_alpha_bar = !(flags & ImGuiColorEditFlags_NoAlpha) && !(flags & ImGuiColorEditFlags_AlphaBar); + if ((!allow_opt_picker && !allow_opt_alpha_bar) || !BeginPopup("context")) + return; + ImGuiContext& g = *GImGui; + if (allow_opt_picker) + { + ImVec2 picker_size(g.FontSize * 8, ImMax(g.FontSize * 8 - (GetFrameHeight() + g.Style.ItemInnerSpacing.x), 1.0f)); // FIXME: Picker size copied from main picker function + PushItemWidth(picker_size.x); + for (int picker_type = 0; picker_type < 2; picker_type++) + { + // Draw small/thumbnail version of each picker type (over an invisible button for selection) + if (picker_type > 0) Separator(); + PushID(picker_type); + ImGuiColorEditFlags picker_flags = ImGuiColorEditFlags_NoInputs | ImGuiColorEditFlags_NoOptions | ImGuiColorEditFlags_NoLabel | ImGuiColorEditFlags_NoSidePreview | (flags & ImGuiColorEditFlags_NoAlpha); + if (picker_type == 0) picker_flags |= ImGuiColorEditFlags_PickerHueBar; + if (picker_type == 1) picker_flags |= ImGuiColorEditFlags_PickerHueWheel; + ImVec2 backup_pos = GetCursorScreenPos(); + if (Selectable("##selectable", false, 0, picker_size)) // By default, Selectable() is closing popup + g.ColorEditOptions = (g.ColorEditOptions & ~ImGuiColorEditFlags_PickerMask_) | (picker_flags & ImGuiColorEditFlags_PickerMask_); + SetCursorScreenPos(backup_pos); + ImVec4 previewing_ref_col; + memcpy(&previewing_ref_col, ref_col, sizeof(float) * ((picker_flags & ImGuiColorEditFlags_NoAlpha) ? 3 : 4)); + ColorPicker4("##previewing_picker", &previewing_ref_col.x, picker_flags); + PopID(); + } + PopItemWidth(); + } + if (allow_opt_alpha_bar) + { + if (allow_opt_picker) Separator(); + CheckboxFlags("Alpha Bar", &g.ColorEditOptions, ImGuiColorEditFlags_AlphaBar); + } + EndPopup(); +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: TreeNode, CollapsingHeader, etc. +//------------------------------------------------------------------------- +// - TreeNode() +// - TreeNodeV() +// - TreeNodeEx() +// - TreeNodeExV() +// - TreeNodeBehavior() [Internal] +// - TreePush() +// - TreePop() +// - GetTreeNodeToLabelSpacing() +// - SetNextItemOpen() +// - CollapsingHeader() +//------------------------------------------------------------------------- + +bool ImGui::TreeNode(const char* str_id, const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); + bool is_open = TreeNodeExV(str_id, 0, fmt, args); + va_end(args); + return is_open; +} + +bool ImGui::TreeNode(const void* ptr_id, const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); + bool is_open = TreeNodeExV(ptr_id, 0, fmt, args); + va_end(args); + return is_open; +} + +bool ImGui::TreeNode(const char* label) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + return TreeNodeBehavior(window->GetID(label), 0, label, NULL); +} + +bool ImGui::TreeNodeV(const char* str_id, const char* fmt, va_list args) +{ + return TreeNodeExV(str_id, 0, fmt, args); +} + +bool ImGui::TreeNodeV(const void* ptr_id, const char* fmt, va_list args) +{ + return TreeNodeExV(ptr_id, 0, fmt, args); +} + +bool ImGui::TreeNodeEx(const char* label, ImGuiTreeNodeFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + return TreeNodeBehavior(window->GetID(label), flags, label, NULL); +} + +bool ImGui::TreeNodeEx(const char* str_id, ImGuiTreeNodeFlags flags, const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); + bool is_open = TreeNodeExV(str_id, flags, fmt, args); + va_end(args); + return is_open; +} + +bool ImGui::TreeNodeEx(const void* ptr_id, ImGuiTreeNodeFlags flags, const char* fmt, ...) +{ + va_list args; + va_start(args, fmt); + bool is_open = TreeNodeExV(ptr_id, flags, fmt, args); + va_end(args); + return is_open; +} + +bool ImGui::TreeNodeExV(const char* str_id, ImGuiTreeNodeFlags flags, const char* fmt, va_list args) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const char* label_end = g.TempBuffer + ImFormatStringV(g.TempBuffer, IM_ARRAYSIZE(g.TempBuffer), fmt, args); + return TreeNodeBehavior(window->GetID(str_id), flags, g.TempBuffer, label_end); +} + +bool ImGui::TreeNodeExV(const void* ptr_id, ImGuiTreeNodeFlags flags, const char* fmt, va_list args) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const char* label_end = g.TempBuffer + ImFormatStringV(g.TempBuffer, IM_ARRAYSIZE(g.TempBuffer), fmt, args); + return TreeNodeBehavior(window->GetID(ptr_id), flags, g.TempBuffer, label_end); +} + +bool ImGui::TreeNodeBehaviorIsOpen(ImGuiID id, ImGuiTreeNodeFlags flags) +{ + if (flags & ImGuiTreeNodeFlags_Leaf) + return true; + + // We only write to the tree storage if the user clicks (or explicitly use the SetNextItemOpen function) + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + ImGuiStorage* storage = window->DC.StateStorage; + + bool is_open; + if (g.NextItemData.Flags & ImGuiNextItemDataFlags_HasOpen) + { + if (g.NextItemData.OpenCond & ImGuiCond_Always) + { + is_open = g.NextItemData.OpenVal; + storage->SetInt(id, is_open); + } + else + { + // We treat ImGuiCond_Once and ImGuiCond_FirstUseEver the same because tree node state are not saved persistently. + const int stored_value = storage->GetInt(id, -1); + if (stored_value == -1) + { + is_open = g.NextItemData.OpenVal; + storage->SetInt(id, is_open); + } + else + { + is_open = stored_value != 0; + } + } + } + else + { + is_open = storage->GetInt(id, (flags & ImGuiTreeNodeFlags_DefaultOpen) ? 1 : 0) != 0; + } + + // When logging is enabled, we automatically expand tree nodes (but *NOT* collapsing headers.. seems like sensible behavior). + // NB- If we are above max depth we still allow manually opened nodes to be logged. + if (g.LogEnabled && !(flags & ImGuiTreeNodeFlags_NoAutoOpenOnLog) && (window->DC.TreeDepth - g.LogDepthRef) < g.LogDepthToExpand) + is_open = true; + + return is_open; +} + +bool ImGui::TreeNodeBehavior(ImGuiID id, ImGuiTreeNodeFlags flags, const char* label, const char* label_end) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + const bool display_frame = (flags & ImGuiTreeNodeFlags_Framed) != 0; + const ImVec2 padding = (display_frame || (flags & ImGuiTreeNodeFlags_FramePadding)) ? style.FramePadding : ImVec2(style.FramePadding.x, ImMin(window->DC.CurrLineTextBaseOffset, style.FramePadding.y)); + + if (!label_end) + label_end = FindRenderedTextEnd(label); + const ImVec2 label_size = CalcTextSize(label, label_end, false); + + // We vertically grow up to current line height up the typical widget height. + const float frame_height = ImMax(ImMin(window->DC.CurrLineSize.y, g.FontSize + style.FramePadding.y * 2), label_size.y + padding.y * 2); + ImRect frame_bb; + frame_bb.Min.x = (flags & ImGuiTreeNodeFlags_SpanFullWidth) ? window->WorkRect.Min.x : window->DC.CursorPos.x; + frame_bb.Min.y = window->DC.CursorPos.y; + frame_bb.Max.x = window->WorkRect.Max.x; + frame_bb.Max.y = window->DC.CursorPos.y + frame_height; + if (display_frame) + { + // Framed header expand a little outside the default padding, to the edge of InnerClipRect + // (FIXME: May remove this at some point and make InnerClipRect align with WindowPadding.x instead of WindowPadding.x*0.5f) + frame_bb.Min.x -= IM_FLOOR(window->WindowPadding.x * 0.5f - 1.0f); + frame_bb.Max.x += IM_FLOOR(window->WindowPadding.x * 0.5f); + } + + const float text_offset_x = g.FontSize + (display_frame ? padding.x * 3 : padding.x * 2); // Collapser arrow width + Spacing + const float text_offset_y = ImMax(padding.y, window->DC.CurrLineTextBaseOffset); // Latch before ItemSize changes it + const float text_width = g.FontSize + (label_size.x > 0.0f ? label_size.x + padding.x * 2 : 0.0f); // Include collapser + ImVec2 text_pos(window->DC.CursorPos.x + text_offset_x, window->DC.CursorPos.y + text_offset_y); + ItemSize(ImVec2(text_width, frame_height), padding.y); + + // For regular tree nodes, we arbitrary allow to click past 2 worth of ItemSpacing + ImRect interact_bb = frame_bb; + if (!display_frame && (flags & (ImGuiTreeNodeFlags_SpanAvailWidth | ImGuiTreeNodeFlags_SpanFullWidth)) == 0) + interact_bb.Max.x = frame_bb.Min.x + text_width + style.ItemSpacing.x * 2.0f; + + // Store a flag for the current depth to tell if we will allow closing this node when navigating one of its child. + // For this purpose we essentially compare if g.NavIdIsAlive went from 0 to 1 between TreeNode() and TreePop(). + // This is currently only support 32 level deep and we are fine with (1 << Depth) overflowing into a zero. + const bool is_leaf = (flags & ImGuiTreeNodeFlags_Leaf) != 0; + bool is_open = TreeNodeBehaviorIsOpen(id, flags); + if (is_open && !g.NavIdIsAlive && (flags & ImGuiTreeNodeFlags_NavLeftJumpsBackHere) && !(flags & ImGuiTreeNodeFlags_NoTreePushOnOpen)) + window->DC.TreeJumpToParentOnPopMask |= (1 << window->DC.TreeDepth); + + bool item_add = ItemAdd(interact_bb, id); + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_HasDisplayRect; + g.LastItemData.DisplayRect = frame_bb; + + if (!item_add) + { + if (is_open && !(flags & ImGuiTreeNodeFlags_NoTreePushOnOpen)) + TreePushOverrideID(id); + IMGUI_TEST_ENGINE_ITEM_INFO(g.LastItemData.ID, label, g.LastItemData.StatusFlags | (is_leaf ? 0 : ImGuiItemStatusFlags_Openable) | (is_open ? ImGuiItemStatusFlags_Opened : 0)); + return is_open; + } + + ImGuiButtonFlags button_flags = ImGuiTreeNodeFlags_None; + if (flags & ImGuiTreeNodeFlags_AllowItemOverlap) + button_flags |= ImGuiButtonFlags_AllowItemOverlap; + if (!is_leaf) + button_flags |= ImGuiButtonFlags_PressedOnDragDropHold; + + // We allow clicking on the arrow section with keyboard modifiers held, in order to easily + // allow browsing a tree while preserving selection with code implementing multi-selection patterns. + // When clicking on the rest of the tree node we always disallow keyboard modifiers. + const float arrow_hit_x1 = (text_pos.x - text_offset_x) - style.TouchExtraPadding.x; + const float arrow_hit_x2 = (text_pos.x - text_offset_x) + (g.FontSize + padding.x * 2.0f) + style.TouchExtraPadding.x; + const bool is_mouse_x_over_arrow = (g.IO.MousePos.x >= arrow_hit_x1 && g.IO.MousePos.x < arrow_hit_x2); + if (window != g.HoveredWindow || !is_mouse_x_over_arrow) + button_flags |= ImGuiButtonFlags_NoKeyModifiers; + + // Open behaviors can be altered with the _OpenOnArrow and _OnOnDoubleClick flags. + // Some alteration have subtle effects (e.g. toggle on MouseUp vs MouseDown events) due to requirements for multi-selection and drag and drop support. + // - Single-click on label = Toggle on MouseUp (default, when _OpenOnArrow=0) + // - Single-click on arrow = Toggle on MouseDown (when _OpenOnArrow=0) + // - Single-click on arrow = Toggle on MouseDown (when _OpenOnArrow=1) + // - Double-click on label = Toggle on MouseDoubleClick (when _OpenOnDoubleClick=1) + // - Double-click on arrow = Toggle on MouseDoubleClick (when _OpenOnDoubleClick=1 and _OpenOnArrow=0) + // It is rather standard that arrow click react on Down rather than Up. + // We set ImGuiButtonFlags_PressedOnClickRelease on OpenOnDoubleClick because we want the item to be active on the initial MouseDown in order for drag and drop to work. + if (is_mouse_x_over_arrow) + button_flags |= ImGuiButtonFlags_PressedOnClick; + else if (flags & ImGuiTreeNodeFlags_OpenOnDoubleClick) + button_flags |= ImGuiButtonFlags_PressedOnClickRelease | ImGuiButtonFlags_PressedOnDoubleClick; + else + button_flags |= ImGuiButtonFlags_PressedOnClickRelease; + + bool selected = (flags & ImGuiTreeNodeFlags_Selected) != 0; + const bool was_selected = selected; + + bool hovered, held; + bool pressed = ButtonBehavior(interact_bb, id, &hovered, &held, button_flags); + bool toggled = false; + if (!is_leaf) + { + if (pressed && g.DragDropHoldJustPressedId != id) + { + if ((flags & (ImGuiTreeNodeFlags_OpenOnArrow | ImGuiTreeNodeFlags_OpenOnDoubleClick)) == 0 || (g.NavActivateId == id)) + toggled = true; + if (flags & ImGuiTreeNodeFlags_OpenOnArrow) + toggled |= is_mouse_x_over_arrow && !g.NavDisableMouseHover; // Lightweight equivalent of IsMouseHoveringRect() since ButtonBehavior() already did the job + if ((flags & ImGuiTreeNodeFlags_OpenOnDoubleClick) && g.IO.MouseDoubleClicked[0]) + toggled = true; + } + else if (pressed && g.DragDropHoldJustPressedId == id) + { + IM_ASSERT(button_flags & ImGuiButtonFlags_PressedOnDragDropHold); + if (!is_open) // When using Drag and Drop "hold to open" we keep the node highlighted after opening, but never close it again. + toggled = true; + } + + if (g.NavId == id && g.NavMoveDir == ImGuiDir_Left && is_open) + { + toggled = true; + NavMoveRequestCancel(); + } + if (g.NavId == id && g.NavMoveDir == ImGuiDir_Right && !is_open) // If there's something upcoming on the line we may want to give it the priority? + { + toggled = true; + NavMoveRequestCancel(); + } + + if (toggled) + { + is_open = !is_open; + window->DC.StateStorage->SetInt(id, is_open); + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_ToggledOpen; + } + } + if (flags & ImGuiTreeNodeFlags_AllowItemOverlap) + SetItemAllowOverlap(); + + // In this branch, TreeNodeBehavior() cannot toggle the selection so this will never trigger. + if (selected != was_selected) //-V547 + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_ToggledSelection; + + // Render + const ImU32 text_col = GetColorU32(ImGuiCol_Text); + ImGuiNavHighlightFlags nav_highlight_flags = ImGuiNavHighlightFlags_TypeThin; + if (display_frame) + { + // Framed type + const ImU32 bg_col = GetColorU32((held && hovered) ? ImGuiCol_HeaderActive : hovered ? ImGuiCol_HeaderHovered : ImGuiCol_Header); + RenderFrame(frame_bb.Min, frame_bb.Max, bg_col, true, style.FrameRounding); + RenderNavHighlight(frame_bb, id, nav_highlight_flags); + if (flags & ImGuiTreeNodeFlags_Bullet) + RenderBullet(window->DrawList, ImVec2(text_pos.x - text_offset_x * 0.60f, text_pos.y + g.FontSize * 0.5f), text_col); + else if (!is_leaf) + RenderArrow(window->DrawList, ImVec2(text_pos.x - text_offset_x + padding.x, text_pos.y), text_col, is_open ? ImGuiDir_Down : ImGuiDir_Right, 1.0f); + else // Leaf without bullet, left-adjusted text + text_pos.x -= text_offset_x; + if (flags & ImGuiTreeNodeFlags_ClipLabelForTrailingButton) + frame_bb.Max.x -= g.FontSize + style.FramePadding.x; + + if (g.LogEnabled) + LogSetNextTextDecoration("###", "###"); + RenderTextClipped(text_pos, frame_bb.Max, label, label_end, &label_size); + } + else + { + // Unframed typed for tree nodes + if (hovered || selected) + { + const ImU32 bg_col = GetColorU32((held && hovered) ? ImGuiCol_HeaderActive : hovered ? ImGuiCol_HeaderHovered : ImGuiCol_Header); + RenderFrame(frame_bb.Min, frame_bb.Max, bg_col, false); + } + RenderNavHighlight(frame_bb, id, nav_highlight_flags); + if (flags & ImGuiTreeNodeFlags_Bullet) + RenderBullet(window->DrawList, ImVec2(text_pos.x - text_offset_x * 0.5f, text_pos.y + g.FontSize * 0.5f), text_col); + else if (!is_leaf) + RenderArrow(window->DrawList, ImVec2(text_pos.x - text_offset_x + padding.x, text_pos.y + g.FontSize * 0.15f), text_col, is_open ? ImGuiDir_Down : ImGuiDir_Right, 0.70f); + if (g.LogEnabled) + LogSetNextTextDecoration(">", NULL); + RenderText(text_pos, label, label_end, false); + } + + if (is_open && !(flags & ImGuiTreeNodeFlags_NoTreePushOnOpen)) + TreePushOverrideID(id); + IMGUI_TEST_ENGINE_ITEM_INFO(id, label, g.LastItemData.StatusFlags | (is_leaf ? 0 : ImGuiItemStatusFlags_Openable) | (is_open ? ImGuiItemStatusFlags_Opened : 0)); + return is_open; +} + +void ImGui::TreePush(const char* str_id) +{ + ImGuiWindow* window = GetCurrentWindow(); + Indent(); + window->DC.TreeDepth++; + PushID(str_id); +} + +void ImGui::TreePush(const void* ptr_id) +{ + ImGuiWindow* window = GetCurrentWindow(); + Indent(); + window->DC.TreeDepth++; + PushID(ptr_id); +} + +void ImGui::TreePushOverrideID(ImGuiID id) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + Indent(); + window->DC.TreeDepth++; + window->IDStack.push_back(id); +} + +void ImGui::TreePop() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + Unindent(); + + window->DC.TreeDepth--; + ImU32 tree_depth_mask = (1 << window->DC.TreeDepth); + + // Handle Left arrow to move to parent tree node (when ImGuiTreeNodeFlags_NavLeftJumpsBackHere is enabled) + if (g.NavMoveDir == ImGuiDir_Left && g.NavWindow == window && NavMoveRequestButNoResultYet()) + if (g.NavIdIsAlive && (window->DC.TreeJumpToParentOnPopMask & tree_depth_mask)) + { + SetNavID(window->IDStack.back(), g.NavLayer, 0, ImRect()); + NavMoveRequestCancel(); + } + window->DC.TreeJumpToParentOnPopMask &= tree_depth_mask - 1; + + IM_ASSERT(window->IDStack.Size > 1); // There should always be 1 element in the IDStack (pushed during window creation). If this triggers you called TreePop/PopID too much. + PopID(); +} + +// Horizontal distance preceding label when using TreeNode() or Bullet() +float ImGui::GetTreeNodeToLabelSpacing() +{ + ImGuiContext& g = *GImGui; + return g.FontSize + (g.Style.FramePadding.x * 2.0f); +} + +// Set next TreeNode/CollapsingHeader open state. +void ImGui::SetNextItemOpen(bool is_open, ImGuiCond cond) +{ + ImGuiContext& g = *GImGui; + if (g.CurrentWindow->SkipItems) + return; + g.NextItemData.Flags |= ImGuiNextItemDataFlags_HasOpen; + g.NextItemData.OpenVal = is_open; + g.NextItemData.OpenCond = cond ? cond : ImGuiCond_Always; +} + +// CollapsingHeader returns true when opened but do not indent nor push into the ID stack (because of the ImGuiTreeNodeFlags_NoTreePushOnOpen flag). +// This is basically the same as calling TreeNodeEx(label, ImGuiTreeNodeFlags_CollapsingHeader). You can remove the _NoTreePushOnOpen flag if you want behavior closer to normal TreeNode(). +bool ImGui::CollapsingHeader(const char* label, ImGuiTreeNodeFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + return TreeNodeBehavior(window->GetID(label), flags | ImGuiTreeNodeFlags_CollapsingHeader, label); +} + +// p_visible == NULL : regular collapsing header +// p_visible != NULL && *p_visible == true : show a small close button on the corner of the header, clicking the button will set *p_visible = false +// p_visible != NULL && *p_visible == false : do not show the header at all +// Do not mistake this with the Open state of the header itself, which you can adjust with SetNextItemOpen() or ImGuiTreeNodeFlags_DefaultOpen. +bool ImGui::CollapsingHeader(const char* label, bool* p_visible, ImGuiTreeNodeFlags flags) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + if (p_visible && !*p_visible) + return false; + + ImGuiID id = window->GetID(label); + flags |= ImGuiTreeNodeFlags_CollapsingHeader; + if (p_visible) + flags |= ImGuiTreeNodeFlags_AllowItemOverlap | ImGuiTreeNodeFlags_ClipLabelForTrailingButton; + bool is_open = TreeNodeBehavior(id, flags, label); + if (p_visible != NULL) + { + // Create a small overlapping close button + // FIXME: We can evolve this into user accessible helpers to add extra buttons on title bars, headers, etc. + // FIXME: CloseButton can overlap into text, need find a way to clip the text somehow. + ImGuiContext& g = *GImGui; + ImGuiLastItemData last_item_backup = g.LastItemData; + float button_size = g.FontSize; + float button_x = ImMax(g.LastItemData.Rect.Min.x, g.LastItemData.Rect.Max.x - g.Style.FramePadding.x * 2.0f - button_size); + float button_y = g.LastItemData.Rect.Min.y; + ImGuiID close_button_id = GetIDWithSeed("#CLOSE", NULL, id); + if (CloseButton(close_button_id, ImVec2(button_x, button_y))) + *p_visible = false; + g.LastItemData = last_item_backup; + } + + return is_open; +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: Selectable +//------------------------------------------------------------------------- +// - Selectable() +//------------------------------------------------------------------------- + +// Tip: pass a non-visible label (e.g. "##hello") then you can use the space to draw other text or image. +// But you need to make sure the ID is unique, e.g. enclose calls in PushID/PopID or use ##unique_id. +// With this scheme, ImGuiSelectableFlags_SpanAllColumns and ImGuiSelectableFlags_AllowItemOverlap are also frequently used flags. +// FIXME: Selectable() with (size.x == 0.0f) and (SelectableTextAlign.x > 0.0f) followed by SameLine() is currently not supported. +bool ImGui::Selectable(const char* label, bool selected, ImGuiSelectableFlags flags, const ImVec2& size_arg) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + + // Submit label or explicit size to ItemSize(), whereas ItemAdd() will submit a larger/spanning rectangle. + ImGuiID id = window->GetID(label); + ImVec2 label_size = CalcTextSize(label, NULL, true); + ImVec2 size(size_arg.x != 0.0f ? size_arg.x : label_size.x, size_arg.y != 0.0f ? size_arg.y : label_size.y); + ImVec2 pos = window->DC.CursorPos; + pos.y += window->DC.CurrLineTextBaseOffset; + ItemSize(size, 0.0f); + + // Fill horizontal space + // We don't support (size < 0.0f) in Selectable() because the ItemSpacing extension would make explicitly right-aligned sizes not visibly match other widgets. + const bool span_all_columns = (flags & ImGuiSelectableFlags_SpanAllColumns) != 0; + const float min_x = span_all_columns ? window->ParentWorkRect.Min.x : pos.x; + const float max_x = span_all_columns ? window->ParentWorkRect.Max.x : window->WorkRect.Max.x; + if (size_arg.x == 0.0f || (flags & ImGuiSelectableFlags_SpanAvailWidth)) + size.x = ImMax(label_size.x, max_x - min_x); + + // Text stays at the submission position, but bounding box may be extended on both sides + const ImVec2 text_min = pos; + const ImVec2 text_max(min_x + size.x, pos.y + size.y); + + // Selectables are meant to be tightly packed together with no click-gap, so we extend their box to cover spacing between selectable. + ImRect bb(min_x, pos.y, text_max.x, text_max.y); + if ((flags & ImGuiSelectableFlags_NoPadWithHalfSpacing) == 0) + { + const float spacing_x = span_all_columns ? 0.0f : style.ItemSpacing.x; + const float spacing_y = style.ItemSpacing.y; + const float spacing_L = IM_FLOOR(spacing_x * 0.50f); + const float spacing_U = IM_FLOOR(spacing_y * 0.50f); + bb.Min.x -= spacing_L; + bb.Min.y -= spacing_U; + bb.Max.x += (spacing_x - spacing_L); + bb.Max.y += (spacing_y - spacing_U); + } + //if (g.IO.KeyCtrl) { GetForegroundDrawList()->AddRect(bb.Min, bb.Max, IM_COL32(0, 255, 0, 255)); } + + // Modify ClipRect for the ItemAdd(), faster than doing a PushColumnsBackground/PushTableBackground for every Selectable.. + const float backup_clip_rect_min_x = window->ClipRect.Min.x; + const float backup_clip_rect_max_x = window->ClipRect.Max.x; + if (span_all_columns) + { + window->ClipRect.Min.x = window->ParentWorkRect.Min.x; + window->ClipRect.Max.x = window->ParentWorkRect.Max.x; + } + + const bool disabled_item = (flags & ImGuiSelectableFlags_Disabled) != 0; + const bool item_add = ItemAdd(bb, id, NULL, disabled_item ? ImGuiItemFlags_Disabled : ImGuiItemFlags_None); + if (span_all_columns) + { + window->ClipRect.Min.x = backup_clip_rect_min_x; + window->ClipRect.Max.x = backup_clip_rect_max_x; + } + + if (!item_add) + return false; + + const bool disabled_global = (g.CurrentItemFlags & ImGuiItemFlags_Disabled) != 0; + if (disabled_item && !disabled_global) // Only testing this as an optimization + BeginDisabled(); + + // FIXME: We can standardize the behavior of those two, we could also keep the fast path of override ClipRect + full push on render only, + // which would be advantageous since most selectable are not selected. + if (span_all_columns && window->DC.CurrentColumns) + PushColumnsBackground(); + else if (span_all_columns && g.CurrentTable) + TablePushBackgroundChannel(); + + // We use NoHoldingActiveID on menus so user can click and _hold_ on a menu then drag to browse child entries + ImGuiButtonFlags button_flags = 0; + if (flags & ImGuiSelectableFlags_NoHoldingActiveID) { button_flags |= ImGuiButtonFlags_NoHoldingActiveId; } + if (flags & ImGuiSelectableFlags_SelectOnClick) { button_flags |= ImGuiButtonFlags_PressedOnClick; } + if (flags & ImGuiSelectableFlags_SelectOnRelease) { button_flags |= ImGuiButtonFlags_PressedOnRelease; } + if (flags & ImGuiSelectableFlags_AllowDoubleClick) { button_flags |= ImGuiButtonFlags_PressedOnClickRelease | ImGuiButtonFlags_PressedOnDoubleClick; } + if (flags & ImGuiSelectableFlags_AllowItemOverlap) { button_flags |= ImGuiButtonFlags_AllowItemOverlap; } + + const bool was_selected = selected; + bool hovered, held; + bool pressed = ButtonBehavior(bb, id, &hovered, &held, button_flags); + + // Auto-select when moved into + // - This will be more fully fleshed in the range-select branch + // - This is not exposed as it won't nicely work with some user side handling of shift/control + // - We cannot do 'if (g.NavJustMovedToId != id) { selected = false; pressed = was_selected; }' for two reasons + // - (1) it would require focus scope to be set, need exposing PushFocusScope() or equivalent (e.g. BeginSelection() calling PushFocusScope()) + // - (2) usage will fail with clipped items + // The multi-select API aim to fix those issues, e.g. may be replaced with a BeginSelection() API. + if ((flags & ImGuiSelectableFlags_SelectOnNav) && g.NavJustMovedToId != 0 && g.NavJustMovedToFocusScopeId == window->DC.NavFocusScopeIdCurrent) + if (g.NavJustMovedToId == id) + selected = pressed = true; + + // Update NavId when clicking or when Hovering (this doesn't happen on most widgets), so navigation can be resumed with gamepad/keyboard + if (pressed || (hovered && (flags & ImGuiSelectableFlags_SetNavIdOnHover))) + { + if (!g.NavDisableMouseHover && g.NavWindow == window && g.NavLayer == window->DC.NavLayerCurrent) + { + SetNavID(id, window->DC.NavLayerCurrent, window->DC.NavFocusScopeIdCurrent, ImRect(bb.Min - window->Pos, bb.Max - window->Pos)); // (bb == NavRect) + g.NavDisableHighlight = true; + } + } + if (pressed) + MarkItemEdited(id); + + if (flags & ImGuiSelectableFlags_AllowItemOverlap) + SetItemAllowOverlap(); + + // In this branch, Selectable() cannot toggle the selection so this will never trigger. + if (selected != was_selected) //-V547 + g.LastItemData.StatusFlags |= ImGuiItemStatusFlags_ToggledSelection; + + // Render + if (held && (flags & ImGuiSelectableFlags_DrawHoveredWhenHeld)) + hovered = true; + if (hovered || selected) + { + const ImU32 col = GetColorU32((held && hovered) ? ImGuiCol_HeaderActive : hovered ? ImGuiCol_HeaderHovered : ImGuiCol_Header); + RenderFrame(bb.Min, bb.Max, col, false, 0.0f); + } + RenderNavHighlight(bb, id, ImGuiNavHighlightFlags_TypeThin | ImGuiNavHighlightFlags_NoRounding); + + if (span_all_columns && window->DC.CurrentColumns) + PopColumnsBackground(); + else if (span_all_columns && g.CurrentTable) + TablePopBackgroundChannel(); + + RenderTextClipped(text_min, text_max, label, NULL, &label_size, style.SelectableTextAlign, &bb); + + // Automatically close popups + if (pressed && (window->Flags & ImGuiWindowFlags_Popup) && !(flags & ImGuiSelectableFlags_DontClosePopups) && !(g.LastItemData.InFlags & ImGuiItemFlags_SelectableDontClosePopup)) + CloseCurrentPopup(); + + if (disabled_item && !disabled_global) + EndDisabled(); + + IMGUI_TEST_ENGINE_ITEM_INFO(id, label, g.LastItemData.StatusFlags); + return pressed; //-V1020 +} + +bool ImGui::Selectable(const char* label, bool* p_selected, ImGuiSelectableFlags flags, const ImVec2& size_arg) +{ + if (Selectable(label, *p_selected, flags, size_arg)) + { + *p_selected = !*p_selected; + return true; + } + return false; +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: ListBox +//------------------------------------------------------------------------- +// - BeginListBox() +// - EndListBox() +// - ListBox() +//------------------------------------------------------------------------- + +// Tip: To have a list filling the entire window width, use size.x = -FLT_MIN and pass an non-visible label e.g. "##empty" +// Tip: If your vertical size is calculated from an item count (e.g. 10 * item_height) consider adding a fractional part to facilitate seeing scrolling boundaries (e.g. 10.25 * item_height). +bool ImGui::BeginListBox(const char* label, const ImVec2& size_arg) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + const ImGuiStyle& style = g.Style; + const ImGuiID id = GetID(label); + const ImVec2 label_size = CalcTextSize(label, NULL, true); + + // Size default to hold ~7.25 items. + // Fractional number of items helps seeing that we can scroll down/up without looking at scrollbar. + ImVec2 size = ImFloor(CalcItemSize(size_arg, CalcItemWidth(), GetTextLineHeightWithSpacing() * 7.25f + style.FramePadding.y * 2.0f)); + ImVec2 frame_size = ImVec2(size.x, ImMax(size.y, label_size.y)); + ImRect frame_bb(window->DC.CursorPos, window->DC.CursorPos + frame_size); + ImRect bb(frame_bb.Min, frame_bb.Max + ImVec2(label_size.x > 0.0f ? style.ItemInnerSpacing.x + label_size.x : 0.0f, 0.0f)); + g.NextItemData.ClearFlags(); + + if (!IsRectVisible(bb.Min, bb.Max)) + { + ItemSize(bb.GetSize(), style.FramePadding.y); + ItemAdd(bb, 0, &frame_bb); + return false; + } + + // FIXME-OPT: We could omit the BeginGroup() if label_size.x but would need to omit the EndGroup() as well. + BeginGroup(); + if (label_size.x > 0.0f) + { + ImVec2 label_pos = ImVec2(frame_bb.Max.x + style.ItemInnerSpacing.x, frame_bb.Min.y + style.FramePadding.y); + RenderText(label_pos, label); + window->DC.CursorMaxPos = ImMax(window->DC.CursorMaxPos, label_pos + label_size); + } + + BeginChildFrame(id, frame_bb.GetSize()); + return true; +} + +#ifndef IMGUI_DISABLE_OBSOLETE_FUNCTIONS +// OBSOLETED in 1.81 (from February 2021) +bool ImGui::ListBoxHeader(const char* label, int items_count, int height_in_items) +{ + // If height_in_items == -1, default height is maximum 7. + ImGuiContext& g = *GImGui; + float height_in_items_f = (height_in_items < 0 ? ImMin(items_count, 7) : height_in_items) + 0.25f; + ImVec2 size; + size.x = 0.0f; + size.y = GetTextLineHeightWithSpacing() * height_in_items_f + g.Style.FramePadding.y * 2.0f; + return BeginListBox(label, size); +} +#endif + +void ImGui::EndListBox() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + IM_ASSERT((window->Flags & ImGuiWindowFlags_ChildWindow) && "Mismatched BeginListBox/EndListBox calls. Did you test the return value of BeginListBox?"); + IM_UNUSED(window); + + EndChildFrame(); + EndGroup(); // This is only required to be able to do IsItemXXX query on the whole ListBox including label +} + +bool ImGui::ListBox(const char* label, int* current_item, const char* const items[], int items_count, int height_items) +{ + const bool value_changed = ListBox(label, current_item, Items_ArrayGetter, (void*)items, items_count, height_items); + return value_changed; +} + +// This is merely a helper around BeginListBox(), EndListBox(). +// Considering using those directly to submit custom data or store selection differently. +bool ImGui::ListBox(const char* label, int* current_item, bool (*items_getter)(void*, int, const char**), void* data, int items_count, int height_in_items) +{ + ImGuiContext& g = *GImGui; + + // Calculate size from "height_in_items" + if (height_in_items < 0) + height_in_items = ImMin(items_count, 7); + float height_in_items_f = height_in_items + 0.25f; + ImVec2 size(0.0f, ImFloor(GetTextLineHeightWithSpacing() * height_in_items_f + g.Style.FramePadding.y * 2.0f)); + + if (!BeginListBox(label, size)) + return false; + + // Assume all items have even height (= 1 line of text). If you need items of different height, + // you can create a custom version of ListBox() in your code without using the clipper. + bool value_changed = false; + ImGuiListClipper clipper; + clipper.Begin(items_count, GetTextLineHeightWithSpacing()); // We know exactly our line height here so we pass it as a minor optimization, but generally you don't need to. + while (clipper.Step()) + for (int i = clipper.DisplayStart; i < clipper.DisplayEnd; i++) + { + const char* item_text; + if (!items_getter(data, i, &item_text)) + item_text = "*Unknown item*"; + + PushID(i); + const bool item_selected = (i == *current_item); + if (Selectable(item_text, item_selected)) + { + *current_item = i; + value_changed = true; + } + if (item_selected) + SetItemDefaultFocus(); + PopID(); + } + EndListBox(); + + if (value_changed) + MarkItemEdited(g.LastItemData.ID); + + return value_changed; +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: PlotLines, PlotHistogram +//------------------------------------------------------------------------- +// - PlotEx() [Internal] +// - PlotLines() +// - PlotHistogram() +//------------------------------------------------------------------------- +// Plot/Graph widgets are not very good. +// Consider writing your own, or using a third-party one, see: +// - ImPlot https://github.com/epezent/implot +// - others https://github.com/ocornut/imgui/wiki/Useful-Extensions +//------------------------------------------------------------------------- + +int ImGui::PlotEx(ImGuiPlotType plot_type, const char* label, float (*values_getter)(void* data, int idx), void* data, int values_count, int values_offset, const char* overlay_text, float scale_min, float scale_max, ImVec2 frame_size) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return -1; + + const ImGuiStyle& style = g.Style; + const ImGuiID id = window->GetID(label); + + const ImVec2 label_size = CalcTextSize(label, NULL, true); + if (frame_size.x == 0.0f) + frame_size.x = CalcItemWidth(); + if (frame_size.y == 0.0f) + frame_size.y = label_size.y + (style.FramePadding.y * 2); + + const ImRect frame_bb(window->DC.CursorPos, window->DC.CursorPos + frame_size); + const ImRect inner_bb(frame_bb.Min + style.FramePadding, frame_bb.Max - style.FramePadding); + const ImRect total_bb(frame_bb.Min, frame_bb.Max + ImVec2(label_size.x > 0.0f ? style.ItemInnerSpacing.x + label_size.x : 0.0f, 0)); + ItemSize(total_bb, style.FramePadding.y); + if (!ItemAdd(total_bb, 0, &frame_bb)) + return -1; + const bool hovered = ItemHoverable(frame_bb, id); + + // Determine scale from values if not specified + if (scale_min == FLT_MAX || scale_max == FLT_MAX) + { + float v_min = FLT_MAX; + float v_max = -FLT_MAX; + for (int i = 0; i < values_count; i++) + { + const float v = values_getter(data, i); + if (v != v) // Ignore NaN values + continue; + v_min = ImMin(v_min, v); + v_max = ImMax(v_max, v); + } + if (scale_min == FLT_MAX) + scale_min = v_min; + if (scale_max == FLT_MAX) + scale_max = v_max; + } + + RenderFrame(frame_bb.Min, frame_bb.Max, GetColorU32(ImGuiCol_FrameBg), true, style.FrameRounding); + + const int values_count_min = (plot_type == ImGuiPlotType_Lines) ? 2 : 1; + int idx_hovered = -1; + if (values_count >= values_count_min) + { + int res_w = ImMin((int)frame_size.x, values_count) + ((plot_type == ImGuiPlotType_Lines) ? -1 : 0); + int item_count = values_count + ((plot_type == ImGuiPlotType_Lines) ? -1 : 0); + + // Tooltip on hover + if (hovered && inner_bb.Contains(g.IO.MousePos)) + { + const float t = ImClamp((g.IO.MousePos.x - inner_bb.Min.x) / (inner_bb.Max.x - inner_bb.Min.x), 0.0f, 0.9999f); + const int v_idx = (int)(t * item_count); + IM_ASSERT(v_idx >= 0 && v_idx < values_count); + + const float v0 = values_getter(data, (v_idx + values_offset) % values_count); + const float v1 = values_getter(data, (v_idx + 1 + values_offset) % values_count); + if (plot_type == ImGuiPlotType_Lines) + SetTooltip("%d: %8.4g\n%d: %8.4g", v_idx, v0, v_idx + 1, v1); + else if (plot_type == ImGuiPlotType_Histogram) + SetTooltip("%d: %8.4g", v_idx, v0); + idx_hovered = v_idx; + } + + const float t_step = 1.0f / (float)res_w; + const float inv_scale = (scale_min == scale_max) ? 0.0f : (1.0f / (scale_max - scale_min)); + + float v0 = values_getter(data, (0 + values_offset) % values_count); + float t0 = 0.0f; + ImVec2 tp0 = ImVec2( t0, 1.0f - ImSaturate((v0 - scale_min) * inv_scale) ); // Point in the normalized space of our target rectangle + float histogram_zero_line_t = (scale_min * scale_max < 0.0f) ? (1 + scale_min * inv_scale) : (scale_min < 0.0f ? 0.0f : 1.0f); // Where does the zero line stands + + const ImU32 col_base = GetColorU32((plot_type == ImGuiPlotType_Lines) ? ImGuiCol_PlotLines : ImGuiCol_PlotHistogram); + const ImU32 col_hovered = GetColorU32((plot_type == ImGuiPlotType_Lines) ? ImGuiCol_PlotLinesHovered : ImGuiCol_PlotHistogramHovered); + + for (int n = 0; n < res_w; n++) + { + const float t1 = t0 + t_step; + const int v1_idx = (int)(t0 * item_count + 0.5f); + IM_ASSERT(v1_idx >= 0 && v1_idx < values_count); + const float v1 = values_getter(data, (v1_idx + values_offset + 1) % values_count); + const ImVec2 tp1 = ImVec2( t1, 1.0f - ImSaturate((v1 - scale_min) * inv_scale) ); + + // NB: Draw calls are merged together by the DrawList system. Still, we should render our batch are lower level to save a bit of CPU. + ImVec2 pos0 = ImLerp(inner_bb.Min, inner_bb.Max, tp0); + ImVec2 pos1 = ImLerp(inner_bb.Min, inner_bb.Max, (plot_type == ImGuiPlotType_Lines) ? tp1 : ImVec2(tp1.x, histogram_zero_line_t)); + if (plot_type == ImGuiPlotType_Lines) + { + window->DrawList->AddLine(pos0, pos1, idx_hovered == v1_idx ? col_hovered : col_base); + } + else if (plot_type == ImGuiPlotType_Histogram) + { + if (pos1.x >= pos0.x + 2.0f) + pos1.x -= 1.0f; + window->DrawList->AddRectFilled(pos0, pos1, idx_hovered == v1_idx ? col_hovered : col_base); + } + + t0 = t1; + tp0 = tp1; + } + } + + // Text overlay + if (overlay_text) + RenderTextClipped(ImVec2(frame_bb.Min.x, frame_bb.Min.y + style.FramePadding.y), frame_bb.Max, overlay_text, NULL, NULL, ImVec2(0.5f, 0.0f)); + + if (label_size.x > 0.0f) + RenderText(ImVec2(frame_bb.Max.x + style.ItemInnerSpacing.x, inner_bb.Min.y), label); + + // Return hovered index or -1 if none are hovered. + // This is currently not exposed in the public API because we need a larger redesign of the whole thing, but in the short-term we are making it available in PlotEx(). + return idx_hovered; +} + +struct ImGuiPlotArrayGetterData +{ + const float* Values; + int Stride; + + ImGuiPlotArrayGetterData(const float* values, int stride) { Values = values; Stride = stride; } +}; + +static float Plot_ArrayGetter(void* data, int idx) +{ + ImGuiPlotArrayGetterData* plot_data = (ImGuiPlotArrayGetterData*)data; + const float v = *(const float*)(const void*)((const unsigned char*)plot_data->Values + (size_t)idx * plot_data->Stride); + return v; +} + +void ImGui::PlotLines(const char* label, const float* values, int values_count, int values_offset, const char* overlay_text, float scale_min, float scale_max, ImVec2 graph_size, int stride) +{ + ImGuiPlotArrayGetterData data(values, stride); + PlotEx(ImGuiPlotType_Lines, label, &Plot_ArrayGetter, (void*)&data, values_count, values_offset, overlay_text, scale_min, scale_max, graph_size); +} + +void ImGui::PlotLines(const char* label, float (*values_getter)(void* data, int idx), void* data, int values_count, int values_offset, const char* overlay_text, float scale_min, float scale_max, ImVec2 graph_size) +{ + PlotEx(ImGuiPlotType_Lines, label, values_getter, data, values_count, values_offset, overlay_text, scale_min, scale_max, graph_size); +} + +void ImGui::PlotHistogram(const char* label, const float* values, int values_count, int values_offset, const char* overlay_text, float scale_min, float scale_max, ImVec2 graph_size, int stride) +{ + ImGuiPlotArrayGetterData data(values, stride); + PlotEx(ImGuiPlotType_Histogram, label, &Plot_ArrayGetter, (void*)&data, values_count, values_offset, overlay_text, scale_min, scale_max, graph_size); +} + +void ImGui::PlotHistogram(const char* label, float (*values_getter)(void* data, int idx), void* data, int values_count, int values_offset, const char* overlay_text, float scale_min, float scale_max, ImVec2 graph_size) +{ + PlotEx(ImGuiPlotType_Histogram, label, values_getter, data, values_count, values_offset, overlay_text, scale_min, scale_max, graph_size); +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: Value helpers +// Those is not very useful, legacy API. +//------------------------------------------------------------------------- +// - Value() +//------------------------------------------------------------------------- + +void ImGui::Value(const char* prefix, bool b) +{ + Text("%s: %s", prefix, (b ? "true" : "false")); +} + +void ImGui::Value(const char* prefix, int v) +{ + Text("%s: %d", prefix, v); +} + +void ImGui::Value(const char* prefix, unsigned int v) +{ + Text("%s: %d", prefix, v); +} + +void ImGui::Value(const char* prefix, float v, const char* float_format) +{ + if (float_format) + { + char fmt[64]; + ImFormatString(fmt, IM_ARRAYSIZE(fmt), "%%s: %s", float_format); + Text(fmt, prefix, v); + } + else + { + Text("%s: %.3f", prefix, v); + } +} + +//------------------------------------------------------------------------- +// [SECTION] MenuItem, BeginMenu, EndMenu, etc. +//------------------------------------------------------------------------- +// - ImGuiMenuColumns [Internal] +// - BeginMenuBar() +// - EndMenuBar() +// - BeginMainMenuBar() +// - EndMainMenuBar() +// - BeginMenu() +// - EndMenu() +// - MenuItemEx() [Internal] +// - MenuItem() +//------------------------------------------------------------------------- + +// Helpers for internal use +void ImGuiMenuColumns::Update(float spacing, bool window_reappearing) +{ + if (window_reappearing) + memset(Widths, 0, sizeof(Widths)); + Spacing = (ImU16)spacing; + CalcNextTotalWidth(true); + memset(Widths, 0, sizeof(Widths)); + TotalWidth = NextTotalWidth; + NextTotalWidth = 0; +} + +void ImGuiMenuColumns::CalcNextTotalWidth(bool update_offsets) +{ + ImU16 offset = 0; + bool want_spacing = false; + for (int i = 0; i < IM_ARRAYSIZE(Widths); i++) + { + ImU16 width = Widths[i]; + if (want_spacing && width > 0) + offset += Spacing; + want_spacing |= (width > 0); + if (update_offsets) + { + if (i == 1) { OffsetLabel = offset; } + if (i == 2) { OffsetShortcut = offset; } + if (i == 3) { OffsetMark = offset; } + } + offset += width; + } + NextTotalWidth = offset; +} + +float ImGuiMenuColumns::DeclColumns(float w_icon, float w_label, float w_shortcut, float w_mark) +{ + Widths[0] = ImMax(Widths[0], (ImU16)w_icon); + Widths[1] = ImMax(Widths[1], (ImU16)w_label); + Widths[2] = ImMax(Widths[2], (ImU16)w_shortcut); + Widths[3] = ImMax(Widths[3], (ImU16)w_mark); + CalcNextTotalWidth(false); + return (float)ImMax(TotalWidth, NextTotalWidth); +} + +// FIXME: Provided a rectangle perhaps e.g. a BeginMenuBarEx() could be used anywhere.. +// Currently the main responsibility of this function being to setup clip-rect + horizontal layout + menu navigation layer. +// Ideally we also want this to be responsible for claiming space out of the main window scrolling rectangle, in which case ImGuiWindowFlags_MenuBar will become unnecessary. +// Then later the same system could be used for multiple menu-bars, scrollbars, side-bars. +bool ImGui::BeginMenuBar() +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + if (!(window->Flags & ImGuiWindowFlags_MenuBar)) + return false; + + IM_ASSERT(!window->DC.MenuBarAppending); + BeginGroup(); // Backup position on layer 0 // FIXME: Misleading to use a group for that backup/restore + PushID("##menubar"); + + // We don't clip with current window clipping rectangle as it is already set to the area below. However we clip with window full rect. + // We remove 1 worth of rounding to Max.x to that text in long menus and small windows don't tend to display over the lower-right rounded area, which looks particularly glitchy. + ImRect bar_rect = window->MenuBarRect(); + ImRect clip_rect(IM_ROUND(bar_rect.Min.x + window->WindowBorderSize), IM_ROUND(bar_rect.Min.y + window->WindowBorderSize), IM_ROUND(ImMax(bar_rect.Min.x, bar_rect.Max.x - ImMax(window->WindowRounding, window->WindowBorderSize))), IM_ROUND(bar_rect.Max.y)); + clip_rect.ClipWith(window->OuterRectClipped); + PushClipRect(clip_rect.Min, clip_rect.Max, false); + + // We overwrite CursorMaxPos because BeginGroup sets it to CursorPos (essentially the .EmitItem hack in EndMenuBar() would need something analogous here, maybe a BeginGroupEx() with flags). + window->DC.CursorPos = window->DC.CursorMaxPos = ImVec2(bar_rect.Min.x + window->DC.MenuBarOffset.x, bar_rect.Min.y + window->DC.MenuBarOffset.y); + window->DC.LayoutType = ImGuiLayoutType_Horizontal; + window->DC.NavLayerCurrent = ImGuiNavLayer_Menu; + window->DC.MenuBarAppending = true; + AlignTextToFramePadding(); + return true; +} + +void ImGui::EndMenuBar() +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return; + ImGuiContext& g = *GImGui; + + // Nav: When a move request within one of our child menu failed, capture the request to navigate among our siblings. + if (NavMoveRequestButNoResultYet() && (g.NavMoveDir == ImGuiDir_Left || g.NavMoveDir == ImGuiDir_Right) && (g.NavWindow->Flags & ImGuiWindowFlags_ChildMenu)) + { + // Try to find out if the request is for one of our child menu + ImGuiWindow* nav_earliest_child = g.NavWindow; + while (nav_earliest_child->ParentWindow && (nav_earliest_child->ParentWindow->Flags & ImGuiWindowFlags_ChildMenu)) + nav_earliest_child = nav_earliest_child->ParentWindow; + if (nav_earliest_child->ParentWindow == window && nav_earliest_child->DC.ParentLayoutType == ImGuiLayoutType_Horizontal && (g.NavMoveFlags & ImGuiNavMoveFlags_Forwarded) == 0) + { + // To do so we claim focus back, restore NavId and then process the movement request for yet another frame. + // This involve a one-frame delay which isn't very problematic in this situation. We could remove it by scoring in advance for multiple window (probably not worth bothering) + const ImGuiNavLayer layer = ImGuiNavLayer_Menu; + IM_ASSERT(window->DC.NavLayersActiveMaskNext & (1 << layer)); // Sanity check + FocusWindow(window); + SetNavID(window->NavLastIds[layer], layer, 0, window->NavRectRel[layer]); + g.NavDisableHighlight = true; // Hide highlight for the current frame so we don't see the intermediary selection. + g.NavDisableMouseHover = g.NavMousePosDirty = true; + NavMoveRequestForward(g.NavMoveDir, g.NavMoveClipDir, g.NavMoveFlags); // Repeat + } + } + + IM_MSVC_WARNING_SUPPRESS(6011); // Static Analysis false positive "warning C6011: Dereferencing NULL pointer 'window'" + IM_ASSERT(window->Flags & ImGuiWindowFlags_MenuBar); + IM_ASSERT(window->DC.MenuBarAppending); + PopClipRect(); + PopID(); + window->DC.MenuBarOffset.x = window->DC.CursorPos.x - window->Pos.x; // Save horizontal position so next append can reuse it. This is kinda equivalent to a per-layer CursorPos. + g.GroupStack.back().EmitItem = false; + EndGroup(); // Restore position on layer 0 + window->DC.LayoutType = ImGuiLayoutType_Vertical; + window->DC.NavLayerCurrent = ImGuiNavLayer_Main; + window->DC.MenuBarAppending = false; +} + +// Important: calling order matters! +// FIXME: Somehow overlapping with docking tech. +// FIXME: The "rect-cut" aspect of this could be formalized into a lower-level helper (rect-cut: https://halt.software/dead-simple-layouts) +bool ImGui::BeginViewportSideBar(const char* name, ImGuiViewport* viewport_p, ImGuiDir dir, float axis_size, ImGuiWindowFlags window_flags) +{ + IM_ASSERT(dir != ImGuiDir_None); + + ImGuiWindow* bar_window = FindWindowByName(name); + if (bar_window == NULL || bar_window->BeginCount == 0) + { + // Calculate and set window size/position + ImGuiViewportP* viewport = (ImGuiViewportP*)(void*)(viewport_p ? viewport_p : GetMainViewport()); + ImRect avail_rect = viewport->GetBuildWorkRect(); + ImGuiAxis axis = (dir == ImGuiDir_Up || dir == ImGuiDir_Down) ? ImGuiAxis_Y : ImGuiAxis_X; + ImVec2 pos = avail_rect.Min; + if (dir == ImGuiDir_Right || dir == ImGuiDir_Down) + pos[axis] = avail_rect.Max[axis] - axis_size; + ImVec2 size = avail_rect.GetSize(); + size[axis] = axis_size; + SetNextWindowPos(pos); + SetNextWindowSize(size); + + // Report our size into work area (for next frame) using actual window size + if (dir == ImGuiDir_Up || dir == ImGuiDir_Left) + viewport->BuildWorkOffsetMin[axis] += axis_size; + else if (dir == ImGuiDir_Down || dir == ImGuiDir_Right) + viewport->BuildWorkOffsetMax[axis] -= axis_size; + } + + window_flags |= ImGuiWindowFlags_NoTitleBar | ImGuiWindowFlags_NoResize | ImGuiWindowFlags_NoMove; + PushStyleVar(ImGuiStyleVar_WindowRounding, 0.0f); + PushStyleVar(ImGuiStyleVar_WindowMinSize, ImVec2(0, 0)); // Lift normal size constraint + bool is_open = Begin(name, NULL, window_flags); + PopStyleVar(2); + + return is_open; +} + +bool ImGui::BeginMainMenuBar() +{ + ImGuiContext& g = *GImGui; + ImGuiViewportP* viewport = (ImGuiViewportP*)(void*)GetMainViewport(); + + // For the main menu bar, which cannot be moved, we honor g.Style.DisplaySafeAreaPadding to ensure text can be visible on a TV set. + // FIXME: This could be generalized as an opt-in way to clamp window->DC.CursorStartPos to avoid SafeArea? + // FIXME: Consider removing support for safe area down the line... it's messy. Nowadays consoles have support for TV calibration in OS settings. + g.NextWindowData.MenuBarOffsetMinVal = ImVec2(g.Style.DisplaySafeAreaPadding.x, ImMax(g.Style.DisplaySafeAreaPadding.y - g.Style.FramePadding.y, 0.0f)); + ImGuiWindowFlags window_flags = ImGuiWindowFlags_NoScrollbar | ImGuiWindowFlags_NoSavedSettings | ImGuiWindowFlags_MenuBar; + float height = GetFrameHeight(); + bool is_open = BeginViewportSideBar("##MainMenuBar", viewport, ImGuiDir_Up, height, window_flags); + g.NextWindowData.MenuBarOffsetMinVal = ImVec2(0.0f, 0.0f); + + if (is_open) + BeginMenuBar(); + else + End(); + return is_open; +} + +void ImGui::EndMainMenuBar() +{ + EndMenuBar(); + + // When the user has left the menu layer (typically: closed menus through activation of an item), we restore focus to the previous window + // FIXME: With this strategy we won't be able to restore a NULL focus. + ImGuiContext& g = *GImGui; + if (g.CurrentWindow == g.NavWindow && g.NavLayer == ImGuiNavLayer_Main && !g.NavAnyRequest) + FocusTopMostWindowUnderOne(g.NavWindow, NULL); + + End(); +} + +bool ImGui::BeginMenuEx(const char* label, const char* icon, bool enabled) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + const ImGuiStyle& style = g.Style; + const ImGuiID id = window->GetID(label); + bool menu_is_open = IsPopupOpen(id, ImGuiPopupFlags_None); + + // Sub-menus are ChildWindow so that mouse can be hovering across them (otherwise top-most popup menu would steal focus and not allow hovering on parent menu) + ImGuiWindowFlags flags = ImGuiWindowFlags_ChildMenu | ImGuiWindowFlags_AlwaysAutoResize | ImGuiWindowFlags_NoMove | ImGuiWindowFlags_NoTitleBar | ImGuiWindowFlags_NoSavedSettings | ImGuiWindowFlags_NoNavFocus; + if (window->Flags & (ImGuiWindowFlags_Popup | ImGuiWindowFlags_ChildMenu)) + flags |= ImGuiWindowFlags_ChildWindow; + + // If a menu with same the ID was already submitted, we will append to it, matching the behavior of Begin(). + // We are relying on a O(N) search - so O(N log N) over the frame - which seems like the most efficient for the expected small amount of BeginMenu() calls per frame. + // If somehow this is ever becoming a problem we can switch to use e.g. ImGuiStorage mapping key to last frame used. + if (g.MenusIdSubmittedThisFrame.contains(id)) + { + if (menu_is_open) + menu_is_open = BeginPopupEx(id, flags); // menu_is_open can be 'false' when the popup is completely clipped (e.g. zero size display) + else + g.NextWindowData.ClearFlags(); // we behave like Begin() and need to consume those values + return menu_is_open; + } + + // Tag menu as used. Next time BeginMenu() with same ID is called it will append to existing menu + g.MenusIdSubmittedThisFrame.push_back(id); + + ImVec2 label_size = CalcTextSize(label, NULL, true); + bool pressed; + bool menuset_is_open = !(window->Flags & ImGuiWindowFlags_Popup) && (g.OpenPopupStack.Size > g.BeginPopupStack.Size && g.OpenPopupStack[g.BeginPopupStack.Size].OpenParentId == window->IDStack.back()); + ImGuiWindow* backed_nav_window = g.NavWindow; + if (menuset_is_open) + g.NavWindow = window; // Odd hack to allow hovering across menus of a same menu-set (otherwise we wouldn't be able to hover parent) + + // The reference position stored in popup_pos will be used by Begin() to find a suitable position for the child menu, + // However the final position is going to be different! It is chosen by FindBestWindowPosForPopup(). + // e.g. Menus tend to overlap each other horizontally to amplify relative Z-ordering. + ImVec2 popup_pos, pos = window->DC.CursorPos; + PushID(label); + if (!enabled) + BeginDisabled(); + const ImGuiMenuColumns* offsets = &window->DC.MenuColumns; + if (window->DC.LayoutType == ImGuiLayoutType_Horizontal) + { + // Menu inside an horizontal menu bar + // Selectable extend their highlight by half ItemSpacing in each direction. + // For ChildMenu, the popup position will be overwritten by the call to FindBestWindowPosForPopup() in Begin() + popup_pos = ImVec2(pos.x - 1.0f - IM_FLOOR(style.ItemSpacing.x * 0.5f), pos.y - style.FramePadding.y + window->MenuBarHeight()); + window->DC.CursorPos.x += IM_FLOOR(style.ItemSpacing.x * 0.5f); + PushStyleVar(ImGuiStyleVar_ItemSpacing, ImVec2(style.ItemSpacing.x * 2.0f, style.ItemSpacing.y)); + float w = label_size.x; + ImVec2 text_pos(window->DC.CursorPos.x + offsets->OffsetLabel, window->DC.CursorPos.y + window->DC.CurrLineTextBaseOffset); + pressed = Selectable("", menu_is_open, ImGuiSelectableFlags_NoHoldingActiveID | ImGuiSelectableFlags_SelectOnClick | ImGuiSelectableFlags_DontClosePopups, ImVec2(w, 0.0f)); + RenderText(text_pos, label); + PopStyleVar(); + window->DC.CursorPos.x += IM_FLOOR(style.ItemSpacing.x * (-1.0f + 0.5f)); // -1 spacing to compensate the spacing added when Selectable() did a SameLine(). It would also work to call SameLine() ourselves after the PopStyleVar(). + } + else + { + // Menu inside a regular/vertical menu + // (In a typical menu window where all items are BeginMenu() or MenuItem() calls, extra_w will always be 0.0f. + // Only when they are other items sticking out we're going to add spacing, yet only register minimum width into the layout system. + popup_pos = ImVec2(pos.x, pos.y - style.WindowPadding.y); + float icon_w = (icon && icon[0]) ? CalcTextSize(icon, NULL).x : 0.0f; + float checkmark_w = IM_FLOOR(g.FontSize * 1.20f); + float min_w = window->DC.MenuColumns.DeclColumns(icon_w, label_size.x, 0.0f, checkmark_w); // Feedback to next frame + float extra_w = ImMax(0.0f, GetContentRegionAvail().x - min_w); + ImVec2 text_pos(window->DC.CursorPos.x + offsets->OffsetLabel, window->DC.CursorPos.y + window->DC.CurrLineTextBaseOffset); + pressed = Selectable("", menu_is_open, ImGuiSelectableFlags_NoHoldingActiveID | ImGuiSelectableFlags_SelectOnClick | ImGuiSelectableFlags_DontClosePopups | ImGuiSelectableFlags_SpanAvailWidth, ImVec2(min_w, 0.0f)); + RenderText(text_pos, label); + if (icon_w > 0.0f) + RenderText(pos + ImVec2(offsets->OffsetIcon, 0.0f), icon); + RenderArrow(window->DrawList, pos + ImVec2(offsets->OffsetMark + extra_w + g.FontSize * 0.30f, 0.0f), GetColorU32(ImGuiCol_Text), ImGuiDir_Right); + } + if (!enabled) + EndDisabled(); + + const bool hovered = (g.HoveredId == id) && enabled; + if (menuset_is_open) + g.NavWindow = backed_nav_window; + + bool want_open = false; + bool want_close = false; + if (window->DC.LayoutType == ImGuiLayoutType_Vertical) // (window->Flags & (ImGuiWindowFlags_Popup|ImGuiWindowFlags_ChildMenu)) + { + // Close menu when not hovering it anymore unless we are moving roughly in the direction of the menu + // Implement http://bjk5.com/post/44698559168/breaking-down-amazons-mega-dropdown to avoid using timers, so menus feels more reactive. + bool moving_toward_other_child_menu = false; + ImGuiWindow* child_menu_window = (g.BeginPopupStack.Size < g.OpenPopupStack.Size && g.OpenPopupStack[g.BeginPopupStack.Size].SourceWindow == window) ? g.OpenPopupStack[g.BeginPopupStack.Size].Window : NULL; + if (g.HoveredWindow == window && child_menu_window != NULL && !(window->Flags & ImGuiWindowFlags_MenuBar)) + { + float ref_unit = g.FontSize; // FIXME-DPI + ImRect next_window_rect = child_menu_window->Rect(); + ImVec2 ta = (g.IO.MousePos - g.IO.MouseDelta); + ImVec2 tb = (window->Pos.x < child_menu_window->Pos.x) ? next_window_rect.GetTL() : next_window_rect.GetTR(); + ImVec2 tc = (window->Pos.x < child_menu_window->Pos.x) ? next_window_rect.GetBL() : next_window_rect.GetBR(); + float extra = ImClamp(ImFabs(ta.x - tb.x) * 0.30f, ref_unit * 0.5f, ref_unit * 2.5f); // add a bit of extra slack. + ta.x += (window->Pos.x < child_menu_window->Pos.x) ? -0.5f : +0.5f; // to avoid numerical issues (FIXME: ??) + tb.y = ta.y + ImMax((tb.y - extra) - ta.y, -ref_unit * 8.0f); // triangle is maximum 200 high to limit the slope and the bias toward large sub-menus // FIXME: Multiply by fb_scale? + tc.y = ta.y + ImMin((tc.y + extra) - ta.y, +ref_unit * 8.0f); + moving_toward_other_child_menu = ImTriangleContainsPoint(ta, tb, tc, g.IO.MousePos); + //GetForegroundDrawList()->AddTriangleFilled(ta, tb, tc, moving_toward_other_child_menu ? IM_COL32(0,128,0,128) : IM_COL32(128,0,0,128)); // [DEBUG] + } + if (menu_is_open && !hovered && g.HoveredWindow == window && g.HoveredIdPreviousFrame != 0 && g.HoveredIdPreviousFrame != id && !moving_toward_other_child_menu) + want_close = true; + + // Open + if (!menu_is_open && pressed) // Click/activate to open + want_open = true; + else if (!menu_is_open && hovered && !moving_toward_other_child_menu) // Hover to open + want_open = true; + if (g.NavId == id && g.NavMoveDir == ImGuiDir_Right) // Nav-Right to open + { + want_open = true; + NavMoveRequestCancel(); + } + } + else + { + // Menu bar + if (menu_is_open && pressed && menuset_is_open) // Click an open menu again to close it + { + want_close = true; + want_open = menu_is_open = false; + } + else if (pressed || (hovered && menuset_is_open && !menu_is_open)) // First click to open, then hover to open others + { + want_open = true; + } + else if (g.NavId == id && g.NavMoveDir == ImGuiDir_Down) // Nav-Down to open + { + want_open = true; + NavMoveRequestCancel(); + } + } + + if (!enabled) // explicitly close if an open menu becomes disabled, facilitate users code a lot in pattern such as 'if (BeginMenu("options", has_object)) { ..use object.. }' + want_close = true; + if (want_close && IsPopupOpen(id, ImGuiPopupFlags_None)) + ClosePopupToLevel(g.BeginPopupStack.Size, true); + + IMGUI_TEST_ENGINE_ITEM_INFO(id, label, g.LastItemData.StatusFlags | ImGuiItemStatusFlags_Openable | (menu_is_open ? ImGuiItemStatusFlags_Opened : 0)); + PopID(); + + if (!menu_is_open && want_open && g.OpenPopupStack.Size > g.BeginPopupStack.Size) + { + // Don't recycle same menu level in the same frame, first close the other menu and yield for a frame. + OpenPopup(label); + return false; + } + + menu_is_open |= want_open; + if (want_open) + OpenPopup(label); + + if (menu_is_open) + { + SetNextWindowPos(popup_pos, ImGuiCond_Always); // Note: this is super misleading! The value will serve as reference for FindBestWindowPosForPopup(), not actual pos. + menu_is_open = BeginPopupEx(id, flags); // menu_is_open can be 'false' when the popup is completely clipped (e.g. zero size display) + } + else + { + g.NextWindowData.ClearFlags(); // We behave like Begin() and need to consume those values + } + + return menu_is_open; +} + +bool ImGui::BeginMenu(const char* label, bool enabled) +{ + return BeginMenuEx(label, NULL, enabled); +} + +void ImGui::EndMenu() +{ + // Nav: When a left move request _within our child menu_ failed, close ourselves (the _parent_ menu). + // A menu doesn't close itself because EndMenuBar() wants the catch the last Left<>Right inputs. + // However, it means that with the current code, a BeginMenu() from outside another menu or a menu-bar won't be closable with the Left direction. + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (g.NavMoveDir == ImGuiDir_Left && NavMoveRequestButNoResultYet() && window->DC.LayoutType == ImGuiLayoutType_Vertical) + if (g.NavWindow && (g.NavWindow->RootWindowForNav->Flags & ImGuiWindowFlags_Popup) && g.NavWindow->RootWindowForNav->ParentWindow == window) + { + ClosePopupToLevel(g.BeginPopupStack.Size, true); + NavMoveRequestCancel(); + } + + EndPopup(); +} + +bool ImGui::MenuItemEx(const char* label, const char* icon, const char* shortcut, bool selected, bool enabled) +{ + ImGuiWindow* window = GetCurrentWindow(); + if (window->SkipItems) + return false; + + ImGuiContext& g = *GImGui; + ImGuiStyle& style = g.Style; + ImVec2 pos = window->DC.CursorPos; + ImVec2 label_size = CalcTextSize(label, NULL, true); + + // We've been using the equivalent of ImGuiSelectableFlags_SetNavIdOnHover on all Selectable() since early Nav system days (commit 43ee5d73), + // but I am unsure whether this should be kept at all. For now moved it to be an opt-in feature used by menus only. + bool pressed; + PushID(label); + if (!enabled) + BeginDisabled(); + const ImGuiSelectableFlags flags = ImGuiSelectableFlags_SelectOnRelease | ImGuiSelectableFlags_SetNavIdOnHover; + const ImGuiMenuColumns* offsets = &window->DC.MenuColumns; + if (window->DC.LayoutType == ImGuiLayoutType_Horizontal) + { + // Mimic the exact layout spacing of BeginMenu() to allow MenuItem() inside a menu bar, which is a little misleading but may be useful + // Note that in this situation: we don't render the shortcut, we render a highlight instead of the selected tick mark. + float w = label_size.x; + window->DC.CursorPos.x += IM_FLOOR(style.ItemSpacing.x * 0.5f); + ImVec2 text_pos(window->DC.CursorPos.x + offsets->OffsetLabel, window->DC.CursorPos.y + window->DC.CurrLineTextBaseOffset); + PushStyleVar(ImGuiStyleVar_ItemSpacing, ImVec2(style.ItemSpacing.x * 2.0f, style.ItemSpacing.y)); + pressed = Selectable("", selected, flags, ImVec2(w, 0.0f)); + PopStyleVar(); + RenderText(text_pos, label); + window->DC.CursorPos.x += IM_FLOOR(style.ItemSpacing.x * (-1.0f + 0.5f)); // -1 spacing to compensate the spacing added when Selectable() did a SameLine(). It would also work to call SameLine() ourselves after the PopStyleVar(). + } + else + { + // Menu item inside a vertical menu + // (In a typical menu window where all items are BeginMenu() or MenuItem() calls, extra_w will always be 0.0f. + // Only when they are other items sticking out we're going to add spacing, yet only register minimum width into the layout system. + float icon_w = (icon && icon[0]) ? CalcTextSize(icon, NULL).x : 0.0f; + float shortcut_w = (shortcut && shortcut[0]) ? CalcTextSize(shortcut, NULL).x : 0.0f; + float checkmark_w = IM_FLOOR(g.FontSize * 1.20f); + float min_w = window->DC.MenuColumns.DeclColumns(icon_w, label_size.x, shortcut_w, checkmark_w); // Feedback for next frame + float stretch_w = ImMax(0.0f, GetContentRegionAvail().x - min_w); + pressed = Selectable("", false, flags | ImGuiSelectableFlags_SpanAvailWidth, ImVec2(min_w, 0.0f)); + RenderText(pos + ImVec2(offsets->OffsetLabel, 0.0f), label); + if (icon_w > 0.0f) + RenderText(pos + ImVec2(offsets->OffsetIcon, 0.0f), icon); + if (shortcut_w > 0.0f) + { + PushStyleColor(ImGuiCol_Text, style.Colors[ImGuiCol_TextDisabled]); + RenderText(pos + ImVec2(offsets->OffsetShortcut + stretch_w, 0.0f), shortcut, NULL, false); + PopStyleColor(); + } + if (selected) + RenderCheckMark(window->DrawList, pos + ImVec2(offsets->OffsetMark + stretch_w + g.FontSize * 0.40f, g.FontSize * 0.134f * 0.5f), GetColorU32(ImGuiCol_Text), g.FontSize * 0.866f); + } + IMGUI_TEST_ENGINE_ITEM_INFO(g.LastItemData.ID, label, g.LastItemData.StatusFlags | ImGuiItemStatusFlags_Checkable | (selected ? ImGuiItemStatusFlags_Checked : 0)); + if (!enabled) + EndDisabled(); + PopID(); + + return pressed; +} + +bool ImGui::MenuItem(const char* label, const char* shortcut, bool selected, bool enabled) +{ + return MenuItemEx(label, NULL, shortcut, selected, enabled); +} + +bool ImGui::MenuItem(const char* label, const char* shortcut, bool* p_selected, bool enabled) +{ + if (MenuItemEx(label, NULL, shortcut, p_selected ? *p_selected : false, enabled)) + { + if (p_selected) + *p_selected = !*p_selected; + return true; + } + return false; +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: BeginTabBar, EndTabBar, etc. +//------------------------------------------------------------------------- +// - BeginTabBar() +// - BeginTabBarEx() [Internal] +// - EndTabBar() +// - TabBarLayout() [Internal] +// - TabBarCalcTabID() [Internal] +// - TabBarCalcMaxTabWidth() [Internal] +// - TabBarFindTabById() [Internal] +// - TabBarRemoveTab() [Internal] +// - TabBarCloseTab() [Internal] +// - TabBarScrollClamp() [Internal] +// - TabBarScrollToTab() [Internal] +// - TabBarQueueChangeTabOrder() [Internal] +// - TabBarScrollingButtons() [Internal] +// - TabBarTabListPopupButton() [Internal] +//------------------------------------------------------------------------- + +struct ImGuiTabBarSection +{ + int TabCount; // Number of tabs in this section. + float Width; // Sum of width of tabs in this section (after shrinking down) + float Spacing; // Horizontal spacing at the end of the section. + + ImGuiTabBarSection() { memset(this, 0, sizeof(*this)); } +}; + +namespace ImGui +{ + static void TabBarLayout(ImGuiTabBar* tab_bar); + static ImU32 TabBarCalcTabID(ImGuiTabBar* tab_bar, const char* label); + static float TabBarCalcMaxTabWidth(); + static float TabBarScrollClamp(ImGuiTabBar* tab_bar, float scrolling); + static void TabBarScrollToTab(ImGuiTabBar* tab_bar, ImGuiID tab_id, ImGuiTabBarSection* sections); + static ImGuiTabItem* TabBarScrollingButtons(ImGuiTabBar* tab_bar); + static ImGuiTabItem* TabBarTabListPopupButton(ImGuiTabBar* tab_bar); +} + +ImGuiTabBar::ImGuiTabBar() +{ + memset(this, 0, sizeof(*this)); + CurrFrameVisible = PrevFrameVisible = -1; + LastTabItemIdx = -1; +} + +static inline int TabItemGetSectionIdx(const ImGuiTabItem* tab) +{ + return (tab->Flags & ImGuiTabItemFlags_Leading) ? 0 : (tab->Flags & ImGuiTabItemFlags_Trailing) ? 2 : 1; +} + +static int IMGUI_CDECL TabItemComparerBySection(const void* lhs, const void* rhs) +{ + const ImGuiTabItem* a = (const ImGuiTabItem*)lhs; + const ImGuiTabItem* b = (const ImGuiTabItem*)rhs; + const int a_section = TabItemGetSectionIdx(a); + const int b_section = TabItemGetSectionIdx(b); + if (a_section != b_section) + return a_section - b_section; + return (int)(a->IndexDuringLayout - b->IndexDuringLayout); +} + +static int IMGUI_CDECL TabItemComparerByBeginOrder(const void* lhs, const void* rhs) +{ + const ImGuiTabItem* a = (const ImGuiTabItem*)lhs; + const ImGuiTabItem* b = (const ImGuiTabItem*)rhs; + return (int)(a->BeginOrder - b->BeginOrder); +} + +static ImGuiTabBar* GetTabBarFromTabBarRef(const ImGuiPtrOrIndex& ref) +{ + ImGuiContext& g = *GImGui; + return ref.Ptr ? (ImGuiTabBar*)ref.Ptr : g.TabBars.GetByIndex(ref.Index); +} + +static ImGuiPtrOrIndex GetTabBarRefFromTabBar(ImGuiTabBar* tab_bar) +{ + ImGuiContext& g = *GImGui; + if (g.TabBars.Contains(tab_bar)) + return ImGuiPtrOrIndex(g.TabBars.GetIndex(tab_bar)); + return ImGuiPtrOrIndex(tab_bar); +} + +bool ImGui::BeginTabBar(const char* str_id, ImGuiTabBarFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return false; + + ImGuiID id = window->GetID(str_id); + ImGuiTabBar* tab_bar = g.TabBars.GetOrAddByKey(id); + ImRect tab_bar_bb = ImRect(window->DC.CursorPos.x, window->DC.CursorPos.y, window->WorkRect.Max.x, window->DC.CursorPos.y + g.FontSize + g.Style.FramePadding.y * 2); + tab_bar->ID = id; + return BeginTabBarEx(tab_bar, tab_bar_bb, flags | ImGuiTabBarFlags_IsFocused); +} + +bool ImGui::BeginTabBarEx(ImGuiTabBar* tab_bar, const ImRect& tab_bar_bb, ImGuiTabBarFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return false; + + if ((flags & ImGuiTabBarFlags_DockNode) == 0) + PushOverrideID(tab_bar->ID); + + // Add to stack + g.CurrentTabBarStack.push_back(GetTabBarRefFromTabBar(tab_bar)); + g.CurrentTabBar = tab_bar; + + // Append with multiple BeginTabBar()/EndTabBar() pairs. + tab_bar->BackupCursorPos = window->DC.CursorPos; + if (tab_bar->CurrFrameVisible == g.FrameCount) + { + window->DC.CursorPos = ImVec2(tab_bar->BarRect.Min.x, tab_bar->BarRect.Max.y + tab_bar->ItemSpacingY); + tab_bar->BeginCount++; + return true; + } + + // Ensure correct ordering when toggling ImGuiTabBarFlags_Reorderable flag, or when a new tab was added while being not reorderable + if ((flags & ImGuiTabBarFlags_Reorderable) != (tab_bar->Flags & ImGuiTabBarFlags_Reorderable) || (tab_bar->TabsAddedNew && !(flags & ImGuiTabBarFlags_Reorderable))) + if (tab_bar->Tabs.Size > 1) + ImQsort(tab_bar->Tabs.Data, tab_bar->Tabs.Size, sizeof(ImGuiTabItem), TabItemComparerByBeginOrder); + tab_bar->TabsAddedNew = false; + + // Flags + if ((flags & ImGuiTabBarFlags_FittingPolicyMask_) == 0) + flags |= ImGuiTabBarFlags_FittingPolicyDefault_; + + tab_bar->Flags = flags; + tab_bar->BarRect = tab_bar_bb; + tab_bar->WantLayout = true; // Layout will be done on the first call to ItemTab() + tab_bar->PrevFrameVisible = tab_bar->CurrFrameVisible; + tab_bar->CurrFrameVisible = g.FrameCount; + tab_bar->PrevTabsContentsHeight = tab_bar->CurrTabsContentsHeight; + tab_bar->CurrTabsContentsHeight = 0.0f; + tab_bar->ItemSpacingY = g.Style.ItemSpacing.y; + tab_bar->FramePadding = g.Style.FramePadding; + tab_bar->TabsActiveCount = 0; + tab_bar->BeginCount = 1; + + // Set cursor pos in a way which only be used in the off-chance the user erroneously submits item before BeginTabItem(): items will overlap + window->DC.CursorPos = ImVec2(tab_bar->BarRect.Min.x, tab_bar->BarRect.Max.y + tab_bar->ItemSpacingY); + + // Draw separator + const ImU32 col = GetColorU32((flags & ImGuiTabBarFlags_IsFocused) ? ImGuiCol_TabActive : ImGuiCol_TabUnfocusedActive); + const float y = tab_bar->BarRect.Max.y - 1.0f; + { + const float separator_min_x = tab_bar->BarRect.Min.x - IM_FLOOR(window->WindowPadding.x * 0.5f); + const float separator_max_x = tab_bar->BarRect.Max.x + IM_FLOOR(window->WindowPadding.x * 0.5f); + window->DrawList->AddLine(ImVec2(separator_min_x, y), ImVec2(separator_max_x, y), col, 1.0f); + } + return true; +} + +void ImGui::EndTabBar() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return; + + ImGuiTabBar* tab_bar = g.CurrentTabBar; + if (tab_bar == NULL) + { + IM_ASSERT_USER_ERROR(tab_bar != NULL, "Mismatched BeginTabBar()/EndTabBar()!"); + return; + } + + // Fallback in case no TabItem have been submitted + if (tab_bar->WantLayout) + TabBarLayout(tab_bar); + + // Restore the last visible height if no tab is visible, this reduce vertical flicker/movement when a tabs gets removed without calling SetTabItemClosed(). + const bool tab_bar_appearing = (tab_bar->PrevFrameVisible + 1 < g.FrameCount); + if (tab_bar->VisibleTabWasSubmitted || tab_bar->VisibleTabId == 0 || tab_bar_appearing) + { + tab_bar->CurrTabsContentsHeight = ImMax(window->DC.CursorPos.y - tab_bar->BarRect.Max.y, tab_bar->CurrTabsContentsHeight); + window->DC.CursorPos.y = tab_bar->BarRect.Max.y + tab_bar->CurrTabsContentsHeight; + } + else + { + window->DC.CursorPos.y = tab_bar->BarRect.Max.y + tab_bar->PrevTabsContentsHeight; + } + if (tab_bar->BeginCount > 1) + window->DC.CursorPos = tab_bar->BackupCursorPos; + + if ((tab_bar->Flags & ImGuiTabBarFlags_DockNode) == 0) + PopID(); + + g.CurrentTabBarStack.pop_back(); + g.CurrentTabBar = g.CurrentTabBarStack.empty() ? NULL : GetTabBarFromTabBarRef(g.CurrentTabBarStack.back()); +} + +// This is called only once a frame before by the first call to ItemTab() +// The reason we're not calling it in BeginTabBar() is to leave a chance to the user to call the SetTabItemClosed() functions. +static void ImGui::TabBarLayout(ImGuiTabBar* tab_bar) +{ + ImGuiContext& g = *GImGui; + tab_bar->WantLayout = false; + + // Garbage collect by compacting list + // Detect if we need to sort out tab list (e.g. in rare case where a tab changed section) + int tab_dst_n = 0; + bool need_sort_by_section = false; + ImGuiTabBarSection sections[3]; // Layout sections: Leading, Central, Trailing + for (int tab_src_n = 0; tab_src_n < tab_bar->Tabs.Size; tab_src_n++) + { + ImGuiTabItem* tab = &tab_bar->Tabs[tab_src_n]; + if (tab->LastFrameVisible < tab_bar->PrevFrameVisible || tab->WantClose) + { + // Remove tab + if (tab_bar->VisibleTabId == tab->ID) { tab_bar->VisibleTabId = 0; } + if (tab_bar->SelectedTabId == tab->ID) { tab_bar->SelectedTabId = 0; } + if (tab_bar->NextSelectedTabId == tab->ID) { tab_bar->NextSelectedTabId = 0; } + continue; + } + if (tab_dst_n != tab_src_n) + tab_bar->Tabs[tab_dst_n] = tab_bar->Tabs[tab_src_n]; + + tab = &tab_bar->Tabs[tab_dst_n]; + tab->IndexDuringLayout = (ImS16)tab_dst_n; + + // We will need sorting if tabs have changed section (e.g. moved from one of Leading/Central/Trailing to another) + int curr_tab_section_n = TabItemGetSectionIdx(tab); + if (tab_dst_n > 0) + { + ImGuiTabItem* prev_tab = &tab_bar->Tabs[tab_dst_n - 1]; + int prev_tab_section_n = TabItemGetSectionIdx(prev_tab); + if (curr_tab_section_n == 0 && prev_tab_section_n != 0) + need_sort_by_section = true; + if (prev_tab_section_n == 2 && curr_tab_section_n != 2) + need_sort_by_section = true; + } + + sections[curr_tab_section_n].TabCount++; + tab_dst_n++; + } + if (tab_bar->Tabs.Size != tab_dst_n) + tab_bar->Tabs.resize(tab_dst_n); + + if (need_sort_by_section) + ImQsort(tab_bar->Tabs.Data, tab_bar->Tabs.Size, sizeof(ImGuiTabItem), TabItemComparerBySection); + + // Calculate spacing between sections + sections[0].Spacing = sections[0].TabCount > 0 && (sections[1].TabCount + sections[2].TabCount) > 0 ? g.Style.ItemInnerSpacing.x : 0.0f; + sections[1].Spacing = sections[1].TabCount > 0 && sections[2].TabCount > 0 ? g.Style.ItemInnerSpacing.x : 0.0f; + + // Setup next selected tab + ImGuiID scroll_to_tab_id = 0; + if (tab_bar->NextSelectedTabId) + { + tab_bar->SelectedTabId = tab_bar->NextSelectedTabId; + tab_bar->NextSelectedTabId = 0; + scroll_to_tab_id = tab_bar->SelectedTabId; + } + + // Process order change request (we could probably process it when requested but it's just saner to do it in a single spot). + if (tab_bar->ReorderRequestTabId != 0) + { + if (TabBarProcessReorder(tab_bar)) + if (tab_bar->ReorderRequestTabId == tab_bar->SelectedTabId) + scroll_to_tab_id = tab_bar->ReorderRequestTabId; + tab_bar->ReorderRequestTabId = 0; + } + + // Tab List Popup (will alter tab_bar->BarRect and therefore the available width!) + const bool tab_list_popup_button = (tab_bar->Flags & ImGuiTabBarFlags_TabListPopupButton) != 0; + if (tab_list_popup_button) + if (ImGuiTabItem* tab_to_select = TabBarTabListPopupButton(tab_bar)) // NB: Will alter BarRect.Min.x! + scroll_to_tab_id = tab_bar->SelectedTabId = tab_to_select->ID; + + // Leading/Trailing tabs will be shrink only if central one aren't visible anymore, so layout the shrink data as: leading, trailing, central + // (whereas our tabs are stored as: leading, central, trailing) + int shrink_buffer_indexes[3] = { 0, sections[0].TabCount + sections[2].TabCount, sections[0].TabCount }; + g.ShrinkWidthBuffer.resize(tab_bar->Tabs.Size); + + // Compute ideal tabs widths + store them into shrink buffer + ImGuiTabItem* most_recently_selected_tab = NULL; + int curr_section_n = -1; + bool found_selected_tab_id = false; + for (int tab_n = 0; tab_n < tab_bar->Tabs.Size; tab_n++) + { + ImGuiTabItem* tab = &tab_bar->Tabs[tab_n]; + IM_ASSERT(tab->LastFrameVisible >= tab_bar->PrevFrameVisible); + + if ((most_recently_selected_tab == NULL || most_recently_selected_tab->LastFrameSelected < tab->LastFrameSelected) && !(tab->Flags & ImGuiTabItemFlags_Button)) + most_recently_selected_tab = tab; + if (tab->ID == tab_bar->SelectedTabId) + found_selected_tab_id = true; + if (scroll_to_tab_id == 0 && g.NavJustMovedToId == tab->ID) + scroll_to_tab_id = tab->ID; + + // Refresh tab width immediately, otherwise changes of style e.g. style.FramePadding.x would noticeably lag in the tab bar. + // Additionally, when using TabBarAddTab() to manipulate tab bar order we occasionally insert new tabs that don't have a width yet, + // and we cannot wait for the next BeginTabItem() call. We cannot compute this width within TabBarAddTab() because font size depends on the active window. + const char* tab_name = tab_bar->GetTabName(tab); + const bool has_close_button = (tab->Flags & ImGuiTabItemFlags_NoCloseButton) ? false : true; + tab->ContentWidth = TabItemCalcSize(tab_name, has_close_button).x; + + int section_n = TabItemGetSectionIdx(tab); + ImGuiTabBarSection* section = §ions[section_n]; + section->Width += tab->ContentWidth + (section_n == curr_section_n ? g.Style.ItemInnerSpacing.x : 0.0f); + curr_section_n = section_n; + + // Store data so we can build an array sorted by width if we need to shrink tabs down + IM_MSVC_WARNING_SUPPRESS(6385); + int shrink_buffer_index = shrink_buffer_indexes[section_n]++; + g.ShrinkWidthBuffer[shrink_buffer_index].Index = tab_n; + g.ShrinkWidthBuffer[shrink_buffer_index].Width = tab->ContentWidth; + + IM_ASSERT(tab->ContentWidth > 0.0f); + tab->Width = tab->ContentWidth; + } + + // Compute total ideal width (used for e.g. auto-resizing a window) + tab_bar->WidthAllTabsIdeal = 0.0f; + for (int section_n = 0; section_n < 3; section_n++) + tab_bar->WidthAllTabsIdeal += sections[section_n].Width + sections[section_n].Spacing; + + // Horizontal scrolling buttons + // (note that TabBarScrollButtons() will alter BarRect.Max.x) + if ((tab_bar->WidthAllTabsIdeal > tab_bar->BarRect.GetWidth() && tab_bar->Tabs.Size > 1) && !(tab_bar->Flags & ImGuiTabBarFlags_NoTabListScrollingButtons) && (tab_bar->Flags & ImGuiTabBarFlags_FittingPolicyScroll)) + if (ImGuiTabItem* scroll_and_select_tab = TabBarScrollingButtons(tab_bar)) + { + scroll_to_tab_id = scroll_and_select_tab->ID; + if ((scroll_and_select_tab->Flags & ImGuiTabItemFlags_Button) == 0) + tab_bar->SelectedTabId = scroll_to_tab_id; + } + + // Shrink widths if full tabs don't fit in their allocated space + float section_0_w = sections[0].Width + sections[0].Spacing; + float section_1_w = sections[1].Width + sections[1].Spacing; + float section_2_w = sections[2].Width + sections[2].Spacing; + bool central_section_is_visible = (section_0_w + section_2_w) < tab_bar->BarRect.GetWidth(); + float width_excess; + if (central_section_is_visible) + width_excess = ImMax(section_1_w - (tab_bar->BarRect.GetWidth() - section_0_w - section_2_w), 0.0f); // Excess used to shrink central section + else + width_excess = (section_0_w + section_2_w) - tab_bar->BarRect.GetWidth(); // Excess used to shrink leading/trailing section + + // With ImGuiTabBarFlags_FittingPolicyScroll policy, we will only shrink leading/trailing if the central section is not visible anymore + if (width_excess > 0.0f && ((tab_bar->Flags & ImGuiTabBarFlags_FittingPolicyResizeDown) || !central_section_is_visible)) + { + int shrink_data_count = (central_section_is_visible ? sections[1].TabCount : sections[0].TabCount + sections[2].TabCount); + int shrink_data_offset = (central_section_is_visible ? sections[0].TabCount + sections[2].TabCount : 0); + ShrinkWidths(g.ShrinkWidthBuffer.Data + shrink_data_offset, shrink_data_count, width_excess); + + // Apply shrunk values into tabs and sections + for (int tab_n = shrink_data_offset; tab_n < shrink_data_offset + shrink_data_count; tab_n++) + { + ImGuiTabItem* tab = &tab_bar->Tabs[g.ShrinkWidthBuffer[tab_n].Index]; + float shrinked_width = IM_FLOOR(g.ShrinkWidthBuffer[tab_n].Width); + if (shrinked_width < 0.0f) + continue; + + int section_n = TabItemGetSectionIdx(tab); + sections[section_n].Width -= (tab->Width - shrinked_width); + tab->Width = shrinked_width; + } + } + + // Layout all active tabs + int section_tab_index = 0; + float tab_offset = 0.0f; + tab_bar->WidthAllTabs = 0.0f; + for (int section_n = 0; section_n < 3; section_n++) + { + ImGuiTabBarSection* section = §ions[section_n]; + if (section_n == 2) + tab_offset = ImMin(ImMax(0.0f, tab_bar->BarRect.GetWidth() - section->Width), tab_offset); + + for (int tab_n = 0; tab_n < section->TabCount; tab_n++) + { + ImGuiTabItem* tab = &tab_bar->Tabs[section_tab_index + tab_n]; + tab->Offset = tab_offset; + tab_offset += tab->Width + (tab_n < section->TabCount - 1 ? g.Style.ItemInnerSpacing.x : 0.0f); + } + tab_bar->WidthAllTabs += ImMax(section->Width + section->Spacing, 0.0f); + tab_offset += section->Spacing; + section_tab_index += section->TabCount; + } + + // If we have lost the selected tab, select the next most recently active one + if (found_selected_tab_id == false) + tab_bar->SelectedTabId = 0; + if (tab_bar->SelectedTabId == 0 && tab_bar->NextSelectedTabId == 0 && most_recently_selected_tab != NULL) + scroll_to_tab_id = tab_bar->SelectedTabId = most_recently_selected_tab->ID; + + // Lock in visible tab + tab_bar->VisibleTabId = tab_bar->SelectedTabId; + tab_bar->VisibleTabWasSubmitted = false; + + // Update scrolling + if (scroll_to_tab_id != 0) + TabBarScrollToTab(tab_bar, scroll_to_tab_id, sections); + tab_bar->ScrollingAnim = TabBarScrollClamp(tab_bar, tab_bar->ScrollingAnim); + tab_bar->ScrollingTarget = TabBarScrollClamp(tab_bar, tab_bar->ScrollingTarget); + if (tab_bar->ScrollingAnim != tab_bar->ScrollingTarget) + { + // Scrolling speed adjust itself so we can always reach our target in 1/3 seconds. + // Teleport if we are aiming far off the visible line + tab_bar->ScrollingSpeed = ImMax(tab_bar->ScrollingSpeed, 70.0f * g.FontSize); + tab_bar->ScrollingSpeed = ImMax(tab_bar->ScrollingSpeed, ImFabs(tab_bar->ScrollingTarget - tab_bar->ScrollingAnim) / 0.3f); + const bool teleport = (tab_bar->PrevFrameVisible + 1 < g.FrameCount) || (tab_bar->ScrollingTargetDistToVisibility > 10.0f * g.FontSize); + tab_bar->ScrollingAnim = teleport ? tab_bar->ScrollingTarget : ImLinearSweep(tab_bar->ScrollingAnim, tab_bar->ScrollingTarget, g.IO.DeltaTime * tab_bar->ScrollingSpeed); + } + else + { + tab_bar->ScrollingSpeed = 0.0f; + } + tab_bar->ScrollingRectMinX = tab_bar->BarRect.Min.x + sections[0].Width + sections[0].Spacing; + tab_bar->ScrollingRectMaxX = tab_bar->BarRect.Max.x - sections[2].Width - sections[1].Spacing; + + // Clear name buffers + if ((tab_bar->Flags & ImGuiTabBarFlags_DockNode) == 0) + tab_bar->TabsNames.Buf.resize(0); + + // Actual layout in host window (we don't do it in BeginTabBar() so as not to waste an extra frame) + ImGuiWindow* window = g.CurrentWindow; + window->DC.CursorPos = tab_bar->BarRect.Min; + ItemSize(ImVec2(tab_bar->WidthAllTabs, tab_bar->BarRect.GetHeight()), tab_bar->FramePadding.y); + window->DC.IdealMaxPos.x = ImMax(window->DC.IdealMaxPos.x, tab_bar->BarRect.Min.x + tab_bar->WidthAllTabsIdeal); +} + +// Dockables uses Name/ID in the global namespace. Non-dockable items use the ID stack. +static ImU32 ImGui::TabBarCalcTabID(ImGuiTabBar* tab_bar, const char* label) +{ + if (tab_bar->Flags & ImGuiTabBarFlags_DockNode) + { + ImGuiID id = ImHashStr(label); + KeepAliveID(id); + return id; + } + else + { + ImGuiWindow* window = GImGui->CurrentWindow; + return window->GetID(label); + } +} + +static float ImGui::TabBarCalcMaxTabWidth() +{ + ImGuiContext& g = *GImGui; + return g.FontSize * 20.0f; +} + +ImGuiTabItem* ImGui::TabBarFindTabByID(ImGuiTabBar* tab_bar, ImGuiID tab_id) +{ + if (tab_id != 0) + for (int n = 0; n < tab_bar->Tabs.Size; n++) + if (tab_bar->Tabs[n].ID == tab_id) + return &tab_bar->Tabs[n]; + return NULL; +} + +// The *TabId fields be already set by the docking system _before_ the actual TabItem was created, so we clear them regardless. +void ImGui::TabBarRemoveTab(ImGuiTabBar* tab_bar, ImGuiID tab_id) +{ + if (ImGuiTabItem* tab = TabBarFindTabByID(tab_bar, tab_id)) + tab_bar->Tabs.erase(tab); + if (tab_bar->VisibleTabId == tab_id) { tab_bar->VisibleTabId = 0; } + if (tab_bar->SelectedTabId == tab_id) { tab_bar->SelectedTabId = 0; } + if (tab_bar->NextSelectedTabId == tab_id) { tab_bar->NextSelectedTabId = 0; } +} + +// Called on manual closure attempt +void ImGui::TabBarCloseTab(ImGuiTabBar* tab_bar, ImGuiTabItem* tab) +{ + IM_ASSERT(!(tab->Flags & ImGuiTabItemFlags_Button)); + if (!(tab->Flags & ImGuiTabItemFlags_UnsavedDocument)) + { + // This will remove a frame of lag for selecting another tab on closure. + // However we don't run it in the case where the 'Unsaved' flag is set, so user gets a chance to fully undo the closure + tab->WantClose = true; + if (tab_bar->VisibleTabId == tab->ID) + { + tab->LastFrameVisible = -1; + tab_bar->SelectedTabId = tab_bar->NextSelectedTabId = 0; + } + } + else + { + // Actually select before expecting closure attempt (on an UnsavedDocument tab user is expect to e.g. show a popup) + if (tab_bar->VisibleTabId != tab->ID) + tab_bar->NextSelectedTabId = tab->ID; + } +} + +static float ImGui::TabBarScrollClamp(ImGuiTabBar* tab_bar, float scrolling) +{ + scrolling = ImMin(scrolling, tab_bar->WidthAllTabs - tab_bar->BarRect.GetWidth()); + return ImMax(scrolling, 0.0f); +} + +// Note: we may scroll to tab that are not selected! e.g. using keyboard arrow keys +static void ImGui::TabBarScrollToTab(ImGuiTabBar* tab_bar, ImGuiID tab_id, ImGuiTabBarSection* sections) +{ + ImGuiTabItem* tab = TabBarFindTabByID(tab_bar, tab_id); + if (tab == NULL) + return; + if (tab->Flags & ImGuiTabItemFlags_SectionMask_) + return; + + ImGuiContext& g = *GImGui; + float margin = g.FontSize * 1.0f; // When to scroll to make Tab N+1 visible always make a bit of N visible to suggest more scrolling area (since we don't have a scrollbar) + int order = tab_bar->GetTabOrder(tab); + + // Scrolling happens only in the central section (leading/trailing sections are not scrolling) + // FIXME: This is all confusing. + float scrollable_width = tab_bar->BarRect.GetWidth() - sections[0].Width - sections[2].Width - sections[1].Spacing; + + // We make all tabs positions all relative Sections[0].Width to make code simpler + float tab_x1 = tab->Offset - sections[0].Width + (order > sections[0].TabCount - 1 ? -margin : 0.0f); + float tab_x2 = tab->Offset - sections[0].Width + tab->Width + (order + 1 < tab_bar->Tabs.Size - sections[2].TabCount ? margin : 1.0f); + tab_bar->ScrollingTargetDistToVisibility = 0.0f; + if (tab_bar->ScrollingTarget > tab_x1 || (tab_x2 - tab_x1 >= scrollable_width)) + { + // Scroll to the left + tab_bar->ScrollingTargetDistToVisibility = ImMax(tab_bar->ScrollingAnim - tab_x2, 0.0f); + tab_bar->ScrollingTarget = tab_x1; + } + else if (tab_bar->ScrollingTarget < tab_x2 - scrollable_width) + { + // Scroll to the right + tab_bar->ScrollingTargetDistToVisibility = ImMax((tab_x1 - scrollable_width) - tab_bar->ScrollingAnim, 0.0f); + tab_bar->ScrollingTarget = tab_x2 - scrollable_width; + } +} + +void ImGui::TabBarQueueReorder(ImGuiTabBar* tab_bar, const ImGuiTabItem* tab, int offset) +{ + IM_ASSERT(offset != 0); + IM_ASSERT(tab_bar->ReorderRequestTabId == 0); + tab_bar->ReorderRequestTabId = tab->ID; + tab_bar->ReorderRequestOffset = (ImS16)offset; +} + +void ImGui::TabBarQueueReorderFromMousePos(ImGuiTabBar* tab_bar, const ImGuiTabItem* src_tab, ImVec2 mouse_pos) +{ + ImGuiContext& g = *GImGui; + IM_ASSERT(tab_bar->ReorderRequestTabId == 0); + if ((tab_bar->Flags & ImGuiTabBarFlags_Reorderable) == 0) + return; + + const bool is_central_section = (src_tab->Flags & ImGuiTabItemFlags_SectionMask_) == 0; + const float bar_offset = tab_bar->BarRect.Min.x - (is_central_section ? tab_bar->ScrollingTarget : 0); + + // Count number of contiguous tabs we are crossing over + const int dir = (bar_offset + src_tab->Offset) > mouse_pos.x ? -1 : +1; + const int src_idx = tab_bar->Tabs.index_from_ptr(src_tab); + int dst_idx = src_idx; + for (int i = src_idx; i >= 0 && i < tab_bar->Tabs.Size; i += dir) + { + // Reordered tabs must share the same section + const ImGuiTabItem* dst_tab = &tab_bar->Tabs[i]; + if (dst_tab->Flags & ImGuiTabItemFlags_NoReorder) + break; + if ((dst_tab->Flags & ImGuiTabItemFlags_SectionMask_) != (src_tab->Flags & ImGuiTabItemFlags_SectionMask_)) + break; + dst_idx = i; + + // Include spacing after tab, so when mouse cursor is between tabs we would not continue checking further tabs that are not hovered. + const float x1 = bar_offset + dst_tab->Offset - g.Style.ItemInnerSpacing.x; + const float x2 = bar_offset + dst_tab->Offset + dst_tab->Width + g.Style.ItemInnerSpacing.x; + //GetForegroundDrawList()->AddRect(ImVec2(x1, tab_bar->BarRect.Min.y), ImVec2(x2, tab_bar->BarRect.Max.y), IM_COL32(255, 0, 0, 255)); + if ((dir < 0 && mouse_pos.x > x1) || (dir > 0 && mouse_pos.x < x2)) + break; + } + + if (dst_idx != src_idx) + TabBarQueueReorder(tab_bar, src_tab, dst_idx - src_idx); +} + +bool ImGui::TabBarProcessReorder(ImGuiTabBar* tab_bar) +{ + ImGuiTabItem* tab1 = TabBarFindTabByID(tab_bar, tab_bar->ReorderRequestTabId); + if (tab1 == NULL || (tab1->Flags & ImGuiTabItemFlags_NoReorder)) + return false; + + //IM_ASSERT(tab_bar->Flags & ImGuiTabBarFlags_Reorderable); // <- this may happen when using debug tools + int tab2_order = tab_bar->GetTabOrder(tab1) + tab_bar->ReorderRequestOffset; + if (tab2_order < 0 || tab2_order >= tab_bar->Tabs.Size) + return false; + + // Reordered tabs must share the same section + // (Note: TabBarQueueReorderFromMousePos() also has a similar test but since we allow direct calls to TabBarQueueReorder() we do it here too) + ImGuiTabItem* tab2 = &tab_bar->Tabs[tab2_order]; + if (tab2->Flags & ImGuiTabItemFlags_NoReorder) + return false; + if ((tab1->Flags & ImGuiTabItemFlags_SectionMask_) != (tab2->Flags & ImGuiTabItemFlags_SectionMask_)) + return false; + + ImGuiTabItem item_tmp = *tab1; + ImGuiTabItem* src_tab = (tab_bar->ReorderRequestOffset > 0) ? tab1 + 1 : tab2; + ImGuiTabItem* dst_tab = (tab_bar->ReorderRequestOffset > 0) ? tab1 : tab2 + 1; + const int move_count = (tab_bar->ReorderRequestOffset > 0) ? tab_bar->ReorderRequestOffset : -tab_bar->ReorderRequestOffset; + memmove(dst_tab, src_tab, move_count * sizeof(ImGuiTabItem)); + *tab2 = item_tmp; + + if (tab_bar->Flags & ImGuiTabBarFlags_SaveSettings) + MarkIniSettingsDirty(); + return true; +} + +static ImGuiTabItem* ImGui::TabBarScrollingButtons(ImGuiTabBar* tab_bar) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + const ImVec2 arrow_button_size(g.FontSize - 2.0f, g.FontSize + g.Style.FramePadding.y * 2.0f); + const float scrolling_buttons_width = arrow_button_size.x * 2.0f; + + const ImVec2 backup_cursor_pos = window->DC.CursorPos; + //window->DrawList->AddRect(ImVec2(tab_bar->BarRect.Max.x - scrolling_buttons_width, tab_bar->BarRect.Min.y), ImVec2(tab_bar->BarRect.Max.x, tab_bar->BarRect.Max.y), IM_COL32(255,0,0,255)); + + int select_dir = 0; + ImVec4 arrow_col = g.Style.Colors[ImGuiCol_Text]; + arrow_col.w *= 0.5f; + + PushStyleColor(ImGuiCol_Text, arrow_col); + PushStyleColor(ImGuiCol_Button, ImVec4(0, 0, 0, 0)); + const float backup_repeat_delay = g.IO.KeyRepeatDelay; + const float backup_repeat_rate = g.IO.KeyRepeatRate; + g.IO.KeyRepeatDelay = 0.250f; + g.IO.KeyRepeatRate = 0.200f; + float x = ImMax(tab_bar->BarRect.Min.x, tab_bar->BarRect.Max.x - scrolling_buttons_width); + window->DC.CursorPos = ImVec2(x, tab_bar->BarRect.Min.y); + if (ArrowButtonEx("##<", ImGuiDir_Left, arrow_button_size, ImGuiButtonFlags_PressedOnClick | ImGuiButtonFlags_Repeat)) + select_dir = -1; + window->DC.CursorPos = ImVec2(x + arrow_button_size.x, tab_bar->BarRect.Min.y); + if (ArrowButtonEx("##>", ImGuiDir_Right, arrow_button_size, ImGuiButtonFlags_PressedOnClick | ImGuiButtonFlags_Repeat)) + select_dir = +1; + PopStyleColor(2); + g.IO.KeyRepeatRate = backup_repeat_rate; + g.IO.KeyRepeatDelay = backup_repeat_delay; + + ImGuiTabItem* tab_to_scroll_to = NULL; + if (select_dir != 0) + if (ImGuiTabItem* tab_item = TabBarFindTabByID(tab_bar, tab_bar->SelectedTabId)) + { + int selected_order = tab_bar->GetTabOrder(tab_item); + int target_order = selected_order + select_dir; + + // Skip tab item buttons until another tab item is found or end is reached + while (tab_to_scroll_to == NULL) + { + // If we are at the end of the list, still scroll to make our tab visible + tab_to_scroll_to = &tab_bar->Tabs[(target_order >= 0 && target_order < tab_bar->Tabs.Size) ? target_order : selected_order]; + + // Cross through buttons + // (even if first/last item is a button, return it so we can update the scroll) + if (tab_to_scroll_to->Flags & ImGuiTabItemFlags_Button) + { + target_order += select_dir; + selected_order += select_dir; + tab_to_scroll_to = (target_order < 0 || target_order >= tab_bar->Tabs.Size) ? tab_to_scroll_to : NULL; + } + } + } + window->DC.CursorPos = backup_cursor_pos; + tab_bar->BarRect.Max.x -= scrolling_buttons_width + 1.0f; + + return tab_to_scroll_to; +} + +static ImGuiTabItem* ImGui::TabBarTabListPopupButton(ImGuiTabBar* tab_bar) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + + // We use g.Style.FramePadding.y to match the square ArrowButton size + const float tab_list_popup_button_width = g.FontSize + g.Style.FramePadding.y; + const ImVec2 backup_cursor_pos = window->DC.CursorPos; + window->DC.CursorPos = ImVec2(tab_bar->BarRect.Min.x - g.Style.FramePadding.y, tab_bar->BarRect.Min.y); + tab_bar->BarRect.Min.x += tab_list_popup_button_width; + + ImVec4 arrow_col = g.Style.Colors[ImGuiCol_Text]; + arrow_col.w *= 0.5f; + PushStyleColor(ImGuiCol_Text, arrow_col); + PushStyleColor(ImGuiCol_Button, ImVec4(0, 0, 0, 0)); + bool open = BeginCombo("##v", NULL, ImGuiComboFlags_NoPreview | ImGuiComboFlags_HeightLargest); + PopStyleColor(2); + + ImGuiTabItem* tab_to_select = NULL; + if (open) + { + for (int tab_n = 0; tab_n < tab_bar->Tabs.Size; tab_n++) + { + ImGuiTabItem* tab = &tab_bar->Tabs[tab_n]; + if (tab->Flags & ImGuiTabItemFlags_Button) + continue; + + const char* tab_name = tab_bar->GetTabName(tab); + if (Selectable(tab_name, tab_bar->SelectedTabId == tab->ID)) + tab_to_select = tab; + } + EndCombo(); + } + + window->DC.CursorPos = backup_cursor_pos; + return tab_to_select; +} + +//------------------------------------------------------------------------- +// [SECTION] Widgets: BeginTabItem, EndTabItem, etc. +//------------------------------------------------------------------------- +// - BeginTabItem() +// - EndTabItem() +// - TabItemButton() +// - TabItemEx() [Internal] +// - SetTabItemClosed() +// - TabItemCalcSize() [Internal] +// - TabItemBackground() [Internal] +// - TabItemLabelAndCloseButton() [Internal] +//------------------------------------------------------------------------- + +bool ImGui::BeginTabItem(const char* label, bool* p_open, ImGuiTabItemFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return false; + + ImGuiTabBar* tab_bar = g.CurrentTabBar; + if (tab_bar == NULL) + { + IM_ASSERT_USER_ERROR(tab_bar, "Needs to be called between BeginTabBar() and EndTabBar()!"); + return false; + } + IM_ASSERT(!(flags & ImGuiTabItemFlags_Button)); // BeginTabItem() Can't be used with button flags, use TabItemButton() instead! + + bool ret = TabItemEx(tab_bar, label, p_open, flags); + if (ret && !(flags & ImGuiTabItemFlags_NoPushId)) + { + ImGuiTabItem* tab = &tab_bar->Tabs[tab_bar->LastTabItemIdx]; + PushOverrideID(tab->ID); // We already hashed 'label' so push into the ID stack directly instead of doing another hash through PushID(label) + } + return ret; +} + +void ImGui::EndTabItem() +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return; + + ImGuiTabBar* tab_bar = g.CurrentTabBar; + if (tab_bar == NULL) + { + IM_ASSERT_USER_ERROR(tab_bar != NULL, "Needs to be called between BeginTabBar() and EndTabBar()!"); + return; + } + IM_ASSERT(tab_bar->LastTabItemIdx >= 0); + ImGuiTabItem* tab = &tab_bar->Tabs[tab_bar->LastTabItemIdx]; + if (!(tab->Flags & ImGuiTabItemFlags_NoPushId)) + PopID(); +} + +bool ImGui::TabItemButton(const char* label, ImGuiTabItemFlags flags) +{ + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return false; + + ImGuiTabBar* tab_bar = g.CurrentTabBar; + if (tab_bar == NULL) + { + IM_ASSERT_USER_ERROR(tab_bar != NULL, "Needs to be called between BeginTabBar() and EndTabBar()!"); + return false; + } + return TabItemEx(tab_bar, label, NULL, flags | ImGuiTabItemFlags_Button | ImGuiTabItemFlags_NoReorder); +} + +bool ImGui::TabItemEx(ImGuiTabBar* tab_bar, const char* label, bool* p_open, ImGuiTabItemFlags flags) +{ + // Layout whole tab bar if not already done + if (tab_bar->WantLayout) + TabBarLayout(tab_bar); + + ImGuiContext& g = *GImGui; + ImGuiWindow* window = g.CurrentWindow; + if (window->SkipItems) + return false; + + const ImGuiStyle& style = g.Style; + const ImGuiID id = TabBarCalcTabID(tab_bar, label); + + // If the user called us with *p_open == false, we early out and don't render. + // We make a call to ItemAdd() so that attempts to use a contextual popup menu with an implicit ID won't use an older ID. + IMGUI_TEST_ENGINE_ITEM_INFO(id, label, g.LastItemData.StatusFlags); + if (p_open && !*p_open) + { + PushItemFlag(ImGuiItemFlags_NoNav | ImGuiItemFlags_NoNavDefaultFocus, true); + ItemAdd(ImRect(), id); + PopItemFlag(); + return false; + } + + IM_ASSERT(!p_open || !(flags & ImGuiTabItemFlags_Button)); + IM_ASSERT((flags & (ImGuiTabItemFlags_Leading | ImGuiTabItemFlags_Trailing)) != (ImGuiTabItemFlags_Leading | ImGuiTabItemFlags_Trailing)); // Can't use both Leading and Trailing + + // Store into ImGuiTabItemFlags_NoCloseButton, also honor ImGuiTabItemFlags_NoCloseButton passed by user (although not documented) + if (flags & ImGuiTabItemFlags_NoCloseButton) + p_open = NULL; + else if (p_open == NULL) + flags |= ImGuiTabItemFlags_NoCloseButton; + + // Calculate tab contents size + ImVec2 size = TabItemCalcSize(label, p_open != NULL); + + // Acquire tab data + ImGuiTabItem* tab = TabBarFindTabByID(tab_bar, id); + bool tab_is_new = false; + if (tab == NULL) + { + tab_bar->Tabs.push_back(ImGuiTabItem()); + tab = &tab_bar->Tabs.back(); + tab->ID = id; + tab->Width = size.x; + tab_bar->TabsAddedNew = true; + tab_is_new = true; + } + tab_bar->LastTabItemIdx = (ImS16)tab_bar->Tabs.index_from_ptr(tab); + tab->ContentWidth = size.x; + tab->BeginOrder = tab_bar->TabsActiveCount++; + + const bool tab_bar_appearing = (tab_bar->PrevFrameVisible + 1 < g.FrameCount); + const bool tab_bar_focused = (tab_bar->Flags & ImGuiTabBarFlags_IsFocused) != 0; + const bool tab_appearing = (tab->LastFrameVisible + 1 < g.FrameCount); + const bool is_tab_button = (flags & ImGuiTabItemFlags_Button) != 0; + tab->LastFrameVisible = g.FrameCount; + tab->Flags = flags; + + // Append name with zero-terminator + tab->NameOffset = (ImS32)tab_bar->TabsNames.size(); + tab_bar->TabsNames.append(label, label + strlen(label) + 1); + + // Update selected tab + if (tab_appearing && (tab_bar->Flags & ImGuiTabBarFlags_AutoSelectNewTabs) && tab_bar->NextSelectedTabId == 0) + if (!tab_bar_appearing || tab_bar->SelectedTabId == 0) + if (!is_tab_button) + tab_bar->NextSelectedTabId = id; // New tabs gets activated + if ((flags & ImGuiTabItemFlags_SetSelected) && (tab_bar->SelectedTabId != id)) // SetSelected can only be passed on explicit tab bar + if (!is_tab_button) + tab_bar->NextSelectedTabId = id; + + // Lock visibility + // (Note: tab_contents_visible != tab_selected... because CTRL+TAB operations may preview some tabs without selecting them!) + bool tab_contents_visible = (tab_bar->VisibleTabId == id); + if (tab_contents_visible) + tab_bar->VisibleTabWasSubmitted = true; + + // On the very first frame of a tab bar we let first tab contents be visible to minimize appearing glitches + if (!tab_contents_visible && tab_bar->SelectedTabId == 0 && tab_bar_appearing) + if (tab_bar->Tabs.Size == 1 && !(tab_bar->Flags & ImGuiTabBarFlags_AutoSelectNewTabs)) + tab_contents_visible = true; + + // Note that tab_is_new is not necessarily the same as tab_appearing! When a tab bar stops being submitted + // and then gets submitted again, the tabs will have 'tab_appearing=true' but 'tab_is_new=false'. + if (tab_appearing && (!tab_bar_appearing || tab_is_new)) + { + PushItemFlag(ImGuiItemFlags_NoNav | ImGuiItemFlags_NoNavDefaultFocus, true); + ItemAdd(ImRect(), id); + PopItemFlag(); + if (is_tab_button) + return false; + return tab_contents_visible; + } + + if (tab_bar->SelectedTabId == id) + tab->LastFrameSelected = g.FrameCount; + + // Backup current layout position + const ImVec2 backup_main_cursor_pos = window->DC.CursorPos; + + // Layout + const bool is_central_section = (tab->Flags & ImGuiTabItemFlags_SectionMask_) == 0; + size.x = tab->Width; + if (is_central_section) + window->DC.CursorPos = tab_bar->BarRect.Min + ImVec2(IM_FLOOR(tab->Offset - tab_bar->ScrollingAnim), 0.0f); + else + window->DC.CursorPos = tab_bar->BarRect.Min + ImVec2(tab->Offset, 0.0f); + ImVec2 pos = window->DC.CursorPos; + ImRect bb(pos, pos + size); + + // We don't have CPU clipping primitives to clip the CloseButton (until it becomes a texture), so need to add an extra draw call (temporary in the case of vertical animation) + const bool want_clip_rect = is_central_section && (bb.Min.x < tab_bar->ScrollingRectMinX || bb.Max.x > tab_bar->ScrollingRectMaxX); + if (want_clip_rect) + PushClipRect(ImVec2(ImMax(bb.Min.x, tab_bar->ScrollingRectMinX), bb.Min.y - 1), ImVec2(tab_bar->ScrollingRectMaxX, bb.Max.y), true); + + ImVec2 backup_cursor_max_pos = window->DC.CursorMaxPos; + ItemSize(bb.GetSize(), style.FramePadding.y); + window->DC.CursorMaxPos = backup_cursor_max_pos; + + if (!ItemAdd(bb, id)) + { + if (want_clip_rect) + PopClipRect(); + window->DC.CursorPos = backup_main_cursor_pos; + return tab_contents_visible; + } + + // Click to Select a tab + ImGuiButtonFlags button_flags = ((is_tab_button ? ImGuiButtonFlags_PressedOnClickRelease : ImGuiButtonFlags_PressedOnClick) | ImGuiButtonFlags_AllowItemOverlap); + if (g.DragDropActive) + button_flags |= ImGuiButtonFlags_PressedOnDragDropHold; + bool hovered, held; + bool pressed = ButtonBehavior(bb, id, &hovered, &held, button_flags); + if (pressed && !is_tab_button) + tab_bar->NextSelectedTabId = id; + + // Allow the close button to overlap unless we are dragging (in which case we don't want any overlapping tabs to be hovered) + if (g.ActiveId != id) + SetItemAllowOverlap(); + + // Drag and drop: re-order tabs + if (held && !tab_appearing && IsMouseDragging(0)) + { + if (!g.DragDropActive && (tab_bar->Flags & ImGuiTabBarFlags_Reorderable)) + { + // While moving a tab it will jump on the other side of the mouse, so we also test for MouseDelta.x + if (g.IO.MouseDelta.x < 0.0f && g.IO.MousePos.x < bb.Min.x) + { + TabBarQueueReorderFromMousePos(tab_bar, tab, g.IO.MousePos); + } + else if (g.IO.MouseDelta.x > 0.0f && g.IO.MousePos.x > bb.Max.x) + { + TabBarQueueReorderFromMousePos(tab_bar, tab, g.IO.MousePos); + } + } + } + +#if 0 + if (hovered && g.HoveredIdNotActiveTimer > TOOLTIP_DELAY && bb.GetWidth() < tab->ContentWidth) + { + // Enlarge tab display when hovering + bb.Max.x = bb.Min.x + IM_FLOOR(ImLerp(bb.GetWidth(), tab->ContentWidth, ImSaturate((g.HoveredIdNotActiveTimer - 0.40f) * 6.0f))); + display_draw_list = GetForegroundDrawList(window); + TabItemBackground(display_draw_list, bb, flags, GetColorU32(ImGuiCol_TitleBgActive)); + } +#endif + + // Render tab shape + ImDrawList* display_draw_list = window->DrawList; + const ImU32 tab_col = GetColorU32((held || hovered) ? ImGuiCol_TabHovered : tab_contents_visible ? (tab_bar_focused ? ImGuiCol_TabActive : ImGuiCol_TabUnfocusedActive) : (tab_bar_focused ? ImGuiCol_Tab : ImGuiCol_TabUnfocused)); + TabItemBackground(display_draw_list, bb, flags, tab_col); + RenderNavHighlight(bb, id); + + // Select with right mouse button. This is so the common idiom for context menu automatically highlight the current widget. + const bool hovered_unblocked = IsItemHovered(ImGuiHoveredFlags_AllowWhenBlockedByPopup); + if (hovered_unblocked && (IsMouseClicked(1) || IsMouseReleased(1))) + if (!is_tab_button) + tab_bar->NextSelectedTabId = id; + + if (tab_bar->Flags & ImGuiTabBarFlags_NoCloseWithMiddleMouseButton) + flags |= ImGuiTabItemFlags_NoCloseWithMiddleMouseButton; + + // Render tab label, process close button + const ImGuiID close_button_id = p_open ? GetIDWithSeed("#CLOSE", NULL, id) : 0; + bool just_closed; + bool text_clipped; + TabItemLabelAndCloseButton(display_draw_list, bb, flags, tab_bar->FramePadding, label, id, close_button_id, tab_contents_visible, &just_closed, &text_clipped); + if (just_closed && p_open != NULL) + { + *p_open = false; + TabBarCloseTab(tab_bar, tab); + } + + // Restore main window position so user can draw there + if (want_clip_rect) + PopClipRect(); + window->DC.CursorPos = backup_main_cursor_pos; + + // Tooltip + // (Won't work over the close button because ItemOverlap systems messes up with HoveredIdTimer-> seems ok) + // (We test IsItemHovered() to discard e.g. when another item is active or drag and drop over the tab bar, which g.HoveredId ignores) + // FIXME: This is a mess. + // FIXME: We may want disabled tab to still display the tooltip? + if (text_clipped && g.HoveredId == id && !held && g.HoveredIdNotActiveTimer > g.TooltipSlowDelay && IsItemHovered()) + if (!(tab_bar->Flags & ImGuiTabBarFlags_NoTooltip) && !(tab->Flags & ImGuiTabItemFlags_NoTooltip)) + SetTooltip("%.*s", (int)(FindRenderedTextEnd(label) - label), label); + + IM_ASSERT(!is_tab_button || !(tab_bar->SelectedTabId == tab->ID && is_tab_button)); // TabItemButton should not be selected + if (is_tab_button) + return pressed; + return tab_contents_visible; +} + +// [Public] This is call is 100% optional but it allows to remove some one-frame glitches when a tab has been unexpectedly removed. +// To use it to need to call the function SetTabItemClosed() between BeginTabBar() and EndTabBar(). +// Tabs closed by the close button will automatically be flagged to avoid this issue. +void ImGui::SetTabItemClosed(const char* label) +{ + ImGuiContext& g = *GImGui; + bool is_within_manual_tab_bar = g.CurrentTabBar && !(g.CurrentTabBar->Flags & ImGuiTabBarFlags_DockNode); + if (is_within_manual_tab_bar) + { + ImGuiTabBar* tab_bar = g.CurrentTabBar; + ImGuiID tab_id = TabBarCalcTabID(tab_bar, label); + if (ImGuiTabItem* tab = TabBarFindTabByID(tab_bar, tab_id)) + tab->WantClose = true; // Will be processed by next call to TabBarLayout() + } +} + +ImVec2 ImGui::TabItemCalcSize(const char* label, bool has_close_button) +{ + ImGuiContext& g = *GImGui; + ImVec2 label_size = CalcTextSize(label, NULL, true); + ImVec2 size = ImVec2(label_size.x + g.Style.FramePadding.x, label_size.y + g.Style.FramePadding.y * 2.0f); + if (has_close_button) + size.x += g.Style.FramePadding.x + (g.Style.ItemInnerSpacing.x + g.FontSize); // We use Y intentionally to fit the close button circle. + else + size.x += g.Style.FramePadding.x + 1.0f; + return ImVec2(ImMin(size.x, TabBarCalcMaxTabWidth()), size.y); +} + +void ImGui::TabItemBackground(ImDrawList* draw_list, const ImRect& bb, ImGuiTabItemFlags flags, ImU32 col) +{ + // While rendering tabs, we trim 1 pixel off the top of our bounding box so they can fit within a regular frame height while looking "detached" from it. + ImGuiContext& g = *GImGui; + const float width = bb.GetWidth(); + IM_UNUSED(flags); + IM_ASSERT(width > 0.0f); + const float rounding = ImMax(0.0f, ImMin((flags & ImGuiTabItemFlags_Button) ? g.Style.FrameRounding : g.Style.TabRounding, width * 0.5f - 1.0f)); + const float y1 = bb.Min.y + 1.0f; + const float y2 = bb.Max.y - 1.0f; + draw_list->PathLineTo(ImVec2(bb.Min.x, y2)); + draw_list->PathArcToFast(ImVec2(bb.Min.x + rounding, y1 + rounding), rounding, 6, 9); + draw_list->PathArcToFast(ImVec2(bb.Max.x - rounding, y1 + rounding), rounding, 9, 12); + draw_list->PathLineTo(ImVec2(bb.Max.x, y2)); + draw_list->PathFillConvex(col); + if (g.Style.TabBorderSize > 0.0f) + { + draw_list->PathLineTo(ImVec2(bb.Min.x + 0.5f, y2)); + draw_list->PathArcToFast(ImVec2(bb.Min.x + rounding + 0.5f, y1 + rounding + 0.5f), rounding, 6, 9); + draw_list->PathArcToFast(ImVec2(bb.Max.x - rounding - 0.5f, y1 + rounding + 0.5f), rounding, 9, 12); + draw_list->PathLineTo(ImVec2(bb.Max.x - 0.5f, y2)); + draw_list->PathStroke(GetColorU32(ImGuiCol_Border), 0, g.Style.TabBorderSize); + } +} + +// Render text label (with custom clipping) + Unsaved Document marker + Close Button logic +// We tend to lock style.FramePadding for a given tab-bar, hence the 'frame_padding' parameter. +void ImGui::TabItemLabelAndCloseButton(ImDrawList* draw_list, const ImRect& bb, ImGuiTabItemFlags flags, ImVec2 frame_padding, const char* label, ImGuiID tab_id, ImGuiID close_button_id, bool is_contents_visible, bool* out_just_closed, bool* out_text_clipped) +{ + ImGuiContext& g = *GImGui; + ImVec2 label_size = CalcTextSize(label, NULL, true); + + if (out_just_closed) + *out_just_closed = false; + if (out_text_clipped) + *out_text_clipped = false; + + if (bb.GetWidth() <= 1.0f) + return; + + // In Style V2 we'll have full override of all colors per state (e.g. focused, selected) + // But right now if you want to alter text color of tabs this is what you need to do. +#if 0 + const float backup_alpha = g.Style.Alpha; + if (!is_contents_visible) + g.Style.Alpha *= 0.7f; +#endif + + // Render text label (with clipping + alpha gradient) + unsaved marker + ImRect text_pixel_clip_bb(bb.Min.x + frame_padding.x, bb.Min.y + frame_padding.y, bb.Max.x - frame_padding.x, bb.Max.y); + ImRect text_ellipsis_clip_bb = text_pixel_clip_bb; + + // Return clipped state ignoring the close button + if (out_text_clipped) + { + *out_text_clipped = (text_ellipsis_clip_bb.Min.x + label_size.x) > text_pixel_clip_bb.Max.x; + //draw_list->AddCircle(text_ellipsis_clip_bb.Min, 3.0f, *out_text_clipped ? IM_COL32(255, 0, 0, 255) : IM_COL32(0, 255, 0, 255)); + } + + const float button_sz = g.FontSize; + const ImVec2 button_pos(ImMax(bb.Min.x, bb.Max.x - frame_padding.x * 2.0f - button_sz), bb.Min.y); + + // Close Button & Unsaved Marker + // We are relying on a subtle and confusing distinction between 'hovered' and 'g.HoveredId' which happens because we are using ImGuiButtonFlags_AllowOverlapMode + SetItemAllowOverlap() + // 'hovered' will be true when hovering the Tab but NOT when hovering the close button + // 'g.HoveredId==id' will be true when hovering the Tab including when hovering the close button + // 'g.ActiveId==close_button_id' will be true when we are holding on the close button, in which case both hovered booleans are false + bool close_button_pressed = false; + bool close_button_visible = false; + if (close_button_id != 0) + if (is_contents_visible || bb.GetWidth() >= ImMax(button_sz, g.Style.TabMinWidthForCloseButton)) + if (g.HoveredId == tab_id || g.HoveredId == close_button_id || g.ActiveId == tab_id || g.ActiveId == close_button_id) + close_button_visible = true; + bool unsaved_marker_visible = (flags & ImGuiTabItemFlags_UnsavedDocument) != 0 && (button_pos.x + button_sz <= bb.Max.x); + + if (close_button_visible) + { + ImGuiLastItemData last_item_backup = g.LastItemData; + PushStyleVar(ImGuiStyleVar_FramePadding, frame_padding); + if (CloseButton(close_button_id, button_pos)) + close_button_pressed = true; + PopStyleVar(); + g.LastItemData = last_item_backup; + + // Close with middle mouse button + if (!(flags & ImGuiTabItemFlags_NoCloseWithMiddleMouseButton) && IsMouseClicked(2)) + close_button_pressed = true; + } + else if (unsaved_marker_visible) + { + const ImRect bullet_bb(button_pos, button_pos + ImVec2(button_sz, button_sz) + g.Style.FramePadding * 2.0f); + RenderBullet(draw_list, bullet_bb.GetCenter(), GetColorU32(ImGuiCol_Text)); + } + + // This is all rather complicated + // (the main idea is that because the close button only appears on hover, we don't want it to alter the ellipsis position) + // FIXME: if FramePadding is noticeably large, ellipsis_max_x will be wrong here (e.g. #3497), maybe for consistency that parameter of RenderTextEllipsis() shouldn't exist.. + float ellipsis_max_x = close_button_visible ? text_pixel_clip_bb.Max.x : bb.Max.x - 1.0f; + if (close_button_visible || unsaved_marker_visible) + { + text_pixel_clip_bb.Max.x -= close_button_visible ? (button_sz) : (button_sz * 0.80f); + text_ellipsis_clip_bb.Max.x -= unsaved_marker_visible ? (button_sz * 0.80f) : 0.0f; + ellipsis_max_x = text_pixel_clip_bb.Max.x; + } + RenderTextEllipsis(draw_list, text_ellipsis_clip_bb.Min, text_ellipsis_clip_bb.Max, text_pixel_clip_bb.Max.x, ellipsis_max_x, label, NULL, &label_size); + +#if 0 + if (!is_contents_visible) + g.Style.Alpha = backup_alpha; +#endif + + if (out_just_closed) + *out_just_closed = close_button_pressed; +} + + +#endif // #ifndef IMGUI_DISABLE diff --git a/source/editor/imgui/imstb_rectpack.h b/source/editor/imgui/imstb_rectpack.h new file mode 100644 index 0000000..3958952 --- /dev/null +++ b/source/editor/imgui/imstb_rectpack.h @@ -0,0 +1,639 @@ +// [DEAR IMGUI] +// This is a slightly modified version of stb_rect_pack.h 1.00. +// Those changes would need to be pushed into nothings/stb: +// - Added STBRP__CDECL +// Grep for [DEAR IMGUI] to find the changes. + +// stb_rect_pack.h - v1.00 - public domain - rectangle packing +// Sean Barrett 2014 +// +// Useful for e.g. packing rectangular textures into an atlas. +// Does not do rotation. +// +// Not necessarily the awesomest packing method, but better than +// the totally naive one in stb_truetype (which is primarily what +// this is meant to replace). +// +// Has only had a few tests run, may have issues. +// +// More docs to come. +// +// No memory allocations; uses qsort() and assert() from stdlib. +// Can override those by defining STBRP_SORT and STBRP_ASSERT. +// +// This library currently uses the Skyline Bottom-Left algorithm. +// +// Please note: better rectangle packers are welcome! Please +// implement them to the same API, but with a different init +// function. +// +// Credits +// +// Library +// Sean Barrett +// Minor features +// Martins Mozeiko +// github:IntellectualKitty +// +// Bugfixes / warning fixes +// Jeremy Jaussaud +// Fabian Giesen +// +// Version history: +// +// 1.00 (2019-02-25) avoid small space waste; gracefully fail too-wide rectangles +// 0.99 (2019-02-07) warning fixes +// 0.11 (2017-03-03) return packing success/fail result +// 0.10 (2016-10-25) remove cast-away-const to avoid warnings +// 0.09 (2016-08-27) fix compiler warnings +// 0.08 (2015-09-13) really fix bug with empty rects (w=0 or h=0) +// 0.07 (2015-09-13) fix bug with empty rects (w=0 or h=0) +// 0.06 (2015-04-15) added STBRP_SORT to allow replacing qsort +// 0.05: added STBRP_ASSERT to allow replacing assert +// 0.04: fixed minor bug in STBRP_LARGE_RECTS support +// 0.01: initial release +// +// LICENSE +// +// See end of file for license information. + +////////////////////////////////////////////////////////////////////////////// +// +// INCLUDE SECTION +// + +#ifndef STB_INCLUDE_STB_RECT_PACK_H +#define STB_INCLUDE_STB_RECT_PACK_H + +#define STB_RECT_PACK_VERSION 1 + +#ifdef STBRP_STATIC +#define STBRP_DEF static +#else +#define STBRP_DEF extern +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +typedef struct stbrp_context stbrp_context; +typedef struct stbrp_node stbrp_node; +typedef struct stbrp_rect stbrp_rect; + +#ifdef STBRP_LARGE_RECTS +typedef int stbrp_coord; +#else +typedef unsigned short stbrp_coord; +#endif + +STBRP_DEF int stbrp_pack_rects (stbrp_context *context, stbrp_rect *rects, int num_rects); +// Assign packed locations to rectangles. The rectangles are of type +// 'stbrp_rect' defined below, stored in the array 'rects', and there +// are 'num_rects' many of them. +// +// Rectangles which are successfully packed have the 'was_packed' flag +// set to a non-zero value and 'x' and 'y' store the minimum location +// on each axis (i.e. bottom-left in cartesian coordinates, top-left +// if you imagine y increasing downwards). Rectangles which do not fit +// have the 'was_packed' flag set to 0. +// +// You should not try to access the 'rects' array from another thread +// while this function is running, as the function temporarily reorders +// the array while it executes. +// +// To pack into another rectangle, you need to call stbrp_init_target +// again. To continue packing into the same rectangle, you can call +// this function again. Calling this multiple times with multiple rect +// arrays will probably produce worse packing results than calling it +// a single time with the full rectangle array, but the option is +// available. +// +// The function returns 1 if all of the rectangles were successfully +// packed and 0 otherwise. + +struct stbrp_rect +{ + // reserved for your use: + int id; + + // input: + stbrp_coord w, h; + + // output: + stbrp_coord x, y; + int was_packed; // non-zero if valid packing + +}; // 16 bytes, nominally + + +STBRP_DEF void stbrp_init_target (stbrp_context *context, int width, int height, stbrp_node *nodes, int num_nodes); +// Initialize a rectangle packer to: +// pack a rectangle that is 'width' by 'height' in dimensions +// using temporary storage provided by the array 'nodes', which is 'num_nodes' long +// +// You must call this function every time you start packing into a new target. +// +// There is no "shutdown" function. The 'nodes' memory must stay valid for +// the following stbrp_pack_rects() call (or calls), but can be freed after +// the call (or calls) finish. +// +// Note: to guarantee best results, either: +// 1. make sure 'num_nodes' >= 'width' +// or 2. call stbrp_allow_out_of_mem() defined below with 'allow_out_of_mem = 1' +// +// If you don't do either of the above things, widths will be quantized to multiples +// of small integers to guarantee the algorithm doesn't run out of temporary storage. +// +// If you do #2, then the non-quantized algorithm will be used, but the algorithm +// may run out of temporary storage and be unable to pack some rectangles. + +STBRP_DEF void stbrp_setup_allow_out_of_mem (stbrp_context *context, int allow_out_of_mem); +// Optionally call this function after init but before doing any packing to +// change the handling of the out-of-temp-memory scenario, described above. +// If you call init again, this will be reset to the default (false). + + +STBRP_DEF void stbrp_setup_heuristic (stbrp_context *context, int heuristic); +// Optionally select which packing heuristic the library should use. Different +// heuristics will produce better/worse results for different data sets. +// If you call init again, this will be reset to the default. + +enum +{ + STBRP_HEURISTIC_Skyline_default=0, + STBRP_HEURISTIC_Skyline_BL_sortHeight = STBRP_HEURISTIC_Skyline_default, + STBRP_HEURISTIC_Skyline_BF_sortHeight +}; + + +////////////////////////////////////////////////////////////////////////////// +// +// the details of the following structures don't matter to you, but they must +// be visible so you can handle the memory allocations for them + +struct stbrp_node +{ + stbrp_coord x,y; + stbrp_node *next; +}; + +struct stbrp_context +{ + int width; + int height; + int align; + int init_mode; + int heuristic; + int num_nodes; + stbrp_node *active_head; + stbrp_node *free_head; + stbrp_node extra[2]; // we allocate two extra nodes so optimal user-node-count is 'width' not 'width+2' +}; + +#ifdef __cplusplus +} +#endif + +#endif + +////////////////////////////////////////////////////////////////////////////// +// +// IMPLEMENTATION SECTION +// + +#ifdef STB_RECT_PACK_IMPLEMENTATION +#ifndef STBRP_SORT +#include +#define STBRP_SORT qsort +#endif + +#ifndef STBRP_ASSERT +#include +#define STBRP_ASSERT assert +#endif + +// [DEAR IMGUI] Added STBRP__CDECL +#ifdef _MSC_VER +#define STBRP__NOTUSED(v) (void)(v) +#define STBRP__CDECL __cdecl +#else +#define STBRP__NOTUSED(v) (void)sizeof(v) +#define STBRP__CDECL +#endif + +enum +{ + STBRP__INIT_skyline = 1 +}; + +STBRP_DEF void stbrp_setup_heuristic(stbrp_context *context, int heuristic) +{ + switch (context->init_mode) { + case STBRP__INIT_skyline: + STBRP_ASSERT(heuristic == STBRP_HEURISTIC_Skyline_BL_sortHeight || heuristic == STBRP_HEURISTIC_Skyline_BF_sortHeight); + context->heuristic = heuristic; + break; + default: + STBRP_ASSERT(0); + } +} + +STBRP_DEF void stbrp_setup_allow_out_of_mem(stbrp_context *context, int allow_out_of_mem) +{ + if (allow_out_of_mem) + // if it's ok to run out of memory, then don't bother aligning them; + // this gives better packing, but may fail due to OOM (even though + // the rectangles easily fit). @TODO a smarter approach would be to only + // quantize once we've hit OOM, then we could get rid of this parameter. + context->align = 1; + else { + // if it's not ok to run out of memory, then quantize the widths + // so that num_nodes is always enough nodes. + // + // I.e. num_nodes * align >= width + // align >= width / num_nodes + // align = ceil(width/num_nodes) + + context->align = (context->width + context->num_nodes-1) / context->num_nodes; + } +} + +STBRP_DEF void stbrp_init_target(stbrp_context *context, int width, int height, stbrp_node *nodes, int num_nodes) +{ + int i; +#ifndef STBRP_LARGE_RECTS + STBRP_ASSERT(width <= 0xffff && height <= 0xffff); +#endif + + for (i=0; i < num_nodes-1; ++i) + nodes[i].next = &nodes[i+1]; + nodes[i].next = NULL; + context->init_mode = STBRP__INIT_skyline; + context->heuristic = STBRP_HEURISTIC_Skyline_default; + context->free_head = &nodes[0]; + context->active_head = &context->extra[0]; + context->width = width; + context->height = height; + context->num_nodes = num_nodes; + stbrp_setup_allow_out_of_mem(context, 0); + + // node 0 is the full width, node 1 is the sentinel (lets us not store width explicitly) + context->extra[0].x = 0; + context->extra[0].y = 0; + context->extra[0].next = &context->extra[1]; + context->extra[1].x = (stbrp_coord) width; +#ifdef STBRP_LARGE_RECTS + context->extra[1].y = (1<<30); +#else + context->extra[1].y = 65535; +#endif + context->extra[1].next = NULL; +} + +// find minimum y position if it starts at x1 +static int stbrp__skyline_find_min_y(stbrp_context *c, stbrp_node *first, int x0, int width, int *pwaste) +{ + stbrp_node *node = first; + int x1 = x0 + width; + int min_y, visited_width, waste_area; + + STBRP__NOTUSED(c); + + STBRP_ASSERT(first->x <= x0); + + #if 0 + // skip in case we're past the node + while (node->next->x <= x0) + ++node; + #else + STBRP_ASSERT(node->next->x > x0); // we ended up handling this in the caller for efficiency + #endif + + STBRP_ASSERT(node->x <= x0); + + min_y = 0; + waste_area = 0; + visited_width = 0; + while (node->x < x1) { + if (node->y > min_y) { + // raise min_y higher. + // we've accounted for all waste up to min_y, + // but we'll now add more waste for everything we've visted + waste_area += visited_width * (node->y - min_y); + min_y = node->y; + // the first time through, visited_width might be reduced + if (node->x < x0) + visited_width += node->next->x - x0; + else + visited_width += node->next->x - node->x; + } else { + // add waste area + int under_width = node->next->x - node->x; + if (under_width + visited_width > width) + under_width = width - visited_width; + waste_area += under_width * (min_y - node->y); + visited_width += under_width; + } + node = node->next; + } + + *pwaste = waste_area; + return min_y; +} + +typedef struct +{ + int x,y; + stbrp_node **prev_link; +} stbrp__findresult; + +static stbrp__findresult stbrp__skyline_find_best_pos(stbrp_context *c, int width, int height) +{ + int best_waste = (1<<30), best_x, best_y = (1 << 30); + stbrp__findresult fr; + stbrp_node **prev, *node, *tail, **best = NULL; + + // align to multiple of c->align + width = (width + c->align - 1); + width -= width % c->align; + STBRP_ASSERT(width % c->align == 0); + + // if it can't possibly fit, bail immediately + if (width > c->width || height > c->height) { + fr.prev_link = NULL; + fr.x = fr.y = 0; + return fr; + } + + node = c->active_head; + prev = &c->active_head; + while (node->x + width <= c->width) { + int y,waste; + y = stbrp__skyline_find_min_y(c, node, node->x, width, &waste); + if (c->heuristic == STBRP_HEURISTIC_Skyline_BL_sortHeight) { // actually just want to test BL + // bottom left + if (y < best_y) { + best_y = y; + best = prev; + } + } else { + // best-fit + if (y + height <= c->height) { + // can only use it if it first vertically + if (y < best_y || (y == best_y && waste < best_waste)) { + best_y = y; + best_waste = waste; + best = prev; + } + } + } + prev = &node->next; + node = node->next; + } + + best_x = (best == NULL) ? 0 : (*best)->x; + + // if doing best-fit (BF), we also have to try aligning right edge to each node position + // + // e.g, if fitting + // + // ____________________ + // |____________________| + // + // into + // + // | | + // | ____________| + // |____________| + // + // then right-aligned reduces waste, but bottom-left BL is always chooses left-aligned + // + // This makes BF take about 2x the time + + if (c->heuristic == STBRP_HEURISTIC_Skyline_BF_sortHeight) { + tail = c->active_head; + node = c->active_head; + prev = &c->active_head; + // find first node that's admissible + while (tail->x < width) + tail = tail->next; + while (tail) { + int xpos = tail->x - width; + int y,waste; + STBRP_ASSERT(xpos >= 0); + // find the left position that matches this + while (node->next->x <= xpos) { + prev = &node->next; + node = node->next; + } + STBRP_ASSERT(node->next->x > xpos && node->x <= xpos); + y = stbrp__skyline_find_min_y(c, node, xpos, width, &waste); + if (y + height <= c->height) { + if (y <= best_y) { + if (y < best_y || waste < best_waste || (waste==best_waste && xpos < best_x)) { + best_x = xpos; + STBRP_ASSERT(y <= best_y); + best_y = y; + best_waste = waste; + best = prev; + } + } + } + tail = tail->next; + } + } + + fr.prev_link = best; + fr.x = best_x; + fr.y = best_y; + return fr; +} + +static stbrp__findresult stbrp__skyline_pack_rectangle(stbrp_context *context, int width, int height) +{ + // find best position according to heuristic + stbrp__findresult res = stbrp__skyline_find_best_pos(context, width, height); + stbrp_node *node, *cur; + + // bail if: + // 1. it failed + // 2. the best node doesn't fit (we don't always check this) + // 3. we're out of memory + if (res.prev_link == NULL || res.y + height > context->height || context->free_head == NULL) { + res.prev_link = NULL; + return res; + } + + // on success, create new node + node = context->free_head; + node->x = (stbrp_coord) res.x; + node->y = (stbrp_coord) (res.y + height); + + context->free_head = node->next; + + // insert the new node into the right starting point, and + // let 'cur' point to the remaining nodes needing to be + // stiched back in + + cur = *res.prev_link; + if (cur->x < res.x) { + // preserve the existing one, so start testing with the next one + stbrp_node *next = cur->next; + cur->next = node; + cur = next; + } else { + *res.prev_link = node; + } + + // from here, traverse cur and free the nodes, until we get to one + // that shouldn't be freed + while (cur->next && cur->next->x <= res.x + width) { + stbrp_node *next = cur->next; + // move the current node to the free list + cur->next = context->free_head; + context->free_head = cur; + cur = next; + } + + // stitch the list back in + node->next = cur; + + if (cur->x < res.x + width) + cur->x = (stbrp_coord) (res.x + width); + +#ifdef _DEBUG + cur = context->active_head; + while (cur->x < context->width) { + STBRP_ASSERT(cur->x < cur->next->x); + cur = cur->next; + } + STBRP_ASSERT(cur->next == NULL); + + { + int count=0; + cur = context->active_head; + while (cur) { + cur = cur->next; + ++count; + } + cur = context->free_head; + while (cur) { + cur = cur->next; + ++count; + } + STBRP_ASSERT(count == context->num_nodes+2); + } +#endif + + return res; +} + +// [DEAR IMGUI] Added STBRP__CDECL +static int STBRP__CDECL rect_height_compare(const void *a, const void *b) +{ + const stbrp_rect *p = (const stbrp_rect *) a; + const stbrp_rect *q = (const stbrp_rect *) b; + if (p->h > q->h) + return -1; + if (p->h < q->h) + return 1; + return (p->w > q->w) ? -1 : (p->w < q->w); +} + +// [DEAR IMGUI] Added STBRP__CDECL +static int STBRP__CDECL rect_original_order(const void *a, const void *b) +{ + const stbrp_rect *p = (const stbrp_rect *) a; + const stbrp_rect *q = (const stbrp_rect *) b; + return (p->was_packed < q->was_packed) ? -1 : (p->was_packed > q->was_packed); +} + +#ifdef STBRP_LARGE_RECTS +#define STBRP__MAXVAL 0xffffffff +#else +#define STBRP__MAXVAL 0xffff +#endif + +STBRP_DEF int stbrp_pack_rects(stbrp_context *context, stbrp_rect *rects, int num_rects) +{ + int i, all_rects_packed = 1; + + // we use the 'was_packed' field internally to allow sorting/unsorting + for (i=0; i < num_rects; ++i) { + rects[i].was_packed = i; + } + + // sort according to heuristic + STBRP_SORT(rects, num_rects, sizeof(rects[0]), rect_height_compare); + + for (i=0; i < num_rects; ++i) { + if (rects[i].w == 0 || rects[i].h == 0) { + rects[i].x = rects[i].y = 0; // empty rect needs no space + } else { + stbrp__findresult fr = stbrp__skyline_pack_rectangle(context, rects[i].w, rects[i].h); + if (fr.prev_link) { + rects[i].x = (stbrp_coord) fr.x; + rects[i].y = (stbrp_coord) fr.y; + } else { + rects[i].x = rects[i].y = STBRP__MAXVAL; + } + } + } + + // unsort + STBRP_SORT(rects, num_rects, sizeof(rects[0]), rect_original_order); + + // set was_packed flags and all_rects_packed status + for (i=0; i < num_rects; ++i) { + rects[i].was_packed = !(rects[i].x == STBRP__MAXVAL && rects[i].y == STBRP__MAXVAL); + if (!rects[i].was_packed) + all_rects_packed = 0; + } + + // return the all_rects_packed status + return all_rects_packed; +} +#endif + +/* +------------------------------------------------------------------------------ +This software is available under 2 licenses -- choose whichever you prefer. +------------------------------------------------------------------------------ +ALTERNATIVE A - MIT License +Copyright (c) 2017 Sean Barrett +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. +------------------------------------------------------------------------------ +ALTERNATIVE B - Public Domain (www.unlicense.org) +This is free and unencumbered software released into the public domain. +Anyone is free to copy, modify, publish, use, compile, sell, or distribute this +software, either in source code form or as a compiled binary, for any purpose, +commercial or non-commercial, and by any means. +In jurisdictions that recognize copyright laws, the author or authors of this +software dedicate any and all copyright interest in the software to the public +domain. We make this dedication for the benefit of the public at large and to +the detriment of our heirs and successors. We intend this dedication to be an +overt act of relinquishment in perpetuity of all present and future rights to +this software under copyright law. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +------------------------------------------------------------------------------ +*/ diff --git a/source/editor/imgui/imstb_textedit.h b/source/editor/imgui/imstb_textedit.h new file mode 100644 index 0000000..2c635b2 --- /dev/null +++ b/source/editor/imgui/imstb_textedit.h @@ -0,0 +1,1449 @@ +// [DEAR IMGUI] +// This is a slightly modified version of stb_textedit.h 1.13. +// Those changes would need to be pushed into nothings/stb: +// - Fix in stb_textedit_discard_redo (see https://github.com/nothings/stb/issues/321) +// Grep for [DEAR IMGUI] to find the changes. + +// stb_textedit.h - v1.13 - public domain - Sean Barrett +// Development of this library was sponsored by RAD Game Tools +// +// This C header file implements the guts of a multi-line text-editing +// widget; you implement display, word-wrapping, and low-level string +// insertion/deletion, and stb_textedit will map user inputs into +// insertions & deletions, plus updates to the cursor position, +// selection state, and undo state. +// +// It is intended for use in games and other systems that need to build +// their own custom widgets and which do not have heavy text-editing +// requirements (this library is not recommended for use for editing large +// texts, as its performance does not scale and it has limited undo). +// +// Non-trivial behaviors are modelled after Windows text controls. +// +// +// LICENSE +// +// See end of file for license information. +// +// +// DEPENDENCIES +// +// Uses the C runtime function 'memmove', which you can override +// by defining STB_TEXTEDIT_memmove before the implementation. +// Uses no other functions. Performs no runtime allocations. +// +// +// VERSION HISTORY +// +// 1.13 (2019-02-07) fix bug in undo size management +// 1.12 (2018-01-29) user can change STB_TEXTEDIT_KEYTYPE, fix redo to avoid crash +// 1.11 (2017-03-03) fix HOME on last line, dragging off single-line textfield +// 1.10 (2016-10-25) supress warnings about casting away const with -Wcast-qual +// 1.9 (2016-08-27) customizable move-by-word +// 1.8 (2016-04-02) better keyboard handling when mouse button is down +// 1.7 (2015-09-13) change y range handling in case baseline is non-0 +// 1.6 (2015-04-15) allow STB_TEXTEDIT_memmove +// 1.5 (2014-09-10) add support for secondary keys for OS X +// 1.4 (2014-08-17) fix signed/unsigned warnings +// 1.3 (2014-06-19) fix mouse clicking to round to nearest char boundary +// 1.2 (2014-05-27) fix some RAD types that had crept into the new code +// 1.1 (2013-12-15) move-by-word (requires STB_TEXTEDIT_IS_SPACE ) +// 1.0 (2012-07-26) improve documentation, initial public release +// 0.3 (2012-02-24) bugfixes, single-line mode; insert mode +// 0.2 (2011-11-28) fixes to undo/redo +// 0.1 (2010-07-08) initial version +// +// ADDITIONAL CONTRIBUTORS +// +// Ulf Winklemann: move-by-word in 1.1 +// Fabian Giesen: secondary key inputs in 1.5 +// Martins Mozeiko: STB_TEXTEDIT_memmove in 1.6 +// +// Bugfixes: +// Scott Graham +// Daniel Keller +// Omar Cornut +// Dan Thompson +// +// USAGE +// +// This file behaves differently depending on what symbols you define +// before including it. +// +// +// Header-file mode: +// +// If you do not define STB_TEXTEDIT_IMPLEMENTATION before including this, +// it will operate in "header file" mode. In this mode, it declares a +// single public symbol, STB_TexteditState, which encapsulates the current +// state of a text widget (except for the string, which you will store +// separately). +// +// To compile in this mode, you must define STB_TEXTEDIT_CHARTYPE to a +// primitive type that defines a single character (e.g. char, wchar_t, etc). +// +// To save space or increase undo-ability, you can optionally define the +// following things that are used by the undo system: +// +// STB_TEXTEDIT_POSITIONTYPE small int type encoding a valid cursor position +// STB_TEXTEDIT_UNDOSTATECOUNT the number of undo states to allow +// STB_TEXTEDIT_UNDOCHARCOUNT the number of characters to store in the undo buffer +// +// If you don't define these, they are set to permissive types and +// moderate sizes. The undo system does no memory allocations, so +// it grows STB_TexteditState by the worst-case storage which is (in bytes): +// +// [4 + 3 * sizeof(STB_TEXTEDIT_POSITIONTYPE)] * STB_TEXTEDIT_UNDOSTATE_COUNT +// + sizeof(STB_TEXTEDIT_CHARTYPE) * STB_TEXTEDIT_UNDOCHAR_COUNT +// +// +// Implementation mode: +// +// If you define STB_TEXTEDIT_IMPLEMENTATION before including this, it +// will compile the implementation of the text edit widget, depending +// on a large number of symbols which must be defined before the include. +// +// The implementation is defined only as static functions. You will then +// need to provide your own APIs in the same file which will access the +// static functions. +// +// The basic concept is that you provide a "string" object which +// behaves like an array of characters. stb_textedit uses indices to +// refer to positions in the string, implicitly representing positions +// in the displayed textedit. This is true for both plain text and +// rich text; even with rich text stb_truetype interacts with your +// code as if there was an array of all the displayed characters. +// +// Symbols that must be the same in header-file and implementation mode: +// +// STB_TEXTEDIT_CHARTYPE the character type +// STB_TEXTEDIT_POSITIONTYPE small type that is a valid cursor position +// STB_TEXTEDIT_UNDOSTATECOUNT the number of undo states to allow +// STB_TEXTEDIT_UNDOCHARCOUNT the number of characters to store in the undo buffer +// +// Symbols you must define for implementation mode: +// +// STB_TEXTEDIT_STRING the type of object representing a string being edited, +// typically this is a wrapper object with other data you need +// +// STB_TEXTEDIT_STRINGLEN(obj) the length of the string (ideally O(1)) +// STB_TEXTEDIT_LAYOUTROW(&r,obj,n) returns the results of laying out a line of characters +// starting from character #n (see discussion below) +// STB_TEXTEDIT_GETWIDTH(obj,n,i) returns the pixel delta from the xpos of the i'th character +// to the xpos of the i+1'th char for a line of characters +// starting at character #n (i.e. accounts for kerning +// with previous char) +// STB_TEXTEDIT_KEYTOTEXT(k) maps a keyboard input to an insertable character +// (return type is int, -1 means not valid to insert) +// STB_TEXTEDIT_GETCHAR(obj,i) returns the i'th character of obj, 0-based +// STB_TEXTEDIT_NEWLINE the character returned by _GETCHAR() we recognize +// as manually wordwrapping for end-of-line positioning +// +// STB_TEXTEDIT_DELETECHARS(obj,i,n) delete n characters starting at i +// STB_TEXTEDIT_INSERTCHARS(obj,i,c*,n) insert n characters at i (pointed to by STB_TEXTEDIT_CHARTYPE*) +// +// STB_TEXTEDIT_K_SHIFT a power of two that is or'd in to a keyboard input to represent the shift key +// +// STB_TEXTEDIT_K_LEFT keyboard input to move cursor left +// STB_TEXTEDIT_K_RIGHT keyboard input to move cursor right +// STB_TEXTEDIT_K_UP keyboard input to move cursor up +// STB_TEXTEDIT_K_DOWN keyboard input to move cursor down +// STB_TEXTEDIT_K_PGUP keyboard input to move cursor up a page +// STB_TEXTEDIT_K_PGDOWN keyboard input to move cursor down a page +// STB_TEXTEDIT_K_LINESTART keyboard input to move cursor to start of line // e.g. HOME +// STB_TEXTEDIT_K_LINEEND keyboard input to move cursor to end of line // e.g. END +// STB_TEXTEDIT_K_TEXTSTART keyboard input to move cursor to start of text // e.g. ctrl-HOME +// STB_TEXTEDIT_K_TEXTEND keyboard input to move cursor to end of text // e.g. ctrl-END +// STB_TEXTEDIT_K_DELETE keyboard input to delete selection or character under cursor +// STB_TEXTEDIT_K_BACKSPACE keyboard input to delete selection or character left of cursor +// STB_TEXTEDIT_K_UNDO keyboard input to perform undo +// STB_TEXTEDIT_K_REDO keyboard input to perform redo +// +// Optional: +// STB_TEXTEDIT_K_INSERT keyboard input to toggle insert mode +// STB_TEXTEDIT_IS_SPACE(ch) true if character is whitespace (e.g. 'isspace'), +// required for default WORDLEFT/WORDRIGHT handlers +// STB_TEXTEDIT_MOVEWORDLEFT(obj,i) custom handler for WORDLEFT, returns index to move cursor to +// STB_TEXTEDIT_MOVEWORDRIGHT(obj,i) custom handler for WORDRIGHT, returns index to move cursor to +// STB_TEXTEDIT_K_WORDLEFT keyboard input to move cursor left one word // e.g. ctrl-LEFT +// STB_TEXTEDIT_K_WORDRIGHT keyboard input to move cursor right one word // e.g. ctrl-RIGHT +// STB_TEXTEDIT_K_LINESTART2 secondary keyboard input to move cursor to start of line +// STB_TEXTEDIT_K_LINEEND2 secondary keyboard input to move cursor to end of line +// STB_TEXTEDIT_K_TEXTSTART2 secondary keyboard input to move cursor to start of text +// STB_TEXTEDIT_K_TEXTEND2 secondary keyboard input to move cursor to end of text +// +// Keyboard input must be encoded as a single integer value; e.g. a character code +// and some bitflags that represent shift states. to simplify the interface, SHIFT must +// be a bitflag, so we can test the shifted state of cursor movements to allow selection, +// i.e. (STB_TEXTEDIT_K_RIGHT|STB_TEXTEDIT_K_SHIFT) should be shifted right-arrow. +// +// You can encode other things, such as CONTROL or ALT, in additional bits, and +// then test for their presence in e.g. STB_TEXTEDIT_K_WORDLEFT. For example, +// my Windows implementations add an additional CONTROL bit, and an additional KEYDOWN +// bit. Then all of the STB_TEXTEDIT_K_ values bitwise-or in the KEYDOWN bit, +// and I pass both WM_KEYDOWN and WM_CHAR events to the "key" function in the +// API below. The control keys will only match WM_KEYDOWN events because of the +// keydown bit I add, and STB_TEXTEDIT_KEYTOTEXT only tests for the KEYDOWN +// bit so it only decodes WM_CHAR events. +// +// STB_TEXTEDIT_LAYOUTROW returns information about the shape of one displayed +// row of characters assuming they start on the i'th character--the width and +// the height and the number of characters consumed. This allows this library +// to traverse the entire layout incrementally. You need to compute word-wrapping +// here. +// +// Each textfield keeps its own insert mode state, which is not how normal +// applications work. To keep an app-wide insert mode, update/copy the +// "insert_mode" field of STB_TexteditState before/after calling API functions. +// +// API +// +// void stb_textedit_initialize_state(STB_TexteditState *state, int is_single_line) +// +// void stb_textedit_click(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, float x, float y) +// void stb_textedit_drag(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, float x, float y) +// int stb_textedit_cut(STB_TEXTEDIT_STRING *str, STB_TexteditState *state) +// int stb_textedit_paste(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, STB_TEXTEDIT_CHARTYPE *text, int len) +// void stb_textedit_key(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, STB_TEXEDIT_KEYTYPE key) +// +// Each of these functions potentially updates the string and updates the +// state. +// +// initialize_state: +// set the textedit state to a known good default state when initially +// constructing the textedit. +// +// click: +// call this with the mouse x,y on a mouse down; it will update the cursor +// and reset the selection start/end to the cursor point. the x,y must +// be relative to the text widget, with (0,0) being the top left. +// +// drag: +// call this with the mouse x,y on a mouse drag/up; it will update the +// cursor and the selection end point +// +// cut: +// call this to delete the current selection; returns true if there was +// one. you should FIRST copy the current selection to the system paste buffer. +// (To copy, just copy the current selection out of the string yourself.) +// +// paste: +// call this to paste text at the current cursor point or over the current +// selection if there is one. +// +// key: +// call this for keyboard inputs sent to the textfield. you can use it +// for "key down" events or for "translated" key events. if you need to +// do both (as in Win32), or distinguish Unicode characters from control +// inputs, set a high bit to distinguish the two; then you can define the +// various definitions like STB_TEXTEDIT_K_LEFT have the is-key-event bit +// set, and make STB_TEXTEDIT_KEYTOCHAR check that the is-key-event bit is +// clear. STB_TEXTEDIT_KEYTYPE defaults to int, but you can #define it to +// anything other type you wante before including. +// +// +// When rendering, you can read the cursor position and selection state from +// the STB_TexteditState. +// +// +// Notes: +// +// This is designed to be usable in IMGUI, so it allows for the possibility of +// running in an IMGUI that has NOT cached the multi-line layout. For this +// reason, it provides an interface that is compatible with computing the +// layout incrementally--we try to make sure we make as few passes through +// as possible. (For example, to locate the mouse pointer in the text, we +// could define functions that return the X and Y positions of characters +// and binary search Y and then X, but if we're doing dynamic layout this +// will run the layout algorithm many times, so instead we manually search +// forward in one pass. Similar logic applies to e.g. up-arrow and +// down-arrow movement.) +// +// If it's run in a widget that *has* cached the layout, then this is less +// efficient, but it's not horrible on modern computers. But you wouldn't +// want to edit million-line files with it. + + +//////////////////////////////////////////////////////////////////////////// +//////////////////////////////////////////////////////////////////////////// +//// +//// Header-file mode +//// +//// + +#ifndef INCLUDE_STB_TEXTEDIT_H +#define INCLUDE_STB_TEXTEDIT_H + +//////////////////////////////////////////////////////////////////////// +// +// STB_TexteditState +// +// Definition of STB_TexteditState which you should store +// per-textfield; it includes cursor position, selection state, +// and undo state. +// + +#ifndef STB_TEXTEDIT_UNDOSTATECOUNT +#define STB_TEXTEDIT_UNDOSTATECOUNT 99 +#endif +#ifndef STB_TEXTEDIT_UNDOCHARCOUNT +#define STB_TEXTEDIT_UNDOCHARCOUNT 999 +#endif +#ifndef STB_TEXTEDIT_CHARTYPE +#define STB_TEXTEDIT_CHARTYPE int +#endif +#ifndef STB_TEXTEDIT_POSITIONTYPE +#define STB_TEXTEDIT_POSITIONTYPE int +#endif + +typedef struct +{ + // private data + STB_TEXTEDIT_POSITIONTYPE where; + STB_TEXTEDIT_POSITIONTYPE insert_length; + STB_TEXTEDIT_POSITIONTYPE delete_length; + int char_storage; +} StbUndoRecord; + +typedef struct +{ + // private data + StbUndoRecord undo_rec [STB_TEXTEDIT_UNDOSTATECOUNT]; + STB_TEXTEDIT_CHARTYPE undo_char[STB_TEXTEDIT_UNDOCHARCOUNT]; + short undo_point, redo_point; + int undo_char_point, redo_char_point; +} StbUndoState; + +typedef struct +{ + ///////////////////// + // + // public data + // + + int cursor; + // position of the text cursor within the string + + int select_start; // selection start point + int select_end; + // selection start and end point in characters; if equal, no selection. + // note that start may be less than or greater than end (e.g. when + // dragging the mouse, start is where the initial click was, and you + // can drag in either direction) + + unsigned char insert_mode; + // each textfield keeps its own insert mode state. to keep an app-wide + // insert mode, copy this value in/out of the app state + + int row_count_per_page; + // page size in number of row. + // this value MUST be set to >0 for pageup or pagedown in multilines documents. + + ///////////////////// + // + // private data + // + unsigned char cursor_at_end_of_line; // not implemented yet + unsigned char initialized; + unsigned char has_preferred_x; + unsigned char single_line; + unsigned char padding1, padding2, padding3; + float preferred_x; // this determines where the cursor up/down tries to seek to along x + StbUndoState undostate; +} STB_TexteditState; + + +//////////////////////////////////////////////////////////////////////// +// +// StbTexteditRow +// +// Result of layout query, used by stb_textedit to determine where +// the text in each row is. + +// result of layout query +typedef struct +{ + float x0,x1; // starting x location, end x location (allows for align=right, etc) + float baseline_y_delta; // position of baseline relative to previous row's baseline + float ymin,ymax; // height of row above and below baseline + int num_chars; +} StbTexteditRow; +#endif //INCLUDE_STB_TEXTEDIT_H + + +//////////////////////////////////////////////////////////////////////////// +//////////////////////////////////////////////////////////////////////////// +//// +//// Implementation mode +//// +//// + + +// implementation isn't include-guarded, since it might have indirectly +// included just the "header" portion +#ifdef STB_TEXTEDIT_IMPLEMENTATION + +#ifndef STB_TEXTEDIT_memmove +#include +#define STB_TEXTEDIT_memmove memmove +#endif + + +///////////////////////////////////////////////////////////////////////////// +// +// Mouse input handling +// + +// traverse the layout to locate the nearest character to a display position +static int stb_text_locate_coord(STB_TEXTEDIT_STRING *str, float x, float y) +{ + StbTexteditRow r; + int n = STB_TEXTEDIT_STRINGLEN(str); + float base_y = 0, prev_x; + int i=0, k; + + r.x0 = r.x1 = 0; + r.ymin = r.ymax = 0; + r.num_chars = 0; + + // search rows to find one that straddles 'y' + while (i < n) { + STB_TEXTEDIT_LAYOUTROW(&r, str, i); + if (r.num_chars <= 0) + return n; + + if (i==0 && y < base_y + r.ymin) + return 0; + + if (y < base_y + r.ymax) + break; + + i += r.num_chars; + base_y += r.baseline_y_delta; + } + + // below all text, return 'after' last character + if (i >= n) + return n; + + // check if it's before the beginning of the line + if (x < r.x0) + return i; + + // check if it's before the end of the line + if (x < r.x1) { + // search characters in row for one that straddles 'x' + prev_x = r.x0; + for (k=0; k < r.num_chars; ++k) { + float w = STB_TEXTEDIT_GETWIDTH(str, i, k); + if (x < prev_x+w) { + if (x < prev_x+w/2) + return k+i; + else + return k+i+1; + } + prev_x += w; + } + // shouldn't happen, but if it does, fall through to end-of-line case + } + + // if the last character is a newline, return that. otherwise return 'after' the last character + if (STB_TEXTEDIT_GETCHAR(str, i+r.num_chars-1) == STB_TEXTEDIT_NEWLINE) + return i+r.num_chars-1; + else + return i+r.num_chars; +} + +// API click: on mouse down, move the cursor to the clicked location, and reset the selection +static void stb_textedit_click(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, float x, float y) +{ + // In single-line mode, just always make y = 0. This lets the drag keep working if the mouse + // goes off the top or bottom of the text + if( state->single_line ) + { + StbTexteditRow r; + STB_TEXTEDIT_LAYOUTROW(&r, str, 0); + y = r.ymin; + } + + state->cursor = stb_text_locate_coord(str, x, y); + state->select_start = state->cursor; + state->select_end = state->cursor; + state->has_preferred_x = 0; +} + +// API drag: on mouse drag, move the cursor and selection endpoint to the clicked location +static void stb_textedit_drag(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, float x, float y) +{ + int p = 0; + + // In single-line mode, just always make y = 0. This lets the drag keep working if the mouse + // goes off the top or bottom of the text + if( state->single_line ) + { + StbTexteditRow r; + STB_TEXTEDIT_LAYOUTROW(&r, str, 0); + y = r.ymin; + } + + if (state->select_start == state->select_end) + state->select_start = state->cursor; + + p = stb_text_locate_coord(str, x, y); + state->cursor = state->select_end = p; +} + +///////////////////////////////////////////////////////////////////////////// +// +// Keyboard input handling +// + +// forward declarations +static void stb_text_undo(STB_TEXTEDIT_STRING *str, STB_TexteditState *state); +static void stb_text_redo(STB_TEXTEDIT_STRING *str, STB_TexteditState *state); +static void stb_text_makeundo_delete(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, int where, int length); +static void stb_text_makeundo_insert(STB_TexteditState *state, int where, int length); +static void stb_text_makeundo_replace(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, int where, int old_length, int new_length); + +typedef struct +{ + float x,y; // position of n'th character + float height; // height of line + int first_char, length; // first char of row, and length + int prev_first; // first char of previous row +} StbFindState; + +// find the x/y location of a character, and remember info about the previous row in +// case we get a move-up event (for page up, we'll have to rescan) +static void stb_textedit_find_charpos(StbFindState *find, STB_TEXTEDIT_STRING *str, int n, int single_line) +{ + StbTexteditRow r; + int prev_start = 0; + int z = STB_TEXTEDIT_STRINGLEN(str); + int i=0, first; + + if (n == z) { + // if it's at the end, then find the last line -- simpler than trying to + // explicitly handle this case in the regular code + if (single_line) { + STB_TEXTEDIT_LAYOUTROW(&r, str, 0); + find->y = 0; + find->first_char = 0; + find->length = z; + find->height = r.ymax - r.ymin; + find->x = r.x1; + } else { + find->y = 0; + find->x = 0; + find->height = 1; + while (i < z) { + STB_TEXTEDIT_LAYOUTROW(&r, str, i); + prev_start = i; + i += r.num_chars; + } + find->first_char = i; + find->length = 0; + find->prev_first = prev_start; + } + return; + } + + // search rows to find the one that straddles character n + find->y = 0; + + for(;;) { + STB_TEXTEDIT_LAYOUTROW(&r, str, i); + if (n < i + r.num_chars) + break; + prev_start = i; + i += r.num_chars; + find->y += r.baseline_y_delta; + } + + find->first_char = first = i; + find->length = r.num_chars; + find->height = r.ymax - r.ymin; + find->prev_first = prev_start; + + // now scan to find xpos + find->x = r.x0; + for (i=0; first+i < n; ++i) + find->x += STB_TEXTEDIT_GETWIDTH(str, first, i); +} + +#define STB_TEXT_HAS_SELECTION(s) ((s)->select_start != (s)->select_end) + +// make the selection/cursor state valid if client altered the string +static void stb_textedit_clamp(STB_TEXTEDIT_STRING *str, STB_TexteditState *state) +{ + int n = STB_TEXTEDIT_STRINGLEN(str); + if (STB_TEXT_HAS_SELECTION(state)) { + if (state->select_start > n) state->select_start = n; + if (state->select_end > n) state->select_end = n; + // if clamping forced them to be equal, move the cursor to match + if (state->select_start == state->select_end) + state->cursor = state->select_start; + } + if (state->cursor > n) state->cursor = n; +} + +// delete characters while updating undo +static void stb_textedit_delete(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, int where, int len) +{ + stb_text_makeundo_delete(str, state, where, len); + STB_TEXTEDIT_DELETECHARS(str, where, len); + state->has_preferred_x = 0; +} + +// delete the section +static void stb_textedit_delete_selection(STB_TEXTEDIT_STRING *str, STB_TexteditState *state) +{ + stb_textedit_clamp(str, state); + if (STB_TEXT_HAS_SELECTION(state)) { + if (state->select_start < state->select_end) { + stb_textedit_delete(str, state, state->select_start, state->select_end - state->select_start); + state->select_end = state->cursor = state->select_start; + } else { + stb_textedit_delete(str, state, state->select_end, state->select_start - state->select_end); + state->select_start = state->cursor = state->select_end; + } + state->has_preferred_x = 0; + } +} + +// canoncialize the selection so start <= end +static void stb_textedit_sortselection(STB_TexteditState *state) +{ + if (state->select_end < state->select_start) { + int temp = state->select_end; + state->select_end = state->select_start; + state->select_start = temp; + } +} + +// move cursor to first character of selection +static void stb_textedit_move_to_first(STB_TexteditState *state) +{ + if (STB_TEXT_HAS_SELECTION(state)) { + stb_textedit_sortselection(state); + state->cursor = state->select_start; + state->select_end = state->select_start; + state->has_preferred_x = 0; + } +} + +// move cursor to last character of selection +static void stb_textedit_move_to_last(STB_TEXTEDIT_STRING *str, STB_TexteditState *state) +{ + if (STB_TEXT_HAS_SELECTION(state)) { + stb_textedit_sortselection(state); + stb_textedit_clamp(str, state); + state->cursor = state->select_end; + state->select_start = state->select_end; + state->has_preferred_x = 0; + } +} + +#ifdef STB_TEXTEDIT_IS_SPACE +static int is_word_boundary( STB_TEXTEDIT_STRING *str, int idx ) +{ + return idx > 0 ? (STB_TEXTEDIT_IS_SPACE( STB_TEXTEDIT_GETCHAR(str,idx-1) ) && !STB_TEXTEDIT_IS_SPACE( STB_TEXTEDIT_GETCHAR(str, idx) ) ) : 1; +} + +#ifndef STB_TEXTEDIT_MOVEWORDLEFT +static int stb_textedit_move_to_word_previous( STB_TEXTEDIT_STRING *str, int c ) +{ + --c; // always move at least one character + while( c >= 0 && !is_word_boundary( str, c ) ) + --c; + + if( c < 0 ) + c = 0; + + return c; +} +#define STB_TEXTEDIT_MOVEWORDLEFT stb_textedit_move_to_word_previous +#endif + +#ifndef STB_TEXTEDIT_MOVEWORDRIGHT +static int stb_textedit_move_to_word_next( STB_TEXTEDIT_STRING *str, int c ) +{ + const int len = STB_TEXTEDIT_STRINGLEN(str); + ++c; // always move at least one character + while( c < len && !is_word_boundary( str, c ) ) + ++c; + + if( c > len ) + c = len; + + return c; +} +#define STB_TEXTEDIT_MOVEWORDRIGHT stb_textedit_move_to_word_next +#endif + +#endif + +// update selection and cursor to match each other +static void stb_textedit_prep_selection_at_cursor(STB_TexteditState *state) +{ + if (!STB_TEXT_HAS_SELECTION(state)) + state->select_start = state->select_end = state->cursor; + else + state->cursor = state->select_end; +} + +// API cut: delete selection +static int stb_textedit_cut(STB_TEXTEDIT_STRING *str, STB_TexteditState *state) +{ + if (STB_TEXT_HAS_SELECTION(state)) { + stb_textedit_delete_selection(str,state); // implicitly clamps + state->has_preferred_x = 0; + return 1; + } + return 0; +} + +// API paste: replace existing selection with passed-in text +static int stb_textedit_paste_internal(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, STB_TEXTEDIT_CHARTYPE *text, int len) +{ + // if there's a selection, the paste should delete it + stb_textedit_clamp(str, state); + stb_textedit_delete_selection(str,state); + // try to insert the characters + if (STB_TEXTEDIT_INSERTCHARS(str, state->cursor, text, len)) { + stb_text_makeundo_insert(state, state->cursor, len); + state->cursor += len; + state->has_preferred_x = 0; + return 1; + } + // [DEAR IMGUI] + //// remove the undo since we didn't actually insert the characters + //if (state->undostate.undo_point) + // --state->undostate.undo_point; + // note: paste failure will leave deleted selection, may be restored with an undo (see https://github.com/nothings/stb/issues/734 for details) + return 0; +} + +#ifndef STB_TEXTEDIT_KEYTYPE +#define STB_TEXTEDIT_KEYTYPE int +#endif + +// API key: process a keyboard input +static void stb_textedit_key(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, STB_TEXTEDIT_KEYTYPE key) +{ +retry: + switch (key) { + default: { + int c = STB_TEXTEDIT_KEYTOTEXT(key); + if (c > 0) { + STB_TEXTEDIT_CHARTYPE ch = (STB_TEXTEDIT_CHARTYPE) c; + + // can't add newline in single-line mode + if (c == '\n' && state->single_line) + break; + + if (state->insert_mode && !STB_TEXT_HAS_SELECTION(state) && state->cursor < STB_TEXTEDIT_STRINGLEN(str)) { + stb_text_makeundo_replace(str, state, state->cursor, 1, 1); + STB_TEXTEDIT_DELETECHARS(str, state->cursor, 1); + if (STB_TEXTEDIT_INSERTCHARS(str, state->cursor, &ch, 1)) { + ++state->cursor; + state->has_preferred_x = 0; + } + } else { + stb_textedit_delete_selection(str,state); // implicitly clamps + if (STB_TEXTEDIT_INSERTCHARS(str, state->cursor, &ch, 1)) { + stb_text_makeundo_insert(state, state->cursor, 1); + ++state->cursor; + state->has_preferred_x = 0; + } + } + } + break; + } + +#ifdef STB_TEXTEDIT_K_INSERT + case STB_TEXTEDIT_K_INSERT: + state->insert_mode = !state->insert_mode; + break; +#endif + + case STB_TEXTEDIT_K_UNDO: + stb_text_undo(str, state); + state->has_preferred_x = 0; + break; + + case STB_TEXTEDIT_K_REDO: + stb_text_redo(str, state); + state->has_preferred_x = 0; + break; + + case STB_TEXTEDIT_K_LEFT: + // if currently there's a selection, move cursor to start of selection + if (STB_TEXT_HAS_SELECTION(state)) + stb_textedit_move_to_first(state); + else + if (state->cursor > 0) + --state->cursor; + state->has_preferred_x = 0; + break; + + case STB_TEXTEDIT_K_RIGHT: + // if currently there's a selection, move cursor to end of selection + if (STB_TEXT_HAS_SELECTION(state)) + stb_textedit_move_to_last(str, state); + else + ++state->cursor; + stb_textedit_clamp(str, state); + state->has_preferred_x = 0; + break; + + case STB_TEXTEDIT_K_LEFT | STB_TEXTEDIT_K_SHIFT: + stb_textedit_clamp(str, state); + stb_textedit_prep_selection_at_cursor(state); + // move selection left + if (state->select_end > 0) + --state->select_end; + state->cursor = state->select_end; + state->has_preferred_x = 0; + break; + +#ifdef STB_TEXTEDIT_MOVEWORDLEFT + case STB_TEXTEDIT_K_WORDLEFT: + if (STB_TEXT_HAS_SELECTION(state)) + stb_textedit_move_to_first(state); + else { + state->cursor = STB_TEXTEDIT_MOVEWORDLEFT(str, state->cursor); + stb_textedit_clamp( str, state ); + } + break; + + case STB_TEXTEDIT_K_WORDLEFT | STB_TEXTEDIT_K_SHIFT: + if( !STB_TEXT_HAS_SELECTION( state ) ) + stb_textedit_prep_selection_at_cursor(state); + + state->cursor = STB_TEXTEDIT_MOVEWORDLEFT(str, state->cursor); + state->select_end = state->cursor; + + stb_textedit_clamp( str, state ); + break; +#endif + +#ifdef STB_TEXTEDIT_MOVEWORDRIGHT + case STB_TEXTEDIT_K_WORDRIGHT: + if (STB_TEXT_HAS_SELECTION(state)) + stb_textedit_move_to_last(str, state); + else { + state->cursor = STB_TEXTEDIT_MOVEWORDRIGHT(str, state->cursor); + stb_textedit_clamp( str, state ); + } + break; + + case STB_TEXTEDIT_K_WORDRIGHT | STB_TEXTEDIT_K_SHIFT: + if( !STB_TEXT_HAS_SELECTION( state ) ) + stb_textedit_prep_selection_at_cursor(state); + + state->cursor = STB_TEXTEDIT_MOVEWORDRIGHT(str, state->cursor); + state->select_end = state->cursor; + + stb_textedit_clamp( str, state ); + break; +#endif + + case STB_TEXTEDIT_K_RIGHT | STB_TEXTEDIT_K_SHIFT: + stb_textedit_prep_selection_at_cursor(state); + // move selection right + ++state->select_end; + stb_textedit_clamp(str, state); + state->cursor = state->select_end; + state->has_preferred_x = 0; + break; + + case STB_TEXTEDIT_K_DOWN: + case STB_TEXTEDIT_K_DOWN | STB_TEXTEDIT_K_SHIFT: + case STB_TEXTEDIT_K_PGDOWN: + case STB_TEXTEDIT_K_PGDOWN | STB_TEXTEDIT_K_SHIFT: { + StbFindState find; + StbTexteditRow row; + int i, j, sel = (key & STB_TEXTEDIT_K_SHIFT) != 0; + int is_page = (key & ~STB_TEXTEDIT_K_SHIFT) == STB_TEXTEDIT_K_PGDOWN; + int row_count = is_page ? state->row_count_per_page : 1; + + if (!is_page && state->single_line) { + // on windows, up&down in single-line behave like left&right + key = STB_TEXTEDIT_K_RIGHT | (key & STB_TEXTEDIT_K_SHIFT); + goto retry; + } + + if (sel) + stb_textedit_prep_selection_at_cursor(state); + else if (STB_TEXT_HAS_SELECTION(state)) + stb_textedit_move_to_last(str, state); + + // compute current position of cursor point + stb_textedit_clamp(str, state); + stb_textedit_find_charpos(&find, str, state->cursor, state->single_line); + + for (j = 0; j < row_count; ++j) { + float x, goal_x = state->has_preferred_x ? state->preferred_x : find.x; + int start = find.first_char + find.length; + + if (find.length == 0) + break; + + // [DEAR IMGUI] + // going down while being on the last line shouldn't bring us to that line end + if (STB_TEXTEDIT_GETCHAR(str, find.first_char + find.length - 1) != STB_TEXTEDIT_NEWLINE) + break; + + // now find character position down a row + state->cursor = start; + STB_TEXTEDIT_LAYOUTROW(&row, str, state->cursor); + x = row.x0; + for (i=0; i < row.num_chars; ++i) { + float dx = STB_TEXTEDIT_GETWIDTH(str, start, i); + #ifdef STB_TEXTEDIT_GETWIDTH_NEWLINE + if (dx == STB_TEXTEDIT_GETWIDTH_NEWLINE) + break; + #endif + x += dx; + if (x > goal_x) + break; + ++state->cursor; + } + stb_textedit_clamp(str, state); + + state->has_preferred_x = 1; + state->preferred_x = goal_x; + + if (sel) + state->select_end = state->cursor; + + // go to next line + find.first_char = find.first_char + find.length; + find.length = row.num_chars; + } + break; + } + + case STB_TEXTEDIT_K_UP: + case STB_TEXTEDIT_K_UP | STB_TEXTEDIT_K_SHIFT: + case STB_TEXTEDIT_K_PGUP: + case STB_TEXTEDIT_K_PGUP | STB_TEXTEDIT_K_SHIFT: { + StbFindState find; + StbTexteditRow row; + int i, j, prev_scan, sel = (key & STB_TEXTEDIT_K_SHIFT) != 0; + int is_page = (key & ~STB_TEXTEDIT_K_SHIFT) == STB_TEXTEDIT_K_PGUP; + int row_count = is_page ? state->row_count_per_page : 1; + + if (!is_page && state->single_line) { + // on windows, up&down become left&right + key = STB_TEXTEDIT_K_LEFT | (key & STB_TEXTEDIT_K_SHIFT); + goto retry; + } + + if (sel) + stb_textedit_prep_selection_at_cursor(state); + else if (STB_TEXT_HAS_SELECTION(state)) + stb_textedit_move_to_first(state); + + // compute current position of cursor point + stb_textedit_clamp(str, state); + stb_textedit_find_charpos(&find, str, state->cursor, state->single_line); + + for (j = 0; j < row_count; ++j) { + float x, goal_x = state->has_preferred_x ? state->preferred_x : find.x; + + // can only go up if there's a previous row + if (find.prev_first == find.first_char) + break; + + // now find character position up a row + state->cursor = find.prev_first; + STB_TEXTEDIT_LAYOUTROW(&row, str, state->cursor); + x = row.x0; + for (i=0; i < row.num_chars; ++i) { + float dx = STB_TEXTEDIT_GETWIDTH(str, find.prev_first, i); + #ifdef STB_TEXTEDIT_GETWIDTH_NEWLINE + if (dx == STB_TEXTEDIT_GETWIDTH_NEWLINE) + break; + #endif + x += dx; + if (x > goal_x) + break; + ++state->cursor; + } + stb_textedit_clamp(str, state); + + state->has_preferred_x = 1; + state->preferred_x = goal_x; + + if (sel) + state->select_end = state->cursor; + + // go to previous line + // (we need to scan previous line the hard way. maybe we could expose this as a new API function?) + prev_scan = find.prev_first > 0 ? find.prev_first - 1 : 0; + while (prev_scan > 0 && STB_TEXTEDIT_GETCHAR(str, prev_scan - 1) != STB_TEXTEDIT_NEWLINE) + --prev_scan; + find.first_char = find.prev_first; + find.prev_first = prev_scan; + } + break; + } + + case STB_TEXTEDIT_K_DELETE: + case STB_TEXTEDIT_K_DELETE | STB_TEXTEDIT_K_SHIFT: + if (STB_TEXT_HAS_SELECTION(state)) + stb_textedit_delete_selection(str, state); + else { + int n = STB_TEXTEDIT_STRINGLEN(str); + if (state->cursor < n) + stb_textedit_delete(str, state, state->cursor, 1); + } + state->has_preferred_x = 0; + break; + + case STB_TEXTEDIT_K_BACKSPACE: + case STB_TEXTEDIT_K_BACKSPACE | STB_TEXTEDIT_K_SHIFT: + if (STB_TEXT_HAS_SELECTION(state)) + stb_textedit_delete_selection(str, state); + else { + stb_textedit_clamp(str, state); + if (state->cursor > 0) { + stb_textedit_delete(str, state, state->cursor-1, 1); + --state->cursor; + } + } + state->has_preferred_x = 0; + break; + +#ifdef STB_TEXTEDIT_K_TEXTSTART2 + case STB_TEXTEDIT_K_TEXTSTART2: +#endif + case STB_TEXTEDIT_K_TEXTSTART: + state->cursor = state->select_start = state->select_end = 0; + state->has_preferred_x = 0; + break; + +#ifdef STB_TEXTEDIT_K_TEXTEND2 + case STB_TEXTEDIT_K_TEXTEND2: +#endif + case STB_TEXTEDIT_K_TEXTEND: + state->cursor = STB_TEXTEDIT_STRINGLEN(str); + state->select_start = state->select_end = 0; + state->has_preferred_x = 0; + break; + +#ifdef STB_TEXTEDIT_K_TEXTSTART2 + case STB_TEXTEDIT_K_TEXTSTART2 | STB_TEXTEDIT_K_SHIFT: +#endif + case STB_TEXTEDIT_K_TEXTSTART | STB_TEXTEDIT_K_SHIFT: + stb_textedit_prep_selection_at_cursor(state); + state->cursor = state->select_end = 0; + state->has_preferred_x = 0; + break; + +#ifdef STB_TEXTEDIT_K_TEXTEND2 + case STB_TEXTEDIT_K_TEXTEND2 | STB_TEXTEDIT_K_SHIFT: +#endif + case STB_TEXTEDIT_K_TEXTEND | STB_TEXTEDIT_K_SHIFT: + stb_textedit_prep_selection_at_cursor(state); + state->cursor = state->select_end = STB_TEXTEDIT_STRINGLEN(str); + state->has_preferred_x = 0; + break; + + +#ifdef STB_TEXTEDIT_K_LINESTART2 + case STB_TEXTEDIT_K_LINESTART2: +#endif + case STB_TEXTEDIT_K_LINESTART: + stb_textedit_clamp(str, state); + stb_textedit_move_to_first(state); + if (state->single_line) + state->cursor = 0; + else while (state->cursor > 0 && STB_TEXTEDIT_GETCHAR(str, state->cursor-1) != STB_TEXTEDIT_NEWLINE) + --state->cursor; + state->has_preferred_x = 0; + break; + +#ifdef STB_TEXTEDIT_K_LINEEND2 + case STB_TEXTEDIT_K_LINEEND2: +#endif + case STB_TEXTEDIT_K_LINEEND: { + int n = STB_TEXTEDIT_STRINGLEN(str); + stb_textedit_clamp(str, state); + stb_textedit_move_to_first(state); + if (state->single_line) + state->cursor = n; + else while (state->cursor < n && STB_TEXTEDIT_GETCHAR(str, state->cursor) != STB_TEXTEDIT_NEWLINE) + ++state->cursor; + state->has_preferred_x = 0; + break; + } + +#ifdef STB_TEXTEDIT_K_LINESTART2 + case STB_TEXTEDIT_K_LINESTART2 | STB_TEXTEDIT_K_SHIFT: +#endif + case STB_TEXTEDIT_K_LINESTART | STB_TEXTEDIT_K_SHIFT: + stb_textedit_clamp(str, state); + stb_textedit_prep_selection_at_cursor(state); + if (state->single_line) + state->cursor = 0; + else while (state->cursor > 0 && STB_TEXTEDIT_GETCHAR(str, state->cursor-1) != STB_TEXTEDIT_NEWLINE) + --state->cursor; + state->select_end = state->cursor; + state->has_preferred_x = 0; + break; + +#ifdef STB_TEXTEDIT_K_LINEEND2 + case STB_TEXTEDIT_K_LINEEND2 | STB_TEXTEDIT_K_SHIFT: +#endif + case STB_TEXTEDIT_K_LINEEND | STB_TEXTEDIT_K_SHIFT: { + int n = STB_TEXTEDIT_STRINGLEN(str); + stb_textedit_clamp(str, state); + stb_textedit_prep_selection_at_cursor(state); + if (state->single_line) + state->cursor = n; + else while (state->cursor < n && STB_TEXTEDIT_GETCHAR(str, state->cursor) != STB_TEXTEDIT_NEWLINE) + ++state->cursor; + state->select_end = state->cursor; + state->has_preferred_x = 0; + break; + } + } +} + +///////////////////////////////////////////////////////////////////////////// +// +// Undo processing +// +// @OPTIMIZE: the undo/redo buffer should be circular + +static void stb_textedit_flush_redo(StbUndoState *state) +{ + state->redo_point = STB_TEXTEDIT_UNDOSTATECOUNT; + state->redo_char_point = STB_TEXTEDIT_UNDOCHARCOUNT; +} + +// discard the oldest entry in the undo list +static void stb_textedit_discard_undo(StbUndoState *state) +{ + if (state->undo_point > 0) { + // if the 0th undo state has characters, clean those up + if (state->undo_rec[0].char_storage >= 0) { + int n = state->undo_rec[0].insert_length, i; + // delete n characters from all other records + state->undo_char_point -= n; + STB_TEXTEDIT_memmove(state->undo_char, state->undo_char + n, (size_t) (state->undo_char_point*sizeof(STB_TEXTEDIT_CHARTYPE))); + for (i=0; i < state->undo_point; ++i) + if (state->undo_rec[i].char_storage >= 0) + state->undo_rec[i].char_storage -= n; // @OPTIMIZE: get rid of char_storage and infer it + } + --state->undo_point; + STB_TEXTEDIT_memmove(state->undo_rec, state->undo_rec+1, (size_t) (state->undo_point*sizeof(state->undo_rec[0]))); + } +} + +// discard the oldest entry in the redo list--it's bad if this +// ever happens, but because undo & redo have to store the actual +// characters in different cases, the redo character buffer can +// fill up even though the undo buffer didn't +static void stb_textedit_discard_redo(StbUndoState *state) +{ + int k = STB_TEXTEDIT_UNDOSTATECOUNT-1; + + if (state->redo_point <= k) { + // if the k'th undo state has characters, clean those up + if (state->undo_rec[k].char_storage >= 0) { + int n = state->undo_rec[k].insert_length, i; + // move the remaining redo character data to the end of the buffer + state->redo_char_point += n; + STB_TEXTEDIT_memmove(state->undo_char + state->redo_char_point, state->undo_char + state->redo_char_point-n, (size_t) ((STB_TEXTEDIT_UNDOCHARCOUNT - state->redo_char_point)*sizeof(STB_TEXTEDIT_CHARTYPE))); + // adjust the position of all the other records to account for above memmove + for (i=state->redo_point; i < k; ++i) + if (state->undo_rec[i].char_storage >= 0) + state->undo_rec[i].char_storage += n; + } + // now move all the redo records towards the end of the buffer; the first one is at 'redo_point' + // [DEAR IMGUI] + size_t move_size = (size_t)((STB_TEXTEDIT_UNDOSTATECOUNT - state->redo_point - 1) * sizeof(state->undo_rec[0])); + const char* buf_begin = (char*)state->undo_rec; (void)buf_begin; + const char* buf_end = (char*)state->undo_rec + sizeof(state->undo_rec); (void)buf_end; + IM_ASSERT(((char*)(state->undo_rec + state->redo_point)) >= buf_begin); + IM_ASSERT(((char*)(state->undo_rec + state->redo_point + 1) + move_size) <= buf_end); + STB_TEXTEDIT_memmove(state->undo_rec + state->redo_point+1, state->undo_rec + state->redo_point, move_size); + + // now move redo_point to point to the new one + ++state->redo_point; + } +} + +static StbUndoRecord *stb_text_create_undo_record(StbUndoState *state, int numchars) +{ + // any time we create a new undo record, we discard redo + stb_textedit_flush_redo(state); + + // if we have no free records, we have to make room, by sliding the + // existing records down + if (state->undo_point == STB_TEXTEDIT_UNDOSTATECOUNT) + stb_textedit_discard_undo(state); + + // if the characters to store won't possibly fit in the buffer, we can't undo + if (numchars > STB_TEXTEDIT_UNDOCHARCOUNT) { + state->undo_point = 0; + state->undo_char_point = 0; + return NULL; + } + + // if we don't have enough free characters in the buffer, we have to make room + while (state->undo_char_point + numchars > STB_TEXTEDIT_UNDOCHARCOUNT) + stb_textedit_discard_undo(state); + + return &state->undo_rec[state->undo_point++]; +} + +static STB_TEXTEDIT_CHARTYPE *stb_text_createundo(StbUndoState *state, int pos, int insert_len, int delete_len) +{ + StbUndoRecord *r = stb_text_create_undo_record(state, insert_len); + if (r == NULL) + return NULL; + + r->where = pos; + r->insert_length = (STB_TEXTEDIT_POSITIONTYPE) insert_len; + r->delete_length = (STB_TEXTEDIT_POSITIONTYPE) delete_len; + + if (insert_len == 0) { + r->char_storage = -1; + return NULL; + } else { + r->char_storage = state->undo_char_point; + state->undo_char_point += insert_len; + return &state->undo_char[r->char_storage]; + } +} + +static void stb_text_undo(STB_TEXTEDIT_STRING *str, STB_TexteditState *state) +{ + StbUndoState *s = &state->undostate; + StbUndoRecord u, *r; + if (s->undo_point == 0) + return; + + // we need to do two things: apply the undo record, and create a redo record + u = s->undo_rec[s->undo_point-1]; + r = &s->undo_rec[s->redo_point-1]; + r->char_storage = -1; + + r->insert_length = u.delete_length; + r->delete_length = u.insert_length; + r->where = u.where; + + if (u.delete_length) { + // if the undo record says to delete characters, then the redo record will + // need to re-insert the characters that get deleted, so we need to store + // them. + + // there are three cases: + // there's enough room to store the characters + // characters stored for *redoing* don't leave room for redo + // characters stored for *undoing* don't leave room for redo + // if the last is true, we have to bail + + if (s->undo_char_point + u.delete_length >= STB_TEXTEDIT_UNDOCHARCOUNT) { + // the undo records take up too much character space; there's no space to store the redo characters + r->insert_length = 0; + } else { + int i; + + // there's definitely room to store the characters eventually + while (s->undo_char_point + u.delete_length > s->redo_char_point) { + // should never happen: + if (s->redo_point == STB_TEXTEDIT_UNDOSTATECOUNT) + return; + // there's currently not enough room, so discard a redo record + stb_textedit_discard_redo(s); + } + r = &s->undo_rec[s->redo_point-1]; + + r->char_storage = s->redo_char_point - u.delete_length; + s->redo_char_point = s->redo_char_point - u.delete_length; + + // now save the characters + for (i=0; i < u.delete_length; ++i) + s->undo_char[r->char_storage + i] = STB_TEXTEDIT_GETCHAR(str, u.where + i); + } + + // now we can carry out the deletion + STB_TEXTEDIT_DELETECHARS(str, u.where, u.delete_length); + } + + // check type of recorded action: + if (u.insert_length) { + // easy case: was a deletion, so we need to insert n characters + STB_TEXTEDIT_INSERTCHARS(str, u.where, &s->undo_char[u.char_storage], u.insert_length); + s->undo_char_point -= u.insert_length; + } + + state->cursor = u.where + u.insert_length; + + s->undo_point--; + s->redo_point--; +} + +static void stb_text_redo(STB_TEXTEDIT_STRING *str, STB_TexteditState *state) +{ + StbUndoState *s = &state->undostate; + StbUndoRecord *u, r; + if (s->redo_point == STB_TEXTEDIT_UNDOSTATECOUNT) + return; + + // we need to do two things: apply the redo record, and create an undo record + u = &s->undo_rec[s->undo_point]; + r = s->undo_rec[s->redo_point]; + + // we KNOW there must be room for the undo record, because the redo record + // was derived from an undo record + + u->delete_length = r.insert_length; + u->insert_length = r.delete_length; + u->where = r.where; + u->char_storage = -1; + + if (r.delete_length) { + // the redo record requires us to delete characters, so the undo record + // needs to store the characters + + if (s->undo_char_point + u->insert_length > s->redo_char_point) { + u->insert_length = 0; + u->delete_length = 0; + } else { + int i; + u->char_storage = s->undo_char_point; + s->undo_char_point = s->undo_char_point + u->insert_length; + + // now save the characters + for (i=0; i < u->insert_length; ++i) + s->undo_char[u->char_storage + i] = STB_TEXTEDIT_GETCHAR(str, u->where + i); + } + + STB_TEXTEDIT_DELETECHARS(str, r.where, r.delete_length); + } + + if (r.insert_length) { + // easy case: need to insert n characters + STB_TEXTEDIT_INSERTCHARS(str, r.where, &s->undo_char[r.char_storage], r.insert_length); + s->redo_char_point += r.insert_length; + } + + state->cursor = r.where + r.insert_length; + + s->undo_point++; + s->redo_point++; +} + +static void stb_text_makeundo_insert(STB_TexteditState *state, int where, int length) +{ + stb_text_createundo(&state->undostate, where, 0, length); +} + +static void stb_text_makeundo_delete(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, int where, int length) +{ + int i; + STB_TEXTEDIT_CHARTYPE *p = stb_text_createundo(&state->undostate, where, length, 0); + if (p) { + for (i=0; i < length; ++i) + p[i] = STB_TEXTEDIT_GETCHAR(str, where+i); + } +} + +static void stb_text_makeundo_replace(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, int where, int old_length, int new_length) +{ + int i; + STB_TEXTEDIT_CHARTYPE *p = stb_text_createundo(&state->undostate, where, old_length, new_length); + if (p) { + for (i=0; i < old_length; ++i) + p[i] = STB_TEXTEDIT_GETCHAR(str, where+i); + } +} + +// reset the state to default +static void stb_textedit_clear_state(STB_TexteditState *state, int is_single_line) +{ + state->undostate.undo_point = 0; + state->undostate.undo_char_point = 0; + state->undostate.redo_point = STB_TEXTEDIT_UNDOSTATECOUNT; + state->undostate.redo_char_point = STB_TEXTEDIT_UNDOCHARCOUNT; + state->select_end = state->select_start = 0; + state->cursor = 0; + state->has_preferred_x = 0; + state->preferred_x = 0; + state->cursor_at_end_of_line = 0; + state->initialized = 1; + state->single_line = (unsigned char) is_single_line; + state->insert_mode = 0; + state->row_count_per_page = 0; +} + +// API initialize +static void stb_textedit_initialize_state(STB_TexteditState *state, int is_single_line) +{ + stb_textedit_clear_state(state, is_single_line); +} + +#if defined(__GNUC__) || defined(__clang__) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wcast-qual" +#endif + +static int stb_textedit_paste(STB_TEXTEDIT_STRING *str, STB_TexteditState *state, STB_TEXTEDIT_CHARTYPE const *ctext, int len) +{ + return stb_textedit_paste_internal(str, state, (STB_TEXTEDIT_CHARTYPE *) ctext, len); +} + +#if defined(__GNUC__) || defined(__clang__) +#pragma GCC diagnostic pop +#endif + +#endif//STB_TEXTEDIT_IMPLEMENTATION + +/* +------------------------------------------------------------------------------ +This software is available under 2 licenses -- choose whichever you prefer. +------------------------------------------------------------------------------ +ALTERNATIVE A - MIT License +Copyright (c) 2017 Sean Barrett +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. +------------------------------------------------------------------------------ +ALTERNATIVE B - Public Domain (www.unlicense.org) +This is free and unencumbered software released into the public domain. +Anyone is free to copy, modify, publish, use, compile, sell, or distribute this +software, either in source code form or as a compiled binary, for any purpose, +commercial or non-commercial, and by any means. +In jurisdictions that recognize copyright laws, the author or authors of this +software dedicate any and all copyright interest in the software to the public +domain. We make this dedication for the benefit of the public at large and to +the detriment of our heirs and successors. We intend this dedication to be an +overt act of relinquishment in perpetuity of all present and future rights to +this software under copyright law. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +------------------------------------------------------------------------------ +*/ diff --git a/source/editor/imgui/imstb_truetype.h b/source/editor/imgui/imstb_truetype.h new file mode 100644 index 0000000..48c2026 --- /dev/null +++ b/source/editor/imgui/imstb_truetype.h @@ -0,0 +1,4903 @@ +// [DEAR IMGUI] +// This is a slightly modified version of stb_truetype.h 1.20. +// Mostly fixing for compiler and static analyzer warnings. +// Grep for [DEAR IMGUI] to find the changes. + +// stb_truetype.h - v1.20 - public domain +// authored from 2009-2016 by Sean Barrett / RAD Game Tools +// +// This library processes TrueType files: +// parse files +// extract glyph metrics +// extract glyph shapes +// render glyphs to one-channel bitmaps with antialiasing (box filter) +// render glyphs to one-channel SDF bitmaps (signed-distance field/function) +// +// Todo: +// non-MS cmaps +// crashproof on bad data +// hinting? (no longer patented) +// cleartype-style AA? +// optimize: use simple memory allocator for intermediates +// optimize: build edge-list directly from curves +// optimize: rasterize directly from curves? +// +// ADDITIONAL CONTRIBUTORS +// +// Mikko Mononen: compound shape support, more cmap formats +// Tor Andersson: kerning, subpixel rendering +// Dougall Johnson: OpenType / Type 2 font handling +// Daniel Ribeiro Maciel: basic GPOS-based kerning +// +// Misc other: +// Ryan Gordon +// Simon Glass +// github:IntellectualKitty +// Imanol Celaya +// Daniel Ribeiro Maciel +// +// Bug/warning reports/fixes: +// "Zer" on mollyrocket Fabian "ryg" Giesen +// Cass Everitt Martins Mozeiko +// stoiko (Haemimont Games) Cap Petschulat +// Brian Hook Omar Cornut +// Walter van Niftrik github:aloucks +// David Gow Peter LaValle +// David Given Sergey Popov +// Ivan-Assen Ivanov Giumo X. Clanjor +// Anthony Pesch Higor Euripedes +// Johan Duparc Thomas Fields +// Hou Qiming Derek Vinyard +// Rob Loach Cort Stratton +// Kenney Phillis Jr. github:oyvindjam +// Brian Costabile github:vassvik +// +// VERSION HISTORY +// +// 1.20 (2019-02-07) PackFontRange skips missing codepoints; GetScaleFontVMetrics() +// 1.19 (2018-02-11) GPOS kerning, STBTT_fmod +// 1.18 (2018-01-29) add missing function +// 1.17 (2017-07-23) make more arguments const; doc fix +// 1.16 (2017-07-12) SDF support +// 1.15 (2017-03-03) make more arguments const +// 1.14 (2017-01-16) num-fonts-in-TTC function +// 1.13 (2017-01-02) support OpenType fonts, certain Apple fonts +// 1.12 (2016-10-25) suppress warnings about casting away const with -Wcast-qual +// 1.11 (2016-04-02) fix unused-variable warning +// 1.10 (2016-04-02) user-defined fabs(); rare memory leak; remove duplicate typedef +// 1.09 (2016-01-16) warning fix; avoid crash on outofmem; use allocation userdata properly +// 1.08 (2015-09-13) document stbtt_Rasterize(); fixes for vertical & horizontal edges +// 1.07 (2015-08-01) allow PackFontRanges to accept arrays of sparse codepoints; +// variant PackFontRanges to pack and render in separate phases; +// fix stbtt_GetFontOFfsetForIndex (never worked for non-0 input?); +// fixed an assert() bug in the new rasterizer +// replace assert() with STBTT_assert() in new rasterizer +// +// Full history can be found at the end of this file. +// +// LICENSE +// +// See end of file for license information. +// +// USAGE +// +// Include this file in whatever places need to refer to it. In ONE C/C++ +// file, write: +// #define STB_TRUETYPE_IMPLEMENTATION +// before the #include of this file. This expands out the actual +// implementation into that C/C++ file. +// +// To make the implementation private to the file that generates the implementation, +// #define STBTT_STATIC +// +// Simple 3D API (don't ship this, but it's fine for tools and quick start) +// stbtt_BakeFontBitmap() -- bake a font to a bitmap for use as texture +// stbtt_GetBakedQuad() -- compute quad to draw for a given char +// +// Improved 3D API (more shippable): +// #include "stb_rect_pack.h" -- optional, but you really want it +// stbtt_PackBegin() +// stbtt_PackSetOversampling() -- for improved quality on small fonts +// stbtt_PackFontRanges() -- pack and renders +// stbtt_PackEnd() +// stbtt_GetPackedQuad() +// +// "Load" a font file from a memory buffer (you have to keep the buffer loaded) +// stbtt_InitFont() +// stbtt_GetFontOffsetForIndex() -- indexing for TTC font collections +// stbtt_GetNumberOfFonts() -- number of fonts for TTC font collections +// +// Render a unicode codepoint to a bitmap +// stbtt_GetCodepointBitmap() -- allocates and returns a bitmap +// stbtt_MakeCodepointBitmap() -- renders into bitmap you provide +// stbtt_GetCodepointBitmapBox() -- how big the bitmap must be +// +// Character advance/positioning +// stbtt_GetCodepointHMetrics() +// stbtt_GetFontVMetrics() +// stbtt_GetFontVMetricsOS2() +// stbtt_GetCodepointKernAdvance() +// +// Starting with version 1.06, the rasterizer was replaced with a new, +// faster and generally-more-precise rasterizer. The new rasterizer more +// accurately measures pixel coverage for anti-aliasing, except in the case +// where multiple shapes overlap, in which case it overestimates the AA pixel +// coverage. Thus, anti-aliasing of intersecting shapes may look wrong. If +// this turns out to be a problem, you can re-enable the old rasterizer with +// #define STBTT_RASTERIZER_VERSION 1 +// which will incur about a 15% speed hit. +// +// ADDITIONAL DOCUMENTATION +// +// Immediately after this block comment are a series of sample programs. +// +// After the sample programs is the "header file" section. This section +// includes documentation for each API function. +// +// Some important concepts to understand to use this library: +// +// Codepoint +// Characters are defined by unicode codepoints, e.g. 65 is +// uppercase A, 231 is lowercase c with a cedilla, 0x7e30 is +// the hiragana for "ma". +// +// Glyph +// A visual character shape (every codepoint is rendered as +// some glyph) +// +// Glyph index +// A font-specific integer ID representing a glyph +// +// Baseline +// Glyph shapes are defined relative to a baseline, which is the +// bottom of uppercase characters. Characters extend both above +// and below the baseline. +// +// Current Point +// As you draw text to the screen, you keep track of a "current point" +// which is the origin of each character. The current point's vertical +// position is the baseline. Even "baked fonts" use this model. +// +// Vertical Font Metrics +// The vertical qualities of the font, used to vertically position +// and space the characters. See docs for stbtt_GetFontVMetrics. +// +// Font Size in Pixels or Points +// The preferred interface for specifying font sizes in stb_truetype +// is to specify how tall the font's vertical extent should be in pixels. +// If that sounds good enough, skip the next paragraph. +// +// Most font APIs instead use "points", which are a common typographic +// measurement for describing font size, defined as 72 points per inch. +// stb_truetype provides a point API for compatibility. However, true +// "per inch" conventions don't make much sense on computer displays +// since different monitors have different number of pixels per +// inch. For example, Windows traditionally uses a convention that +// there are 96 pixels per inch, thus making 'inch' measurements have +// nothing to do with inches, and thus effectively defining a point to +// be 1.333 pixels. Additionally, the TrueType font data provides +// an explicit scale factor to scale a given font's glyphs to points, +// but the author has observed that this scale factor is often wrong +// for non-commercial fonts, thus making fonts scaled in points +// according to the TrueType spec incoherently sized in practice. +// +// DETAILED USAGE: +// +// Scale: +// Select how high you want the font to be, in points or pixels. +// Call ScaleForPixelHeight or ScaleForMappingEmToPixels to compute +// a scale factor SF that will be used by all other functions. +// +// Baseline: +// You need to select a y-coordinate that is the baseline of where +// your text will appear. Call GetFontBoundingBox to get the baseline-relative +// bounding box for all characters. SF*-y0 will be the distance in pixels +// that the worst-case character could extend above the baseline, so if +// you want the top edge of characters to appear at the top of the +// screen where y=0, then you would set the baseline to SF*-y0. +// +// Current point: +// Set the current point where the first character will appear. The +// first character could extend left of the current point; this is font +// dependent. You can either choose a current point that is the leftmost +// point and hope, or add some padding, or check the bounding box or +// left-side-bearing of the first character to be displayed and set +// the current point based on that. +// +// Displaying a character: +// Compute the bounding box of the character. It will contain signed values +// relative to . I.e. if it returns x0,y0,x1,y1, +// then the character should be displayed in the rectangle from +// to = 32 && *text < 128) { + stbtt_aligned_quad q; + stbtt_GetBakedQuad(cdata, 512,512, *text-32, &x,&y,&q,1);//1=opengl & d3d10+,0=d3d9 + glTexCoord2f(q.s0,q.t1); glVertex2f(q.x0,q.y0); + glTexCoord2f(q.s1,q.t1); glVertex2f(q.x1,q.y0); + glTexCoord2f(q.s1,q.t0); glVertex2f(q.x1,q.y1); + glTexCoord2f(q.s0,q.t0); glVertex2f(q.x0,q.y1); + } + ++text; + } + glEnd(); +} +#endif +// +// +////////////////////////////////////////////////////////////////////////////// +// +// Complete program (this compiles): get a single bitmap, print as ASCII art +// +#if 0 +#include +#define STB_TRUETYPE_IMPLEMENTATION // force following include to generate implementation +#include "stb_truetype.h" + +char ttf_buffer[1<<25]; + +int main(int argc, char **argv) +{ + stbtt_fontinfo font; + unsigned char *bitmap; + int w,h,i,j,c = (argc > 1 ? atoi(argv[1]) : 'a'), s = (argc > 2 ? atoi(argv[2]) : 20); + + fread(ttf_buffer, 1, 1<<25, fopen(argc > 3 ? argv[3] : "c:/windows/fonts/arialbd.ttf", "rb")); + + stbtt_InitFont(&font, ttf_buffer, stbtt_GetFontOffsetForIndex(ttf_buffer,0)); + bitmap = stbtt_GetCodepointBitmap(&font, 0,stbtt_ScaleForPixelHeight(&font, s), c, &w, &h, 0,0); + + for (j=0; j < h; ++j) { + for (i=0; i < w; ++i) + putchar(" .:ioVM@"[bitmap[j*w+i]>>5]); + putchar('\n'); + } + return 0; +} +#endif +// +// Output: +// +// .ii. +// @@@@@@. +// V@Mio@@o +// :i. V@V +// :oM@@M +// :@@@MM@M +// @@o o@M +// :@@. M@M +// @@@o@@@@ +// :M@@V:@@. +// +////////////////////////////////////////////////////////////////////////////// +// +// Complete program: print "Hello World!" banner, with bugs +// +#if 0 +char buffer[24<<20]; +unsigned char screen[20][79]; + +int main(int arg, char **argv) +{ + stbtt_fontinfo font; + int i,j,ascent,baseline,ch=0; + float scale, xpos=2; // leave a little padding in case the character extends left + char *text = "Heljo World!"; // intentionally misspelled to show 'lj' brokenness + + fread(buffer, 1, 1000000, fopen("c:/windows/fonts/arialbd.ttf", "rb")); + stbtt_InitFont(&font, buffer, 0); + + scale = stbtt_ScaleForPixelHeight(&font, 15); + stbtt_GetFontVMetrics(&font, &ascent,0,0); + baseline = (int) (ascent*scale); + + while (text[ch]) { + int advance,lsb,x0,y0,x1,y1; + float x_shift = xpos - (float) floor(xpos); + stbtt_GetCodepointHMetrics(&font, text[ch], &advance, &lsb); + stbtt_GetCodepointBitmapBoxSubpixel(&font, text[ch], scale,scale,x_shift,0, &x0,&y0,&x1,&y1); + stbtt_MakeCodepointBitmapSubpixel(&font, &screen[baseline + y0][(int) xpos + x0], x1-x0,y1-y0, 79, scale,scale,x_shift,0, text[ch]); + // note that this stomps the old data, so where character boxes overlap (e.g. 'lj') it's wrong + // because this API is really for baking character bitmaps into textures. if you want to render + // a sequence of characters, you really need to render each bitmap to a temp buffer, then + // "alpha blend" that into the working buffer + xpos += (advance * scale); + if (text[ch+1]) + xpos += scale*stbtt_GetCodepointKernAdvance(&font, text[ch],text[ch+1]); + ++ch; + } + + for (j=0; j < 20; ++j) { + for (i=0; i < 78; ++i) + putchar(" .:ioVM@"[screen[j][i]>>5]); + putchar('\n'); + } + + return 0; +} +#endif + + +////////////////////////////////////////////////////////////////////////////// +////////////////////////////////////////////////////////////////////////////// +//// +//// INTEGRATION WITH YOUR CODEBASE +//// +//// The following sections allow you to supply alternate definitions +//// of C library functions used by stb_truetype, e.g. if you don't +//// link with the C runtime library. + +#ifdef STB_TRUETYPE_IMPLEMENTATION + // #define your own (u)stbtt_int8/16/32 before including to override this + #ifndef stbtt_uint8 + typedef unsigned char stbtt_uint8; + typedef signed char stbtt_int8; + typedef unsigned short stbtt_uint16; + typedef signed short stbtt_int16; + typedef unsigned int stbtt_uint32; + typedef signed int stbtt_int32; + #endif + + typedef char stbtt__check_size32[sizeof(stbtt_int32)==4 ? 1 : -1]; + typedef char stbtt__check_size16[sizeof(stbtt_int16)==2 ? 1 : -1]; + + // e.g. #define your own STBTT_ifloor/STBTT_iceil() to avoid math.h + #ifndef STBTT_ifloor + #include + #define STBTT_ifloor(x) ((int) floor(x)) + #define STBTT_iceil(x) ((int) ceil(x)) + #endif + + #ifndef STBTT_sqrt + #include + #define STBTT_sqrt(x) sqrt(x) + #define STBTT_pow(x,y) pow(x,y) + #endif + + #ifndef STBTT_fmod + #include + #define STBTT_fmod(x,y) fmod(x,y) + #endif + + #ifndef STBTT_cos + #include + #define STBTT_cos(x) cos(x) + #define STBTT_acos(x) acos(x) + #endif + + #ifndef STBTT_fabs + #include + #define STBTT_fabs(x) fabs(x) + #endif + + // #define your own functions "STBTT_malloc" / "STBTT_free" to avoid malloc.h + #ifndef STBTT_malloc + #include + #define STBTT_malloc(x,u) ((void)(u),malloc(x)) + #define STBTT_free(x,u) ((void)(u),free(x)) + #endif + + #ifndef STBTT_assert + #include + #define STBTT_assert(x) assert(x) + #endif + + #ifndef STBTT_strlen + #include + #define STBTT_strlen(x) strlen(x) + #endif + + #ifndef STBTT_memcpy + #include + #define STBTT_memcpy memcpy + #define STBTT_memset memset + #endif +#endif + +/////////////////////////////////////////////////////////////////////////////// +/////////////////////////////////////////////////////////////////////////////// +//// +//// INTERFACE +//// +//// + +#ifndef __STB_INCLUDE_STB_TRUETYPE_H__ +#define __STB_INCLUDE_STB_TRUETYPE_H__ + +#ifdef STBTT_STATIC +#define STBTT_DEF static +#else +#define STBTT_DEF extern +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +// private structure +typedef struct +{ + unsigned char *data; + int cursor; + int size; +} stbtt__buf; + +////////////////////////////////////////////////////////////////////////////// +// +// TEXTURE BAKING API +// +// If you use this API, you only have to call two functions ever. +// + +typedef struct +{ + unsigned short x0,y0,x1,y1; // coordinates of bbox in bitmap + float xoff,yoff,xadvance; +} stbtt_bakedchar; + +STBTT_DEF int stbtt_BakeFontBitmap(const unsigned char *data, int offset, // font location (use offset=0 for plain .ttf) + float pixel_height, // height of font in pixels + unsigned char *pixels, int pw, int ph, // bitmap to be filled in + int first_char, int num_chars, // characters to bake + stbtt_bakedchar *chardata); // you allocate this, it's num_chars long +// if return is positive, the first unused row of the bitmap +// if return is negative, returns the negative of the number of characters that fit +// if return is 0, no characters fit and no rows were used +// This uses a very crappy packing. + +typedef struct +{ + float x0,y0,s0,t0; // top-left + float x1,y1,s1,t1; // bottom-right +} stbtt_aligned_quad; + +STBTT_DEF void stbtt_GetBakedQuad(const stbtt_bakedchar *chardata, int pw, int ph, // same data as above + int char_index, // character to display + float *xpos, float *ypos, // pointers to current position in screen pixel space + stbtt_aligned_quad *q, // output: quad to draw + int opengl_fillrule); // true if opengl fill rule; false if DX9 or earlier +// Call GetBakedQuad with char_index = 'character - first_char', and it +// creates the quad you need to draw and advances the current position. +// +// The coordinate system used assumes y increases downwards. +// +// Characters will extend both above and below the current position; +// see discussion of "BASELINE" above. +// +// It's inefficient; you might want to c&p it and optimize it. + +STBTT_DEF void stbtt_GetScaledFontVMetrics(const unsigned char *fontdata, int index, float size, float *ascent, float *descent, float *lineGap); +// Query the font vertical metrics without having to create a font first. + + +////////////////////////////////////////////////////////////////////////////// +// +// NEW TEXTURE BAKING API +// +// This provides options for packing multiple fonts into one atlas, not +// perfectly but better than nothing. + +typedef struct +{ + unsigned short x0,y0,x1,y1; // coordinates of bbox in bitmap + float xoff,yoff,xadvance; + float xoff2,yoff2; +} stbtt_packedchar; + +typedef struct stbtt_pack_context stbtt_pack_context; +typedef struct stbtt_fontinfo stbtt_fontinfo; +#ifndef STB_RECT_PACK_VERSION +typedef struct stbrp_rect stbrp_rect; +#endif + +STBTT_DEF int stbtt_PackBegin(stbtt_pack_context *spc, unsigned char *pixels, int width, int height, int stride_in_bytes, int padding, void *alloc_context); +// Initializes a packing context stored in the passed-in stbtt_pack_context. +// Future calls using this context will pack characters into the bitmap passed +// in here: a 1-channel bitmap that is width * height. stride_in_bytes is +// the distance from one row to the next (or 0 to mean they are packed tightly +// together). "padding" is the amount of padding to leave between each +// character (normally you want '1' for bitmaps you'll use as textures with +// bilinear filtering). +// +// Returns 0 on failure, 1 on success. + +STBTT_DEF void stbtt_PackEnd (stbtt_pack_context *spc); +// Cleans up the packing context and frees all memory. + +#define STBTT_POINT_SIZE(x) (-(x)) + +STBTT_DEF int stbtt_PackFontRange(stbtt_pack_context *spc, const unsigned char *fontdata, int font_index, float font_size, + int first_unicode_char_in_range, int num_chars_in_range, stbtt_packedchar *chardata_for_range); +// Creates character bitmaps from the font_index'th font found in fontdata (use +// font_index=0 if you don't know what that is). It creates num_chars_in_range +// bitmaps for characters with unicode values starting at first_unicode_char_in_range +// and increasing. Data for how to render them is stored in chardata_for_range; +// pass these to stbtt_GetPackedQuad to get back renderable quads. +// +// font_size is the full height of the character from ascender to descender, +// as computed by stbtt_ScaleForPixelHeight. To use a point size as computed +// by stbtt_ScaleForMappingEmToPixels, wrap the point size in STBTT_POINT_SIZE() +// and pass that result as 'font_size': +// ..., 20 , ... // font max minus min y is 20 pixels tall +// ..., STBTT_POINT_SIZE(20), ... // 'M' is 20 pixels tall + +typedef struct +{ + float font_size; + int first_unicode_codepoint_in_range; // if non-zero, then the chars are continuous, and this is the first codepoint + int *array_of_unicode_codepoints; // if non-zero, then this is an array of unicode codepoints + int num_chars; + stbtt_packedchar *chardata_for_range; // output + unsigned char h_oversample, v_oversample; // don't set these, they're used internally +} stbtt_pack_range; + +STBTT_DEF int stbtt_PackFontRanges(stbtt_pack_context *spc, const unsigned char *fontdata, int font_index, stbtt_pack_range *ranges, int num_ranges); +// Creates character bitmaps from multiple ranges of characters stored in +// ranges. This will usually create a better-packed bitmap than multiple +// calls to stbtt_PackFontRange. Note that you can call this multiple +// times within a single PackBegin/PackEnd. + +STBTT_DEF void stbtt_PackSetOversampling(stbtt_pack_context *spc, unsigned int h_oversample, unsigned int v_oversample); +// Oversampling a font increases the quality by allowing higher-quality subpixel +// positioning, and is especially valuable at smaller text sizes. +// +// This function sets the amount of oversampling for all following calls to +// stbtt_PackFontRange(s) or stbtt_PackFontRangesGatherRects for a given +// pack context. The default (no oversampling) is achieved by h_oversample=1 +// and v_oversample=1. The total number of pixels required is +// h_oversample*v_oversample larger than the default; for example, 2x2 +// oversampling requires 4x the storage of 1x1. For best results, render +// oversampled textures with bilinear filtering. Look at the readme in +// stb/tests/oversample for information about oversampled fonts +// +// To use with PackFontRangesGather etc., you must set it before calls +// call to PackFontRangesGatherRects. + +STBTT_DEF void stbtt_PackSetSkipMissingCodepoints(stbtt_pack_context *spc, int skip); +// If skip != 0, this tells stb_truetype to skip any codepoints for which +// there is no corresponding glyph. If skip=0, which is the default, then +// codepoints without a glyph recived the font's "missing character" glyph, +// typically an empty box by convention. + +STBTT_DEF void stbtt_GetPackedQuad(const stbtt_packedchar *chardata, int pw, int ph, // same data as above + int char_index, // character to display + float *xpos, float *ypos, // pointers to current position in screen pixel space + stbtt_aligned_quad *q, // output: quad to draw + int align_to_integer); + +STBTT_DEF int stbtt_PackFontRangesGatherRects(stbtt_pack_context *spc, const stbtt_fontinfo *info, stbtt_pack_range *ranges, int num_ranges, stbrp_rect *rects); +STBTT_DEF void stbtt_PackFontRangesPackRects(stbtt_pack_context *spc, stbrp_rect *rects, int num_rects); +STBTT_DEF int stbtt_PackFontRangesRenderIntoRects(stbtt_pack_context *spc, const stbtt_fontinfo *info, stbtt_pack_range *ranges, int num_ranges, stbrp_rect *rects); +// Calling these functions in sequence is roughly equivalent to calling +// stbtt_PackFontRanges(). If you more control over the packing of multiple +// fonts, or if you want to pack custom data into a font texture, take a look +// at the source to of stbtt_PackFontRanges() and create a custom version +// using these functions, e.g. call GatherRects multiple times, +// building up a single array of rects, then call PackRects once, +// then call RenderIntoRects repeatedly. This may result in a +// better packing than calling PackFontRanges multiple times +// (or it may not). + +// this is an opaque structure that you shouldn't mess with which holds +// all the context needed from PackBegin to PackEnd. +struct stbtt_pack_context { + void *user_allocator_context; + void *pack_info; + int width; + int height; + int stride_in_bytes; + int padding; + int skip_missing; + unsigned int h_oversample, v_oversample; + unsigned char *pixels; + void *nodes; +}; + +////////////////////////////////////////////////////////////////////////////// +// +// FONT LOADING +// +// + +STBTT_DEF int stbtt_GetNumberOfFonts(const unsigned char *data); +// This function will determine the number of fonts in a font file. TrueType +// collection (.ttc) files may contain multiple fonts, while TrueType font +// (.ttf) files only contain one font. The number of fonts can be used for +// indexing with the previous function where the index is between zero and one +// less than the total fonts. If an error occurs, -1 is returned. + +STBTT_DEF int stbtt_GetFontOffsetForIndex(const unsigned char *data, int index); +// Each .ttf/.ttc file may have more than one font. Each font has a sequential +// index number starting from 0. Call this function to get the font offset for +// a given index; it returns -1 if the index is out of range. A regular .ttf +// file will only define one font and it always be at offset 0, so it will +// return '0' for index 0, and -1 for all other indices. + +// The following structure is defined publicly so you can declare one on +// the stack or as a global or etc, but you should treat it as opaque. +struct stbtt_fontinfo +{ + void * userdata; + unsigned char * data; // pointer to .ttf file + int fontstart; // offset of start of font + + int numGlyphs; // number of glyphs, needed for range checking + + int loca,head,glyf,hhea,hmtx,kern,gpos; // table locations as offset from start of .ttf + int index_map; // a cmap mapping for our chosen character encoding + int indexToLocFormat; // format needed to map from glyph index to glyph + + stbtt__buf cff; // cff font data + stbtt__buf charstrings; // the charstring index + stbtt__buf gsubrs; // global charstring subroutines index + stbtt__buf subrs; // private charstring subroutines index + stbtt__buf fontdicts; // array of font dicts + stbtt__buf fdselect; // map from glyph to fontdict +}; + +STBTT_DEF int stbtt_InitFont(stbtt_fontinfo *info, const unsigned char *data, int offset); +// Given an offset into the file that defines a font, this function builds +// the necessary cached info for the rest of the system. You must allocate +// the stbtt_fontinfo yourself, and stbtt_InitFont will fill it out. You don't +// need to do anything special to free it, because the contents are pure +// value data with no additional data structures. Returns 0 on failure. + + +////////////////////////////////////////////////////////////////////////////// +// +// CHARACTER TO GLYPH-INDEX CONVERSIOn + +STBTT_DEF int stbtt_FindGlyphIndex(const stbtt_fontinfo *info, int unicode_codepoint); +// If you're going to perform multiple operations on the same character +// and you want a speed-up, call this function with the character you're +// going to process, then use glyph-based functions instead of the +// codepoint-based functions. +// Returns 0 if the character codepoint is not defined in the font. + + +////////////////////////////////////////////////////////////////////////////// +// +// CHARACTER PROPERTIES +// + +STBTT_DEF float stbtt_ScaleForPixelHeight(const stbtt_fontinfo *info, float pixels); +// computes a scale factor to produce a font whose "height" is 'pixels' tall. +// Height is measured as the distance from the highest ascender to the lowest +// descender; in other words, it's equivalent to calling stbtt_GetFontVMetrics +// and computing: +// scale = pixels / (ascent - descent) +// so if you prefer to measure height by the ascent only, use a similar calculation. + +STBTT_DEF float stbtt_ScaleForMappingEmToPixels(const stbtt_fontinfo *info, float pixels); +// computes a scale factor to produce a font whose EM size is mapped to +// 'pixels' tall. This is probably what traditional APIs compute, but +// I'm not positive. + +STBTT_DEF void stbtt_GetFontVMetrics(const stbtt_fontinfo *info, int *ascent, int *descent, int *lineGap); +// ascent is the coordinate above the baseline the font extends; descent +// is the coordinate below the baseline the font extends (i.e. it is typically negative) +// lineGap is the spacing between one row's descent and the next row's ascent... +// so you should advance the vertical position by "*ascent - *descent + *lineGap" +// these are expressed in unscaled coordinates, so you must multiply by +// the scale factor for a given size + +STBTT_DEF int stbtt_GetFontVMetricsOS2(const stbtt_fontinfo *info, int *typoAscent, int *typoDescent, int *typoLineGap); +// analogous to GetFontVMetrics, but returns the "typographic" values from the OS/2 +// table (specific to MS/Windows TTF files). +// +// Returns 1 on success (table present), 0 on failure. + +STBTT_DEF void stbtt_GetFontBoundingBox(const stbtt_fontinfo *info, int *x0, int *y0, int *x1, int *y1); +// the bounding box around all possible characters + +STBTT_DEF void stbtt_GetCodepointHMetrics(const stbtt_fontinfo *info, int codepoint, int *advanceWidth, int *leftSideBearing); +// leftSideBearing is the offset from the current horizontal position to the left edge of the character +// advanceWidth is the offset from the current horizontal position to the next horizontal position +// these are expressed in unscaled coordinates + +STBTT_DEF int stbtt_GetCodepointKernAdvance(const stbtt_fontinfo *info, int ch1, int ch2); +// an additional amount to add to the 'advance' value between ch1 and ch2 + +STBTT_DEF int stbtt_GetCodepointBox(const stbtt_fontinfo *info, int codepoint, int *x0, int *y0, int *x1, int *y1); +// Gets the bounding box of the visible part of the glyph, in unscaled coordinates + +STBTT_DEF void stbtt_GetGlyphHMetrics(const stbtt_fontinfo *info, int glyph_index, int *advanceWidth, int *leftSideBearing); +STBTT_DEF int stbtt_GetGlyphKernAdvance(const stbtt_fontinfo *info, int glyph1, int glyph2); +STBTT_DEF int stbtt_GetGlyphBox(const stbtt_fontinfo *info, int glyph_index, int *x0, int *y0, int *x1, int *y1); +// as above, but takes one or more glyph indices for greater efficiency + + +////////////////////////////////////////////////////////////////////////////// +// +// GLYPH SHAPES (you probably don't need these, but they have to go before +// the bitmaps for C declaration-order reasons) +// + +#ifndef STBTT_vmove // you can predefine these to use different values (but why?) + enum { + STBTT_vmove=1, + STBTT_vline, + STBTT_vcurve, + STBTT_vcubic + }; +#endif + +#ifndef stbtt_vertex // you can predefine this to use different values + // (we share this with other code at RAD) + #define stbtt_vertex_type short // can't use stbtt_int16 because that's not visible in the header file + typedef struct + { + stbtt_vertex_type x,y,cx,cy,cx1,cy1; + unsigned char type,padding; + } stbtt_vertex; +#endif + +STBTT_DEF int stbtt_IsGlyphEmpty(const stbtt_fontinfo *info, int glyph_index); +// returns non-zero if nothing is drawn for this glyph + +STBTT_DEF int stbtt_GetCodepointShape(const stbtt_fontinfo *info, int unicode_codepoint, stbtt_vertex **vertices); +STBTT_DEF int stbtt_GetGlyphShape(const stbtt_fontinfo *info, int glyph_index, stbtt_vertex **vertices); +// returns # of vertices and fills *vertices with the pointer to them +// these are expressed in "unscaled" coordinates +// +// The shape is a series of contours. Each one starts with +// a STBTT_moveto, then consists of a series of mixed +// STBTT_lineto and STBTT_curveto segments. A lineto +// draws a line from previous endpoint to its x,y; a curveto +// draws a quadratic bezier from previous endpoint to +// its x,y, using cx,cy as the bezier control point. + +STBTT_DEF void stbtt_FreeShape(const stbtt_fontinfo *info, stbtt_vertex *vertices); +// frees the data allocated above + +////////////////////////////////////////////////////////////////////////////// +// +// BITMAP RENDERING +// + +STBTT_DEF void stbtt_FreeBitmap(unsigned char *bitmap, void *userdata); +// frees the bitmap allocated below + +STBTT_DEF unsigned char *stbtt_GetCodepointBitmap(const stbtt_fontinfo *info, float scale_x, float scale_y, int codepoint, int *width, int *height, int *xoff, int *yoff); +// allocates a large-enough single-channel 8bpp bitmap and renders the +// specified character/glyph at the specified scale into it, with +// antialiasing. 0 is no coverage (transparent), 255 is fully covered (opaque). +// *width & *height are filled out with the width & height of the bitmap, +// which is stored left-to-right, top-to-bottom. +// +// xoff/yoff are the offset it pixel space from the glyph origin to the top-left of the bitmap + +STBTT_DEF unsigned char *stbtt_GetCodepointBitmapSubpixel(const stbtt_fontinfo *info, float scale_x, float scale_y, float shift_x, float shift_y, int codepoint, int *width, int *height, int *xoff, int *yoff); +// the same as stbtt_GetCodepoitnBitmap, but you can specify a subpixel +// shift for the character + +STBTT_DEF void stbtt_MakeCodepointBitmap(const stbtt_fontinfo *info, unsigned char *output, int out_w, int out_h, int out_stride, float scale_x, float scale_y, int codepoint); +// the same as stbtt_GetCodepointBitmap, but you pass in storage for the bitmap +// in the form of 'output', with row spacing of 'out_stride' bytes. the bitmap +// is clipped to out_w/out_h bytes. Call stbtt_GetCodepointBitmapBox to get the +// width and height and positioning info for it first. + +STBTT_DEF void stbtt_MakeCodepointBitmapSubpixel(const stbtt_fontinfo *info, unsigned char *output, int out_w, int out_h, int out_stride, float scale_x, float scale_y, float shift_x, float shift_y, int codepoint); +// same as stbtt_MakeCodepointBitmap, but you can specify a subpixel +// shift for the character + +STBTT_DEF void stbtt_MakeCodepointBitmapSubpixelPrefilter(const stbtt_fontinfo *info, unsigned char *output, int out_w, int out_h, int out_stride, float scale_x, float scale_y, float shift_x, float shift_y, int oversample_x, int oversample_y, float *sub_x, float *sub_y, int codepoint); +// same as stbtt_MakeCodepointBitmapSubpixel, but prefiltering +// is performed (see stbtt_PackSetOversampling) + +STBTT_DEF void stbtt_GetCodepointBitmapBox(const stbtt_fontinfo *font, int codepoint, float scale_x, float scale_y, int *ix0, int *iy0, int *ix1, int *iy1); +// get the bbox of the bitmap centered around the glyph origin; so the +// bitmap width is ix1-ix0, height is iy1-iy0, and location to place +// the bitmap top left is (leftSideBearing*scale,iy0). +// (Note that the bitmap uses y-increases-down, but the shape uses +// y-increases-up, so CodepointBitmapBox and CodepointBox are inverted.) + +STBTT_DEF void stbtt_GetCodepointBitmapBoxSubpixel(const stbtt_fontinfo *font, int codepoint, float scale_x, float scale_y, float shift_x, float shift_y, int *ix0, int *iy0, int *ix1, int *iy1); +// same as stbtt_GetCodepointBitmapBox, but you can specify a subpixel +// shift for the character + +// the following functions are equivalent to the above functions, but operate +// on glyph indices instead of Unicode codepoints (for efficiency) +STBTT_DEF unsigned char *stbtt_GetGlyphBitmap(const stbtt_fontinfo *info, float scale_x, float scale_y, int glyph, int *width, int *height, int *xoff, int *yoff); +STBTT_DEF unsigned char *stbtt_GetGlyphBitmapSubpixel(const stbtt_fontinfo *info, float scale_x, float scale_y, float shift_x, float shift_y, int glyph, int *width, int *height, int *xoff, int *yoff); +STBTT_DEF void stbtt_MakeGlyphBitmap(const stbtt_fontinfo *info, unsigned char *output, int out_w, int out_h, int out_stride, float scale_x, float scale_y, int glyph); +STBTT_DEF void stbtt_MakeGlyphBitmapSubpixel(const stbtt_fontinfo *info, unsigned char *output, int out_w, int out_h, int out_stride, float scale_x, float scale_y, float shift_x, float shift_y, int glyph); +STBTT_DEF void stbtt_MakeGlyphBitmapSubpixelPrefilter(const stbtt_fontinfo *info, unsigned char *output, int out_w, int out_h, int out_stride, float scale_x, float scale_y, float shift_x, float shift_y, int oversample_x, int oversample_y, float *sub_x, float *sub_y, int glyph); +STBTT_DEF void stbtt_GetGlyphBitmapBox(const stbtt_fontinfo *font, int glyph, float scale_x, float scale_y, int *ix0, int *iy0, int *ix1, int *iy1); +STBTT_DEF void stbtt_GetGlyphBitmapBoxSubpixel(const stbtt_fontinfo *font, int glyph, float scale_x, float scale_y,float shift_x, float shift_y, int *ix0, int *iy0, int *ix1, int *iy1); + + +// @TODO: don't expose this structure +typedef struct +{ + int w,h,stride; + unsigned char *pixels; +} stbtt__bitmap; + +// rasterize a shape with quadratic beziers into a bitmap +STBTT_DEF void stbtt_Rasterize(stbtt__bitmap *result, // 1-channel bitmap to draw into + float flatness_in_pixels, // allowable error of curve in pixels + stbtt_vertex *vertices, // array of vertices defining shape + int num_verts, // number of vertices in above array + float scale_x, float scale_y, // scale applied to input vertices + float shift_x, float shift_y, // translation applied to input vertices + int x_off, int y_off, // another translation applied to input + int invert, // if non-zero, vertically flip shape + void *userdata); // context for to STBTT_MALLOC + +////////////////////////////////////////////////////////////////////////////// +// +// Signed Distance Function (or Field) rendering + +STBTT_DEF void stbtt_FreeSDF(unsigned char *bitmap, void *userdata); +// frees the SDF bitmap allocated below + +STBTT_DEF unsigned char * stbtt_GetGlyphSDF(const stbtt_fontinfo *info, float scale, int glyph, int padding, unsigned char onedge_value, float pixel_dist_scale, int *width, int *height, int *xoff, int *yoff); +STBTT_DEF unsigned char * stbtt_GetCodepointSDF(const stbtt_fontinfo *info, float scale, int codepoint, int padding, unsigned char onedge_value, float pixel_dist_scale, int *width, int *height, int *xoff, int *yoff); +// These functions compute a discretized SDF field for a single character, suitable for storing +// in a single-channel texture, sampling with bilinear filtering, and testing against +// larger than some threshold to produce scalable fonts. +// info -- the font +// scale -- controls the size of the resulting SDF bitmap, same as it would be creating a regular bitmap +// glyph/codepoint -- the character to generate the SDF for +// padding -- extra "pixels" around the character which are filled with the distance to the character (not 0), +// which allows effects like bit outlines +// onedge_value -- value 0-255 to test the SDF against to reconstruct the character (i.e. the isocontour of the character) +// pixel_dist_scale -- what value the SDF should increase by when moving one SDF "pixel" away from the edge (on the 0..255 scale) +// if positive, > onedge_value is inside; if negative, < onedge_value is inside +// width,height -- output height & width of the SDF bitmap (including padding) +// xoff,yoff -- output origin of the character +// return value -- a 2D array of bytes 0..255, width*height in size +// +// pixel_dist_scale & onedge_value are a scale & bias that allows you to make +// optimal use of the limited 0..255 for your application, trading off precision +// and special effects. SDF values outside the range 0..255 are clamped to 0..255. +// +// Example: +// scale = stbtt_ScaleForPixelHeight(22) +// padding = 5 +// onedge_value = 180 +// pixel_dist_scale = 180/5.0 = 36.0 +// +// This will create an SDF bitmap in which the character is about 22 pixels +// high but the whole bitmap is about 22+5+5=32 pixels high. To produce a filled +// shape, sample the SDF at each pixel and fill the pixel if the SDF value +// is greater than or equal to 180/255. (You'll actually want to antialias, +// which is beyond the scope of this example.) Additionally, you can compute +// offset outlines (e.g. to stroke the character border inside & outside, +// or only outside). For example, to fill outside the character up to 3 SDF +// pixels, you would compare against (180-36.0*3)/255 = 72/255. The above +// choice of variables maps a range from 5 pixels outside the shape to +// 2 pixels inside the shape to 0..255; this is intended primarily for apply +// outside effects only (the interior range is needed to allow proper +// antialiasing of the font at *smaller* sizes) +// +// The function computes the SDF analytically at each SDF pixel, not by e.g. +// building a higher-res bitmap and approximating it. In theory the quality +// should be as high as possible for an SDF of this size & representation, but +// unclear if this is true in practice (perhaps building a higher-res bitmap +// and computing from that can allow drop-out prevention). +// +// The algorithm has not been optimized at all, so expect it to be slow +// if computing lots of characters or very large sizes. + + + +////////////////////////////////////////////////////////////////////////////// +// +// Finding the right font... +// +// You should really just solve this offline, keep your own tables +// of what font is what, and don't try to get it out of the .ttf file. +// That's because getting it out of the .ttf file is really hard, because +// the names in the file can appear in many possible encodings, in many +// possible languages, and e.g. if you need a case-insensitive comparison, +// the details of that depend on the encoding & language in a complex way +// (actually underspecified in truetype, but also gigantic). +// +// But you can use the provided functions in two possible ways: +// stbtt_FindMatchingFont() will use *case-sensitive* comparisons on +// unicode-encoded names to try to find the font you want; +// you can run this before calling stbtt_InitFont() +// +// stbtt_GetFontNameString() lets you get any of the various strings +// from the file yourself and do your own comparisons on them. +// You have to have called stbtt_InitFont() first. + + +STBTT_DEF int stbtt_FindMatchingFont(const unsigned char *fontdata, const char *name, int flags); +// returns the offset (not index) of the font that matches, or -1 if none +// if you use STBTT_MACSTYLE_DONTCARE, use a font name like "Arial Bold". +// if you use any other flag, use a font name like "Arial"; this checks +// the 'macStyle' header field; i don't know if fonts set this consistently +#define STBTT_MACSTYLE_DONTCARE 0 +#define STBTT_MACSTYLE_BOLD 1 +#define STBTT_MACSTYLE_ITALIC 2 +#define STBTT_MACSTYLE_UNDERSCORE 4 +#define STBTT_MACSTYLE_NONE 8 // <= not same as 0, this makes us check the bitfield is 0 + +STBTT_DEF int stbtt_CompareUTF8toUTF16_bigendian(const char *s1, int len1, const char *s2, int len2); +// returns 1/0 whether the first string interpreted as utf8 is identical to +// the second string interpreted as big-endian utf16... useful for strings from next func + +STBTT_DEF const char *stbtt_GetFontNameString(const stbtt_fontinfo *font, int *length, int platformID, int encodingID, int languageID, int nameID); +// returns the string (which may be big-endian double byte, e.g. for unicode) +// and puts the length in bytes in *length. +// +// some of the values for the IDs are below; for more see the truetype spec: +// http://developer.apple.com/textfonts/TTRefMan/RM06/Chap6name.html +// http://www.microsoft.com/typography/otspec/name.htm + +enum { // platformID + STBTT_PLATFORM_ID_UNICODE =0, + STBTT_PLATFORM_ID_MAC =1, + STBTT_PLATFORM_ID_ISO =2, + STBTT_PLATFORM_ID_MICROSOFT =3 +}; + +enum { // encodingID for STBTT_PLATFORM_ID_UNICODE + STBTT_UNICODE_EID_UNICODE_1_0 =0, + STBTT_UNICODE_EID_UNICODE_1_1 =1, + STBTT_UNICODE_EID_ISO_10646 =2, + STBTT_UNICODE_EID_UNICODE_2_0_BMP=3, + STBTT_UNICODE_EID_UNICODE_2_0_FULL=4 +}; + +enum { // encodingID for STBTT_PLATFORM_ID_MICROSOFT + STBTT_MS_EID_SYMBOL =0, + STBTT_MS_EID_UNICODE_BMP =1, + STBTT_MS_EID_SHIFTJIS =2, + STBTT_MS_EID_UNICODE_FULL =10 +}; + +enum { // encodingID for STBTT_PLATFORM_ID_MAC; same as Script Manager codes + STBTT_MAC_EID_ROMAN =0, STBTT_MAC_EID_ARABIC =4, + STBTT_MAC_EID_JAPANESE =1, STBTT_MAC_EID_HEBREW =5, + STBTT_MAC_EID_CHINESE_TRAD =2, STBTT_MAC_EID_GREEK =6, + STBTT_MAC_EID_KOREAN =3, STBTT_MAC_EID_RUSSIAN =7 +}; + +enum { // languageID for STBTT_PLATFORM_ID_MICROSOFT; same as LCID... + // problematic because there are e.g. 16 english LCIDs and 16 arabic LCIDs + STBTT_MS_LANG_ENGLISH =0x0409, STBTT_MS_LANG_ITALIAN =0x0410, + STBTT_MS_LANG_CHINESE =0x0804, STBTT_MS_LANG_JAPANESE =0x0411, + STBTT_MS_LANG_DUTCH =0x0413, STBTT_MS_LANG_KOREAN =0x0412, + STBTT_MS_LANG_FRENCH =0x040c, STBTT_MS_LANG_RUSSIAN =0x0419, + STBTT_MS_LANG_GERMAN =0x0407, STBTT_MS_LANG_SPANISH =0x0409, + STBTT_MS_LANG_HEBREW =0x040d, STBTT_MS_LANG_SWEDISH =0x041D +}; + +enum { // languageID for STBTT_PLATFORM_ID_MAC + STBTT_MAC_LANG_ENGLISH =0 , STBTT_MAC_LANG_JAPANESE =11, + STBTT_MAC_LANG_ARABIC =12, STBTT_MAC_LANG_KOREAN =23, + STBTT_MAC_LANG_DUTCH =4 , STBTT_MAC_LANG_RUSSIAN =32, + STBTT_MAC_LANG_FRENCH =1 , STBTT_MAC_LANG_SPANISH =6 , + STBTT_MAC_LANG_GERMAN =2 , STBTT_MAC_LANG_SWEDISH =5 , + STBTT_MAC_LANG_HEBREW =10, STBTT_MAC_LANG_CHINESE_SIMPLIFIED =33, + STBTT_MAC_LANG_ITALIAN =3 , STBTT_MAC_LANG_CHINESE_TRAD =19 +}; + +#ifdef __cplusplus +} +#endif + +#endif // __STB_INCLUDE_STB_TRUETYPE_H__ + +/////////////////////////////////////////////////////////////////////////////// +/////////////////////////////////////////////////////////////////////////////// +//// +//// IMPLEMENTATION +//// +//// + +#ifdef STB_TRUETYPE_IMPLEMENTATION + +#ifndef STBTT_MAX_OVERSAMPLE +#define STBTT_MAX_OVERSAMPLE 8 +#endif + +#if STBTT_MAX_OVERSAMPLE > 255 +#error "STBTT_MAX_OVERSAMPLE cannot be > 255" +#endif + +typedef int stbtt__test_oversample_pow2[(STBTT_MAX_OVERSAMPLE & (STBTT_MAX_OVERSAMPLE-1)) == 0 ? 1 : -1]; + +#ifndef STBTT_RASTERIZER_VERSION +#define STBTT_RASTERIZER_VERSION 2 +#endif + +#ifdef _MSC_VER +#define STBTT__NOTUSED(v) (void)(v) +#else +#define STBTT__NOTUSED(v) (void)sizeof(v) +#endif + +////////////////////////////////////////////////////////////////////////// +// +// stbtt__buf helpers to parse data from file +// + +static stbtt_uint8 stbtt__buf_get8(stbtt__buf *b) +{ + if (b->cursor >= b->size) + return 0; + return b->data[b->cursor++]; +} + +static stbtt_uint8 stbtt__buf_peek8(stbtt__buf *b) +{ + if (b->cursor >= b->size) + return 0; + return b->data[b->cursor]; +} + +static void stbtt__buf_seek(stbtt__buf *b, int o) +{ + STBTT_assert(!(o > b->size || o < 0)); + b->cursor = (o > b->size || o < 0) ? b->size : o; +} + +static void stbtt__buf_skip(stbtt__buf *b, int o) +{ + stbtt__buf_seek(b, b->cursor + o); +} + +static stbtt_uint32 stbtt__buf_get(stbtt__buf *b, int n) +{ + stbtt_uint32 v = 0; + int i; + STBTT_assert(n >= 1 && n <= 4); + for (i = 0; i < n; i++) + v = (v << 8) | stbtt__buf_get8(b); + return v; +} + +static stbtt__buf stbtt__new_buf(const void *p, size_t size) +{ + stbtt__buf r; + STBTT_assert(size < 0x40000000); + r.data = (stbtt_uint8*) p; + r.size = (int) size; + r.cursor = 0; + return r; +} + +#define stbtt__buf_get16(b) stbtt__buf_get((b), 2) +#define stbtt__buf_get32(b) stbtt__buf_get((b), 4) + +static stbtt__buf stbtt__buf_range(const stbtt__buf *b, int o, int s) +{ + stbtt__buf r = stbtt__new_buf(NULL, 0); + if (o < 0 || s < 0 || o > b->size || s > b->size - o) return r; + r.data = b->data + o; + r.size = s; + return r; +} + +static stbtt__buf stbtt__cff_get_index(stbtt__buf *b) +{ + int count, start, offsize; + start = b->cursor; + count = stbtt__buf_get16(b); + if (count) { + offsize = stbtt__buf_get8(b); + STBTT_assert(offsize >= 1 && offsize <= 4); + stbtt__buf_skip(b, offsize * count); + stbtt__buf_skip(b, stbtt__buf_get(b, offsize) - 1); + } + return stbtt__buf_range(b, start, b->cursor - start); +} + +static stbtt_uint32 stbtt__cff_int(stbtt__buf *b) +{ + int b0 = stbtt__buf_get8(b); + if (b0 >= 32 && b0 <= 246) return b0 - 139; + else if (b0 >= 247 && b0 <= 250) return (b0 - 247)*256 + stbtt__buf_get8(b) + 108; + else if (b0 >= 251 && b0 <= 254) return -(b0 - 251)*256 - stbtt__buf_get8(b) - 108; + else if (b0 == 28) return stbtt__buf_get16(b); + else if (b0 == 29) return stbtt__buf_get32(b); + STBTT_assert(0); + return 0; +} + +static void stbtt__cff_skip_operand(stbtt__buf *b) { + int v, b0 = stbtt__buf_peek8(b); + STBTT_assert(b0 >= 28); + if (b0 == 30) { + stbtt__buf_skip(b, 1); + while (b->cursor < b->size) { + v = stbtt__buf_get8(b); + if ((v & 0xF) == 0xF || (v >> 4) == 0xF) + break; + } + } else { + stbtt__cff_int(b); + } +} + +static stbtt__buf stbtt__dict_get(stbtt__buf *b, int key) +{ + stbtt__buf_seek(b, 0); + while (b->cursor < b->size) { + int start = b->cursor, end, op; + while (stbtt__buf_peek8(b) >= 28) + stbtt__cff_skip_operand(b); + end = b->cursor; + op = stbtt__buf_get8(b); + if (op == 12) op = stbtt__buf_get8(b) | 0x100; + if (op == key) return stbtt__buf_range(b, start, end-start); + } + return stbtt__buf_range(b, 0, 0); +} + +static void stbtt__dict_get_ints(stbtt__buf *b, int key, int outcount, stbtt_uint32 *out) +{ + int i; + stbtt__buf operands = stbtt__dict_get(b, key); + for (i = 0; i < outcount && operands.cursor < operands.size; i++) + out[i] = stbtt__cff_int(&operands); +} + +static int stbtt__cff_index_count(stbtt__buf *b) +{ + stbtt__buf_seek(b, 0); + return stbtt__buf_get16(b); +} + +static stbtt__buf stbtt__cff_index_get(stbtt__buf b, int i) +{ + int count, offsize, start, end; + stbtt__buf_seek(&b, 0); + count = stbtt__buf_get16(&b); + offsize = stbtt__buf_get8(&b); + STBTT_assert(i >= 0 && i < count); + STBTT_assert(offsize >= 1 && offsize <= 4); + stbtt__buf_skip(&b, i*offsize); + start = stbtt__buf_get(&b, offsize); + end = stbtt__buf_get(&b, offsize); + return stbtt__buf_range(&b, 2+(count+1)*offsize+start, end - start); +} + +////////////////////////////////////////////////////////////////////////// +// +// accessors to parse data from file +// + +// on platforms that don't allow misaligned reads, if we want to allow +// truetype fonts that aren't padded to alignment, define ALLOW_UNALIGNED_TRUETYPE + +#define ttBYTE(p) (* (stbtt_uint8 *) (p)) +#define ttCHAR(p) (* (stbtt_int8 *) (p)) +#define ttFixed(p) ttLONG(p) + +static stbtt_uint16 ttUSHORT(stbtt_uint8 *p) { return p[0]*256 + p[1]; } +static stbtt_int16 ttSHORT(stbtt_uint8 *p) { return p[0]*256 + p[1]; } +static stbtt_uint32 ttULONG(stbtt_uint8 *p) { return (p[0]<<24) + (p[1]<<16) + (p[2]<<8) + p[3]; } +static stbtt_int32 ttLONG(stbtt_uint8 *p) { return (p[0]<<24) + (p[1]<<16) + (p[2]<<8) + p[3]; } + +#define stbtt_tag4(p,c0,c1,c2,c3) ((p)[0] == (c0) && (p)[1] == (c1) && (p)[2] == (c2) && (p)[3] == (c3)) +#define stbtt_tag(p,str) stbtt_tag4(p,str[0],str[1],str[2],str[3]) + +static int stbtt__isfont(stbtt_uint8 *font) +{ + // check the version number + if (stbtt_tag4(font, '1',0,0,0)) return 1; // TrueType 1 + if (stbtt_tag(font, "typ1")) return 1; // TrueType with type 1 font -- we don't support this! + if (stbtt_tag(font, "OTTO")) return 1; // OpenType with CFF + if (stbtt_tag4(font, 0,1,0,0)) return 1; // OpenType 1.0 + if (stbtt_tag(font, "true")) return 1; // Apple specification for TrueType fonts + return 0; +} + +// @OPTIMIZE: binary search +static stbtt_uint32 stbtt__find_table(stbtt_uint8 *data, stbtt_uint32 fontstart, const char *tag) +{ + stbtt_int32 num_tables = ttUSHORT(data+fontstart+4); + stbtt_uint32 tabledir = fontstart + 12; + stbtt_int32 i; + for (i=0; i < num_tables; ++i) { + stbtt_uint32 loc = tabledir + 16*i; + if (stbtt_tag(data+loc+0, tag)) + return ttULONG(data+loc+8); + } + return 0; +} + +static int stbtt_GetFontOffsetForIndex_internal(unsigned char *font_collection, int index) +{ + // if it's just a font, there's only one valid index + if (stbtt__isfont(font_collection)) + return index == 0 ? 0 : -1; + + // check if it's a TTC + if (stbtt_tag(font_collection, "ttcf")) { + // version 1? + if (ttULONG(font_collection+4) == 0x00010000 || ttULONG(font_collection+4) == 0x00020000) { + stbtt_int32 n = ttLONG(font_collection+8); + if (index >= n) + return -1; + return ttULONG(font_collection+12+index*4); + } + } + return -1; +} + +static int stbtt_GetNumberOfFonts_internal(unsigned char *font_collection) +{ + // if it's just a font, there's only one valid font + if (stbtt__isfont(font_collection)) + return 1; + + // check if it's a TTC + if (stbtt_tag(font_collection, "ttcf")) { + // version 1? + if (ttULONG(font_collection+4) == 0x00010000 || ttULONG(font_collection+4) == 0x00020000) { + return ttLONG(font_collection+8); + } + } + return 0; +} + +static stbtt__buf stbtt__get_subrs(stbtt__buf cff, stbtt__buf fontdict) +{ + stbtt_uint32 subrsoff = 0, private_loc[2] = { 0, 0 }; + stbtt__buf pdict; + stbtt__dict_get_ints(&fontdict, 18, 2, private_loc); + if (!private_loc[1] || !private_loc[0]) return stbtt__new_buf(NULL, 0); + pdict = stbtt__buf_range(&cff, private_loc[1], private_loc[0]); + stbtt__dict_get_ints(&pdict, 19, 1, &subrsoff); + if (!subrsoff) return stbtt__new_buf(NULL, 0); + stbtt__buf_seek(&cff, private_loc[1]+subrsoff); + return stbtt__cff_get_index(&cff); +} + +static int stbtt_InitFont_internal(stbtt_fontinfo *info, unsigned char *data, int fontstart) +{ + stbtt_uint32 cmap, t; + stbtt_int32 i,numTables; + + info->data = data; + info->fontstart = fontstart; + info->cff = stbtt__new_buf(NULL, 0); + + cmap = stbtt__find_table(data, fontstart, "cmap"); // required + info->loca = stbtt__find_table(data, fontstart, "loca"); // required + info->head = stbtt__find_table(data, fontstart, "head"); // required + info->glyf = stbtt__find_table(data, fontstart, "glyf"); // required + info->hhea = stbtt__find_table(data, fontstart, "hhea"); // required + info->hmtx = stbtt__find_table(data, fontstart, "hmtx"); // required + info->kern = stbtt__find_table(data, fontstart, "kern"); // not required + info->gpos = stbtt__find_table(data, fontstart, "GPOS"); // not required + + if (!cmap || !info->head || !info->hhea || !info->hmtx) + return 0; + if (info->glyf) { + // required for truetype + if (!info->loca) return 0; + } else { + // initialization for CFF / Type2 fonts (OTF) + stbtt__buf b, topdict, topdictidx; + stbtt_uint32 cstype = 2, charstrings = 0, fdarrayoff = 0, fdselectoff = 0; + stbtt_uint32 cff; + + cff = stbtt__find_table(data, fontstart, "CFF "); + if (!cff) return 0; + + info->fontdicts = stbtt__new_buf(NULL, 0); + info->fdselect = stbtt__new_buf(NULL, 0); + + // @TODO this should use size from table (not 512MB) + info->cff = stbtt__new_buf(data+cff, 512*1024*1024); + b = info->cff; + + // read the header + stbtt__buf_skip(&b, 2); + stbtt__buf_seek(&b, stbtt__buf_get8(&b)); // hdrsize + + // @TODO the name INDEX could list multiple fonts, + // but we just use the first one. + stbtt__cff_get_index(&b); // name INDEX + topdictidx = stbtt__cff_get_index(&b); + topdict = stbtt__cff_index_get(topdictidx, 0); + stbtt__cff_get_index(&b); // string INDEX + info->gsubrs = stbtt__cff_get_index(&b); + + stbtt__dict_get_ints(&topdict, 17, 1, &charstrings); + stbtt__dict_get_ints(&topdict, 0x100 | 6, 1, &cstype); + stbtt__dict_get_ints(&topdict, 0x100 | 36, 1, &fdarrayoff); + stbtt__dict_get_ints(&topdict, 0x100 | 37, 1, &fdselectoff); + info->subrs = stbtt__get_subrs(b, topdict); + + // we only support Type 2 charstrings + if (cstype != 2) return 0; + if (charstrings == 0) return 0; + + if (fdarrayoff) { + // looks like a CID font + if (!fdselectoff) return 0; + stbtt__buf_seek(&b, fdarrayoff); + info->fontdicts = stbtt__cff_get_index(&b); + info->fdselect = stbtt__buf_range(&b, fdselectoff, b.size-fdselectoff); + } + + stbtt__buf_seek(&b, charstrings); + info->charstrings = stbtt__cff_get_index(&b); + } + + t = stbtt__find_table(data, fontstart, "maxp"); + if (t) + info->numGlyphs = ttUSHORT(data+t+4); + else + info->numGlyphs = 0xffff; + + // find a cmap encoding table we understand *now* to avoid searching + // later. (todo: could make this installable) + // the same regardless of glyph. + numTables = ttUSHORT(data + cmap + 2); + info->index_map = 0; + for (i=0; i < numTables; ++i) { + stbtt_uint32 encoding_record = cmap + 4 + 8 * i; + // find an encoding we understand: + switch(ttUSHORT(data+encoding_record)) { + case STBTT_PLATFORM_ID_MICROSOFT: + switch (ttUSHORT(data+encoding_record+2)) { + case STBTT_MS_EID_UNICODE_BMP: + case STBTT_MS_EID_UNICODE_FULL: + // MS/Unicode + info->index_map = cmap + ttULONG(data+encoding_record+4); + break; + } + break; + case STBTT_PLATFORM_ID_UNICODE: + // Mac/iOS has these + // all the encodingIDs are unicode, so we don't bother to check it + info->index_map = cmap + ttULONG(data+encoding_record+4); + break; + } + } + if (info->index_map == 0) + return 0; + + info->indexToLocFormat = ttUSHORT(data+info->head + 50); + return 1; +} + +STBTT_DEF int stbtt_FindGlyphIndex(const stbtt_fontinfo *info, int unicode_codepoint) +{ + stbtt_uint8 *data = info->data; + stbtt_uint32 index_map = info->index_map; + + stbtt_uint16 format = ttUSHORT(data + index_map + 0); + if (format == 0) { // apple byte encoding + stbtt_int32 bytes = ttUSHORT(data + index_map + 2); + if (unicode_codepoint < bytes-6) + return ttBYTE(data + index_map + 6 + unicode_codepoint); + return 0; + } else if (format == 6) { + stbtt_uint32 first = ttUSHORT(data + index_map + 6); + stbtt_uint32 count = ttUSHORT(data + index_map + 8); + if ((stbtt_uint32) unicode_codepoint >= first && (stbtt_uint32) unicode_codepoint < first+count) + return ttUSHORT(data + index_map + 10 + (unicode_codepoint - first)*2); + return 0; + } else if (format == 2) { + STBTT_assert(0); // @TODO: high-byte mapping for japanese/chinese/korean + return 0; + } else if (format == 4) { // standard mapping for windows fonts: binary search collection of ranges + stbtt_uint16 segcount = ttUSHORT(data+index_map+6) >> 1; + stbtt_uint16 searchRange = ttUSHORT(data+index_map+8) >> 1; + stbtt_uint16 entrySelector = ttUSHORT(data+index_map+10); + stbtt_uint16 rangeShift = ttUSHORT(data+index_map+12) >> 1; + + // do a binary search of the segments + stbtt_uint32 endCount = index_map + 14; + stbtt_uint32 search = endCount; + + if (unicode_codepoint > 0xffff) + return 0; + + // they lie from endCount .. endCount + segCount + // but searchRange is the nearest power of two, so... + if (unicode_codepoint >= ttUSHORT(data + search + rangeShift*2)) + search += rangeShift*2; + + // now decrement to bias correctly to find smallest + search -= 2; + while (entrySelector) { + stbtt_uint16 end; + searchRange >>= 1; + end = ttUSHORT(data + search + searchRange*2); + if (unicode_codepoint > end) + search += searchRange*2; + --entrySelector; + } + search += 2; + + { + stbtt_uint16 offset, start; + stbtt_uint16 item = (stbtt_uint16) ((search - endCount) >> 1); + + STBTT_assert(unicode_codepoint <= ttUSHORT(data + endCount + 2*item)); + start = ttUSHORT(data + index_map + 14 + segcount*2 + 2 + 2*item); + if (unicode_codepoint < start) + return 0; + + offset = ttUSHORT(data + index_map + 14 + segcount*6 + 2 + 2*item); + if (offset == 0) + return (stbtt_uint16) (unicode_codepoint + ttSHORT(data + index_map + 14 + segcount*4 + 2 + 2*item)); + + return ttUSHORT(data + offset + (unicode_codepoint-start)*2 + index_map + 14 + segcount*6 + 2 + 2*item); + } + } else if (format == 12 || format == 13) { + stbtt_uint32 ngroups = ttULONG(data+index_map+12); + stbtt_int32 low,high; + low = 0; high = (stbtt_int32)ngroups; + // Binary search the right group. + while (low < high) { + stbtt_int32 mid = low + ((high-low) >> 1); // rounds down, so low <= mid < high + stbtt_uint32 start_char = ttULONG(data+index_map+16+mid*12); + stbtt_uint32 end_char = ttULONG(data+index_map+16+mid*12+4); + if ((stbtt_uint32) unicode_codepoint < start_char) + high = mid; + else if ((stbtt_uint32) unicode_codepoint > end_char) + low = mid+1; + else { + stbtt_uint32 start_glyph = ttULONG(data+index_map+16+mid*12+8); + if (format == 12) + return start_glyph + unicode_codepoint-start_char; + else // format == 13 + return start_glyph; + } + } + return 0; // not found + } + // @TODO + STBTT_assert(0); + return 0; +} + +STBTT_DEF int stbtt_GetCodepointShape(const stbtt_fontinfo *info, int unicode_codepoint, stbtt_vertex **vertices) +{ + return stbtt_GetGlyphShape(info, stbtt_FindGlyphIndex(info, unicode_codepoint), vertices); +} + +static void stbtt_setvertex(stbtt_vertex *v, stbtt_uint8 type, stbtt_int32 x, stbtt_int32 y, stbtt_int32 cx, stbtt_int32 cy) +{ + v->type = type; + v->x = (stbtt_int16) x; + v->y = (stbtt_int16) y; + v->cx = (stbtt_int16) cx; + v->cy = (stbtt_int16) cy; +} + +static int stbtt__GetGlyfOffset(const stbtt_fontinfo *info, int glyph_index) +{ + int g1,g2; + + STBTT_assert(!info->cff.size); + + if (glyph_index >= info->numGlyphs) return -1; // glyph index out of range + if (info->indexToLocFormat >= 2) return -1; // unknown index->glyph map format + + if (info->indexToLocFormat == 0) { + g1 = info->glyf + ttUSHORT(info->data + info->loca + glyph_index * 2) * 2; + g2 = info->glyf + ttUSHORT(info->data + info->loca + glyph_index * 2 + 2) * 2; + } else { + g1 = info->glyf + ttULONG (info->data + info->loca + glyph_index * 4); + g2 = info->glyf + ttULONG (info->data + info->loca + glyph_index * 4 + 4); + } + + return g1==g2 ? -1 : g1; // if length is 0, return -1 +} + +static int stbtt__GetGlyphInfoT2(const stbtt_fontinfo *info, int glyph_index, int *x0, int *y0, int *x1, int *y1); + +STBTT_DEF int stbtt_GetGlyphBox(const stbtt_fontinfo *info, int glyph_index, int *x0, int *y0, int *x1, int *y1) +{ + if (info->cff.size) { + stbtt__GetGlyphInfoT2(info, glyph_index, x0, y0, x1, y1); + } else { + int g = stbtt__GetGlyfOffset(info, glyph_index); + if (g < 0) return 0; + + if (x0) *x0 = ttSHORT(info->data + g + 2); + if (y0) *y0 = ttSHORT(info->data + g + 4); + if (x1) *x1 = ttSHORT(info->data + g + 6); + if (y1) *y1 = ttSHORT(info->data + g + 8); + } + return 1; +} + +STBTT_DEF int stbtt_GetCodepointBox(const stbtt_fontinfo *info, int codepoint, int *x0, int *y0, int *x1, int *y1) +{ + return stbtt_GetGlyphBox(info, stbtt_FindGlyphIndex(info,codepoint), x0,y0,x1,y1); +} + +STBTT_DEF int stbtt_IsGlyphEmpty(const stbtt_fontinfo *info, int glyph_index) +{ + stbtt_int16 numberOfContours; + int g; + if (info->cff.size) + return stbtt__GetGlyphInfoT2(info, glyph_index, NULL, NULL, NULL, NULL) == 0; + g = stbtt__GetGlyfOffset(info, glyph_index); + if (g < 0) return 1; + numberOfContours = ttSHORT(info->data + g); + return numberOfContours == 0; +} + +static int stbtt__close_shape(stbtt_vertex *vertices, int num_vertices, int was_off, int start_off, + stbtt_int32 sx, stbtt_int32 sy, stbtt_int32 scx, stbtt_int32 scy, stbtt_int32 cx, stbtt_int32 cy) +{ + if (start_off) { + if (was_off) + stbtt_setvertex(&vertices[num_vertices++], STBTT_vcurve, (cx+scx)>>1, (cy+scy)>>1, cx,cy); + stbtt_setvertex(&vertices[num_vertices++], STBTT_vcurve, sx,sy,scx,scy); + } else { + if (was_off) + stbtt_setvertex(&vertices[num_vertices++], STBTT_vcurve,sx,sy,cx,cy); + else + stbtt_setvertex(&vertices[num_vertices++], STBTT_vline,sx,sy,0,0); + } + return num_vertices; +} + +static int stbtt__GetGlyphShapeTT(const stbtt_fontinfo *info, int glyph_index, stbtt_vertex **pvertices) +{ + stbtt_int16 numberOfContours; + stbtt_uint8 *endPtsOfContours; + stbtt_uint8 *data = info->data; + stbtt_vertex *vertices=0; + int num_vertices=0; + int g = stbtt__GetGlyfOffset(info, glyph_index); + + *pvertices = NULL; + + if (g < 0) return 0; + + numberOfContours = ttSHORT(data + g); + + if (numberOfContours > 0) { + stbtt_uint8 flags=0,flagcount; + stbtt_int32 ins, i,j=0,m,n, next_move, was_off=0, off, start_off=0; + stbtt_int32 x,y,cx,cy,sx,sy, scx,scy; + stbtt_uint8 *points; + endPtsOfContours = (data + g + 10); + ins = ttUSHORT(data + g + 10 + numberOfContours * 2); + points = data + g + 10 + numberOfContours * 2 + 2 + ins; + + n = 1+ttUSHORT(endPtsOfContours + numberOfContours*2-2); + + m = n + 2*numberOfContours; // a loose bound on how many vertices we might need + vertices = (stbtt_vertex *) STBTT_malloc(m * sizeof(vertices[0]), info->userdata); + if (vertices == 0) + return 0; + + next_move = 0; + flagcount=0; + + // in first pass, we load uninterpreted data into the allocated array + // above, shifted to the end of the array so we won't overwrite it when + // we create our final data starting from the front + + off = m - n; // starting offset for uninterpreted data, regardless of how m ends up being calculated + + // first load flags + + for (i=0; i < n; ++i) { + if (flagcount == 0) { + flags = *points++; + if (flags & 8) + flagcount = *points++; + } else + --flagcount; + vertices[off+i].type = flags; + } + + // now load x coordinates + x=0; + for (i=0; i < n; ++i) { + flags = vertices[off+i].type; + if (flags & 2) { + stbtt_int16 dx = *points++; + x += (flags & 16) ? dx : -dx; // ??? + } else { + if (!(flags & 16)) { + x = x + (stbtt_int16) (points[0]*256 + points[1]); + points += 2; + } + } + vertices[off+i].x = (stbtt_int16) x; + } + + // now load y coordinates + y=0; + for (i=0; i < n; ++i) { + flags = vertices[off+i].type; + if (flags & 4) { + stbtt_int16 dy = *points++; + y += (flags & 32) ? dy : -dy; // ??? + } else { + if (!(flags & 32)) { + y = y + (stbtt_int16) (points[0]*256 + points[1]); + points += 2; + } + } + vertices[off+i].y = (stbtt_int16) y; + } + + // now convert them to our format + num_vertices=0; + sx = sy = cx = cy = scx = scy = 0; + for (i=0; i < n; ++i) { + flags = vertices[off+i].type; + x = (stbtt_int16) vertices[off+i].x; + y = (stbtt_int16) vertices[off+i].y; + + if (next_move == i) { + if (i != 0) + num_vertices = stbtt__close_shape(vertices, num_vertices, was_off, start_off, sx,sy,scx,scy,cx,cy); + + // now start the new one + start_off = !(flags & 1); + if (start_off) { + // if we start off with an off-curve point, then when we need to find a point on the curve + // where we can start, and we need to save some state for when we wraparound. + scx = x; + scy = y; + if (!(vertices[off+i+1].type & 1)) { + // next point is also a curve point, so interpolate an on-point curve + sx = (x + (stbtt_int32) vertices[off+i+1].x) >> 1; + sy = (y + (stbtt_int32) vertices[off+i+1].y) >> 1; + } else { + // otherwise just use the next point as our start point + sx = (stbtt_int32) vertices[off+i+1].x; + sy = (stbtt_int32) vertices[off+i+1].y; + ++i; // we're using point i+1 as the starting point, so skip it + } + } else { + sx = x; + sy = y; + } + stbtt_setvertex(&vertices[num_vertices++], STBTT_vmove,sx,sy,0,0); + was_off = 0; + next_move = 1 + ttUSHORT(endPtsOfContours+j*2); + ++j; + } else { + if (!(flags & 1)) { // if it's a curve + if (was_off) // two off-curve control points in a row means interpolate an on-curve midpoint + stbtt_setvertex(&vertices[num_vertices++], STBTT_vcurve, (cx+x)>>1, (cy+y)>>1, cx, cy); + cx = x; + cy = y; + was_off = 1; + } else { + if (was_off) + stbtt_setvertex(&vertices[num_vertices++], STBTT_vcurve, x,y, cx, cy); + else + stbtt_setvertex(&vertices[num_vertices++], STBTT_vline, x,y,0,0); + was_off = 0; + } + } + } + num_vertices = stbtt__close_shape(vertices, num_vertices, was_off, start_off, sx,sy,scx,scy,cx,cy); + } else if (numberOfContours == -1) { + // Compound shapes. + int more = 1; + stbtt_uint8 *comp = data + g + 10; + num_vertices = 0; + vertices = 0; + while (more) { + stbtt_uint16 flags, gidx; + int comp_num_verts = 0, i; + stbtt_vertex *comp_verts = 0, *tmp = 0; + float mtx[6] = {1,0,0,1,0,0}, m, n; + + flags = ttSHORT(comp); comp+=2; + gidx = ttSHORT(comp); comp+=2; + + if (flags & 2) { // XY values + if (flags & 1) { // shorts + mtx[4] = ttSHORT(comp); comp+=2; + mtx[5] = ttSHORT(comp); comp+=2; + } else { + mtx[4] = ttCHAR(comp); comp+=1; + mtx[5] = ttCHAR(comp); comp+=1; + } + } + else { + // @TODO handle matching point + STBTT_assert(0); + } + if (flags & (1<<3)) { // WE_HAVE_A_SCALE + mtx[0] = mtx[3] = ttSHORT(comp)/16384.0f; comp+=2; + mtx[1] = mtx[2] = 0; + } else if (flags & (1<<6)) { // WE_HAVE_AN_X_AND_YSCALE + mtx[0] = ttSHORT(comp)/16384.0f; comp+=2; + mtx[1] = mtx[2] = 0; + mtx[3] = ttSHORT(comp)/16384.0f; comp+=2; + } else if (flags & (1<<7)) { // WE_HAVE_A_TWO_BY_TWO + mtx[0] = ttSHORT(comp)/16384.0f; comp+=2; + mtx[1] = ttSHORT(comp)/16384.0f; comp+=2; + mtx[2] = ttSHORT(comp)/16384.0f; comp+=2; + mtx[3] = ttSHORT(comp)/16384.0f; comp+=2; + } + + // Find transformation scales. + m = (float) STBTT_sqrt(mtx[0]*mtx[0] + mtx[1]*mtx[1]); + n = (float) STBTT_sqrt(mtx[2]*mtx[2] + mtx[3]*mtx[3]); + + // Get indexed glyph. + comp_num_verts = stbtt_GetGlyphShape(info, gidx, &comp_verts); + if (comp_num_verts > 0) { + // Transform vertices. + for (i = 0; i < comp_num_verts; ++i) { + stbtt_vertex* v = &comp_verts[i]; + stbtt_vertex_type x,y; + x=v->x; y=v->y; + v->x = (stbtt_vertex_type)(m * (mtx[0]*x + mtx[2]*y + mtx[4])); + v->y = (stbtt_vertex_type)(n * (mtx[1]*x + mtx[3]*y + mtx[5])); + x=v->cx; y=v->cy; + v->cx = (stbtt_vertex_type)(m * (mtx[0]*x + mtx[2]*y + mtx[4])); + v->cy = (stbtt_vertex_type)(n * (mtx[1]*x + mtx[3]*y + mtx[5])); + } + // Append vertices. + tmp = (stbtt_vertex*)STBTT_malloc((num_vertices+comp_num_verts)*sizeof(stbtt_vertex), info->userdata); + if (!tmp) { + if (vertices) STBTT_free(vertices, info->userdata); + if (comp_verts) STBTT_free(comp_verts, info->userdata); + return 0; + } + if (num_vertices > 0) STBTT_memcpy(tmp, vertices, num_vertices*sizeof(stbtt_vertex)); //-V595 + STBTT_memcpy(tmp+num_vertices, comp_verts, comp_num_verts*sizeof(stbtt_vertex)); + if (vertices) STBTT_free(vertices, info->userdata); + vertices = tmp; + STBTT_free(comp_verts, info->userdata); + num_vertices += comp_num_verts; + } + // More components ? + more = flags & (1<<5); + } + } else if (numberOfContours < 0) { + // @TODO other compound variations? + STBTT_assert(0); + } else { + // numberOfCounters == 0, do nothing + } + + *pvertices = vertices; + return num_vertices; +} + +typedef struct +{ + int bounds; + int started; + float first_x, first_y; + float x, y; + stbtt_int32 min_x, max_x, min_y, max_y; + + stbtt_vertex *pvertices; + int num_vertices; +} stbtt__csctx; + +#define STBTT__CSCTX_INIT(bounds) {bounds,0, 0,0, 0,0, 0,0,0,0, NULL, 0} + +static void stbtt__track_vertex(stbtt__csctx *c, stbtt_int32 x, stbtt_int32 y) +{ + if (x > c->max_x || !c->started) c->max_x = x; + if (y > c->max_y || !c->started) c->max_y = y; + if (x < c->min_x || !c->started) c->min_x = x; + if (y < c->min_y || !c->started) c->min_y = y; + c->started = 1; +} + +static void stbtt__csctx_v(stbtt__csctx *c, stbtt_uint8 type, stbtt_int32 x, stbtt_int32 y, stbtt_int32 cx, stbtt_int32 cy, stbtt_int32 cx1, stbtt_int32 cy1) +{ + if (c->bounds) { + stbtt__track_vertex(c, x, y); + if (type == STBTT_vcubic) { + stbtt__track_vertex(c, cx, cy); + stbtt__track_vertex(c, cx1, cy1); + } + } else { + stbtt_setvertex(&c->pvertices[c->num_vertices], type, x, y, cx, cy); + c->pvertices[c->num_vertices].cx1 = (stbtt_int16) cx1; + c->pvertices[c->num_vertices].cy1 = (stbtt_int16) cy1; + } + c->num_vertices++; +} + +static void stbtt__csctx_close_shape(stbtt__csctx *ctx) +{ + if (ctx->first_x != ctx->x || ctx->first_y != ctx->y) + stbtt__csctx_v(ctx, STBTT_vline, (int)ctx->first_x, (int)ctx->first_y, 0, 0, 0, 0); +} + +static void stbtt__csctx_rmove_to(stbtt__csctx *ctx, float dx, float dy) +{ + stbtt__csctx_close_shape(ctx); + ctx->first_x = ctx->x = ctx->x + dx; + ctx->first_y = ctx->y = ctx->y + dy; + stbtt__csctx_v(ctx, STBTT_vmove, (int)ctx->x, (int)ctx->y, 0, 0, 0, 0); +} + +static void stbtt__csctx_rline_to(stbtt__csctx *ctx, float dx, float dy) +{ + ctx->x += dx; + ctx->y += dy; + stbtt__csctx_v(ctx, STBTT_vline, (int)ctx->x, (int)ctx->y, 0, 0, 0, 0); +} + +static void stbtt__csctx_rccurve_to(stbtt__csctx *ctx, float dx1, float dy1, float dx2, float dy2, float dx3, float dy3) +{ + float cx1 = ctx->x + dx1; + float cy1 = ctx->y + dy1; + float cx2 = cx1 + dx2; + float cy2 = cy1 + dy2; + ctx->x = cx2 + dx3; + ctx->y = cy2 + dy3; + stbtt__csctx_v(ctx, STBTT_vcubic, (int)ctx->x, (int)ctx->y, (int)cx1, (int)cy1, (int)cx2, (int)cy2); +} + +static stbtt__buf stbtt__get_subr(stbtt__buf idx, int n) +{ + int count = stbtt__cff_index_count(&idx); + int bias = 107; + if (count >= 33900) + bias = 32768; + else if (count >= 1240) + bias = 1131; + n += bias; + if (n < 0 || n >= count) + return stbtt__new_buf(NULL, 0); + return stbtt__cff_index_get(idx, n); +} + +static stbtt__buf stbtt__cid_get_glyph_subrs(const stbtt_fontinfo *info, int glyph_index) +{ + stbtt__buf fdselect = info->fdselect; + int nranges, start, end, v, fmt, fdselector = -1, i; + + stbtt__buf_seek(&fdselect, 0); + fmt = stbtt__buf_get8(&fdselect); + if (fmt == 0) { + // untested + stbtt__buf_skip(&fdselect, glyph_index); + fdselector = stbtt__buf_get8(&fdselect); + } else if (fmt == 3) { + nranges = stbtt__buf_get16(&fdselect); + start = stbtt__buf_get16(&fdselect); + for (i = 0; i < nranges; i++) { + v = stbtt__buf_get8(&fdselect); + end = stbtt__buf_get16(&fdselect); + if (glyph_index >= start && glyph_index < end) { + fdselector = v; + break; + } + start = end; + } + } + if (fdselector == -1) stbtt__new_buf(NULL, 0); + return stbtt__get_subrs(info->cff, stbtt__cff_index_get(info->fontdicts, fdselector)); +} + +static int stbtt__run_charstring(const stbtt_fontinfo *info, int glyph_index, stbtt__csctx *c) +{ + int in_header = 1, maskbits = 0, subr_stack_height = 0, sp = 0, v, i, b0; + int has_subrs = 0, clear_stack; + float s[48]; + stbtt__buf subr_stack[10], subrs = info->subrs, b; + float f; + +#define STBTT__CSERR(s) (0) + + // this currently ignores the initial width value, which isn't needed if we have hmtx + b = stbtt__cff_index_get(info->charstrings, glyph_index); + while (b.cursor < b.size) { + i = 0; + clear_stack = 1; + b0 = stbtt__buf_get8(&b); + switch (b0) { + // @TODO implement hinting + case 0x13: // hintmask + case 0x14: // cntrmask + if (in_header) + maskbits += (sp / 2); // implicit "vstem" + in_header = 0; + stbtt__buf_skip(&b, (maskbits + 7) / 8); + break; + + case 0x01: // hstem + case 0x03: // vstem + case 0x12: // hstemhm + case 0x17: // vstemhm + maskbits += (sp / 2); + break; + + case 0x15: // rmoveto + in_header = 0; + if (sp < 2) return STBTT__CSERR("rmoveto stack"); + stbtt__csctx_rmove_to(c, s[sp-2], s[sp-1]); + break; + case 0x04: // vmoveto + in_header = 0; + if (sp < 1) return STBTT__CSERR("vmoveto stack"); + stbtt__csctx_rmove_to(c, 0, s[sp-1]); + break; + case 0x16: // hmoveto + in_header = 0; + if (sp < 1) return STBTT__CSERR("hmoveto stack"); + stbtt__csctx_rmove_to(c, s[sp-1], 0); + break; + + case 0x05: // rlineto + if (sp < 2) return STBTT__CSERR("rlineto stack"); + for (; i + 1 < sp; i += 2) + stbtt__csctx_rline_to(c, s[i], s[i+1]); + break; + + // hlineto/vlineto and vhcurveto/hvcurveto alternate horizontal and vertical + // starting from a different place. + + case 0x07: // vlineto + if (sp < 1) return STBTT__CSERR("vlineto stack"); + goto vlineto; + case 0x06: // hlineto + if (sp < 1) return STBTT__CSERR("hlineto stack"); + for (;;) { + if (i >= sp) break; + stbtt__csctx_rline_to(c, s[i], 0); + i++; + vlineto: + if (i >= sp) break; + stbtt__csctx_rline_to(c, 0, s[i]); + i++; + } + break; + + case 0x1F: // hvcurveto + if (sp < 4) return STBTT__CSERR("hvcurveto stack"); + goto hvcurveto; + case 0x1E: // vhcurveto + if (sp < 4) return STBTT__CSERR("vhcurveto stack"); + for (;;) { + if (i + 3 >= sp) break; + stbtt__csctx_rccurve_to(c, 0, s[i], s[i+1], s[i+2], s[i+3], (sp - i == 5) ? s[i + 4] : 0.0f); + i += 4; + hvcurveto: + if (i + 3 >= sp) break; + stbtt__csctx_rccurve_to(c, s[i], 0, s[i+1], s[i+2], (sp - i == 5) ? s[i+4] : 0.0f, s[i+3]); + i += 4; + } + break; + + case 0x08: // rrcurveto + if (sp < 6) return STBTT__CSERR("rcurveline stack"); + for (; i + 5 < sp; i += 6) + stbtt__csctx_rccurve_to(c, s[i], s[i+1], s[i+2], s[i+3], s[i+4], s[i+5]); + break; + + case 0x18: // rcurveline + if (sp < 8) return STBTT__CSERR("rcurveline stack"); + for (; i + 5 < sp - 2; i += 6) + stbtt__csctx_rccurve_to(c, s[i], s[i+1], s[i+2], s[i+3], s[i+4], s[i+5]); + if (i + 1 >= sp) return STBTT__CSERR("rcurveline stack"); + stbtt__csctx_rline_to(c, s[i], s[i+1]); + break; + + case 0x19: // rlinecurve + if (sp < 8) return STBTT__CSERR("rlinecurve stack"); + for (; i + 1 < sp - 6; i += 2) + stbtt__csctx_rline_to(c, s[i], s[i+1]); + if (i + 5 >= sp) return STBTT__CSERR("rlinecurve stack"); + stbtt__csctx_rccurve_to(c, s[i], s[i+1], s[i+2], s[i+3], s[i+4], s[i+5]); + break; + + case 0x1A: // vvcurveto + case 0x1B: // hhcurveto + if (sp < 4) return STBTT__CSERR("(vv|hh)curveto stack"); + f = 0.0; + if (sp & 1) { f = s[i]; i++; } + for (; i + 3 < sp; i += 4) { + if (b0 == 0x1B) + stbtt__csctx_rccurve_to(c, s[i], f, s[i+1], s[i+2], s[i+3], 0.0); + else + stbtt__csctx_rccurve_to(c, f, s[i], s[i+1], s[i+2], 0.0, s[i+3]); + f = 0.0; + } + break; + + case 0x0A: // callsubr + if (!has_subrs) { + if (info->fdselect.size) + subrs = stbtt__cid_get_glyph_subrs(info, glyph_index); + has_subrs = 1; + } + // fallthrough + case 0x1D: // callgsubr + if (sp < 1) return STBTT__CSERR("call(g|)subr stack"); + v = (int) s[--sp]; + if (subr_stack_height >= 10) return STBTT__CSERR("recursion limit"); + subr_stack[subr_stack_height++] = b; + b = stbtt__get_subr(b0 == 0x0A ? subrs : info->gsubrs, v); + if (b.size == 0) return STBTT__CSERR("subr not found"); + b.cursor = 0; + clear_stack = 0; + break; + + case 0x0B: // return + if (subr_stack_height <= 0) return STBTT__CSERR("return outside subr"); + b = subr_stack[--subr_stack_height]; + clear_stack = 0; + break; + + case 0x0E: // endchar + stbtt__csctx_close_shape(c); + return 1; + + case 0x0C: { // two-byte escape + float dx1, dx2, dx3, dx4, dx5, dx6, dy1, dy2, dy3, dy4, dy5, dy6; + float dx, dy; + int b1 = stbtt__buf_get8(&b); + switch (b1) { + // @TODO These "flex" implementations ignore the flex-depth and resolution, + // and always draw beziers. + case 0x22: // hflex + if (sp < 7) return STBTT__CSERR("hflex stack"); + dx1 = s[0]; + dx2 = s[1]; + dy2 = s[2]; + dx3 = s[3]; + dx4 = s[4]; + dx5 = s[5]; + dx6 = s[6]; + stbtt__csctx_rccurve_to(c, dx1, 0, dx2, dy2, dx3, 0); + stbtt__csctx_rccurve_to(c, dx4, 0, dx5, -dy2, dx6, 0); + break; + + case 0x23: // flex + if (sp < 13) return STBTT__CSERR("flex stack"); + dx1 = s[0]; + dy1 = s[1]; + dx2 = s[2]; + dy2 = s[3]; + dx3 = s[4]; + dy3 = s[5]; + dx4 = s[6]; + dy4 = s[7]; + dx5 = s[8]; + dy5 = s[9]; + dx6 = s[10]; + dy6 = s[11]; + //fd is s[12] + stbtt__csctx_rccurve_to(c, dx1, dy1, dx2, dy2, dx3, dy3); + stbtt__csctx_rccurve_to(c, dx4, dy4, dx5, dy5, dx6, dy6); + break; + + case 0x24: // hflex1 + if (sp < 9) return STBTT__CSERR("hflex1 stack"); + dx1 = s[0]; + dy1 = s[1]; + dx2 = s[2]; + dy2 = s[3]; + dx3 = s[4]; + dx4 = s[5]; + dx5 = s[6]; + dy5 = s[7]; + dx6 = s[8]; + stbtt__csctx_rccurve_to(c, dx1, dy1, dx2, dy2, dx3, 0); + stbtt__csctx_rccurve_to(c, dx4, 0, dx5, dy5, dx6, -(dy1+dy2+dy5)); + break; + + case 0x25: // flex1 + if (sp < 11) return STBTT__CSERR("flex1 stack"); + dx1 = s[0]; + dy1 = s[1]; + dx2 = s[2]; + dy2 = s[3]; + dx3 = s[4]; + dy3 = s[5]; + dx4 = s[6]; + dy4 = s[7]; + dx5 = s[8]; + dy5 = s[9]; + dx6 = dy6 = s[10]; + dx = dx1+dx2+dx3+dx4+dx5; + dy = dy1+dy2+dy3+dy4+dy5; + if (STBTT_fabs(dx) > STBTT_fabs(dy)) + dy6 = -dy; + else + dx6 = -dx; + stbtt__csctx_rccurve_to(c, dx1, dy1, dx2, dy2, dx3, dy3); + stbtt__csctx_rccurve_to(c, dx4, dy4, dx5, dy5, dx6, dy6); + break; + + default: + return STBTT__CSERR("unimplemented"); + } + } break; + + default: + if (b0 != 255 && b0 != 28 && (b0 < 32 || b0 > 254)) //-V560 + return STBTT__CSERR("reserved operator"); + + // push immediate + if (b0 == 255) { + f = (float)(stbtt_int32)stbtt__buf_get32(&b) / 0x10000; + } else { + stbtt__buf_skip(&b, -1); + f = (float)(stbtt_int16)stbtt__cff_int(&b); + } + if (sp >= 48) return STBTT__CSERR("push stack overflow"); + s[sp++] = f; + clear_stack = 0; + break; + } + if (clear_stack) sp = 0; + } + return STBTT__CSERR("no endchar"); + +#undef STBTT__CSERR +} + +static int stbtt__GetGlyphShapeT2(const stbtt_fontinfo *info, int glyph_index, stbtt_vertex **pvertices) +{ + // runs the charstring twice, once to count and once to output (to avoid realloc) + stbtt__csctx count_ctx = STBTT__CSCTX_INIT(1); + stbtt__csctx output_ctx = STBTT__CSCTX_INIT(0); + if (stbtt__run_charstring(info, glyph_index, &count_ctx)) { + *pvertices = (stbtt_vertex*)STBTT_malloc(count_ctx.num_vertices*sizeof(stbtt_vertex), info->userdata); + output_ctx.pvertices = *pvertices; + if (stbtt__run_charstring(info, glyph_index, &output_ctx)) { + STBTT_assert(output_ctx.num_vertices == count_ctx.num_vertices); + return output_ctx.num_vertices; + } + } + *pvertices = NULL; + return 0; +} + +static int stbtt__GetGlyphInfoT2(const stbtt_fontinfo *info, int glyph_index, int *x0, int *y0, int *x1, int *y1) +{ + stbtt__csctx c = STBTT__CSCTX_INIT(1); + int r = stbtt__run_charstring(info, glyph_index, &c); + if (x0) *x0 = r ? c.min_x : 0; + if (y0) *y0 = r ? c.min_y : 0; + if (x1) *x1 = r ? c.max_x : 0; + if (y1) *y1 = r ? c.max_y : 0; + return r ? c.num_vertices : 0; +} + +STBTT_DEF int stbtt_GetGlyphShape(const stbtt_fontinfo *info, int glyph_index, stbtt_vertex **pvertices) +{ + if (!info->cff.size) + return stbtt__GetGlyphShapeTT(info, glyph_index, pvertices); + else + return stbtt__GetGlyphShapeT2(info, glyph_index, pvertices); +} + +STBTT_DEF void stbtt_GetGlyphHMetrics(const stbtt_fontinfo *info, int glyph_index, int *advanceWidth, int *leftSideBearing) +{ + stbtt_uint16 numOfLongHorMetrics = ttUSHORT(info->data+info->hhea + 34); + if (glyph_index < numOfLongHorMetrics) { + if (advanceWidth) *advanceWidth = ttSHORT(info->data + info->hmtx + 4*glyph_index); + if (leftSideBearing) *leftSideBearing = ttSHORT(info->data + info->hmtx + 4*glyph_index + 2); + } else { + if (advanceWidth) *advanceWidth = ttSHORT(info->data + info->hmtx + 4*(numOfLongHorMetrics-1)); + if (leftSideBearing) *leftSideBearing = ttSHORT(info->data + info->hmtx + 4*numOfLongHorMetrics + 2*(glyph_index - numOfLongHorMetrics)); + } +} + +static int stbtt__GetGlyphKernInfoAdvance(const stbtt_fontinfo *info, int glyph1, int glyph2) +{ + stbtt_uint8 *data = info->data + info->kern; + stbtt_uint32 needle, straw; + int l, r, m; + + // we only look at the first table. it must be 'horizontal' and format 0. + if (!info->kern) + return 0; + if (ttUSHORT(data+2) < 1) // number of tables, need at least 1 + return 0; + if (ttUSHORT(data+8) != 1) // horizontal flag must be set in format + return 0; + + l = 0; + r = ttUSHORT(data+10) - 1; + needle = glyph1 << 16 | glyph2; + while (l <= r) { + m = (l + r) >> 1; + straw = ttULONG(data+18+(m*6)); // note: unaligned read + if (needle < straw) + r = m - 1; + else if (needle > straw) + l = m + 1; + else + return ttSHORT(data+22+(m*6)); + } + return 0; +} + +static stbtt_int32 stbtt__GetCoverageIndex(stbtt_uint8 *coverageTable, int glyph) +{ + stbtt_uint16 coverageFormat = ttUSHORT(coverageTable); + switch(coverageFormat) { + case 1: { + stbtt_uint16 glyphCount = ttUSHORT(coverageTable + 2); + + // Binary search. + stbtt_int32 l=0, r=glyphCount-1, m; + int straw, needle=glyph; + while (l <= r) { + stbtt_uint8 *glyphArray = coverageTable + 4; + stbtt_uint16 glyphID; + m = (l + r) >> 1; + glyphID = ttUSHORT(glyphArray + 2 * m); + straw = glyphID; + if (needle < straw) + r = m - 1; + else if (needle > straw) + l = m + 1; + else { + return m; + } + } + } break; + + case 2: { + stbtt_uint16 rangeCount = ttUSHORT(coverageTable + 2); + stbtt_uint8 *rangeArray = coverageTable + 4; + + // Binary search. + stbtt_int32 l=0, r=rangeCount-1, m; + int strawStart, strawEnd, needle=glyph; + while (l <= r) { + stbtt_uint8 *rangeRecord; + m = (l + r) >> 1; + rangeRecord = rangeArray + 6 * m; + strawStart = ttUSHORT(rangeRecord); + strawEnd = ttUSHORT(rangeRecord + 2); + if (needle < strawStart) + r = m - 1; + else if (needle > strawEnd) + l = m + 1; + else { + stbtt_uint16 startCoverageIndex = ttUSHORT(rangeRecord + 4); + return startCoverageIndex + glyph - strawStart; + } + } + } break; + + default: { + // There are no other cases. + STBTT_assert(0); + } break; + } + + return -1; +} + +static stbtt_int32 stbtt__GetGlyphClass(stbtt_uint8 *classDefTable, int glyph) +{ + stbtt_uint16 classDefFormat = ttUSHORT(classDefTable); + switch(classDefFormat) + { + case 1: { + stbtt_uint16 startGlyphID = ttUSHORT(classDefTable + 2); + stbtt_uint16 glyphCount = ttUSHORT(classDefTable + 4); + stbtt_uint8 *classDef1ValueArray = classDefTable + 6; + + if (glyph >= startGlyphID && glyph < startGlyphID + glyphCount) + return (stbtt_int32)ttUSHORT(classDef1ValueArray + 2 * (glyph - startGlyphID)); + + // [DEAR IMGUI] Commented to fix static analyzer warning + //classDefTable = classDef1ValueArray + 2 * glyphCount; + } break; + + case 2: { + stbtt_uint16 classRangeCount = ttUSHORT(classDefTable + 2); + stbtt_uint8 *classRangeRecords = classDefTable + 4; + + // Binary search. + stbtt_int32 l=0, r=classRangeCount-1, m; + int strawStart, strawEnd, needle=glyph; + while (l <= r) { + stbtt_uint8 *classRangeRecord; + m = (l + r) >> 1; + classRangeRecord = classRangeRecords + 6 * m; + strawStart = ttUSHORT(classRangeRecord); + strawEnd = ttUSHORT(classRangeRecord + 2); + if (needle < strawStart) + r = m - 1; + else if (needle > strawEnd) + l = m + 1; + else + return (stbtt_int32)ttUSHORT(classRangeRecord + 4); + } + + // [DEAR IMGUI] Commented to fix static analyzer warning + //classDefTable = classRangeRecords + 6 * classRangeCount; + } break; + + default: { + // There are no other cases. + STBTT_assert(0); + } break; + } + + return -1; +} + +// Define to STBTT_assert(x) if you want to break on unimplemented formats. +#define STBTT_GPOS_TODO_assert(x) + +static stbtt_int32 stbtt__GetGlyphGPOSInfoAdvance(const stbtt_fontinfo *info, int glyph1, int glyph2) +{ + stbtt_uint16 lookupListOffset; + stbtt_uint8 *lookupList; + stbtt_uint16 lookupCount; + stbtt_uint8 *data; + stbtt_int32 i; + + if (!info->gpos) return 0; + + data = info->data + info->gpos; + + if (ttUSHORT(data+0) != 1) return 0; // Major version 1 + if (ttUSHORT(data+2) != 0) return 0; // Minor version 0 + + lookupListOffset = ttUSHORT(data+8); + lookupList = data + lookupListOffset; + lookupCount = ttUSHORT(lookupList); + + for (i=0; i> 1; + pairValue = pairValueArray + (2 + valueRecordPairSizeInBytes) * m; + secondGlyph = ttUSHORT(pairValue); + straw = secondGlyph; + if (needle < straw) + r = m - 1; + else if (needle > straw) + l = m + 1; + else { + stbtt_int16 xAdvance = ttSHORT(pairValue + 2); + return xAdvance; + } + } + } break; + + case 2: { + stbtt_uint16 valueFormat1 = ttUSHORT(table + 4); + stbtt_uint16 valueFormat2 = ttUSHORT(table + 6); + + stbtt_uint16 classDef1Offset = ttUSHORT(table + 8); + stbtt_uint16 classDef2Offset = ttUSHORT(table + 10); + int glyph1class = stbtt__GetGlyphClass(table + classDef1Offset, glyph1); + int glyph2class = stbtt__GetGlyphClass(table + classDef2Offset, glyph2); + + stbtt_uint16 class1Count = ttUSHORT(table + 12); + stbtt_uint16 class2Count = ttUSHORT(table + 14); + STBTT_assert(glyph1class < class1Count); + STBTT_assert(glyph2class < class2Count); + + // TODO: Support more formats. + STBTT_GPOS_TODO_assert(valueFormat1 == 4); + if (valueFormat1 != 4) return 0; + STBTT_GPOS_TODO_assert(valueFormat2 == 0); + if (valueFormat2 != 0) return 0; + + if (glyph1class >= 0 && glyph1class < class1Count && glyph2class >= 0 && glyph2class < class2Count) { + stbtt_uint8 *class1Records = table + 16; + stbtt_uint8 *class2Records = class1Records + 2 * (glyph1class * class2Count); + stbtt_int16 xAdvance = ttSHORT(class2Records + 2 * glyph2class); + return xAdvance; + } + } break; + + default: { + // There are no other cases. + STBTT_assert(0); + break; + } // [DEAR IMGUI] removed ; + } + } + break; + } // [DEAR IMGUI] removed ; + + default: + // TODO: Implement other stuff. + break; + } + } + + return 0; +} + +STBTT_DEF int stbtt_GetGlyphKernAdvance(const stbtt_fontinfo *info, int g1, int g2) +{ + int xAdvance = 0; + + if (info->gpos) + xAdvance += stbtt__GetGlyphGPOSInfoAdvance(info, g1, g2); + + if (info->kern) + xAdvance += stbtt__GetGlyphKernInfoAdvance(info, g1, g2); + + return xAdvance; +} + +STBTT_DEF int stbtt_GetCodepointKernAdvance(const stbtt_fontinfo *info, int ch1, int ch2) +{ + if (!info->kern && !info->gpos) // if no kerning table, don't waste time looking up both codepoint->glyphs + return 0; + return stbtt_GetGlyphKernAdvance(info, stbtt_FindGlyphIndex(info,ch1), stbtt_FindGlyphIndex(info,ch2)); +} + +STBTT_DEF void stbtt_GetCodepointHMetrics(const stbtt_fontinfo *info, int codepoint, int *advanceWidth, int *leftSideBearing) +{ + stbtt_GetGlyphHMetrics(info, stbtt_FindGlyphIndex(info,codepoint), advanceWidth, leftSideBearing); +} + +STBTT_DEF void stbtt_GetFontVMetrics(const stbtt_fontinfo *info, int *ascent, int *descent, int *lineGap) +{ + if (ascent ) *ascent = ttSHORT(info->data+info->hhea + 4); + if (descent) *descent = ttSHORT(info->data+info->hhea + 6); + if (lineGap) *lineGap = ttSHORT(info->data+info->hhea + 8); +} + +STBTT_DEF int stbtt_GetFontVMetricsOS2(const stbtt_fontinfo *info, int *typoAscent, int *typoDescent, int *typoLineGap) +{ + int tab = stbtt__find_table(info->data, info->fontstart, "OS/2"); + if (!tab) + return 0; + if (typoAscent ) *typoAscent = ttSHORT(info->data+tab + 68); + if (typoDescent) *typoDescent = ttSHORT(info->data+tab + 70); + if (typoLineGap) *typoLineGap = ttSHORT(info->data+tab + 72); + return 1; +} + +STBTT_DEF void stbtt_GetFontBoundingBox(const stbtt_fontinfo *info, int *x0, int *y0, int *x1, int *y1) +{ + *x0 = ttSHORT(info->data + info->head + 36); + *y0 = ttSHORT(info->data + info->head + 38); + *x1 = ttSHORT(info->data + info->head + 40); + *y1 = ttSHORT(info->data + info->head + 42); +} + +STBTT_DEF float stbtt_ScaleForPixelHeight(const stbtt_fontinfo *info, float height) +{ + int fheight = ttSHORT(info->data + info->hhea + 4) - ttSHORT(info->data + info->hhea + 6); + return (float) height / fheight; +} + +STBTT_DEF float stbtt_ScaleForMappingEmToPixels(const stbtt_fontinfo *info, float pixels) +{ + int unitsPerEm = ttUSHORT(info->data + info->head + 18); + return pixels / unitsPerEm; +} + +STBTT_DEF void stbtt_FreeShape(const stbtt_fontinfo *info, stbtt_vertex *v) +{ + STBTT_free(v, info->userdata); +} + +////////////////////////////////////////////////////////////////////////////// +// +// antialiasing software rasterizer +// + +STBTT_DEF void stbtt_GetGlyphBitmapBoxSubpixel(const stbtt_fontinfo *font, int glyph, float scale_x, float scale_y,float shift_x, float shift_y, int *ix0, int *iy0, int *ix1, int *iy1) +{ + int x0=0,y0=0,x1,y1; // =0 suppresses compiler warning + if (!stbtt_GetGlyphBox(font, glyph, &x0,&y0,&x1,&y1)) { + // e.g. space character + if (ix0) *ix0 = 0; + if (iy0) *iy0 = 0; + if (ix1) *ix1 = 0; + if (iy1) *iy1 = 0; + } else { + // move to integral bboxes (treating pixels as little squares, what pixels get touched)? + if (ix0) *ix0 = STBTT_ifloor( x0 * scale_x + shift_x); + if (iy0) *iy0 = STBTT_ifloor(-y1 * scale_y + shift_y); + if (ix1) *ix1 = STBTT_iceil ( x1 * scale_x + shift_x); + if (iy1) *iy1 = STBTT_iceil (-y0 * scale_y + shift_y); + } +} + +STBTT_DEF void stbtt_GetGlyphBitmapBox(const stbtt_fontinfo *font, int glyph, float scale_x, float scale_y, int *ix0, int *iy0, int *ix1, int *iy1) +{ + stbtt_GetGlyphBitmapBoxSubpixel(font, glyph, scale_x, scale_y,0.0f,0.0f, ix0, iy0, ix1, iy1); +} + +STBTT_DEF void stbtt_GetCodepointBitmapBoxSubpixel(const stbtt_fontinfo *font, int codepoint, float scale_x, float scale_y, float shift_x, float shift_y, int *ix0, int *iy0, int *ix1, int *iy1) +{ + stbtt_GetGlyphBitmapBoxSubpixel(font, stbtt_FindGlyphIndex(font,codepoint), scale_x, scale_y,shift_x,shift_y, ix0,iy0,ix1,iy1); +} + +STBTT_DEF void stbtt_GetCodepointBitmapBox(const stbtt_fontinfo *font, int codepoint, float scale_x, float scale_y, int *ix0, int *iy0, int *ix1, int *iy1) +{ + stbtt_GetCodepointBitmapBoxSubpixel(font, codepoint, scale_x, scale_y,0.0f,0.0f, ix0,iy0,ix1,iy1); +} + +////////////////////////////////////////////////////////////////////////////// +// +// Rasterizer + +typedef struct stbtt__hheap_chunk +{ + struct stbtt__hheap_chunk *next; +} stbtt__hheap_chunk; + +typedef struct stbtt__hheap +{ + struct stbtt__hheap_chunk *head; + void *first_free; + int num_remaining_in_head_chunk; +} stbtt__hheap; + +static void *stbtt__hheap_alloc(stbtt__hheap *hh, size_t size, void *userdata) +{ + if (hh->first_free) { + void *p = hh->first_free; + hh->first_free = * (void **) p; + return p; + } else { + if (hh->num_remaining_in_head_chunk == 0) { + int count = (size < 32 ? 2000 : size < 128 ? 800 : 100); + stbtt__hheap_chunk *c = (stbtt__hheap_chunk *) STBTT_malloc(sizeof(stbtt__hheap_chunk) + size * count, userdata); + if (c == NULL) + return NULL; + c->next = hh->head; + hh->head = c; + hh->num_remaining_in_head_chunk = count; + } + --hh->num_remaining_in_head_chunk; + return (char *) (hh->head) + sizeof(stbtt__hheap_chunk) + size * hh->num_remaining_in_head_chunk; + } +} + +static void stbtt__hheap_free(stbtt__hheap *hh, void *p) +{ + *(void **) p = hh->first_free; + hh->first_free = p; +} + +static void stbtt__hheap_cleanup(stbtt__hheap *hh, void *userdata) +{ + stbtt__hheap_chunk *c = hh->head; + while (c) { + stbtt__hheap_chunk *n = c->next; + STBTT_free(c, userdata); + c = n; + } +} + +typedef struct stbtt__edge { + float x0,y0, x1,y1; + int invert; +} stbtt__edge; + + +typedef struct stbtt__active_edge +{ + struct stbtt__active_edge *next; + #if STBTT_RASTERIZER_VERSION==1 + int x,dx; + float ey; + int direction; + #elif STBTT_RASTERIZER_VERSION==2 + float fx,fdx,fdy; + float direction; + float sy; + float ey; + #else + #error "Unrecognized value of STBTT_RASTERIZER_VERSION" + #endif +} stbtt__active_edge; + +#if STBTT_RASTERIZER_VERSION == 1 +#define STBTT_FIXSHIFT 10 +#define STBTT_FIX (1 << STBTT_FIXSHIFT) +#define STBTT_FIXMASK (STBTT_FIX-1) + +static stbtt__active_edge *stbtt__new_active(stbtt__hheap *hh, stbtt__edge *e, int off_x, float start_point, void *userdata) +{ + stbtt__active_edge *z = (stbtt__active_edge *) stbtt__hheap_alloc(hh, sizeof(*z), userdata); + float dxdy = (e->x1 - e->x0) / (e->y1 - e->y0); + STBTT_assert(z != NULL); + if (!z) return z; + + // round dx down to avoid overshooting + if (dxdy < 0) + z->dx = -STBTT_ifloor(STBTT_FIX * -dxdy); + else + z->dx = STBTT_ifloor(STBTT_FIX * dxdy); + + z->x = STBTT_ifloor(STBTT_FIX * e->x0 + z->dx * (start_point - e->y0)); // use z->dx so when we offset later it's by the same amount + z->x -= off_x * STBTT_FIX; + + z->ey = e->y1; + z->next = 0; + z->direction = e->invert ? 1 : -1; + return z; +} +#elif STBTT_RASTERIZER_VERSION == 2 +static stbtt__active_edge *stbtt__new_active(stbtt__hheap *hh, stbtt__edge *e, int off_x, float start_point, void *userdata) +{ + stbtt__active_edge *z = (stbtt__active_edge *) stbtt__hheap_alloc(hh, sizeof(*z), userdata); + float dxdy = (e->x1 - e->x0) / (e->y1 - e->y0); + STBTT_assert(z != NULL); + //STBTT_assert(e->y0 <= start_point); + if (!z) return z; + z->fdx = dxdy; + z->fdy = dxdy != 0.0f ? (1.0f/dxdy) : 0.0f; + z->fx = e->x0 + dxdy * (start_point - e->y0); + z->fx -= off_x; + z->direction = e->invert ? 1.0f : -1.0f; + z->sy = e->y0; + z->ey = e->y1; + z->next = 0; + return z; +} +#else +#error "Unrecognized value of STBTT_RASTERIZER_VERSION" +#endif + +#if STBTT_RASTERIZER_VERSION == 1 +// note: this routine clips fills that extend off the edges... ideally this +// wouldn't happen, but it could happen if the truetype glyph bounding boxes +// are wrong, or if the user supplies a too-small bitmap +static void stbtt__fill_active_edges(unsigned char *scanline, int len, stbtt__active_edge *e, int max_weight) +{ + // non-zero winding fill + int x0=0, w=0; + + while (e) { + if (w == 0) { + // if we're currently at zero, we need to record the edge start point + x0 = e->x; w += e->direction; + } else { + int x1 = e->x; w += e->direction; + // if we went to zero, we need to draw + if (w == 0) { + int i = x0 >> STBTT_FIXSHIFT; + int j = x1 >> STBTT_FIXSHIFT; + + if (i < len && j >= 0) { + if (i == j) { + // x0,x1 are the same pixel, so compute combined coverage + scanline[i] = scanline[i] + (stbtt_uint8) ((x1 - x0) * max_weight >> STBTT_FIXSHIFT); + } else { + if (i >= 0) // add antialiasing for x0 + scanline[i] = scanline[i] + (stbtt_uint8) (((STBTT_FIX - (x0 & STBTT_FIXMASK)) * max_weight) >> STBTT_FIXSHIFT); + else + i = -1; // clip + + if (j < len) // add antialiasing for x1 + scanline[j] = scanline[j] + (stbtt_uint8) (((x1 & STBTT_FIXMASK) * max_weight) >> STBTT_FIXSHIFT); + else + j = len; // clip + + for (++i; i < j; ++i) // fill pixels between x0 and x1 + scanline[i] = scanline[i] + (stbtt_uint8) max_weight; + } + } + } + } + + e = e->next; + } +} + +static void stbtt__rasterize_sorted_edges(stbtt__bitmap *result, stbtt__edge *e, int n, int vsubsample, int off_x, int off_y, void *userdata) +{ + stbtt__hheap hh = { 0, 0, 0 }; + stbtt__active_edge *active = NULL; + int y,j=0; + int max_weight = (255 / vsubsample); // weight per vertical scanline + int s; // vertical subsample index + unsigned char scanline_data[512], *scanline; + + if (result->w > 512) + scanline = (unsigned char *) STBTT_malloc(result->w, userdata); + else + scanline = scanline_data; + + y = off_y * vsubsample; + e[n].y0 = (off_y + result->h) * (float) vsubsample + 1; + + while (j < result->h) { + STBTT_memset(scanline, 0, result->w); + for (s=0; s < vsubsample; ++s) { + // find center of pixel for this scanline + float scan_y = y + 0.5f; + stbtt__active_edge **step = &active; + + // update all active edges; + // remove all active edges that terminate before the center of this scanline + while (*step) { + stbtt__active_edge * z = *step; + if (z->ey <= scan_y) { + *step = z->next; // delete from list + STBTT_assert(z->direction); + z->direction = 0; + stbtt__hheap_free(&hh, z); + } else { + z->x += z->dx; // advance to position for current scanline + step = &((*step)->next); // advance through list + } + } + + // resort the list if needed + for(;;) { + int changed=0; + step = &active; + while (*step && (*step)->next) { + if ((*step)->x > (*step)->next->x) { + stbtt__active_edge *t = *step; + stbtt__active_edge *q = t->next; + + t->next = q->next; + q->next = t; + *step = q; + changed = 1; + } + step = &(*step)->next; + } + if (!changed) break; + } + + // insert all edges that start before the center of this scanline -- omit ones that also end on this scanline + while (e->y0 <= scan_y) { + if (e->y1 > scan_y) { + stbtt__active_edge *z = stbtt__new_active(&hh, e, off_x, scan_y, userdata); + if (z != NULL) { + // find insertion point + if (active == NULL) + active = z; + else if (z->x < active->x) { + // insert at front + z->next = active; + active = z; + } else { + // find thing to insert AFTER + stbtt__active_edge *p = active; + while (p->next && p->next->x < z->x) + p = p->next; + // at this point, p->next->x is NOT < z->x + z->next = p->next; + p->next = z; + } + } + } + ++e; + } + + // now process all active edges in XOR fashion + if (active) + stbtt__fill_active_edges(scanline, result->w, active, max_weight); + + ++y; + } + STBTT_memcpy(result->pixels + j * result->stride, scanline, result->w); + ++j; + } + + stbtt__hheap_cleanup(&hh, userdata); + + if (scanline != scanline_data) + STBTT_free(scanline, userdata); +} + +#elif STBTT_RASTERIZER_VERSION == 2 + +// the edge passed in here does not cross the vertical line at x or the vertical line at x+1 +// (i.e. it has already been clipped to those) +static void stbtt__handle_clipped_edge(float *scanline, int x, stbtt__active_edge *e, float x0, float y0, float x1, float y1) +{ + if (y0 == y1) return; + STBTT_assert(y0 < y1); + STBTT_assert(e->sy <= e->ey); + if (y0 > e->ey) return; + if (y1 < e->sy) return; + if (y0 < e->sy) { + x0 += (x1-x0) * (e->sy - y0) / (y1-y0); + y0 = e->sy; + } + if (y1 > e->ey) { + x1 += (x1-x0) * (e->ey - y1) / (y1-y0); + y1 = e->ey; + } + + if (x0 == x) + STBTT_assert(x1 <= x+1); + else if (x0 == x+1) + STBTT_assert(x1 >= x); + else if (x0 <= x) + STBTT_assert(x1 <= x); + else if (x0 >= x+1) + STBTT_assert(x1 >= x+1); + else + STBTT_assert(x1 >= x && x1 <= x+1); + + if (x0 <= x && x1 <= x) + scanline[x] += e->direction * (y1-y0); + else if (x0 >= x+1 && x1 >= x+1) + ; + else { + STBTT_assert(x0 >= x && x0 <= x+1 && x1 >= x && x1 <= x+1); + scanline[x] += e->direction * (y1-y0) * (1-((x0-x)+(x1-x))/2); // coverage = 1 - average x position + } +} + +static void stbtt__fill_active_edges_new(float *scanline, float *scanline_fill, int len, stbtt__active_edge *e, float y_top) +{ + float y_bottom = y_top+1; + + while (e) { + // brute force every pixel + + // compute intersection points with top & bottom + STBTT_assert(e->ey >= y_top); + + if (e->fdx == 0) { + float x0 = e->fx; + if (x0 < len) { + if (x0 >= 0) { + stbtt__handle_clipped_edge(scanline,(int) x0,e, x0,y_top, x0,y_bottom); + stbtt__handle_clipped_edge(scanline_fill-1,(int) x0+1,e, x0,y_top, x0,y_bottom); + } else { + stbtt__handle_clipped_edge(scanline_fill-1,0,e, x0,y_top, x0,y_bottom); + } + } + } else { + float x0 = e->fx; + float dx = e->fdx; + float xb = x0 + dx; + float x_top, x_bottom; + float sy0,sy1; + float dy = e->fdy; + STBTT_assert(e->sy <= y_bottom && e->ey >= y_top); + + // compute endpoints of line segment clipped to this scanline (if the + // line segment starts on this scanline. x0 is the intersection of the + // line with y_top, but that may be off the line segment. + if (e->sy > y_top) { + x_top = x0 + dx * (e->sy - y_top); + sy0 = e->sy; + } else { + x_top = x0; + sy0 = y_top; + } + if (e->ey < y_bottom) { + x_bottom = x0 + dx * (e->ey - y_top); + sy1 = e->ey; + } else { + x_bottom = xb; + sy1 = y_bottom; + } + + if (x_top >= 0 && x_bottom >= 0 && x_top < len && x_bottom < len) { + // from here on, we don't have to range check x values + + if ((int) x_top == (int) x_bottom) { + float height; + // simple case, only spans one pixel + int x = (int) x_top; + height = sy1 - sy0; + STBTT_assert(x >= 0 && x < len); + scanline[x] += e->direction * (1-((x_top - x) + (x_bottom-x))/2) * height; + scanline_fill[x] += e->direction * height; // everything right of this pixel is filled + } else { + int x,x1,x2; + float y_crossing, step, sign, area; + // covers 2+ pixels + if (x_top > x_bottom) { + // flip scanline vertically; signed area is the same + float t; + sy0 = y_bottom - (sy0 - y_top); + sy1 = y_bottom - (sy1 - y_top); + t = sy0, sy0 = sy1, sy1 = t; + t = x_bottom, x_bottom = x_top, x_top = t; + dx = -dx; + dy = -dy; + t = x0, x0 = xb, xb = t; + // [DEAR IMGUI] Fix static analyzer warning + (void)dx; // [ImGui: fix static analyzer warning] + } + + x1 = (int) x_top; + x2 = (int) x_bottom; + // compute intersection with y axis at x1+1 + y_crossing = (x1+1 - x0) * dy + y_top; + + sign = e->direction; + // area of the rectangle covered from y0..y_crossing + area = sign * (y_crossing-sy0); + // area of the triangle (x_top,y0), (x+1,y0), (x+1,y_crossing) + scanline[x1] += area * (1-((x_top - x1)+(x1+1-x1))/2); + + step = sign * dy; + for (x = x1+1; x < x2; ++x) { + scanline[x] += area + step/2; + area += step; + } + y_crossing += dy * (x2 - (x1+1)); + + STBTT_assert(STBTT_fabs(area) <= 1.01f); + + scanline[x2] += area + sign * (1-((x2-x2)+(x_bottom-x2))/2) * (sy1-y_crossing); + + scanline_fill[x2] += sign * (sy1-sy0); + } + } else { + // if edge goes outside of box we're drawing, we require + // clipping logic. since this does not match the intended use + // of this library, we use a different, very slow brute + // force implementation + int x; + for (x=0; x < len; ++x) { + // cases: + // + // there can be up to two intersections with the pixel. any intersection + // with left or right edges can be handled by splitting into two (or three) + // regions. intersections with top & bottom do not necessitate case-wise logic. + // + // the old way of doing this found the intersections with the left & right edges, + // then used some simple logic to produce up to three segments in sorted order + // from top-to-bottom. however, this had a problem: if an x edge was epsilon + // across the x border, then the corresponding y position might not be distinct + // from the other y segment, and it might ignored as an empty segment. to avoid + // that, we need to explicitly produce segments based on x positions. + + // rename variables to clearly-defined pairs + float y0 = y_top; + float x1 = (float) (x); + float x2 = (float) (x+1); + float x3 = xb; + float y3 = y_bottom; + + // x = e->x + e->dx * (y-y_top) + // (y-y_top) = (x - e->x) / e->dx + // y = (x - e->x) / e->dx + y_top + float y1 = (x - x0) / dx + y_top; + float y2 = (x+1 - x0) / dx + y_top; + + if (x0 < x1 && x3 > x2) { // three segments descending down-right + stbtt__handle_clipped_edge(scanline,x,e, x0,y0, x1,y1); + stbtt__handle_clipped_edge(scanline,x,e, x1,y1, x2,y2); + stbtt__handle_clipped_edge(scanline,x,e, x2,y2, x3,y3); + } else if (x3 < x1 && x0 > x2) { // three segments descending down-left + stbtt__handle_clipped_edge(scanline,x,e, x0,y0, x2,y2); + stbtt__handle_clipped_edge(scanline,x,e, x2,y2, x1,y1); + stbtt__handle_clipped_edge(scanline,x,e, x1,y1, x3,y3); + } else if (x0 < x1 && x3 > x1) { // two segments across x, down-right + stbtt__handle_clipped_edge(scanline,x,e, x0,y0, x1,y1); + stbtt__handle_clipped_edge(scanline,x,e, x1,y1, x3,y3); + } else if (x3 < x1 && x0 > x1) { // two segments across x, down-left + stbtt__handle_clipped_edge(scanline,x,e, x0,y0, x1,y1); + stbtt__handle_clipped_edge(scanline,x,e, x1,y1, x3,y3); + } else if (x0 < x2 && x3 > x2) { // two segments across x+1, down-right + stbtt__handle_clipped_edge(scanline,x,e, x0,y0, x2,y2); + stbtt__handle_clipped_edge(scanline,x,e, x2,y2, x3,y3); + } else if (x3 < x2 && x0 > x2) { // two segments across x+1, down-left + stbtt__handle_clipped_edge(scanline,x,e, x0,y0, x2,y2); + stbtt__handle_clipped_edge(scanline,x,e, x2,y2, x3,y3); + } else { // one segment + stbtt__handle_clipped_edge(scanline,x,e, x0,y0, x3,y3); + } + } + } + } + e = e->next; + } +} + +// directly AA rasterize edges w/o supersampling +static void stbtt__rasterize_sorted_edges(stbtt__bitmap *result, stbtt__edge *e, int n, int vsubsample, int off_x, int off_y, void *userdata) +{ + stbtt__hheap hh = { 0, 0, 0 }; + stbtt__active_edge *active = NULL; + int y,j=0, i; + float scanline_data[129], *scanline, *scanline2; + + STBTT__NOTUSED(vsubsample); + + if (result->w > 64) + scanline = (float *) STBTT_malloc((result->w*2+1) * sizeof(float), userdata); + else + scanline = scanline_data; + + scanline2 = scanline + result->w; + + y = off_y; + e[n].y0 = (float) (off_y + result->h) + 1; + + while (j < result->h) { + // find center of pixel for this scanline + float scan_y_top = y + 0.0f; + float scan_y_bottom = y + 1.0f; + stbtt__active_edge **step = &active; + + STBTT_memset(scanline , 0, result->w*sizeof(scanline[0])); + STBTT_memset(scanline2, 0, (result->w+1)*sizeof(scanline[0])); + + // update all active edges; + // remove all active edges that terminate before the top of this scanline + while (*step) { + stbtt__active_edge * z = *step; + if (z->ey <= scan_y_top) { + *step = z->next; // delete from list + STBTT_assert(z->direction); + z->direction = 0; + stbtt__hheap_free(&hh, z); + } else { + step = &((*step)->next); // advance through list + } + } + + // insert all edges that start before the bottom of this scanline + while (e->y0 <= scan_y_bottom) { + if (e->y0 != e->y1) { + stbtt__active_edge *z = stbtt__new_active(&hh, e, off_x, scan_y_top, userdata); + if (z != NULL) { + if (j == 0 && off_y != 0) { + if (z->ey < scan_y_top) { + // this can happen due to subpixel positioning and some kind of fp rounding error i think + z->ey = scan_y_top; + } + } + STBTT_assert(z->ey >= scan_y_top); // if we get really unlucky a tiny bit of an edge can be out of bounds + // insert at front + z->next = active; + active = z; + } + } + ++e; + } + + // now process all active edges + if (active) + stbtt__fill_active_edges_new(scanline, scanline2+1, result->w, active, scan_y_top); + + { + float sum = 0; + for (i=0; i < result->w; ++i) { + float k; + int m; + sum += scanline2[i]; + k = scanline[i] + sum; + k = (float) STBTT_fabs(k)*255 + 0.5f; + m = (int) k; + if (m > 255) m = 255; + result->pixels[j*result->stride + i] = (unsigned char) m; + } + } + // advance all the edges + step = &active; + while (*step) { + stbtt__active_edge *z = *step; + z->fx += z->fdx; // advance to position for current scanline + step = &((*step)->next); // advance through list + } + + ++y; + ++j; + } + + stbtt__hheap_cleanup(&hh, userdata); + + if (scanline != scanline_data) + STBTT_free(scanline, userdata); +} +#else +#error "Unrecognized value of STBTT_RASTERIZER_VERSION" +#endif + +#define STBTT__COMPARE(a,b) ((a)->y0 < (b)->y0) + +static void stbtt__sort_edges_ins_sort(stbtt__edge *p, int n) +{ + int i,j; + for (i=1; i < n; ++i) { + stbtt__edge t = p[i], *a = &t; + j = i; + while (j > 0) { + stbtt__edge *b = &p[j-1]; + int c = STBTT__COMPARE(a,b); + if (!c) break; + p[j] = p[j-1]; + --j; + } + if (i != j) + p[j] = t; + } +} + +static void stbtt__sort_edges_quicksort(stbtt__edge *p, int n) +{ + /* threshold for transitioning to insertion sort */ + while (n > 12) { + stbtt__edge t; + int c01,c12,c,m,i,j; + + /* compute median of three */ + m = n >> 1; + c01 = STBTT__COMPARE(&p[0],&p[m]); + c12 = STBTT__COMPARE(&p[m],&p[n-1]); + /* if 0 >= mid >= end, or 0 < mid < end, then use mid */ + if (c01 != c12) { + /* otherwise, we'll need to swap something else to middle */ + int z; + c = STBTT__COMPARE(&p[0],&p[n-1]); + /* 0>mid && midn => n; 0 0 */ + /* 0n: 0>n => 0; 0 n */ + z = (c == c12) ? 0 : n-1; + t = p[z]; + p[z] = p[m]; + p[m] = t; + } + /* now p[m] is the median-of-three */ + /* swap it to the beginning so it won't move around */ + t = p[0]; + p[0] = p[m]; + p[m] = t; + + /* partition loop */ + i=1; + j=n-1; + for(;;) { + /* handling of equality is crucial here */ + /* for sentinels & efficiency with duplicates */ + for (;;++i) { + if (!STBTT__COMPARE(&p[i], &p[0])) break; + } + for (;;--j) { + if (!STBTT__COMPARE(&p[0], &p[j])) break; + } + /* make sure we haven't crossed */ + if (i >= j) break; + t = p[i]; + p[i] = p[j]; + p[j] = t; + + ++i; + --j; + } + /* recurse on smaller side, iterate on larger */ + if (j < (n-i)) { + stbtt__sort_edges_quicksort(p,j); + p = p+i; + n = n-i; + } else { + stbtt__sort_edges_quicksort(p+i, n-i); + n = j; + } + } +} + +static void stbtt__sort_edges(stbtt__edge *p, int n) +{ + stbtt__sort_edges_quicksort(p, n); + stbtt__sort_edges_ins_sort(p, n); +} + +typedef struct +{ + float x,y; +} stbtt__point; + +static void stbtt__rasterize(stbtt__bitmap *result, stbtt__point *pts, int *wcount, int windings, float scale_x, float scale_y, float shift_x, float shift_y, int off_x, int off_y, int invert, void *userdata) +{ + float y_scale_inv = invert ? -scale_y : scale_y; + stbtt__edge *e; + int n,i,j,k,m; +#if STBTT_RASTERIZER_VERSION == 1 + int vsubsample = result->h < 8 ? 15 : 5; +#elif STBTT_RASTERIZER_VERSION == 2 + int vsubsample = 1; +#else + #error "Unrecognized value of STBTT_RASTERIZER_VERSION" +#endif + // vsubsample should divide 255 evenly; otherwise we won't reach full opacity + + // now we have to blow out the windings into explicit edge lists + n = 0; + for (i=0; i < windings; ++i) + n += wcount[i]; + + e = (stbtt__edge *) STBTT_malloc(sizeof(*e) * (n+1), userdata); // add an extra one as a sentinel + if (e == 0) return; + n = 0; + + m=0; + for (i=0; i < windings; ++i) { + stbtt__point *p = pts + m; + m += wcount[i]; + j = wcount[i]-1; + for (k=0; k < wcount[i]; j=k++) { + int a=k,b=j; + // skip the edge if horizontal + if (p[j].y == p[k].y) + continue; + // add edge from j to k to the list + e[n].invert = 0; + if (invert ? p[j].y > p[k].y : p[j].y < p[k].y) { + e[n].invert = 1; + a=j,b=k; + } + e[n].x0 = p[a].x * scale_x + shift_x; + e[n].y0 = (p[a].y * y_scale_inv + shift_y) * vsubsample; + e[n].x1 = p[b].x * scale_x + shift_x; + e[n].y1 = (p[b].y * y_scale_inv + shift_y) * vsubsample; + ++n; + } + } + + // now sort the edges by their highest point (should snap to integer, and then by x) + //STBTT_sort(e, n, sizeof(e[0]), stbtt__edge_compare); + stbtt__sort_edges(e, n); + + // now, traverse the scanlines and find the intersections on each scanline, use xor winding rule + stbtt__rasterize_sorted_edges(result, e, n, vsubsample, off_x, off_y, userdata); + + STBTT_free(e, userdata); +} + +static void stbtt__add_point(stbtt__point *points, int n, float x, float y) +{ + if (!points) return; // during first pass, it's unallocated + points[n].x = x; + points[n].y = y; +} + +// tessellate until threshold p is happy... @TODO warped to compensate for non-linear stretching +static int stbtt__tesselate_curve(stbtt__point *points, int *num_points, float x0, float y0, float x1, float y1, float x2, float y2, float objspace_flatness_squared, int n) +{ + // midpoint + float mx = (x0 + 2*x1 + x2)/4; + float my = (y0 + 2*y1 + y2)/4; + // versus directly drawn line + float dx = (x0+x2)/2 - mx; + float dy = (y0+y2)/2 - my; + if (n > 16) // 65536 segments on one curve better be enough! + return 1; + if (dx*dx+dy*dy > objspace_flatness_squared) { // half-pixel error allowed... need to be smaller if AA + stbtt__tesselate_curve(points, num_points, x0,y0, (x0+x1)/2.0f,(y0+y1)/2.0f, mx,my, objspace_flatness_squared,n+1); + stbtt__tesselate_curve(points, num_points, mx,my, (x1+x2)/2.0f,(y1+y2)/2.0f, x2,y2, objspace_flatness_squared,n+1); + } else { + stbtt__add_point(points, *num_points,x2,y2); + *num_points = *num_points+1; + } + return 1; +} + +static void stbtt__tesselate_cubic(stbtt__point *points, int *num_points, float x0, float y0, float x1, float y1, float x2, float y2, float x3, float y3, float objspace_flatness_squared, int n) +{ + // @TODO this "flatness" calculation is just made-up nonsense that seems to work well enough + float dx0 = x1-x0; + float dy0 = y1-y0; + float dx1 = x2-x1; + float dy1 = y2-y1; + float dx2 = x3-x2; + float dy2 = y3-y2; + float dx = x3-x0; + float dy = y3-y0; + float longlen = (float) (STBTT_sqrt(dx0*dx0+dy0*dy0)+STBTT_sqrt(dx1*dx1+dy1*dy1)+STBTT_sqrt(dx2*dx2+dy2*dy2)); + float shortlen = (float) STBTT_sqrt(dx*dx+dy*dy); + float flatness_squared = longlen*longlen-shortlen*shortlen; + + if (n > 16) // 65536 segments on one curve better be enough! + return; + + if (flatness_squared > objspace_flatness_squared) { + float x01 = (x0+x1)/2; + float y01 = (y0+y1)/2; + float x12 = (x1+x2)/2; + float y12 = (y1+y2)/2; + float x23 = (x2+x3)/2; + float y23 = (y2+y3)/2; + + float xa = (x01+x12)/2; + float ya = (y01+y12)/2; + float xb = (x12+x23)/2; + float yb = (y12+y23)/2; + + float mx = (xa+xb)/2; + float my = (ya+yb)/2; + + stbtt__tesselate_cubic(points, num_points, x0,y0, x01,y01, xa,ya, mx,my, objspace_flatness_squared,n+1); + stbtt__tesselate_cubic(points, num_points, mx,my, xb,yb, x23,y23, x3,y3, objspace_flatness_squared,n+1); + } else { + stbtt__add_point(points, *num_points,x3,y3); + *num_points = *num_points+1; + } +} + +// returns number of contours +static stbtt__point *stbtt_FlattenCurves(stbtt_vertex *vertices, int num_verts, float objspace_flatness, int **contour_lengths, int *num_contours, void *userdata) +{ + stbtt__point *points=0; + int num_points=0; + + float objspace_flatness_squared = objspace_flatness * objspace_flatness; + int i,n=0,start=0, pass; + + // count how many "moves" there are to get the contour count + for (i=0; i < num_verts; ++i) + if (vertices[i].type == STBTT_vmove) + ++n; + + *num_contours = n; + if (n == 0) return 0; + + *contour_lengths = (int *) STBTT_malloc(sizeof(**contour_lengths) * n, userdata); + + if (*contour_lengths == 0) { + *num_contours = 0; + return 0; + } + + // make two passes through the points so we don't need to realloc + for (pass=0; pass < 2; ++pass) { + float x=0,y=0; + if (pass == 1) { + points = (stbtt__point *) STBTT_malloc(num_points * sizeof(points[0]), userdata); + if (points == NULL) goto error; + } + num_points = 0; + n= -1; + for (i=0; i < num_verts; ++i) { + switch (vertices[i].type) { + case STBTT_vmove: + // start the next contour + if (n >= 0) + (*contour_lengths)[n] = num_points - start; + ++n; + start = num_points; + + x = vertices[i].x, y = vertices[i].y; + stbtt__add_point(points, num_points++, x,y); + break; + case STBTT_vline: + x = vertices[i].x, y = vertices[i].y; + stbtt__add_point(points, num_points++, x, y); + break; + case STBTT_vcurve: + stbtt__tesselate_curve(points, &num_points, x,y, + vertices[i].cx, vertices[i].cy, + vertices[i].x, vertices[i].y, + objspace_flatness_squared, 0); + x = vertices[i].x, y = vertices[i].y; + break; + case STBTT_vcubic: + stbtt__tesselate_cubic(points, &num_points, x,y, + vertices[i].cx, vertices[i].cy, + vertices[i].cx1, vertices[i].cy1, + vertices[i].x, vertices[i].y, + objspace_flatness_squared, 0); + x = vertices[i].x, y = vertices[i].y; + break; + } + } + (*contour_lengths)[n] = num_points - start; + } + + return points; +error: + STBTT_free(points, userdata); + STBTT_free(*contour_lengths, userdata); + *contour_lengths = 0; + *num_contours = 0; + return NULL; +} + +STBTT_DEF void stbtt_Rasterize(stbtt__bitmap *result, float flatness_in_pixels, stbtt_vertex *vertices, int num_verts, float scale_x, float scale_y, float shift_x, float shift_y, int x_off, int y_off, int invert, void *userdata) +{ + float scale = scale_x > scale_y ? scale_y : scale_x; + int winding_count = 0; + int *winding_lengths = NULL; + stbtt__point *windings = stbtt_FlattenCurves(vertices, num_verts, flatness_in_pixels / scale, &winding_lengths, &winding_count, userdata); + if (windings) { + stbtt__rasterize(result, windings, winding_lengths, winding_count, scale_x, scale_y, shift_x, shift_y, x_off, y_off, invert, userdata); + STBTT_free(winding_lengths, userdata); + STBTT_free(windings, userdata); + } +} + +STBTT_DEF void stbtt_FreeBitmap(unsigned char *bitmap, void *userdata) +{ + STBTT_free(bitmap, userdata); +} + +STBTT_DEF unsigned char *stbtt_GetGlyphBitmapSubpixel(const stbtt_fontinfo *info, float scale_x, float scale_y, float shift_x, float shift_y, int glyph, int *width, int *height, int *xoff, int *yoff) +{ + int ix0,iy0,ix1,iy1; + stbtt__bitmap gbm; + stbtt_vertex *vertices; + int num_verts = stbtt_GetGlyphShape(info, glyph, &vertices); + + if (scale_x == 0) scale_x = scale_y; + if (scale_y == 0) { + if (scale_x == 0) { + STBTT_free(vertices, info->userdata); + return NULL; + } + scale_y = scale_x; + } + + stbtt_GetGlyphBitmapBoxSubpixel(info, glyph, scale_x, scale_y, shift_x, shift_y, &ix0,&iy0,&ix1,&iy1); + + // now we get the size + gbm.w = (ix1 - ix0); + gbm.h = (iy1 - iy0); + gbm.pixels = NULL; // in case we error + + if (width ) *width = gbm.w; + if (height) *height = gbm.h; + if (xoff ) *xoff = ix0; + if (yoff ) *yoff = iy0; + + if (gbm.w && gbm.h) { + gbm.pixels = (unsigned char *) STBTT_malloc(gbm.w * gbm.h, info->userdata); + if (gbm.pixels) { + gbm.stride = gbm.w; + + stbtt_Rasterize(&gbm, 0.35f, vertices, num_verts, scale_x, scale_y, shift_x, shift_y, ix0, iy0, 1, info->userdata); + } + } + STBTT_free(vertices, info->userdata); + return gbm.pixels; +} + +STBTT_DEF unsigned char *stbtt_GetGlyphBitmap(const stbtt_fontinfo *info, float scale_x, float scale_y, int glyph, int *width, int *height, int *xoff, int *yoff) +{ + return stbtt_GetGlyphBitmapSubpixel(info, scale_x, scale_y, 0.0f, 0.0f, glyph, width, height, xoff, yoff); +} + +STBTT_DEF void stbtt_MakeGlyphBitmapSubpixel(const stbtt_fontinfo *info, unsigned char *output, int out_w, int out_h, int out_stride, float scale_x, float scale_y, float shift_x, float shift_y, int glyph) +{ + int ix0,iy0; + stbtt_vertex *vertices; + int num_verts = stbtt_GetGlyphShape(info, glyph, &vertices); + stbtt__bitmap gbm; + + stbtt_GetGlyphBitmapBoxSubpixel(info, glyph, scale_x, scale_y, shift_x, shift_y, &ix0,&iy0,0,0); + gbm.pixels = output; + gbm.w = out_w; + gbm.h = out_h; + gbm.stride = out_stride; + + if (gbm.w && gbm.h) + stbtt_Rasterize(&gbm, 0.35f, vertices, num_verts, scale_x, scale_y, shift_x, shift_y, ix0,iy0, 1, info->userdata); + + STBTT_free(vertices, info->userdata); +} + +STBTT_DEF void stbtt_MakeGlyphBitmap(const stbtt_fontinfo *info, unsigned char *output, int out_w, int out_h, int out_stride, float scale_x, float scale_y, int glyph) +{ + stbtt_MakeGlyphBitmapSubpixel(info, output, out_w, out_h, out_stride, scale_x, scale_y, 0.0f,0.0f, glyph); +} + +STBTT_DEF unsigned char *stbtt_GetCodepointBitmapSubpixel(const stbtt_fontinfo *info, float scale_x, float scale_y, float shift_x, float shift_y, int codepoint, int *width, int *height, int *xoff, int *yoff) +{ + return stbtt_GetGlyphBitmapSubpixel(info, scale_x, scale_y,shift_x,shift_y, stbtt_FindGlyphIndex(info,codepoint), width,height,xoff,yoff); +} + +STBTT_DEF void stbtt_MakeCodepointBitmapSubpixelPrefilter(const stbtt_fontinfo *info, unsigned char *output, int out_w, int out_h, int out_stride, float scale_x, float scale_y, float shift_x, float shift_y, int oversample_x, int oversample_y, float *sub_x, float *sub_y, int codepoint) +{ + stbtt_MakeGlyphBitmapSubpixelPrefilter(info, output, out_w, out_h, out_stride, scale_x, scale_y, shift_x, shift_y, oversample_x, oversample_y, sub_x, sub_y, stbtt_FindGlyphIndex(info,codepoint)); +} + +STBTT_DEF void stbtt_MakeCodepointBitmapSubpixel(const stbtt_fontinfo *info, unsigned char *output, int out_w, int out_h, int out_stride, float scale_x, float scale_y, float shift_x, float shift_y, int codepoint) +{ + stbtt_MakeGlyphBitmapSubpixel(info, output, out_w, out_h, out_stride, scale_x, scale_y, shift_x, shift_y, stbtt_FindGlyphIndex(info,codepoint)); +} + +STBTT_DEF unsigned char *stbtt_GetCodepointBitmap(const stbtt_fontinfo *info, float scale_x, float scale_y, int codepoint, int *width, int *height, int *xoff, int *yoff) +{ + return stbtt_GetCodepointBitmapSubpixel(info, scale_x, scale_y, 0.0f,0.0f, codepoint, width,height,xoff,yoff); +} + +STBTT_DEF void stbtt_MakeCodepointBitmap(const stbtt_fontinfo *info, unsigned char *output, int out_w, int out_h, int out_stride, float scale_x, float scale_y, int codepoint) +{ + stbtt_MakeCodepointBitmapSubpixel(info, output, out_w, out_h, out_stride, scale_x, scale_y, 0.0f,0.0f, codepoint); +} + +////////////////////////////////////////////////////////////////////////////// +// +// bitmap baking +// +// This is SUPER-CRAPPY packing to keep source code small + +static int stbtt_BakeFontBitmap_internal(unsigned char *data, int offset, // font location (use offset=0 for plain .ttf) + float pixel_height, // height of font in pixels + unsigned char *pixels, int pw, int ph, // bitmap to be filled in + int first_char, int num_chars, // characters to bake + stbtt_bakedchar *chardata) +{ + float scale; + int x,y,bottom_y, i; + stbtt_fontinfo f; + f.userdata = NULL; + if (!stbtt_InitFont(&f, data, offset)) + return -1; + STBTT_memset(pixels, 0, pw*ph); // background of 0 around pixels + x=y=1; + bottom_y = 1; + + scale = stbtt_ScaleForPixelHeight(&f, pixel_height); + + for (i=0; i < num_chars; ++i) { + int advance, lsb, x0,y0,x1,y1,gw,gh; + int g = stbtt_FindGlyphIndex(&f, first_char + i); + stbtt_GetGlyphHMetrics(&f, g, &advance, &lsb); + stbtt_GetGlyphBitmapBox(&f, g, scale,scale, &x0,&y0,&x1,&y1); + gw = x1-x0; + gh = y1-y0; + if (x + gw + 1 >= pw) + y = bottom_y, x = 1; // advance to next row + if (y + gh + 1 >= ph) // check if it fits vertically AFTER potentially moving to next row + return -i; + STBTT_assert(x+gw < pw); + STBTT_assert(y+gh < ph); + stbtt_MakeGlyphBitmap(&f, pixels+x+y*pw, gw,gh,pw, scale,scale, g); + chardata[i].x0 = (stbtt_int16) x; + chardata[i].y0 = (stbtt_int16) y; + chardata[i].x1 = (stbtt_int16) (x + gw); + chardata[i].y1 = (stbtt_int16) (y + gh); + chardata[i].xadvance = scale * advance; + chardata[i].xoff = (float) x0; + chardata[i].yoff = (float) y0; + x = x + gw + 1; + if (y+gh+1 > bottom_y) + bottom_y = y+gh+1; + } + return bottom_y; +} + +STBTT_DEF void stbtt_GetBakedQuad(const stbtt_bakedchar *chardata, int pw, int ph, int char_index, float *xpos, float *ypos, stbtt_aligned_quad *q, int opengl_fillrule) +{ + float d3d_bias = opengl_fillrule ? 0 : -0.5f; + float ipw = 1.0f / pw, iph = 1.0f / ph; + const stbtt_bakedchar *b = chardata + char_index; + int round_x = STBTT_ifloor((*xpos + b->xoff) + 0.5f); + int round_y = STBTT_ifloor((*ypos + b->yoff) + 0.5f); + + q->x0 = round_x + d3d_bias; + q->y0 = round_y + d3d_bias; + q->x1 = round_x + b->x1 - b->x0 + d3d_bias; + q->y1 = round_y + b->y1 - b->y0 + d3d_bias; + + q->s0 = b->x0 * ipw; + q->t0 = b->y0 * iph; + q->s1 = b->x1 * ipw; + q->t1 = b->y1 * iph; + + *xpos += b->xadvance; +} + +////////////////////////////////////////////////////////////////////////////// +// +// rectangle packing replacement routines if you don't have stb_rect_pack.h +// + +#ifndef STB_RECT_PACK_VERSION + +typedef int stbrp_coord; + +//////////////////////////////////////////////////////////////////////////////////// +// // +// // +// COMPILER WARNING ?!?!? // +// // +// // +// if you get a compile warning due to these symbols being defined more than // +// once, move #include "stb_rect_pack.h" before #include "stb_truetype.h" // +// // +//////////////////////////////////////////////////////////////////////////////////// + +typedef struct +{ + int width,height; + int x,y,bottom_y; +} stbrp_context; + +typedef struct +{ + unsigned char x; +} stbrp_node; + +struct stbrp_rect +{ + stbrp_coord x,y; + int id,w,h,was_packed; +}; + +static void stbrp_init_target(stbrp_context *con, int pw, int ph, stbrp_node *nodes, int num_nodes) +{ + con->width = pw; + con->height = ph; + con->x = 0; + con->y = 0; + con->bottom_y = 0; + STBTT__NOTUSED(nodes); + STBTT__NOTUSED(num_nodes); +} + +static void stbrp_pack_rects(stbrp_context *con, stbrp_rect *rects, int num_rects) +{ + int i; + for (i=0; i < num_rects; ++i) { + if (con->x + rects[i].w > con->width) { + con->x = 0; + con->y = con->bottom_y; + } + if (con->y + rects[i].h > con->height) + break; + rects[i].x = con->x; + rects[i].y = con->y; + rects[i].was_packed = 1; + con->x += rects[i].w; + if (con->y + rects[i].h > con->bottom_y) + con->bottom_y = con->y + rects[i].h; + } + for ( ; i < num_rects; ++i) + rects[i].was_packed = 0; +} +#endif + +////////////////////////////////////////////////////////////////////////////// +// +// bitmap baking +// +// This is SUPER-AWESOME (tm Ryan Gordon) packing using stb_rect_pack.h. If +// stb_rect_pack.h isn't available, it uses the BakeFontBitmap strategy. + +STBTT_DEF int stbtt_PackBegin(stbtt_pack_context *spc, unsigned char *pixels, int pw, int ph, int stride_in_bytes, int padding, void *alloc_context) +{ + stbrp_context *context = (stbrp_context *) STBTT_malloc(sizeof(*context) ,alloc_context); + int num_nodes = pw - padding; + stbrp_node *nodes = (stbrp_node *) STBTT_malloc(sizeof(*nodes ) * num_nodes,alloc_context); + + if (context == NULL || nodes == NULL) { + if (context != NULL) STBTT_free(context, alloc_context); + if (nodes != NULL) STBTT_free(nodes , alloc_context); + return 0; + } + + spc->user_allocator_context = alloc_context; + spc->width = pw; + spc->height = ph; + spc->pixels = pixels; + spc->pack_info = context; + spc->nodes = nodes; + spc->padding = padding; + spc->stride_in_bytes = stride_in_bytes != 0 ? stride_in_bytes : pw; + spc->h_oversample = 1; + spc->v_oversample = 1; + spc->skip_missing = 0; + + stbrp_init_target(context, pw-padding, ph-padding, nodes, num_nodes); + + if (pixels) + STBTT_memset(pixels, 0, pw*ph); // background of 0 around pixels + + return 1; +} + +STBTT_DEF void stbtt_PackEnd (stbtt_pack_context *spc) +{ + STBTT_free(spc->nodes , spc->user_allocator_context); + STBTT_free(spc->pack_info, spc->user_allocator_context); +} + +STBTT_DEF void stbtt_PackSetOversampling(stbtt_pack_context *spc, unsigned int h_oversample, unsigned int v_oversample) +{ + STBTT_assert(h_oversample <= STBTT_MAX_OVERSAMPLE); + STBTT_assert(v_oversample <= STBTT_MAX_OVERSAMPLE); + if (h_oversample <= STBTT_MAX_OVERSAMPLE) + spc->h_oversample = h_oversample; + if (v_oversample <= STBTT_MAX_OVERSAMPLE) + spc->v_oversample = v_oversample; +} + +STBTT_DEF void stbtt_PackSetSkipMissingCodepoints(stbtt_pack_context *spc, int skip) +{ + spc->skip_missing = skip; +} + +#define STBTT__OVER_MASK (STBTT_MAX_OVERSAMPLE-1) + +static void stbtt__h_prefilter(unsigned char *pixels, int w, int h, int stride_in_bytes, unsigned int kernel_width) +{ + unsigned char buffer[STBTT_MAX_OVERSAMPLE]; + int safe_w = w - kernel_width; + int j; + STBTT_memset(buffer, 0, STBTT_MAX_OVERSAMPLE); // suppress bogus warning from VS2013 -analyze + for (j=0; j < h; ++j) { + int i; + unsigned int total; + STBTT_memset(buffer, 0, kernel_width); + + total = 0; + + // make kernel_width a constant in common cases so compiler can optimize out the divide + switch (kernel_width) { + case 2: + for (i=0; i <= safe_w; ++i) { + total += pixels[i] - buffer[i & STBTT__OVER_MASK]; + buffer[(i+kernel_width) & STBTT__OVER_MASK] = pixels[i]; + pixels[i] = (unsigned char) (total / 2); + } + break; + case 3: + for (i=0; i <= safe_w; ++i) { + total += pixels[i] - buffer[i & STBTT__OVER_MASK]; + buffer[(i+kernel_width) & STBTT__OVER_MASK] = pixels[i]; + pixels[i] = (unsigned char) (total / 3); + } + break; + case 4: + for (i=0; i <= safe_w; ++i) { + total += pixels[i] - buffer[i & STBTT__OVER_MASK]; + buffer[(i+kernel_width) & STBTT__OVER_MASK] = pixels[i]; + pixels[i] = (unsigned char) (total / 4); + } + break; + case 5: + for (i=0; i <= safe_w; ++i) { + total += pixels[i] - buffer[i & STBTT__OVER_MASK]; + buffer[(i+kernel_width) & STBTT__OVER_MASK] = pixels[i]; + pixels[i] = (unsigned char) (total / 5); + } + break; + default: + for (i=0; i <= safe_w; ++i) { + total += pixels[i] - buffer[i & STBTT__OVER_MASK]; + buffer[(i+kernel_width) & STBTT__OVER_MASK] = pixels[i]; + pixels[i] = (unsigned char) (total / kernel_width); + } + break; + } + + for (; i < w; ++i) { + STBTT_assert(pixels[i] == 0); + total -= buffer[i & STBTT__OVER_MASK]; + pixels[i] = (unsigned char) (total / kernel_width); + } + + pixels += stride_in_bytes; + } +} + +static void stbtt__v_prefilter(unsigned char *pixels, int w, int h, int stride_in_bytes, unsigned int kernel_width) +{ + unsigned char buffer[STBTT_MAX_OVERSAMPLE]; + int safe_h = h - kernel_width; + int j; + STBTT_memset(buffer, 0, STBTT_MAX_OVERSAMPLE); // suppress bogus warning from VS2013 -analyze + for (j=0; j < w; ++j) { + int i; + unsigned int total; + STBTT_memset(buffer, 0, kernel_width); + + total = 0; + + // make kernel_width a constant in common cases so compiler can optimize out the divide + switch (kernel_width) { + case 2: + for (i=0; i <= safe_h; ++i) { + total += pixels[i*stride_in_bytes] - buffer[i & STBTT__OVER_MASK]; + buffer[(i+kernel_width) & STBTT__OVER_MASK] = pixels[i*stride_in_bytes]; + pixels[i*stride_in_bytes] = (unsigned char) (total / 2); + } + break; + case 3: + for (i=0; i <= safe_h; ++i) { + total += pixels[i*stride_in_bytes] - buffer[i & STBTT__OVER_MASK]; + buffer[(i+kernel_width) & STBTT__OVER_MASK] = pixels[i*stride_in_bytes]; + pixels[i*stride_in_bytes] = (unsigned char) (total / 3); + } + break; + case 4: + for (i=0; i <= safe_h; ++i) { + total += pixels[i*stride_in_bytes] - buffer[i & STBTT__OVER_MASK]; + buffer[(i+kernel_width) & STBTT__OVER_MASK] = pixels[i*stride_in_bytes]; + pixels[i*stride_in_bytes] = (unsigned char) (total / 4); + } + break; + case 5: + for (i=0; i <= safe_h; ++i) { + total += pixels[i*stride_in_bytes] - buffer[i & STBTT__OVER_MASK]; + buffer[(i+kernel_width) & STBTT__OVER_MASK] = pixels[i*stride_in_bytes]; + pixels[i*stride_in_bytes] = (unsigned char) (total / 5); + } + break; + default: + for (i=0; i <= safe_h; ++i) { + total += pixels[i*stride_in_bytes] - buffer[i & STBTT__OVER_MASK]; + buffer[(i+kernel_width) & STBTT__OVER_MASK] = pixels[i*stride_in_bytes]; + pixels[i*stride_in_bytes] = (unsigned char) (total / kernel_width); + } + break; + } + + for (; i < h; ++i) { + STBTT_assert(pixels[i*stride_in_bytes] == 0); + total -= buffer[i & STBTT__OVER_MASK]; + pixels[i*stride_in_bytes] = (unsigned char) (total / kernel_width); + } + + pixels += 1; + } +} + +static float stbtt__oversample_shift(int oversample) +{ + if (!oversample) + return 0.0f; + + // The prefilter is a box filter of width "oversample", + // which shifts phase by (oversample - 1)/2 pixels in + // oversampled space. We want to shift in the opposite + // direction to counter this. + return (float)-(oversample - 1) / (2.0f * (float)oversample); +} + +// rects array must be big enough to accommodate all characters in the given ranges +STBTT_DEF int stbtt_PackFontRangesGatherRects(stbtt_pack_context *spc, const stbtt_fontinfo *info, stbtt_pack_range *ranges, int num_ranges, stbrp_rect *rects) +{ + int i,j,k; + + k=0; + for (i=0; i < num_ranges; ++i) { + float fh = ranges[i].font_size; + float scale = fh > 0 ? stbtt_ScaleForPixelHeight(info, fh) : stbtt_ScaleForMappingEmToPixels(info, -fh); + ranges[i].h_oversample = (unsigned char) spc->h_oversample; + ranges[i].v_oversample = (unsigned char) spc->v_oversample; + for (j=0; j < ranges[i].num_chars; ++j) { + int x0,y0,x1,y1; + int codepoint = ranges[i].array_of_unicode_codepoints == NULL ? ranges[i].first_unicode_codepoint_in_range + j : ranges[i].array_of_unicode_codepoints[j]; + int glyph = stbtt_FindGlyphIndex(info, codepoint); + if (glyph == 0 && spc->skip_missing) { + rects[k].w = rects[k].h = 0; + } else { + stbtt_GetGlyphBitmapBoxSubpixel(info,glyph, + scale * spc->h_oversample, + scale * spc->v_oversample, + 0,0, + &x0,&y0,&x1,&y1); + rects[k].w = (stbrp_coord) (x1-x0 + spc->padding + spc->h_oversample-1); + rects[k].h = (stbrp_coord) (y1-y0 + spc->padding + spc->v_oversample-1); + } + ++k; + } + } + + return k; +} + +STBTT_DEF void stbtt_MakeGlyphBitmapSubpixelPrefilter(const stbtt_fontinfo *info, unsigned char *output, int out_w, int out_h, int out_stride, float scale_x, float scale_y, float shift_x, float shift_y, int prefilter_x, int prefilter_y, float *sub_x, float *sub_y, int glyph) +{ + stbtt_MakeGlyphBitmapSubpixel(info, + output, + out_w - (prefilter_x - 1), + out_h - (prefilter_y - 1), + out_stride, + scale_x, + scale_y, + shift_x, + shift_y, + glyph); + + if (prefilter_x > 1) + stbtt__h_prefilter(output, out_w, out_h, out_stride, prefilter_x); + + if (prefilter_y > 1) + stbtt__v_prefilter(output, out_w, out_h, out_stride, prefilter_y); + + *sub_x = stbtt__oversample_shift(prefilter_x); + *sub_y = stbtt__oversample_shift(prefilter_y); +} + +// rects array must be big enough to accommodate all characters in the given ranges +STBTT_DEF int stbtt_PackFontRangesRenderIntoRects(stbtt_pack_context *spc, const stbtt_fontinfo *info, stbtt_pack_range *ranges, int num_ranges, stbrp_rect *rects) +{ + int i,j,k, return_value = 1; + + // save current values + int old_h_over = spc->h_oversample; + int old_v_over = spc->v_oversample; + + k = 0; + for (i=0; i < num_ranges; ++i) { + float fh = ranges[i].font_size; + float scale = fh > 0 ? stbtt_ScaleForPixelHeight(info, fh) : stbtt_ScaleForMappingEmToPixels(info, -fh); + float recip_h,recip_v,sub_x,sub_y; + spc->h_oversample = ranges[i].h_oversample; + spc->v_oversample = ranges[i].v_oversample; + recip_h = 1.0f / spc->h_oversample; + recip_v = 1.0f / spc->v_oversample; + sub_x = stbtt__oversample_shift(spc->h_oversample); + sub_y = stbtt__oversample_shift(spc->v_oversample); + for (j=0; j < ranges[i].num_chars; ++j) { + stbrp_rect *r = &rects[k]; + if (r->was_packed && r->w != 0 && r->h != 0) { + stbtt_packedchar *bc = &ranges[i].chardata_for_range[j]; + int advance, lsb, x0,y0,x1,y1; + int codepoint = ranges[i].array_of_unicode_codepoints == NULL ? ranges[i].first_unicode_codepoint_in_range + j : ranges[i].array_of_unicode_codepoints[j]; + int glyph = stbtt_FindGlyphIndex(info, codepoint); + stbrp_coord pad = (stbrp_coord) spc->padding; + + // pad on left and top + r->x += pad; + r->y += pad; + r->w -= pad; + r->h -= pad; + stbtt_GetGlyphHMetrics(info, glyph, &advance, &lsb); + stbtt_GetGlyphBitmapBox(info, glyph, + scale * spc->h_oversample, + scale * spc->v_oversample, + &x0,&y0,&x1,&y1); + stbtt_MakeGlyphBitmapSubpixel(info, + spc->pixels + r->x + r->y*spc->stride_in_bytes, + r->w - spc->h_oversample+1, + r->h - spc->v_oversample+1, + spc->stride_in_bytes, + scale * spc->h_oversample, + scale * spc->v_oversample, + 0,0, + glyph); + + if (spc->h_oversample > 1) + stbtt__h_prefilter(spc->pixels + r->x + r->y*spc->stride_in_bytes, + r->w, r->h, spc->stride_in_bytes, + spc->h_oversample); + + if (spc->v_oversample > 1) + stbtt__v_prefilter(spc->pixels + r->x + r->y*spc->stride_in_bytes, + r->w, r->h, spc->stride_in_bytes, + spc->v_oversample); + + bc->x0 = (stbtt_int16) r->x; + bc->y0 = (stbtt_int16) r->y; + bc->x1 = (stbtt_int16) (r->x + r->w); + bc->y1 = (stbtt_int16) (r->y + r->h); + bc->xadvance = scale * advance; + bc->xoff = (float) x0 * recip_h + sub_x; + bc->yoff = (float) y0 * recip_v + sub_y; + bc->xoff2 = (x0 + r->w) * recip_h + sub_x; + bc->yoff2 = (y0 + r->h) * recip_v + sub_y; + } else { + return_value = 0; // if any fail, report failure + } + + ++k; + } + } + + // restore original values + spc->h_oversample = old_h_over; + spc->v_oversample = old_v_over; + + return return_value; +} + +STBTT_DEF void stbtt_PackFontRangesPackRects(stbtt_pack_context *spc, stbrp_rect *rects, int num_rects) +{ + stbrp_pack_rects((stbrp_context *) spc->pack_info, rects, num_rects); +} + +STBTT_DEF int stbtt_PackFontRanges(stbtt_pack_context *spc, const unsigned char *fontdata, int font_index, stbtt_pack_range *ranges, int num_ranges) +{ + stbtt_fontinfo info; + int i,j,n, return_value; // [DEAR IMGUI] removed = 1 + //stbrp_context *context = (stbrp_context *) spc->pack_info; + stbrp_rect *rects; + + // flag all characters as NOT packed + for (i=0; i < num_ranges; ++i) + for (j=0; j < ranges[i].num_chars; ++j) + ranges[i].chardata_for_range[j].x0 = + ranges[i].chardata_for_range[j].y0 = + ranges[i].chardata_for_range[j].x1 = + ranges[i].chardata_for_range[j].y1 = 0; + + n = 0; + for (i=0; i < num_ranges; ++i) + n += ranges[i].num_chars; + + rects = (stbrp_rect *) STBTT_malloc(sizeof(*rects) * n, spc->user_allocator_context); + if (rects == NULL) + return 0; + + info.userdata = spc->user_allocator_context; + stbtt_InitFont(&info, fontdata, stbtt_GetFontOffsetForIndex(fontdata,font_index)); + + n = stbtt_PackFontRangesGatherRects(spc, &info, ranges, num_ranges, rects); + + stbtt_PackFontRangesPackRects(spc, rects, n); + + return_value = stbtt_PackFontRangesRenderIntoRects(spc, &info, ranges, num_ranges, rects); + + STBTT_free(rects, spc->user_allocator_context); + return return_value; +} + +STBTT_DEF int stbtt_PackFontRange(stbtt_pack_context *spc, const unsigned char *fontdata, int font_index, float font_size, + int first_unicode_codepoint_in_range, int num_chars_in_range, stbtt_packedchar *chardata_for_range) +{ + stbtt_pack_range range; + range.first_unicode_codepoint_in_range = first_unicode_codepoint_in_range; + range.array_of_unicode_codepoints = NULL; + range.num_chars = num_chars_in_range; + range.chardata_for_range = chardata_for_range; + range.font_size = font_size; + return stbtt_PackFontRanges(spc, fontdata, font_index, &range, 1); +} + +STBTT_DEF void stbtt_GetScaledFontVMetrics(const unsigned char *fontdata, int index, float size, float *ascent, float *descent, float *lineGap) +{ + int i_ascent, i_descent, i_lineGap; + float scale; + stbtt_fontinfo info; + stbtt_InitFont(&info, fontdata, stbtt_GetFontOffsetForIndex(fontdata, index)); + scale = size > 0 ? stbtt_ScaleForPixelHeight(&info, size) : stbtt_ScaleForMappingEmToPixels(&info, -size); + stbtt_GetFontVMetrics(&info, &i_ascent, &i_descent, &i_lineGap); + *ascent = (float) i_ascent * scale; + *descent = (float) i_descent * scale; + *lineGap = (float) i_lineGap * scale; +} + +STBTT_DEF void stbtt_GetPackedQuad(const stbtt_packedchar *chardata, int pw, int ph, int char_index, float *xpos, float *ypos, stbtt_aligned_quad *q, int align_to_integer) +{ + float ipw = 1.0f / pw, iph = 1.0f / ph; + const stbtt_packedchar *b = chardata + char_index; + + if (align_to_integer) { + float x = (float) STBTT_ifloor((*xpos + b->xoff) + 0.5f); + float y = (float) STBTT_ifloor((*ypos + b->yoff) + 0.5f); + q->x0 = x; + q->y0 = y; + q->x1 = x + b->xoff2 - b->xoff; + q->y1 = y + b->yoff2 - b->yoff; + } else { + q->x0 = *xpos + b->xoff; + q->y0 = *ypos + b->yoff; + q->x1 = *xpos + b->xoff2; + q->y1 = *ypos + b->yoff2; + } + + q->s0 = b->x0 * ipw; + q->t0 = b->y0 * iph; + q->s1 = b->x1 * ipw; + q->t1 = b->y1 * iph; + + *xpos += b->xadvance; +} + +////////////////////////////////////////////////////////////////////////////// +// +// sdf computation +// + +#define STBTT_min(a,b) ((a) < (b) ? (a) : (b)) +#define STBTT_max(a,b) ((a) < (b) ? (b) : (a)) + +static int stbtt__ray_intersect_bezier(float orig[2], float ray[2], float q0[2], float q1[2], float q2[2], float hits[2][2]) +{ + float q0perp = q0[1]*ray[0] - q0[0]*ray[1]; + float q1perp = q1[1]*ray[0] - q1[0]*ray[1]; + float q2perp = q2[1]*ray[0] - q2[0]*ray[1]; + float roperp = orig[1]*ray[0] - orig[0]*ray[1]; + + float a = q0perp - 2*q1perp + q2perp; + float b = q1perp - q0perp; + float c = q0perp - roperp; + + float s0 = 0., s1 = 0.; + int num_s = 0; + + if (a != 0.0) { + float discr = b*b - a*c; + if (discr > 0.0) { + float rcpna = -1 / a; + float d = (float) STBTT_sqrt(discr); + s0 = (b+d) * rcpna; + s1 = (b-d) * rcpna; + if (s0 >= 0.0 && s0 <= 1.0) + num_s = 1; + if (d > 0.0 && s1 >= 0.0 && s1 <= 1.0) { + if (num_s == 0) s0 = s1; + ++num_s; + } + } + } else { + // 2*b*s + c = 0 + // s = -c / (2*b) + s0 = c / (-2 * b); + if (s0 >= 0.0 && s0 <= 1.0) + num_s = 1; + } + + if (num_s == 0) + return 0; + else { + float rcp_len2 = 1 / (ray[0]*ray[0] + ray[1]*ray[1]); + float rayn_x = ray[0] * rcp_len2, rayn_y = ray[1] * rcp_len2; + + float q0d = q0[0]*rayn_x + q0[1]*rayn_y; + float q1d = q1[0]*rayn_x + q1[1]*rayn_y; + float q2d = q2[0]*rayn_x + q2[1]*rayn_y; + float rod = orig[0]*rayn_x + orig[1]*rayn_y; + + float q10d = q1d - q0d; + float q20d = q2d - q0d; + float q0rd = q0d - rod; + + hits[0][0] = q0rd + s0*(2.0f - 2.0f*s0)*q10d + s0*s0*q20d; + hits[0][1] = a*s0+b; + + if (num_s > 1) { + hits[1][0] = q0rd + s1*(2.0f - 2.0f*s1)*q10d + s1*s1*q20d; + hits[1][1] = a*s1+b; + return 2; + } else { + return 1; + } + } +} + +static int equal(float *a, float *b) +{ + return (a[0] == b[0] && a[1] == b[1]); +} + +static int stbtt__compute_crossings_x(float x, float y, int nverts, stbtt_vertex *verts) +{ + int i; + float orig[2], ray[2] = { 1, 0 }; + float y_frac; + int winding = 0; + + orig[0] = x; + //orig[1] = y; // [DEAR IMGUI] commented double assignment + + // make sure y never passes through a vertex of the shape + y_frac = (float) STBTT_fmod(y, 1.0f); + if (y_frac < 0.01f) + y += 0.01f; + else if (y_frac > 0.99f) + y -= 0.01f; + orig[1] = y; + + // test a ray from (-infinity,y) to (x,y) + for (i=0; i < nverts; ++i) { + if (verts[i].type == STBTT_vline) { + int x0 = (int) verts[i-1].x, y0 = (int) verts[i-1].y; + int x1 = (int) verts[i ].x, y1 = (int) verts[i ].y; + if (y > STBTT_min(y0,y1) && y < STBTT_max(y0,y1) && x > STBTT_min(x0,x1)) { + float x_inter = (y - y0) / (y1 - y0) * (x1-x0) + x0; + if (x_inter < x) + winding += (y0 < y1) ? 1 : -1; + } + } + if (verts[i].type == STBTT_vcurve) { + int x0 = (int) verts[i-1].x , y0 = (int) verts[i-1].y ; + int x1 = (int) verts[i ].cx, y1 = (int) verts[i ].cy; + int x2 = (int) verts[i ].x , y2 = (int) verts[i ].y ; + int ax = STBTT_min(x0,STBTT_min(x1,x2)), ay = STBTT_min(y0,STBTT_min(y1,y2)); + int by = STBTT_max(y0,STBTT_max(y1,y2)); + if (y > ay && y < by && x > ax) { + float q0[2],q1[2],q2[2]; + float hits[2][2]; + q0[0] = (float)x0; + q0[1] = (float)y0; + q1[0] = (float)x1; + q1[1] = (float)y1; + q2[0] = (float)x2; + q2[1] = (float)y2; + if (equal(q0,q1) || equal(q1,q2)) { + x0 = (int)verts[i-1].x; + y0 = (int)verts[i-1].y; + x1 = (int)verts[i ].x; + y1 = (int)verts[i ].y; + if (y > STBTT_min(y0,y1) && y < STBTT_max(y0,y1) && x > STBTT_min(x0,x1)) { + float x_inter = (y - y0) / (y1 - y0) * (x1-x0) + x0; + if (x_inter < x) + winding += (y0 < y1) ? 1 : -1; + } + } else { + int num_hits = stbtt__ray_intersect_bezier(orig, ray, q0, q1, q2, hits); + if (num_hits >= 1) + if (hits[0][0] < 0) + winding += (hits[0][1] < 0 ? -1 : 1); + if (num_hits >= 2) + if (hits[1][0] < 0) + winding += (hits[1][1] < 0 ? -1 : 1); + } + } + } + } + return winding; +} + +static float stbtt__cuberoot( float x ) +{ + if (x<0) + return -(float) STBTT_pow(-x,1.0f/3.0f); + else + return (float) STBTT_pow( x,1.0f/3.0f); +} + +// x^3 + c*x^2 + b*x + a = 0 +static int stbtt__solve_cubic(float a, float b, float c, float* r) +{ + float s = -a / 3; + float p = b - a*a / 3; + float q = a * (2*a*a - 9*b) / 27 + c; + float p3 = p*p*p; + float d = q*q + 4*p3 / 27; + if (d >= 0) { + float z = (float) STBTT_sqrt(d); + float u = (-q + z) / 2; + float v = (-q - z) / 2; + u = stbtt__cuberoot(u); + v = stbtt__cuberoot(v); + r[0] = s + u + v; + return 1; + } else { + float u = (float) STBTT_sqrt(-p/3); + float v = (float) STBTT_acos(-STBTT_sqrt(-27/p3) * q / 2) / 3; // p3 must be negative, since d is negative + float m = (float) STBTT_cos(v); + float n = (float) STBTT_cos(v-3.141592/2)*1.732050808f; + r[0] = s + u * 2 * m; + r[1] = s - u * (m + n); + r[2] = s - u * (m - n); + + //STBTT_assert( STBTT_fabs(((r[0]+a)*r[0]+b)*r[0]+c) < 0.05f); // these asserts may not be safe at all scales, though they're in bezier t parameter units so maybe? + //STBTT_assert( STBTT_fabs(((r[1]+a)*r[1]+b)*r[1]+c) < 0.05f); + //STBTT_assert( STBTT_fabs(((r[2]+a)*r[2]+b)*r[2]+c) < 0.05f); + return 3; + } +} + +STBTT_DEF unsigned char * stbtt_GetGlyphSDF(const stbtt_fontinfo *info, float scale, int glyph, int padding, unsigned char onedge_value, float pixel_dist_scale, int *width, int *height, int *xoff, int *yoff) +{ + float scale_x = scale, scale_y = scale; + int ix0,iy0,ix1,iy1; + int w,h; + unsigned char *data; + + // if one scale is 0, use same scale for both + if (scale_x == 0) scale_x = scale_y; + if (scale_y == 0) { + if (scale_x == 0) return NULL; // if both scales are 0, return NULL + scale_y = scale_x; + } + + stbtt_GetGlyphBitmapBoxSubpixel(info, glyph, scale, scale, 0.0f,0.0f, &ix0,&iy0,&ix1,&iy1); + + // if empty, return NULL + if (ix0 == ix1 || iy0 == iy1) + return NULL; + + ix0 -= padding; + iy0 -= padding; + ix1 += padding; + iy1 += padding; + + w = (ix1 - ix0); + h = (iy1 - iy0); + + if (width ) *width = w; + if (height) *height = h; + if (xoff ) *xoff = ix0; + if (yoff ) *yoff = iy0; + + // invert for y-downwards bitmaps + scale_y = -scale_y; + + { + int x,y,i,j; + float *precompute; + stbtt_vertex *verts; + int num_verts = stbtt_GetGlyphShape(info, glyph, &verts); + data = (unsigned char *) STBTT_malloc(w * h, info->userdata); + precompute = (float *) STBTT_malloc(num_verts * sizeof(float), info->userdata); + + for (i=0,j=num_verts-1; i < num_verts; j=i++) { + if (verts[i].type == STBTT_vline) { + float x0 = verts[i].x*scale_x, y0 = verts[i].y*scale_y; + float x1 = verts[j].x*scale_x, y1 = verts[j].y*scale_y; + float dist = (float) STBTT_sqrt((x1-x0)*(x1-x0) + (y1-y0)*(y1-y0)); + precompute[i] = (dist == 0) ? 0.0f : 1.0f / dist; + } else if (verts[i].type == STBTT_vcurve) { + float x2 = verts[j].x *scale_x, y2 = verts[j].y *scale_y; + float x1 = verts[i].cx*scale_x, y1 = verts[i].cy*scale_y; + float x0 = verts[i].x *scale_x, y0 = verts[i].y *scale_y; + float bx = x0 - 2*x1 + x2, by = y0 - 2*y1 + y2; + float len2 = bx*bx + by*by; + if (len2 != 0.0f) + precompute[i] = 1.0f / (bx*bx + by*by); + else + precompute[i] = 0.0f; + } else + precompute[i] = 0.0f; + } + + for (y=iy0; y < iy1; ++y) { + for (x=ix0; x < ix1; ++x) { + float val; + float min_dist = 999999.0f; + float sx = (float) x + 0.5f; + float sy = (float) y + 0.5f; + float x_gspace = (sx / scale_x); + float y_gspace = (sy / scale_y); + + int winding = stbtt__compute_crossings_x(x_gspace, y_gspace, num_verts, verts); // @OPTIMIZE: this could just be a rasterization, but needs to be line vs. non-tesselated curves so a new path + + for (i=0; i < num_verts; ++i) { + float x0 = verts[i].x*scale_x, y0 = verts[i].y*scale_y; + + // check against every point here rather than inside line/curve primitives -- @TODO: wrong if multiple 'moves' in a row produce a garbage point, and given culling, probably more efficient to do within line/curve + float dist2 = (x0-sx)*(x0-sx) + (y0-sy)*(y0-sy); + if (dist2 < min_dist*min_dist) + min_dist = (float) STBTT_sqrt(dist2); + + if (verts[i].type == STBTT_vline) { + float x1 = verts[i-1].x*scale_x, y1 = verts[i-1].y*scale_y; + + // coarse culling against bbox + //if (sx > STBTT_min(x0,x1)-min_dist && sx < STBTT_max(x0,x1)+min_dist && + // sy > STBTT_min(y0,y1)-min_dist && sy < STBTT_max(y0,y1)+min_dist) + float dist = (float) STBTT_fabs((x1-x0)*(y0-sy) - (y1-y0)*(x0-sx)) * precompute[i]; + STBTT_assert(i != 0); + if (dist < min_dist) { + // check position along line + // x' = x0 + t*(x1-x0), y' = y0 + t*(y1-y0) + // minimize (x'-sx)*(x'-sx)+(y'-sy)*(y'-sy) + float dx = x1-x0, dy = y1-y0; + float px = x0-sx, py = y0-sy; + // minimize (px+t*dx)^2 + (py+t*dy)^2 = px*px + 2*px*dx*t + t^2*dx*dx + py*py + 2*py*dy*t + t^2*dy*dy + // derivative: 2*px*dx + 2*py*dy + (2*dx*dx+2*dy*dy)*t, set to 0 and solve + float t = -(px*dx + py*dy) / (dx*dx + dy*dy); + if (t >= 0.0f && t <= 1.0f) + min_dist = dist; + } + } else if (verts[i].type == STBTT_vcurve) { + float x2 = verts[i-1].x *scale_x, y2 = verts[i-1].y *scale_y; + float x1 = verts[i ].cx*scale_x, y1 = verts[i ].cy*scale_y; + float box_x0 = STBTT_min(STBTT_min(x0,x1),x2); + float box_y0 = STBTT_min(STBTT_min(y0,y1),y2); + float box_x1 = STBTT_max(STBTT_max(x0,x1),x2); + float box_y1 = STBTT_max(STBTT_max(y0,y1),y2); + // coarse culling against bbox to avoid computing cubic unnecessarily + if (sx > box_x0-min_dist && sx < box_x1+min_dist && sy > box_y0-min_dist && sy < box_y1+min_dist) { + int num=0; + float ax = x1-x0, ay = y1-y0; + float bx = x0 - 2*x1 + x2, by = y0 - 2*y1 + y2; + float mx = x0 - sx, my = y0 - sy; + float res[3],px,py,t,it; + float a_inv = precompute[i]; + if (a_inv == 0.0) { // if a_inv is 0, it's 2nd degree so use quadratic formula + float a = 3*(ax*bx + ay*by); + float b = 2*(ax*ax + ay*ay) + (mx*bx+my*by); + float c = mx*ax+my*ay; + if (a == 0.0) { // if a is 0, it's linear + if (b != 0.0) { + res[num++] = -c/b; + } + } else { + float discriminant = b*b - 4*a*c; + if (discriminant < 0) + num = 0; + else { + float root = (float) STBTT_sqrt(discriminant); + res[0] = (-b - root)/(2*a); + res[1] = (-b + root)/(2*a); + num = 2; // don't bother distinguishing 1-solution case, as code below will still work + } + } + } else { + float b = 3*(ax*bx + ay*by) * a_inv; // could precompute this as it doesn't depend on sample point + float c = (2*(ax*ax + ay*ay) + (mx*bx+my*by)) * a_inv; + float d = (mx*ax+my*ay) * a_inv; + num = stbtt__solve_cubic(b, c, d, res); + } + if (num >= 1 && res[0] >= 0.0f && res[0] <= 1.0f) { + t = res[0], it = 1.0f - t; + px = it*it*x0 + 2*t*it*x1 + t*t*x2; + py = it*it*y0 + 2*t*it*y1 + t*t*y2; + dist2 = (px-sx)*(px-sx) + (py-sy)*(py-sy); + if (dist2 < min_dist * min_dist) + min_dist = (float) STBTT_sqrt(dist2); + } + if (num >= 2 && res[1] >= 0.0f && res[1] <= 1.0f) { + t = res[1], it = 1.0f - t; + px = it*it*x0 + 2*t*it*x1 + t*t*x2; + py = it*it*y0 + 2*t*it*y1 + t*t*y2; + dist2 = (px-sx)*(px-sx) + (py-sy)*(py-sy); + if (dist2 < min_dist * min_dist) + min_dist = (float) STBTT_sqrt(dist2); + } + if (num >= 3 && res[2] >= 0.0f && res[2] <= 1.0f) { + t = res[2], it = 1.0f - t; + px = it*it*x0 + 2*t*it*x1 + t*t*x2; + py = it*it*y0 + 2*t*it*y1 + t*t*y2; + dist2 = (px-sx)*(px-sx) + (py-sy)*(py-sy); + if (dist2 < min_dist * min_dist) + min_dist = (float) STBTT_sqrt(dist2); + } + } + } + } + if (winding == 0) + min_dist = -min_dist; // if outside the shape, value is negative + val = onedge_value + pixel_dist_scale * min_dist; + if (val < 0) + val = 0; + else if (val > 255) + val = 255; + data[(y-iy0)*w+(x-ix0)] = (unsigned char) val; + } + } + STBTT_free(precompute, info->userdata); + STBTT_free(verts, info->userdata); + } + return data; +} + +STBTT_DEF unsigned char * stbtt_GetCodepointSDF(const stbtt_fontinfo *info, float scale, int codepoint, int padding, unsigned char onedge_value, float pixel_dist_scale, int *width, int *height, int *xoff, int *yoff) +{ + return stbtt_GetGlyphSDF(info, scale, stbtt_FindGlyphIndex(info, codepoint), padding, onedge_value, pixel_dist_scale, width, height, xoff, yoff); +} + +STBTT_DEF void stbtt_FreeSDF(unsigned char *bitmap, void *userdata) +{ + STBTT_free(bitmap, userdata); +} + +////////////////////////////////////////////////////////////////////////////// +// +// font name matching -- recommended not to use this +// + +// check if a utf8 string contains a prefix which is the utf16 string; if so return length of matching utf8 string +static stbtt_int32 stbtt__CompareUTF8toUTF16_bigendian_prefix(stbtt_uint8 *s1, stbtt_int32 len1, stbtt_uint8 *s2, stbtt_int32 len2) +{ + stbtt_int32 i=0; + + // convert utf16 to utf8 and compare the results while converting + while (len2) { + stbtt_uint16 ch = s2[0]*256 + s2[1]; + if (ch < 0x80) { + if (i >= len1) return -1; + if (s1[i++] != ch) return -1; + } else if (ch < 0x800) { + if (i+1 >= len1) return -1; + if (s1[i++] != 0xc0 + (ch >> 6)) return -1; + if (s1[i++] != 0x80 + (ch & 0x3f)) return -1; + } else if (ch >= 0xd800 && ch < 0xdc00) { + stbtt_uint32 c; + stbtt_uint16 ch2 = s2[2]*256 + s2[3]; + if (i+3 >= len1) return -1; + c = ((ch - 0xd800) << 10) + (ch2 - 0xdc00) + 0x10000; + if (s1[i++] != 0xf0 + (c >> 18)) return -1; + if (s1[i++] != 0x80 + ((c >> 12) & 0x3f)) return -1; + if (s1[i++] != 0x80 + ((c >> 6) & 0x3f)) return -1; + if (s1[i++] != 0x80 + ((c ) & 0x3f)) return -1; + s2 += 2; // plus another 2 below + len2 -= 2; + } else if (ch >= 0xdc00 && ch < 0xe000) { + return -1; + } else { + if (i+2 >= len1) return -1; + if (s1[i++] != 0xe0 + (ch >> 12)) return -1; + if (s1[i++] != 0x80 + ((ch >> 6) & 0x3f)) return -1; + if (s1[i++] != 0x80 + ((ch ) & 0x3f)) return -1; + } + s2 += 2; + len2 -= 2; + } + return i; +} + +static int stbtt_CompareUTF8toUTF16_bigendian_internal(char *s1, int len1, char *s2, int len2) +{ + return len1 == stbtt__CompareUTF8toUTF16_bigendian_prefix((stbtt_uint8*) s1, len1, (stbtt_uint8*) s2, len2); +} + +// returns results in whatever encoding you request... but note that 2-byte encodings +// will be BIG-ENDIAN... use stbtt_CompareUTF8toUTF16_bigendian() to compare +STBTT_DEF const char *stbtt_GetFontNameString(const stbtt_fontinfo *font, int *length, int platformID, int encodingID, int languageID, int nameID) +{ + stbtt_int32 i,count,stringOffset; + stbtt_uint8 *fc = font->data; + stbtt_uint32 offset = font->fontstart; + stbtt_uint32 nm = stbtt__find_table(fc, offset, "name"); + if (!nm) return NULL; + + count = ttUSHORT(fc+nm+2); + stringOffset = nm + ttUSHORT(fc+nm+4); + for (i=0; i < count; ++i) { + stbtt_uint32 loc = nm + 6 + 12 * i; + if (platformID == ttUSHORT(fc+loc+0) && encodingID == ttUSHORT(fc+loc+2) + && languageID == ttUSHORT(fc+loc+4) && nameID == ttUSHORT(fc+loc+6)) { + *length = ttUSHORT(fc+loc+8); + return (const char *) (fc+stringOffset+ttUSHORT(fc+loc+10)); + } + } + return NULL; +} + +static int stbtt__matchpair(stbtt_uint8 *fc, stbtt_uint32 nm, stbtt_uint8 *name, stbtt_int32 nlen, stbtt_int32 target_id, stbtt_int32 next_id) +{ + stbtt_int32 i; + stbtt_int32 count = ttUSHORT(fc+nm+2); + stbtt_int32 stringOffset = nm + ttUSHORT(fc+nm+4); + + for (i=0; i < count; ++i) { + stbtt_uint32 loc = nm + 6 + 12 * i; + stbtt_int32 id = ttUSHORT(fc+loc+6); + if (id == target_id) { + // find the encoding + stbtt_int32 platform = ttUSHORT(fc+loc+0), encoding = ttUSHORT(fc+loc+2), language = ttUSHORT(fc+loc+4); + + // is this a Unicode encoding? + if (platform == 0 || (platform == 3 && encoding == 1) || (platform == 3 && encoding == 10)) { + stbtt_int32 slen = ttUSHORT(fc+loc+8); + stbtt_int32 off = ttUSHORT(fc+loc+10); + + // check if there's a prefix match + stbtt_int32 matchlen = stbtt__CompareUTF8toUTF16_bigendian_prefix(name, nlen, fc+stringOffset+off,slen); + if (matchlen >= 0) { + // check for target_id+1 immediately following, with same encoding & language + if (i+1 < count && ttUSHORT(fc+loc+12+6) == next_id && ttUSHORT(fc+loc+12) == platform && ttUSHORT(fc+loc+12+2) == encoding && ttUSHORT(fc+loc+12+4) == language) { + slen = ttUSHORT(fc+loc+12+8); + off = ttUSHORT(fc+loc+12+10); + if (slen == 0) { + if (matchlen == nlen) + return 1; + } else if (matchlen < nlen && name[matchlen] == ' ') { + ++matchlen; + if (stbtt_CompareUTF8toUTF16_bigendian_internal((char*) (name+matchlen), nlen-matchlen, (char*)(fc+stringOffset+off),slen)) + return 1; + } + } else { + // if nothing immediately following + if (matchlen == nlen) + return 1; + } + } + } + + // @TODO handle other encodings + } + } + return 0; +} + +static int stbtt__matches(stbtt_uint8 *fc, stbtt_uint32 offset, stbtt_uint8 *name, stbtt_int32 flags) +{ + stbtt_int32 nlen = (stbtt_int32) STBTT_strlen((char *) name); + stbtt_uint32 nm,hd; + if (!stbtt__isfont(fc+offset)) return 0; + + // check italics/bold/underline flags in macStyle... + if (flags) { + hd = stbtt__find_table(fc, offset, "head"); + if ((ttUSHORT(fc+hd+44) & 7) != (flags & 7)) return 0; + } + + nm = stbtt__find_table(fc, offset, "name"); + if (!nm) return 0; + + if (flags) { + // if we checked the macStyle flags, then just check the family and ignore the subfamily + if (stbtt__matchpair(fc, nm, name, nlen, 16, -1)) return 1; + if (stbtt__matchpair(fc, nm, name, nlen, 1, -1)) return 1; + if (stbtt__matchpair(fc, nm, name, nlen, 3, -1)) return 1; + } else { + if (stbtt__matchpair(fc, nm, name, nlen, 16, 17)) return 1; + if (stbtt__matchpair(fc, nm, name, nlen, 1, 2)) return 1; + if (stbtt__matchpair(fc, nm, name, nlen, 3, -1)) return 1; + } + + return 0; +} + +static int stbtt_FindMatchingFont_internal(unsigned char *font_collection, char *name_utf8, stbtt_int32 flags) +{ + stbtt_int32 i; + for (i=0;;++i) { + stbtt_int32 off = stbtt_GetFontOffsetForIndex(font_collection, i); + if (off < 0) return off; + if (stbtt__matches((stbtt_uint8 *) font_collection, off, (stbtt_uint8*) name_utf8, flags)) + return off; + } +} + +#if defined(__GNUC__) || defined(__clang__) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wcast-qual" +#endif + +STBTT_DEF int stbtt_BakeFontBitmap(const unsigned char *data, int offset, + float pixel_height, unsigned char *pixels, int pw, int ph, + int first_char, int num_chars, stbtt_bakedchar *chardata) +{ + return stbtt_BakeFontBitmap_internal((unsigned char *) data, offset, pixel_height, pixels, pw, ph, first_char, num_chars, chardata); +} + +STBTT_DEF int stbtt_GetFontOffsetForIndex(const unsigned char *data, int index) +{ + return stbtt_GetFontOffsetForIndex_internal((unsigned char *) data, index); +} + +STBTT_DEF int stbtt_GetNumberOfFonts(const unsigned char *data) +{ + return stbtt_GetNumberOfFonts_internal((unsigned char *) data); +} + +STBTT_DEF int stbtt_InitFont(stbtt_fontinfo *info, const unsigned char *data, int offset) +{ + return stbtt_InitFont_internal(info, (unsigned char *) data, offset); +} + +STBTT_DEF int stbtt_FindMatchingFont(const unsigned char *fontdata, const char *name, int flags) +{ + return stbtt_FindMatchingFont_internal((unsigned char *) fontdata, (char *) name, flags); +} + +STBTT_DEF int stbtt_CompareUTF8toUTF16_bigendian(const char *s1, int len1, const char *s2, int len2) +{ + return stbtt_CompareUTF8toUTF16_bigendian_internal((char *) s1, len1, (char *) s2, len2); +} + +#if defined(__GNUC__) || defined(__clang__) +#pragma GCC diagnostic pop +#endif + +#endif // STB_TRUETYPE_IMPLEMENTATION + + +// FULL VERSION HISTORY +// +// 1.19 (2018-02-11) OpenType GPOS kerning (horizontal only), STBTT_fmod +// 1.18 (2018-01-29) add missing function +// 1.17 (2017-07-23) make more arguments const; doc fix +// 1.16 (2017-07-12) SDF support +// 1.15 (2017-03-03) make more arguments const +// 1.14 (2017-01-16) num-fonts-in-TTC function +// 1.13 (2017-01-02) support OpenType fonts, certain Apple fonts +// 1.12 (2016-10-25) suppress warnings about casting away const with -Wcast-qual +// 1.11 (2016-04-02) fix unused-variable warning +// 1.10 (2016-04-02) allow user-defined fabs() replacement +// fix memory leak if fontsize=0.0 +// fix warning from duplicate typedef +// 1.09 (2016-01-16) warning fix; avoid crash on outofmem; use alloc userdata for PackFontRanges +// 1.08 (2015-09-13) document stbtt_Rasterize(); fixes for vertical & horizontal edges +// 1.07 (2015-08-01) allow PackFontRanges to accept arrays of sparse codepoints; +// allow PackFontRanges to pack and render in separate phases; +// fix stbtt_GetFontOFfsetForIndex (never worked for non-0 input?); +// fixed an assert() bug in the new rasterizer +// replace assert() with STBTT_assert() in new rasterizer +// 1.06 (2015-07-14) performance improvements (~35% faster on x86 and x64 on test machine) +// also more precise AA rasterizer, except if shapes overlap +// remove need for STBTT_sort +// 1.05 (2015-04-15) fix misplaced definitions for STBTT_STATIC +// 1.04 (2015-04-15) typo in example +// 1.03 (2015-04-12) STBTT_STATIC, fix memory leak in new packing, various fixes +// 1.02 (2014-12-10) fix various warnings & compile issues w/ stb_rect_pack, C++ +// 1.01 (2014-12-08) fix subpixel position when oversampling to exactly match +// non-oversampled; STBTT_POINT_SIZE for packed case only +// 1.00 (2014-12-06) add new PackBegin etc. API, w/ support for oversampling +// 0.99 (2014-09-18) fix multiple bugs with subpixel rendering (ryg) +// 0.9 (2014-08-07) support certain mac/iOS fonts without an MS platformID +// 0.8b (2014-07-07) fix a warning +// 0.8 (2014-05-25) fix a few more warnings +// 0.7 (2013-09-25) bugfix: subpixel glyph bug fixed in 0.5 had come back +// 0.6c (2012-07-24) improve documentation +// 0.6b (2012-07-20) fix a few more warnings +// 0.6 (2012-07-17) fix warnings; added stbtt_ScaleForMappingEmToPixels, +// stbtt_GetFontBoundingBox, stbtt_IsGlyphEmpty +// 0.5 (2011-12-09) bugfixes: +// subpixel glyph renderer computed wrong bounding box +// first vertex of shape can be off-curve (FreeSans) +// 0.4b (2011-12-03) fixed an error in the font baking example +// 0.4 (2011-12-01) kerning, subpixel rendering (tor) +// bugfixes for: +// codepoint-to-glyph conversion using table fmt=12 +// codepoint-to-glyph conversion using table fmt=4 +// stbtt_GetBakedQuad with non-square texture (Zer) +// updated Hello World! sample to use kerning and subpixel +// fixed some warnings +// 0.3 (2009-06-24) cmap fmt=12, compound shapes (MM) +// userdata, malloc-from-userdata, non-zero fill (stb) +// 0.2 (2009-03-11) Fix unsigned/signed char warnings +// 0.1 (2009-03-09) First public release +// + +/* +------------------------------------------------------------------------------ +This software is available under 2 licenses -- choose whichever you prefer. +------------------------------------------------------------------------------ +ALTERNATIVE A - MIT License +Copyright (c) 2017 Sean Barrett +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. +------------------------------------------------------------------------------ +ALTERNATIVE B - Public Domain (www.unlicense.org) +This is free and unencumbered software released into the public domain. +Anyone is free to copy, modify, publish, use, compile, sell, or distribute this +software, either in source code form or as a compiled binary, for any purpose, +commercial or non-commercial, and by any means. +In jurisdictions that recognize copyright laws, the author or authors of this +software dedicate any and all copyright interest in the software to the public +domain. We make this dedication for the benefit of the public at large and to +the detriment of our heirs and successors. We intend this dedication to be an +overt act of relinquishment in perpetuity of all present and future rights to +this software under copyright law. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +------------------------------------------------------------------------------ +*/ diff --git a/source/engine/camera.c b/source/engine/camera.c index b2f7e2c..6f9c00b 100644 --- a/source/engine/camera.c +++ b/source/engine/camera.c @@ -2,7 +2,7 @@ #include "gameobject.h" #include "input.h" -#include +#include const float CAMERA_MINSPEED = 1.f; const float CAMERA_MAXSPEED = 300.f; diff --git a/source/engine/config.h b/source/engine/config.h index 2e662ff..0a84fdd 100644 --- a/source/engine/config.h +++ b/source/engine/config.h @@ -15,4 +15,7 @@ #define MSAA_SAMPLES 2 + + + #endif \ No newline at end of file diff --git a/source/engine/datastream.c b/source/engine/datastream.c index 3e22802..bb06286 100644 --- a/source/engine/datastream.c +++ b/source/engine/datastream.c @@ -131,7 +131,7 @@ void ds_seek(struct datastream *ds, uint32_t time) plm_seek(ds->plm, time, false); } -void ds_fwdframes(struct datastream *ds, int frames) +void ds_advanceframes(struct datastream *ds, int frames) { for (int i = 0; i < frames; i++) { plm_frame_t *frame = plm_decode_video(ds->plm); @@ -139,8 +139,6 @@ void ds_fwdframes(struct datastream *ds, int frames) } } - - void ds_pause(struct datastream *ds) { ds->playing = false; @@ -171,3 +169,8 @@ double ds_remainingtime(struct datastream *ds) else return 0.f; } + +double ds_length(struct datastream *ds) +{ + return plm_get_duration(ds->plm); +} \ No newline at end of file diff --git a/source/engine/datastream.h b/source/engine/datastream.h index 1dced35..6b5ab35 100644 --- a/source/engine/datastream.h +++ b/source/engine/datastream.h @@ -1,7 +1,7 @@ #ifndef DATASTREAM_H #define DATASTREAM_H -#include +#include typedef struct plm_t plm_t; @@ -22,9 +22,11 @@ void ds_openvideo(struct datastream *ds, const char *path, const char *adriver); void ds_advance(struct datastream *ds, uint32_t ms); void ds_seek(struct datastream *ds, uint32_t time); +void ds_advanceframes(struct datastream *ds, int frames); void ds_pause(struct datastream *ds); void ds_stop(struct datastream *ds); int ds_videodone(struct datastream *ds); double ds_remainingtime(struct datastream *ds); +double ds_length(struct datastream *ds); #endif diff --git a/source/editor/debugdraw.c b/source/engine/debugdraw.c similarity index 100% rename from source/editor/debugdraw.c rename to source/engine/debugdraw.c diff --git a/source/editor/debugdraw.h b/source/engine/debugdraw.h similarity index 100% rename from source/editor/debugdraw.h rename to source/engine/debugdraw.h diff --git a/source/engine/engine.c b/source/engine/engine.c index ecbb17b..d56ff0a 100644 --- a/source/engine/engine.c +++ b/source/engine/engine.c @@ -1,24 +1,11 @@ -#define PL_MPEG_IMPLEMENTATION -#define CGLTF_IMPLEMENTATION -#define GL_GLEXT_PROTOTYPES - -//#define MATHC_USE_INT16 -//#define MATHC_FLOATING_POINT_TYPE GLfloat -//#define MATHC_USE_DOUBLE_FLOATING_POINT - -#define STB_DS_IMPLEMENTATION -#include - -#define STB_IMAGE_IMPLEMENTATION -#include - -#include +#include "engine.h" #ifdef EDITOR #include "editor.h" #endif -#include +#include +#include #include "openglrender.h" #include "window.h" #include "camera.h" @@ -27,96 +14,63 @@ #include "2dphysics.h" #include "gameobject.h" #include "registry.h" +#include "log.h" +#include "resources.h" + -#define FPS30 33 -#define FPS60 17 -#define FPS120 8; -#define FPS144 7 -#define FPS300 3 unsigned int frameCount = 0; -Uint32 lastTick = 0; -Uint32 frameTick = 0; -Uint32 elapsed = 0; +uint32_t lastTick = 0; +uint32_t frameTick = 0; +uint32_t elapsed = 0; -Uint32 physMS = FPS144; -Uint32 physlag = 0; -Uint32 renderMS = FPS144; -Uint32 renderlag = 0; +uint32_t physMS = FPS144; +uint32_t physlag = 0; +uint32_t renderMS = FPS144; +uint32_t renderlag = 0; +// TODO: Init on the heap +struct mCamera camera = {0}; +#include "engine.h" -int main(int argc, char **args) +void engine_init() { - script_init(); - registry_init(); - gameobjects = vec_make(sizeof(struct mGameObject), 100); - prefabs = vec_make(MAXNAME, 25); - - // TODO: Init these on the heap instead - struct mCamera camera = { 0 }; - camera.speed = 500; - - stbi_set_flip_vertically_on_load(1); - - resources_init(); - openglInit(); - sprite_initialize(); - -#ifdef EDITOR - editor_init(window); -#endif - - phys2d_init(); - - quit = false; - SDL_Event e; - - //While application is running - while (!quit) { - frameTick = SDL_GetTicks(); - elapsed = frameTick - lastTick; - lastTick = frameTick; - deltaT = elapsed / 1000.f; - - physlag += elapsed; - renderlag += elapsed; - - input_poll(); - - if (physlag >= physMS) { - phys2d_update(physMS / 1000.f); - - physlag -= physMS; - } - - - if (renderlag >= renderMS) { - if (physOn) { - vec_walk(gameobjects, gameobject_update); - } - - - camera_2d_update(&camera, renderMS / 1000.f); - - openglRender(&camera); - - -#ifdef EDITOR - editor_render(); -#endif - - window_swap(window); - - renderlag -= renderMS; - } + //Initialize SDL + if (SDL_Init(SDL_INIT_VIDEO | SDL_INIT_AUDIO | SDL_INIT_TIMER)) { + YughLog(0, SDL_LOG_PRIORITY_ERROR, + "SDL could not initialize! SDL Error: %s", SDL_GetError()); } + //Use OpenGL 3.3 + SDL_GL_SetAttribute(SDL_GL_CONTEXT_MAJOR_VERSION, 3); + SDL_GL_SetAttribute(SDL_GL_CONTEXT_MINOR_VERSION, 3); + SDL_GL_SetAttribute(SDL_GL_CONTEXT_PROFILE_MASK, + SDL_GL_CONTEXT_PROFILE_CORE); + SDL_GL_SetAttribute(SDL_GL_MULTISAMPLEBUFFERS, 1); + SDL_GL_SetAttribute(SDL_GL_MULTISAMPLESAMPLES, 2); /* How many x MSAA */ + + SDL_GL_SetAttribute(SDL_GL_STENCIL_SIZE, 1); +resources_init(); + script_init(); + registry_init(); + init_gameobjects(); + + prefabs = vec_make(MAXNAME, 25); + camera.speed = 500; + stbi_set_flip_vertically_on_load(1); + phys2d_init(); + gui_init(); + sound_init(); + + Mix_OpenAudio(44100, MIX_DEFAULT_FORMAT, 2, 2048); +} + +void engine_stop() +{ SDL_StopTextInput(); SDL_Quit(); - - return 0; -} +} \ No newline at end of file diff --git a/source/engine/engine.h b/source/engine/engine.h new file mode 100644 index 0000000..587906d --- /dev/null +++ b/source/engine/engine.h @@ -0,0 +1,19 @@ +#ifndef ENGINE_H +#define ENGINE_H + +#define FPS30 33 +#define FPS60 17 +#define FPS120 8; +#define FPS144 7 +#define FPS300 3 + +#include +#include +#include + +void engine_init(); +void engine_stop(); + + + +#endif \ No newline at end of file diff --git a/source/engine/font.c b/source/engine/font.c index 0345ae3..7a23290 100644 --- a/source/engine/font.c +++ b/source/engine/font.c @@ -19,10 +19,13 @@ static uint32_t VAO = 0; unsigned char ttf_buffer[24 << 20]; unsigned char temp_bitmap[512 * 512]; -struct sFont MakeFont(const char *fontfile, int height) +static struct sFont *font; +static struct mShader *shader; + +struct sFont *MakeFont(const char *fontfile, int height) { - struct sFont newfont = { 0 }; - newfont.height = height; + struct sFont *newfont = calloc(1, sizeof(struct sFont)); + newfont->height = height; char fontpath[256]; snprintf(fontpath, 256, "fonts/%s", fontfile); @@ -42,7 +45,7 @@ struct sFont MakeFont(const char *fontfile, int height) bitmap = stbtt_GetCodepointBitmap(&fontinfo, 0, stbtt_ScaleForPixelHeight(&fontinfo, - newfont. + newfont-> height), c, &w, &h, 0, 0); @@ -52,7 +55,7 @@ struct sFont MakeFont(const char *fontfile, int height) glTexImage2D(GL_TEXTURE_2D, 0, GL_RED, w, h, 0, GL_RED, GL_UNSIGNED_BYTE, bitmap); - glGenerateMipmap(GL_TEXTURE_2D); + //glGenerateMipmap(GL_TEXTURE_2D); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, @@ -85,8 +88,6 @@ struct sFont MakeFont(const char *fontfile, int height) glBindVertexArray(0); return newfont; - - } void sdrawCharacter(struct Character c, mfloat_t cursor[2], float scale, @@ -156,9 +157,13 @@ void sdrawCharacter(struct Character c, mfloat_t cursor[2], float scale, } -void renderText(struct sFont font, struct mShader *shader, - const char *text, mfloat_t pos[2], float scale, - mfloat_t color[3], float lw) +void text_settype(struct sFont *mfont, struct mShader *mshader) +{ + font = mfont; + shader = mshader; +} + +void renderText(const char *text, mfloat_t pos[2], float scale, mfloat_t color[3], float lw) { shader_use(shader); shader_setvec3(shader, "textColor", color); @@ -193,7 +198,7 @@ void renderText(struct sFont font, struct mShader *shader, && (cursor[0] + ((ch.Advance >> 6) * scale) - pos[0] >= lw)) { cursor[0] = pos[0]; - cursor[1] -= scale * font.height; + cursor[1] -= scale * font->height; } else { // now advance cursors for next glyph (note that advance is number of 1/64 pixels) @@ -211,7 +216,7 @@ void renderText(struct sFont font, struct mShader *shader, // Now wordStart and stringPos surround the word, go through them. If the word that's about to be drawn goes past the line width, go to next line if (lw > 0 && (cursor[0] + wordWidth - pos[0] >= lw)) { cursor[0] = pos[0]; - cursor[1] -= scale * font.height; + cursor[1] -= scale * font->height; } while (wordstart < line) { // Go through @@ -229,7 +234,7 @@ void renderText(struct sFont font, struct mShader *shader, } - cursor[1] -= scale * font.height; + cursor[1] -= scale * font->height; line = strtok(NULL, "\n"); } diff --git a/source/engine/font.h b/source/engine/font.h index 1b18eaa..08b2bf4 100644 --- a/source/engine/font.h +++ b/source/engine/font.h @@ -18,10 +18,11 @@ struct sFont { uint32_t height; }; -struct sFont MakeFont(const char *fontfile, int height); +struct sFont *MakeFont(const char *fontfile, int height); void sdrawCharacter(struct Character c, mfloat_t cursor[2], float scale, struct mShader *shader, float color[3]); -void renderText(struct sFont font, struct mShader *shader, +void text_settype(struct sFont *font, struct mShader *shader); +void renderText( const char *text, mfloat_t pos[2], float scale, mfloat_t color[3], float lw); diff --git a/source/engine/gameobject.c b/source/engine/gameobject.c index 51e795f..c1feaea 100644 --- a/source/engine/gameobject.c +++ b/source/engine/gameobject.c @@ -16,6 +16,11 @@ struct mGameObject *updateGO = NULL; const int nameBuf[MAXNAME] = { 0 }; const int prefabNameBuf[MAXNAME] = { 0 }; +void init_gameobjects() +{ + gameobjects = vec_make(sizeof(struct mGameObject), 100); +} + struct mGameObject *get_gameobject_from_id(int id) { return vec_get(gameobjects, id - 1); diff --git a/source/engine/gameobject.h b/source/engine/gameobject.h index 156973e..89a3323 100644 --- a/source/engine/gameobject.h +++ b/source/engine/gameobject.h @@ -44,6 +44,7 @@ struct mGameObject { }; struct mGameObject *MakeGameobject(); +void init_gameobjects(); void gameobject_delete(int id); void clear_gameobjects(); int number_of_gameobjects(); diff --git a/source/engine/input.c b/source/engine/input.c index e41bd91..637bc40 100644 --- a/source/engine/input.c +++ b/source/engine/input.c @@ -1,7 +1,7 @@ #include "input.h" #include "window.h" -#include +#include int32_t mouseWheelX = 0; int32_t mouseWheelY = 0; @@ -22,10 +22,10 @@ void input_poll() currentKeystates = SDL_GetKeyboardState(NULL); while (SDL_PollEvent(&e)) { - window_handle_event(window, &e); + window_all_handle_events(&e); #ifdef EDITOR - editor_input(&e); + //editor_input(&e); #endif } diff --git a/source/engine/input.h b/source/engine/input.h index cc55940..771d299 100644 --- a/source/engine/input.h +++ b/source/engine/input.h @@ -1,7 +1,7 @@ #ifndef INPUT_H #define INPUT_H -#include +#include #include extern int32_t mouseWheelX; diff --git a/source/engine/log.h b/source/engine/log.h index becf55a..4dbb814 100644 --- a/source/engine/log.h +++ b/source/engine/log.h @@ -1,7 +1,7 @@ #ifndef LOG_H #define LOG_H -#include +#include #define ERROR_BUFFER 2048 diff --git a/source/engine/mathc.h b/source/engine/mathc.h index b58cfc7..83e96b7 100644 --- a/source/engine/mathc.h +++ b/source/engine/mathc.h @@ -658,6 +658,7 @@ Matrix 4×4 representation: mfloat_t basis[3][3]); + mfloat_t *vec3_rotate_quat(mfloat_t * result, const mfloat_t * v, const mfloat_t * q); diff --git a/source/engine/model.c b/source/engine/model.c index b7d0428..1b9d2d8 100644 --- a/source/engine/model.c +++ b/source/engine/model.c @@ -3,7 +3,6 @@ #include "mesh.h" #include "resources.h" #include "shader.h" -#include #include #include diff --git a/source/engine/openglrender.c b/source/engine/openglrender.c index 65d9a1c..86c6530 100644 --- a/source/engine/openglrender.c +++ b/source/engine/openglrender.c @@ -1,7 +1,6 @@ #include "openglrender.h" -#include -#include +#include #include "sprite.h" #include "shader.h" #include "font.h" @@ -37,7 +36,7 @@ struct mShader *animSpriteShader = NULL; static struct mShader *textShader; static struct mShader *diffuseShader; -struct sFont stdFont; +struct sFont *stdFont; static struct mShader *debugDepthQuad; static struct mShader *debugColorPickShader; @@ -94,34 +93,17 @@ static struct mSprite *tanim = NULL; static unsigned int projUBO; -void openglInit() +void openglInit(struct mSDLWindow *window) { - //Initialize SDL - if (SDL_Init(SDL_INIT_VIDEO | SDL_INIT_TIMER)) { - YughLog(0, SDL_LOG_PRIORITY_ERROR, - "SDL could not initialize! SDL Error: %s", SDL_GetError()); - } - //Use OpenGL 3.3 - SDL_GL_SetAttribute(SDL_GL_CONTEXT_MAJOR_VERSION, 3); - SDL_GL_SetAttribute(SDL_GL_CONTEXT_MINOR_VERSION, 3); - SDL_GL_SetAttribute(SDL_GL_CONTEXT_PROFILE_MASK, - SDL_GL_CONTEXT_PROFILE_CORE); + window_makecurrent(window); - SDL_GL_SetAttribute(SDL_GL_MULTISAMPLEBUFFERS, 1); - SDL_GL_SetAttribute(SDL_GL_MULTISAMPLESAMPLES, 2); /* How many x MSAA */ - - SDL_GL_SetAttribute(SDL_GL_STENCIL_SIZE, 1); - - // TODO: Add non starter initializtion return here for some reason? - window = MakeSDLWindow("Untitled Game", 1920, 1080, - SDL_WINDOW_OPENGL | SDL_WINDOW_SHOWN | - SDL_WINDOW_RESIZABLE); - - //Use Vsync if (SDL_GL_SetSwapInterval(1)) { YughLog(0, SDL_LOG_PRIORITY_WARN, "Unable to set VSync! SDL Error: %s", SDL_GetError()); } + + sprite_initialize(); + ////// MAKE SHADERS outlineShader = MakeShader("outlinevert.glsl", "outline.glsl"); @@ -161,7 +143,7 @@ void openglInit() } -void openglRender(struct mCamera *mcamera) +void openglRender(struct mSDLWindow *window, struct mCamera *mcamera) { //////////// 2D projection mfloat_t projection[16] = { 0.f }; @@ -640,7 +622,8 @@ void openglRender3d(struct mSDLWindow *window, struct mCamera *mcamera) shader_setmat4(textShader, "projection", window->projection); mfloat_t fontpos[2] = { 25.f, 25.f }; mfloat_t fontcolor[3] = { 0.5f, 0.8f, 0.2f }; - renderText(stdFont, textShader, "Sample text", fontpos, 0.4f, + text_settype(stdFont, textShader); + renderText("Sample text", fontpos, 0.4f, fontcolor, -1.f); sprite_draw(tsprite); diff --git a/source/engine/openglrender.h b/source/engine/openglrender.h index 2a9bb86..8f97fc6 100644 --- a/source/engine/openglrender.h +++ b/source/engine/openglrender.h @@ -2,6 +2,7 @@ #define OPENGL_RENDER_H #include "render.h" +#include "window.h" struct mCamera; struct mSDLWindow; @@ -42,8 +43,8 @@ enum RenderMode { OBJECTPICKER }; -void openglInit(); -void openglRender(struct mCamera *camera); +void openglInit(struct mSDLWindow *window); +void openglRender(struct mSDLWindow *window, struct mCamera *camera); void openglInit3d(struct mSDLWindow *window); void openglRender3d(struct mSDLWindow *window, struct mCamera *camera); diff --git a/source/engine/render.h b/source/engine/render.h index 941b775..17081a3 100644 --- a/source/engine/render.h +++ b/source/engine/render.h @@ -3,7 +3,7 @@ #define GL_GLEXT_PROTOTYPES #include -#include +#include #endif \ No newline at end of file diff --git a/source/engine/resources.c b/source/engine/resources.c index 0e4bc7a..3718e7f 100644 --- a/source/engine/resources.c +++ b/source/engine/resources.c @@ -9,6 +9,8 @@ #include #include #include +#include +#include char *DATA_PATH = NULL; char *PREF_PATH = NULL; @@ -29,13 +31,15 @@ char pathbuf[MAXPATH]; void resources_init() { - char *dpath = SDL_GetBasePath(); - DATA_PATH = malloc(strlen(dpath) + 1); - strcpy(DATA_PATH, dpath); + DATA_PATH = malloc(256); + getcwd(DATA_PATH, 256); + strncat(DATA_PATH, "/", 256); - char *ppath = SDL_GetPrefPath("Odplot", "Test Game"); - PREF_PATH = malloc(strlen(ppath) + 1); - strcpy(PREF_PATH, ppath); + + + PREF_PATH = SDL_GetPrefPath("Odplot", "Test Game"); + if (!PREF_PATH) + PREF_PATH = strdup("./tmp/"); } char *get_filename_from_path(char *path, int extension) @@ -87,7 +91,7 @@ static int ext_check(const char *path, const struct stat *sb, int typeflag, return 0; } -void fill_extensions(struct vec *vec, char *path, const char *ext) +void fill_extensions(struct vec *vec, const char *path, const char *ext) { c_vec = vec; cur_ext = ext; @@ -109,4 +113,11 @@ FILE *path_open(const char *fmt, const char *tag, ...) FILE *f = fopen(pathbuf, tag); return f; +} + +char *make_path(char *file) +{ + strncpy(pathbuf, DATA_PATH, MAXPATH); + strncat(pathbuf, file, MAXPATH); + return pathbuf; } \ No newline at end of file diff --git a/source/engine/resources.h b/source/engine/resources.h index cf352ec..b40a634 100644 --- a/source/engine/resources.h +++ b/source/engine/resources.h @@ -18,10 +18,11 @@ void resources_init(); extern struct vec *prefabs; void findPrefabs(); -void fill_extensions(struct vec *vec, char *path, const char *ext); +void fill_extensions(struct vec *vec, const char *path, const char *ext); char *get_filename_from_path(char *path, int extension); char *get_directory_from_path(char *path); FILE *res_open(char *path, const char *tag); FILE *path_open(const char *fmt, const char *tag, ...); +char *make_path(char *file); #endif diff --git a/source/engine/shader.c b/source/engine/shader.c index 39526ef..206b9ea 100644 --- a/source/engine/shader.c +++ b/source/engine/shader.c @@ -56,8 +56,8 @@ GLuint load_shader_from_file(char *path, int type) { char spath[MAXPATH] = {'\0'}; - sprintf(spath, "%s%s%s", DATA_PATH, "shaders/", path); - FILE *f = fopen(spath, "r'"); + sprintf(spath, "%s%s", "shaders/", path); + FILE *f = fopen(make_path(spath), "r'"); if (!path) perror(spath), exit(1); diff --git a/source/engine/skybox.c b/source/engine/skybox.c index 6e1ba4e..4cee2f3 100644 --- a/source/engine/skybox.c +++ b/source/engine/skybox.c @@ -2,7 +2,6 @@ #include "shader.h" #include "camera.h" -#include #include #include "openglrender.h" diff --git a/source/engine/sound.c b/source/engine/sound.c new file mode 100644 index 0000000..61db1e3 --- /dev/null +++ b/source/engine/sound.c @@ -0,0 +1,94 @@ +#include "sound.h" + +const char *audioDriver; + +static int mus_ch = -1; + +void sound_init() +{ + int flags = MIX_INIT_MP3 | MIX_INIT_OGG; + int err = Mix_Init(flags); + if (err&flags != flags) { + printf("MIX did not init!!"); + } + + mus_ch = Mix_AllocateChannels(1); +} + +void audio_open(const char *device) +{ + Mix_OpenAudioDevice(44100, MIX_DEFAULT_FORMAT, 2, 2048, device, 0); +} + +void audio_close() +{ + Mix_CloseAudio(); +} + +struct sound *make_sound(const char *wav) +{ + struct sound *new = calloc(1, sizeof(struct sound)); + new->sound = Mix_LoadWAV(wav); + + return new; +} + +struct music *make_music(const char *ogg) +{ + struct music *sound = calloc(1, sizeof(struct music)); + sound->music = Mix_LoadMUS(make_path(ogg)); + + return sound; +} + +void play_sound(struct sound *sound) +{ + Mix_VolumeChunk(sound->sound, sound->volume); + Mix_PlayChannel(-1, sound->sound, 0); +} + +void play_music(struct sound *music) +{ + Mix_PlayChannel(mus_ch, music->sound, -1); +} + +void music_set(struct sound *music) +{ + +} + +void music_volume(unsigned char vol) +{ + Mix_Volume(mus_ch, vol); +} + +int music_playing() +{ + return Mix_Playing(mus_ch); +} + +int music_paused() +{ + return Mix_Paused(mus_ch); +} + +void music_resume() +{ + Mix_Resume(mus_ch); +} + +void music_pause() +{ + Mix_Pause(mus_ch); +} + +void music_stop() +{ + Mix_HaltChannel(mus_ch); +} + + +void audio_init() +{ + audioDriver = SDL_GetAudioDeviceName(0,0); +} \ No newline at end of file diff --git a/source/engine/sound.h b/source/engine/sound.h new file mode 100644 index 0000000..864ea87 --- /dev/null +++ b/source/engine/sound.h @@ -0,0 +1,46 @@ +#ifndef SOUND_H +#define SOUND_H + +#include + + + +struct sound { + Mix_Chunk *sound; + unsigned char volume; +}; + +struct music { + Mix_Music *music; + unsigned char volume; +}; + +struct player { + +}; + +extern const char *audioDriver; + +void sound_init(); +void audio_open(const char *device); +void audio_close(); + +struct sound *make_sound(const char *wav); +struct music *make_music(const char *ogg); + +void play_sound(struct sound *sound); + +const char *get_audio_driver(); + +void play_music(struct sound *music); +void music_set(struct sound *music); +int music_playing(); +int music_paused(); +void music_volume(unsigned char vol); +void music_resume(); +void music_pause(); +void music_stop(); + +void audio_init(); + +#endif \ No newline at end of file diff --git a/source/engine/sprite.c b/source/engine/sprite.c index c73ada4..09e31ec 100644 --- a/source/engine/sprite.c +++ b/source/engine/sprite.c @@ -9,6 +9,8 @@ #include "gameobject.h" #include +static struct mGameObject *gui_go = NULL; + /* static struct mShader *spriteShader = NULL; @@ -48,13 +50,13 @@ void sprite_init(struct mSprite *sprite, struct mGameObject *go) void sprite_loadtex(struct mSprite *sprite, const char *path) { - sprite->tex = texture_loadfromfile(sprite->tex, path); + sprite->tex = texture_loadfromfile(path); } void sprite_loadanim(struct mSprite *sprite, const char *path, struct Anim2D anim) { - sprite->tex = texture_loadfromfile(sprite->tex, path); + sprite->tex = texture_loadfromfile(path); sprite->anim = anim; sprite->anim.timer = SDL_AddTimer(sprite->anim.ms, incrementAnimFrame, sprite); @@ -64,6 +66,10 @@ void sprite_loadanim(struct mSprite *sprite, const char *path, */ } +void sprite_settex(struct mSprite *sprite, struct Texture *tex) +{ + sprite->tex = tex; +} Uint32 incrementAnimFrame(Uint32 interval, struct mSprite *sprite) { @@ -204,3 +210,14 @@ void video_draw(struct datastream *stream, mfloat_t position[2], glDrawArrays(GL_TRIANGLE_STRIP, 0, 4); glBindVertexArray(0); } + +void gui_init() +{ + gui_go = MakeGameobject(); +} + +struct mSprite *gui_makesprite() +{ + struct mSprite *new = MakeSprite(gui_go); + return new; +} \ No newline at end of file diff --git a/source/engine/sprite.h b/source/engine/sprite.h index a450614..ad56396 100644 --- a/source/engine/sprite.h +++ b/source/engine/sprite.h @@ -1,11 +1,12 @@ #ifndef SPRITE_H #define SPRITE_H -#include +#include #include "mathc.h" struct datastream; struct mGameObject; +struct Texture; struct Anim2D { int frames; @@ -34,6 +35,7 @@ void sprite_init(struct mSprite *sprite, struct mGameObject *go); void sprite_loadtex(struct mSprite *sprite, const char *path); void sprite_loadanim(struct mSprite *sprite, const char *path, struct Anim2D anim); +void sprite_settex(struct mSprite *sprite, struct Texture *tex); void sprite_initalize(); void sprite_draw(struct mSprite *sprite); void spriteanim_draw(struct mSprite *sprite); @@ -41,6 +43,9 @@ void video_draw(struct datastream *ds, mfloat_t pos[2], mfloat_t size[2], float rotate, mfloat_t color[3]); Uint32 incrementAnimFrame(Uint32 interval, struct mSprite *sprite); +struct mSprite *gui_makesprite(); +void gui_init(); + void sprite_draw_all(); diff --git a/source/engine/static_actor.c b/source/engine/static_actor.c index adf68ff..3da833a 100644 --- a/source/engine/static_actor.c +++ b/source/engine/static_actor.c @@ -1,5 +1,4 @@ #include "static_actor.h" -#include "editorstate.h" //ADDMAKE(StaticActor); diff --git a/source/engine/texture.c b/source/engine/texture.c index 4b0a070..9843128 100644 --- a/source/engine/texture.c +++ b/source/engine/texture.c @@ -1,12 +1,10 @@ #include "texture.h" -#define STBI_FAILURE_USERMSG - +#include #include #include #include #include -#include #include "log.h" static struct { @@ -14,14 +12,13 @@ static struct { struct Texture *value; } *texhash = NULL; - -struct Texture *texture_loadfromfile(struct Texture *tex, const char *path) +struct Texture *texture_pullfromfile(const char *path) { int index = shgeti(texhash, path); if (index != -1) return texhash[index].value; - tex = calloc(1, sizeof(*tex)); + struct Texture *tex = calloc(1, sizeof(*tex)); tex->path = malloc(strlen(path) + 1); strncpy(tex->path, path, strlen(path) + 1); tex->flipy = 0; @@ -30,7 +27,38 @@ struct Texture *texture_loadfromfile(struct Texture *tex, const char *path) tex->anim.frames = 1; tex->anim.ms = 1; + int n; + stbi_set_flip_vertically_on_load(0); + unsigned char *data = stbi_load(path, &tex->width, &tex->height, &n, 4); + + if (stbi_failure_reason()) { + YughLog(0, 3, "STBI failed to load file %s with message: %s", + tex->path, stbi_failure_reason()); + + } + + tex->data = data; + + shput(texhash, tex->path, tex); + glGenTextures(1, &tex->id); + + return tex; +} + +struct Texture *texture_loadfromfile(const char *path) +{ + struct Texture *new = texture_pullfromfile(path); + + tex_gpu_load(new); + + return new; +} + + + +void tex_pull(struct Texture *tex) +{ uint8_t n; stbi_set_flip_vertically_on_load(0); tex->data = stbi_load(tex->path, &tex->width, &tex->height, &n, 4); @@ -38,22 +66,27 @@ struct Texture *texture_loadfromfile(struct Texture *tex, const char *path) if (stbi_failure_reason()) YughLog(0, 3, "STBI failed to load file %s with message: %s", tex->path, stbi_failure_reason()); - - shput(texhash, tex->path, tex); - - tex_gpu_load(tex); - - - return tex; } -void tex_reload(struct Texture *tex) +void tex_flush(struct Texture *tex) { - tex_free(tex); + free(tex->data); +} + +void tex_gpu_reload(struct Texture *tex) +{ + tex_gpu_free(tex); tex_gpu_load(tex); } +void tex_free(struct Texture *tex) +{ + free(tex->data); + free(tex->path); + free(tex); +} + void tex_gpu_load(struct Texture *tex) { if (tex->anim.frames >= 0) { @@ -172,7 +205,9 @@ void tex_anim_set(struct TexAnimation *anim) tex_anim_calc_uv(anim); } -void tex_free(struct Texture *tex) + + +void tex_gpu_free(struct Texture *tex) { if (tex->id != 0) { glDeleteTextures(1, &tex->id); diff --git a/source/engine/texture.h b/source/engine/texture.h index 3fe71ff..80e5454 100644 --- a/source/engine/texture.h +++ b/source/engine/texture.h @@ -1,7 +1,7 @@ #ifndef TEXTURE_H #define TEXTURE_H -#include +#include struct Rect { float x; @@ -36,8 +36,8 @@ struct Texture { char *type; unsigned int id; char *path; - unsigned int width; - unsigned int height; + int width; + int height; short flipy; unsigned char *data; @@ -45,14 +45,14 @@ struct Texture { struct TexAnim anim; }; - - - -struct Texture *texture_loadfromfile(struct Texture *tex, - const char *path); +struct Texture *tex_pullfromfile(const char *path); +struct Texture *texture_loadfromfile(const char *path); void tex_gpu_load(struct Texture *tex); -void tex_reload(struct Texture *tex); +void tex_gpu_reload(struct Texture *tex); +void tex_gpu_free(struct Texture *tex); void tex_free(struct Texture *tex); +void tex_flush(struct Texture *tex); +void tex_pull(struct Texture *tex); void tex_bind(struct Texture *tex); unsigned int powof2(unsigned int num); int ispow2(int num); diff --git a/source/engine/thirdparty/Chipmunk2D/LICENSE.txt b/source/engine/thirdparty/Chipmunk2D/LICENSE.txt new file mode 100644 index 0000000..55c24c9 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/LICENSE.txt @@ -0,0 +1,19 @@ +Copyright (c) 2007-2015 Scott Lembcke and Howling Moon Software + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/source/engine/thirdparty/Chipmunk2D/VERSION.txt b/source/engine/thirdparty/Chipmunk2D/VERSION.txt new file mode 100644 index 0000000..489f434 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/VERSION.txt @@ -0,0 +1,300 @@ +What's new in 7.0.3: +* MISC: Replacing GLFW with Sokol in the demo application. No need to push GLFW binaries and has a nice x-platform renderer to build on. +* MISC: Fixed some 'const' warnings for MSCV. + +What's new in 7.0.2: +* MISC: Merging pull requests. Build fixes and the like. + +What's new in 7.0.1: +* BUG: Remove references to M_PI sinces it's not actually part of C and causes problems with MSVC. +* BUG: Build fixes for Mac/CMake and MSVC 13. +* BUG: Move to using __declspec(dllexport) for Windows builds. +* BUG: Fixed a precision issue with the EPA algorithm that would cause excessive iteration. +* BUG: cpPolyshapeNewRaw() was undefined. +* BUG: Changing gravity will wake up all objects in a space. + +What's new in 7.0.0: +* All features from Chipmunk Pro are now free and open source! (threaded and NEON solver, autogeometry) +* API: Lots of cleanup to the API naming for better consistency. +* API: Renamed nearest point queries to simply point queries. +* API: Removed many deprecated functions. +* API: Struct definitions have become fully opaque instead of mangling names with the CP_PRIVATE() macro. +* API: Replaced templated accessor functions with concrete ones. Should be simpler to deal with for FFIs. +* API: Optional automatic mass properties for shapes. Calculates the moment of inertia and center of gravity for you. +* API: Optional anchor point for bodies that is separate from the center of gravity. +* API: Added radius parameters to many functions dealing with shapes (moment calculation, initialization, etc). +* API: The convex hull and winding is automatically calculated when creating a poly shape. +* API: Added a cpShapesCollide() function to check overlap of arbitrary shapes. +* API: cpShape filter property to supersede layers and groups. +* API: Collision handlers now return a collision handler struct to make it simpler to set up callbacks. +* API: Wildcard collision types. +* API: The cpArbiterTotalImpulseWithFriction() function was renamed to cpArbiterTotalImpulse(). The old useless cpArbiterTotalImpulse() implementation was removed. +* API: Contacts now store the colliding point on the surface of both shapes. +* API: cpArbiterIsRemoval() to check if a separate callback is called due to a removal and not a true separating collision. +* API: Arbiters now only store one normal per pair of colliding shapes. +* API: cpBBNewForExtents(). +* API: Added a concrete kinematic body type to replace the confusing "rogue" body concept. +* API: Added a 2x3 affine transform type, cpTransform. +* API: Added a new debug rendering API. +* MISC: Numerous improvements to the collision detection. +* MISC: cpPolyline structs are passed by reference instead of value. (I've regretted that decision for years!) + +What's new in 6.2.2: +* Fixed some issues on arm64. +* PRO: Added a 64 bit NEON solver to use on arm64. + +What's new in 6.2.1: +* Added Android support to the CMake files. (Thanks Eric Wing!) +* Added a MSVC 2012 project file. (Thanks Leonid Usov!) +* Merged a fix for VAOs on Windows. (Thanks Leonid Usov!) +* Merged a couple of other minor fixes. +* BUG: Fixed a crash issue with the ChipmunkTileCache and ChipmunkPointCloudSampler classes. (Pro only). + +What's new in 6.2.0: +* Collision detection now primarily uses the GJK and EPA algorithms instead of SAT. Internally this was a rather huge change. o_O +* Improved collision point quality and better collision point identification. +* All shape types can now be given a rounding radius. +* Collisions are now guaranteed to have a maximum of 2 collision points. +* Poly to poly collision performance is slightly better when they have a radius. Slightly worse with none. +* Implemented smoothed segment collisions to prevent colliding with the "cracks" between segment shapes. +* API: (Officially) added cpSegmentShapeSetNeighbors() used to enable smoothed line collisions. +* API: Added cpBBCenter() to get the center of a bounding box. +* API: Added cpPolyShapeInit2() and cpPolyShapeNew2() to create poly shapes with a radius. (Horrible names yes, but it will go away in Chipmunk 7) +* API: Added cpBoxShapeInit3() and cpBoxShapeNew3() to create boxes with a radius. +* API: Added cpPolyShapeGetRadius() and cpPolyShapeSetRadius() (the latter only in chipmunk_unsafe.h). +* API: Added cpNearestPointQueryInfo.g which returns the gradient of the signed distance field for the shape. +* BUG: cpMomentForPoly() will now return a correct value for degenerate 2 vertex polygons. +* BUG: Fixed an issue where certain segment query calls would return a t value of 0 instead of 1 for a missed query. +* MISC: Passing cpvzero to cpvnormalize() will now return cpvzero. No need to worry about NaNs or cpvnormalize_safe(). +* MISC: Demo app now uses GLFW instead of GLUT, and has improved drawing and text rendering routines. + +What's new in 6.1.5: +* API: Added cpArbiter*SurfaceVelocity() to allow for custom surface velocity calculation. +* API: Added cpArbiteSetContactPointSet() to allow changing the contact geometry on the fly. +* API: Added cpSpaceConvertBodyToStatic() and cpSpaceConvertBodyToDynamic(). +* API: Added [ChipmunkBody velocityAt*Point:] methods to wrap their C equivalents. (Pro only) +* API: Added overridable [ChipmunkBody updateVelocity:...] and [ChipmunkBody updatePosition:] methods. (Pro only) +* API: Added .space properties to ChipmunkBody, ChipmunkShape and ChipmunkConstaint to wrap their C equivalents. (Pro only) +* API: Added overridable [ChipmunkConstraint preSolve:] and [ChipmunkConstraint postSolve:] methods. (Pro only) +* API: Added an ChipmunkMultiGrab.grabSort property that allows you to prioritize which shape is grabbed when there is overlap. (Pro only) +* MISC: Segment queries started inside of a shape now return t=0 and n=cpvzero instead of being undefined. +* MISC: Cleaned up a lot of common assertion messages to be more clear. +* MISC: Added a new demo called Shatter. +* MISC: Added a crushing force estimation example to the ContactGraph demo and a static/dynamic conversion example to Plink. +* MISC: Modified the Sticky demo to use the new cpArbiteSetContactPointSet() to avoid the use of unnecessary sensor shapes. +* MISC: [ChipmunkSpace addBounds:...] now returns a NSArray of the bounding segments. (Pro only) + +What's new in 6.1.4: +* MISC: Fixed a build script issue that was preventing the documentation from being generated. + +What's new in 6.1.3: +* BUG: Fixed a couple of very specific but fatal bugs that occur when sleeping is enabled and filtering collisions. +* BUG: Fixed an issue with cpvslerp() between very similar vectors. +* BUG: Fixed an issue with grab friction in ChipmunkMultiGrab. (Pro only) +* MISC: Implemented the cpConstraintGetImpulse() functionality for spring joints. +* MISC: Added more functions to chipmunk_ffi.h + +What's new in 6.1.2: +* API: Added a cpArbiter.data pointer. Now you can tag collisions with custom persistent data. +* API: Added segment to segment collisions (thanks to LegoCylon) +* API: cpSpaceAddPostStepCallback() now returns false if the callback was a duplicate. +* API: Added the ChipmunkAbstractSampler.marchThreshold property instead of hardcoding it to 0.5. +* API: Added ChipmunkGrooveJoint properties for the groove and joint anchors. +* API: ChipmunkMultiGrab now returns information about grabbed shapes. +* BUG: Fixed a minor (non-crashing, non-leaking) memory pooling issue with reindexing lots of static shapes. +* BUG: Fixed an issue with the slerp functions that would cause them to return incorrect results when given non-unit length input. +* BUG: Fixed a precision bug with the ChipmunkImage sampler classes that could cause artifacts or miss small features. +* BUG: Fixed a number of properties in Objective-Chipmunk that should have been nonatomic. +* BUG: Fixed a number of types in Objective-Chipmunk that were incorrectly id that should have been cpGroup, cpCollisionType etc. It's now possible to redefine them at compile time if you wish. +* MISC: Dropped armv6 support in favor of armv7s on iOS. (You can switch it back easily if you need.) +* MISC: Updated iOS build scripts to guess the latest SDK. +* MISC: Added the "Sticky Surfaces" demo as a cpArbiter.data example. +* MISC: Updated Objective-Chipmunk build scripts to always use the latest iOS SDK. + +What's new in 6.1.1: +* API: Renamed the new block based iterators as soon as possible to match the Apple convention ("_b" suffix). + +What's new in 6.1.0: +* API: Added a pthread based, multi-threaded solver to accelerate the game on multi-core systems. (Pro only) +* API: Added cpConvexHull() and CP_CONVEX_HULL() for generating convex hulls. +* API: Added cpPolylineConvexDecomposition_BETA() to generate an approximate concave decomposition of a polyline. (Pro only) +* API: Added [ChipmunkPolyline toConvexHull:] to generate approximate convex hulls. (Pro only). +* API: Added [ChipmunkPolylineSet toConvexHulls_BETA:]. (Pro only) +* API: Added nearest point queries. +* API: Added a push mode to ChipmunkMultiGrab so touches can interact with the scene even if they didn't initially touch a shape. (Pro only) +* API: Added optional block based iterators. +* API: Added a space property to cpBody, cpShape and cpConstraint types. +* BUG: Fixed an issue with changing the floating point and vector type on OS X. +* BUG: Fixed a pixel offset in ChipmunkImageSampler that could cause minor sampling artifacts. (Pro only) +* BUG: Fixed an issue where cpShape and cpConstraint structs could have garbage space pointers if cpcalloc() was redefined. +* BUG: Fixed assertions in cpArbiter getters to correctly reflect a contact count of 0 from separate() callbacks. +* BUG: Fixed a regression relating to registering post-step() callbacks from other post-step() callbacks. +* BUG: Fixed a minor memory leak for sleeping bodies when destroying a space. +* MISC: Point queries are now deprecated in preference to point queries. +* MISC: cpSpatialIndexPointQuery() was redundant and has been removed. Use cpSpatialIndexQuery() instead. +* MISC: cpShape*Query() functions now accept a NULL info pointer if you don't want detailed query info. +* MISC: The enableContactGraph property of cpSpace is deprecated and always be true. +* MISC: Added a new demos of the convex hull functions and a self balancing Unicycle. + +What's new in 6.0.3: +* API: Added a cpBBForCircle() convenience function. +* API: Added cpBBSegmentQuery() to check where a segment hits a cpBB. +* API: Added cpBodyGetVelAtWorldPoint() and cpBodyGetVelAtLocalPoint() to get point velocities on a body. +* API: Added cpArbiterTotalKE() to calculate the energy lost due to a collision. Great for calculating damage accurately. +* API: Added methods to get an ObjC pointer from a C chipmunk struct. +* API: Added a CHIPMUNK_ARBITER_GET_BODIES() macro for Objective-Chipmunk. +* API: The Objective-Chipmunk headers are now ARC compatible. +* API: Added a [ChipmunkSpace contains:] method to check if a ChipmunkObject has been added to the space or not. +* API: Added a cpBBNewForCircle() function. +* API: Added a cpBBSegmentQuery() function for raycasting againsts AABBs. +* BUG: Fixed a regression with ChipmunkSpace.bodies and ChipmunkSpace.shapes that caused crashes. +* BUG: Fixed a rare bug with postStep() callbacks and iterators. +* BUG: Fixed a border case in cpBBIntersectsSegment() that could cause missed segment queries. +* MISC: Added some new assertions for error conditions that were previously uncaught. +* MISC: Accelerated segment queries in cpBBTree by sorting the nodes. +* MISC: Added a new "Slice" demo that lets you cut up a polygon. +* MISC: Added NEON optimizations for Chipmunk Pro. Expect running on most ARM platforms to be 25-35% faster for contact heavy simulations. +* MISC: All ChipmunkObject instances added to a space are now retained, even composite ones. + +What's new in 6.0.2: +* API: Added cpSpaceIsLocked() to check if you are in a callback or not. +* API: Removed the long deprecated [ChipmunkSpace addShapeAHandler:] and [ChipmunkSpace addShapeBHandler:] methods. +* API: The ChipmunkObject protocol now can return any id object instead of just an NSSet. +* API: The largely useless [ChipmunkSpace addBaseObjects:] and [ChipmunkSpace removeBaseObjects:] methods were removed. +* API: Added [ChipmunkSpace smartAdd:] and [ChipmunkSpace smartRemove:] methods for a consistent API to remove objects inside and out of callbacks. +* API: Added [ChipmunkSpace addPostStepBlock:key:] to complement [ChipmunkSpace addPostStepCallback:selector:key:]. +* API: Added [ChipmunkSpace addPostStepAddition:]. +* API: Objective-Chipmunk collision handlers no longer retain their target to avoid reference cycles. +* API: Added callbacks to joints. +* BUG: Soft errors (only checked when debug mode is enabled) and warnings were disabled. Whoops. +* BUG: cpShapeIsSensor() was incorrectly named in chipmunk_ffi.h. +* BUG: It should be safe to call cpActivateBody() from an space iterator callback now. +* MISC: Very nice bouyancy demo added based on callbacks. +* MISC: Breakable Joints demo showing how to use the new joint callbacks. +* MISC: Player demo updated and greatly enhanced by Chipmunk 6 features. +* MISC: Changed adding a static body to a space from a warning to a hard error. +* MISC: cpGroup and cpCollisionType now default to uintptr_t so you can safely use pointers instead of ints for these types. +* MISC: Updated the MSVC10 project file. +* MISC: Updated the FFI defs. + +What's new in 6.0.1: +* BUG: Calling cpBodySetPos() on a sleeping body was delaying the Separate() handler callback if one existed. +* BUG: Fixed a bug where Separate() handler callbacks were not occuring when removing shapes. +* BUG: Calling cpBodyApplyForce() or cpBodyResetForces() was not activating sleeping bodies. +* API: Added cpSpaceEachConstraint(). +* API: Added a "CurrentTimeStep" property to cpSpace to retrieve the current (or most recent) timestep. +* MISC: Got rid of anonymous unions so that it is C99 clean again. + +What's new in 6.0.0: +Chipmunk 6.x's API is not quite 100% compatible with 5.x. Make sure you read the list of changes carefully. +Keep in mind that this is a x.0.0 release and that it's likely there are still some bugs I don't know about yet. I've spent a lot of effort rewritting the collision detection, sleeping, and contact graph algorithms that have required large changes and cleanup to the 5.x codebase. I've ironed out all the bugs that I know of, and the beta test went well. So it's finally time for 6! + +* API: Chipmunk now has hard runtime assertions that aren't disabled in release mode for many error conditions. Most people have been using release builds of Chipmunk during development and were missing out on very important error checking. +* API: Access to the private API has been disabled by default now and much of the private API has changed. I've added official APIs for all the uses of the private API I knew of. +* API: Added accessor functions for every property on every type. As Chipmunk's complexity has grown, it's become more difficult to ignore accessors. You are encouraged to use them, but are not required to. +* API: Added cpSpaceEachBody() and cpSpaceEachShape() to iterate bodies/shapes in a space. +* API: Added cpSpaceReindexShapesForBody() to reindex all the shapes attached to a particular body. +* API: Added a 'data' pointer to spaces now too. +* API: cpSpace.staticBody is a pointer to the static body instead of a static reference. +* API: The globals cp_bias_coef, cp_collision_slop, cp_contact_persistence have been moved to properties of a space. (collisionBias, collisionSlop, collisionPersistence respectively) +* API: Added cpBodyActivateStatic() to wake up bodies touching a static body with an optional shape filter parameter. +* API: Added cpBodyEachShape() and cpBodyEachConstraint() iterators to iterate the active shapes/constraints attached to a body. +* API: Added cpBodyEeachArbiter() to iterate the collision pairs a body is involved in. This makes it easy to perform grounding checks or find how much collision force is being applied to an object. +* API: The error correction applied by the collision bias and joint bias is now timestep independent and the units have completely changed. +* FIX: Units of damping for springs are correct regardless of the number of iterations. Previously they were only correct if you had 1 or 2 iterations. +* MISC: Numerous changes to help make Chipmunk work better with variable timesteps. Use of constant timesteps is still highly recommended, but it is now easier to change the time scale without introducing artifacts. +* MISC: Performance! Chipmunk 6 should be way faster than Chipmunk 5 for almost any game. +* MISC: Chipmunk supports multiple spatial indexes and uses a bounding box tree similar to the one found in the Bullet physics library by default. This should provide much better performance for scenes with objects of differening size and works without any tuning for any scale. + + +What's new in 5.3.5 +* FIX: Fixed spelling of cpArbiterGetDepth(). Was cpArbiteGetDepth() before. Apparently nobody ever used this function. +* FIX: Added defines for M_PI and M_E. Apparently these values were never part of the C standard math library. Who knew!? +* FIX: Added a guard to cpBodyActivate() so that it's a noop for rouge bodies. +* FIX: Shape queries now work with (and against) sensor shapes. +* FIX: Fixed an issue where removing a collision handler while a separate() callback was waiting to fire the next step would cause crashes. +* FIX: Fixed an issue where the default callback would not be called for sensor shapes. +* FIX: Resetting or applying forces or impulses on a body causes it to wake up now. +* MISC: Added a check that a space was not locked when adding or removing a callback. +* MISC: Removed cpmalloc from the API and replaced all occurences with cpcalloc +* MISC: Added a benchmarking mode to the demo app. -trial runs it in time trial mode and -bench makes it run some benchmarking demos. + +What's new in 5.3.4: +* FIX: cpBodyActivate() can now be called from collision and query callbacks. This way you can use the setter functions to change properties without indirectly calling cpBodyActivate() and causing an assertion. +* FIX: cpArbiterGetContactPointSet() was returning the collision points for the normals. +* FIX: cpSpaceEachBody() now includes sleeping bodies. +* FIX: Shapes attached to static rogue bodies created with cpBodyNewStatic() are added as static shapes. +* MISC: Applied a user patch to update the MSVC project and add a .def file. + +What's new in 5.3.3: +* API: Added cpArbiteGetCount() to return the number of contact points. +* API: Added helper functions for calculating areas of Chipmunk shapes as well as calculating polygon centroids and centering polygons on their centroid. +* API: Shape queries. Query a shape to test for collisions if it were to be inserted into a space. +* API: cpBodyInitStatic() and cpBodyNewStatic() for creating additional static (rogue) bodies. +* API: cpBodySleepWithGroup() to allow you to create groups of sleeping objects that are woken up together. +* API: Added overloaded *, +, - and == operators for C++ users. +* API: Added cpSpaceActivateShapesTouchingShape() to query for and activate any shapes touching a given shape. Useful if you ever need to move a static body. +* FIX: Fixed an extremely rare memory bug in the collision cache. +* FIX: Fixed a memory leak in Objective-Chipmunk that could cause ChipmunkSpace objects to be leaked. +* MISC: C struct fields and function that are considered private have been explicitly marked as such. Defining CP_ALLOW_PRIVATE_ACCESS to 0 in Chipmunk.h will let you test which parts of the private API that you are using and give me feedback about how to build proper APIs in Chipmunk 6 for what you are trying to do. +* MISC: Allow CGPoints to be used as cpVect on Mac OS X as well as iOS. + + +What's new in 5.3.2: +* FIX: Collision begin callbacks were being called continuously for sensors or collisions rejected from the pre-solve callback. +* FIX: Plugged a nasty memory leak when adding post-step callbacks. +* FIX: Shapes were being added to the spatial hash using an uninitialized bounding box in some cases. +* FIX: Perfectly aligned circle shapes now push each other apart. +* FIX: cpBody setter functions now call cpBodyActivate(). +* FIX: Collision handler targets are released in Objective-Chipmunk when they are no longer needed instead of waiting for the space to be deallocated. +* API: cpSpaceSegmentQuery() no longer returns a boolean. Use cpSpaceSegmentQueryFirst() instead as it's more efficient. +* NEW: cpSpaceRehashShape() Rehash an individual shape, active or static. +* NEW: cpBodySleep() Force a body to fall asleep immediately. +* NEW: cpConstraintGetImpulse() Return the most recent impulse applied by a constraint. +* NEW: Added setter functions for the groove joint endpoints. +* MISC: A number of other minor optimizations and fixes. + +What's new in 5.3.1: + * NEW: Added a brand new tutorial for Objective-Chipmunk: SimpleObjectiveChipmunk that can be found in the Objective-Chipmunk folder. + * NEW: Proper API docs for Objective-Chipmunk. + * NEW: Updated the included Objective-Chipmunk library. + * FIX: Fixed a rare memory crash in the sensor demo. + * FIX: Fixed some warnings that users submitted. + +What's new in 5.3.0: + * FIX: Fixed the source so it can compile as C, C++, Objective-C, and Objective-C++. + * FIX: Fixed cp_contact_persistence. It was broken so that it would forget collision solutions after 1 frame instead of respecting the value set. + * OPTIMIZATION: Several minor optimizations have been added. Though performance should only differ by a few percent. + * OPTIMIZATION: Chipmunk now supports putting bodies to sleep when they become inactive. + * API: Elastic iterations are now deprecated as they should no longer be necessary. + * API: Added API elements to support body sleeping. + * API: Added a statically allocated static body to each space for attaching static shapes to. + * API: Static shapes attached to the space's static body can simply be added to the space using cpSpaceAddShape(). + * NEW: New MSVC projects. + * NEW: Added boolean and time stamp types for clarity. + +What's new in 5.2.0: + * OPTIMIZATION: Chipmunk structs used within the solver are now allocated linearly in large blocks. This is much more CPU cache friendly. Programs have seen up to 50% performance improvements though 15-20% should be expected. + * API: Shape references in cpArbiter structs changed to private_a and private_b to discourage accessing the fields directly and getting them out of order. You should be using cpArbiterGetShapes() or CP_ARBITER_GET_SHAPES() to access the shapes in the correct order. + * API: Added assertion error messages as well as warnings and covered many new assertion cases. + * FIX: separate() callbacks are called before shapes are removed from the space to prevent dangling pointers. + * NEW: Added convenience functions for creating box shapes and calculating moments. + + +What's new in 5.1.0: + * FIX: fixed a NaN issue that was causing raycasts for horizontal or vertical lines to end up in an infinite loop + * FIX: fixed a number of memory leaks + * FIX: fixed warnings for various compiler/OS combinations + * API: Rejecting a collision from a begin() callback permanently rejects the collision until separation + * API: Erroneous collision type parameterns removed from cpSpaceDefaulteCollisionHandler() + * MOVE: FFI declarations of inlined functions into their own header + * MOVE: Rearranged the project structure to separate out the header files into a separate include/ directory. + * NEW: Added a static library target for the iPhone. + * NEW: Type changes when building on the iPhone to make it friendlier to other iPhone APIs + * NEW: Added an AABB query to complement point and segment queries + * NEW: CP_NO_GROUP and CP_ALL_LAYERS constants + +What's new in 5.0.0: + * Brand new Joint/Constraint API: New constraints can be added easily and are much more flexible than the old joint system + * Efficient Segment Queries - Like raycasting, but with line segments. + * Brand new collision callback API: Collision begin/separate events, API for removal of objects within callbacks, more programable control over collision handling. \ No newline at end of file diff --git a/source/engine/thirdparty/Chipmunk2D/doc/examples.html b/source/engine/thirdparty/Chipmunk2D/doc/examples.html new file mode 100644 index 0000000..66ef905 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/examples.html @@ -0,0 +1,119 @@ + + + + + Chipmunk Game Dynamics Documentation + + + + +

Example Code Snippets:

+ + + +

Getting a Transformation from a Rigid Body:

+ +

You can quickly and easily build a transformation matrix from a Chipmunk body. The following code is for OpenGL, but it should be trivial to modify for DirectX or affine transforms. (Note that OpenGL matrices are column-major)

+ +
cpVect pos = body->p;
+cpVect rot = body->rot;
+
+GLFloat matrix[16] = {
+   rot.x, rot.y, 0.0f, 0.0f,
+  -rot.y, rot.x, 0.0f, 0.0f,
+   0.0f,   0.0f, 1.0f, 0.0f,
+   pos.x, pos.y, 0.0f, 1.0f,
+};
+
+glMultMatrixf(matrix.farr);
+
+ + + +

Collision Callbacks:

+ +

This snippet demonstrates several Chipmunk collision callback features. It defines a collision handler that is called when collision shapes start touching and also a post-step callback to remove the collision shape and body.

+ +
static void
+postStepRemove(cpSpace *space, cpShape *shape, void *unused)
+{
+  cpSpaceRemoveBody(space, shape->body);
+  cpSpaceRemoveShape(space, shape);
+  
+  cpShapeFree(shape);
+  cpBodyFree(shape->body);
+}
+
+static int
+begin(cpArbiter *arb, cpSpace *space, void *unused)
+{
+  // Get the cpShapes involved in the collision
+  // The order will be the same as you defined in the handler definition
+  // a->collision_type will be BULLET_TYPE and b->collision_type will be MONSTER_TYPE
+  cpShape *a, *b; cpArbiterGetShapes(arb, &a, &b);
+  
+  // Alternatively you can use the CP_ARBITER_GET_SHAPES() macro
+  // It defines and sets the variables for you.
+  //CP_ARBITER_GET_SHAPES(arb, a, b);
+  
+  // Add a post step callback to safely remove the body and shape from the space.
+  // Calling cpSpaceRemove*() directly from a collision handler callback can cause crashes.
+  cpSpaceAddPostStepCallback(space, (cpPostStepFunc)postStepRemove, b, NULL);
+  
+  // The object is dead, don’t process the collision further
+  return 0;
+}
+
+#define BULLET_TYPE 1
+#define MONSTER_TYPE 2
+
+// Define a collision handler for bullets and monsters
+// Kill the monster by removing it’s shape and body from the space as soon as it’s hit by a bullet 
+cpSpaceAddCollisionHandler(space, BULLET_TYPE, MONSTER_TYPE, begin, NULL, NULL, NULL, NULL);
+ +

For more callback examples, see the One Way Platform Demo, Sensors Demo, or the Player Demo.

+ + + +

Query Examples:

+ +

The following example is taken directly from ChipmunkDemo.c. When the mouse is clicked, a point query is performed to see if there is a shape under the mouse. If there is, it adds a joint to the body that links it to the mouse's movement.

+ +
static void
+click(int button, int state, int x, int y)
+{
+  if(button == GLUT_LEFT_BUTTON){
+    if(state == GLUT_DOWN){
+      cpVect point = mouseToSpace(x, y);
+    
+      cpShape *shape = cpSpacePointQueryFirst(space, point, GRABABLE_MASK_BIT, 0);
+      if(shape){
+        cpBody *body = shape->body;
+        mouseJoint = cpPivotJointNew2(mouseBody, body, cpvzero, cpBodyWorld2Local(body, point));
+        mouseJoint->maxForce = 50000.0f;
+        mouseJoint->biasCoef = 0.15f;
+        cpSpaceAddConstraint(space, mouseJoint);
+      }
+    } else if(mouseJoint){
+      cpSpaceRemoveConstraint(space, mouseJoint);
+      cpConstraintFree(mouseJoint);
+      mouseJoint = NULL;
+    }
+  }
+}
+ +

Perform a segment query to see if a laser beam hits a shape. We want to draw particles at both the position where the beam enters and exits the shape.

+ +
cpVect a = cpv(...), b = cpv(...);
+
+cpSegmentQueryInfo info = {};
+if(cpSpaceSegmentQueryFirst(space, a, b, -1, 0, &info)){
+  cpSegmentQueryInfo info2;
+  cpShapeSegmentQuery(info.shape, b, a, &info2);
+  
+  cpVect enterPoint = cpSegmentQueryHitPoint(a, b, info);
+  cpVect exitPoint = cpSegmentQueryHitPoint(b, a, info2);
+}
+ + + diff --git a/source/engine/thirdparty/Chipmunk2D/doc/examples/BreakableJoint.html b/source/engine/thirdparty/Chipmunk2D/doc/examples/BreakableJoint.html new file mode 100644 index 0000000..a526b9a --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/examples/BreakableJoint.html @@ -0,0 +1,22 @@ +
// Create the joint and set it's max force property.
+breakableJoint = cpSpaceAddConstraint(space, cpPinJointNew(body1, body2, cpv(15,0), cpv(-15,0)));
+cpConstraintSetMaxForce(breakableJoint, 4000);
+
+
+// In your update function:
+// Step your space normally...
+cpFloat dt = 1.0/60.0;
+cpSpaceStep(space, dt);
+
+if(breakableJoint){
+  // Convert the impulse to a force by dividing it by the timestep.
+  cpFloat force = cpConstraintGetImpulse(breakableJoint)/dt;
+  cpFloat maxForce = cpConstraintGetMaxForce(breakableJoint);
+
+  // If the force is almost as big as the joint's max force, break it.
+  if(force > 0.9*maxForce){
+    cpSpaceRemoveConstraint(space, breakableJoint);
+    breakableJoint = NULL;
+  }
+}
+
\ No newline at end of file diff --git a/source/engine/thirdparty/Chipmunk2D/doc/examples/CollisionCallback.html b/source/engine/thirdparty/Chipmunk2D/doc/examples/CollisionCallback.html new file mode 100644 index 0000000..26a2161 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/examples/CollisionCallback.html @@ -0,0 +1,38 @@ +
static void
+postStepRemove(cpSpace *space, cpShape *shape, void *unused)
+{
+  cpSpaceRemoveShape(space, shape);
+  cpSpaceRemoveBody(space, shape->body);
+  
+  cpShapeFree(shape);
+  cpBodyFree(shape->body);
+}
+
+static int
+begin(cpArbiter *arb, cpSpace *space, void *data)
+{
+  // Get the cpShapes involved in the collision
+  // The order will be the same as you defined in the handler definition
+  // a->collision_type will be BULLET_TYPE and b->collision_type will be MONSTER_TYPE
+  CP_ARBITER_GET_SHAPES(arb, a, b);
+  
+  // The macro expands exactly as if you had typed this:
+  // cpShape *a, *b; cpArbiterGetShapes(arb, &a, &b);
+  
+  // Add a post step callback to safely remove the body and shape from the space.
+  // Calling cpSpaceRemove*() directly from a collision handler callback can cause crashes.
+  cpSpaceAddPostStepCallback(space, (cpPostStepFunc)postStepRemove, b, NULL);
+  
+  // The object is dead, don’t process the collision further
+  return 0;
+}
+
+#define BULLET_TYPE 1
+#define MONSTER_TYPE 2
+
+// Define a collision handler for bullets and monsters
+// Kill the monster by removing it’s shape and body from the space as soon as it’s hit by a bullet
+cpCollisionHandler *handler = cpSpaceAddCollisionHandler(space, BULLET_TYPE, MONSTER_TYPE);
+handler->beginFunc = begin;
+
+
\ No newline at end of file diff --git a/source/engine/thirdparty/Chipmunk2D/doc/examples/Crushing.html b/source/engine/thirdparty/Chipmunk2D/doc/examples/Crushing.html new file mode 100644 index 0000000..e16e251 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/examples/Crushing.html @@ -0,0 +1,23 @@ +
struct CrushingContext {
+  cpFloat magnitudeSum;
+  cpVect vectorSum;
+};
+
+static void
+EstimateCrushingHelper(cpBody *body, cpArbiter *arb, struct CrushingContext *context)
+{
+  cpVect j = cpArbiterTotalImpulseWithFriction(arb);
+  context->magnitudeSum += cpvlength(j);
+  context->vectorSum = cpvadd(context->vectorSum, j);
+}
+
+cpFloat
+EstimateCrushForce(cpBody *body, cpFloat dt)
+{
+  struct CrushingContext crush = {0.0f, cpvzero};
+  cpBodyEachArbiter(body, (cpBodyArbiterIteratorFunc)EstimateCrushingHelper, &crush);
+  
+  // Compare the vector sum magnitude and magnitude sum to see if
+  // how much the collision forces oppose one another.
+  cpFloat crushForce = (crush.magnitudeSum - cpvlength(crush.vectorSum))*dt;
+}
\ No newline at end of file diff --git a/source/engine/thirdparty/Chipmunk2D/doc/examples/DynamicStatic.html b/source/engine/thirdparty/Chipmunk2D/doc/examples/DynamicStatic.html new file mode 100644 index 0000000..9938298 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/examples/DynamicStatic.html @@ -0,0 +1,18 @@ +
// This example is pulled from the Plink demo.
+if(ChipmunkDemoRightDown){
+  // Find the shape under the mouse.
+  cpShape *nearest = cpSpaceNearestPointQueryNearest(space, ChipmunkDemoMouse, 0.0, GRABABLE_MASK_BIT, CP_NO_GROUP, NULL);
+  if(nearest){
+    cpBody *body = cpShapeGetBody(nearest);
+    if(cpBodyIsStatic(body)){
+      // If the body is static, convert it to dynamic and add it to the space.
+      cpSpaceConvertBodyToDynamic(space, body, pentagon_mass, pentagon_moment);
+      cpSpaceAddBody(space, body);
+    } else {
+      // If the body is dynamic, remove it from the space and convert it to static.
+      cpSpaceRemoveBody(space, body);
+      cpSpaceConvertBodyToStatic(space, body);
+    }
+  }
+}
+
\ No newline at end of file diff --git a/source/engine/thirdparty/Chipmunk2D/doc/examples/Hello Chipmunk.html b/source/engine/thirdparty/Chipmunk2D/doc/examples/Hello Chipmunk.html new file mode 100644 index 0000000..8215aab --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/examples/Hello Chipmunk.html @@ -0,0 +1,64 @@ +
#include <stdio.h>
+#include <chipmunk.h>
+
+int main(void){
+  // cpVect is a 2D vector and cpv() is a shortcut for initializing them.
+  cpVect gravity = cpv(0, -100);
+  
+  // Create an empty space.
+  cpSpace *space = cpSpaceNew();
+  cpSpaceSetGravity(space, gravity);
+  
+  // Add a static line segment shape for the ground.
+  // We'll make it slightly tilted so the ball will roll off.
+  // We attach it to a static body to tell Chipmunk it shouldn't be movable.
+  cpShape *ground = cpSegmentShapeNew(cpSpaceGetStaticBody(space), cpv(-20, 5), cpv(20, -5), 0);
+  cpShapeSetFriction(ground, 1);
+  cpSpaceAddShape(space, ground);
+  
+  // Now let's make a ball that falls onto the line and rolls off.
+  // First we need to make a cpBody to hold the physical properties of the object.
+  // These include the mass, position, velocity, angle, etc. of the object.
+  // Then we attach collision shapes to the cpBody to give it a size and shape.
+  
+  cpFloat radius = 5;
+  cpFloat mass = 1;
+  
+  // The moment of inertia is like mass for rotation
+  // Use the cpMomentFor*() functions to help you approximate it.
+  cpFloat moment = cpMomentForCircle(mass, 0, radius, cpvzero);
+  
+  // The cpSpaceAdd*() functions return the thing that you are adding.
+  // It's convenient to create and add an object in one line.
+  cpBody *ballBody = cpSpaceAddBody(space, cpBodyNew(mass, moment));
+  cpBodySetPosition(ballBody, cpv(0, 15));
+  
+  // Now we create the collision shape for the ball.
+  // You can create multiple collision shapes that point to the same body.
+  // They will all be attached to the body and move around to follow it.
+  cpShape *ballShape = cpSpaceAddShape(space, cpCircleShapeNew(ballBody, radius, cpvzero));
+  cpShapeSetFriction(ballShape, 0.7);
+  
+  // Now that it's all set up, we simulate all the objects in the space by
+  // stepping forward through time in small increments called steps.
+  // It is *highly* recommended to use a fixed size time step.
+  cpFloat timeStep = 1.0/60.0;
+  for(cpFloat time = 0; time < 2; time += timeStep){
+    cpVect pos = cpBodyGetPosition(ballBody);
+    cpVect vel = cpBodyGetVelocity(ballBody);
+    printf(
+      "Time is %5.2f. ballBody is at (%5.2f, %5.2f). It's velocity is (%5.2f, %5.2f)\n",
+      time, pos.x, pos.y, vel.x, vel.y
+    );
+    
+    cpSpaceStep(space, timeStep);
+  }
+  
+  // Clean up our objects and exit!
+  cpShapeFree(ballShape);
+  cpBodyFree(ballBody);
+  cpShapeFree(ground);
+  cpSpaceFree(space);
+  
+  return 0;
+}
\ No newline at end of file diff --git a/source/engine/thirdparty/Chipmunk2D/doc/examples/JointRecipies.html b/source/engine/thirdparty/Chipmunk2D/doc/examples/JointRecipies.html new file mode 100644 index 0000000..47c5cc2 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/examples/JointRecipies.html @@ -0,0 +1,17 @@ +
// Faked top down friction.
+
+// A pivot joint configured this way will calculate friction against the ground for games with a top down perspective.
+// Because the joint correction is disabled, the joint will not recenter itself and only apply to the velocity.
+// The force the joint applies when changing the velocity will be clamped by the max force
+// and this causes it to work exactly like friction!
+cpConstraint *pivot = cpSpaceAddConstraint(space, cpPivotJointNew2(staticBody, body, cpvzero, cpvzero));
+cpConstraintSetMaxBias(pivot, 0.0f); // disable joint correction
+cpConstraintSetMaxForce(pivot, 1000.0f);
+
+// The pivot joint doesn't apply rotational forces, use a gear joint with a ratio of 1.0 for that.
+cpConstraint *gear = cpSpaceAddConstraint(space, cpGearJointNew(staticBody, body, 0.0f, 1.0f));
+cpConstraintSetMaxBias(gear, 0.0f); // disable joint correction
+cpConstraintSetMaxForce(gear, 5000.0f);
+
+// Also, instead of connecting the joints to a static body, you can connect them to an infinite mass rogue body.
+// You can then use the rogue body as a control body to the connected body. See the Tank demo as an example.
\ No newline at end of file diff --git a/source/engine/thirdparty/Chipmunk2D/doc/examples/Moments.html b/source/engine/thirdparty/Chipmunk2D/doc/examples/Moments.html new file mode 100644 index 0000000..8d0622c --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/examples/Moments.html @@ -0,0 +1,14 @@ +
// Moment for a solid circle with a mass of 2 and radius 5.
+cpFloat circle1 = cpMomentForCircle(2, 0, 5, cpvzero);
+
+// Moment for a hollow circle with a mass of 1, inner radius of 2 and outer radius of 6.
+cpFloat circle2 = cpMomentForCircle(1, 2, 6, cpvzero);
+
+// Moment for a solid circle with a mass of 1, radius of 3 and
+// centered 3 units along the x axis from the center of gravity.
+cpFloat circle3 = cpMomentForCircle(2, 0, 5, cpv(3, 0));
+
+// Composite object. 1x4 box centered on the center of gravity and a circle sitting on top.
+// Just add the moments together.
+cpFloat composite = cpMomentForBox(boxMass, 1, 4) + cpMomentForCircle(circleMass, 0, 1, cpv(0, 3));
+
\ No newline at end of file diff --git a/source/engine/thirdparty/Chipmunk2D/doc/examples/PlaySoundOnCollision.html b/source/engine/thirdparty/Chipmunk2D/doc/examples/PlaySoundOnCollision.html new file mode 100644 index 0000000..a45cc04 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/examples/PlaySoundOnCollision.html @@ -0,0 +1,15 @@ +

+// Callback function
+static cpBool PlaySoundOnImpact(cpArbiter *arb, cpSpace *space, void *data){
+    PlayCrashSound();
+    return cpTrue;
+}
+
+// When setting up, reference your callback function:
+{
+    ...
+    cpCollisionHandler *handler = cpSpaceAddCollisionHandler(space, PLAYER, WALL);
+    handler->postSolveFunc = PlaySoundOnImpact;
+    ...
+}   
+
\ No newline at end of file diff --git a/source/engine/thirdparty/Chipmunk2D/doc/examples/Sleeping.html b/source/engine/thirdparty/Chipmunk2D/doc/examples/Sleeping.html new file mode 100644 index 0000000..32af5bd --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/examples/Sleeping.html @@ -0,0 +1,25 @@ +
// Construct a pile of boxes.
+// Force them to sleep until the first time they are touched.
+// Group them together so that touching any box wakes all of them.
+cpFloat size = 20;
+cpFloat mass = 1;
+cpFloat moment = cpMomentForBox(mass, size, size);
+
+cpBody *lastBody = NULL;
+
+for(int i=0; i<5; i++){
+  cpBody *body = cpSpaceAddBody(space, cpBodyNew(mass, moment));
+  cpBodySetPos(body, cpv(0, i*size));
+  
+  cpShape *shape = cpSpaceAddShape(space, cpBoxShapeNew(body, size, size));
+  cpShapeSetFriction(shape, 0.7);
+  
+  // You can use any sleeping body as a group identifier.
+  // Here we just keep a reference to the last body we initialized.
+  // Passing NULL as the group starts a new sleeping group.
+  // You MUST do this after completely initializing the object.
+  // Attaching shapes or calling setter functions will wake the body back up.
+  cpBodySleepWithGroup(body, lastBody);
+  lastBody = body;
+}
+
\ No newline at end of file diff --git a/source/engine/thirdparty/Chipmunk2D/doc/examples/cpConvexHull.html b/source/engine/thirdparty/Chipmunk2D/doc/examples/cpConvexHull.html new file mode 100644 index 0000000..b58de19 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/examples/cpConvexHull.html @@ -0,0 +1,25 @@ +
int first = 0;
+
+// Create space to store the convex hull.
+// An alloca(), or a variable length array would be a better, but not always portable choice.
+cpVect *hullVerts = (cpVect *)calloc(vertCount, sizeof(cpVect));
+int hullCount = cpConvexHull(vertCount, verts, hullVerts, &first, 0.0);
+
+// hullVerts[0] will be equal to verts[first] here.
+// If you don't care, pass NULL instead of the 'first' pointer.
+
+cpBody *body = cpBodyNew(mass, cpMomentForPoly(mass, hullCount, hullVerts, cpvzero));
+cpShape *shape = cpPolyShapeNew(body, hullCount, hullVerts, cpvzero);
+
+free(hullVerts);
+
+// *********
+// Altenatively you can use the CP_CONVEX_HULL() macro to save yourself a little work
+
+// The macro will declare the hullCount and hullVerts variables.
+// hullVerts is allocated on the stack and does not need to be freed.
+CP_CONVEX_HULL(count, verts, hullCount, hullVerts)
+
+cpBody *body = cpBodyNew(mass, cpMomentForPoly(mass, hullCount, hullVerts, cpvzero));
+cpShape *shape = cpPolyShapeNew(body, hullCount, hullVerts, cpvzero);
+
\ No newline at end of file diff --git a/source/engine/thirdparty/Chipmunk2D/doc/examples/cpSpaceEachBody.html b/source/engine/thirdparty/Chipmunk2D/doc/examples/cpSpaceEachBody.html new file mode 100644 index 0000000..5933c0e --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/examples/cpSpaceEachBody.html @@ -0,0 +1,12 @@ +
// Code snippet to check if all bodies in the space are sleeping
+
+// This function is called once for each body in the space.
+static void EachBody(cpBody *body, cpBool *allSleeping){
+  if(!cpBodyIsSleeping(body)) *allSleeping = cpFalse;
+}
+
+// Then in your tick method, do this:
+cpBool allSleeping = true;
+cpSpaceEachBody(space, (cpSpaceBodyIteratorFunc)EachBody, &allSleeping);
+printf("All are sleeping: %s\n", allSleeping ? "true" : "false");
+
\ No newline at end of file diff --git a/source/engine/thirdparty/Chipmunk2D/doc/images/hash_just_right.png b/source/engine/thirdparty/Chipmunk2D/doc/images/hash_just_right.png new file mode 100644 index 0000000000000000000000000000000000000000..e567fd5255c5384373c874575874c8350aa18fd9 GIT binary patch literal 10953 zcmX9^bzD@>*Iq)pmu4yHl8&XjyKx2S?nOjt=`KZqr5ov%63JD8rCS=74rvg0_xpSQ zxbeAj&&-@>o^xjA%!$+2RU^cs#RC8Ugc|C~h5!H>5cNKYgO0l2EQPzE9=P7>7Ek~H zA60-4L<3~Qr~v?UAr~bjeSK#yKQE}Wmp7A!k`j}*ua~2Xy8{3auvnAc;0E*|AC`M- z04W*JpVX!FO5G=6YmUHsu90Et>PG0InG@E3d7KSfu?$(Uv}GaskN~Bk_ajk>=WORv zX)eYgdaj=E6y~X@fC)jYcl~CX8N`;m=^EbbKDqxJG0@5#$%fIo*}2_h_e-&*?81FA zMw_3@uxckRs8VFK_Uwp-tT)E4iez?_|Ls*>Ue8TM$m6Z=vg1(CU`6EhsO}BF6{?^e!*0#+gFX6@)%6&YSWLrJj;JA@hCP#Bn9u^l7 zo)oW03M3AX(&YG;1GqP=7h-(^t<7xKg$8WX{g#z45&> zD!+L)Kh(T_nwso~q7;*zx}gpL;PD0kfEEA%S9JhDR2Bf>nGFCSI{^T}U;u!s8_gdt z007`5)lgP24p=<0#P>GY&i&3BnL7NepC=M$M1B)5WA3p;+}yr9K$rDcx$+fE5Pw?8gU4*s1&e`-6Vj*RaY{agRgT)#bj z+Syu$_MAwq2CwG)dpaM@g(4otwo_rRL!RbN?xpja8XDpbi&JFp%x!Pr{c=oVVucny z8<@l_F-fD(z=}A6zVq{aYamHSucRbCf-xJ^Lx&2i+h?;?-%zO?O`}Rg2Vq^IEsRa; zA7WQYE-LAV+t@+ZK|nbWvc5qOb+HMI2{sJ;_f?GuIXge^H|kDhJ!WHI(w zk&)Za|HM&C{pnA`xoVwdr$0jGdYRlcfs(HX<9kj^Yirf_*Zy*el+3=9@aKUmemfkr z;QbZ%g(Iu3fQijBZIHz)!Lns=d{@*Cb-vt~zqDiiFt>r%?*;ziSsY1=4mW`^U6qE@EQ!~(Na}w(TB)711z!xtfZi% z47pj4kwj=zc_-8E7Q$GrN0pUJPG?`8#7vM;`WlAE_6py;3H3R;rJ(EZ>i&vfm&`2f zl4x;$y|(z(tZrW#rjZPt4$o#9OJm1k6-11^$bkBdlg+MvQiz33*KLvb0wSbZFC>P4 z4fWU|e`MxWsql$yapobmnAESSvT3QV>>rfvF0)iFZyL{ZRcPM_S z`2dBbXij#u)Y~#BczT$9*0O!?^f?iFkr9}f84KpH2(e`J?UU}aw!{eBV^dY!G zs&?^B2?>~M`iurGQhDVifR2`=(Kne#c>#it4_5sA)BkTAM_xru&EVIaf8O6$uhKH0 zrmiuPCM{ULvNvlHyZ2ffIiF@@^y|sq&smtTscp34g4KYEiIh5Hq_U#{u^if8!WctL z^9-^NkB)TY$(7*>Y-*ofc}W_5lJ9P{g^hxUnzy`r^WmF1Ibv)~5T;ltZJ#+&e zt=@ngA0L~1H8r679q@Xvul2I+Qe>(ZV$DS%go&;!S|x z8(ff-e3ivMTD{?a<0ZowE?a(!Z_|9{BcsL$#&P6CONEFuHkPiSeF_;FM?+`OE@OoV zb+@Qmj?v)UffRKeCPwygKZ#VuJLU}cOfK?&oZXl)YaCa@9>QTz^5oMJZItCe-(vcr zP_36tL{b4{uYU>-C9aBX+JFdtks1PYu-fD5BCT4jFzCrXR<%zn@x+i3Lap=M% ze%kIpBspKaSm}BPwSRh1JQxk@4!q9B1w_73Of_FwL_}nJADtuQ^3}&I7Iufk3Te>K zQ{3(EK-FS){|fb}k;;eg!8fx1$(?NuBNOQqZ~@3u{60FV5E7#G6zi@_a3m<#N>pde zCs<7O{!kd;c)a{gA?{VzCP*h(w{b`Kr8|7#d#GGqJYWgr#{#0u{D570fTUq|d)szi zILyuCQjWO2n9_UweveJKPGSKvEwVkU`x;uc3r!czpV&x*!cFi8BbYM$A$1ZE{Z$WE zcm1mdnKP|S-k(2z`sAgIKytdR`K_&qQsXW?o^W8|a=GR`uZ;2|z^1*42rj1Hi)qI4 zH10c?{isv3M4HkbnuL3ZV7EFK9G3DSrG^F@SA5gwyC;#AfdGZrHu~av}T5*Xx<=U_O+mxi9`*{g{DQzU7hdz=N6SNMzFKyWU?C zaP{>o%9I>WY;DVbX~1w<4vTXdzP|TF@3@3UDp(lbC-}84Bq|X~^%A5;_`K6VB>!c% z1vnuTFb`@5_um0#)-t;+z%@`YNe%X77%=Joc3MLTf`A}XsyTW2`G@ZuH=|QRg~`Qse)MpSD$5?s*0`NC2|JB7YmM9* zT!b3lSC;t}6FE|YagXfdG#oI(MIR{CJ|@OU?Y#d|Tl)eCjv=P|6XuAa03gF|VYVOn zUT(8;z<{_GV6Ser8IpYQ;@C=LHYOBb;dY`}ZAQW;ggnWts3==fRo9h?;|^~PMaLLN zB8r^^5`%&t1fIkjKun6atHI($P-_Bpj1hNgqXZlr=?lCLfR{P|XgGA1Al-IirgsN= zrj&vt?oW91vFfCd{!CAPaXK>luh8n>>;3(GzY5hM@ZCK!Qd#uP@Wldq*jKwm*hl%~ zWP`@`^Gc_sl+c@>~jdV=mU1xdNhyBiD9=D3yl~m?P*b|!X-6V!kTN2TJ!oM4;;Y1qfS}&T;Kji{! zVW9J!0U=cPZyK<{>Y06de$LXA&ku*L_jyDeh>+sVpH2jcM^gI2on*xE2M^}BF}!ke ztA-RU9L2d53|qyOUoaxHFE-azLg5Ud9<~vQ-mp#O?Y+Krm3EL+GFQb=v-hR74cmCE z6*c&$f^PNuwzar$Ll_PzXg*o$McBs?P{T$@b)?eG?d0bkWfKE6x$xX5Pj^U)wup`6 z*~VZ%4gKbU<-A77q61-H!-nhVCE*R$1qdYRr#>X@S5SwoWQ-v~HshzFDVhkoIG-gM z>Scr$DaJ$vol`N9OkT`Z!=R7OIoPE`-9d#ZEM!WWdnh*)WmK+9$TKE*7LiJi0Ch~j zL_y?1<1|TnX~C-c%I6y8^`Wi_0>A>*giF>zX~$NbXvSQ7+M`m7WBR(HY=I2SL|F4W zC^fpyF@)22EWu#wbXDH8fOjsm?-$BEoa1oZOfE8$>D2+LcF~Q*=^;Bo8x_AkaJSf% zNu<2$k~2qEE=e0fxs#$C6Yqy_(P_p2tFGH4-jv zXDn}1jgG?k!KaG8Hp0$IfFm4GogZ@NvJ^BjpteiQB>k$#;x|MXVfPrCbZMY^EGH!V znwakdhq+`7yTE|Z;kks%4>9Cv6Cx2tz6}cIU5`^nUt|+x`axE!lBV`O&rS;PmD*;c z#2}KUgs_)y%*9yxk5%iv4k3q*sxrH8NM736zm7MpL19xKMjTk28)RZq!bk!t2?8TIes)=%>>diHAY6=$yoi>*(IRWO$-i^`s4RcX#(| zB<%hqD(f|0k2cpj@`@g~nh55IlHjQRf}P|VK%_rQz(b>h?JPBJF@k%|5)qkd4+E}E z7upP~4^Z4%8X@}HN@SfE-%{7VyEG)WO3C-k7hH0#RCPTYhy%tiXHzH|AG>o}R1au; zVR%W;!a>+Ax<8|~n#7&K4uEePepl$MYSwW%-7?pUmr!EBw>nW>m;?~6_Y zzTFzolvDa`%4FLx2Nhw8+=ahNRDGSV6fhp1>MlEpt4vO^4xe<}5#%oa@(x*+Tb9pG z{rUY>OLHj(9$I zTTxVG93M*mS5LyOQIjYD7mAk<@1dWj03QK~h>BWhiJO0G{O$*ws)$a@C|b$psa3aS z(kbAQK+c?3p#P*Tow)<4z?3-nEjy;i$HV+{?1q!kSQ~FkOa(g1f9FKrfec$^E)~mx z0)B^)BtqD+v55ggC*^}T5v4g%*F&uvKkr}{$vQju}rh3+1Tg&&{8`1b^>rzvnQ5tmI5+W{bgIn|?PuER5rXOA82N zPnGMLee|4%(BZ)2wDW=PA7}T{{ZT&RsLc7J=>c?FLD#~<;|F3u?6K z_%vB6VI<-SBQ!XzCRzCW@uR(i!}`(EyV6jG{lPFlYzv9Hw39K+)@rbHf7si>0G20nN*eiJGw?;LRt&ymGWnw))j);EciAg->n zrj{>7*1Z-U8pLmnsPzizmp49Fpexdp$#V;Tq)n6~qIpkFI5C_@X{V|oArWxT`D0Sqk4TVe=6f3UHe>M2}CuL1!5N$Gu8W$(rF1i9sM^Yh?UQEDW>FiQ6X)-=p zj|QK{9UmS7WDw4H&t^vcBNQ7Zp zNN1j@g%BWkxP_Z>h{!zQAbE!*PMmo_!+33*E~L}HX6(ANXz+ddG`9ETAqr3 zgK=JpRU8OIzbN}R| zg=6W76dr{Zm`uE2(lSBR3dPrZh%Ny)a|DqkB*?WNDu;QWa<{dk3ccf$v%W3zkvTUn z))3e={5?QXX={7?k_x&E6IqHh85|U)pm2UyMwmB_8GHq?eDQNvi@8R;{TIXfK!hbatY&@dCn8aO`*6!hvB4Z1cQjjq3_E_x+CYHTnYB6SkdT;S~ zjKS!BDiR*Ov@NDpP5uQjIy9^P9@hnaJq%HzE$DJ>B+`YoD>7lKXu6-ge*GU>>SWIQ z46saoI?c`v0}4I&;{}tst0)@6;=c(vigT84=~E*fR(-R(njYrD3!i^ z@E-hR6^TZS&I)I?3w*k}11SiqrFfr8cK40@9)GWq!O0o-@ij_~mDj{%_A7gU?u@TG zI@)dyxRwX;Jzn&|eST_w%?BezE`xGA;u~hP`^j>H!k}x5e>&d|{|{E?Um%)w_4pE& zt`(S#6_2s@&R&fETKnagC&|QbmRj*8B8HzMy3bItxgdtjjAEC&OAt%SbThY*7vY?( zOwatv_a50{oC6LWSMzsLA1Iaosej%(fJPJ0px0@uOZ1(!;paSwjNs4zTM^z``t~dl zW~{7Bpe0$$79^cKq_|hJB$DC6+>(1d?8BG2mGD3O#5|WJ#+b8IgPV$~r{8X(0}bd+ zm7h5yJCkx6lGmDqPb9xpsxeBRj5*)5wB4l4`-%u_nf(~LgAF+0Oy4&+=gqx3rTnBr zSTV0~DbFDSXZXm1!p>$7IzkAof5Gf8*t_ov=e0}Xe92@MTQPOM6D;jcJ-^x1)hF)h z*>danp)D92vApn*&k`YJ`Q$ke$Rw9;Bj#V7QirbkAUdL1A_jN0}2ut*T-0LvxI5l#+mQSC= zK+*lujXs;p<=klWnHNMdIXa73K=zr@`b%CHn*SNIT~Fx|iOXyHg`j=1_VMvko3*_s zosfy!4l%)X_4?-E(FqpeIuiM*5e|gRMIm-~9r*0-_Wc0ux=Vtp(s?7vkoTx)it^G~ z64e=Hh>*hH?(akKktC=1>I(#2&Vw|7u7=Lsp=M$z(h3-{_c6PyIYvV|BRxG_}i;;Kfw59zW`Sbfw zXRY!5pW2&%blx-KIBbbRL2z)d9dc7>E=iF`vwe@&cGBoAza!h{1Z!11asbAtWi zON*Sj*1<#?1l;lXd||j~dXOp0FJT{2zG-(>S}Q@q$oYJ6Mq#`C?9VDO=u~xuF2NKO z6m}dG&u7)*X)d#RjKec!huuHwcFAIYb8KEAPoiB2J`BNjC%S~;F|;wx?~l?XXMNFw zMGS~ss&y6*`jG8~muM|egDZ;=3#}eG`YeQ0M1No^83_u!r@u%h3zV?A(5&49mp-Ej zTNBtv)qF0pAH=x;uaS^TqQ#A|=;&7A(v%auVOSvyTMxxdM)&nTjoLeSQ$))VNw9tO z5t2bYBj9VOl^+o$;Y>4@!J)Tk+8O1CO^dnU+NS!vy^y*3KF%sXqCM(L!2Nru77hZ_ z`}xIkua@^dLFp(NOKHPbeww4n_rSYK)AwPQ;0Vop;IV64bCJm6OvRk=|Adt~>zJd{ z{w5OY24lowDt200)NAl)q<+{#+kwF^!OfA+$X?Cc5GPMX6VjcEbynFuikP2VBzo$ zCQ9!!qP%4YXd0IE&plZF>waIwQlsTBf@b`M36nxQG!(6Tu%6FE?Z3Kpc)TXOC&}A| zu-@!i|D<#Nn_BXMo4b*Wv`dJGv`~)LvXGjM0rBgAO28K@Ru(&iwtm9*8>85)9dap{ zs#8bb0ef~YAwXkHf(;`IhN>@MW1H#SxPmCRK3|qFpLpPWKe3#)MI6 zua@KKK%nPinC*GxSLh{#j6fPv10Nqjh23sh8T3|FX_3NsuoKfRG!>(_juO*0B9eq- z_WXjhRs~&hLq>XI&duq3w%$c*7AR6eLdfGDr3-F|%xfDdA3~p2@(5#I6r`NmgRUfU z3bqxn@Cr|!m(VB<0!nG>x+Mh4 zn0cq+H4U;Hgco2|O=wZymFW#>kaQNOj?okFdwz7EnX>gP$6&*=hnNzL4@NPyV$}lM zQ{@o@LNo)7{PMhL0rTUNc2aS-U@-W{46YHEMlU>$)lvQr(4a@ME3I3_D!fFLbeI)a zDS1@?6CUXnOtK`=Ke0`I%u7fJ2W(arDi~?5NNO9pgw5PL;(hLmN4A=Un#SrkL1w}D z*;x7&xKzR-slUZaMbq{|)1yE}!!Id5ZcFcG+6doy%8Sau$9g`>-7QH;)uh%lD@Q-C z&uDnB8?Qk?4JO@(l8ESK8`YeYTj*^l>bN8whNQ=WsI!^XVN-A1ze{%Sg@5QR6y4QR zVtFoF~)KEaFV73kOcL8ymqye+G($bne zgjf>&K@UB(*vR3-R``}u^l@)GpZqp9N1ATEZnQ*mS)bFLH8Y8;X;H;DCyP((hi~q( zE%Gz4EaFocs7{q-Nv>qiWb(gGmf5oJkkKS7sNQ?o>q8{)>4%H3nXs=R6(Wf6k%V~?Dd6jb-lC)vfU z&Z>0AX|1)eEG`6nQDwmuFaz&<9_H!~Fm5~cV%AUM$#I8p@S!vNk);6zNzuT~1+@mm zpKcw~`#2ZcY5Jk2zNCIk}I?Kry*s8dG^4VrQfEY15 z)x>aLfZ@u;5aiB6$cVV)TlDPx&y9Z{nX51HP{jIJ?e~w;Dc(0E-doo^g#Kq!C4;7| zOOBbpqZd_`j5>tn$?@DPVVI)!e&cVaS+)CBz~g;~hWGpm#TBq#mSfLHSNjSPxB5?H zv}QsUN4{@G>g6a|xdLy~hXJxi-eCW$e_2hCoGX91OGQN1=fK6+?*i4PT8!iUsljK9 zavUM&Q{-Used@2OIxyj2TM9~Mrc_kWLxEpsSjBEgY`Vr->XfN~Ow#JnWy;FP>h3qW z`FO-7m|HpIP3HJ^m-rBs>0Q*VKTI6A(UP4eDiuL)?JP<_tvzp(Cjcf_H<}a3EJ-M zeRL?rh&pE5v)J3c&es_EhY8iymKH~Pnoa{~(TUj{wXLeMB`w`D!4goCG3Naq* z!PN*Gx;6Fz21-5vV0Nx%9M6{*+k1Yz9C|R%<;;HLl5Tosy;aXf4i@`bS*hS-g!9FU z?FeMvvU4dc5R5PS$7JD{`l6PD;`G7`rE3 zD*v@p4<{W`pO#5#9~7nWpj+B`A<(w=@O{KR!rwf?OXt%YyWg~ZBUyPs_K;ao8lG}1-m`}iUkp@Y29}Vo`vSUqD2Y2e z4t&nPt`k3vSm7DuVqBGFs_M6%pR9G!pxBE<_``_s7D6c|^p*7IOH`Mlpw3bQ9Z}*2 zyTlkTNuEGp-$-ktxq69SVcYqCCP<9@WE#>D{gf{xE58g;c^{>+zV@S1&g`6ge5E?d z^(_2`Gdr^L>R8LGtxBq*WlL8+Z@|pRh%}%D3N=oNm^HucUleX>*xk>Y^sB5ThIe})Y&T@FoL$+VA)drGpzc=SG3+x=z}VPGND zo2_j`@T;k1Yyo};YW>j%j`hdG!_zF+@ng#p{?!J^6X)Srk)>ma;fv~OdAPrZJT&{i z#mP;*b>Ch&`)_n5;65`$2A;havtyh<3?a$I%XzFITvNw`3sGTYJz+cn+8aH+8g93f z865&lG@vA7lE)20yGLV-ENb*KYvE}}ZAyEh19z^gBcdS5m5KDMEK+Uidf6C0oiyMq zE!IbSr2#Ucqj@`qj}eJ7kQid|S>T%&8)K;6hHuqmMfcE&khD8aM&{8miC6YHFa3BQ zYc5dI+A3B*K5hFSd1QUngPGh}^p#>YCCx_&6PUB{kEds5)=T94A*QG-pY%A;<)bv~ zdpFl^ND}4wmeHS-qAw9z@wJiJfc3u~WU1Tmb?j zBK}6poo!1tkitUShBS`kPTEV24)}lPqN~ciRn2cu z=}m0dU{d!4d5wJ+=x>d;Iz?_Y(vi+-4n(Q-W50hF!`?tf{ZVLCnO9$tW(zss<(;4s za;Bwe`gKAIe8Ti%PwHq*_Tw2*zigxeA08FwYApkw9YIa!Ch7NxR^JUx+PI6|sLP71H~` zji;)V=Wy9cB+yKjy+_&b!xFq1%x800xEErSLL&)z0}&q<&MaciOe_X|C`q5 zh*C>Zslb{d7k6KRW9Qyw>F?bA)lq-uB39(h=UIl+{$C}UuNBDQ`gFUTy5o)i&|+>Y%lGroW#oZXY=WGYI8nWD zS;=-3G?tM=qd_l3G0d#zHG3+SPj1rqXhj2dj}uVYw}7+Woo|w^&vO^{ zv7(_wCstm%YZb*^&whclv9UG##x@K{p;Sxn z1G|(Um`_2nLDXL??mx}a&52X*uD|An*rsM2-@zIi8_y^x)K-pvNZeory1C;bNJ@%j zhgm_rJKg~4L{Ka1*6gHiJ_c8gh6E-93K+7~468fPZiP;t&6tfAy6>cMz8%@vy6o70 z5OK6+s@{PXt6euM#dy~L*HbS(z6&rDEPa2Ug|fBq>?x#;&~yFhN)nYw2+&Z`RjyUE G{_uZ13i}}d literal 0 HcmV?d00001 diff --git a/source/engine/thirdparty/Chipmunk2D/doc/images/hash_too_big.png b/source/engine/thirdparty/Chipmunk2D/doc/images/hash_too_big.png new file mode 100644 index 0000000000000000000000000000000000000000..434e3d7c4ad3265caa205f1a3696f18927e82bb5 GIT binary patch literal 10756 zcmXY1bzGC*_eW3=5Jc$`loF&v1V%`+(J(rsJ0zq*8b)_Fqq}o-r=z<;N^*eYZ~i{t zKej!uXV1OoectDN&bjw)p^EZSI9Oy@C@3g6GScG8C@9Z(k=KAc7@NygWhU&V$ouiH!{gNm;p00QmmDoL zMzs9H_j^At4F?ISy=I7oq;aUrc~mL$4@LURh~+x>lZHpUEaPaZ;kY)ulQ)SP~!-1RLcx97#^xtM&y1d7lF1Nh0>C&f^3 z31kPVz)*AdZe@Y{>#B0Kx>Bm&jzngxC>XvI-E80wSBteM#J_UZ^&LE6Uky%e&T-#}reBVgUf zCD!kzYRb!#`6Y4-Sn|VcyTq) zY`k4$98&0+QMopPu$rrArWN~9LJ|6tmn9i0g@&^**Xi0%?n~+eLr`72cCX=s5`2ge z9hm)GLe#5+j%9!lJI~)X#phuhH(-v;GiB{zNuJ&YRjZVo`m1k%t@_h8iiqDW@pIq8 z^-+X=&8AD9UJom0bVN#`gqyV;#mg1F#Y5FDxph(6i=x{it-K&2pEz}IyZ^%ZxO&!4 zr9acS`PL2#4E8^oqf|AHItx!)g!krTef4~4*w&AB7H;M#;^`;QSaK8X)`pJ1fSgk( zlQ{RyxoZUNB+10h&lHmVJnQZ1NOezh>tb(<ugdDEdH!I zau59RzZ-gy|GSa>?}>?9<=G?$&gio;HWM$#tt}K`0AP7;Zfg2^eo^`NA1-o~ z^Cv>Q8$vEEZhhxaP||@^l!pHBt#W@bN~Ofe0X$akF7*s{ToKc=p6`HLzw(;oKlG=Y zT?#RYp9Qt#KSnapW4LUoP&dc^gMb7`93nMc*xdYgFotGRB3Y5$=C(x7BpwHwpAAQq4RTAKDUI4>M-y`j7*Nk=Az(zv?HQIc5(C&Tsu$ z`69Qg8qn2m$XC+egBbzczjyY;bIH4_f+5KYe~tQDIPoSW$p}ptL-3wpZ}|LJ*%30y zx+%H%cpT8L-7P_4!11%Uz7^?H+k3zbCUN}D!Y=?Lr=v)>GH2nYdn~GS5Ki&h{#a%B zX6?=Y9Kz_gI#Y3mA2_YSybMuf-tNwXzLOgjWaBL{`~p$W`8OB6-nN;VWN~a3+S0v3 z`|f3dxjf^~fbGJHh4jgD-!~$D6Q2JCv+Y16kcC9_UPoQHVmtqJZA>f~myzO$lLlU#m1SKO1 zW81IGDRN)3G#y}4Tl70P179e;`TC6ZbLKy2_biaHAC0Z3WE0OK!de?fH*pmqA8MH} zspUvCQg0>v8GrWr@gT#ZXOdq~kVq^Le%CS#{**FRQNj9z66;-~>iuG0jXBCFUEbsB zh|l}}%Rj|g07~|tyWG?aGirr;j*z)7M7i%Qw1n=akntzM$T&muC5e1t95NzN-0v<$ zo~?h2{!;-@-`(9^RIiw1v7TgZ6<)0+bZK%&SX#3ZgyzQW%`T(`dd_tDWBf~_kjm)8B5;;7Ax-#9@Qn($Jild`K9;lS$la0?-$R~TAQB91FwmI!9zd8^; z{vqJqR*fI=$K{Tlk{lQ>{!h3)k=Mynrv5p);Hj2^ei_`2(HkyhG55yS!`IEtKBHp~ z`v+QOTCL;GJpO0Rc+7{WII7}8sVSmn|0M4h#fQS z^HyR&;d8ScCIM9a1Cuusl0G2^*GfJ_Wy$N$VsVB;vCpIF@lN{AGSbu8q$^$_9XdY2Zvy=wWgS(We3#oBTAcGsrUYOV9J|A$x(A8;|$Q;!Y&dwyW^T7u(gHNBz3X<#F0D2akg zowv2mO~Rp!OW$GCFtSmPs)Q7+bbr@A*5ELIBOT9y@X9kYw~>~heMf4#T)PoDccs*C zemX$H2Oi2p{`IXwn?Af>=&;i1OYj~~7W2`)z04Nd#gUJSfNgX%I_9hHO16E%a#mEp zV0_5qsi4|ZwD&iA1!xv#J5*k^-2K%*HZEPoeH0F;ArKI-$@TEo+W-R9D+=9-w!9;zTP zgAYllPC0v2IFkcpRk=FL5tw&tOO;r8L*4S}Ula@m;`nT?lajkT+Lr-;B_Ii#B5WQv z&9FLkQ$T&$asu^SR!(1*#vRZGHksz}_k3p?-HHPvz189_tyIr@q><0fKtdI@xP_DnaWR#>QK zT&KlMO8+RB+*Y|g!7xz{4SM(omgEdxt{=TIug&#?PI`-I%XJ&_+b7umjbSY#P`|a*x9Py zQ`ZL&=y`W{_s^XD#xK{Lf`XvfEZ0=x3~ejCC?NfF-?Oz|`GKO=8q>li*p4Dsz5r?~ zESB$9Tvu^l<)3)W0c9Vt)&dDeYI5w=X?juLDbX}eSfZzv+K!OU4dQSPn>>1V z0jDKK-OowDh$5;emZdUEDyRuF4e#84V=r$?tpfI@x*4@j4** z1LRPipXcg6Vvu*Z@NSy_M1DX!ueO+`s8=Ch62yFvVs zU?-3LJV}=CIgrAtj4Y%~$72r7e{}r5VW%G9ovwGEIdsX605|VQDbcDcNnt{m{6#)4 z2age0=1|!$H}T%FE5$*nFTj=*{Z54`dQ8NY2WC$~l9B;o}E zvx{mxunG3+x{UE50s5Keu@~)pADHN+$*mXA4ng?1$OVvW)Gve33c8ltiTQz(GBUzY zAVFYpyfVSGsF)a}2fSciIH3UPS4rPwBq|aGs=-eKku4@`AWww2oa8iwIw)n`?bo+6 z)pXjU4=E-?gM-lyvadEwwaXQvB1Q&_f$G%G-Q8tuays`kQ2@h$Tv>ImTp}VO2th)S zJr$KR*#-k83NwLx`j;-`GG=5hx2WW6t6+t;#;N#5@I0e7!F88E6wg+~0T>kq0`?K$ zA}M2g#gvy66t*eLM#cdMU9tY0Hc2^5+?@etS4pUV9}Xx)3^mvpd0B{Vz2WfljvfBJ zP~Ps+HZP+(S~E!U#VWiagzJ6m0McAk2+z;$LkEPY^eNu;hWcVng|k``M7e*QiCuc; z`Lab20?HBLbF&fr2HEZJt`Ug+r2TW9&Va|nQO4oWRV77^bpnHkv9X%eud_*#1W^sV z_B_Nte8lOMxs=VN6kn=!&cAp9oEA@pQ9ncEZuF}R&Z%jWM?*@2;tT3bqY==Uet)gv zOcwsHZ;MI|2>n}xnXIR3;O{7w8oFWWkETWjm;;1C97S2ds(Hc0Hb&zl11kRdB?hii zJf6*XUYUzHwdNikgNrcbrz=&ue1fs5?3Rav|(M$j$I-{?AbG zAIJIL0`GP9$J=hj!zaMa6rSSz*oB^HM`!{%-yF#`7EF~#qe?(bkSnzk;ny;H z@s#27v_W_Z8DokL+!O8B+>ZGNI$jFUe-0aT$b0Wzc1eXoy8*kshev~3M!Ff1CE#3q zY&V9o+#?}^*o0V>e(o#PFJ1PA>bmcMc zBCfV&ynGg+f^T+eVsHUQ1_Af=c;~N-!lFgM)B5MhnbbsjN5eI1tGkAU`}FeptaOJK zNWQZ?)xyy-Evx>J;+9#bZO3oP3DS7`Eq&)v!zjnt9KWL5ipuj3u^iw`RLmxcy@@O{ zFN=WFZ>fqZH97uAh33)^xNU{qhtm}q?WKny6-APNZIs`_PW1Oo^s>k%IrD2&_&d*? z@8%mI{SLKsDg5k%kY}1~WVnE%Uo27{7wSjgs;`fy2p#Zn=n(m2%9uTuAJ_KW);gHU{{-?@@v~q2T9Z>?dBwB zjinh+Q|W(=;`W!UW{aep=x&u`lVgc=>hpb(0_*H?W*i%e!B@7G$S5H`u|D~m(Dw?m zYNL0BGiStE%V=_>zEikrRHnLdXsS_zL@9IM+_J|+$KzkS*bt8@5l=HS1gnB^x4C*g z^B~|gd&#h-HEPhsWvwHFL^$M0xhjAK;&q>({$$OC2=y7Y^)EX{^3p(~k|1?!u~IKh-D3?K@CnLLFG*DMxkHn7 zn{I&nCFA&9%L-g&l8}neejViy)Z-_`=ez#r0K=i)hH-f%f18%YPHjj-bG@;yLAMy#w0s7?%YMN5?-T+WRD~YBFxT$LS8R}9kj*t6Zj4H=Q*wE33?jtmHYpVx07Z@#w6k(K>CdIb!(>h+K-7I?*Z|n}6V* zM&~(eg@vw~mSxRv(t7Q;-dIeGkN4Aj{hN@DDxJKybRWxsRLdA5CnqPKAV*Hg(T%hT zA}TDG%T(dhWVJVtLb^U*sjL$0=DUl+syYrGJiFbH(#JzXz}y-6g4PvPP#- zt<3GaiALS2#@x!{3}sG9f?;HG8Q-k5x)@miwE^FsW(t`WDQ<;Jhp*?5=2yOk9Uk_#>7@7uHZs#2AydvB z(562LW`6Xepje4&OK7(Y^!>*9?OVZ7!(?%8WOz&Nq{tx+w}@Y)Dp0AUsxX#j)~6pg z6UN!=>trawKcXt0sdzbZ3$NNTApE5zk^gDiTI`DFBJc)=iMyp+o|$b3#(!&W0qe*8 zJ^B+!<79yX+927&Vv)kw5GsnAapg0wD6!)zpqQ;JcC4*laws`a>+T@PkKL&-lMkFBt#nB@AAB*9%% z@RwRVN%ekJ@y_3c1*PVyQPhU=02;FLE9a#Z)rSl?NPBMK=9@#Ia)^k!7dWa#)SH#{ za`;n>Ev|;e+@u$&8<&iXM&|y=^{ynTLWajNVPJdxNPDg6!hQ9hzHz2XY?hUiXtSeH zjM_vod@dDdc51E!Vn$Li-54Z#69AbW_DqLhx$T~O2Os2b^nLEs$>wFAcA#nmpJN+> z|4`Tn=Sgenat%uS9_KNT@8RJtT{4-mHN^N8kIgqPi}*8R(2K;#KdKw~gR(oVd3uRV zt#h?Yq}VquWb_^EW{Pt26YVj2Vkyco6(eQf{BVPRV=kEK?)InIbCk&s1z^Qp$`!03 zF8~Lf-kD3!A>N7c%=J*M7+PlWHyn#r;j&55;F3#h`k$>1DX-^gZeV^~KtbwSKYkDt;uUZ;Xnv^M*HXtSfST z##r3csE0M@=5QAdrY4%eNj$Fqn0Q&3pB6n^t`v;6?K-S_`r`C^5?jFK(aYfdUN=cbXVUu7(DnBL~L_ZE(~9tvI0yo1j@?DmzOe@fa` z_pUqPs0;9Hr_~o!%Ws!$pPIULON{1za*K7FWe72NFe}>#g`Vop92cgiIJ5#K{E#*5 zncfhbkB^UM?`S(~z4ig|DI%UDM1411z`$cKE%t@2OWl{t6mxO7avM+PWfAiHB=fOy z0^L9~%iVF@@h1-x0<8H3BnP+;hOo?3m%>zp6C*AEZL*(v-YDMfE%>oKm^ffTer<|m zg;w0>rVH9$7WFENyX*w0>PFt`x4Er@Pip&^aj-#PPhCOn7Doiu7A8qd-P#%)b*N8T z(t@J*o4NMao8a$6VxrcspDL~VlTZg-2~m=&wqDh8zir?~(KR!ESGgQ;z}HEz#ly-P zu`@vV8RPZkLPOejqVo)Cd9i?#yOoLOA-_v>eP5U+O3rTaz*s4H8u$^_b^MiX)rF51 z#5UZ#A+@pSz1TvC=eXXjPCIvEY#6eM!}8UsCW%3zQ2u_Eo$?N$2h@fpfMuyh6^tP2 zCU@3M*(bZ5$LOq3s$Khc_UY=A+(-)zHnnfC?{COkI#Y{F>tef^+n%XCq2jXctfj1i z!VhG1>|Vu#@V?(f@P4U`M~;K0V$UYsV_NN73yH1QRCkH1OsZoDiNpj=GR8zpsaPSh zc?MIJ$LVxyIZ)TAeEsCt&XfeEOFC`c$p-1#CxwbPw=OyS43VXjRUAW(iQJW~r9^`> z)zEfl?PTaL{iIdCo13Sh!Dw4D%4uoNw7`h9DG>2iD$cNTKp4^fYdcRYa$hsz-_=TK zbwzzw*f-Tm{djBjH*9ViTDlsf^U)=QfO#x+4v^6Yeair-+7b}2#^{zQMkT#T^ryTL z`G@|&{D;9)vg=Ld%OB#w1Bnnxe@x|tfIsn?WSblXMxgq3ebpuXE9v=onh98o?L8(Y z-&%Av0seFJ8bGUibuu**n)PKAXrMIx`1{g#&t~C4##{5+sce|4JK*UfJBTKkEn(ty z)VsS6yy_v-X|hpwe^j>3U-0pc>C92@k;BoxboOggNj&%#lpoa(qiiYY-=-E)RZ8t- zU1ag&W^ca6vYVbHpHAWg^?UAtz`Qx|xpbB1zx)k{Ye8y3V~Gtddig%O znoaorq}X<(*@mCCU1yS3ql@lM{=D5@u{W%OnWI+ z>D$d%?l_6;p$chs%t4WB?kBe!60be8{Ly9Tddd5#VdjX8jj%JAfwl8N#sk;fTBTm- z$(D;u;u41%6AFHb-S(Cf#4t3jd z`MUa#V`+yvuRR*n4+Vs+CKH($JlZ$}6{U@vq!q_kr|)$#$}D;>6F*MPFrkItJ%E0Z z{EeFisG6*eSLMcjwfr2Btk_L0*25gpXE4@q`6Fp&4wG9fK{Q+WE8zjO3H3&PnMkY;`?L-642y?-H9_^RKz&+V*p``Gdhr_Z~06#n~_ zl+>^37XmRV$+fHg)6>RLQ&t}_{O_5V661O2D*LeGWMUGZ(I5Q?HA~eG%D!B=SN0Ms zIe3WlM(heFEro3JA}bx;-u8Zwn*;Dh2BVzi@6W%DCZ{xe1*F8&g?J$&f7<$I1s(^F zX4M!nAc4mFzOjNxEtr;as2B({mJq$8V)_}Yv?A^5k z23G!tj9PaGm%m%7q-Btl@jb52EUxXbO$F6J7_r}0zj|Ksq=;6ef}Tu`OcQcQn~8IO zj|3;$onA9eOrgGs);QbPw?s)u`f;G1!#ERj;nn_U5Ik#l$921a_gBcPaA*T#NuFI# zlgPN39%S>|w+q^KXfF2as8wZVG}+S!kj!)c7M-m=$(m1}fTcn3QQm^jLVK%@z4cIw zJ1kQR5-E4B8o0bWA7811*SO35Mqpx=aq`*712f&u5S?0vPwv9jCWKy<-%9-p!J}Ez zWun#!vV5_XL=_IE@XCudqFv^K@M$vcFzzr{j- zT8w?*&1{qYV#owX>IUZk5=e3RqW+4n{H-o_$n{SKDt!A0EFhY`M#@&+@1763NPv`I z&r|>}l%5*i+jSe)kbnRFx;Sgq()sZ-qm1-2l-W&cGcxGlOae$W!fwLb`8@yAK2|{Y zN`zQX(sD3c^GWMkB^I$e_w;3~#SGS8RFv(>z(}sQ4iG0~)&y!6ezjqneCC@-QiVr%X)C?7zR)ALD7f5rOn zfi4A}51;%)N`;J9jDx!wLPrPeVO9F}9D1n!dOun*uoMekP+*)|=c4e+)b7LkHN}j% z^mQwx#qGNjc-X4sMEvrHn1~v*eTpxFX;kLA0?Yxyh)qUF!d2c+;Y?}3-7BbgDw zUSlUu3wk#YtFY-2sF7ZhBzzxSSw2@R*?o8!f!oqEtn7i}{SIDV6ud0qmOx)`>ALla zn+c6V+l3|OBA0tjhYO(@o1$_1)xT#VT2HmQ2yW!sQB3MhXJYRCWcgHLr?>Rs`}c)J zNnSYl*iH{?;?QXW9105GA+8gCTI=3yuxh!dx?l9pg@-;@Uu zOITGl9zNJ`=@%Qyfe{W9_Q;K|yj>?nxbXVooObXJwqQw}HZj{D#a$Gmo^N8G`oKGf zztyslzkyK!RqC`wdR0pwm+QLY>qdz)zf-2AgWVf~or#NpCoT`say(MQ4cu^}`~8;A zn&btR3cKak4v9o&MXUMc-qOOrd~ig735%!ce!0^}7m3za?8rmw5{VcR?bjXLWi~8e zg@l`Q=uXp2950osTxYsLqNMA5+PRac)a`aW?w5+7&2}O0+*~~8z>-Ggx8M}tNu-Z; z;n=&E{Bxk|jC}o-#bcVF^rbNO6XkdH<}iD8y@^gRjuJ_&PqmDx^cxCJY5DIWv8Dj? zfEG{Hy~Aak7e%*;`2cP6I64+I*^li-t~nZO8oU zW7(gtn1y*-RYrahx{WYL)J=I@ND3%3$7Abu;&n?0SDmL%Rp;7&SGu*@wq1Od!&l

g^dOBq_r34mv~fB=p`S`yk^-ovV>21j_R+Z0-Vs?+>_oW&$#$Fh2M*!p;WIpZ z*P`+r?6Fr4ssnv93To`_$q8nFV?Rwuw{%r`z@;SF+?V3O;R+xKFtr-c>E= z(MLvx%FW$gRJ^2PR~6yRMwxL-+o7tz#+Ew!ki=WVqI+p16uzDFNsE`n>3e<9JgtRw zhCXknc%n;~N3`K+-KFO|+{?@ub=}@4_&yYhym-Xjty3xu`HQ(brMvVTjV3=RU zt8IJ$hP(stL;GZR`t7wgDr>a^jQ}wo(=}dV;?!QB&(I~HAJ%Q#bx{nE|QvoG< z)Jk3VYc*FZKnI}0-6zYzy9CTGXhS^YS?f|zNER!V631~pt|{Z|gpHyy>brfe{0s36 z%2gZfRI~FswgB&Q+ng;HiNoVBf4R5{UAUwrWTm1;2QkYNZcZgq-b`V zU|l8J9n`Mh1S=+8(1?UNc`oiuDDMYcx3*39Gw*C*tN(DhS(tDO+0%K0t)MUFS7!{ymzTm|sK42d zr2u?8F-bgUN6e}L7mB!^)NOXC$~Cj{p_%7i4Z^REMe|tkq5TrW8!bM;u%yyH4c87e z(1B*$K6dTST3qboo4d;LrE(x>#;r=Bopt94EvV5+FiPa{CGtObC^8cA;uWIb{QeLB CouRk@ literal 0 HcmV?d00001 diff --git a/source/engine/thirdparty/Chipmunk2D/doc/images/hash_too_small.png b/source/engine/thirdparty/Chipmunk2D/doc/images/hash_too_small.png new file mode 100644 index 0000000000000000000000000000000000000000..ca9f8e992034d36f787103d5a69ab5f9d98448ef GIT binary patch literal 8771 zcmX9@cRbtQ_fEtf4KYf6NGP>x7NtgFHbz^cMX8EWtxZuo5__~(X|1AmYuBuqnpKqA zTkKt%Ao!)f?;r2+dfjuMd(XM&Jm=nXBlRBMXP~`73jhEZw2q;9mM>x$Sy`57}JeHW>MSSO@Wl|y}v7a4tpaaL6!H|w8o?17DRP{9d}U5iaS=lj9!HNqkMpqj;o z`%Mdsr{I zwY)x?f`mZ1n>?$SL#v;xuz->4%18!SiOgfJ+)YGhNg^Grgsj{5r#NQG>Zc3F#;oWZ z<^*_p|1MXYANGCyyd7*6V0a?Uxg-GFuGr4M7WopV|DaBpPZrZgHU+(P)Vua%t)-ePObpv zsi4_3uKF-_x&4u^DL8O>zR&X7&PBwV#ewU9Z@Vb273>#I*Sl102Lo3$+6ew|#d|lJ z2Gju8SaiF}pX9yrZ8cCJo|KmuRTV+k+}U1=0jRM3t>RC3k0&b^nZ#3=-!pC6y9qBi zyld5+UVNB%vpF|IM8i?ey>idLNP1>QhV6uNmf+}R`$E~O_DM!G;kCQ)-?4XA#eEgF z3n}? z=cnNNm^X?!Z*3|I2o&R;Rr9-XF&-qBf>|RC9smGNo&bP*765Qu1^|Sn007RZ0KjSk z03aCv09MD=DC%4U=TpvG4{R=!r!g!b>$Tc9RjBr(IRT|4h{C&zu zip0q7U4CI$qzc)M5U%@J-9EXPIIfqTA=C=>+Jdggk%Y;pv*30M(}suZkDZb($AczI z2ESfZn#u$o3!G1*8y;mUpG>>AH0(45Je<+?bk1y^2{;evAL530%gU$YF#dH)q3i53?VY>*l zb)s93=WLWTL_M_;ZwK{fPMkUf66V7<$I1fty9J;Dhkqsx<&wC?n+XdUN`8}5Q&8Wv z&q*T2qhn)ZBO_0YjSCFEeElk{i1X2H@IBgygfUpS+cCgelH<)S;X0VEGP%9HZ>Sinz#MQ8&fc@3nPC8 zssG$RJ;y7o%U>c96{UB#*29X`f+_~BHTomZlb0wpeg4vM}6|=%PUyORo=g-(kWj04hz^xyQM(M_)$ET~?NgywL(`e&sRqHI* zTiQ%>$cuoBhB143YE!anVq33kHu_DgVH|T5F@`DW zk4CdH2dt-lVm0(8OHSAL8M1r>eoJZR6^afA(W>ik1G4zX{UK4EVQeGIe<<&ut%hmW0gd zm(yd~2ydk!I|4!LKBwXMQpNGPd2N#yKOU^by*1l%Y@Q+w5F+9qdd2Qs1aT%e9l%zJ zXrRl9hO&1bi8(!ZGvU7!=BBb#^WSeTzkqjG*HCfZ4WxN7+pzK4&Q8HH)G|FrQo&CN z?pT%)+rt~T;on?DLL?8yl0EJ?J!P*kZFMgRDJQnQ={LLV+LCI3n%xj3`aEt?sgTRu z**LoaqWJ^5bmHl^0Lt{np(E^^PmQ&0x{{@`#nZq5{Mql-hI+K{Tj3McOlp?u`C_G8gIyF%s}U->%IOD=8^)nyPUs)K?o=`Q$ar!OfkKoD8G)K5xe7>!wJ(IP0tI zHmg2VH!qzYJoTnqVWUD{c%!m#-%QG*>H#j-V#y^+V3H-^!>XFYV!Mrc2REIIp!~1D zCfA3Ad!-Y9{nEzR%+z}Vw7k6TBCKpvkX(SThmYIwT%#unDPRUnt;6^fSLab%D*~pR z9cUr?d}ni2`QXaH`x4o|RuR0Ik|TZsSUquq`hE*=9l9BAW>%l}*A9eS=`*K~V-#NL zOADv}xKN^h2~Y|q#PXdkmo-~RLS0_gb?`j1*u*Za0cFe6)e<$ahP*jj1y=Tm~gw!`Pf?V^$4o}1)IjW7^9O#Ml zWi6LyC%-=HQSiT@>r0ns?)l!%yjFQtTVqR8%yn?o-JgFCoq2SYvHB9iggv0j-T|YY z)q6y$vQf{=ONR7beMl6wNfr@lnAV1Kx$>2-N4UDt)~qb`TQoJVo>F%}T9i?jh}=Vr z2TuVMWqGlX(QF~XKE9&tk~og4U6^ud=`dHF9{R+Zs1!NYx-ws;C?#bzjFqh=e^R#N zql`#i91{qGqxer$>kIzI@b91{e9<=kJMLjxQI0V_=tyhKBgi6~r?PC8DdF^B+7QWw zuf|_$zqb4_vgwzRc@x4H3C}Vjvk9J^86aPO*){uoQ4_W;-aE#gg?%9J78pmtyfme3 zK5!R}=V;q$Z|#3=8NtLOEY7w;C>lFaB-u+I9Uw&j(eAKm`T5U}IG8FoIz}j8Os$@;gwdOJs@#)Zr5IWHK6v z83QOnCS^G}nEBMJxf!$RJT}ww!w-gR%CmM&Z(r4+tgUmB>F8p>cpv3N2&6M|0Zi18 zeX})=ZD_fiuSp-U;J%K-p)i^0{bd#O!B9_@`}E}vweG9GpM4JD?|iK*s7S6Af<)E1my9s2_(> zFFh=M-gLu9jMMBV8CVeZ2_C2{1e~R%O(!YQjNpq948+}`EM#{$H=MCmsa01!=PLWYrT zEQWTTXns=4h{E?lBcyx==Rc7PXc`FqSuG4>NqW=sLA1y0mD(c6J0r8J3>*vBE6;F} zrut$*30Su(lN0BNo&pLcz)@BHhXIU z6$^wFW;oT9X;@{NO8n<ujr*p0!O0}1c1iBZuUCnpU#v;)ZZ{zSA$7pO(sVBn z)91$viRM@Fg{#ojKhdi$el88l|MJfo5E4tzVP->}ykkG)qM|%Pm=i!y_Z#|f; zb};T<`8iCag^~O2AFdCTk@g**)xu?6X5Z?OKi=zFUJk*wBqe=Xie^&%XTaD-nW>-m z)GrY{7eL;YY~l}eMXft)*ySm0ikb<9juBXH-ZJ-7vEc`Y~v!E1C{-(3I7~qyilBj2uvxWCjGeZ8BaHmVn|8{M~b!Lw2dCDOq6O-o`!u zpqNC7)8z)_{l|GU5QzD;b(^{E^Bz#K-=d8)iyMJi-@iYNcrQFi(P{Xxi^(v1oBRit zkPxJ4D(N{kE*&Cx`yXV5zC|kmlqg2%h*Z(o4d+5cS5R1}fm*p}ejbIrq!T&=GwN$i zSLW*Z1NsjRs4tmT!G&W2cLFgl`cU(N{{a-^$Z*1t*J|KsV19BuyBOpjXpTPgsv@Ts zs#owXFX+7Q?i{WL8%xJ-vPTu6Z#Qe(YVXG?x;f~!x6tuzqH-+LztZF%y8FAc?0%^0 z2u-vS#tnRvRRYmIR7_s8y>ZL7$@EOezD&afG*yUy$QJ+4(0iMaNJh^~jG9HCBI6Q} zo^k&^MM#RSwk#$suSuYKwRT_hDeR|~F(>FSU$6YNf!>D; zZgZ(Kb@J|$41G6(eBx6}b_aBqgHxt#v+60*^T?4KFv#VjcGl}AT{P^Qu)_G#U@gGh z`(I>1cvaL1Bq|b~LX%;Dx5t91!1pFnlw4<69q5re;J%3_zq_GEQ9Yz7XOcLl3rcPO zT`E)GOMp7|I<)I?@ELkAo!+Hx{Qs9Cf;@f!Ot@=S;`r3^I@=L3==+iWD9Gp}T)tgr zQX%^HKM=x^I$wm_6?WGV;>q6>LmjVH{OSwKi%URS91o;D70!sNe}Dyk5|aQ6GecyH zgxUTr-uP>)!13`ts@5UUhUkn8<-pV4Mg_HJ1kj3RfaD4|WHs#`&9x8v7&YB(bPkR* z%-mOfi*y1g^pMJ9GMQnk$ob*7&ImXz=2?z1oCp+U)~B9Ii@tJnzqN7KV5gaMgm^My z``Qf;E zTZnm>>{}H{d8eD}7GR7*=T1NK{Y!wtdxzoG6nK`T9*Q1MC6Xy={kPFnB4iCI&rKo> zGCrbp*4MB0LOqQ4ga3IO6V0fJ^hUJG6?U*4XU%1PU75SU+S@T*sW}eq|94-I%jI&N z2%Y8Z+?ynwQP3%3u@ki}nXJrhKKN+j&%%FES-UjWm3@VvIcpEWD*joG%Tn&2WK1=e zGwy!>R+L5ZpM&f=l^;CA5rImoBOrz234{zU_yv_sO5O|I0^<4K~vY zfK!lfNECM4ubvg+GD@?By#e~&?R;D7KcRm>>U=+CAm9*q*8Oo`TqCidU)N-v+?I|a zn+k#aC6g8@8i@H6Zsva;9J|D{@NAEYtRGyb{qn;kZd5DG!f#EY1xM#Bc_n^Dcvk<6 zThj1~oMwsYl|m$P4;Uo_&zqb!}u?;Q*OHKH*enbX>jOBf$L>mf`IkkDl&xy~LJWy3AR0Ru; z`W5+e!~&&`dPs|H~$sef_!2G1KSc zH02iMZIOz7R3K@)_W2MR(Oh(6Xp6HALv@LxD_fGlUu}+A5*@Ao*E&$6hYU_I6xp$8 z@HOu_V{nq2oK#Tx@&jvSa8K_+)eZ`Nsk-KdBhStWI2UU?KIn&omo|Isj`o(oA%lUi zm{R-Ol=ds5rREK&A7s+A=}Fu|cR>y(N1J1yAAmW`&A&vf-Wj;=hW*(aq%Uriz5JaE zTVDC285gWGUj2=KJU3EkAO^Bqka7oqb!W9EH5wiWOS}YSNTOzc<)glc^dDUd^$;Dt zVC#LL$#QTJ$eyfL$tF5V#MW&9YtP@Eb$<;zVGa4=#jY=%M!Rt*`r@bd2RP$>dhazj zW4uIB{a)geN}+ZCE2yS)IH@J>u@e5P`0I*8%r4Ie!&vLC5`53l36A ze6t&%=L;+3)6}!TnnOpllai9+2*(+v@R%#ZxvUC@)BFc%A#o*Xl?Bk@71+5b7_LbZ$H@pi~ zj_Ph*A1ctvQRDA}B9plVndp%LfWz;SMrZtVSLijl_kP?oa*rr{INXs3RAjNn z>zP__x$z|=kjEdRmNU%={WM4%mL~buqYp{917W;jAy@1#x+hf~PvO2Rbx+s&?vJEz zXuTJxZ3hXrL=h4p6X%}f(q}U_AaA&2(UYqUZ^_}v~GY+0_o1eSz z^W;yRxN`EHNIHJl2X)O2Wk%8MF?~&*RQ0&}LB)8R_sen)psj_T`?4kKH44zRdQvt* z1djdCE1`-iq;kDtWs86B&k{r0c|60dQ%g+m`C zxNvfJ6#cUOAd_d1SyhAH9m=$=DHy$=f<$6No+QyyxR*!#68Uw&KRe5eImQeuRu>OZ zaj(|!kB~&ZP$h%_(RxD#wsg@yiy1Pw)+lUuA$lTxV_&8Q^3O@0->zF(5ny{=mWG3akE(+|kl$nfUwlq0{LjxpH-XQFnfEQiOOx$q7=Ri9(4HI?8)46Xi z=v=gf3EZt+2sIrRyUL6YqHA;%=r=`P zxs57K@&QJ)L@fE^r<8*JOx@Eyn{d2M^TGqWD|=UQofvo=Qi+ktOtA2x6ht0;7VzZ@ zhXEDkPO%4plpASTqi)MB&ar*lfM-z#Pc=wNNs+Ne%`%mrkCY!@|HLWMn zS@lp=q?7OkeeSidMMd!{cMPaV0dSl0ce?x{Er_Y0a?jvg-#1Gr%qRX0^;=}X9I5JS zNa-{ZeP22-OU@U@yZ0a*p@F;1*Lp8#8~e#E{uin0B=StxZawBPr~2-B_Jo7A_08{8 z{$fu_B!L6i1)H?L`45ehR!^08n#6xNZUZY1zBy6SSsBf(Qz-;+(fi%cdEOUk8}ZvK z&-ISFM{=KGqO=4>X>e1-RR$=tgeKo38q*ZWghnztO&K_(nGN8w1# zS{M+K3P;6;82p829dA4H1(>|B;rY*8#7Jtrp9dRE9&_+W`A+$sB#8AW+J30X=GA{n zzS3+KP$W#i^6x&YB1F6B3iG~xnjE}do6jptUHf#+DfZ5%sjof1xJi|6_8D>*P(SDG zL&EkK?_Da@?T>|K%T4Eh8yF)#mu^4p{vD2eDzLN|V$xF4z`9GggDfASiN}LO{=jFR zh-!a30z7exa`1PV3sD8xSOS*t)w{G-zG~ilm>6dBOGNo4CR@8A_YmMmzr)rU@bH_T z=pklHs68HrD9^VFFnf)BCcvHQt^{A>QdDY9^5M2 z>S%RlBtuwnH~FI**~~+?+*;*)_W9!UWc_6GSo9(p>>tK_`%gI#utUM7?k1s!*~*7S z=bWmUBX+)K%sy$M@X`BeboM=vNnhhxbzMiv5BvS->*9ZBo6^?or1ji^7XT#ADa$|+ zOvKKfg!xsvLRNDATvLY@_B2{l7{!<0m0?;+P|y4l1lU|3Ip}*IPg6rrD^#4d)g5Iw zgwpOvTtX@6d4<3RNtXqJ+1j8HZ^8bsVbc{3-EsEqwX@7rvrBi&8GMZS?!DbsnKJsU z5!0D|*#&!#iPY2^$u@;gw3yGvJsb0_N`%6z=PL~ z;(TAAn;}_LTxvPn>bDxNWmmYIJFD^q4qF2rN?de5dYjEP{i^@y&^d|HDZ=4{3#UYG zCTURNZ7XfUWAHF)Y;^REhX*oKLlScA^+TLO_D*9&R8*Az-oqJb&;7#`Ly?ys%bx2U zL0=eBg91OnH&?~sMB)ImIKz&d>{+kFqLN1y^m*(@1Pu!i)IpZ^G|^HYFGiecwwSA# z9=E6EcTgD_Dx#ncMWkfKP0}V{u|cYj?QeX+mqF2F+&6ox-4-?dt0&Eb`}{IY%`;6L z172pL68d5Sw=J$L9@H+dbBym!df)v`ymj%BOMy~W&s(&cU2p7_UP$xaUPftcr`zpS`M%1UR}MPmcDZE2Vooc5{EQ|i?=ebaL0{nKK3(&<=GE1UgfN&N^yKY zbZ_t4Rs5B`sq)4qe;eu>WH%gQjkqUfULUd(Xl6~9+j0QyqM_{bqgwlj`}9OyRT-YN zXI?cx1;G0fnqd5m(Uvae+Wc~-8hy{UN!-#0l4mpkM$Mnt+ za;3oTkJg}{mMxwMlCYANF0$afD&HRvNWi7{R=ZF7>fJ1c^b%G0)R(?k9lq!DoHkIH zUM)3<>PJE%okmhDw(!JvpXdij#a7`RNn1#jauV3O$r70&~1jQkh zz?WuBJ=lK@1=7qZxh0AIk|Fc^0qhdzz?4Z%3Hr0;z<0qfcneh7RZQ;9S3HYO);`WV z-#b5jJghb4^Md?JypY0Ml>U2NoJL>mwUf&46DEskH=H@|jqpb)pX}fxMfq|z-buVI z)HKeiuJbaRLMn|^vzn~GjaFB*gJeC@6=RvUu$=$MU2^|-Z?bvM=uDQq`A)-*@<10J zjL14LAZO#xCi*l+$w$YFey{#jw+IwPu-+-)`Wql2@YhJ9ZhGo?cjmT-^|G1ur}~1t z=QV>~X0I^Qr>8nAI6-O?u=>;c?|GhAR&^VlP3#dkb9U4Agl&V)uYz`3u9Q{r{*V3k z(!WO>GYX@&1?l-{X**sG0hBQyOPQ??;XATvN=994RDKM3Gtn|mGI%$I(B_i;_HgRS z;w@odWXbjvSzyPzC^+9(w)`+HIVORYav-9Msx7<$?<`}6_r|(9EChITUaOBv`^V+4WgW(8XSlpGkl*-{ zDo{+jrdq@iO*^RuX!+g~W7l1~58S`aZzLAKn<{TV`EXrAz$osl&d#2rcZkg9NuFB7 zNPT^U>V%^=JZcv!L~heCZl-};hpn32$jLFeV?n(%eHXP1(OLoP-J_r9GMj%xM!6pg z{0eAkRwE1cXf9g&uOBL94a2Ew&V$~+z4qVi+QYL4D1>z6N$B{I&}i*dFY_B3V0TOZ z%O3uOUZ_Mt+q4+bQQ4<6(TH9TOkT%dZyLk3fz7HJoQDh3%OlI1igl6@&F;M)PX>=3 zEJJ2~57`tyYYIZrj!jd+XJ7|;=S1QhcA@FdmZlys^+Rv;%H-`gjPkLI@7={x;59-d!Wz>mQ1 U8=^xKLZ*U+IBfRsybQWXdwQbLP>6pAqfylh#{fb6;Z(vMMVS~$e@S=j*ftg6;Uhf59&ghTmgWD0l;*T zI709Y^p6lP1rIRMx#05C~cW=H_Aw*bJ-5DT&Z2n+x)QHX^p z00esgV8|mQcmRZ%02D^@S3L16t`O%c004NIvOKvYIYoh62rY33S640`D9%Y2D-rV&neh&#Q1i z007~1e$oCcFS8neI|hJl{-P!B1ZZ9hpmq0)X0i`JwE&>$+E?>%_LC6RbVIkUx0b+_+BaR3cnT7Zv!AJxW zizFb)h!jyGOOZ85F;a?DAXP{m@;!0_IfqH8(HlgRxt7s3}k3K`kFu>>-2Q$QMFfPW!La{h336o>X zu_CMttHv6zR;&ZNiS=X8v3CR#fknUxHUxJ0uoBa_M6WNWeqIg~6QE69c9o#eyhGvpiOA@W-aonk<7r1(?fC{oI5N*U!4 zfg=2N-7=cNnjjOr{yriy6mMFgG#l znCF=fnQv8CDz++o6_Lscl}eQ+l^ZHARH>?_s@|##Rr6KLRFA1%Q+=*RRWnoLsR`7U zt5vFIcfW3@?wFpwUVxrVZ>QdQz32KIeJ}k~{cZZE^+ya? z2D1z#2HOnI7(B%_ac?{wFUQ;QQA1tBKtrWrm0_3Rgps+?Jfqb{jYbcQX~taRB;#$y zZN{S}1|}gUOHJxc?wV3fxuz+mJ4`!F$IZ;mqRrNsHJd##*D~ju=bP7?-?v~|cv>vB zsJ6IeNwVZxrdjT`yl#bBIa#GxRa#xMMy;K#CDyyGyQdMSxlWT#tDe?p!?5wT$+oGt z8L;Kp2HUQ-ZMJ=3XJQv;x5ci*?vuTfeY$;({XGW_huIFR9a(?@3)XSs8O^N5RyOM=TTmp(3=8^+zpz2r)C z^>JO{deZfso3oq3?Wo(Y?l$ge?uXo;%ru`Vo>?<<(8I_>;8Eq#KMS9gFl*neeosSB zfoHYnBQIkwkyowPu(zdms`p{<7e4kra-ZWq<2*OsGTvEV%s0Td$hXT+!*8Bnh2KMe zBmZRodjHV?r+_5^X9J0WL4jKW`}lf%A-|44I@@LTvf1rHjG(ze6+w@Jt%Bvjts!X0 z?2xS?_ve_-kiKB_KiJlZ$9G`c^=E@oNG)mWWaNo-3TIW8)$Hg0Ub-~8?KhvJ>$ z3*&nim@mj(aCxE5!t{lw7O5^0EIO7zOo&c6l<+|iDySBWCGrz@C5{St!X3hAA}`T4 z(TLbXTq+(;@<=L8dXnssyft|w#WSTW<++3>sgS%(4NTpeI-VAqb|7ssJvzNHgOZVu zaYCvgO_R1~>SyL=cFU|~g|hy|Zi}}s9+d~lYqOB71z9Z$wnC=pR9Yz4DhIM>Wmjgu z&56o6maCpC&F##y%G;1PobR9i?GnNg;gYtchD%p19a!eQtZF&3JaKv33gZ<8D~47E ztUS1iwkmDaPpj=$m#%)jCVEY4fnLGNg2A-`YwHVD3gv};>)hAvT~AmqS>Lr``i7kw zJ{5_It`yrBmlc25DBO7E8;5VoznR>Ww5hAaxn$2~(q`%A-YuS64wkBy=9dm`4cXeX z4c}I@?e+FW+b@^RDBHV(wnMq2zdX3SWv9u`%{xC-q*U}&`cyXV(%rRT*Z6MH?i+i& z_B8C(+grT%{XWUQ+f@NoP1R=AW&26{v-dx)iK^-Nmiuj8txj!m?Z*Ss1N{dh4z}01 z)YTo*JycSU)+_5r4#yw9{+;i4Ee$peRgIj+;v;ZGdF1K$3E%e~4LaI(jC-u%2h$&R z9cLXcYC@Xwnns&bn)_Q~Te?roKGD|d-g^8;+aC{{G(1^(O7m37Y1-+6)01cN&y1aw zoqc{T`P^XJqPBbIW6s}d4{z_f5Om?vMgNQEJG?v2T=KYd^0M3I6IZxbny)%vZR&LD zJpPl@Psh8QyPB@KTx+@RdcC!KX7}kEo;S|j^u2lU7XQ}Oo;f|;z4Ll+_r>@1-xl3| zawq-H%e&ckC+@AhPrP6BKT#_XdT7&;F71j}Joy zkC~6lh7E@6o;W@^IpRNZ{ptLtL(gQ-CY~4mqW;US7Zxvm_|@yz&e53Bp_lTPlfP|z zrTyx_>lv@x#=^!PzR7qqF<$gm`|ZJZ+;<)Cqu&ot2z=0000WV@Og>004R=004l4008;_004mL004C`008P>0026e000+nl3&F} z001LHNkl#RyD zl~?cGv+ucQzBNRoMm48fLHB?ffm(yQf&4(hpeRrRC{cTj(%$#eKG$0Nzk9UnRO`8_ zZVyxk^c<)UXgp{YXg}yXsoeNZyUr@@x_z|osdEDi-b1yt)f)y{3p(WtXRloORW4n= zBEMX^EI*Sj+FtoP-{;?*9H+GJ4b$$U)(tRtmi`Lr3z`KwQ!2B6{Z)SW`J$Zo=Dh4a zeoj6+a8efS_)_L582G_D9+JWs&4>|3W6N-YsLmTubgI z37@|~LbKOP2#Bv?_?_=XhJOIVRrw=_jo;CcjBtu>U;Qo{9b;4DdW6$ zza4#LJMs1#r1CZnbmE##{K7A4wJs<;EEAUR5NqBhFwMrmQS&~N@SF`2wP2H5$pRv9 zbbyigz5IUO2k(dXRmwP_Jx8M(U~rw9f#!oQ8)x)Ki0GZizEa|Q^y00>tCy>p%nHXV zfiQMyp<*1tL1wud6eR!xX~FN;r4H|l_s9F>{o0Mo+H*C#0fzFasU})WjALJ)$KL$~ zn7pkR09>IuLu^uEy+kkEtX3zLz%$=nka5elD{z<%2qW>nbYSp)dEdPMQbxY^yf?sL zM^AyWjWc!W$`#pj;+)L*Y@eFs5Q7A;Cr&(paQ6EPC1(5kpMH^qMO!3vKE(L~&jCUw z-Y@T)Kl3^GJbW&@k*z)dbq|KRpj7hS2!b6)&q^kgH17Lhn&ReIOk=|5t(PNbOLrw4 zKX+a+#3)HTO}u}lxZ-*ETzoz|P+ZdHq3-nvhTnjCfsX34@hi+Vt{hHQn5NBJ%9&)Y z_7PcYVfvNrUf6K(l=_^tiojr0K=o(ibMkqAEor76)#l|l*9#aLf^tf%UhJte*Y8te zl@sO6#8M9knzK%(t^M37@6fb$pG(kO&*~3lQJ7}l^0|*+t5f7?^HioiStD#nwWZC83H4?`glj=G&YztL>hCLH2-feI`2l&`4qxLwuCPZB z*NBA$@zcf2QrSUsj;`vc1slB<3`X}h=kb@4dPK0dgCSJE(+e<@W^df@lF3*eaV67V z;I6T7+ZQr&&N{DDChbj7S{t0t3nk6ZP;Ui8u|!}32$MrXHNU(&h~k|3!m`~*-3A6u zY%EOFa4+&bl&wdsSM&Nq$!KV>w}HXm2!ttX_qY`Zx=9%flaPw2JIA&oXKlWRyiGm> z2+pq^ApE@r4E>EBMR!XCdvBeqj;3;zNf6@%D%8DTlTS$qyDg)CRfD04HlK14IRv_n zV3z%DfwK4Qg`dUUeg>E&NnHxYCw4MLn zZG-n8=mW~6Js^1B2BY&>WjvJ?1;WjsLj4YC2Uo_c=n5DvxWTL}Z7@ZR2{I8m8+`^0 zy0?<^Zy1Fde>?_;;-J&+6JOb~i*r4ZAhI4J{k)hpHXb@{%X`T49qGV%=lt(Jan3%t zg)Lk z^oHp{Cr|Bt?- zPmE8HedJ5N2cw6!pkxqlp~g42gQ2JX4F`+9QTvp|LrJF0PNEpJi}9N_zW(7S<(VV^ zeF+SfTw7qvZY%BSZZNPs?6~g2Wkya#5>qNl%ynFhnn!)CJ8(iKuh~=KoCaqGJ$&=G z98!rio+!p~XMzm*V{k|vcecFGSumvQS1v$oz|#sA!`3WBIfJ?gdJDN?{b#MQH>pe+ z`;mq=2FWxd=d4v0jW75i$e)6eF`RUFfr0gb7j2%p^GM#@?C}}|GGX?H{px4kZOnTJ z!-_5X?ta`iHIrgeu^k=dmu&RXpP zSJa?AH7K1@m+w?rQpS7n%IyO4MSdBQVsa}Bh8OiKF#(mKUW*q!FquKEfAbfoJq8Gx zwrlpCP?gxhUQ~xsT40a-vP&F(v7%sLRnKBu$=k20CxKZ?V`TzFbhr={tgH0oD1w7$ z@|wL$mr(ZrvFwe?B>8sfs&8g-S=Cx)f#C%`BFWl7vw&dBjohG=#EM8AJ?SND<9?}% zvH9?6o5ka$jwi$f3Rr#RsX^MQ{N!rb&CRp zs}stHPM~Az;$^9-!L;^xFLYLse|xS5vMy@;bs7xGwv=*P1yWe{26Mmwhfd*ikcRy?@v?q84n13FrI@BX}6c_{oIr;_~Iol8}%fx7>1zv~Al~ z3JMC!{5;zU=>fe_Ra~$`J}xr2^h*nImu5~b(ldWp(`Z(%f-TUsNxuE@=W=T!Ggj_W zNhhvY7qd;YE`o!DF>^H(b?DGRii(QL$+5IKt487(s>)eKK9Zk?rellj%}jeR+(#Vn zle^HZ%nV(@2nOXJxKO@-fR3I#t>A?bOskXD1)W1?jevlFVn8fiy0qNS(}TNqKb=(@ zm9wg! zS)4_)FcR@BW$7kWF*d<%Z}DQVeDOXEnZG1BO@hPb@IG2ErJ1q!_R0 zV1sX_dX<-aV%5^-4xRbdtH3~L=4?HrEDcX?738mByiyt%BJ|ijGi5xH@yrS-PQ;c< zU-sR3@XFxr-LECq-j;W_6uC815A9?1rshp7B`vyOGF9<~4r( zL&a+;*J0aWp^dEx$F(&Vb4zN{RX!M;3!LNmf?x8NeAW#djsL}9cuo&jFT^pg?f0t!?mOrgLT!< z2!`>x3z{dbcti0i0YSy^^GfC@&{4Jh=o#_Wu^xS`J>5!({3V|auIcecFsxBN^l!8% zr8nd^=GkmwS_!#@*EF}PHiPvI%w+cD0<>s~B>An4H98pBiuQo+Y^tg)qRco0y@)_E zE4ixUP>Q67P0a9;&L{G}Cc*GOqMiH5W|^U0Sb@xBQ>K1X!Q{yN2|=%>J_L8pwjmZMv>;1iuRDNwrDdZ#)KdLmWl7!SoM$mjeWUl?!UDT1N3 zry`Z^k`i=5Q=iyy=v1`<17kFFt6MzOq_mU>W^00>tNt4sZidbG{+@_>c^&g4SsZIt zh}zR*{#IL|uP1Z|^4YGzYFC26Pfs9WWY1R`WEzuL(pKz}^FLqoc`$tQgVyoh1EB!& znfx|1Kk*|Ng7kbnIzW7>!Ii#kaIZ}+*lyn_(?>0fFFoRSAfL(aOIM|85Wx_|pJ>N3 zX~fsSp!*~!A*Qa~Yu|m{=f?LqW=RF`Oy&dmOnw{uH&Fybf=U>{o3!O4eGm-AeH>tV zy1RpHRSfo4FuRRVq*l#l=!TO(FeK{PLrjUP%JUy9t5kBkSia|&&x3*6ovtLCnL0pz z8!FHe%asiLr>kd8Z!o3Q&YftdYqvV+4$DwPWM;=&N0Pyz&Oj#*gGH0p@0S?7W+2~S z`lf>tji23>{6cWqm*lJW(5=ArogBKsR;8juK`N@5|oo(vKC6 zhPbohbowY1y;=cO{;fJl2WEen6|-<;O*r&3M1rQG2=>9d-;pjKXUK@?x$=h^FUdO} zrOKGqd&&euc~%LFVbW0y8VF#uY!@MMFb&Dvu}Dmb9=Aa5s@Yt+`cIVjPj^Zhz%m6r zozieG<6$wxqB2NrXOJA(+rE@!Qe000(_eoxTuppbO1{+kuh*nU&@>qhM^9AlRlTCbiUp zdKqAF=Wg+G+aF$&kWW@iELM0lR``g_0%`E*2l7GKOi98$ji0$vn!oHX13%7`J_9F+ zW$LFAg=^14XuEqCtGxDJtOSf-B+otVCr>u^lh}eCl7Q<}hp;#6Bh83eIPyR`j7<;> znGo5XdyK&ZZx`#hg;E=g>uZ@U2@o-4tOZQvY8{UYlaXOS+*AN)RKyG!HX&azUIzrj zrs?=w8XhhlpBoRr3>`IH?yUKy1WsKpG5CMh15SgBIcL{ViGkRs#E8Zgb=%FaNh~Bl z^Opjo7VhEWh00ih z5xIp^0OV>B(S!sHaw44(3rV0G;pfa`R_O6UB5IieW&DL zHFkPCLTcXBO76I&jXd-~cZtA?9EY^^p3o~AzZ@Vb*ypEW#YciU6S3lhBWB5;e&1Re zH6A1xTMvtW$PB4ltG$E*1l%U9OuI{2D1Z8GD{0vwN|GQw(vb0d=O5pY@JY+0E2I>` z&<_&DZ^R_^a{?qz7COKT1wdYEAF1>in@PMuhzA+>LQUAhjRER&%v4-K9s_3nII!hn35uiRGBaHI8ZYbPz* zMao!we;Ov?E^H-1K~UaZSnb504~9x=TUC{ zqR1y0US5d+)BN4pM9fj9lfxWH{=*ck%mGl`C|0I`QTJdKbHZorJubZmjF($~`-*fM zIaOxwJ|>O+(O>>{|NClHj=_nt0gwX2hGj}^fTThF_vM{;tkM8~f8c++NGMFE)QtyZ zH~@3^9UbudTIIiphmMc}WwI`|j%Kfi${0wd3~VoV-TIaUPFN%ZhGfWXkOrNgNY48F zgk+*rKLW~C5=`JgYZfF!gbfT@753cC2YdnyX)AZCb2c4~li%9T(Td77HwV&Tb~M2- z4H|#f9*Hsv6FVJXsCQdiX^s^*1*^J8-(ZUTpUA{*&QYG5d@P zcMKK~4VkeDM+7)_m`#V2bVprgdD+pW)=hAmn1X8O4jnBL2<31hyn=OaeN+DR{7^~9 z{{P|7OzijVAO&_w!J#5){P+NQo(#k_toUp!R&2xjyGoPRAxaS(2S?RokMx#7V;89H zAPJufg?PX1rdOpGbO-tv@*r`dV&+IqfacjI!(}YIpBcFEyKZ@11}EmoAm|FetMQ`R zf7A zF_b^$K;lt3Smnc07t6@0E0jJE1%QN7E5<9YJsRK$0)y+;ZY!MzrO8C>ivtFw%2Ut! z$wLi$Nkdp10gwi9a3;0yn}loUOC%noG5DU*FjcMSBdPDJwkBd5eIl%V z6xHOT=B_XH&N3hJcqxao?L-@%%DSk_tF?5x3Y$!e(ft3Mbnf$H2qlFrUg5yw1*T*{ zlt1xs4{6>uLhbSC>{4%;DINSKsI5f>o3sEGU*nf;FX6N*rreSq&2cMj`p0NUG4*)^ zkhwqlf@HX2D7CX{4CB#__HB-Ms2Uw}70p$3rV6|A{TXu0k50~nW%A6^A4wgUi9;a% zmmEATFaFz4-t09-t^A6_Eb2vg+aSt z@7JIgBB#MByJVN}%SK@pO^tK5KZB{ATNw08g(5g`*hJ-=YT9~~WMMVeyB+$%z*I?O ztV2_7EMO$JCT=4}kWqXxra_M;w+Q~827q;WKSAmtm^Nx`t~~gcccn?oky`k7lhT@f zrRauIAj*)`qSE=m^tq6zWqrz){;TQ(4v|tzSCmm+yJopnPV1mZrdejrfVS5^ez*)mb`bhTnBk~U@ zxOc)aHUzN?DzXIEneQ)%uZ;PqJ~uj-2nbe^+ecw5l2-3ZPbX8my+z`oQm|5c0tgi2 ze}AmE#AmIMrY{VWmyj=!0LhR}^D|>H{1WY@Hlm|XBDN7t>i~KQ^?_OWo8{pL-jh4v z!K{B@R|!INGXo}W0L;v~cXgCW*fJXZv%l1X6N_L-fHgzSeETuq30P5)wC@v1J&ey` z=;4Sq%dYo!aHZRuseK?Lv~8m2kaUS-#1p?yM%Gk|W+UW@e-Dy4fMGtw;p6|;NACSg zXXyp0Q4c9%>ku0bR8E94)D14| zD6DkucbOXwNSCe&^2k32s8~l_+7h`PL9AwPgi98b%a;L^y3i@Yuu>)i(f8JQ8{CA|=>gAw|!`I}ZU96kyQ+~EWR!PX33%e!lL5PtwGP6I<_ z+6z|2U=#FMr66y-ramM@nVegdxy;~JsFUvLiu8^)t*bo2FdfWq`&PJojOZh!1HmvD zBLDvTx~a^mNW4#m55}s_+J92IBPMd+J?}{z#Qivcrye|QZoH^sGB30%pEYIL?p|jVh zC@7V&eW$+mIWX|NPBPHqAPbx;-PwlZl{s(1>62&_2=cbb*cJOQ@!J$L?2}%tct2*b zmcR-(^RV=#DorgKJ_LF%M<8LPpLMo!HPh`(@!qCOoILvY2gqj}tUQtGvt%r?q1yFM zg2FjK8a~uhMj>9pR5`1b9>@FPYa*tYDtu!srfc(R8Ge@vyLe8#9($eb%V;ZNpQ#Mb>*IGse>UPYK%Pkd~-?Lc2<&> z?UdP&6mi*Wko$N*GO}`{0e}*ko`oFBG1BJkPV)3?osh41LfX93U9I@|<@=O$={-DD zrYv49{ry8EFfm;QT2o}~ssoZZb)Iw|JVN>m8!1C9qos5A9`e>Zo#oX|U7=W(Ub|t{ z&Y9%74!%BYU1TdBrF7T1mgSy!8@mJ^zVx|>1-vRDld}H3C<*D4^^slcW`Uq-Ce>GAVDRSf?)(YjUd8taXPBO_?t3-t8jR zq%?WtiKiuCQXZ~hl_s5f*-H9mE|ykp+QJ02Nc%25BwTfX-CSyc4!5bV&R_6(F!0RJ z&GGh{&}EZZ&dQ?n%?G9KB_jighr59R&A0b)rQBQ3gqC<)W&OTGIZP<#9I zUFVRI)J0xy(NYE{PnVPxd!_EZe}y%XBQLh;AVbr06tKe5XUoku-;9uSggpLyQyCaB zTAIJtSCXJ-Bw$-fSly$0k7$-Eu7u5a9A9_p>u&3l4sFb*mts$S*@`TW)#0 zb_NWMbjyOLu(9M_51qy?-Y)(b^QB#XfBC?YBBN%lkPZOEv&~vcFn$i1y-NI&XQ|wR z7=AW0SDJR{F1@Ykum)hV&Ver=zfdWVwiS+Rqeh}fc(RPbf#d!exiWHkfsFcOxw2GL z<`lN3LE~o2M@h3vSTFif1)m)}CDm=HehqofS7dW8$fpxm{R$T~K2{nGr1aukJ(RnL z7^DMNeZr@Em6V9V&#_C93=0Ow!nZ&W#4p=@H3bfU7>gAix721z#%R`nN>$Sz1`jbB zmIVC-u}ijVDR3ogHscF+p^kG$35h_3vGB+lsjhY(bSY%h5a}?}8BGr8`O)UWqy0SXw=qCc&_1Ny|ERS6Q!%d)t`Zwsu`c@?nxHU{i zoZ@;JdE3e^z$HKIj(1w9@y+dEAl0Yot9!>Lt=?T_?S&~0nLS(`IV-_ zN&m*(C%)1;w|G`hFjNFxS0fimKt@F}QY#}Q9}FX@B7ChV7;Xj?>fgL--*H>)-2)0G zw+Gd~u$rDsQ{Ld&TRIpx-<)^OzhM+={P7qVbp7F&9{tGkz$v*Z5(%lW_vF`dy$+_t z#Vy*RmEf&c^KPgyKjx~Q;4Uzbn&^>D?q@uo+AKim$0ajK<9Z*g*d7kIJLlU_8TG5i zj~Z1422y|hZg}$SG?;p30D^~dFnZ@p1uphT-oHKDrAGq+lZ;+$kX;vmD)qFl4TX^c5A8xSUHZHrv zYN!e@keY#tvn<#;Mh|W|w^aP(g1qPiuik1(ddn}oy zq*oSO?6wGQDcA8R(&o!!{P8pxNDW0R-O~rFgPGRNxV*k~FkfM1H8@SCf+I(pryA8A z40^RzFQalv6O_fFnOeKz;V7v$6pLO@N@6c5qw1+Tf5%iC^%!FBp8s4r-iXlG=2(Kw^sS6}TueQIuf5e!DECALFa!$506p039~rG0Oh zb|1BTc|Ls|45e)+JYt7Ek$DK$D$st>&h4zk_)fddD($*`wC|}?o#wB)fuS_I6?BiL zym9q*6Wd|%%oK_OC4dsO*C_3MKkaj^wg0EdKu{DF#MoP+Vj)V@n5d{&QDZ>GmRKYDD)!f2 zv3F4u+l!6Zm8e0`sMrvVVk7n_0tQi}pU1&*<=dUTJMQ*o_GW>@^UFQIpSRpIvoo{v zpQq03DNqDTa+WKm=V#0tp2oRo1^KrD!)TN(yh0kIfLT~K?{t0XHR7DCU*)mfGf zK(fjTh$YYs-^M#+%pV0QRzNI(X1DuID;cSTfXE^j`G5U+jjFC1sy;YOsVmIAw04-M zM~D8ikG{7~u3%CeYPq`b+dC3K)S*3Hdj%c6`FC>adq`UnKLvVv3_w>Fe5df0X;m5Nd^!e^F`|GlQr4}od~b7~&+4q@@VT$Q#0{^fM^qd7y!1sGrU~w zk0B4siAZRAOxjtf>|Zd6$@(4!}#>#pMJp|yCOm1HV)q9uR$`74_{6m4XZ zy*{|m(27DK?QFK&SYt#dGf}os18e|D^M-J$_psk;Re%uNSm)aW-R%;9jJ*%j|Ed)W zkO263`Vsrhg$)!dSZCY>siV;R;DTbREW5$*vQ-l6#5|6=&-aG^ROAZ*fopVeFor5?@D{J66i3CYeO0YuabD#SwqM)F%2m!2~0mqu)O zT;i$`H--sl!g%SoGtu$-ndNinYOiz^9$^|{Hld@9xG=5srxE)S^kva(dOo>)jLxDx z-|DskMMMt}4_7$21Wt{p2T0n?lnwOb(s70zX~g!+quC3LxXWp7rXMf)_HJLle24Yv z+Tn~xSKFYou)dgvm?HyAjJQkSycw})GVDV}>|SgRH<8PKUIRV5m+pvbAq!rR0OG~^ zSlk*-nj@)BDXN6LYcuMZ*b&niz6a0EIgrC>zIY18|5}GJB2(WI0P-#T47W@*oik}V zZ~0Sg_ASb+!`O%6|AYw+jwhgvNJ1Z}X+YXAA8#I7s^#2pk~bE(SSo>#BnKw5qVpT}~2ta-ep8Xy!`%^L&aL}W7Bc!Llp%njjzrT`hrnjy<|E+5|| zFe0}l<{d;RCaL<_5Hw#JiEC-w8h${if$$Pz!R|iq;!k=}Dhn$4Jf>gA{pMP6&hJt^S5}u`eA~W|OWLGc+9o+=Cl|F$75LXisWU1zcrcWQ{V9ZwX z-ju*Z(Ra;1IPA+9gM_yg6@mwZ4gM|TwAG+>>q5^6y-9hwG)xG+?SvE5DZ)1@)Z@>Y zkdQ|fqo2I$2wrZbmtO%A5O|`i_%pfdTbee09GQwzUoMq?usW-o2hI_Q;5jOC zVJs35=w>E>Pnj-0NH3Ls;_eC+k=XPTw)pn;E?+Bs=`Xwj48Noa zf3A6qGiJ)yfmsvq4aye<7y-gOK)xmYAOK-V(FDV9{80v7ZXBlIP%_y3J?&$7>p`wi!T0p9O96;PoVFKEnIiT$6FL><8m?%R)n7nnCg=nkaSFGHP*orNS ztlUKaw|G>R#4dRaK=ZR{7qD_9Pl{gd_tHp0Ec`cRT#;OKzM``^R{tcDTDXiBJPUuO zJk~k!K2qNRkbF=guc>ufNK;QUsRJapkpqg`(i{T_Dnn4IWkWPSnQ@j|&cr#)|2yB! zP-W$o3?QAC(A3L3fMAX|q2}JDra1=S)RCkXZlemGX_(d)RpcJ@a1__e$^w@DA}7@z z5bLbY<_SZFkyM(9wsl}XlO=Ze-B^IU!v9+Eg;5-mVHAt01O;g3r*@cC-=&mnI!%6# z1eIKdqxpI8cyg7qRSme}0k9q?no$JG`dliDvGnsX{5IuE4UlsENNPAdZ;=~cz*ONgGxF;-WfUi@i4RXm)t_|n9u`LP{vrZ*QsZwLHs~cso{5Meg>Os z^E|43_upl4(pK(Bb$~EwEJG)vpa%_-dYNUwQD**TY+0Am5)j&65yhLhBU&5TXu8*v zrp%?mFNupP8`aSP@(?(vCeRqEq8Hea=(8Syiq-MjjTz z==fC$>ny&vKq1vUd*x<-^a>McQxdP}L!=c2Oq#tJ0qGP_NMlF%e&b@oALh=#dsX7D zlIfgYxbfj9tk>+(jHK1xm|XK+?OQDF9dNfYfWYU?y`wpKLP#za6rpq>)mVr~dw65_ zzG{++LP8M=_qx|wleaQ}z#Izma$!{glTh1&0P!XT1mPg7pFTz$FvrImL&Zc9B*yq( zNF)KI75wW2of>c;pM)UI6Ae9YNGkz~b>_gUG*Rp(tL`~Gv*Xi?O z{l$cj!Y-}#%t^;M@)PHkR|3nTR(gNe=Q*}HhUkA3qQ>$1bYyd@+ZHL)|E7Ta6Fa~b zmuPeTI2E`Pn!L-6EDVq?gn5&;D@aT{q8 zNkXK`l6y^o1p~sHH<`89*;HH3yMjt0eNuKJvr&HT{;;xwo5ix%vYxt`z-SHU-%B|1#gfS*MBlEMsf1C#2(QK3#0T7y+c{9h; z;$m;1>Gr+HZ=_j&ZtZJVc*_l=TB8~EK;yfaWwP@&mo_o>$hdNEo&lfa)YWWT{h?#r zXH~@rZll`Zq{76r=^v6%j~V+QUXpS;Ko`XXaLP|={jA&EJ2xOT$?Jnfh@Lq{F5lkS z)eTKmt2hBky2Rk^660EM@i-XsnQWbNRW32=Lu_1`FUE1<)YVw<3Oa^HB{^~%)jg?N zn(;x5dQ8_!b{{fx3lk~jIpwFh2Z{lRA}g6bxS07NSB9fpsU$l+<<+aS z!d><}BZ6g0V?M){8*!P92(@u#z8`7M=hS5vh+3j!Ft_24z-5x_E)iO1&%6k6?LlY?pI)dV6U=T%wveqv~pU-R!z0TU{V+{^mo$Q6vr zk{hrTYMja<)&L5;){}`yRF>3O69Z{#W&sf((3HRE^+ z4i4TpuiIaN1JjG9$&6`J_)_$;RdOaeAE$3rq=2ZgDoZIR8LwK3T*b2YN+Oj-*UcJs zyWxX1ZK~Dk5OleF0Kt%zyxtW3GUk8*1Nep)cx_^okm@y zrD=7aPQy=XN1U_y`}X}dWO1fg_cS)^MWNXg^?K}D4d?!h2>SE48E-O{_iESo2wPEg zWqsg4|LKwJ2zHLmc|N+idk^}Dy>r)eaPPK@74+?653-G?t?$>q_oA0&8p0CVmjxkpgl(vFAj<0c42pvY4!d{r*$n$RdxN`R;ys z<+&jt30=3VL{THBvqOH=aaF#%Y^~Q5w1iMpn||+T6)08f4Jt)?}~<9o^QAAeGSP@ zuWfKWw3(ez>E*IEzv<6U0cJXlEv+rXw2Q=T}D$uvUE5_FJc~AF>bnp?2)q%V(=>xXIl4WN_YzbGt4a`tXC)(1sKa z$q!tiv6!LQ3cqEYZQ%jy&HDav2TpFgX ztFdzP6ge4rY92sdvA=vkWk*1Qi@DcCdPlcR^WC<`V3*1XedtT)aRqO8SEZ;H^8kI6 zn|jwLbyItq?Y;1yeHaO$=`X4LB{=I`NchviKO&W$TErDvX2zU)oFjBG{Gd0v11FMKpoY zMO+Jl5fFQkCN<4us#FH4el8$#_QW;yY80dkP~p+r5;BEtRreQcpMzkdok07_%+;GY zI8KF08uW(jVGiL2xh%b>abO&4P-aRNl(d6Rer&y=@Zv-Lt#eitlzqFm5H;WrIh{eH z#?18_+gFrYlQyNUCJcm3s!Ai~vn~jHk8}ZxpDRFcF&c{^GU-|Yk!TzPwJcMr!~o(9 z-oroY@1-e_9ZS;uZyX$K-3Gjao*uAe*I*^!rn%BtRVog+vNCni<&pja>OT$rDv&G1 z{ErShX=dERfsSmon(*S_07sv`(5rThY7P24hHj;%P}i4D`Fv*h>@3{@Uiwctt?Aw- zBTnRU=BEG<&#?eR@S(oJoXRmiuPy8IN(-fo{&krT3M3#+!EHDK=iW4V!jU}mS`Idz z4PWsED}X?xZA7f6e5D{}I7>$QOHy+*J866ofHDs*VsiFXBkGqhx@|0IP^Bi|+34u6zlvh8*% z|9IOb+*atzx;NVnkN5T-9Mlcj7kg#jNu}ICqQPU@jf#A_$z@qEClaB|VM7W?@K9h- zD+7=8$c@|rrBotUb0wrf&zE1nGn|II^(U}sr2_rA(VHatuXf;yVd$z-(4^AyveeTO zhxUNAs}H>VEIfOZK{J}izGLgha^K_nD$Hkif#ZgAp`=_!T&{G~a2RS(e3fO)!|oRu z>`d_qhyo=(Dw!l#X$T0ly7K*=uQj`G?ElE%_@3Q`isAV`cc^|Xvf0F!atAAk1-UfI z3)gtE|G{RfG$Wn_cKlkYABB(*#{xF6i$Bi+gfaqzYSAfXCuBZd#c*%tFdDmplMP3? zASX>=@`lUJQxgE9#AGnVjDRR*m^elu%~cresn-Z^e9wL6jd!WHR(%=j!FW!Cvzr}P zf!v+LTyT>_vm7pT-ZkPcmF&FttTTo^JlMZ~|DHAdJ!JBf!yA`a`xqGW^uHmE8I# zh4eQZVMJhH;FRT;+8qjW)(v@bo_Z98l8_NoV|{A6SD(1RTf?@q6C0~6P3>w??f19; ztl5&!|ENpb^nI1*dpOtG=r@D&c*QanXg1*4jW8`BWtf1GrwI}J>rXmB=-04bTwghP z>YAvyfHDx#kkn(-MjeXp8FW}o)A}P~NOi&j;ME~wIlQy%&-d3&njQMY-=Ouc;s3XI z>T2?tK6=y9RP5D2n+6E0$FjqIW(KqL!OrPJwm$uF0)%gFgsUwhNp@ii*xGxUO4OW) z39!rR5m%Q^UKDu^h9f>VZf=^r`uaXQPVQ4Jz=n_uj!8hUb6y5+Sn@QXi5m3)p-uFJ zrAx+n>Rin#{TDCxE9=;?Z#kO0;b*yWRloOySI3^7nmg-{U$MZ~(XjQZ-5K(3RnFi6 z7b>S{zc=pg#B#fS3%}PLI%nbFij;eIW@20Rv;!hqM8w@&v9&ufp*i(sPj^k1t){J* z*?}FW3N-s^-b4>$Ln&xqm@u^F@FZcmc7=mmUu*xDeElA7_iRga%qd$G#ak9;PZ*oG9f110Wo ziI`4<@!Ti2;lv^4mypn%^VY;T7vIwIbs{#kh>IB*>hup5K%5ZJ`Fy@JZ(>_eGJpsm zx1W|xu4(4=Z&ONwhV4hK!roE9b1+K}k7BAUVM?}`xmLI{6S`_SBK5SwGrZS1FZBRZ#?_G$ce+ zf&zkg6GjAz6Ns4IZxT`)mjNr`NL^4k!%wI;lQ>3Q-zt8BCIoy$0a2HXH4+uQy^?T{ zN>D;fsqqpLUA!q0Zb5iXF6xYk=u`EwC=2a|5?CVQh#d8)PdW9e44MK&fLN)Bq%I+( z3RRYItp2amNu@LhO0d&VM5_)2Wlx28izZTjCR2if#>?-s0P>I&0CIbdmXJ?3b@Km% zM3!z9|HXjd%#s>O)~PGyz|%?=1Bg{;eRM$3ehk0cVx2nk(EkDWUHT1{MZ)j^0000< KMNUMnLSTYR=uag8 literal 0 HcmV?d00001 diff --git a/source/engine/thirdparty/Chipmunk2D/doc/stylesheet.css b/source/engine/thirdparty/Chipmunk2D/doc/stylesheet.css new file mode 100644 index 0000000..b0d0b1d --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/doc/stylesheet.css @@ -0,0 +1,72 @@ +h1, h2 { + padding: 0.25em; + border-radius: 0.25em; +} + +h1 { + background-color: #89b4cb; +} + +h2 { + background-color: lightGrey; +} + +p { + margin-left: 1em; +} + +p.expl { + margin-left: 2em; +} + +code { + color: #191970 +} + +.HideShow { + background-color: lightGrey; + padding: 0.5em; + border-radius: 1em; + border: 2px grey solid; +} + +.PopOpen { + border-radius: 1em; + border: 1px grey solid; +} + +pre { + border-radius: 0.75em; + background-color: #F0F0F0; + padding: 0.5em; + margin-left: 1em; +} + +/*ul { + border-radius: 0.75em; + background-color: #F0F0F0; + margin-left: 1em; +}*/ + +table { + border: 2px solid black; + border-collapse: collapse; + margin-left: 1em; +} + +table td, th { + border: 1px black solid; + padding: 0.5em; +} + +h1 a:link, h2 a:link, h3 a:link, h1 a:visited, h2 a:visited, h3 a:visited { + text-decoration:none; + color:black; + background-color:transparent +} + +h1 a:hover, h2 a:hover, h3 a:hover, h1 a:active, h2 a:active, h3 a:active { + text-decoration:underline; + color:black; + background-color:transparent +} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk.h new file mode 100644 index 0000000..184d63a --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk.h @@ -0,0 +1,234 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#ifndef CHIPMUNK_H +#define CHIPMUNK_H + +#include +#include + +#ifndef alloca + #ifdef _WIN32 + #include + #elif defined(__FreeBSD__) + /* already included in */ + #else + #include + #endif +#endif + +#ifdef _WIN32 + #define CP_EXPORT __declspec(dllexport) +#else + #define CP_EXPORT +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +CP_EXPORT void cpMessage(const char *condition, const char *file, int line, int isError, int isHardError, const char *message, ...); +#ifdef NDEBUG + #define cpAssertWarn(__condition__, ...) + #define cpAssertSoft(__condition__, ...) +#else + #define cpAssertSoft(__condition__, ...) if(!(__condition__)){cpMessage(#__condition__, __FILE__, __LINE__, 1, 0, __VA_ARGS__); abort();} + #define cpAssertWarn(__condition__, ...) if(!(__condition__)) cpMessage(#__condition__, __FILE__, __LINE__, 0, 0, __VA_ARGS__) +#endif + +// Hard assertions are used in situations where the program definitely will crash anyway, and the reason is inexpensive to detect. +#define cpAssertHard(__condition__, ...) if(!(__condition__)){cpMessage(#__condition__, __FILE__, __LINE__, 1, 1, __VA_ARGS__); abort();} + +#include "chipmunk_types.h" + +/// @defgroup misc Misc +/// @{ + +/// Allocated size for various Chipmunk buffers +#ifndef CP_BUFFER_BYTES + #define CP_BUFFER_BYTES (32*1024) +#endif + +#ifndef cpcalloc + /// Chipmunk calloc() alias. + #define cpcalloc calloc +#endif + +#ifndef cprealloc + /// Chipmunk realloc() alias. + #define cprealloc realloc +#endif + +#ifndef cpfree + /// Chipmunk free() alias. + #define cpfree free +#endif + +typedef struct cpArray cpArray; +typedef struct cpHashSet cpHashSet; + +typedef struct cpBody cpBody; + +typedef struct cpShape cpShape; +typedef struct cpCircleShape cpCircleShape; +typedef struct cpSegmentShape cpSegmentShape; +typedef struct cpPolyShape cpPolyShape; + +typedef struct cpConstraint cpConstraint; +typedef struct cpPinJoint cpPinJoint; +typedef struct cpSlideJoint cpSlideJoint; +typedef struct cpPivotJoint cpPivotJoint; +typedef struct cpGrooveJoint cpGrooveJoint; +typedef struct cpDampedSpring cpDampedSpring; +typedef struct cpDampedRotarySpring cpDampedRotarySpring; +typedef struct cpRotaryLimitJoint cpRotaryLimitJoint; +typedef struct cpRatchetJoint cpRatchetJoint; +typedef struct cpGearJoint cpGearJoint; +typedef struct cpSimpleMotorJoint cpSimpleMotorJoint; + +typedef struct cpCollisionHandler cpCollisionHandler; +typedef struct cpContactPointSet cpContactPointSet; +typedef struct cpArbiter cpArbiter; + +typedef struct cpSpace cpSpace; + +#include "cpVect.h" +#include "cpBB.h" +#include "cpTransform.h" +#include "cpSpatialIndex.h" + +#include "cpArbiter.h" + +#include "cpBody.h" +#include "cpShape.h" +#include "cpPolyShape.h" + +#include "cpConstraint.h" + +#include "cpSpace.h" + +// Chipmunk 7.0.3 +#define CP_VERSION_MAJOR 7 +#define CP_VERSION_MINOR 0 +#define CP_VERSION_RELEASE 3 + +/// Version string. +CP_EXPORT extern const char *cpVersionString; + +/// Calculate the moment of inertia for a circle. +/// @c r1 and @c r2 are the inner and outer diameters. A solid circle has an inner diameter of 0. +CP_EXPORT cpFloat cpMomentForCircle(cpFloat m, cpFloat r1, cpFloat r2, cpVect offset); + +/// Calculate area of a hollow circle. +/// @c r1 and @c r2 are the inner and outer diameters. A solid circle has an inner diameter of 0. +CP_EXPORT cpFloat cpAreaForCircle(cpFloat r1, cpFloat r2); + +/// Calculate the moment of inertia for a line segment. +/// Beveling radius is not supported. +CP_EXPORT cpFloat cpMomentForSegment(cpFloat m, cpVect a, cpVect b, cpFloat radius); + +/// Calculate the area of a fattened (capsule shaped) line segment. +CP_EXPORT cpFloat cpAreaForSegment(cpVect a, cpVect b, cpFloat radius); + +/// Calculate the moment of inertia for a solid polygon shape assuming it's center of gravity is at it's centroid. The offset is added to each vertex. +CP_EXPORT cpFloat cpMomentForPoly(cpFloat m, int count, const cpVect *verts, cpVect offset, cpFloat radius); + +/// Calculate the signed area of a polygon. A Clockwise winding gives positive area. +/// This is probably backwards from what you expect, but matches Chipmunk's the winding for poly shapes. +CP_EXPORT cpFloat cpAreaForPoly(const int count, const cpVect *verts, cpFloat radius); + +/// Calculate the natural centroid of a polygon. +CP_EXPORT cpVect cpCentroidForPoly(const int count, const cpVect *verts); + +/// Calculate the moment of inertia for a solid box. +CP_EXPORT cpFloat cpMomentForBox(cpFloat m, cpFloat width, cpFloat height); + +/// Calculate the moment of inertia for a solid box. +CP_EXPORT cpFloat cpMomentForBox2(cpFloat m, cpBB box); + +/// Calculate the convex hull of a given set of points. Returns the count of points in the hull. +/// @c result must be a pointer to a @c cpVect array with at least @c count elements. If @c verts == @c result, then @c verts will be reduced inplace. +/// @c first is an optional pointer to an integer to store where the first vertex in the hull came from (i.e. verts[first] == result[0]) +/// @c tol is the allowed amount to shrink the hull when simplifying it. A tolerance of 0.0 creates an exact hull. +CP_EXPORT int cpConvexHull(int count, const cpVect *verts, cpVect *result, int *first, cpFloat tol); + +/// Convenience macro to work with cpConvexHull. +/// @c count and @c verts is the input array passed to cpConvexHull(). +/// @c count_var and @c verts_var are the names of the variables the macro creates to store the result. +/// The output vertex array is allocated on the stack using alloca() so it will be freed automatically, but cannot be returned from the current scope. +#define CP_CONVEX_HULL(__count__, __verts__, __count_var__, __verts_var__) \ +cpVect *__verts_var__ = (cpVect *)alloca(__count__*sizeof(cpVect)); \ +int __count_var__ = cpConvexHull(__count__, __verts__, __verts_var__, NULL, 0.0); \ + +/// Returns the closest point on the line segment ab, to the point p. +static inline cpVect +cpClosetPointOnSegment(const cpVect p, const cpVect a, const cpVect b) +{ + cpVect delta = cpvsub(a, b); + cpFloat t = cpfclamp01(cpvdot(delta, cpvsub(p, b))/cpvlengthsq(delta)); + return cpvadd(b, cpvmult(delta, t)); +} + +#if defined(__has_extension) +#if __has_extension(blocks) +// Define alternate block based alternatives for a few of the callback heavy functions. +// Collision handlers are post-step callbacks are not included to avoid memory management issues. +// If you want to use blocks for those and are aware of how to correctly manage the memory, the implementation is trivial. + +void cpSpaceEachBody_b(cpSpace *space, void (^block)(cpBody *body)); +void cpSpaceEachShape_b(cpSpace *space, void (^block)(cpShape *shape)); +void cpSpaceEachConstraint_b(cpSpace *space, void (^block)(cpConstraint *constraint)); + +void cpBodyEachShape_b(cpBody *body, void (^block)(cpShape *shape)); +void cpBodyEachConstraint_b(cpBody *body, void (^block)(cpConstraint *constraint)); +void cpBodyEachArbiter_b(cpBody *body, void (^block)(cpArbiter *arbiter)); + +typedef void (^cpSpacePointQueryBlock)(cpShape *shape, cpVect point, cpFloat distance, cpVect gradient); +void cpSpacePointQuery_b(cpSpace *space, cpVect point, cpFloat maxDistance, cpShapeFilter filter, cpSpacePointQueryBlock block); + +typedef void (^cpSpaceSegmentQueryBlock)(cpShape *shape, cpVect point, cpVect normal, cpFloat alpha); +void cpSpaceSegmentQuery_b(cpSpace *space, cpVect start, cpVect end, cpFloat radius, cpShapeFilter filter, cpSpaceSegmentQueryBlock block); + +typedef void (^cpSpaceBBQueryBlock)(cpShape *shape); +void cpSpaceBBQuery_b(cpSpace *space, cpBB bb, cpShapeFilter filter, cpSpaceBBQueryBlock block); + +typedef void (^cpSpaceShapeQueryBlock)(cpShape *shape, cpContactPointSet *points); +cpBool cpSpaceShapeQuery_b(cpSpace *space, cpShape *shape, cpSpaceShapeQueryBlock block); + +#endif +#endif + + +//@} + +#ifdef __cplusplus +} + +/* +static inline cpVect operator *(const cpVect v, const cpFloat s){return cpvmult(v, s);} +static inline cpVect operator +(const cpVect v1, const cpVect v2){return cpvadd(v1, v2);} +static inline cpVect operator -(const cpVect v1, const cpVect v2){return cpvsub(v1, v2);} +static inline cpBool operator ==(const cpVect v1, const cpVect v2){return cpveql(v1, v2);} +static inline cpVect operator -(const cpVect v){return cpvneg(v);} +*/ + +#endif +#endif diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_ffi.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_ffi.h new file mode 100644 index 0000000..86e3d9f --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_ffi.h @@ -0,0 +1,105 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#ifdef CHIPMUNK_FFI + +// Create non static inlined copies of Chipmunk functions, useful for working with dynamic FFIs +// For many languages, it may be faster to reimplement these functions natively instead. +// Note: This file should only be included by chipmunk.c. + +#ifdef _MSC_VER + #if _MSC_VER >= 1600 + #define MAKE_REF(name) CP_EXPORT decltype(name) *_##name = name + #else + #define MAKE_REF(name) + #endif +#else + #define MAKE_REF(name) __typeof__(name) *_##name = name +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +MAKE_REF(cpv); // makes a variable named _cpv that contains the function pointer for cpv() +MAKE_REF(cpveql); +MAKE_REF(cpvadd); +MAKE_REF(cpvneg); +MAKE_REF(cpvsub); +MAKE_REF(cpvmult); +MAKE_REF(cpvdot); +MAKE_REF(cpvcross); +MAKE_REF(cpvperp); +MAKE_REF(cpvrperp); +MAKE_REF(cpvproject); +MAKE_REF(cpvforangle); +MAKE_REF(cpvtoangle); +MAKE_REF(cpvrotate); +MAKE_REF(cpvunrotate); +MAKE_REF(cpvlengthsq); +MAKE_REF(cpvlength); +MAKE_REF(cpvlerp); +MAKE_REF(cpvnormalize); +MAKE_REF(cpvclamp); +MAKE_REF(cpvlerpconst); +MAKE_REF(cpvdist); +MAKE_REF(cpvdistsq); +MAKE_REF(cpvnear); + +MAKE_REF(cpfmax); +MAKE_REF(cpfmin); +MAKE_REF(cpfabs); +MAKE_REF(cpfclamp); +MAKE_REF(cpflerp); +MAKE_REF(cpflerpconst); + +MAKE_REF(cpBBNew); +MAKE_REF(cpBBNewForExtents); +MAKE_REF(cpBBNewForCircle); +MAKE_REF(cpBBIntersects); +MAKE_REF(cpBBContainsBB); +MAKE_REF(cpBBContainsVect); +MAKE_REF(cpBBMerge); +MAKE_REF(cpBBExpand); +MAKE_REF(cpBBCenter); +MAKE_REF(cpBBArea); +MAKE_REF(cpBBMergedArea); +MAKE_REF(cpBBSegmentQuery); +MAKE_REF(cpBBIntersectsSegment); +MAKE_REF(cpBBClampVect); + +MAKE_REF(cpSpatialIndexDestroy); +MAKE_REF(cpSpatialIndexCount); +MAKE_REF(cpSpatialIndexEach); +MAKE_REF(cpSpatialIndexContains); +MAKE_REF(cpSpatialIndexInsert); +MAKE_REF(cpSpatialIndexRemove); +MAKE_REF(cpSpatialIndexReindex); +MAKE_REF(cpSpatialIndexReindexObject); +MAKE_REF(cpSpatialIndexSegmentQuery); +MAKE_REF(cpSpatialIndexQuery); +MAKE_REF(cpSpatialIndexReindexQuery); + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_private.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_private.h new file mode 100644 index 0000000..e606ba1 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_private.h @@ -0,0 +1,344 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#ifndef CHIPMUNK_PRIVATE_H +#define CHIPMUNK_PRIVATE_H + +#include "chipmunk/chipmunk.h" +#include "chipmunk/chipmunk_structs.h" + +#define CP_HASH_COEF (3344921057ul) +#define CP_HASH_PAIR(A, B) ((cpHashValue)(A)*CP_HASH_COEF ^ (cpHashValue)(B)*CP_HASH_COEF) + +// TODO: Eww. Magic numbers. +#define MAGIC_EPSILON 1e-5 + + +//MARK: cpArray + +cpArray *cpArrayNew(int size); + +void cpArrayFree(cpArray *arr); + +void cpArrayPush(cpArray *arr, void *object); +void *cpArrayPop(cpArray *arr); +void cpArrayDeleteObj(cpArray *arr, void *obj); +cpBool cpArrayContains(cpArray *arr, void *ptr); + +void cpArrayFreeEach(cpArray *arr, void (freeFunc)(void*)); + + +//MARK: cpHashSet + +typedef cpBool (*cpHashSetEqlFunc)(const void *ptr, const void *elt); +typedef void *(*cpHashSetTransFunc)(const void *ptr, void *data); + +cpHashSet *cpHashSetNew(int size, cpHashSetEqlFunc eqlFunc); +void cpHashSetSetDefaultValue(cpHashSet *set, void *default_value); + +void cpHashSetFree(cpHashSet *set); + +int cpHashSetCount(cpHashSet *set); +const void *cpHashSetInsert(cpHashSet *set, cpHashValue hash, const void *ptr, cpHashSetTransFunc trans, void *data); +const void *cpHashSetRemove(cpHashSet *set, cpHashValue hash, const void *ptr); +const void *cpHashSetFind(cpHashSet *set, cpHashValue hash, const void *ptr); + +typedef void (*cpHashSetIteratorFunc)(void *elt, void *data); +void cpHashSetEach(cpHashSet *set, cpHashSetIteratorFunc func, void *data); + +typedef cpBool (*cpHashSetFilterFunc)(void *elt, void *data); +void cpHashSetFilter(cpHashSet *set, cpHashSetFilterFunc func, void *data); + + +//MARK: Bodies + +void cpBodyAddShape(cpBody *body, cpShape *shape); +void cpBodyRemoveShape(cpBody *body, cpShape *shape); + +//void cpBodyAccumulateMassForShape(cpBody *body, cpShape *shape); +void cpBodyAccumulateMassFromShapes(cpBody *body); + +void cpBodyRemoveConstraint(cpBody *body, cpConstraint *constraint); + + +//MARK: Spatial Index Functions + +cpSpatialIndex *cpSpatialIndexInit(cpSpatialIndex *index, cpSpatialIndexClass *klass, cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex); + + +//MARK: Arbiters + +cpArbiter* cpArbiterInit(cpArbiter *arb, cpShape *a, cpShape *b); + +static inline struct cpArbiterThread * +cpArbiterThreadForBody(cpArbiter *arb, cpBody *body) +{ + return (arb->body_a == body ? &arb->thread_a : &arb->thread_b); +} + +void cpArbiterUnthread(cpArbiter *arb); + +void cpArbiterUpdate(cpArbiter *arb, struct cpCollisionInfo *info, cpSpace *space); +void cpArbiterPreStep(cpArbiter *arb, cpFloat dt, cpFloat bias, cpFloat slop); +void cpArbiterApplyCachedImpulse(cpArbiter *arb, cpFloat dt_coef); +void cpArbiterApplyImpulse(cpArbiter *arb); + + +//MARK: Shapes/Collisions + +cpShape *cpShapeInit(cpShape *shape, const cpShapeClass *klass, cpBody *body, struct cpShapeMassInfo massInfo); + +static inline cpBool +cpShapeActive(cpShape *shape) +{ + // checks if the shape is added to a shape list. + // TODO could this just check the space now? + return (shape->prev || (shape->body && shape->body->shapeList == shape)); +} + +// Note: This function returns contact points with r1/r2 in absolute coordinates, not body relative. +struct cpCollisionInfo cpCollide(const cpShape *a, const cpShape *b, cpCollisionID id, struct cpContact *contacts); + +static inline void +CircleSegmentQuery(cpShape *shape, cpVect center, cpFloat r1, cpVect a, cpVect b, cpFloat r2, cpSegmentQueryInfo *info) +{ + cpVect da = cpvsub(a, center); + cpVect db = cpvsub(b, center); + cpFloat rsum = r1 + r2; + + cpFloat qa = cpvdot(da, da) - 2.0f*cpvdot(da, db) + cpvdot(db, db); + cpFloat qb = cpvdot(da, db) - cpvdot(da, da); + cpFloat det = qb*qb - qa*(cpvdot(da, da) - rsum*rsum); + + if(det >= 0.0f){ + cpFloat t = (-qb - cpfsqrt(det))/(qa); + if(0.0f<= t && t <= 1.0f){ + cpVect n = cpvnormalize(cpvlerp(da, db, t)); + + info->shape = shape; + info->point = cpvsub(cpvlerp(a, b, t), cpvmult(n, r2)); + info->normal = n; + info->alpha = t; + } + } +} + +static inline cpBool +cpShapeFilterReject(cpShapeFilter a, cpShapeFilter b) +{ + // Reject the collision if: + return ( + // They are in the same non-zero group. + (a.group != 0 && a.group == b.group) || + // One of the category/mask combinations fails. + (a.categories & b.mask) == 0 || + (b.categories & a.mask) == 0 + ); +} + +void cpLoopIndexes(const cpVect *verts, int count, int *start, int *end); + + +//MARK: Constraints +// TODO naming conventions here + +void cpConstraintInit(cpConstraint *constraint, const struct cpConstraintClass *klass, cpBody *a, cpBody *b); + +static inline void +cpConstraintActivateBodies(cpConstraint *constraint) +{ + cpBody *a = constraint->a; cpBodyActivate(a); + cpBody *b = constraint->b; cpBodyActivate(b); +} + +static inline cpVect +relative_velocity(cpBody *a, cpBody *b, cpVect r1, cpVect r2){ + cpVect v1_sum = cpvadd(a->v, cpvmult(cpvperp(r1), a->w)); + cpVect v2_sum = cpvadd(b->v, cpvmult(cpvperp(r2), b->w)); + + return cpvsub(v2_sum, v1_sum); +} + +static inline cpFloat +normal_relative_velocity(cpBody *a, cpBody *b, cpVect r1, cpVect r2, cpVect n){ + return cpvdot(relative_velocity(a, b, r1, r2), n); +} + +static inline void +apply_impulse(cpBody *body, cpVect j, cpVect r){ + body->v = cpvadd(body->v, cpvmult(j, body->m_inv)); + body->w += body->i_inv*cpvcross(r, j); +} + +static inline void +apply_impulses(cpBody *a , cpBody *b, cpVect r1, cpVect r2, cpVect j) +{ + apply_impulse(a, cpvneg(j), r1); + apply_impulse(b, j, r2); +} + +static inline void +apply_bias_impulse(cpBody *body, cpVect j, cpVect r) +{ + body->v_bias = cpvadd(body->v_bias, cpvmult(j, body->m_inv)); + body->w_bias += body->i_inv*cpvcross(r, j); +} + +static inline void +apply_bias_impulses(cpBody *a , cpBody *b, cpVect r1, cpVect r2, cpVect j) +{ + apply_bias_impulse(a, cpvneg(j), r1); + apply_bias_impulse(b, j, r2); +} + +static inline cpFloat +k_scalar_body(cpBody *body, cpVect r, cpVect n) +{ + cpFloat rcn = cpvcross(r, n); + return body->m_inv + body->i_inv*rcn*rcn; +} + +static inline cpFloat +k_scalar(cpBody *a, cpBody *b, cpVect r1, cpVect r2, cpVect n) +{ + cpFloat value = k_scalar_body(a, r1, n) + k_scalar_body(b, r2, n); + cpAssertSoft(value != 0.0, "Unsolvable collision or constraint."); + + return value; +} + +static inline cpMat2x2 +k_tensor(cpBody *a, cpBody *b, cpVect r1, cpVect r2) +{ + cpFloat m_sum = a->m_inv + b->m_inv; + + // start with Identity*m_sum + cpFloat k11 = m_sum, k12 = 0.0f; + cpFloat k21 = 0.0f, k22 = m_sum; + + // add the influence from r1 + cpFloat a_i_inv = a->i_inv; + cpFloat r1xsq = r1.x * r1.x * a_i_inv; + cpFloat r1ysq = r1.y * r1.y * a_i_inv; + cpFloat r1nxy = -r1.x * r1.y * a_i_inv; + k11 += r1ysq; k12 += r1nxy; + k21 += r1nxy; k22 += r1xsq; + + // add the influnce from r2 + cpFloat b_i_inv = b->i_inv; + cpFloat r2xsq = r2.x * r2.x * b_i_inv; + cpFloat r2ysq = r2.y * r2.y * b_i_inv; + cpFloat r2nxy = -r2.x * r2.y * b_i_inv; + k11 += r2ysq; k12 += r2nxy; + k21 += r2nxy; k22 += r2xsq; + + // invert + cpFloat det = k11*k22 - k12*k21; + cpAssertSoft(det != 0.0, "Unsolvable constraint."); + + cpFloat det_inv = 1.0f/det; + return cpMat2x2New( + k22*det_inv, -k12*det_inv, + -k21*det_inv, k11*det_inv + ); +} + +static inline cpFloat +bias_coef(cpFloat errorBias, cpFloat dt) +{ + return 1.0f - cpfpow(errorBias, dt); +} + + +//MARK: Spaces + +#define cpAssertSpaceUnlocked(space) \ + cpAssertHard(!space->locked, \ + "This operation cannot be done safely during a call to cpSpaceStep() or during a query. " \ + "Put these calls into a post-step callback." \ + ); + +void cpSpaceSetStaticBody(cpSpace *space, cpBody *body); + +extern cpCollisionHandler cpCollisionHandlerDoNothing; + +void cpSpaceProcessComponents(cpSpace *space, cpFloat dt); + +void cpSpacePushFreshContactBuffer(cpSpace *space); +struct cpContact *cpContactBufferGetArray(cpSpace *space); +void cpSpacePushContacts(cpSpace *space, int count); + +cpPostStepCallback *cpSpaceGetPostStepCallback(cpSpace *space, void *key); + +cpBool cpSpaceArbiterSetFilter(cpArbiter *arb, cpSpace *space); +void cpSpaceFilterArbiters(cpSpace *space, cpBody *body, cpShape *filter); + +void cpSpaceActivateBody(cpSpace *space, cpBody *body); +void cpSpaceLock(cpSpace *space); +void cpSpaceUnlock(cpSpace *space, cpBool runPostStep); + +static inline void +cpSpaceUncacheArbiter(cpSpace *space, cpArbiter *arb) +{ + const cpShape *a = arb->a, *b = arb->b; + const cpShape *shape_pair[] = {a, b}; + cpHashValue arbHashID = CP_HASH_PAIR((cpHashValue)a, (cpHashValue)b); + cpHashSetRemove(space->cachedArbiters, arbHashID, shape_pair); + cpArrayDeleteObj(space->arbiters, arb); +} + +static inline cpArray * +cpSpaceArrayForBodyType(cpSpace *space, cpBodyType type) +{ + return (type == CP_BODY_TYPE_STATIC ? space->staticBodies : space->dynamicBodies); +} + +void cpShapeUpdateFunc(cpShape *shape, void *unused); +cpCollisionID cpSpaceCollideShapes(cpShape *a, cpShape *b, cpCollisionID id, cpSpace *space); + + +//MARK: Foreach loops + +static inline cpConstraint * +cpConstraintNext(cpConstraint *node, cpBody *body) +{ + return (node->a == body ? node->next_a : node->next_b); +} + +#define CP_BODY_FOREACH_CONSTRAINT(bdy, var)\ + for(cpConstraint *var = bdy->constraintList; var; var = cpConstraintNext(var, bdy)) + +static inline cpArbiter * +cpArbiterNext(cpArbiter *node, cpBody *body) +{ + return (node->body_a == body ? node->thread_a.next : node->thread_b.next); +} + +#define CP_BODY_FOREACH_ARBITER(bdy, var)\ + for(cpArbiter *var = bdy->arbiterList; var; var = cpArbiterNext(var, bdy)) + +#define CP_BODY_FOREACH_SHAPE(body, var)\ + for(cpShape *var = body->shapeList; var; var = var->next) + +#define CP_BODY_FOREACH_COMPONENT(root, var)\ + for(cpBody *var = root; var; var = var->sleeping.next) + +#endif diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_structs.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_structs.h new file mode 100644 index 0000000..d8b1e6f --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_structs.h @@ -0,0 +1,450 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +// All of the struct definitions for Chipmunk should be considered part of the private API. +// However, it is very valuable to know the struct sizes for preallocating memory. + +#ifndef CHIPMUNK_STRUCTS_H +#define CHIPMUNK_STRUCTS_H + +#include "chipmunk/chipmunk.h" + +struct cpArray { + int num, max; + void **arr; +}; + +struct cpBody { + // Integration functions + cpBodyVelocityFunc velocity_func; + cpBodyPositionFunc position_func; + + // mass and it's inverse + cpFloat m; + cpFloat m_inv; + + // moment of inertia and it's inverse + cpFloat i; + cpFloat i_inv; + + // center of gravity + cpVect cog; + + // position, velocity, force + cpVect p; + cpVect v; + cpVect f; + + // Angle, angular velocity, torque (radians) + cpFloat a; + cpFloat w; + cpFloat t; + + cpTransform transform; + + cpDataPointer userData; + + // "pseudo-velocities" used for eliminating overlap. + // Erin Catto has some papers that talk about what these are. + cpVect v_bias; + cpFloat w_bias; + + cpSpace *space; + + cpShape *shapeList; + cpArbiter *arbiterList; + cpConstraint *constraintList; + + struct { + cpBody *root; + cpBody *next; + cpFloat idleTime; + } sleeping; +}; + +enum cpArbiterState { + // Arbiter is active and its the first collision. + CP_ARBITER_STATE_FIRST_COLLISION, + // Arbiter is active and its not the first collision. + CP_ARBITER_STATE_NORMAL, + // Collision has been explicitly ignored. + // Either by returning false from a begin collision handler or calling cpArbiterIgnore(). + CP_ARBITER_STATE_IGNORE, + // Collison is no longer active. A space will cache an arbiter for up to cpSpace.collisionPersistence more steps. + CP_ARBITER_STATE_CACHED, + // Collison arbiter is invalid because one of the shapes was removed. + CP_ARBITER_STATE_INVALIDATED, +}; + +struct cpArbiterThread { + struct cpArbiter *next, *prev; +}; + +struct cpContact { + cpVect r1, r2; + + cpFloat nMass, tMass; + cpFloat bounce; // TODO: look for an alternate bounce solution. + + cpFloat jnAcc, jtAcc, jBias; + cpFloat bias; + + cpHashValue hash; +}; + +struct cpCollisionInfo { + const cpShape *a, *b; + cpCollisionID id; + + cpVect n; + + int count; + // TODO Should this be a unique struct type? + struct cpContact *arr; +}; + +struct cpArbiter { + cpFloat e; + cpFloat u; + cpVect surface_vr; + + cpDataPointer data; + + const cpShape *a, *b; + cpBody *body_a, *body_b; + struct cpArbiterThread thread_a, thread_b; + + int count; + struct cpContact *contacts; + cpVect n; + + // Regular, wildcard A and wildcard B collision handlers. + cpCollisionHandler *handler, *handlerA, *handlerB; + cpBool swapped; + + cpTimestamp stamp; + enum cpArbiterState state; +}; + +struct cpShapeMassInfo { + cpFloat m; + cpFloat i; + cpVect cog; + cpFloat area; +}; + +typedef enum cpShapeType{ + CP_CIRCLE_SHAPE, + CP_SEGMENT_SHAPE, + CP_POLY_SHAPE, + CP_NUM_SHAPES +} cpShapeType; + +typedef cpBB (*cpShapeCacheDataImpl)(cpShape *shape, cpTransform transform); +typedef void (*cpShapeDestroyImpl)(cpShape *shape); +typedef void (*cpShapePointQueryImpl)(const cpShape *shape, cpVect p, cpPointQueryInfo *info); +typedef void (*cpShapeSegmentQueryImpl)(const cpShape *shape, cpVect a, cpVect b, cpFloat radius, cpSegmentQueryInfo *info); + +typedef struct cpShapeClass cpShapeClass; + +struct cpShapeClass { + cpShapeType type; + + cpShapeCacheDataImpl cacheData; + cpShapeDestroyImpl destroy; + cpShapePointQueryImpl pointQuery; + cpShapeSegmentQueryImpl segmentQuery; +}; + +struct cpShape { + const cpShapeClass *klass; + + cpSpace *space; + cpBody *body; + struct cpShapeMassInfo massInfo; + cpBB bb; + + cpBool sensor; + + cpFloat e; + cpFloat u; + cpVect surfaceV; + + cpDataPointer userData; + + cpCollisionType type; + cpShapeFilter filter; + + cpShape *next; + cpShape *prev; + + cpHashValue hashid; +}; + +struct cpCircleShape { + cpShape shape; + + cpVect c, tc; + cpFloat r; +}; + +struct cpSegmentShape { + cpShape shape; + + cpVect a, b, n; + cpVect ta, tb, tn; + cpFloat r; + + cpVect a_tangent, b_tangent; +}; + +struct cpSplittingPlane { + cpVect v0, n; +}; + +#define CP_POLY_SHAPE_INLINE_ALLOC 6 + +struct cpPolyShape { + cpShape shape; + + cpFloat r; + + int count; + // The untransformed planes are appended at the end of the transformed planes. + struct cpSplittingPlane *planes; + + // Allocate a small number of splitting planes internally for simple poly. + struct cpSplittingPlane _planes[2*CP_POLY_SHAPE_INLINE_ALLOC]; +}; + +typedef void (*cpConstraintPreStepImpl)(cpConstraint *constraint, cpFloat dt); +typedef void (*cpConstraintApplyCachedImpulseImpl)(cpConstraint *constraint, cpFloat dt_coef); +typedef void (*cpConstraintApplyImpulseImpl)(cpConstraint *constraint, cpFloat dt); +typedef cpFloat (*cpConstraintGetImpulseImpl)(cpConstraint *constraint); + +typedef struct cpConstraintClass { + cpConstraintPreStepImpl preStep; + cpConstraintApplyCachedImpulseImpl applyCachedImpulse; + cpConstraintApplyImpulseImpl applyImpulse; + cpConstraintGetImpulseImpl getImpulse; +} cpConstraintClass; + +struct cpConstraint { + const cpConstraintClass *klass; + + cpSpace *space; + + cpBody *a, *b; + cpConstraint *next_a, *next_b; + + cpFloat maxForce; + cpFloat errorBias; + cpFloat maxBias; + + cpBool collideBodies; + + cpConstraintPreSolveFunc preSolve; + cpConstraintPostSolveFunc postSolve; + + cpDataPointer userData; +}; + +struct cpPinJoint { + cpConstraint constraint; + cpVect anchorA, anchorB; + cpFloat dist; + + cpVect r1, r2; + cpVect n; + cpFloat nMass; + + cpFloat jnAcc; + cpFloat bias; +}; + +struct cpSlideJoint { + cpConstraint constraint; + cpVect anchorA, anchorB; + cpFloat min, max; + + cpVect r1, r2; + cpVect n; + cpFloat nMass; + + cpFloat jnAcc; + cpFloat bias; +}; + +struct cpPivotJoint { + cpConstraint constraint; + cpVect anchorA, anchorB; + + cpVect r1, r2; + cpMat2x2 k; + + cpVect jAcc; + cpVect bias; +}; + +struct cpGrooveJoint { + cpConstraint constraint; + cpVect grv_n, grv_a, grv_b; + cpVect anchorB; + + cpVect grv_tn; + cpFloat clamp; + cpVect r1, r2; + cpMat2x2 k; + + cpVect jAcc; + cpVect bias; +}; + +struct cpDampedSpring { + cpConstraint constraint; + cpVect anchorA, anchorB; + cpFloat restLength; + cpFloat stiffness; + cpFloat damping; + cpDampedSpringForceFunc springForceFunc; + + cpFloat target_vrn; + cpFloat v_coef; + + cpVect r1, r2; + cpFloat nMass; + cpVect n; + + cpFloat jAcc; +}; + +struct cpDampedRotarySpring { + cpConstraint constraint; + cpFloat restAngle; + cpFloat stiffness; + cpFloat damping; + cpDampedRotarySpringTorqueFunc springTorqueFunc; + + cpFloat target_wrn; + cpFloat w_coef; + + cpFloat iSum; + cpFloat jAcc; +}; + +struct cpRotaryLimitJoint { + cpConstraint constraint; + cpFloat min, max; + + cpFloat iSum; + + cpFloat bias; + cpFloat jAcc; +}; + +struct cpRatchetJoint { + cpConstraint constraint; + cpFloat angle, phase, ratchet; + + cpFloat iSum; + + cpFloat bias; + cpFloat jAcc; +}; + +struct cpGearJoint { + cpConstraint constraint; + cpFloat phase, ratio; + cpFloat ratio_inv; + + cpFloat iSum; + + cpFloat bias; + cpFloat jAcc; +}; + +struct cpSimpleMotor { + cpConstraint constraint; + cpFloat rate; + + cpFloat iSum; + + cpFloat jAcc; +}; + +typedef struct cpContactBufferHeader cpContactBufferHeader; +typedef void (*cpSpaceArbiterApplyImpulseFunc)(cpArbiter *arb); + +struct cpSpace { + int iterations; + + cpVect gravity; + cpFloat damping; + + cpFloat idleSpeedThreshold; + cpFloat sleepTimeThreshold; + + cpFloat collisionSlop; + cpFloat collisionBias; + cpTimestamp collisionPersistence; + + cpDataPointer userData; + + cpTimestamp stamp; + cpFloat curr_dt; + + cpArray *dynamicBodies; + cpArray *staticBodies; + cpArray *rousedBodies; + cpArray *sleepingComponents; + + cpHashValue shapeIDCounter; + cpSpatialIndex *staticShapes; + cpSpatialIndex *dynamicShapes; + + cpArray *constraints; + + cpArray *arbiters; + cpContactBufferHeader *contactBuffersHead; + cpHashSet *cachedArbiters; + cpArray *pooledArbiters; + + cpArray *allocatedBuffers; + unsigned int locked; + + cpBool usesWildcards; + cpHashSet *collisionHandlers; + cpCollisionHandler defaultHandler; + + cpBool skipPostStep; + cpArray *postStepCallbacks; + + cpBody *staticBody; + cpBody _staticBody; +}; + +typedef struct cpPostStepCallback { + cpPostStepFunc func; + void *key; + void *data; +} cpPostStepCallback; + +#endif diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_types.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_types.h new file mode 100644 index 0000000..9544da8 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_types.h @@ -0,0 +1,268 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#ifndef CHIPMUNK_TYPES_H +#define CHIPMUNK_TYPES_H + +#include +#include +#include + +#ifdef __APPLE__ + #include "TargetConditionals.h" +#endif + +// Use CGTypes by default on iOS and Mac. +// Also enables usage of doubles on 64 bit. +// Performance is usually very comparable when the CPU cache is well utilised. +#if (TARGET_OS_IPHONE || TARGET_OS_MAC) && (!defined CP_USE_CGTYPES) + #define CP_USE_CGTYPES 1 +#endif + +#if CP_USE_CGTYPES + #if TARGET_OS_IPHONE + #include + #include + #elif TARGET_OS_MAC + #include + #endif + + #if defined(__LP64__) && __LP64__ + #define CP_USE_DOUBLES 1 + #else + #define CP_USE_DOUBLES 0 + #endif +#endif + +#ifndef CP_USE_DOUBLES + // Use doubles by default for higher precision. + #define CP_USE_DOUBLES 1 +#endif + +/// @defgroup basicTypes Basic Types +/// Most of these types can be configured at compile time. +/// @{ + +#if CP_USE_DOUBLES +/// Chipmunk's floating point type. +/// Can be reconfigured at compile time. + typedef double cpFloat; + #define cpfsqrt sqrt + #define cpfsin sin + #define cpfcos cos + #define cpfacos acos + #define cpfatan2 atan2 + #define cpfmod fmod + #define cpfexp exp + #define cpfpow pow + #define cpffloor floor + #define cpfceil ceil + #define CPFLOAT_MIN DBL_MIN +#else + typedef float cpFloat; + #define cpfsqrt sqrtf + #define cpfsin sinf + #define cpfcos cosf + #define cpfacos acosf + #define cpfatan2 atan2f + #define cpfmod fmodf + #define cpfexp expf + #define cpfpow powf + #define cpffloor floorf + #define cpfceil ceilf + #define CPFLOAT_MIN FLT_MIN +#endif + +#ifndef INFINITY + #ifdef _MSC_VER + union MSVC_EVIL_FLOAT_HACK + { + unsigned __int8 Bytes[4]; + float Value; + }; + static union MSVC_EVIL_FLOAT_HACK INFINITY_HACK = {{0x00, 0x00, 0x80, 0x7F}}; + #define INFINITY (INFINITY_HACK.Value) + #endif + + #ifdef __GNUC__ + #define INFINITY (__builtin_inf()) + #endif + + #ifndef INFINITY + #define INFINITY (1e1000) + #endif +#endif + + +#define CP_PI ((cpFloat)3.14159265358979323846264338327950288) + + +/// Return the max of two cpFloats. +static inline cpFloat cpfmax(cpFloat a, cpFloat b) +{ + return (a > b) ? a : b; +} + +/// Return the min of two cpFloats. +static inline cpFloat cpfmin(cpFloat a, cpFloat b) +{ + return (a < b) ? a : b; +} + +/// Return the absolute value of a cpFloat. +static inline cpFloat cpfabs(cpFloat f) +{ + return (f < 0) ? -f : f; +} + +/// Clamp @c f to be between @c min and @c max. +static inline cpFloat cpfclamp(cpFloat f, cpFloat min, cpFloat max) +{ + return cpfmin(cpfmax(f, min), max); +} + +/// Clamp @c f to be between 0 and 1. +static inline cpFloat cpfclamp01(cpFloat f) +{ + return cpfmax(0.0f, cpfmin(f, 1.0f)); +} + + + +/// Linearly interpolate (or extrapolate) between @c f1 and @c f2 by @c t percent. +static inline cpFloat cpflerp(cpFloat f1, cpFloat f2, cpFloat t) +{ + return f1*(1.0f - t) + f2*t; +} + +/// Linearly interpolate from @c f1 to @c f2 by no more than @c d. +static inline cpFloat cpflerpconst(cpFloat f1, cpFloat f2, cpFloat d) +{ + return f1 + cpfclamp(f2 - f1, -d, d); +} + +/// Hash value type. +#ifdef CP_HASH_VALUE_TYPE + typedef CP_HASH_VALUE_TYPE cpHashValue; +#else + typedef uintptr_t cpHashValue; +#endif + +/// Type used internally to cache colliding object info for cpCollideShapes(). +/// Should be at least 32 bits. +typedef uint32_t cpCollisionID; + +// Oh C, how we love to define our own boolean types to get compiler compatibility +/// Chipmunk's boolean type. +#ifdef CP_BOOL_TYPE + typedef CP_BOOL_TYPE cpBool; +#else + typedef unsigned char cpBool; +#endif + +#ifndef cpTrue +/// true value. + #define cpTrue 1 +#endif + +#ifndef cpFalse +/// false value. + #define cpFalse 0 +#endif + +#ifdef CP_DATA_POINTER_TYPE + typedef CP_DATA_POINTER_TYPE cpDataPointer; +#else +/// Type used for user data pointers. + typedef void * cpDataPointer; +#endif + +#ifdef CP_COLLISION_TYPE_TYPE + typedef CP_COLLISION_TYPE_TYPE cpCollisionType; +#else +/// Type used for cpSpace.collision_type. + typedef uintptr_t cpCollisionType; +#endif + +#ifdef CP_GROUP_TYPE + typedef CP_GROUP_TYPE cpGroup; +#else +/// Type used for cpShape.group. + typedef uintptr_t cpGroup; +#endif + +#ifdef CP_BITMASK_TYPE + typedef CP_BITMASK_TYPE cpBitmask; +#else +/// Type used for cpShapeFilter category and mask. + typedef unsigned int cpBitmask; +#endif + +#ifdef CP_TIMESTAMP_TYPE + typedef CP_TIMESTAMP_TYPE cpTimestamp; +#else +/// Type used for various timestamps in Chipmunk. + typedef unsigned int cpTimestamp; +#endif + +#ifndef CP_NO_GROUP +/// Value for cpShape.group signifying that a shape is in no group. + #define CP_NO_GROUP ((cpGroup)0) +#endif + +#ifndef CP_ALL_CATEGORIES +/// Value for cpShape.layers signifying that a shape is in every layer. + #define CP_ALL_CATEGORIES (~(cpBitmask)0) +#endif + +#ifndef CP_WILDCARD_COLLISION_TYPE +/// cpCollisionType value internally reserved for hashing wildcard handlers. + #define CP_WILDCARD_COLLISION_TYPE (~(cpCollisionType)0) +#endif + +/// @} + +// CGPoints are structurally the same, and allow +// easy interoperability with other Cocoa libraries +#if CP_USE_CGTYPES + typedef CGPoint cpVect; +#else +/// Chipmunk's 2D vector type. +/// @addtogroup cpVect + typedef struct cpVect{cpFloat x,y;} cpVect; +#endif + +#if CP_USE_CGTYPES + typedef CGAffineTransform cpTransform; +#else + /// Column major affine transform. + typedef struct cpTransform { + cpFloat a, b, c, d, tx, ty; + } cpTransform; +#endif + +// NUKE +typedef struct cpMat2x2 { + // Row major [[a, b][c d]] + cpFloat a, b, c, d; +} cpMat2x2; + +#endif diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_unsafe.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_unsafe.h new file mode 100644 index 0000000..990bd01 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/chipmunk_unsafe.h @@ -0,0 +1,66 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/* This header defines a number of "unsafe" operations on Chipmunk objects. + * In this case "unsafe" is referring to operations which may reduce the + * physical accuracy or numerical stability of the simulation, but will not + * cause crashes. + * + * The prime example is mutating collision shapes. Chipmunk does not support + * this directly. Mutating shapes using this API will caused objects in contact + * to be pushed apart using Chipmunk's overlap solver, but not using real + * persistent velocities. Probably not what you meant, but perhaps close enough. + */ + +/// @defgroup unsafe Chipmunk Unsafe Shape Operations +/// These functions are used for mutating collision shapes. +/// Chipmunk does not have any way to get velocity information on changing shapes, +/// so the results will be unrealistic. You must explicity include the chipmunk_unsafe.h header to use them. +/// @{ + +#ifndef CHIPMUNK_UNSAFE_H +#define CHIPMUNK_UNSAFE_H + +#ifdef __cplusplus +extern "C" { +#endif + +/// Set the radius of a circle shape. +CP_EXPORT void cpCircleShapeSetRadius(cpShape *shape, cpFloat radius); +/// Set the offset of a circle shape. +CP_EXPORT void cpCircleShapeSetOffset(cpShape *shape, cpVect offset); + +/// Set the endpoints of a segment shape. +CP_EXPORT void cpSegmentShapeSetEndpoints(cpShape *shape, cpVect a, cpVect b); +/// Set the radius of a segment shape. +CP_EXPORT void cpSegmentShapeSetRadius(cpShape *shape, cpFloat radius); + +/// Set the vertexes of a poly shape. +CP_EXPORT void cpPolyShapeSetVerts(cpShape *shape, int count, cpVect *verts, cpTransform transform); +CP_EXPORT void cpPolyShapeSetVertsRaw(cpShape *shape, int count, cpVect *verts); +/// Set the radius of a poly shape. +CP_EXPORT void cpPolyShapeSetRadius(cpShape *shape, cpFloat radius); + +#ifdef __cplusplus +} +#endif +#endif +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpArbiter.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpArbiter.h new file mode 100644 index 0000000..1dc130a --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpArbiter.h @@ -0,0 +1,145 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpArbiter cpArbiter +/// The cpArbiter struct tracks pairs of colliding shapes. +/// They are also used in conjuction with collision handler callbacks +/// allowing you to retrieve information on the collision or change it. +/// A unique arbiter value is used for each pair of colliding objects. It persists until the shapes separate. +/// @{ + +#define CP_MAX_CONTACTS_PER_ARBITER 2 + +/// Get the restitution (elasticity) that will be applied to the pair of colliding objects. +CP_EXPORT cpFloat cpArbiterGetRestitution(const cpArbiter *arb); +/// Override the restitution (elasticity) that will be applied to the pair of colliding objects. +CP_EXPORT void cpArbiterSetRestitution(cpArbiter *arb, cpFloat restitution); +/// Get the friction coefficient that will be applied to the pair of colliding objects. +CP_EXPORT cpFloat cpArbiterGetFriction(const cpArbiter *arb); +/// Override the friction coefficient that will be applied to the pair of colliding objects. +CP_EXPORT void cpArbiterSetFriction(cpArbiter *arb, cpFloat friction); + +// Get the relative surface velocity of the two shapes in contact. +CP_EXPORT cpVect cpArbiterGetSurfaceVelocity(cpArbiter *arb); + +// Override the relative surface velocity of the two shapes in contact. +// By default this is calculated to be the difference of the two surface velocities clamped to the tangent plane. +CP_EXPORT void cpArbiterSetSurfaceVelocity(cpArbiter *arb, cpVect vr); + +/// Get the user data pointer associated with this pair of colliding objects. +CP_EXPORT cpDataPointer cpArbiterGetUserData(const cpArbiter *arb); +/// Set a user data point associated with this pair of colliding objects. +/// If you need to perform any cleanup for this pointer, you must do it yourself, in the separate callback for instance. +CP_EXPORT void cpArbiterSetUserData(cpArbiter *arb, cpDataPointer userData); + +/// Calculate the total impulse including the friction that was applied by this arbiter. +/// This function should only be called from a post-solve, post-step or cpBodyEachArbiter callback. +CP_EXPORT cpVect cpArbiterTotalImpulse(const cpArbiter *arb); +/// Calculate the amount of energy lost in a collision including static, but not dynamic friction. +/// This function should only be called from a post-solve, post-step or cpBodyEachArbiter callback. +CP_EXPORT cpFloat cpArbiterTotalKE(const cpArbiter *arb); + +/// Mark a collision pair to be ignored until the two objects separate. +/// Pre-solve and post-solve callbacks will not be called, but the separate callback will be called. +CP_EXPORT cpBool cpArbiterIgnore(cpArbiter *arb); + +/// Return the colliding shapes involved for this arbiter. +/// The order of their cpSpace.collision_type values will match +/// the order set when the collision handler was registered. +CP_EXPORT void cpArbiterGetShapes(const cpArbiter *arb, cpShape **a, cpShape **b); + +/// A macro shortcut for defining and retrieving the shapes from an arbiter. +#define CP_ARBITER_GET_SHAPES(__arb__, __a__, __b__) cpShape *__a__, *__b__; cpArbiterGetShapes(__arb__, &__a__, &__b__); + +/// Return the colliding bodies involved for this arbiter. +/// The order of the cpSpace.collision_type the bodies are associated with values will match +/// the order set when the collision handler was registered. +CP_EXPORT void cpArbiterGetBodies(const cpArbiter *arb, cpBody **a, cpBody **b); + +/// A macro shortcut for defining and retrieving the bodies from an arbiter. +#define CP_ARBITER_GET_BODIES(__arb__, __a__, __b__) cpBody *__a__, *__b__; cpArbiterGetBodies(__arb__, &__a__, &__b__); + +/// A struct that wraps up the important collision data for an arbiter. +struct cpContactPointSet { + /// The number of contact points in the set. + int count; + + /// The normal of the collision. + cpVect normal; + + /// The array of contact points. + struct { + /// The position of the contact on the surface of each shape. + cpVect pointA, pointB; + /// Penetration distance of the two shapes. Overlapping means it will be negative. + /// This value is calculated as cpvdot(cpvsub(point2, point1), normal) and is ignored by cpArbiterSetContactPointSet(). + cpFloat distance; + } points[CP_MAX_CONTACTS_PER_ARBITER]; +}; + +/// Return a contact set from an arbiter. +CP_EXPORT cpContactPointSet cpArbiterGetContactPointSet(const cpArbiter *arb); + +/// Replace the contact point set for an arbiter. +/// This can be a very powerful feature, but use it with caution! +CP_EXPORT void cpArbiterSetContactPointSet(cpArbiter *arb, cpContactPointSet *set); + +/// Returns true if this is the first step a pair of objects started colliding. +CP_EXPORT cpBool cpArbiterIsFirstContact(const cpArbiter *arb); +/// Returns true if the separate callback is due to a shape being removed from the space. +CP_EXPORT cpBool cpArbiterIsRemoval(const cpArbiter *arb); + +/// Get the number of contact points for this arbiter. +CP_EXPORT int cpArbiterGetCount(const cpArbiter *arb); +/// Get the normal of the collision. +CP_EXPORT cpVect cpArbiterGetNormal(const cpArbiter *arb); +/// Get the position of the @c ith contact point on the surface of the first shape. +CP_EXPORT cpVect cpArbiterGetPointA(const cpArbiter *arb, int i); +/// Get the position of the @c ith contact point on the surface of the second shape. +CP_EXPORT cpVect cpArbiterGetPointB(const cpArbiter *arb, int i); +/// Get the depth of the @c ith contact point. +CP_EXPORT cpFloat cpArbiterGetDepth(const cpArbiter *arb, int i); + +/// If you want a custom callback to invoke the wildcard callback for the first collision type, you must call this function explicitly. +/// You must decide how to handle the wildcard's return value since it may disagree with the other wildcard handler's return value or your own. +CP_EXPORT cpBool cpArbiterCallWildcardBeginA(cpArbiter *arb, cpSpace *space); +/// If you want a custom callback to invoke the wildcard callback for the second collision type, you must call this function explicitly. +/// You must decide how to handle the wildcard's return value since it may disagree with the other wildcard handler's return value or your own. +CP_EXPORT cpBool cpArbiterCallWildcardBeginB(cpArbiter *arb, cpSpace *space); + +/// If you want a custom callback to invoke the wildcard callback for the first collision type, you must call this function explicitly. +/// You must decide how to handle the wildcard's return value since it may disagree with the other wildcard handler's return value or your own. +CP_EXPORT cpBool cpArbiterCallWildcardPreSolveA(cpArbiter *arb, cpSpace *space); +/// If you want a custom callback to invoke the wildcard callback for the second collision type, you must call this function explicitly. +/// You must decide how to handle the wildcard's return value since it may disagree with the other wildcard handler's return value or your own. +CP_EXPORT cpBool cpArbiterCallWildcardPreSolveB(cpArbiter *arb, cpSpace *space); + +/// If you want a custom callback to invoke the wildcard callback for the first collision type, you must call this function explicitly. +CP_EXPORT void cpArbiterCallWildcardPostSolveA(cpArbiter *arb, cpSpace *space); +/// If you want a custom callback to invoke the wildcard callback for the second collision type, you must call this function explicitly. +CP_EXPORT void cpArbiterCallWildcardPostSolveB(cpArbiter *arb, cpSpace *space); + +/// If you want a custom callback to invoke the wildcard callback for the first collision type, you must call this function explicitly. +CP_EXPORT void cpArbiterCallWildcardSeparateA(cpArbiter *arb, cpSpace *space); +/// If you want a custom callback to invoke the wildcard callback for the second collision type, you must call this function explicitly. +CP_EXPORT void cpArbiterCallWildcardSeparateB(cpArbiter *arb, cpSpace *space); + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpBB.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpBB.h new file mode 100644 index 0000000..8fc8704 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpBB.h @@ -0,0 +1,187 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#ifndef CHIPMUNK_BB_H +#define CHIPMUNK_BB_H + +#include "chipmunk_types.h" +#include "cpVect.h" + +/// @defgroup cpBBB cpBB +/// Chipmunk's axis-aligned 2D bounding box type along with a few handy routines. +/// @{ + +/// Chipmunk's axis-aligned 2D bounding box type. (left, bottom, right, top) +typedef struct cpBB{ + cpFloat l, b, r ,t; +} cpBB; + +/// Convenience constructor for cpBB structs. +static inline cpBB cpBBNew(const cpFloat l, const cpFloat b, const cpFloat r, const cpFloat t) +{ + cpBB bb = {l, b, r, t}; + return bb; +} + +/// Constructs a cpBB centered on a point with the given extents (half sizes). +static inline cpBB +cpBBNewForExtents(const cpVect c, const cpFloat hw, const cpFloat hh) +{ + return cpBBNew(c.x - hw, c.y - hh, c.x + hw, c.y + hh); +} + +/// Constructs a cpBB for a circle with the given position and radius. +static inline cpBB cpBBNewForCircle(const cpVect p, const cpFloat r) +{ + return cpBBNewForExtents(p, r, r); +} + +/// Returns true if @c a and @c b intersect. +static inline cpBool cpBBIntersects(const cpBB a, const cpBB b) +{ + return (a.l <= b.r && b.l <= a.r && a.b <= b.t && b.b <= a.t); +} + +/// Returns true if @c other lies completely within @c bb. +static inline cpBool cpBBContainsBB(const cpBB bb, const cpBB other) +{ + return (bb.l <= other.l && bb.r >= other.r && bb.b <= other.b && bb.t >= other.t); +} + +/// Returns true if @c bb contains @c v. +static inline cpBool cpBBContainsVect(const cpBB bb, const cpVect v) +{ + return (bb.l <= v.x && bb.r >= v.x && bb.b <= v.y && bb.t >= v.y); +} + +/// Returns a bounding box that holds both bounding boxes. +static inline cpBB cpBBMerge(const cpBB a, const cpBB b){ + return cpBBNew( + cpfmin(a.l, b.l), + cpfmin(a.b, b.b), + cpfmax(a.r, b.r), + cpfmax(a.t, b.t) + ); +} + +/// Returns a bounding box that holds both @c bb and @c v. +static inline cpBB cpBBExpand(const cpBB bb, const cpVect v){ + return cpBBNew( + cpfmin(bb.l, v.x), + cpfmin(bb.b, v.y), + cpfmax(bb.r, v.x), + cpfmax(bb.t, v.y) + ); +} + +/// Returns the center of a bounding box. +static inline cpVect +cpBBCenter(cpBB bb) +{ + return cpvlerp(cpv(bb.l, bb.b), cpv(bb.r, bb.t), 0.5f); +} + +/// Returns the area of the bounding box. +static inline cpFloat cpBBArea(cpBB bb) +{ + return (bb.r - bb.l)*(bb.t - bb.b); +} + +/// Merges @c a and @c b and returns the area of the merged bounding box. +static inline cpFloat cpBBMergedArea(cpBB a, cpBB b) +{ + return (cpfmax(a.r, b.r) - cpfmin(a.l, b.l))*(cpfmax(a.t, b.t) - cpfmin(a.b, b.b)); +} + +/// Returns the fraction along the segment query the cpBB is hit. Returns INFINITY if it doesn't hit. +static inline cpFloat cpBBSegmentQuery(cpBB bb, cpVect a, cpVect b) +{ + cpVect delta = cpvsub(b, a); + cpFloat tmin = -INFINITY, tmax = INFINITY; + + if(delta.x == 0.0f){ + if(a.x < bb.l || bb.r < a.x) return INFINITY; + } else { + cpFloat t1 = (bb.l - a.x)/delta.x; + cpFloat t2 = (bb.r - a.x)/delta.x; + tmin = cpfmax(tmin, cpfmin(t1, t2)); + tmax = cpfmin(tmax, cpfmax(t1, t2)); + } + + if(delta.y == 0.0f){ + if(a.y < bb.b || bb.t < a.y) return INFINITY; + } else { + cpFloat t1 = (bb.b - a.y)/delta.y; + cpFloat t2 = (bb.t - a.y)/delta.y; + tmin = cpfmax(tmin, cpfmin(t1, t2)); + tmax = cpfmin(tmax, cpfmax(t1, t2)); + } + + if(tmin <= tmax && 0.0f <= tmax && tmin <= 1.0f){ + return cpfmax(tmin, 0.0f); + } else { + return INFINITY; + } +} + +/// Return true if the bounding box intersects the line segment with ends @c a and @c b. +static inline cpBool cpBBIntersectsSegment(cpBB bb, cpVect a, cpVect b) +{ + return (cpBBSegmentQuery(bb, a, b) != INFINITY); +} + +/// Clamp a vector to a bounding box. +static inline cpVect +cpBBClampVect(const cpBB bb, const cpVect v) +{ + return cpv(cpfclamp(v.x, bb.l, bb.r), cpfclamp(v.y, bb.b, bb.t)); +} + +/// Wrap a vector to a bounding box. +static inline cpVect +cpBBWrapVect(const cpBB bb, const cpVect v) +{ + cpFloat dx = cpfabs(bb.r - bb.l); + cpFloat modx = cpfmod(v.x - bb.l, dx); + cpFloat x = (modx > 0.0f) ? modx : modx + dx; + + cpFloat dy = cpfabs(bb.t - bb.b); + cpFloat mody = cpfmod(v.y - bb.b, dy); + cpFloat y = (mody > 0.0f) ? mody : mody + dy; + + return cpv(x + bb.l, y + bb.b); +} + +/// Returns a bounding box offseted by @c v. +static inline cpBB +cpBBOffset(const cpBB bb, const cpVect v) +{ + return cpBBNew( + bb.l + v.x, + bb.b + v.y, + bb.r + v.x, + bb.t + v.y + ); +} + +///@} + +#endif diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpBody.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpBody.h new file mode 100644 index 0000000..7e6943d --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpBody.h @@ -0,0 +1,189 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpBody cpBody +/// Chipmunk's rigid body type. Rigid bodies hold the physical properties of an object like +/// it's mass, and position and velocity of it's center of gravity. They don't have an shape on their own. +/// They are given a shape by creating collision shapes (cpShape) that point to the body. +/// @{ + +typedef enum cpBodyType { + /// A dynamic body is one that is affected by gravity, forces, and collisions. + /// This is the default body type. + CP_BODY_TYPE_DYNAMIC, + /// A kinematic body is an infinite mass, user controlled body that is not affected by gravity, forces or collisions. + /// Instead the body only moves based on it's velocity. + /// Dynamic bodies collide normally with kinematic bodies, though the kinematic body will be unaffected. + /// Collisions between two kinematic bodies, or a kinematic body and a static body produce collision callbacks, but no collision response. + CP_BODY_TYPE_KINEMATIC, + /// A static body is a body that never (or rarely) moves. If you move a static body, you must call one of the cpSpaceReindex*() functions. + /// Chipmunk uses this information to optimize the collision detection. + /// Static bodies do not produce collision callbacks when colliding with other static bodies. + CP_BODY_TYPE_STATIC, +} cpBodyType; + +/// Rigid body velocity update function type. +typedef void (*cpBodyVelocityFunc)(cpBody *body, cpVect gravity, cpFloat damping, cpFloat dt); +/// Rigid body position update function type. +typedef void (*cpBodyPositionFunc)(cpBody *body, cpFloat dt); + +/// Allocate a cpBody. +CP_EXPORT cpBody* cpBodyAlloc(void); +/// Initialize a cpBody. +CP_EXPORT cpBody* cpBodyInit(cpBody *body, cpFloat mass, cpFloat moment); +/// Allocate and initialize a cpBody. +CP_EXPORT cpBody* cpBodyNew(cpFloat mass, cpFloat moment); + +/// Allocate and initialize a cpBody, and set it as a kinematic body. +CP_EXPORT cpBody* cpBodyNewKinematic(void); +/// Allocate and initialize a cpBody, and set it as a static body. +CP_EXPORT cpBody* cpBodyNewStatic(void); + +/// Destroy a cpBody. +CP_EXPORT void cpBodyDestroy(cpBody *body); +/// Destroy and free a cpBody. +CP_EXPORT void cpBodyFree(cpBody *body); + +// Defined in cpSpace.c +/// Wake up a sleeping or idle body. +CP_EXPORT void cpBodyActivate(cpBody *body); +/// Wake up any sleeping or idle bodies touching a static body. +CP_EXPORT void cpBodyActivateStatic(cpBody *body, cpShape *filter); + +/// Force a body to fall asleep immediately. +CP_EXPORT void cpBodySleep(cpBody *body); +/// Force a body to fall asleep immediately along with other bodies in a group. +CP_EXPORT void cpBodySleepWithGroup(cpBody *body, cpBody *group); + +/// Returns true if the body is sleeping. +CP_EXPORT cpBool cpBodyIsSleeping(const cpBody *body); + +/// Get the type of the body. +CP_EXPORT cpBodyType cpBodyGetType(cpBody *body); +/// Set the type of the body. +CP_EXPORT void cpBodySetType(cpBody *body, cpBodyType type); + +/// Get the space this body is added to. +CP_EXPORT cpSpace* cpBodyGetSpace(const cpBody *body); + +/// Get the mass of the body. +CP_EXPORT cpFloat cpBodyGetMass(const cpBody *body); +/// Set the mass of the body. +CP_EXPORT void cpBodySetMass(cpBody *body, cpFloat m); + +/// Get the moment of inertia of the body. +CP_EXPORT cpFloat cpBodyGetMoment(const cpBody *body); +/// Set the moment of inertia of the body. +CP_EXPORT void cpBodySetMoment(cpBody *body, cpFloat i); + +/// Set the position of a body. +CP_EXPORT cpVect cpBodyGetPosition(const cpBody *body); +/// Set the position of the body. +CP_EXPORT void cpBodySetPosition(cpBody *body, cpVect pos); + +/// Get the offset of the center of gravity in body local coordinates. +CP_EXPORT cpVect cpBodyGetCenterOfGravity(const cpBody *body); +/// Set the offset of the center of gravity in body local coordinates. +CP_EXPORT void cpBodySetCenterOfGravity(cpBody *body, cpVect cog); + +/// Get the velocity of the body. +CP_EXPORT cpVect cpBodyGetVelocity(const cpBody *body); +/// Set the velocity of the body. +CP_EXPORT void cpBodySetVelocity(cpBody *body, cpVect velocity); + +/// Get the force applied to the body for the next time step. +CP_EXPORT cpVect cpBodyGetForce(const cpBody *body); +/// Set the force applied to the body for the next time step. +CP_EXPORT void cpBodySetForce(cpBody *body, cpVect force); + +/// Get the angle of the body. +CP_EXPORT cpFloat cpBodyGetAngle(const cpBody *body); +/// Set the angle of a body. +CP_EXPORT void cpBodySetAngle(cpBody *body, cpFloat a); + +/// Get the angular velocity of the body. +CP_EXPORT cpFloat cpBodyGetAngularVelocity(const cpBody *body); +/// Set the angular velocity of the body. +CP_EXPORT void cpBodySetAngularVelocity(cpBody *body, cpFloat angularVelocity); + +/// Get the torque applied to the body for the next time step. +CP_EXPORT cpFloat cpBodyGetTorque(const cpBody *body); +/// Set the torque applied to the body for the next time step. +CP_EXPORT void cpBodySetTorque(cpBody *body, cpFloat torque); + +/// Get the rotation vector of the body. (The x basis vector of it's transform.) +CP_EXPORT cpVect cpBodyGetRotation(const cpBody *body); + +/// Get the user data pointer assigned to the body. +CP_EXPORT cpDataPointer cpBodyGetUserData(const cpBody *body); +/// Set the user data pointer assigned to the body. +CP_EXPORT void cpBodySetUserData(cpBody *body, cpDataPointer userData); + +/// Set the callback used to update a body's velocity. +CP_EXPORT void cpBodySetVelocityUpdateFunc(cpBody *body, cpBodyVelocityFunc velocityFunc); +/// Set the callback used to update a body's position. +/// NOTE: It's not generally recommended to override this unless you call the default position update function. +CP_EXPORT void cpBodySetPositionUpdateFunc(cpBody *body, cpBodyPositionFunc positionFunc); + +/// Default velocity integration function.. +CP_EXPORT void cpBodyUpdateVelocity(cpBody *body, cpVect gravity, cpFloat damping, cpFloat dt); +/// Default position integration function. +CP_EXPORT void cpBodyUpdatePosition(cpBody *body, cpFloat dt); + +/// Convert body relative/local coordinates to absolute/world coordinates. +CP_EXPORT cpVect cpBodyLocalToWorld(const cpBody *body, const cpVect point); +/// Convert body absolute/world coordinates to relative/local coordinates. +CP_EXPORT cpVect cpBodyWorldToLocal(const cpBody *body, const cpVect point); + +/// Apply a force to a body. Both the force and point are expressed in world coordinates. +CP_EXPORT void cpBodyApplyForceAtWorldPoint(cpBody *body, cpVect force, cpVect point); +/// Apply a force to a body. Both the force and point are expressed in body local coordinates. +CP_EXPORT void cpBodyApplyForceAtLocalPoint(cpBody *body, cpVect force, cpVect point); + +/// Apply an impulse to a body. Both the impulse and point are expressed in world coordinates. +CP_EXPORT void cpBodyApplyImpulseAtWorldPoint(cpBody *body, cpVect impulse, cpVect point); +/// Apply an impulse to a body. Both the impulse and point are expressed in body local coordinates. +CP_EXPORT void cpBodyApplyImpulseAtLocalPoint(cpBody *body, cpVect impulse, cpVect point); + +/// Get the velocity on a body (in world units) at a point on the body in world coordinates. +CP_EXPORT cpVect cpBodyGetVelocityAtWorldPoint(const cpBody *body, cpVect point); +/// Get the velocity on a body (in world units) at a point on the body in local coordinates. +CP_EXPORT cpVect cpBodyGetVelocityAtLocalPoint(const cpBody *body, cpVect point); + +/// Get the amount of kinetic energy contained by the body. +CP_EXPORT cpFloat cpBodyKineticEnergy(const cpBody *body); + +/// Body/shape iterator callback function type. +typedef void (*cpBodyShapeIteratorFunc)(cpBody *body, cpShape *shape, void *data); +/// Call @c func once for each shape attached to @c body and added to the space. +CP_EXPORT void cpBodyEachShape(cpBody *body, cpBodyShapeIteratorFunc func, void *data); + +/// Body/constraint iterator callback function type. +typedef void (*cpBodyConstraintIteratorFunc)(cpBody *body, cpConstraint *constraint, void *data); +/// Call @c func once for each constraint attached to @c body and added to the space. +CP_EXPORT void cpBodyEachConstraint(cpBody *body, cpBodyConstraintIteratorFunc func, void *data); + +/// Body/arbiter iterator callback function type. +typedef void (*cpBodyArbiterIteratorFunc)(cpBody *body, cpArbiter *arbiter, void *data); +/// Call @c func once for each arbiter that is currently active on the body. +CP_EXPORT void cpBodyEachArbiter(cpBody *body, cpBodyArbiterIteratorFunc func, void *data); + +///@} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpConstraint.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpConstraint.h new file mode 100644 index 0000000..b1a439f --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpConstraint.h @@ -0,0 +1,95 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpConstraint cpConstraint +/// @{ + +/// Callback function type that gets called before solving a joint. +typedef void (*cpConstraintPreSolveFunc)(cpConstraint *constraint, cpSpace *space); +/// Callback function type that gets called after solving a joint. +typedef void (*cpConstraintPostSolveFunc)(cpConstraint *constraint, cpSpace *space); + +/// Destroy a constraint. +CP_EXPORT void cpConstraintDestroy(cpConstraint *constraint); +/// Destroy and free a constraint. +CP_EXPORT void cpConstraintFree(cpConstraint *constraint); + +/// Get the cpSpace this constraint is added to. +CP_EXPORT cpSpace* cpConstraintGetSpace(const cpConstraint *constraint); + +/// Get the first body the constraint is attached to. +CP_EXPORT cpBody* cpConstraintGetBodyA(const cpConstraint *constraint); + +/// Get the second body the constraint is attached to. +CP_EXPORT cpBody* cpConstraintGetBodyB(const cpConstraint *constraint); + +/// Get the maximum force that this constraint is allowed to use. +CP_EXPORT cpFloat cpConstraintGetMaxForce(const cpConstraint *constraint); +/// Set the maximum force that this constraint is allowed to use. (defaults to INFINITY) +CP_EXPORT void cpConstraintSetMaxForce(cpConstraint *constraint, cpFloat maxForce); + +/// Get rate at which joint error is corrected. +CP_EXPORT cpFloat cpConstraintGetErrorBias(const cpConstraint *constraint); +/// Set rate at which joint error is corrected. +/// Defaults to pow(1.0 - 0.1, 60.0) meaning that it will +/// correct 10% of the error every 1/60th of a second. +CP_EXPORT void cpConstraintSetErrorBias(cpConstraint *constraint, cpFloat errorBias); + +/// Get the maximum rate at which joint error is corrected. +CP_EXPORT cpFloat cpConstraintGetMaxBias(const cpConstraint *constraint); +/// Set the maximum rate at which joint error is corrected. (defaults to INFINITY) +CP_EXPORT void cpConstraintSetMaxBias(cpConstraint *constraint, cpFloat maxBias); + +/// Get if the two bodies connected by the constraint are allowed to collide or not. +CP_EXPORT cpBool cpConstraintGetCollideBodies(const cpConstraint *constraint); +/// Set if the two bodies connected by the constraint are allowed to collide or not. (defaults to cpFalse) +CP_EXPORT void cpConstraintSetCollideBodies(cpConstraint *constraint, cpBool collideBodies); + +/// Get the pre-solve function that is called before the solver runs. +CP_EXPORT cpConstraintPreSolveFunc cpConstraintGetPreSolveFunc(const cpConstraint *constraint); +/// Set the pre-solve function that is called before the solver runs. +CP_EXPORT void cpConstraintSetPreSolveFunc(cpConstraint *constraint, cpConstraintPreSolveFunc preSolveFunc); + +/// Get the post-solve function that is called before the solver runs. +CP_EXPORT cpConstraintPostSolveFunc cpConstraintGetPostSolveFunc(const cpConstraint *constraint); +/// Set the post-solve function that is called before the solver runs. +CP_EXPORT void cpConstraintSetPostSolveFunc(cpConstraint *constraint, cpConstraintPostSolveFunc postSolveFunc); + +/// Get the user definable data pointer for this constraint +CP_EXPORT cpDataPointer cpConstraintGetUserData(const cpConstraint *constraint); +/// Set the user definable data pointer for this constraint +CP_EXPORT void cpConstraintSetUserData(cpConstraint *constraint, cpDataPointer userData); + +/// Get the last impulse applied by this constraint. +CP_EXPORT cpFloat cpConstraintGetImpulse(cpConstraint *constraint); + +#include "cpPinJoint.h" +#include "cpSlideJoint.h" +#include "cpPivotJoint.h" +#include "cpGrooveJoint.h" +#include "cpDampedSpring.h" +#include "cpDampedRotarySpring.h" +#include "cpRotaryLimitJoint.h" +#include "cpRatchetJoint.h" +#include "cpGearJoint.h" +#include "cpSimpleMotor.h" + +///@} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpDampedRotarySpring.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpDampedRotarySpring.h new file mode 100644 index 0000000..6f60e86 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpDampedRotarySpring.h @@ -0,0 +1,58 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpDampedRotarySpring cpDampedRotarySpring +/// @{ + +/// Check if a constraint is a damped rotary springs. +CP_EXPORT cpBool cpConstraintIsDampedRotarySpring(const cpConstraint *constraint); + +/// Function type used for damped rotary spring force callbacks. +typedef cpFloat (*cpDampedRotarySpringTorqueFunc)(struct cpConstraint *spring, cpFloat relativeAngle); + +/// Allocate a damped rotary spring. +CP_EXPORT cpDampedRotarySpring* cpDampedRotarySpringAlloc(void); +/// Initialize a damped rotary spring. +CP_EXPORT cpDampedRotarySpring* cpDampedRotarySpringInit(cpDampedRotarySpring *joint, cpBody *a, cpBody *b, cpFloat restAngle, cpFloat stiffness, cpFloat damping); +/// Allocate and initialize a damped rotary spring. +CP_EXPORT cpConstraint* cpDampedRotarySpringNew(cpBody *a, cpBody *b, cpFloat restAngle, cpFloat stiffness, cpFloat damping); + +/// Get the rest length of the spring. +CP_EXPORT cpFloat cpDampedRotarySpringGetRestAngle(const cpConstraint *constraint); +/// Set the rest length of the spring. +CP_EXPORT void cpDampedRotarySpringSetRestAngle(cpConstraint *constraint, cpFloat restAngle); + +/// Get the stiffness of the spring in force/distance. +CP_EXPORT cpFloat cpDampedRotarySpringGetStiffness(const cpConstraint *constraint); +/// Set the stiffness of the spring in force/distance. +CP_EXPORT void cpDampedRotarySpringSetStiffness(cpConstraint *constraint, cpFloat stiffness); + +/// Get the damping of the spring. +CP_EXPORT cpFloat cpDampedRotarySpringGetDamping(const cpConstraint *constraint); +/// Set the damping of the spring. +CP_EXPORT void cpDampedRotarySpringSetDamping(cpConstraint *constraint, cpFloat damping); + +/// Get the damping of the spring. +CP_EXPORT cpDampedRotarySpringTorqueFunc cpDampedRotarySpringGetSpringTorqueFunc(const cpConstraint *constraint); +/// Set the damping of the spring. +CP_EXPORT void cpDampedRotarySpringSetSpringTorqueFunc(cpConstraint *constraint, cpDampedRotarySpringTorqueFunc springTorqueFunc); + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpDampedSpring.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpDampedSpring.h new file mode 100644 index 0000000..b332fc7 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpDampedSpring.h @@ -0,0 +1,68 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpDampedSpring cpDampedSpring +/// @{ + +/// Check if a constraint is a slide joint. +CP_EXPORT cpBool cpConstraintIsDampedSpring(const cpConstraint *constraint); + +/// Function type used for damped spring force callbacks. +typedef cpFloat (*cpDampedSpringForceFunc)(cpConstraint *spring, cpFloat dist); + +/// Allocate a damped spring. +CP_EXPORT cpDampedSpring* cpDampedSpringAlloc(void); +/// Initialize a damped spring. +CP_EXPORT cpDampedSpring* cpDampedSpringInit(cpDampedSpring *joint, cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB, cpFloat restLength, cpFloat stiffness, cpFloat damping); +/// Allocate and initialize a damped spring. +CP_EXPORT cpConstraint* cpDampedSpringNew(cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB, cpFloat restLength, cpFloat stiffness, cpFloat damping); + +/// Get the location of the first anchor relative to the first body. +CP_EXPORT cpVect cpDampedSpringGetAnchorA(const cpConstraint *constraint); +/// Set the location of the first anchor relative to the first body. +CP_EXPORT void cpDampedSpringSetAnchorA(cpConstraint *constraint, cpVect anchorA); + +/// Get the location of the second anchor relative to the second body. +CP_EXPORT cpVect cpDampedSpringGetAnchorB(const cpConstraint *constraint); +/// Set the location of the second anchor relative to the second body. +CP_EXPORT void cpDampedSpringSetAnchorB(cpConstraint *constraint, cpVect anchorB); + +/// Get the rest length of the spring. +CP_EXPORT cpFloat cpDampedSpringGetRestLength(const cpConstraint *constraint); +/// Set the rest length of the spring. +CP_EXPORT void cpDampedSpringSetRestLength(cpConstraint *constraint, cpFloat restLength); + +/// Get the stiffness of the spring in force/distance. +CP_EXPORT cpFloat cpDampedSpringGetStiffness(const cpConstraint *constraint); +/// Set the stiffness of the spring in force/distance. +CP_EXPORT void cpDampedSpringSetStiffness(cpConstraint *constraint, cpFloat stiffness); + +/// Get the damping of the spring. +CP_EXPORT cpFloat cpDampedSpringGetDamping(const cpConstraint *constraint); +/// Set the damping of the spring. +CP_EXPORT void cpDampedSpringSetDamping(cpConstraint *constraint, cpFloat damping); + +/// Get the damping of the spring. +CP_EXPORT cpDampedSpringForceFunc cpDampedSpringGetSpringForceFunc(const cpConstraint *constraint); +/// Set the damping of the spring. +CP_EXPORT void cpDampedSpringSetSpringForceFunc(cpConstraint *constraint, cpDampedSpringForceFunc springForceFunc); + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpGearJoint.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpGearJoint.h new file mode 100644 index 0000000..8cd80e0 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpGearJoint.h @@ -0,0 +1,45 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpGearJoint cpGearJoint +/// @{ + +/// Check if a constraint is a damped rotary springs. +CP_EXPORT cpBool cpConstraintIsGearJoint(const cpConstraint *constraint); + +/// Allocate a gear joint. +CP_EXPORT cpGearJoint* cpGearJointAlloc(void); +/// Initialize a gear joint. +CP_EXPORT cpGearJoint* cpGearJointInit(cpGearJoint *joint, cpBody *a, cpBody *b, cpFloat phase, cpFloat ratio); +/// Allocate and initialize a gear joint. +CP_EXPORT cpConstraint* cpGearJointNew(cpBody *a, cpBody *b, cpFloat phase, cpFloat ratio); + +/// Get the phase offset of the gears. +CP_EXPORT cpFloat cpGearJointGetPhase(const cpConstraint *constraint); +/// Set the phase offset of the gears. +CP_EXPORT void cpGearJointSetPhase(cpConstraint *constraint, cpFloat phase); + +/// Get the angular distance of each ratchet. +CP_EXPORT cpFloat cpGearJointGetRatio(const cpConstraint *constraint); +/// Set the ratio of a gear joint. +CP_EXPORT void cpGearJointSetRatio(cpConstraint *constraint, cpFloat ratio); + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpGrooveJoint.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpGrooveJoint.h new file mode 100644 index 0000000..8bdafc1 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpGrooveJoint.h @@ -0,0 +1,50 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpGrooveJoint cpGrooveJoint +/// @{ + +/// Check if a constraint is a slide joint. +CP_EXPORT cpBool cpConstraintIsGrooveJoint(const cpConstraint *constraint); + +/// Allocate a groove joint. +CP_EXPORT cpGrooveJoint* cpGrooveJointAlloc(void); +/// Initialize a groove joint. +CP_EXPORT cpGrooveJoint* cpGrooveJointInit(cpGrooveJoint *joint, cpBody *a, cpBody *b, cpVect groove_a, cpVect groove_b, cpVect anchorB); +/// Allocate and initialize a groove joint. +CP_EXPORT cpConstraint* cpGrooveJointNew(cpBody *a, cpBody *b, cpVect groove_a, cpVect groove_b, cpVect anchorB); + +/// Get the first endpoint of the groove relative to the first body. +CP_EXPORT cpVect cpGrooveJointGetGrooveA(const cpConstraint *constraint); +/// Set the first endpoint of the groove relative to the first body. +CP_EXPORT void cpGrooveJointSetGrooveA(cpConstraint *constraint, cpVect grooveA); + +/// Get the first endpoint of the groove relative to the first body. +CP_EXPORT cpVect cpGrooveJointGetGrooveB(const cpConstraint *constraint); +/// Set the first endpoint of the groove relative to the first body. +CP_EXPORT void cpGrooveJointSetGrooveB(cpConstraint *constraint, cpVect grooveB); + +/// Get the location of the second anchor relative to the second body. +CP_EXPORT cpVect cpGrooveJointGetAnchorB(const cpConstraint *constraint); +/// Set the location of the second anchor relative to the second body. +CP_EXPORT void cpGrooveJointSetAnchorB(cpConstraint *constraint, cpVect anchorB); + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpHastySpace.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpHastySpace.h new file mode 100644 index 0000000..6de2283 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpHastySpace.h @@ -0,0 +1,27 @@ +// Copyright 2013 Howling Moon Software. All rights reserved. +// See http://chipmunk2d.net/legal.php for more information. + +/// cpHastySpace is exclusive to Chipmunk Pro +/// Currently it enables ARM NEON optimizations in the solver, but in the future will include other optimizations such as +/// a multi-threaded solver and multi-threaded collision broadphases. + +struct cpHastySpace; +typedef struct cpHastySpace cpHastySpace; + +/// Create a new hasty space. +/// On ARM platforms that support NEON, this will enable the vectorized solver. +/// cpHastySpace also supports multiple threads, but runs single threaded by default for determinism. +CP_EXPORT cpSpace *cpHastySpaceNew(void); +CP_EXPORT void cpHastySpaceFree(cpSpace *space); + +/// Set the number of threads to use for the solver. +/// Currently Chipmunk is limited to 2 threads as using more generally provides very minimal performance gains. +/// Passing 0 as the thread count on iOS or OS X will cause Chipmunk to automatically detect the number of threads it should use. +/// On other platforms passing 0 for the thread count will set 1 thread. +CP_EXPORT void cpHastySpaceSetThreads(cpSpace *space, unsigned long threads); + +/// Returns the number of threads the solver is using to run. +CP_EXPORT unsigned long cpHastySpaceGetThreads(cpSpace *space); + +/// When stepping a hasty space, you must use this function. +CP_EXPORT void cpHastySpaceStep(cpSpace *space, cpFloat dt); diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpMarch.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpMarch.h new file mode 100644 index 0000000..cc1f5c0 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpMarch.h @@ -0,0 +1,28 @@ +// Copyright 2013 Howling Moon Software. All rights reserved. +// See http://chipmunk2d.net/legal.php for more information. + +/// Function type used as a callback from the marching squares algorithm to sample an image function. +/// It passes you the point to sample and your context pointer, and you return the density. +typedef cpFloat (*cpMarchSampleFunc)(cpVect point, void *data); + +/// Function type used as a callback from the marching squares algorithm to output a line segment. +/// It passes you the two endpoints and your context pointer. +typedef void (*cpMarchSegmentFunc)(cpVect v0, cpVect v1, void *data); + +/// Trace an anti-aliased contour of an image along a particular threshold. +/// The given number of samples will be taken and spread across the bounding box area using the sampling function and context. +/// The segment function will be called for each segment detected that lies along the density contour for @c threshold. +CP_EXPORT void cpMarchSoft( + cpBB bb, unsigned long x_samples, unsigned long y_samples, cpFloat threshold, + cpMarchSegmentFunc segment, void *segment_data, + cpMarchSampleFunc sample, void *sample_data +); + +/// Trace an aliased curve of an image along a particular threshold. +/// The given number of samples will be taken and spread across the bounding box area using the sampling function and context. +/// The segment function will be called for each segment detected that lies along the density contour for @c threshold. +CP_EXPORT void cpMarchHard( + cpBB bb, unsigned long x_samples, unsigned long y_samples, cpFloat threshold, + cpMarchSegmentFunc segment, void *segment_data, + cpMarchSampleFunc sample, void *sample_data +); diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPinJoint.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPinJoint.h new file mode 100644 index 0000000..45aaa3e --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPinJoint.h @@ -0,0 +1,50 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpPinJoint cpPinJoint +/// @{ + +/// Check if a constraint is a pin joint. +CP_EXPORT cpBool cpConstraintIsPinJoint(const cpConstraint *constraint); + +/// Allocate a pin joint. +CP_EXPORT cpPinJoint* cpPinJointAlloc(void); +/// Initialize a pin joint. +CP_EXPORT cpPinJoint* cpPinJointInit(cpPinJoint *joint, cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB); +/// Allocate and initialize a pin joint. +CP_EXPORT cpConstraint* cpPinJointNew(cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB); + +/// Get the location of the first anchor relative to the first body. +CP_EXPORT cpVect cpPinJointGetAnchorA(const cpConstraint *constraint); +/// Set the location of the first anchor relative to the first body. +CP_EXPORT void cpPinJointSetAnchorA(cpConstraint *constraint, cpVect anchorA); + +/// Get the location of the second anchor relative to the second body. +CP_EXPORT cpVect cpPinJointGetAnchorB(const cpConstraint *constraint); +/// Set the location of the second anchor relative to the second body. +CP_EXPORT void cpPinJointSetAnchorB(cpConstraint *constraint, cpVect anchorB); + +/// Get the distance the joint will maintain between the two anchors. +CP_EXPORT cpFloat cpPinJointGetDist(const cpConstraint *constraint); +/// Set the distance the joint will maintain between the two anchors. +CP_EXPORT void cpPinJointSetDist(cpConstraint *constraint, cpFloat dist); + +///@} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPivotJoint.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPivotJoint.h new file mode 100644 index 0000000..4a620ef --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPivotJoint.h @@ -0,0 +1,47 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpPivotJoint cpPivotJoint +/// @{ + +/// Check if a constraint is a slide joint. +CP_EXPORT cpBool cpConstraintIsPivotJoint(const cpConstraint *constraint); + +/// Allocate a pivot joint +CP_EXPORT cpPivotJoint* cpPivotJointAlloc(void); +/// Initialize a pivot joint. +CP_EXPORT cpPivotJoint* cpPivotJointInit(cpPivotJoint *joint, cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB); +/// Allocate and initialize a pivot joint. +CP_EXPORT cpConstraint* cpPivotJointNew(cpBody *a, cpBody *b, cpVect pivot); +/// Allocate and initialize a pivot joint with specific anchors. +CP_EXPORT cpConstraint* cpPivotJointNew2(cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB); + +/// Get the location of the first anchor relative to the first body. +CP_EXPORT cpVect cpPivotJointGetAnchorA(const cpConstraint *constraint); +/// Set the location of the first anchor relative to the first body. +CP_EXPORT void cpPivotJointSetAnchorA(cpConstraint *constraint, cpVect anchorA); + +/// Get the location of the second anchor relative to the second body. +CP_EXPORT cpVect cpPivotJointGetAnchorB(const cpConstraint *constraint); +/// Set the location of the second anchor relative to the second body. +CP_EXPORT void cpPivotJointSetAnchorB(cpConstraint *constraint, cpVect anchorB); + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPolyShape.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPolyShape.h new file mode 100644 index 0000000..25f688b --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPolyShape.h @@ -0,0 +1,56 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpPolyShape cpPolyShape +/// @{ + +/// Allocate a polygon shape. +CP_EXPORT cpPolyShape* cpPolyShapeAlloc(void); +/// Initialize a polygon shape with rounded corners. +/// A convex hull will be created from the vertexes. +CP_EXPORT cpPolyShape* cpPolyShapeInit(cpPolyShape *poly, cpBody *body, int count, const cpVect *verts, cpTransform transform, cpFloat radius); +/// Initialize a polygon shape with rounded corners. +/// The vertexes must be convex with a counter-clockwise winding. +CP_EXPORT cpPolyShape* cpPolyShapeInitRaw(cpPolyShape *poly, cpBody *body, int count, const cpVect *verts, cpFloat radius); +/// Allocate and initialize a polygon shape with rounded corners. +/// A convex hull will be created from the vertexes. +CP_EXPORT cpShape* cpPolyShapeNew(cpBody *body, int count, const cpVect *verts, cpTransform transform, cpFloat radius); +/// Allocate and initialize a polygon shape with rounded corners. +/// The vertexes must be convex with a counter-clockwise winding. +CP_EXPORT cpShape* cpPolyShapeNewRaw(cpBody *body, int count, const cpVect *verts, cpFloat radius); + +/// Initialize a box shaped polygon shape with rounded corners. +CP_EXPORT cpPolyShape* cpBoxShapeInit(cpPolyShape *poly, cpBody *body, cpFloat width, cpFloat height, cpFloat radius); +/// Initialize an offset box shaped polygon shape with rounded corners. +CP_EXPORT cpPolyShape* cpBoxShapeInit2(cpPolyShape *poly, cpBody *body, cpBB box, cpFloat radius); +/// Allocate and initialize a box shaped polygon shape. +CP_EXPORT cpShape* cpBoxShapeNew(cpBody *body, cpFloat width, cpFloat height, cpFloat radius); +/// Allocate and initialize an offset box shaped polygon shape. +CP_EXPORT cpShape* cpBoxShapeNew2(cpBody *body, cpBB box, cpFloat radius); + +/// Get the number of verts in a polygon shape. +CP_EXPORT int cpPolyShapeGetCount(const cpShape *shape); +/// Get the @c ith vertex of a polygon shape. +CP_EXPORT cpVect cpPolyShapeGetVert(const cpShape *shape, int index); +/// Get the radius of a polygon shape. +CP_EXPORT cpFloat cpPolyShapeGetRadius(const cpShape *shape); + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPolyline.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPolyline.h new file mode 100644 index 0000000..9a6ebed --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpPolyline.h @@ -0,0 +1,70 @@ +// Copyright 2013 Howling Moon Software. All rights reserved. +// See http://chipmunk2d.net/legal.php for more information. + +// Polylines are just arrays of vertexes. +// They are looped if the first vertex is equal to the last. +// cpPolyline structs are intended to be passed by value and destroyed when you are done with them. +typedef struct cpPolyline { + int count, capacity; + cpVect verts[]; +} cpPolyline; + +/// Destroy and free a polyline instance. +CP_EXPORT void cpPolylineFree(cpPolyline *line); + +/// Returns true if the first vertex is equal to the last. +CP_EXPORT cpBool cpPolylineIsClosed(cpPolyline *line); + +/** + Returns a copy of a polyline simplified by using the Douglas-Peucker algorithm. + This works very well on smooth or gently curved shapes, but not well on straight edged or angular shapes. +*/ +CP_EXPORT cpPolyline *cpPolylineSimplifyCurves(cpPolyline *line, cpFloat tol); + +/** + Returns a copy of a polyline simplified by discarding "flat" vertexes. + This works well on straight edged or angular shapes, not as well on smooth shapes. +*/ +CP_EXPORT cpPolyline *cpPolylineSimplifyVertexes(cpPolyline *line, cpFloat tol); + +/// Get the convex hull of a polyline as a looped polyline. +CP_EXPORT cpPolyline *cpPolylineToConvexHull(cpPolyline *line, cpFloat tol); + + +/// Polyline sets are collections of polylines, generally built by cpMarchSoft() or cpMarchHard(). +typedef struct cpPolylineSet { + int count, capacity; + cpPolyline **lines; +} cpPolylineSet; + +/// Allocate a new polyline set. +CP_EXPORT cpPolylineSet *cpPolylineSetAlloc(void); + +/// Initialize a new polyline set. +CP_EXPORT cpPolylineSet *cpPolylineSetInit(cpPolylineSet *set); + +/// Allocate and initialize a polyline set. +CP_EXPORT cpPolylineSet *cpPolylineSetNew(void); + +/// Destroy a polyline set. +CP_EXPORT void cpPolylineSetDestroy(cpPolylineSet *set, cpBool freePolylines); + +/// Destroy and free a polyline set. +CP_EXPORT void cpPolylineSetFree(cpPolylineSet *set, cpBool freePolylines); + +/** + Add a line segment to a polyline set. + A segment will either start a new polyline, join two others, or add to or loop an existing polyline. + This is mostly intended to be used as a callback directly from cpMarchSoft() or cpMarchHard(). +*/ +CP_EXPORT void cpPolylineSetCollectSegment(cpVect v0, cpVect v1, cpPolylineSet *lines); + +/** + Get an approximate convex decomposition from a polyline. + Returns a cpPolylineSet of convex hulls that match the original shape to within 'tol'. + NOTE: If the input is a self intersecting polygon, the output might end up overly simplified. +*/ + +CP_EXPORT cpPolylineSet *cpPolylineConvexDecomposition(cpPolyline *line, cpFloat tol); + +#define cpPolylineConvexDecomposition_BETA cpPolylineConvexDecomposition diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpRatchetJoint.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpRatchetJoint.h new file mode 100644 index 0000000..3ed4c91 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpRatchetJoint.h @@ -0,0 +1,50 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpRatchetJoint cpRatchetJoint +/// @{ + +/// Check if a constraint is a damped rotary springs. +CP_EXPORT cpBool cpConstraintIsRatchetJoint(const cpConstraint *constraint); + +/// Allocate a ratchet joint. +CP_EXPORT cpRatchetJoint* cpRatchetJointAlloc(void); +/// Initialize a ratched joint. +CP_EXPORT cpRatchetJoint* cpRatchetJointInit(cpRatchetJoint *joint, cpBody *a, cpBody *b, cpFloat phase, cpFloat ratchet); +/// Allocate and initialize a ratchet joint. +CP_EXPORT cpConstraint* cpRatchetJointNew(cpBody *a, cpBody *b, cpFloat phase, cpFloat ratchet); + +/// Get the angle of the current ratchet tooth. +CP_EXPORT cpFloat cpRatchetJointGetAngle(const cpConstraint *constraint); +/// Set the angle of the current ratchet tooth. +CP_EXPORT void cpRatchetJointSetAngle(cpConstraint *constraint, cpFloat angle); + +/// Get the phase offset of the ratchet. +CP_EXPORT cpFloat cpRatchetJointGetPhase(const cpConstraint *constraint); +/// Get the phase offset of the ratchet. +CP_EXPORT void cpRatchetJointSetPhase(cpConstraint *constraint, cpFloat phase); + +/// Get the angular distance of each ratchet. +CP_EXPORT cpFloat cpRatchetJointGetRatchet(const cpConstraint *constraint); +/// Set the angular distance of each ratchet. +CP_EXPORT void cpRatchetJointSetRatchet(cpConstraint *constraint, cpFloat ratchet); + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpRobust.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpRobust.h new file mode 100644 index 0000000..e4b2c42 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpRobust.h @@ -0,0 +1,11 @@ +#include "chipmunk/cpVect.h" + +// This is a private header for functions (currently just one) that need strict floating point results. +// It was easier to put this in it's own file than to fiddle with 4 different compiler specific pragmas or attributes. +// "Fast math" should be disabled here. + +// Check if c is to the left of segment (a, b). +cpBool cpCheckPointGreater(const cpVect a, const cpVect b, const cpVect c); + +// Check if p is behind one of v0 or v1 on axis n. +cpBool cpCheckAxis(cpVect v0, cpVect v1, cpVect p, cpVect n); diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpRotaryLimitJoint.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpRotaryLimitJoint.h new file mode 100644 index 0000000..fac7ad8 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpRotaryLimitJoint.h @@ -0,0 +1,45 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpRotaryLimitJoint cpRotaryLimitJoint +/// @{ + +/// Check if a constraint is a damped rotary springs. +CP_EXPORT cpBool cpConstraintIsRotaryLimitJoint(const cpConstraint *constraint); + +/// Allocate a damped rotary limit joint. +CP_EXPORT cpRotaryLimitJoint* cpRotaryLimitJointAlloc(void); +/// Initialize a damped rotary limit joint. +CP_EXPORT cpRotaryLimitJoint* cpRotaryLimitJointInit(cpRotaryLimitJoint *joint, cpBody *a, cpBody *b, cpFloat min, cpFloat max); +/// Allocate and initialize a damped rotary limit joint. +CP_EXPORT cpConstraint* cpRotaryLimitJointNew(cpBody *a, cpBody *b, cpFloat min, cpFloat max); + +/// Get the minimum distance the joint will maintain between the two anchors. +CP_EXPORT cpFloat cpRotaryLimitJointGetMin(const cpConstraint *constraint); +/// Set the minimum distance the joint will maintain between the two anchors. +CP_EXPORT void cpRotaryLimitJointSetMin(cpConstraint *constraint, cpFloat min); + +/// Get the maximum distance the joint will maintain between the two anchors. +CP_EXPORT cpFloat cpRotaryLimitJointGetMax(const cpConstraint *constraint); +/// Set the maximum distance the joint will maintain between the two anchors. +CP_EXPORT void cpRotaryLimitJointSetMax(cpConstraint *constraint, cpFloat max); + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpShape.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpShape.h new file mode 100644 index 0000000..c78ed05 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpShape.h @@ -0,0 +1,199 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpShape cpShape +/// The cpShape struct defines the shape of a rigid body. +/// @{ + +/// Point query info struct. +typedef struct cpPointQueryInfo { + /// The nearest shape, NULL if no shape was within range. + const cpShape *shape; + /// The closest point on the shape's surface. (in world space coordinates) + cpVect point; + /// The distance to the point. The distance is negative if the point is inside the shape. + cpFloat distance; + /// The gradient of the signed distance function. + /// The value should be similar to info.p/info.d, but accurate even for very small values of info.d. + cpVect gradient; +} cpPointQueryInfo; + +/// Segment query info struct. +typedef struct cpSegmentQueryInfo { + /// The shape that was hit, or NULL if no collision occured. + const cpShape *shape; + /// The point of impact. + cpVect point; + /// The normal of the surface hit. + cpVect normal; + /// The normalized distance along the query segment in the range [0, 1]. + cpFloat alpha; +} cpSegmentQueryInfo; + +/// Fast collision filtering type that is used to determine if two objects collide before calling collision or query callbacks. +typedef struct cpShapeFilter { + /// Two objects with the same non-zero group value do not collide. + /// This is generally used to group objects in a composite object together to disable self collisions. + cpGroup group; + /// A bitmask of user definable categories that this object belongs to. + /// The category/mask combinations of both objects in a collision must agree for a collision to occur. + cpBitmask categories; + /// A bitmask of user definable category types that this object object collides with. + /// The category/mask combinations of both objects in a collision must agree for a collision to occur. + cpBitmask mask; +} cpShapeFilter; + +/// Collision filter value for a shape that will collide with anything except CP_SHAPE_FILTER_NONE. +static const cpShapeFilter CP_SHAPE_FILTER_ALL = {CP_NO_GROUP, CP_ALL_CATEGORIES, CP_ALL_CATEGORIES}; +/// Collision filter value for a shape that does not collide with anything. +static const cpShapeFilter CP_SHAPE_FILTER_NONE = {CP_NO_GROUP, ~CP_ALL_CATEGORIES, ~CP_ALL_CATEGORIES}; + +/// Create a new collision filter. +static inline cpShapeFilter +cpShapeFilterNew(cpGroup group, cpBitmask categories, cpBitmask mask) +{ + cpShapeFilter filter = {group, categories, mask}; + return filter; +} + +/// Destroy a shape. +CP_EXPORT void cpShapeDestroy(cpShape *shape); +/// Destroy and Free a shape. +CP_EXPORT void cpShapeFree(cpShape *shape); + +/// Update, cache and return the bounding box of a shape based on the body it's attached to. +CP_EXPORT cpBB cpShapeCacheBB(cpShape *shape); +/// Update, cache and return the bounding box of a shape with an explicit transformation. +CP_EXPORT cpBB cpShapeUpdate(cpShape *shape, cpTransform transform); + +/// Perform a nearest point query. It finds the closest point on the surface of shape to a specific point. +/// The value returned is the distance between the points. A negative distance means the point is inside the shape. +CP_EXPORT cpFloat cpShapePointQuery(const cpShape *shape, cpVect p, cpPointQueryInfo *out); + +/// Perform a segment query against a shape. @c info must be a pointer to a valid cpSegmentQueryInfo structure. +CP_EXPORT cpBool cpShapeSegmentQuery(const cpShape *shape, cpVect a, cpVect b, cpFloat radius, cpSegmentQueryInfo *info); + +/// Return contact information about two shapes. +CP_EXPORT cpContactPointSet cpShapesCollide(const cpShape *a, const cpShape *b); + +/// The cpSpace this body is added to. +CP_EXPORT cpSpace* cpShapeGetSpace(const cpShape *shape); + +/// The cpBody this shape is connected to. +CP_EXPORT cpBody* cpShapeGetBody(const cpShape *shape); +/// Set the cpBody this shape is connected to. +/// Can only be used if the shape is not currently added to a space. +CP_EXPORT void cpShapeSetBody(cpShape *shape, cpBody *body); + +/// Get the mass of the shape if you are having Chipmunk calculate mass properties for you. +CP_EXPORT cpFloat cpShapeGetMass(cpShape *shape); +/// Set the mass of this shape to have Chipmunk calculate mass properties for you. +CP_EXPORT void cpShapeSetMass(cpShape *shape, cpFloat mass); + +/// Get the density of the shape if you are having Chipmunk calculate mass properties for you. +CP_EXPORT cpFloat cpShapeGetDensity(cpShape *shape); +/// Set the density of this shape to have Chipmunk calculate mass properties for you. +CP_EXPORT void cpShapeSetDensity(cpShape *shape, cpFloat density); + +/// Get the calculated moment of inertia for this shape. +CP_EXPORT cpFloat cpShapeGetMoment(cpShape *shape); +/// Get the calculated area of this shape. +CP_EXPORT cpFloat cpShapeGetArea(cpShape *shape); +/// Get the centroid of this shape. +CP_EXPORT cpVect cpShapeGetCenterOfGravity(cpShape *shape); + +/// Get the bounding box that contains the shape given it's current position and angle. +CP_EXPORT cpBB cpShapeGetBB(const cpShape *shape); + +/// Get if the shape is set to be a sensor or not. +CP_EXPORT cpBool cpShapeGetSensor(const cpShape *shape); +/// Set if the shape is a sensor or not. +CP_EXPORT void cpShapeSetSensor(cpShape *shape, cpBool sensor); + +/// Get the elasticity of this shape. +CP_EXPORT cpFloat cpShapeGetElasticity(const cpShape *shape); +/// Set the elasticity of this shape. +CP_EXPORT void cpShapeSetElasticity(cpShape *shape, cpFloat elasticity); + +/// Get the friction of this shape. +CP_EXPORT cpFloat cpShapeGetFriction(const cpShape *shape); +/// Set the friction of this shape. +CP_EXPORT void cpShapeSetFriction(cpShape *shape, cpFloat friction); + +/// Get the surface velocity of this shape. +CP_EXPORT cpVect cpShapeGetSurfaceVelocity(const cpShape *shape); +/// Set the surface velocity of this shape. +CP_EXPORT void cpShapeSetSurfaceVelocity(cpShape *shape, cpVect surfaceVelocity); + +/// Get the user definable data pointer of this shape. +CP_EXPORT cpDataPointer cpShapeGetUserData(const cpShape *shape); +/// Set the user definable data pointer of this shape. +CP_EXPORT void cpShapeSetUserData(cpShape *shape, cpDataPointer userData); + +/// Set the collision type of this shape. +CP_EXPORT cpCollisionType cpShapeGetCollisionType(const cpShape *shape); +/// Get the collision type of this shape. +CP_EXPORT void cpShapeSetCollisionType(cpShape *shape, cpCollisionType collisionType); + +/// Get the collision filtering parameters of this shape. +CP_EXPORT cpShapeFilter cpShapeGetFilter(const cpShape *shape); +/// Set the collision filtering parameters of this shape. +CP_EXPORT void cpShapeSetFilter(cpShape *shape, cpShapeFilter filter); + + +/// @} +/// @defgroup cpCircleShape cpCircleShape + +/// Allocate a circle shape. +CP_EXPORT cpCircleShape* cpCircleShapeAlloc(void); +/// Initialize a circle shape. +CP_EXPORT cpCircleShape* cpCircleShapeInit(cpCircleShape *circle, cpBody *body, cpFloat radius, cpVect offset); +/// Allocate and initialize a circle shape. +CP_EXPORT cpShape* cpCircleShapeNew(cpBody *body, cpFloat radius, cpVect offset); + +/// Get the offset of a circle shape. +CP_EXPORT cpVect cpCircleShapeGetOffset(const cpShape *shape); +/// Get the radius of a circle shape. +CP_EXPORT cpFloat cpCircleShapeGetRadius(const cpShape *shape); + +/// @} +/// @defgroup cpSegmentShape cpSegmentShape + +/// Allocate a segment shape. +CP_EXPORT cpSegmentShape* cpSegmentShapeAlloc(void); +/// Initialize a segment shape. +CP_EXPORT cpSegmentShape* cpSegmentShapeInit(cpSegmentShape *seg, cpBody *body, cpVect a, cpVect b, cpFloat radius); +/// Allocate and initialize a segment shape. +CP_EXPORT cpShape* cpSegmentShapeNew(cpBody *body, cpVect a, cpVect b, cpFloat radius); + +/// Let Chipmunk know about the geometry of adjacent segments to avoid colliding with endcaps. +CP_EXPORT void cpSegmentShapeSetNeighbors(cpShape *shape, cpVect prev, cpVect next); + +/// Get the first endpoint of a segment shape. +CP_EXPORT cpVect cpSegmentShapeGetA(const cpShape *shape); +/// Get the second endpoint of a segment shape. +CP_EXPORT cpVect cpSegmentShapeGetB(const cpShape *shape); +/// Get the normal of a segment shape. +CP_EXPORT cpVect cpSegmentShapeGetNormal(const cpShape *shape); +/// Get the first endpoint of a segment shape. +CP_EXPORT cpFloat cpSegmentShapeGetRadius(const cpShape *shape); + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSimpleMotor.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSimpleMotor.h new file mode 100644 index 0000000..811b011 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSimpleMotor.h @@ -0,0 +1,43 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpSimpleMotor cpSimpleMotor +/// @{ + +/// Opaque struct type for damped rotary springs. +typedef struct cpSimpleMotor cpSimpleMotor; + +/// Check if a constraint is a damped rotary springs. +CP_EXPORT cpBool cpConstraintIsSimpleMotor(const cpConstraint *constraint); + +/// Allocate a simple motor. +CP_EXPORT cpSimpleMotor* cpSimpleMotorAlloc(void); +/// initialize a simple motor. +CP_EXPORT cpSimpleMotor* cpSimpleMotorInit(cpSimpleMotor *joint, cpBody *a, cpBody *b, cpFloat rate); +/// Allocate and initialize a simple motor. +CP_EXPORT cpConstraint* cpSimpleMotorNew(cpBody *a, cpBody *b, cpFloat rate); + +/// Get the rate of the motor. +CP_EXPORT cpFloat cpSimpleMotorGetRate(const cpConstraint *constraint); +/// Set the rate of the motor. +CP_EXPORT void cpSimpleMotorSetRate(cpConstraint *constraint, cpFloat rate); + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSlideJoint.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSlideJoint.h new file mode 100644 index 0000000..c41f9a4 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSlideJoint.h @@ -0,0 +1,55 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpSlideJoint cpSlideJoint +/// @{ + +/// Check if a constraint is a slide joint. +CP_EXPORT cpBool cpConstraintIsSlideJoint(const cpConstraint *constraint); + +/// Allocate a slide joint. +CP_EXPORT cpSlideJoint* cpSlideJointAlloc(void); +/// Initialize a slide joint. +CP_EXPORT cpSlideJoint* cpSlideJointInit(cpSlideJoint *joint, cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB, cpFloat min, cpFloat max); +/// Allocate and initialize a slide joint. +CP_EXPORT cpConstraint* cpSlideJointNew(cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB, cpFloat min, cpFloat max); + +/// Get the location of the first anchor relative to the first body. +CP_EXPORT cpVect cpSlideJointGetAnchorA(const cpConstraint *constraint); +/// Set the location of the first anchor relative to the first body. +CP_EXPORT void cpSlideJointSetAnchorA(cpConstraint *constraint, cpVect anchorA); + +/// Get the location of the second anchor relative to the second body. +CP_EXPORT cpVect cpSlideJointGetAnchorB(const cpConstraint *constraint); +/// Set the location of the second anchor relative to the second body. +CP_EXPORT void cpSlideJointSetAnchorB(cpConstraint *constraint, cpVect anchorB); + +/// Get the minimum distance the joint will maintain between the two anchors. +CP_EXPORT cpFloat cpSlideJointGetMin(const cpConstraint *constraint); +/// Set the minimum distance the joint will maintain between the two anchors. +CP_EXPORT void cpSlideJointSetMin(cpConstraint *constraint, cpFloat min); + +/// Get the maximum distance the joint will maintain between the two anchors. +CP_EXPORT cpFloat cpSlideJointGetMax(const cpConstraint *constraint); +/// Set the maximum distance the joint will maintain between the two anchors. +CP_EXPORT void cpSlideJointSetMax(cpConstraint *constraint, cpFloat max); + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSpace.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSpace.h new file mode 100644 index 0000000..7bbabb8 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSpace.h @@ -0,0 +1,319 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/// @defgroup cpSpace cpSpace +/// @{ + +//MARK: Definitions + +/// Collision begin event function callback type. +/// Returning false from a begin callback causes the collision to be ignored until +/// the the separate callback is called when the objects stop colliding. +typedef cpBool (*cpCollisionBeginFunc)(cpArbiter *arb, cpSpace *space, cpDataPointer userData); +/// Collision pre-solve event function callback type. +/// Returning false from a pre-step callback causes the collision to be ignored until the next step. +typedef cpBool (*cpCollisionPreSolveFunc)(cpArbiter *arb, cpSpace *space, cpDataPointer userData); +/// Collision post-solve event function callback type. +typedef void (*cpCollisionPostSolveFunc)(cpArbiter *arb, cpSpace *space, cpDataPointer userData); +/// Collision separate event function callback type. +typedef void (*cpCollisionSeparateFunc)(cpArbiter *arb, cpSpace *space, cpDataPointer userData); + +/// Struct that holds function callback pointers to configure custom collision handling. +/// Collision handlers have a pair of types; when a collision occurs between two shapes that have these types, the collision handler functions are triggered. +struct cpCollisionHandler { + /// Collision type identifier of the first shape that this handler recognizes. + /// In the collision handler callback, the shape with this type will be the first argument. Read only. + const cpCollisionType typeA; + /// Collision type identifier of the second shape that this handler recognizes. + /// In the collision handler callback, the shape with this type will be the second argument. Read only. + const cpCollisionType typeB; + /// This function is called when two shapes with types that match this collision handler begin colliding. + cpCollisionBeginFunc beginFunc; + /// This function is called each step when two shapes with types that match this collision handler are colliding. + /// It's called before the collision solver runs so that you can affect a collision's outcome. + cpCollisionPreSolveFunc preSolveFunc; + /// This function is called each step when two shapes with types that match this collision handler are colliding. + /// It's called after the collision solver runs so that you can read back information about the collision to trigger events in your game. + cpCollisionPostSolveFunc postSolveFunc; + /// This function is called when two shapes with types that match this collision handler stop colliding. + cpCollisionSeparateFunc separateFunc; + /// This is a user definable context pointer that is passed to all of the collision handler functions. + cpDataPointer userData; +}; + +// TODO: Make timestep a parameter? + + +//MARK: Memory and Initialization + +/// Allocate a cpSpace. +CP_EXPORT cpSpace* cpSpaceAlloc(void); +/// Initialize a cpSpace. +CP_EXPORT cpSpace* cpSpaceInit(cpSpace *space); +/// Allocate and initialize a cpSpace. +CP_EXPORT cpSpace* cpSpaceNew(void); + +/// Destroy a cpSpace. +CP_EXPORT void cpSpaceDestroy(cpSpace *space); +/// Destroy and free a cpSpace. +CP_EXPORT void cpSpaceFree(cpSpace *space); + + +//MARK: Properties + +/// Number of iterations to use in the impulse solver to solve contacts and other constraints. +CP_EXPORT int cpSpaceGetIterations(const cpSpace *space); +CP_EXPORT void cpSpaceSetIterations(cpSpace *space, int iterations); + +/// Gravity to pass to rigid bodies when integrating velocity. +CP_EXPORT cpVect cpSpaceGetGravity(const cpSpace *space); +CP_EXPORT void cpSpaceSetGravity(cpSpace *space, cpVect gravity); + +/// Damping rate expressed as the fraction of velocity bodies retain each second. +/// A value of 0.9 would mean that each body's velocity will drop 10% per second. +/// The default value is 1.0, meaning no damping is applied. +/// @note This damping value is different than those of cpDampedSpring and cpDampedRotarySpring. +CP_EXPORT cpFloat cpSpaceGetDamping(const cpSpace *space); +CP_EXPORT void cpSpaceSetDamping(cpSpace *space, cpFloat damping); + +/// Speed threshold for a body to be considered idle. +/// The default value of 0 means to let the space guess a good threshold based on gravity. +CP_EXPORT cpFloat cpSpaceGetIdleSpeedThreshold(const cpSpace *space); +CP_EXPORT void cpSpaceSetIdleSpeedThreshold(cpSpace *space, cpFloat idleSpeedThreshold); + +/// Time a group of bodies must remain idle in order to fall asleep. +/// Enabling sleeping also implicitly enables the the contact graph. +/// The default value of INFINITY disables the sleeping algorithm. +CP_EXPORT cpFloat cpSpaceGetSleepTimeThreshold(const cpSpace *space); +CP_EXPORT void cpSpaceSetSleepTimeThreshold(cpSpace *space, cpFloat sleepTimeThreshold); + +/// Amount of encouraged penetration between colliding shapes. +/// Used to reduce oscillating contacts and keep the collision cache warm. +/// Defaults to 0.1. If you have poor simulation quality, +/// increase this number as much as possible without allowing visible amounts of overlap. +CP_EXPORT cpFloat cpSpaceGetCollisionSlop(const cpSpace *space); +CP_EXPORT void cpSpaceSetCollisionSlop(cpSpace *space, cpFloat collisionSlop); + +/// Determines how fast overlapping shapes are pushed apart. +/// Expressed as a fraction of the error remaining after each second. +/// Defaults to pow(1.0 - 0.1, 60.0) meaning that Chipmunk fixes 10% of overlap each frame at 60Hz. +CP_EXPORT cpFloat cpSpaceGetCollisionBias(const cpSpace *space); +CP_EXPORT void cpSpaceSetCollisionBias(cpSpace *space, cpFloat collisionBias); + +/// Number of frames that contact information should persist. +/// Defaults to 3. There is probably never a reason to change this value. +CP_EXPORT cpTimestamp cpSpaceGetCollisionPersistence(const cpSpace *space); +CP_EXPORT void cpSpaceSetCollisionPersistence(cpSpace *space, cpTimestamp collisionPersistence); + +/// User definable data pointer. +/// Generally this points to your game's controller or game state +/// class so you can access it when given a cpSpace reference in a callback. +CP_EXPORT cpDataPointer cpSpaceGetUserData(const cpSpace *space); +CP_EXPORT void cpSpaceSetUserData(cpSpace *space, cpDataPointer userData); + +/// The Space provided static body for a given cpSpace. +/// This is merely provided for convenience and you are not required to use it. +CP_EXPORT cpBody* cpSpaceGetStaticBody(const cpSpace *space); + +/// Returns the current (or most recent) time step used with the given space. +/// Useful from callbacks if your time step is not a compile-time global. +CP_EXPORT cpFloat cpSpaceGetCurrentTimeStep(const cpSpace *space); + +/// returns true from inside a callback when objects cannot be added/removed. +CP_EXPORT cpBool cpSpaceIsLocked(cpSpace *space); + + +//MARK: Collision Handlers + +/// Create or return the existing collision handler that is called for all collisions that are not handled by a more specific collision handler. +CP_EXPORT cpCollisionHandler *cpSpaceAddDefaultCollisionHandler(cpSpace *space); +/// Create or return the existing collision handler for the specified pair of collision types. +/// If wildcard handlers are used with either of the collision types, it's the responibility of the custom handler to invoke the wildcard handlers. +CP_EXPORT cpCollisionHandler *cpSpaceAddCollisionHandler(cpSpace *space, cpCollisionType a, cpCollisionType b); +/// Create or return the existing wildcard collision handler for the specified type. +CP_EXPORT cpCollisionHandler *cpSpaceAddWildcardHandler(cpSpace *space, cpCollisionType type); + + +//MARK: Add/Remove objects + +/// Add a collision shape to the simulation. +/// If the shape is attached to a static body, it will be added as a static shape. +CP_EXPORT cpShape* cpSpaceAddShape(cpSpace *space, cpShape *shape); +/// Add a rigid body to the simulation. +CP_EXPORT cpBody* cpSpaceAddBody(cpSpace *space, cpBody *body); +/// Add a constraint to the simulation. +CP_EXPORT cpConstraint* cpSpaceAddConstraint(cpSpace *space, cpConstraint *constraint); + +/// Remove a collision shape from the simulation. +CP_EXPORT void cpSpaceRemoveShape(cpSpace *space, cpShape *shape); +/// Remove a rigid body from the simulation. +CP_EXPORT void cpSpaceRemoveBody(cpSpace *space, cpBody *body); +/// Remove a constraint from the simulation. +CP_EXPORT void cpSpaceRemoveConstraint(cpSpace *space, cpConstraint *constraint); + +/// Test if a collision shape has been added to the space. +CP_EXPORT cpBool cpSpaceContainsShape(cpSpace *space, cpShape *shape); +/// Test if a rigid body has been added to the space. +CP_EXPORT cpBool cpSpaceContainsBody(cpSpace *space, cpBody *body); +/// Test if a constraint has been added to the space. +CP_EXPORT cpBool cpSpaceContainsConstraint(cpSpace *space, cpConstraint *constraint); + +//MARK: Post-Step Callbacks + +/// Post Step callback function type. +typedef void (*cpPostStepFunc)(cpSpace *space, void *key, void *data); +/// Schedule a post-step callback to be called when cpSpaceStep() finishes. +/// You can only register one callback per unique value for @c key. +/// Returns true only if @c key has never been scheduled before. +/// It's possible to pass @c NULL for @c func if you only want to mark @c key as being used. +CP_EXPORT cpBool cpSpaceAddPostStepCallback(cpSpace *space, cpPostStepFunc func, void *key, void *data); + + +//MARK: Queries + +// TODO: Queries and iterators should take a cpSpace parametery. +// TODO: They should also be abortable. + +/// Nearest point query callback function type. +typedef void (*cpSpacePointQueryFunc)(cpShape *shape, cpVect point, cpFloat distance, cpVect gradient, void *data); +/// Query the space at a point and call @c func for each shape found. +CP_EXPORT void cpSpacePointQuery(cpSpace *space, cpVect point, cpFloat maxDistance, cpShapeFilter filter, cpSpacePointQueryFunc func, void *data); +/// Query the space at a point and return the nearest shape found. Returns NULL if no shapes were found. +CP_EXPORT cpShape *cpSpacePointQueryNearest(cpSpace *space, cpVect point, cpFloat maxDistance, cpShapeFilter filter, cpPointQueryInfo *out); + +/// Segment query callback function type. +typedef void (*cpSpaceSegmentQueryFunc)(cpShape *shape, cpVect point, cpVect normal, cpFloat alpha, void *data); +/// Perform a directed line segment query (like a raycast) against the space calling @c func for each shape intersected. +CP_EXPORT void cpSpaceSegmentQuery(cpSpace *space, cpVect start, cpVect end, cpFloat radius, cpShapeFilter filter, cpSpaceSegmentQueryFunc func, void *data); +/// Perform a directed line segment query (like a raycast) against the space and return the first shape hit. Returns NULL if no shapes were hit. +CP_EXPORT cpShape *cpSpaceSegmentQueryFirst(cpSpace *space, cpVect start, cpVect end, cpFloat radius, cpShapeFilter filter, cpSegmentQueryInfo *out); + +/// Rectangle Query callback function type. +typedef void (*cpSpaceBBQueryFunc)(cpShape *shape, void *data); +/// Perform a fast rectangle query on the space calling @c func for each shape found. +/// Only the shape's bounding boxes are checked for overlap, not their full shape. +CP_EXPORT void cpSpaceBBQuery(cpSpace *space, cpBB bb, cpShapeFilter filter, cpSpaceBBQueryFunc func, void *data); + +/// Shape query callback function type. +typedef void (*cpSpaceShapeQueryFunc)(cpShape *shape, cpContactPointSet *points, void *data); +/// Query a space for any shapes overlapping the given shape and call @c func for each shape found. +CP_EXPORT cpBool cpSpaceShapeQuery(cpSpace *space, cpShape *shape, cpSpaceShapeQueryFunc func, void *data); + + +//MARK: Iteration + +/// Space/body iterator callback function type. +typedef void (*cpSpaceBodyIteratorFunc)(cpBody *body, void *data); +/// Call @c func for each body in the space. +CP_EXPORT void cpSpaceEachBody(cpSpace *space, cpSpaceBodyIteratorFunc func, void *data); + +/// Space/body iterator callback function type. +typedef void (*cpSpaceShapeIteratorFunc)(cpShape *shape, void *data); +/// Call @c func for each shape in the space. +CP_EXPORT void cpSpaceEachShape(cpSpace *space, cpSpaceShapeIteratorFunc func, void *data); + +/// Space/constraint iterator callback function type. +typedef void (*cpSpaceConstraintIteratorFunc)(cpConstraint *constraint, void *data); +/// Call @c func for each shape in the space. +CP_EXPORT void cpSpaceEachConstraint(cpSpace *space, cpSpaceConstraintIteratorFunc func, void *data); + + +//MARK: Indexing + +/// Update the collision detection info for the static shapes in the space. +CP_EXPORT void cpSpaceReindexStatic(cpSpace *space); +/// Update the collision detection data for a specific shape in the space. +CP_EXPORT void cpSpaceReindexShape(cpSpace *space, cpShape *shape); +/// Update the collision detection data for all shapes attached to a body. +CP_EXPORT void cpSpaceReindexShapesForBody(cpSpace *space, cpBody *body); + +/// Switch the space to use a spatial has as it's spatial index. +CP_EXPORT void cpSpaceUseSpatialHash(cpSpace *space, cpFloat dim, int count); + + +//MARK: Time Stepping + +/// Step the space forward in time by @c dt. +CP_EXPORT void cpSpaceStep(cpSpace *space, cpFloat dt); + + +//MARK: Debug API + +#ifndef CP_SPACE_DISABLE_DEBUG_API + +/// Color type to use with the space debug drawing API. +typedef struct cpSpaceDebugColor { + float r, g, b, a; +} cpSpaceDebugColor; + +/// Callback type for a function that draws a filled, stroked circle. +typedef void (*cpSpaceDebugDrawCircleImpl)(cpVect pos, cpFloat angle, cpFloat radius, cpSpaceDebugColor outlineColor, cpSpaceDebugColor fillColor, cpDataPointer data); +/// Callback type for a function that draws a line segment. +typedef void (*cpSpaceDebugDrawSegmentImpl)(cpVect a, cpVect b, cpSpaceDebugColor color, cpDataPointer data); +/// Callback type for a function that draws a thick line segment. +typedef void (*cpSpaceDebugDrawFatSegmentImpl)(cpVect a, cpVect b, cpFloat radius, cpSpaceDebugColor outlineColor, cpSpaceDebugColor fillColor, cpDataPointer data); +/// Callback type for a function that draws a convex polygon. +typedef void (*cpSpaceDebugDrawPolygonImpl)(int count, const cpVect *verts, cpFloat radius, cpSpaceDebugColor outlineColor, cpSpaceDebugColor fillColor, cpDataPointer data); +/// Callback type for a function that draws a dot. +typedef void (*cpSpaceDebugDrawDotImpl)(cpFloat size, cpVect pos, cpSpaceDebugColor color, cpDataPointer data); +/// Callback type for a function that returns a color for a given shape. This gives you an opportunity to color shapes based on how they are used in your engine. +typedef cpSpaceDebugColor (*cpSpaceDebugDrawColorForShapeImpl)(cpShape *shape, cpDataPointer data); + +typedef enum cpSpaceDebugDrawFlags { + CP_SPACE_DEBUG_DRAW_SHAPES = 1<<0, + CP_SPACE_DEBUG_DRAW_CONSTRAINTS = 1<<1, + CP_SPACE_DEBUG_DRAW_COLLISION_POINTS = 1<<2, +} cpSpaceDebugDrawFlags; + +/// Struct used with cpSpaceDebugDraw() containing drawing callbacks and other drawing settings. +typedef struct cpSpaceDebugDrawOptions { + /// Function that will be invoked to draw circles. + cpSpaceDebugDrawCircleImpl drawCircle; + /// Function that will be invoked to draw line segments. + cpSpaceDebugDrawSegmentImpl drawSegment; + /// Function that will be invoked to draw thick line segments. + cpSpaceDebugDrawFatSegmentImpl drawFatSegment; + /// Function that will be invoked to draw convex polygons. + cpSpaceDebugDrawPolygonImpl drawPolygon; + /// Function that will be invoked to draw dots. + cpSpaceDebugDrawDotImpl drawDot; + + /// Flags that request which things to draw (collision shapes, constraints, contact points). + cpSpaceDebugDrawFlags flags; + /// Outline color passed to the drawing function. + cpSpaceDebugColor shapeOutlineColor; + /// Function that decides what fill color to draw shapes using. + cpSpaceDebugDrawColorForShapeImpl colorForShape; + /// Color passed to drawing functions for constraints. + cpSpaceDebugColor constraintColor; + /// Color passed to drawing functions for collision points. + cpSpaceDebugColor collisionPointColor; + + /// User defined context pointer passed to all of the callback functions as the 'data' argument. + cpDataPointer data; +} cpSpaceDebugDrawOptions; + +/// Debug draw the current state of the space using the supplied drawing options. +CP_EXPORT void cpSpaceDebugDraw(cpSpace *space, cpSpaceDebugDrawOptions *options); + +#endif + +/// @} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSpatialIndex.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSpatialIndex.h new file mode 100644 index 0000000..1f7c68c --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpSpatialIndex.h @@ -0,0 +1,227 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +/** + @defgroup cpSpatialIndex cpSpatialIndex + + Spatial indexes are data structures that are used to accelerate collision detection + and spatial queries. Chipmunk provides a number of spatial index algorithms to pick from + and they are programmed in a generic way so that you can use them for holding more than + just cpShape structs. + + It works by using @c void pointers to the objects you add and using a callback to ask your code + for bounding boxes when it needs them. Several types of queries can be performed an index as well + as reindexing and full collision information. All communication to the spatial indexes is performed + through callback functions. + + Spatial indexes should be treated as opaque structs. + This meanns you shouldn't be reading any of the struct fields. + @{ +*/ + +//MARK: Spatial Index + +/// Spatial index bounding box callback function type. +/// The spatial index calls this function and passes you a pointer to an object you added +/// when it needs to get the bounding box associated with that object. +typedef cpBB (*cpSpatialIndexBBFunc)(void *obj); +/// Spatial index/object iterator callback function type. +typedef void (*cpSpatialIndexIteratorFunc)(void *obj, void *data); +/// Spatial query callback function type. +typedef cpCollisionID (*cpSpatialIndexQueryFunc)(void *obj1, void *obj2, cpCollisionID id, void *data); +/// Spatial segment query callback function type. +typedef cpFloat (*cpSpatialIndexSegmentQueryFunc)(void *obj1, void *obj2, void *data); + + +typedef struct cpSpatialIndexClass cpSpatialIndexClass; +typedef struct cpSpatialIndex cpSpatialIndex; + +/// @private +struct cpSpatialIndex { + cpSpatialIndexClass *klass; + + cpSpatialIndexBBFunc bbfunc; + + cpSpatialIndex *staticIndex, *dynamicIndex; +}; + + +//MARK: Spatial Hash + +typedef struct cpSpaceHash cpSpaceHash; + +/// Allocate a spatial hash. +CP_EXPORT cpSpaceHash* cpSpaceHashAlloc(void); +/// Initialize a spatial hash. +CP_EXPORT cpSpatialIndex* cpSpaceHashInit(cpSpaceHash *hash, cpFloat celldim, int numcells, cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex); +/// Allocate and initialize a spatial hash. +CP_EXPORT cpSpatialIndex* cpSpaceHashNew(cpFloat celldim, int cells, cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex); + +/// Change the cell dimensions and table size of the spatial hash to tune it. +/// The cell dimensions should roughly match the average size of your objects +/// and the table size should be ~10 larger than the number of objects inserted. +/// Some trial and error is required to find the optimum numbers for efficiency. +CP_EXPORT void cpSpaceHashResize(cpSpaceHash *hash, cpFloat celldim, int numcells); + +//MARK: AABB Tree + +typedef struct cpBBTree cpBBTree; + +/// Allocate a bounding box tree. +CP_EXPORT cpBBTree* cpBBTreeAlloc(void); +/// Initialize a bounding box tree. +CP_EXPORT cpSpatialIndex* cpBBTreeInit(cpBBTree *tree, cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex); +/// Allocate and initialize a bounding box tree. +CP_EXPORT cpSpatialIndex* cpBBTreeNew(cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex); + +/// Perform a static top down optimization of the tree. +CP_EXPORT void cpBBTreeOptimize(cpSpatialIndex *index); + +/// Bounding box tree velocity callback function. +/// This function should return an estimate for the object's velocity. +typedef cpVect (*cpBBTreeVelocityFunc)(void *obj); +/// Set the velocity function for the bounding box tree to enable temporal coherence. +CP_EXPORT void cpBBTreeSetVelocityFunc(cpSpatialIndex *index, cpBBTreeVelocityFunc func); + +//MARK: Single Axis Sweep + +typedef struct cpSweep1D cpSweep1D; + +/// Allocate a 1D sort and sweep broadphase. +CP_EXPORT cpSweep1D* cpSweep1DAlloc(void); +/// Initialize a 1D sort and sweep broadphase. +CP_EXPORT cpSpatialIndex* cpSweep1DInit(cpSweep1D *sweep, cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex); +/// Allocate and initialize a 1D sort and sweep broadphase. +CP_EXPORT cpSpatialIndex* cpSweep1DNew(cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex); + +//MARK: Spatial Index Implementation + +typedef void (*cpSpatialIndexDestroyImpl)(cpSpatialIndex *index); + +typedef int (*cpSpatialIndexCountImpl)(cpSpatialIndex *index); +typedef void (*cpSpatialIndexEachImpl)(cpSpatialIndex *index, cpSpatialIndexIteratorFunc func, void *data); + +typedef cpBool (*cpSpatialIndexContainsImpl)(cpSpatialIndex *index, void *obj, cpHashValue hashid); +typedef void (*cpSpatialIndexInsertImpl)(cpSpatialIndex *index, void *obj, cpHashValue hashid); +typedef void (*cpSpatialIndexRemoveImpl)(cpSpatialIndex *index, void *obj, cpHashValue hashid); + +typedef void (*cpSpatialIndexReindexImpl)(cpSpatialIndex *index); +typedef void (*cpSpatialIndexReindexObjectImpl)(cpSpatialIndex *index, void *obj, cpHashValue hashid); +typedef void (*cpSpatialIndexReindexQueryImpl)(cpSpatialIndex *index, cpSpatialIndexQueryFunc func, void *data); + +typedef void (*cpSpatialIndexQueryImpl)(cpSpatialIndex *index, void *obj, cpBB bb, cpSpatialIndexQueryFunc func, void *data); +typedef void (*cpSpatialIndexSegmentQueryImpl)(cpSpatialIndex *index, void *obj, cpVect a, cpVect b, cpFloat t_exit, cpSpatialIndexSegmentQueryFunc func, void *data); + +struct cpSpatialIndexClass { + cpSpatialIndexDestroyImpl destroy; + + cpSpatialIndexCountImpl count; + cpSpatialIndexEachImpl each; + + cpSpatialIndexContainsImpl contains; + cpSpatialIndexInsertImpl insert; + cpSpatialIndexRemoveImpl remove; + + cpSpatialIndexReindexImpl reindex; + cpSpatialIndexReindexObjectImpl reindexObject; + cpSpatialIndexReindexQueryImpl reindexQuery; + + cpSpatialIndexQueryImpl query; + cpSpatialIndexSegmentQueryImpl segmentQuery; +}; + +/// Destroy and free a spatial index. +CP_EXPORT void cpSpatialIndexFree(cpSpatialIndex *index); +/// Collide the objects in @c dynamicIndex against the objects in @c staticIndex using the query callback function. +CP_EXPORT void cpSpatialIndexCollideStatic(cpSpatialIndex *dynamicIndex, cpSpatialIndex *staticIndex, cpSpatialIndexQueryFunc func, void *data); + +/// Destroy a spatial index. +static inline void cpSpatialIndexDestroy(cpSpatialIndex *index) +{ + if(index->klass) index->klass->destroy(index); +} + +/// Get the number of objects in the spatial index. +static inline int cpSpatialIndexCount(cpSpatialIndex *index) +{ + return index->klass->count(index); +} + +/// Iterate the objects in the spatial index. @c func will be called once for each object. +static inline void cpSpatialIndexEach(cpSpatialIndex *index, cpSpatialIndexIteratorFunc func, void *data) +{ + index->klass->each(index, func, data); +} + +/// Returns true if the spatial index contains the given object. +/// Most spatial indexes use hashed storage, so you must provide a hash value too. +static inline cpBool cpSpatialIndexContains(cpSpatialIndex *index, void *obj, cpHashValue hashid) +{ + return index->klass->contains(index, obj, hashid); +} + +/// Add an object to a spatial index. +/// Most spatial indexes use hashed storage, so you must provide a hash value too. +static inline void cpSpatialIndexInsert(cpSpatialIndex *index, void *obj, cpHashValue hashid) +{ + index->klass->insert(index, obj, hashid); +} + +/// Remove an object from a spatial index. +/// Most spatial indexes use hashed storage, so you must provide a hash value too. +static inline void cpSpatialIndexRemove(cpSpatialIndex *index, void *obj, cpHashValue hashid) +{ + index->klass->remove(index, obj, hashid); +} + +/// Perform a full reindex of a spatial index. +static inline void cpSpatialIndexReindex(cpSpatialIndex *index) +{ + index->klass->reindex(index); +} + +/// Reindex a single object in the spatial index. +static inline void cpSpatialIndexReindexObject(cpSpatialIndex *index, void *obj, cpHashValue hashid) +{ + index->klass->reindexObject(index, obj, hashid); +} + +/// Perform a rectangle query against the spatial index, calling @c func for each potential match. +static inline void cpSpatialIndexQuery(cpSpatialIndex *index, void *obj, cpBB bb, cpSpatialIndexQueryFunc func, void *data) +{ + index->klass->query(index, obj, bb, func, data); +} + +/// Perform a segment query against the spatial index, calling @c func for each potential match. +static inline void cpSpatialIndexSegmentQuery(cpSpatialIndex *index, void *obj, cpVect a, cpVect b, cpFloat t_exit, cpSpatialIndexSegmentQueryFunc func, void *data) +{ + index->klass->segmentQuery(index, obj, a, b, t_exit, func, data); +} + +/// Simultaneously reindex and find all colliding objects. +/// @c func will be called once for each potentially overlapping pair of objects found. +/// If the spatial index was initialized with a static index, it will collide it's objects against that as well. +static inline void cpSpatialIndexReindexQuery(cpSpatialIndex *index, cpSpatialIndexQueryFunc func, void *data) +{ + index->klass->reindexQuery(index, func, data); +} + +///@} diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpTransform.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpTransform.h new file mode 100644 index 0000000..4a6256b --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpTransform.h @@ -0,0 +1,198 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#ifndef CHIPMUNK_TRANSFORM_H +#define CHIPMUNK_TRANSFORM_H + +#include "chipmunk_types.h" +#include "cpVect.h" +#include "cpBB.h" + +/// Identity transform matrix. +static const cpTransform cpTransformIdentity = {1.0f, 0.0f, 0.0f, 1.0f, 0.0f, 0.0f}; + +/// Construct a new transform matrix. +/// (a, b) is the x basis vector. +/// (c, d) is the y basis vector. +/// (tx, ty) is the translation. +static inline cpTransform +cpTransformNew(cpFloat a, cpFloat b, cpFloat c, cpFloat d, cpFloat tx, cpFloat ty) +{ + cpTransform t = {a, b, c, d, tx, ty}; + return t; +} + +/// Construct a new transform matrix in transposed order. +static inline cpTransform +cpTransformNewTranspose(cpFloat a, cpFloat c, cpFloat tx, cpFloat b, cpFloat d, cpFloat ty) +{ + cpTransform t = {a, b, c, d, tx, ty}; + return t; +} + +/// Get the inverse of a transform matrix. +static inline cpTransform +cpTransformInverse(cpTransform t) +{ + cpFloat inv_det = 1.0/(t.a*t.d - t.c*t.b); + return cpTransformNewTranspose( + t.d*inv_det, -t.c*inv_det, (t.c*t.ty - t.tx*t.d)*inv_det, + -t.b*inv_det, t.a*inv_det, (t.tx*t.b - t.a*t.ty)*inv_det + ); +} + +/// Multiply two transformation matrices. +static inline cpTransform +cpTransformMult(cpTransform t1, cpTransform t2) +{ + return cpTransformNewTranspose( + t1.a*t2.a + t1.c*t2.b, t1.a*t2.c + t1.c*t2.d, t1.a*t2.tx + t1.c*t2.ty + t1.tx, + t1.b*t2.a + t1.d*t2.b, t1.b*t2.c + t1.d*t2.d, t1.b*t2.tx + t1.d*t2.ty + t1.ty + ); +} + +/// Transform an absolute point. (i.e. a vertex) +static inline cpVect +cpTransformPoint(cpTransform t, cpVect p) +{ + return cpv(t.a*p.x + t.c*p.y + t.tx, t.b*p.x + t.d*p.y + t.ty); +} + +/// Transform a vector (i.e. a normal) +static inline cpVect +cpTransformVect(cpTransform t, cpVect v) +{ + return cpv(t.a*v.x + t.c*v.y, t.b*v.x + t.d*v.y); +} + +/// Transform a cpBB. +static inline cpBB +cpTransformbBB(cpTransform t, cpBB bb) +{ + cpVect center = cpBBCenter(bb); + cpFloat hw = (bb.r - bb.l)*0.5; + cpFloat hh = (bb.t - bb.b)*0.5; + + cpFloat a = t.a*hw, b = t.c*hh, d = t.b*hw, e = t.d*hh; + cpFloat hw_max = cpfmax(cpfabs(a + b), cpfabs(a - b)); + cpFloat hh_max = cpfmax(cpfabs(d + e), cpfabs(d - e)); + return cpBBNewForExtents(cpTransformPoint(t, center), hw_max, hh_max); +} + +/// Create a transation matrix. +static inline cpTransform +cpTransformTranslate(cpVect translate) +{ + return cpTransformNewTranspose( + 1.0, 0.0, translate.x, + 0.0, 1.0, translate.y + ); +} + +/// Create a scale matrix. +static inline cpTransform +cpTransformScale(cpFloat scaleX, cpFloat scaleY) +{ + return cpTransformNewTranspose( + scaleX, 0.0, 0.0, + 0.0, scaleY, 0.0 + ); +} + +/// Create a rotation matrix. +static inline cpTransform +cpTransformRotate(cpFloat radians) +{ + cpVect rot = cpvforangle(radians); + return cpTransformNewTranspose( + rot.x, -rot.y, 0.0, + rot.y, rot.x, 0.0 + ); +} + +/// Create a rigid transformation matrix. (transation + rotation) +static inline cpTransform +cpTransformRigid(cpVect translate, cpFloat radians) +{ + cpVect rot = cpvforangle(radians); + return cpTransformNewTranspose( + rot.x, -rot.y, translate.x, + rot.y, rot.x, translate.y + ); +} + +/// Fast inverse of a rigid transformation matrix. +static inline cpTransform +cpTransformRigidInverse(cpTransform t) +{ + return cpTransformNewTranspose( + t.d, -t.c, (t.c*t.ty - t.tx*t.d), + -t.b, t.a, (t.tx*t.b - t.a*t.ty) + ); +} + +//MARK: Miscellaneous (but useful) transformation matrices. +// See source for documentation... + +static inline cpTransform +cpTransformWrap(cpTransform outer, cpTransform inner) +{ + return cpTransformMult(cpTransformInverse(outer), cpTransformMult(inner, outer)); +} + +static inline cpTransform +cpTransformWrapInverse(cpTransform outer, cpTransform inner) +{ + return cpTransformMult(outer, cpTransformMult(inner, cpTransformInverse(outer))); +} + +static inline cpTransform +cpTransformOrtho(cpBB bb) +{ + return cpTransformNewTranspose( + 2.0/(bb.r - bb.l), 0.0, -(bb.r + bb.l)/(bb.r - bb.l), + 0.0, 2.0/(bb.t - bb.b), -(bb.t + bb.b)/(bb.t - bb.b) + ); +} + +static inline cpTransform +cpTransformBoneScale(cpVect v0, cpVect v1) +{ + cpVect d = cpvsub(v1, v0); + return cpTransformNewTranspose( + d.x, -d.y, v0.x, + d.y, d.x, v0.y + ); +} + +static inline cpTransform +cpTransformAxialScale(cpVect axis, cpVect pivot, cpFloat scale) +{ + cpFloat A = axis.x*axis.y*(scale - 1.0); + cpFloat B = cpvdot(axis, pivot)*(1.0 - scale); + + return cpTransformNewTranspose( + scale*axis.x*axis.x + axis.y*axis.y, A, axis.x*B, + A, axis.x*axis.x + scale*axis.y*axis.y, axis.y*B + ); +} + +#endif diff --git a/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpVect.h b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpVect.h new file mode 100644 index 0000000..8ec02bd --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/include/chipmunk/cpVect.h @@ -0,0 +1,230 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#ifndef CHIPMUNK_VECT_H +#define CHIPMUNK_VECT_H + +#include "chipmunk_types.h" + +/// @defgroup cpVect cpVect +/// Chipmunk's 2D vector type along with a handy 2D vector math lib. +/// @{ + +/// Constant for the zero vector. +static const cpVect cpvzero = {0.0f,0.0f}; + +/// Convenience constructor for cpVect structs. +static inline cpVect cpv(const cpFloat x, const cpFloat y) +{ + cpVect v = {x, y}; + return v; +} + +/// Check if two vectors are equal. (Be careful when comparing floating point numbers!) +static inline cpBool cpveql(const cpVect v1, const cpVect v2) +{ + return (v1.x == v2.x && v1.y == v2.y); +} + +/// Add two vectors +static inline cpVect cpvadd(const cpVect v1, const cpVect v2) +{ + return cpv(v1.x + v2.x, v1.y + v2.y); +} + +/// Subtract two vectors. +static inline cpVect cpvsub(const cpVect v1, const cpVect v2) +{ + return cpv(v1.x - v2.x, v1.y - v2.y); +} + +/// Negate a vector. +static inline cpVect cpvneg(const cpVect v) +{ + return cpv(-v.x, -v.y); +} + +/// Scalar multiplication. +static inline cpVect cpvmult(const cpVect v, const cpFloat s) +{ + return cpv(v.x*s, v.y*s); +} + +/// Vector dot product. +static inline cpFloat cpvdot(const cpVect v1, const cpVect v2) +{ + return v1.x*v2.x + v1.y*v2.y; +} + +/// 2D vector cross product analog. +/// The cross product of 2D vectors results in a 3D vector with only a z component. +/// This function returns the magnitude of the z value. +static inline cpFloat cpvcross(const cpVect v1, const cpVect v2) +{ + return v1.x*v2.y - v1.y*v2.x; +} + +/// Returns a perpendicular vector. (90 degree rotation) +static inline cpVect cpvperp(const cpVect v) +{ + return cpv(-v.y, v.x); +} + +/// Returns a perpendicular vector. (-90 degree rotation) +static inline cpVect cpvrperp(const cpVect v) +{ + return cpv(v.y, -v.x); +} + +/// Returns the vector projection of v1 onto v2. +static inline cpVect cpvproject(const cpVect v1, const cpVect v2) +{ + return cpvmult(v2, cpvdot(v1, v2)/cpvdot(v2, v2)); +} + +/// Returns the unit length vector for the given angle (in radians). +static inline cpVect cpvforangle(const cpFloat a) +{ + return cpv(cpfcos(a), cpfsin(a)); +} + +/// Returns the angular direction v is pointing in (in radians). +static inline cpFloat cpvtoangle(const cpVect v) +{ + return cpfatan2(v.y, v.x); +} + +/// Uses complex number multiplication to rotate v1 by v2. Scaling will occur if v1 is not a unit vector. +static inline cpVect cpvrotate(const cpVect v1, const cpVect v2) +{ + return cpv(v1.x*v2.x - v1.y*v2.y, v1.x*v2.y + v1.y*v2.x); +} + +/// Inverse of cpvrotate(). +static inline cpVect cpvunrotate(const cpVect v1, const cpVect v2) +{ + return cpv(v1.x*v2.x + v1.y*v2.y, v1.y*v2.x - v1.x*v2.y); +} + +/// Returns the squared length of v. Faster than cpvlength() when you only need to compare lengths. +static inline cpFloat cpvlengthsq(const cpVect v) +{ + return cpvdot(v, v); +} + +/// Returns the length of v. +static inline cpFloat cpvlength(const cpVect v) +{ + return cpfsqrt(cpvdot(v, v)); +} + +/// Linearly interpolate between v1 and v2. +static inline cpVect cpvlerp(const cpVect v1, const cpVect v2, const cpFloat t) +{ + return cpvadd(cpvmult(v1, 1.0f - t), cpvmult(v2, t)); +} + +/// Returns a normalized copy of v. +static inline cpVect cpvnormalize(const cpVect v) +{ + // Neat trick I saw somewhere to avoid div/0. + return cpvmult(v, 1.0f/(cpvlength(v) + CPFLOAT_MIN)); +} + +/// Spherical linearly interpolate between v1 and v2. +static inline cpVect +cpvslerp(const cpVect v1, const cpVect v2, const cpFloat t) +{ + cpFloat dot = cpvdot(cpvnormalize(v1), cpvnormalize(v2)); + cpFloat omega = cpfacos(cpfclamp(dot, -1.0f, 1.0f)); + + if(omega < 1e-3){ + // If the angle between two vectors is very small, lerp instead to avoid precision issues. + return cpvlerp(v1, v2, t); + } else { + cpFloat denom = 1.0f/cpfsin(omega); + return cpvadd(cpvmult(v1, cpfsin((1.0f - t)*omega)*denom), cpvmult(v2, cpfsin(t*omega)*denom)); + } +} + +/// Spherical linearly interpolate between v1 towards v2 by no more than angle a radians +static inline cpVect +cpvslerpconst(const cpVect v1, const cpVect v2, const cpFloat a) +{ + cpFloat dot = cpvdot(cpvnormalize(v1), cpvnormalize(v2)); + cpFloat omega = cpfacos(cpfclamp(dot, -1.0f, 1.0f)); + + return cpvslerp(v1, v2, cpfmin(a, omega)/omega); +} + +/// Clamp v to length len. +static inline cpVect cpvclamp(const cpVect v, const cpFloat len) +{ + return (cpvdot(v,v) > len*len) ? cpvmult(cpvnormalize(v), len) : v; +} + +/// Linearly interpolate between v1 towards v2 by distance d. +static inline cpVect cpvlerpconst(cpVect v1, cpVect v2, cpFloat d) +{ + return cpvadd(v1, cpvclamp(cpvsub(v2, v1), d)); +} + +/// Returns the distance between v1 and v2. +static inline cpFloat cpvdist(const cpVect v1, const cpVect v2) +{ + return cpvlength(cpvsub(v1, v2)); +} + +/// Returns the squared distance between v1 and v2. Faster than cpvdist() when you only need to compare distances. +static inline cpFloat cpvdistsq(const cpVect v1, const cpVect v2) +{ + return cpvlengthsq(cpvsub(v1, v2)); +} + +/// Returns true if the distance between v1 and v2 is less than dist. +static inline cpBool cpvnear(const cpVect v1, const cpVect v2, const cpFloat dist) +{ + return cpvdistsq(v1, v2) < dist*dist; +} + +/// @} + +/// @defgroup cpMat2x2 cpMat2x2 +/// 2x2 matrix type used for tensors and such. +/// @{ + +// NUKE +static inline cpMat2x2 +cpMat2x2New(cpFloat a, cpFloat b, cpFloat c, cpFloat d) +{ + cpMat2x2 m = {a, b, c, d}; + return m; +} + +static inline cpVect +cpMat2x2Transform(cpMat2x2 m, cpVect v) +{ + return cpv(v.x*m.a + v.y*m.b, v.x*m.c + v.y*m.d); +} + +///@} + +#endif diff --git a/source/engine/thirdparty/Chipmunk2D/src/chipmunk.c b/source/engine/thirdparty/Chipmunk2D/src/chipmunk.c new file mode 100644 index 0000000..a6cc9d6 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/chipmunk.c @@ -0,0 +1,331 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include +#include +#include +#if defined(ANDROID) +# include +#endif + +#include "chipmunk/chipmunk_private.h" + +void +cpMessage(const char *condition, const char *file, int line, int isError, int isHardError, const char *message, ...) +{ + fprintf(stderr, (isError ? "Aborting due to Chipmunk error: " : "Chipmunk warning: ")); + + va_list vargs; + va_start(vargs, message); { +#if defined(ANDROID) + __android_log_print( ANDROID_LOG_INFO, "Chipmunk", "%s(%d)", file, line ); + __android_log_print( ANDROID_LOG_INFO, "Chipmunk", message, vargs ); +#else + vfprintf(stderr, message, vargs); + fprintf(stderr, "\n"); +#endif + } va_end(vargs); + +#if defined(ANDROID) + __android_log_print(ANDROID_LOG_INFO, "Chipmunk", "\tFailed condition: %s\n", condition); + __android_log_print(ANDROID_LOG_INFO, "Chipmunk", "\tSource:%s:%d\n", file, line); +#else + fprintf(stderr, "\tFailed condition: %s\n", condition); + fprintf(stderr, "\tSource:%s:%d\n", file, line); +#endif +} + +#define STR(s) #s +#define XSTR(s) STR(s) + +const char *cpVersionString = XSTR(CP_VERSION_MAJOR) "." XSTR(CP_VERSION_MINOR) "." XSTR(CP_VERSION_RELEASE); + +//MARK: Misc Functions + +cpFloat +cpMomentForCircle(cpFloat m, cpFloat r1, cpFloat r2, cpVect offset) +{ + return m*(0.5f*(r1*r1 + r2*r2) + cpvlengthsq(offset)); +} + +cpFloat +cpAreaForCircle(cpFloat r1, cpFloat r2) +{ + return (cpFloat)CP_PI*cpfabs(r1*r1 - r2*r2); +} + +cpFloat +cpMomentForSegment(cpFloat m, cpVect a, cpVect b, cpFloat r) +{ + cpVect offset = cpvlerp(a, b, 0.5f); + + // This approximates the shape as a box for rounded segments, but it's quite close. + cpFloat length = cpvdist(b, a) + 2.0f*r; + return m*((length*length + 4.0f*r*r)/12.0f + cpvlengthsq(offset)); +} + +cpFloat +cpAreaForSegment(cpVect a, cpVect b, cpFloat r) +{ + return r*((cpFloat)CP_PI*r + 2.0f*cpvdist(a, b)); +} + +cpFloat +cpMomentForPoly(cpFloat m, int count, const cpVect *verts, cpVect offset, cpFloat r) +{ + // TODO account for radius. + if(count == 2) return cpMomentForSegment(m, verts[0], verts[1], 0.0f); + + cpFloat sum1 = 0.0f; + cpFloat sum2 = 0.0f; + for(int i=0; i max.x || (v.x == max.x && v.y > max.y)){ + max = v; + (*end) = i; + } + } +} + +#define SWAP(__A__, __B__) {cpVect __TMP__ = __A__; __A__ = __B__; __B__ = __TMP__;} + +static int +QHullPartition(cpVect *verts, int count, cpVect a, cpVect b, cpFloat tol) +{ + if(count == 0) return 0; + + cpFloat max = 0; + int pivot = 0; + + cpVect delta = cpvsub(b, a); + cpFloat valueTol = tol*cpvlength(delta); + + int head = 0; + for(int tail = count-1; head <= tail;){ + cpFloat value = cpvcross(cpvsub(verts[head], a), delta); + if(value > valueTol){ + if(value > max){ + max = value; + pivot = head; + } + + head++; + } else { + SWAP(verts[head], verts[tail]); + tail--; + } + } + + // move the new pivot to the front if it's not already there. + if(pivot != 0) SWAP(verts[0], verts[pivot]); + return head; +} + +static int +QHullReduce(cpFloat tol, cpVect *verts, int count, cpVect a, cpVect pivot, cpVect b, cpVect *result) +{ + if(count < 0){ + return 0; + } else if(count == 0) { + result[0] = pivot; + return 1; + } else { + int left_count = QHullPartition(verts, count, a, pivot, tol); + int index = QHullReduce(tol, verts + 1, left_count - 1, a, verts[0], pivot, result); + + result[index++] = pivot; + + int right_count = QHullPartition(verts + left_count, count - left_count, pivot, b, tol); + return index + QHullReduce(tol, verts + left_count + 1, right_count - 1, pivot, verts[left_count], b, result + index); + } +} + +// QuickHull seemed like a neat algorithm, and efficient-ish for large input sets. +// My implementation performs an in place reduction using the result array as scratch space. +int +cpConvexHull(int count, const cpVect *verts, cpVect *result, int *first, cpFloat tol) +{ + if(verts != result){ + // Copy the line vertexes into the empty part of the result polyline to use as a scratch buffer. + memcpy(result, verts, count*sizeof(cpVect)); + } + + // Degenerate case, all points are the same. + int start, end; + cpLoopIndexes(verts, count, &start, &end); + if(start == end){ + if(first) (*first) = 0; + return 1; + } + + SWAP(result[0], result[start]); + SWAP(result[1], result[end == 0 ? start : end]); + + cpVect a = result[0]; + cpVect b = result[1]; + + if(first) (*first) = start; + return QHullReduce(tol, result + 2, count - 2, a, b, a, result + 1) + 1; +} + +//MARK: Alternate Block Iterators + +#if defined(__has_extension) +#if __has_extension(blocks) + +static void IteratorFunc(void *ptr, void (^block)(void *ptr)){block(ptr);} + +void cpSpaceEachBody_b(cpSpace *space, void (^block)(cpBody *body)){ + cpSpaceEachBody(space, (cpSpaceBodyIteratorFunc)IteratorFunc, block); +} + +void cpSpaceEachShape_b(cpSpace *space, void (^block)(cpShape *shape)){ + cpSpaceEachShape(space, (cpSpaceShapeIteratorFunc)IteratorFunc, block); +} + +void cpSpaceEachConstraint_b(cpSpace *space, void (^block)(cpConstraint *constraint)){ + cpSpaceEachConstraint(space, (cpSpaceConstraintIteratorFunc)IteratorFunc, block); +} + +static void BodyIteratorFunc(cpBody *body, void *ptr, void (^block)(void *ptr)){block(ptr);} + +void cpBodyEachShape_b(cpBody *body, void (^block)(cpShape *shape)){ + cpBodyEachShape(body, (cpBodyShapeIteratorFunc)BodyIteratorFunc, block); +} + +void cpBodyEachConstraint_b(cpBody *body, void (^block)(cpConstraint *constraint)){ + cpBodyEachConstraint(body, (cpBodyConstraintIteratorFunc)BodyIteratorFunc, block); +} + +void cpBodyEachArbiter_b(cpBody *body, void (^block)(cpArbiter *arbiter)){ + cpBodyEachArbiter(body, (cpBodyArbiterIteratorFunc)BodyIteratorFunc, block); +} + +static void PointQueryIteratorFunc(cpShape *shape, cpVect p, cpFloat d, cpVect g, cpSpacePointQueryBlock block){block(shape, p, d, g);} +void cpSpacePointQuery_b(cpSpace *space, cpVect point, cpFloat maxDistance, cpShapeFilter filter, cpSpacePointQueryBlock block){ + cpSpacePointQuery(space, point, maxDistance, filter, (cpSpacePointQueryFunc)PointQueryIteratorFunc, block); +} + +static void SegmentQueryIteratorFunc(cpShape *shape, cpVect p, cpVect n, cpFloat t, cpSpaceSegmentQueryBlock block){block(shape, p, n, t);} +void cpSpaceSegmentQuery_b(cpSpace *space, cpVect start, cpVect end, cpFloat radius, cpShapeFilter filter, cpSpaceSegmentQueryBlock block){ + cpSpaceSegmentQuery(space, start, end, radius, filter, (cpSpaceSegmentQueryFunc)SegmentQueryIteratorFunc, block); +} + +void cpSpaceBBQuery_b(cpSpace *space, cpBB bb, cpShapeFilter filter, cpSpaceBBQueryBlock block){ + cpSpaceBBQuery(space, bb, filter, (cpSpaceBBQueryFunc)IteratorFunc, block); +} + +static void ShapeQueryIteratorFunc(cpShape *shape, cpContactPointSet *points, cpSpaceShapeQueryBlock block){block(shape, points);} +cpBool cpSpaceShapeQuery_b(cpSpace *space, cpShape *shape, cpSpaceShapeQueryBlock block){ + return cpSpaceShapeQuery(space, shape, (cpSpaceShapeQueryFunc)ShapeQueryIteratorFunc, block); +} + +#endif +#endif + +#include "chipmunk/chipmunk_ffi.h" diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpArbiter.c b/source/engine/thirdparty/Chipmunk2D/src/cpArbiter.c new file mode 100644 index 0000000..5248e6a --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpArbiter.c @@ -0,0 +1,498 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +// TODO: make this generic so I can reuse it for constraints also. +static inline void +unthreadHelper(cpArbiter *arb, cpBody *body) +{ + struct cpArbiterThread *thread = cpArbiterThreadForBody(arb, body); + cpArbiter *prev = thread->prev; + cpArbiter *next = thread->next; + + if(prev){ + cpArbiterThreadForBody(prev, body)->next = next; + } else if(body->arbiterList == arb) { + // IFF prev is NULL and body->arbiterList == arb, is arb at the head of the list. + // This function may be called for an arbiter that was never in a list. + // In that case, we need to protect it from wiping out the body->arbiterList pointer. + body->arbiterList = next; + } + + if(next) cpArbiterThreadForBody(next, body)->prev = prev; + + thread->prev = NULL; + thread->next = NULL; +} + +void +cpArbiterUnthread(cpArbiter *arb) +{ + unthreadHelper(arb, arb->body_a); + unthreadHelper(arb, arb->body_b); +} + +cpBool cpArbiterIsFirstContact(const cpArbiter *arb) +{ + return arb->state == CP_ARBITER_STATE_FIRST_COLLISION; +} + +cpBool cpArbiterIsRemoval(const cpArbiter *arb) +{ + return arb->state == CP_ARBITER_STATE_INVALIDATED; +} + +int cpArbiterGetCount(const cpArbiter *arb) +{ + // Return 0 contacts if we are in a separate callback. + return (arb->state < CP_ARBITER_STATE_CACHED ? arb->count : 0); +} + +cpVect +cpArbiterGetNormal(const cpArbiter *arb) +{ + return cpvmult(arb->n, arb->swapped ? -1.0f : 1.0); +} + +cpVect +cpArbiterGetPointA(const cpArbiter *arb, int i) +{ + cpAssertHard(0 <= i && i < cpArbiterGetCount(arb), "Index error: The specified contact index is invalid for this arbiter"); + return cpvadd(arb->body_a->p, arb->contacts[i].r1); +} + +cpVect +cpArbiterGetPointB(const cpArbiter *arb, int i) +{ + cpAssertHard(0 <= i && i < cpArbiterGetCount(arb), "Index error: The specified contact index is invalid for this arbiter"); + return cpvadd(arb->body_b->p, arb->contacts[i].r2); +} + +cpFloat +cpArbiterGetDepth(const cpArbiter *arb, int i) +{ + cpAssertHard(0 <= i && i < cpArbiterGetCount(arb), "Index error: The specified contact index is invalid for this arbiter"); + + struct cpContact *con = &arb->contacts[i]; + return cpvdot(cpvadd(cpvsub(con->r2, con->r1), cpvsub(arb->body_b->p, arb->body_a->p)), arb->n); +} + +cpContactPointSet +cpArbiterGetContactPointSet(const cpArbiter *arb) +{ + cpContactPointSet set; + set.count = cpArbiterGetCount(arb); + + cpBool swapped = arb->swapped; + cpVect n = arb->n; + set.normal = (swapped ? cpvneg(n) : n); + + for(int i=0; ibody_a->p, arb->contacts[i].r1); + cpVect p2 = cpvadd(arb->body_b->p, arb->contacts[i].r2); + + set.points[i].pointA = (swapped ? p2 : p1); + set.points[i].pointB = (swapped ? p1 : p2); + set.points[i].distance = cpvdot(cpvsub(p2, p1), n); + } + + return set; +} + +void +cpArbiterSetContactPointSet(cpArbiter *arb, cpContactPointSet *set) +{ + int count = set->count; + cpAssertHard(count == arb->count, "The number of contact points cannot be changed."); + + cpBool swapped = arb->swapped; + arb->n = (swapped ? cpvneg(set->normal) : set->normal); + + for(int i=0; ipoints[i].pointA; + cpVect p2 = set->points[i].pointB; + + arb->contacts[i].r1 = cpvsub(swapped ? p2 : p1, arb->body_a->p); + arb->contacts[i].r2 = cpvsub(swapped ? p1 : p2, arb->body_b->p); + } +} + +cpVect +cpArbiterTotalImpulse(const cpArbiter *arb) +{ + struct cpContact *contacts = arb->contacts; + cpVect n = arb->n; + cpVect sum = cpvzero; + + for(int i=0, count=cpArbiterGetCount(arb); ijnAcc, con->jtAcc))); + } + + return (arb->swapped ? sum : cpvneg(sum)); + return cpvzero; +} + +cpFloat +cpArbiterTotalKE(const cpArbiter *arb) +{ + cpFloat eCoef = (1 - arb->e)/(1 + arb->e); + cpFloat sum = 0.0; + + struct cpContact *contacts = arb->contacts; + for(int i=0, count=cpArbiterGetCount(arb); ijnAcc; + cpFloat jtAcc = con->jtAcc; + + sum += eCoef*jnAcc*jnAcc/con->nMass + jtAcc*jtAcc/con->tMass; + } + + return sum; +} + +cpBool +cpArbiterIgnore(cpArbiter *arb) +{ + arb->state = CP_ARBITER_STATE_IGNORE; + return cpFalse; +} + +cpFloat +cpArbiterGetRestitution(const cpArbiter *arb) +{ + return arb->e; +} + +void +cpArbiterSetRestitution(cpArbiter *arb, cpFloat restitution) +{ + arb->e = restitution; +} + +cpFloat +cpArbiterGetFriction(const cpArbiter *arb) +{ + return arb->u; +} + +void +cpArbiterSetFriction(cpArbiter *arb, cpFloat friction) +{ + arb->u = friction; +} + +cpVect +cpArbiterGetSurfaceVelocity(cpArbiter *arb) +{ + return cpvmult(arb->surface_vr, arb->swapped ? -1.0f : 1.0); +} + +void +cpArbiterSetSurfaceVelocity(cpArbiter *arb, cpVect vr) +{ + arb->surface_vr = cpvmult(vr, arb->swapped ? -1.0f : 1.0); +} + +cpDataPointer +cpArbiterGetUserData(const cpArbiter *arb) +{ + return arb->data; +} + +void +cpArbiterSetUserData(cpArbiter *arb, cpDataPointer userData) +{ + arb->data = userData; +} + +void +cpArbiterGetShapes(const cpArbiter *arb, cpShape **a, cpShape **b) +{ + if(arb->swapped){ + (*a) = (cpShape *)arb->b; + (*b) = (cpShape *)arb->a; + } else { + (*a) = (cpShape *)arb->a; + (*b) = (cpShape *)arb->b; + } +} + +void cpArbiterGetBodies(const cpArbiter *arb, cpBody **a, cpBody **b) +{ + CP_ARBITER_GET_SHAPES(arb, shape_a, shape_b); + (*a) = shape_a->body; + (*b) = shape_b->body; +} + +cpBool +cpArbiterCallWildcardBeginA(cpArbiter *arb, cpSpace *space) +{ + cpCollisionHandler *handler = arb->handlerA; + return handler->beginFunc(arb, space, handler->userData); +} + +cpBool +cpArbiterCallWildcardBeginB(cpArbiter *arb, cpSpace *space) +{ + cpCollisionHandler *handler = arb->handlerB; + arb->swapped = !arb->swapped; + cpBool retval = handler->beginFunc(arb, space, handler->userData); + arb->swapped = !arb->swapped; + return retval; +} + +cpBool +cpArbiterCallWildcardPreSolveA(cpArbiter *arb, cpSpace *space) +{ + cpCollisionHandler *handler = arb->handlerA; + return handler->preSolveFunc(arb, space, handler->userData); +} + +cpBool +cpArbiterCallWildcardPreSolveB(cpArbiter *arb, cpSpace *space) +{ + cpCollisionHandler *handler = arb->handlerB; + arb->swapped = !arb->swapped; + cpBool retval = handler->preSolveFunc(arb, space, handler->userData); + arb->swapped = !arb->swapped; + return retval; +} + +void +cpArbiterCallWildcardPostSolveA(cpArbiter *arb, cpSpace *space) +{ + cpCollisionHandler *handler = arb->handlerA; + handler->postSolveFunc(arb, space, handler->userData); +} + +void +cpArbiterCallWildcardPostSolveB(cpArbiter *arb, cpSpace *space) +{ + cpCollisionHandler *handler = arb->handlerB; + arb->swapped = !arb->swapped; + handler->postSolveFunc(arb, space, handler->userData); + arb->swapped = !arb->swapped; +} + +void +cpArbiterCallWildcardSeparateA(cpArbiter *arb, cpSpace *space) +{ + cpCollisionHandler *handler = arb->handlerA; + handler->separateFunc(arb, space, handler->userData); +} + +void +cpArbiterCallWildcardSeparateB(cpArbiter *arb, cpSpace *space) +{ + cpCollisionHandler *handler = arb->handlerB; + arb->swapped = !arb->swapped; + handler->separateFunc(arb, space, handler->userData); + arb->swapped = !arb->swapped; +} + +cpArbiter* +cpArbiterInit(cpArbiter *arb, cpShape *a, cpShape *b) +{ + arb->handler = NULL; + arb->swapped = cpFalse; + + arb->handler = NULL; + arb->handlerA = NULL; + arb->handlerB = NULL; + + arb->e = 0.0f; + arb->u = 0.0f; + arb->surface_vr = cpvzero; + + arb->count = 0; + arb->contacts = NULL; + + arb->a = a; arb->body_a = a->body; + arb->b = b; arb->body_b = b->body; + + arb->thread_a.next = NULL; + arb->thread_b.next = NULL; + arb->thread_a.prev = NULL; + arb->thread_b.prev = NULL; + + arb->stamp = 0; + arb->state = CP_ARBITER_STATE_FIRST_COLLISION; + + arb->data = NULL; + + return arb; +} + +static inline cpCollisionHandler * +cpSpaceLookupHandler(cpSpace *space, cpCollisionType a, cpCollisionType b, cpCollisionHandler *defaultValue) +{ + cpCollisionType types[] = {a, b}; + cpCollisionHandler *handler = (cpCollisionHandler *)cpHashSetFind(space->collisionHandlers, CP_HASH_PAIR(a, b), types); + return (handler ? handler : defaultValue); +} + +void +cpArbiterUpdate(cpArbiter *arb, struct cpCollisionInfo *info, cpSpace *space) +{ + const cpShape *a = info->a, *b = info->b; + + // For collisions between two similar primitive types, the order could have been swapped since the last frame. + arb->a = a; arb->body_a = a->body; + arb->b = b; arb->body_b = b->body; + + // Iterate over the possible pairs to look for hash value matches. + for(int i=0; icount; i++){ + struct cpContact *con = &info->arr[i]; + + // r1 and r2 store absolute offsets at init time. + // Need to convert them to relative offsets. + con->r1 = cpvsub(con->r1, a->body->p); + con->r2 = cpvsub(con->r2, b->body->p); + + // Cached impulses are not zeroed at init time. + con->jnAcc = con->jtAcc = 0.0f; + + for(int j=0; jcount; j++){ + struct cpContact *old = &arb->contacts[j]; + + // This could trigger false positives, but is fairly unlikely nor serious if it does. + if(con->hash == old->hash){ + // Copy the persistant contact information. + con->jnAcc = old->jnAcc; + con->jtAcc = old->jtAcc; + } + } + } + + arb->contacts = info->arr; + arb->count = info->count; + arb->n = info->n; + + arb->e = a->e * b->e; + arb->u = a->u * b->u; + + cpVect surface_vr = cpvsub(b->surfaceV, a->surfaceV); + arb->surface_vr = cpvsub(surface_vr, cpvmult(info->n, cpvdot(surface_vr, info->n))); + + cpCollisionType typeA = info->a->type, typeB = info->b->type; + cpCollisionHandler *defaultHandler = &space->defaultHandler; + cpCollisionHandler *handler = arb->handler = cpSpaceLookupHandler(space, typeA, typeB, defaultHandler); + + // Check if the types match, but don't swap for a default handler which use the wildcard for type A. + cpBool swapped = arb->swapped = (typeA != handler->typeA && handler->typeA != CP_WILDCARD_COLLISION_TYPE); + + if(handler != defaultHandler || space->usesWildcards){ + // The order of the main handler swaps the wildcard handlers too. Uffda. + arb->handlerA = cpSpaceLookupHandler(space, (swapped ? typeB : typeA), CP_WILDCARD_COLLISION_TYPE, &cpCollisionHandlerDoNothing); + arb->handlerB = cpSpaceLookupHandler(space, (swapped ? typeA : typeB), CP_WILDCARD_COLLISION_TYPE, &cpCollisionHandlerDoNothing); + } + + // mark it as new if it's been cached + if(arb->state == CP_ARBITER_STATE_CACHED) arb->state = CP_ARBITER_STATE_FIRST_COLLISION; +} + +void +cpArbiterPreStep(cpArbiter *arb, cpFloat dt, cpFloat slop, cpFloat bias) +{ + cpBody *a = arb->body_a; + cpBody *b = arb->body_b; + cpVect n = arb->n; + cpVect body_delta = cpvsub(b->p, a->p); + + for(int i=0; icount; i++){ + struct cpContact *con = &arb->contacts[i]; + + // Calculate the mass normal and mass tangent. + con->nMass = 1.0f/k_scalar(a, b, con->r1, con->r2, n); + con->tMass = 1.0f/k_scalar(a, b, con->r1, con->r2, cpvperp(n)); + + // Calculate the target bias velocity. + cpFloat dist = cpvdot(cpvadd(cpvsub(con->r2, con->r1), body_delta), n); + con->bias = -bias*cpfmin(0.0f, dist + slop)/dt; + con->jBias = 0.0f; + + // Calculate the target bounce velocity. + con->bounce = normal_relative_velocity(a, b, con->r1, con->r2, n)*arb->e; + } +} + +void +cpArbiterApplyCachedImpulse(cpArbiter *arb, cpFloat dt_coef) +{ + if(cpArbiterIsFirstContact(arb)) return; + + cpBody *a = arb->body_a; + cpBody *b = arb->body_b; + cpVect n = arb->n; + + for(int i=0; icount; i++){ + struct cpContact *con = &arb->contacts[i]; + cpVect j = cpvrotate(n, cpv(con->jnAcc, con->jtAcc)); + apply_impulses(a, b, con->r1, con->r2, cpvmult(j, dt_coef)); + } +} + +// TODO: is it worth splitting velocity/position correction? + +void +cpArbiterApplyImpulse(cpArbiter *arb) +{ + cpBody *a = arb->body_a; + cpBody *b = arb->body_b; + cpVect n = arb->n; + cpVect surface_vr = arb->surface_vr; + cpFloat friction = arb->u; + + for(int i=0; icount; i++){ + struct cpContact *con = &arb->contacts[i]; + cpFloat nMass = con->nMass; + cpVect r1 = con->r1; + cpVect r2 = con->r2; + + cpVect vb1 = cpvadd(a->v_bias, cpvmult(cpvperp(r1), a->w_bias)); + cpVect vb2 = cpvadd(b->v_bias, cpvmult(cpvperp(r2), b->w_bias)); + cpVect vr = cpvadd(relative_velocity(a, b, r1, r2), surface_vr); + + cpFloat vbn = cpvdot(cpvsub(vb2, vb1), n); + cpFloat vrn = cpvdot(vr, n); + cpFloat vrt = cpvdot(vr, cpvperp(n)); + + cpFloat jbn = (con->bias - vbn)*nMass; + cpFloat jbnOld = con->jBias; + con->jBias = cpfmax(jbnOld + jbn, 0.0f); + + cpFloat jn = -(con->bounce + vrn)*nMass; + cpFloat jnOld = con->jnAcc; + con->jnAcc = cpfmax(jnOld + jn, 0.0f); + + cpFloat jtMax = friction*con->jnAcc; + cpFloat jt = -vrt*con->tMass; + cpFloat jtOld = con->jtAcc; + con->jtAcc = cpfclamp(jtOld + jt, -jtMax, jtMax); + + apply_bias_impulses(a, b, r1, r2, cpvmult(n, con->jBias - jbnOld)); + apply_impulses(a, b, r1, r2, cpvrotate(n, cpv(con->jnAcc - jnOld, con->jtAcc - jtOld))); + } +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpArray.c b/source/engine/thirdparty/Chipmunk2D/src/cpArray.c new file mode 100644 index 0000000..a1f8df5 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpArray.c @@ -0,0 +1,101 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include + +#include "chipmunk/chipmunk_private.h" + + +cpArray * +cpArrayNew(int size) +{ + cpArray *arr = (cpArray *)cpcalloc(1, sizeof(cpArray)); + + arr->num = 0; + arr->max = (size ? size : 4); + arr->arr = (void **)cpcalloc(arr->max, sizeof(void*)); + + return arr; +} + +void +cpArrayFree(cpArray *arr) +{ + if(arr){ + cpfree(arr->arr); + arr->arr = NULL; + + cpfree(arr); + } +} + +void +cpArrayPush(cpArray *arr, void *object) +{ + if(arr->num == arr->max){ + arr->max = 3*(arr->max + 1)/2; + arr->arr = (void **)cprealloc(arr->arr, arr->max*sizeof(void*)); + } + + arr->arr[arr->num] = object; + arr->num++; +} + +void * +cpArrayPop(cpArray *arr) +{ + arr->num--; + + void *value = arr->arr[arr->num]; + arr->arr[arr->num] = NULL; + + return value; +} + +void +cpArrayDeleteObj(cpArray *arr, void *obj) +{ + for(int i=0; inum; i++){ + if(arr->arr[i] == obj){ + arr->num--; + + arr->arr[i] = arr->arr[arr->num]; + arr->arr[arr->num] = NULL; + + return; + } + } +} + +void +cpArrayFreeEach(cpArray *arr, void (freeFunc)(void*)) +{ + for(int i=0; inum; i++) freeFunc(arr->arr[i]); +} + +cpBool +cpArrayContains(cpArray *arr, void *ptr) +{ + for(int i=0; inum; i++) + if(arr->arr[i] == ptr) return cpTrue; + + return cpFalse; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpBBTree.c b/source/engine/thirdparty/Chipmunk2D/src/cpBBTree.c new file mode 100644 index 0000000..2cef7bc --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpBBTree.c @@ -0,0 +1,896 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "stdlib.h" +#include "stdio.h" + +#include "chipmunk/chipmunk_private.h" + +static inline cpSpatialIndexClass *Klass(void); + +typedef struct Node Node; +typedef struct Pair Pair; + +struct cpBBTree { + cpSpatialIndex spatialIndex; + cpBBTreeVelocityFunc velocityFunc; + + cpHashSet *leaves; + Node *root; + + Node *pooledNodes; + Pair *pooledPairs; + cpArray *allocatedBuffers; + + cpTimestamp stamp; +}; + +struct Node { + void *obj; + cpBB bb; + Node *parent; + + union { + // Internal nodes + struct { Node *a, *b; } children; + + // Leaves + struct { + cpTimestamp stamp; + Pair *pairs; + } leaf; + } node; +}; + +// Can't use anonymous unions and still get good x-compiler compatability +#define A node.children.a +#define B node.children.b +#define STAMP node.leaf.stamp +#define PAIRS node.leaf.pairs + +typedef struct Thread { + Pair *prev; + Node *leaf; + Pair *next; +} Thread; + +struct Pair { + Thread a, b; + cpCollisionID id; +}; + +//MARK: Misc Functions + +static inline cpBB +GetBB(cpBBTree *tree, void *obj) +{ + cpBB bb = tree->spatialIndex.bbfunc(obj); + + cpBBTreeVelocityFunc velocityFunc = tree->velocityFunc; + if(velocityFunc){ + cpFloat coef = 0.1f; + cpFloat x = (bb.r - bb.l)*coef; + cpFloat y = (bb.t - bb.b)*coef; + + cpVect v = cpvmult(velocityFunc(obj), 0.1f); + return cpBBNew(bb.l + cpfmin(-x, v.x), bb.b + cpfmin(-y, v.y), bb.r + cpfmax(x, v.x), bb.t + cpfmax(y, v.y)); + } else { + return bb; + } +} + +static inline cpBBTree * +GetTree(cpSpatialIndex *index) +{ + return (index && index->klass == Klass() ? (cpBBTree *)index : NULL); +} + +static inline Node * +GetRootIfTree(cpSpatialIndex *index){ + return (index && index->klass == Klass() ? ((cpBBTree *)index)->root : NULL); +} + +static inline cpBBTree * +GetMasterTree(cpBBTree *tree) +{ + cpBBTree *dynamicTree = GetTree(tree->spatialIndex.dynamicIndex); + return (dynamicTree ? dynamicTree : tree); +} + +static inline void +IncrementStamp(cpBBTree *tree) +{ + cpBBTree *dynamicTree = GetTree(tree->spatialIndex.dynamicIndex); + if(dynamicTree){ + dynamicTree->stamp++; + } else { + tree->stamp++; + } +} + +//MARK: Pair/Thread Functions + +static void +PairRecycle(cpBBTree *tree, Pair *pair) +{ + // Share the pool of the master tree. + // TODO: would be lovely to move the pairs stuff into an external data structure. + tree = GetMasterTree(tree); + + pair->a.next = tree->pooledPairs; + tree->pooledPairs = pair; +} + +static Pair * +PairFromPool(cpBBTree *tree) +{ + // Share the pool of the master tree. + // TODO: would be lovely to move the pairs stuff into an external data structure. + tree = GetMasterTree(tree); + + Pair *pair = tree->pooledPairs; + + if(pair){ + tree->pooledPairs = pair->a.next; + return pair; + } else { + // Pool is exhausted, make more + int count = CP_BUFFER_BYTES/sizeof(Pair); + cpAssertHard(count, "Internal Error: Buffer size is too small."); + + Pair *buffer = (Pair *)cpcalloc(1, CP_BUFFER_BYTES); + cpArrayPush(tree->allocatedBuffers, buffer); + + // push all but the first one, return the first instead + for(int i=1; ia.leaf == thread.leaf) next->a.prev = prev; else next->b.prev = prev; + } + + if(prev){ + if(prev->a.leaf == thread.leaf) prev->a.next = next; else prev->b.next = next; + } else { + thread.leaf->PAIRS = next; + } +} + +static void +PairsClear(Node *leaf, cpBBTree *tree) +{ + Pair *pair = leaf->PAIRS; + leaf->PAIRS = NULL; + + while(pair){ + if(pair->a.leaf == leaf){ + Pair *next = pair->a.next; + ThreadUnlink(pair->b); + PairRecycle(tree, pair); + pair = next; + } else { + Pair *next = pair->b.next; + ThreadUnlink(pair->a); + PairRecycle(tree, pair); + pair = next; + } + } +} + +static void +PairInsert(Node *a, Node *b, cpBBTree *tree) +{ + Pair *nextA = a->PAIRS, *nextB = b->PAIRS; + Pair *pair = PairFromPool(tree); + Pair temp = {{NULL, a, nextA},{NULL, b, nextB}, 0}; + + a->PAIRS = b->PAIRS = pair; + *pair = temp; + + if(nextA){ + if(nextA->a.leaf == a) nextA->a.prev = pair; else nextA->b.prev = pair; + } + + if(nextB){ + if(nextB->a.leaf == b) nextB->a.prev = pair; else nextB->b.prev = pair; + } +} + + +//MARK: Node Functions + +static void +NodeRecycle(cpBBTree *tree, Node *node) +{ + node->parent = tree->pooledNodes; + tree->pooledNodes = node; +} + +static Node * +NodeFromPool(cpBBTree *tree) +{ + Node *node = tree->pooledNodes; + + if(node){ + tree->pooledNodes = node->parent; + return node; + } else { + // Pool is exhausted, make more + int count = CP_BUFFER_BYTES/sizeof(Node); + cpAssertHard(count, "Internal Error: Buffer size is too small."); + + Node *buffer = (Node *)cpcalloc(1, CP_BUFFER_BYTES); + cpArrayPush(tree->allocatedBuffers, buffer); + + // push all but the first one, return the first instead + for(int i=1; iA = value; + value->parent = node; +} + +static inline void +NodeSetB(Node *node, Node *value) +{ + node->B = value; + value->parent = node; +} + +static Node * +NodeNew(cpBBTree *tree, Node *a, Node *b) +{ + Node *node = NodeFromPool(tree); + + node->obj = NULL; + node->bb = cpBBMerge(a->bb, b->bb); + node->parent = NULL; + + NodeSetA(node, a); + NodeSetB(node, b); + + return node; +} + +static inline cpBool +NodeIsLeaf(Node *node) +{ + return (node->obj != NULL); +} + +static inline Node * +NodeOther(Node *node, Node *child) +{ + return (node->A == child ? node->B : node->A); +} + +static inline void +NodeReplaceChild(Node *parent, Node *child, Node *value, cpBBTree *tree) +{ + cpAssertSoft(!NodeIsLeaf(parent), "Internal Error: Cannot replace child of a leaf."); + cpAssertSoft(child == parent->A || child == parent->B, "Internal Error: Node is not a child of parent."); + + if(parent->A == child){ + NodeRecycle(tree, parent->A); + NodeSetA(parent, value); + } else { + NodeRecycle(tree, parent->B); + NodeSetB(parent, value); + } + + for(Node *node=parent; node; node = node->parent){ + node->bb = cpBBMerge(node->A->bb, node->B->bb); + } +} + +//MARK: Subtree Functions + +static inline cpFloat +cpBBProximity(cpBB a, cpBB b) +{ + return cpfabs(a.l + a.r - b.l - b.r) + cpfabs(a.b + a.t - b.b - b.t); +} + +static Node * +SubtreeInsert(Node *subtree, Node *leaf, cpBBTree *tree) +{ + if(subtree == NULL){ + return leaf; + } else if(NodeIsLeaf(subtree)){ + return NodeNew(tree, leaf, subtree); + } else { + cpFloat cost_a = cpBBArea(subtree->B->bb) + cpBBMergedArea(subtree->A->bb, leaf->bb); + cpFloat cost_b = cpBBArea(subtree->A->bb) + cpBBMergedArea(subtree->B->bb, leaf->bb); + + if(cost_a == cost_b){ + cost_a = cpBBProximity(subtree->A->bb, leaf->bb); + cost_b = cpBBProximity(subtree->B->bb, leaf->bb); + } + + if(cost_b < cost_a){ + NodeSetB(subtree, SubtreeInsert(subtree->B, leaf, tree)); + } else { + NodeSetA(subtree, SubtreeInsert(subtree->A, leaf, tree)); + } + + subtree->bb = cpBBMerge(subtree->bb, leaf->bb); + return subtree; + } +} + +static void +SubtreeQuery(Node *subtree, void *obj, cpBB bb, cpSpatialIndexQueryFunc func, void *data) +{ + if(cpBBIntersects(subtree->bb, bb)){ + if(NodeIsLeaf(subtree)){ + func(obj, subtree->obj, 0, data); + } else { + SubtreeQuery(subtree->A, obj, bb, func, data); + SubtreeQuery(subtree->B, obj, bb, func, data); + } + } +} + + +static cpFloat +SubtreeSegmentQuery(Node *subtree, void *obj, cpVect a, cpVect b, cpFloat t_exit, cpSpatialIndexSegmentQueryFunc func, void *data) +{ + if(NodeIsLeaf(subtree)){ + return func(obj, subtree->obj, data); + } else { + cpFloat t_a = cpBBSegmentQuery(subtree->A->bb, a, b); + cpFloat t_b = cpBBSegmentQuery(subtree->B->bb, a, b); + + if(t_a < t_b){ + if(t_a < t_exit) t_exit = cpfmin(t_exit, SubtreeSegmentQuery(subtree->A, obj, a, b, t_exit, func, data)); + if(t_b < t_exit) t_exit = cpfmin(t_exit, SubtreeSegmentQuery(subtree->B, obj, a, b, t_exit, func, data)); + } else { + if(t_b < t_exit) t_exit = cpfmin(t_exit, SubtreeSegmentQuery(subtree->B, obj, a, b, t_exit, func, data)); + if(t_a < t_exit) t_exit = cpfmin(t_exit, SubtreeSegmentQuery(subtree->A, obj, a, b, t_exit, func, data)); + } + + return t_exit; + } +} + +static void +SubtreeRecycle(cpBBTree *tree, Node *node) +{ + if(!NodeIsLeaf(node)){ + SubtreeRecycle(tree, node->A); + SubtreeRecycle(tree, node->B); + NodeRecycle(tree, node); + } +} + +static inline Node * +SubtreeRemove(Node *subtree, Node *leaf, cpBBTree *tree) +{ + if(leaf == subtree){ + return NULL; + } else { + Node *parent = leaf->parent; + if(parent == subtree){ + Node *other = NodeOther(subtree, leaf); + other->parent = subtree->parent; + NodeRecycle(tree, subtree); + return other; + } else { + NodeReplaceChild(parent->parent, parent, NodeOther(parent, leaf), tree); + return subtree; + } + } +} + +//MARK: Marking Functions + +typedef struct MarkContext { + cpBBTree *tree; + Node *staticRoot; + cpSpatialIndexQueryFunc func; + void *data; +} MarkContext; + +static void +MarkLeafQuery(Node *subtree, Node *leaf, cpBool left, MarkContext *context) +{ + if(cpBBIntersects(leaf->bb, subtree->bb)){ + if(NodeIsLeaf(subtree)){ + if(left){ + PairInsert(leaf, subtree, context->tree); + } else { + if(subtree->STAMP < leaf->STAMP) PairInsert(subtree, leaf, context->tree); + context->func(leaf->obj, subtree->obj, 0, context->data); + } + } else { + MarkLeafQuery(subtree->A, leaf, left, context); + MarkLeafQuery(subtree->B, leaf, left, context); + } + } +} + +static void +MarkLeaf(Node *leaf, MarkContext *context) +{ + cpBBTree *tree = context->tree; + if(leaf->STAMP == GetMasterTree(tree)->stamp){ + Node *staticRoot = context->staticRoot; + if(staticRoot) MarkLeafQuery(staticRoot, leaf, cpFalse, context); + + for(Node *node = leaf; node->parent; node = node->parent){ + if(node == node->parent->A){ + MarkLeafQuery(node->parent->B, leaf, cpTrue, context); + } else { + MarkLeafQuery(node->parent->A, leaf, cpFalse, context); + } + } + } else { + Pair *pair = leaf->PAIRS; + while(pair){ + if(leaf == pair->b.leaf){ + pair->id = context->func(pair->a.leaf->obj, leaf->obj, pair->id, context->data); + pair = pair->b.next; + } else { + pair = pair->a.next; + } + } + } +} + +static void +MarkSubtree(Node *subtree, MarkContext *context) +{ + if(NodeIsLeaf(subtree)){ + MarkLeaf(subtree, context); + } else { + MarkSubtree(subtree->A, context); + MarkSubtree(subtree->B, context); // TODO: Force TCO here? + } +} + +//MARK: Leaf Functions + +static Node * +LeafNew(cpBBTree *tree, void *obj, cpBB bb) +{ + Node *node = NodeFromPool(tree); + node->obj = obj; + node->bb = GetBB(tree, obj); + + node->parent = NULL; + node->STAMP = 0; + node->PAIRS = NULL; + + return node; +} + +static cpBool +LeafUpdate(Node *leaf, cpBBTree *tree) +{ + Node *root = tree->root; + cpBB bb = tree->spatialIndex.bbfunc(leaf->obj); + + if(!cpBBContainsBB(leaf->bb, bb)){ + leaf->bb = GetBB(tree, leaf->obj); + + root = SubtreeRemove(root, leaf, tree); + tree->root = SubtreeInsert(root, leaf, tree); + + PairsClear(leaf, tree); + leaf->STAMP = GetMasterTree(tree)->stamp; + + return cpTrue; + } else { + return cpFalse; + } +} + +static cpCollisionID VoidQueryFunc(void *obj1, void *obj2, cpCollisionID id, void *data){return id;} + +static void +LeafAddPairs(Node *leaf, cpBBTree *tree) +{ + cpSpatialIndex *dynamicIndex = tree->spatialIndex.dynamicIndex; + if(dynamicIndex){ + Node *dynamicRoot = GetRootIfTree(dynamicIndex); + if(dynamicRoot){ + cpBBTree *dynamicTree = GetTree(dynamicIndex); + MarkContext context = {dynamicTree, NULL, NULL, NULL}; + MarkLeafQuery(dynamicRoot, leaf, cpTrue, &context); + } + } else { + Node *staticRoot = GetRootIfTree(tree->spatialIndex.staticIndex); + MarkContext context = {tree, staticRoot, VoidQueryFunc, NULL}; + MarkLeaf(leaf, &context); + } +} + +//MARK: Memory Management Functions + +cpBBTree * +cpBBTreeAlloc(void) +{ + return (cpBBTree *)cpcalloc(1, sizeof(cpBBTree)); +} + +static int +leafSetEql(void *obj, Node *node) +{ + return (obj == node->obj); +} + +static void * +leafSetTrans(void *obj, cpBBTree *tree) +{ + return LeafNew(tree, obj, tree->spatialIndex.bbfunc(obj)); +} + +cpSpatialIndex * +cpBBTreeInit(cpBBTree *tree, cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex) +{ + cpSpatialIndexInit((cpSpatialIndex *)tree, Klass(), bbfunc, staticIndex); + + tree->velocityFunc = NULL; + + tree->leaves = cpHashSetNew(0, (cpHashSetEqlFunc)leafSetEql); + tree->root = NULL; + + tree->pooledNodes = NULL; + tree->allocatedBuffers = cpArrayNew(0); + + tree->stamp = 0; + + return (cpSpatialIndex *)tree; +} + +void +cpBBTreeSetVelocityFunc(cpSpatialIndex *index, cpBBTreeVelocityFunc func) +{ + if(index->klass != Klass()){ + cpAssertWarn(cpFalse, "Ignoring cpBBTreeSetVelocityFunc() call to non-tree spatial index."); + return; + } + + ((cpBBTree *)index)->velocityFunc = func; +} + +cpSpatialIndex * +cpBBTreeNew(cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex) +{ + return cpBBTreeInit(cpBBTreeAlloc(), bbfunc, staticIndex); +} + +static void +cpBBTreeDestroy(cpBBTree *tree) +{ + cpHashSetFree(tree->leaves); + + if(tree->allocatedBuffers) cpArrayFreeEach(tree->allocatedBuffers, cpfree); + cpArrayFree(tree->allocatedBuffers); +} + +//MARK: Insert/Remove + +static void +cpBBTreeInsert(cpBBTree *tree, void *obj, cpHashValue hashid) +{ + Node *leaf = (Node *)cpHashSetInsert(tree->leaves, hashid, obj, (cpHashSetTransFunc)leafSetTrans, tree); + + Node *root = tree->root; + tree->root = SubtreeInsert(root, leaf, tree); + + leaf->STAMP = GetMasterTree(tree)->stamp; + LeafAddPairs(leaf, tree); + IncrementStamp(tree); +} + +static void +cpBBTreeRemove(cpBBTree *tree, void *obj, cpHashValue hashid) +{ + Node *leaf = (Node *)cpHashSetRemove(tree->leaves, hashid, obj); + + tree->root = SubtreeRemove(tree->root, leaf, tree); + PairsClear(leaf, tree); + NodeRecycle(tree, leaf); +} + +static cpBool +cpBBTreeContains(cpBBTree *tree, void *obj, cpHashValue hashid) +{ + return (cpHashSetFind(tree->leaves, hashid, obj) != NULL); +} + +//MARK: Reindex + +static void LeafUpdateWrap(Node *leaf, cpBBTree *tree) {LeafUpdate(leaf, tree);} + +static void +cpBBTreeReindexQuery(cpBBTree *tree, cpSpatialIndexQueryFunc func, void *data) +{ + if(!tree->root) return; + + // LeafUpdate() may modify tree->root. Don't cache it. + cpHashSetEach(tree->leaves, (cpHashSetIteratorFunc)LeafUpdateWrap, tree); + + cpSpatialIndex *staticIndex = tree->spatialIndex.staticIndex; + Node *staticRoot = (staticIndex && staticIndex->klass == Klass() ? ((cpBBTree *)staticIndex)->root : NULL); + + MarkContext context = {tree, staticRoot, func, data}; + MarkSubtree(tree->root, &context); + if(staticIndex && !staticRoot) cpSpatialIndexCollideStatic((cpSpatialIndex *)tree, staticIndex, func, data); + + IncrementStamp(tree); +} + +static void +cpBBTreeReindex(cpBBTree *tree) +{ + cpBBTreeReindexQuery(tree, VoidQueryFunc, NULL); +} + +static void +cpBBTreeReindexObject(cpBBTree *tree, void *obj, cpHashValue hashid) +{ + Node *leaf = (Node *)cpHashSetFind(tree->leaves, hashid, obj); + if(leaf){ + if(LeafUpdate(leaf, tree)) LeafAddPairs(leaf, tree); + IncrementStamp(tree); + } +} + +//MARK: Query + +static void +cpBBTreeSegmentQuery(cpBBTree *tree, void *obj, cpVect a, cpVect b, cpFloat t_exit, cpSpatialIndexSegmentQueryFunc func, void *data) +{ + Node *root = tree->root; + if(root) SubtreeSegmentQuery(root, obj, a, b, t_exit, func, data); +} + +static void +cpBBTreeQuery(cpBBTree *tree, void *obj, cpBB bb, cpSpatialIndexQueryFunc func, void *data) +{ + if(tree->root) SubtreeQuery(tree->root, obj, bb, func, data); +} + +//MARK: Misc + +static int +cpBBTreeCount(cpBBTree *tree) +{ + return cpHashSetCount(tree->leaves); +} + +typedef struct eachContext { + cpSpatialIndexIteratorFunc func; + void *data; +} eachContext; + +static void each_helper(Node *node, eachContext *context){context->func(node->obj, context->data);} + +static void +cpBBTreeEach(cpBBTree *tree, cpSpatialIndexIteratorFunc func, void *data) +{ + eachContext context = {func, data}; + cpHashSetEach(tree->leaves, (cpHashSetIteratorFunc)each_helper, &context); +} + +static cpSpatialIndexClass klass = { + (cpSpatialIndexDestroyImpl)cpBBTreeDestroy, + + (cpSpatialIndexCountImpl)cpBBTreeCount, + (cpSpatialIndexEachImpl)cpBBTreeEach, + + (cpSpatialIndexContainsImpl)cpBBTreeContains, + (cpSpatialIndexInsertImpl)cpBBTreeInsert, + (cpSpatialIndexRemoveImpl)cpBBTreeRemove, + + (cpSpatialIndexReindexImpl)cpBBTreeReindex, + (cpSpatialIndexReindexObjectImpl)cpBBTreeReindexObject, + (cpSpatialIndexReindexQueryImpl)cpBBTreeReindexQuery, + + (cpSpatialIndexQueryImpl)cpBBTreeQuery, + (cpSpatialIndexSegmentQueryImpl)cpBBTreeSegmentQuery, +}; + +static inline cpSpatialIndexClass *Klass(){return &klass;} + + +//MARK: Tree Optimization + +static int +cpfcompare(const cpFloat *a, const cpFloat *b){ + return (*a < *b ? -1 : (*b < *a ? 1 : 0)); +} + +static void +fillNodeArray(Node *node, Node ***cursor){ + (**cursor) = node; + (*cursor)++; +} + +static Node * +partitionNodes(cpBBTree *tree, Node **nodes, int count) +{ + if(count == 1){ + return nodes[0]; + } else if(count == 2) { + return NodeNew(tree, nodes[0], nodes[1]); + } + + // Find the AABB for these nodes + cpBB bb = nodes[0]->bb; + for(int i=1; ibb); + + // Split it on it's longest axis + cpBool splitWidth = (bb.r - bb.l > bb.t - bb.b); + + // Sort the bounds and use the median as the splitting point + cpFloat *bounds = (cpFloat *)cpcalloc(count*2, sizeof(cpFloat)); + if(splitWidth){ + for(int i=0; ibb.l; + bounds[2*i + 1] = nodes[i]->bb.r; + } + } else { + for(int i=0; ibb.b; + bounds[2*i + 1] = nodes[i]->bb.t; + } + } + + qsort(bounds, count*2, sizeof(cpFloat), (int (*)(const void *, const void *))cpfcompare); + cpFloat split = (bounds[count - 1] + bounds[count])*0.5f; // use the medain as the split + cpfree(bounds); + + // Generate the child BBs + cpBB a = bb, b = bb; + if(splitWidth) a.r = b.l = split; else a.t = b.b = split; + + // Partition the nodes + int right = count; + for(int left=0; left < right;){ + Node *node = nodes[left]; + if(cpBBMergedArea(node->bb, b) < cpBBMergedArea(node->bb, a)){ +// if(cpBBProximity(node->bb, b) < cpBBProximity(node->bb, a)){ + right--; + nodes[left] = nodes[right]; + nodes[right] = node; + } else { + left++; + } + } + + if(right == count){ + Node *node = NULL; + for(int i=0; iroot; +// Node *node = root; +// int bit = 0; +// unsigned int path = tree->opath; +// +// while(!NodeIsLeaf(node)){ +// node = (path&(1<a : node->b); +// bit = (bit + 1)&(sizeof(unsigned int)*8 - 1); +// } +// +// root = subtreeRemove(root, node, tree); +// tree->root = subtreeInsert(root, node, tree); +// } +//} + +void +cpBBTreeOptimize(cpSpatialIndex *index) +{ + if(index->klass != &klass){ + cpAssertWarn(cpFalse, "Ignoring cpBBTreeOptimize() call to non-tree spatial index."); + return; + } + + cpBBTree *tree = (cpBBTree *)index; + Node *root = tree->root; + if(!root) return; + + int count = cpBBTreeCount(tree); + Node **nodes = (Node **)cpcalloc(count, sizeof(Node *)); + Node **cursor = nodes; + + cpHashSetEach(tree->leaves, (cpHashSetIteratorFunc)fillNodeArray, &cursor); + + SubtreeRecycle(tree, root); + tree->root = partitionNodes(tree, nodes, count); + cpfree(nodes); +} + +//MARK: Debug Draw + +//#define CP_BBTREE_DEBUG_DRAW +#ifdef CP_BBTREE_DEBUG_DRAW +#include "OpenGL/gl.h" +#include "OpenGL/glu.h" +#include + +static void +NodeRender(Node *node, int depth) +{ + if(!NodeIsLeaf(node) && depth <= 10){ + NodeRender(node->a, depth + 1); + NodeRender(node->b, depth + 1); + } + + cpBB bb = node->bb; + +// GLfloat v = depth/2.0f; +// glColor3f(1.0f - v, v, 0.0f); + glLineWidth(cpfmax(5.0f - depth, 1.0f)); + glBegin(GL_LINES); { + glVertex2f(bb.l, bb.b); + glVertex2f(bb.l, bb.t); + + glVertex2f(bb.l, bb.t); + glVertex2f(bb.r, bb.t); + + glVertex2f(bb.r, bb.t); + glVertex2f(bb.r, bb.b); + + glVertex2f(bb.r, bb.b); + glVertex2f(bb.l, bb.b); + }; glEnd(); +} + +void +cpBBTreeRenderDebug(cpSpatialIndex *index){ + if(index->klass != &klass){ + cpAssertWarn(cpFalse, "Ignoring cpBBTreeRenderDebug() call to non-tree spatial index."); + return; + } + + cpBBTree *tree = (cpBBTree *)index; + if(tree->root) NodeRender(tree->root, 0); +} +#endif diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpBody.c b/source/engine/thirdparty/Chipmunk2D/src/cpBody.c new file mode 100644 index 0000000..8ad2bc9 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpBody.c @@ -0,0 +1,626 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include +#include + +#include "chipmunk/chipmunk_private.h" + +cpBody* +cpBodyAlloc(void) +{ + return (cpBody *)cpcalloc(1, sizeof(cpBody)); +} + +cpBody * +cpBodyInit(cpBody *body, cpFloat mass, cpFloat moment) +{ + body->space = NULL; + body->shapeList = NULL; + body->arbiterList = NULL; + body->constraintList = NULL; + + body->velocity_func = cpBodyUpdateVelocity; + body->position_func = cpBodyUpdatePosition; + + body->sleeping.root = NULL; + body->sleeping.next = NULL; + body->sleeping.idleTime = 0.0f; + + body->p = cpvzero; + body->v = cpvzero; + body->f = cpvzero; + + body->w = 0.0f; + body->t = 0.0f; + + body->v_bias = cpvzero; + body->w_bias = 0.0f; + + body->userData = NULL; + + // Setters must be called after full initialization so the sanity checks don't assert on garbage data. + cpBodySetMass(body, mass); + cpBodySetMoment(body, moment); + cpBodySetAngle(body, 0.0f); + + return body; +} + +cpBody* +cpBodyNew(cpFloat mass, cpFloat moment) +{ + return cpBodyInit(cpBodyAlloc(), mass, moment); +} + +cpBody* +cpBodyNewKinematic() +{ + cpBody *body = cpBodyNew(0.0f, 0.0f); + cpBodySetType(body, CP_BODY_TYPE_KINEMATIC); + + return body; +} + +cpBody* +cpBodyNewStatic() +{ + cpBody *body = cpBodyNew(0.0f, 0.0f); + cpBodySetType(body, CP_BODY_TYPE_STATIC); + + return body; +} + +void cpBodyDestroy(cpBody *body){} + +void +cpBodyFree(cpBody *body) +{ + if(body){ + cpBodyDestroy(body); + cpfree(body); + } +} + +#ifdef NDEBUG + #define cpAssertSaneBody(body) +#else + static void cpv_assert_nan(cpVect v, char *message){cpAssertHard(v.x == v.x && v.y == v.y, message);} + static void cpv_assert_infinite(cpVect v, char *message){cpAssertHard(cpfabs(v.x) != INFINITY && cpfabs(v.y) != INFINITY, message);} + static void cpv_assert_sane(cpVect v, char *message){cpv_assert_nan(v, message); cpv_assert_infinite(v, message);} + + static void + cpBodySanityCheck(const cpBody *body) + { + cpAssertHard(body->m == body->m && body->m_inv == body->m_inv, "Body's mass is NaN."); + cpAssertHard(body->i == body->i && body->i_inv == body->i_inv, "Body's moment is NaN."); + cpAssertHard(body->m >= 0.0f, "Body's mass is negative."); + cpAssertHard(body->i >= 0.0f, "Body's moment is negative."); + + cpv_assert_sane(body->p, "Body's position is invalid."); + cpv_assert_sane(body->v, "Body's velocity is invalid."); + cpv_assert_sane(body->f, "Body's force is invalid."); + + cpAssertHard(body->a == body->a && cpfabs(body->a) != INFINITY, "Body's angle is invalid."); + cpAssertHard(body->w == body->w && cpfabs(body->w) != INFINITY, "Body's angular velocity is invalid."); + cpAssertHard(body->t == body->t && cpfabs(body->t) != INFINITY, "Body's torque is invalid."); + } + + #define cpAssertSaneBody(body) cpBodySanityCheck(body) +#endif + +cpBool +cpBodyIsSleeping(const cpBody *body) +{ + return (body->sleeping.root != ((cpBody*)0)); +} + +cpBodyType +cpBodyGetType(cpBody *body) +{ + if(body->sleeping.idleTime == INFINITY){ + return CP_BODY_TYPE_STATIC; + } else if(body->m == INFINITY){ + return CP_BODY_TYPE_KINEMATIC; + } else { + return CP_BODY_TYPE_DYNAMIC; + } +} + +void +cpBodySetType(cpBody *body, cpBodyType type) +{ + cpBodyType oldType = cpBodyGetType(body); + if(oldType == type) return; + + // Static bodies have their idle timers set to infinity. + // Non-static bodies should have their idle timer reset. + body->sleeping.idleTime = (type == CP_BODY_TYPE_STATIC ? INFINITY : 0.0f); + + if(type == CP_BODY_TYPE_DYNAMIC){ + body->m = body->i = 0.0f; + body->m_inv = body->i_inv = INFINITY; + + cpBodyAccumulateMassFromShapes(body); + } else { + body->m = body->i = INFINITY; + body->m_inv = body->i_inv = 0.0f; + + body->v = cpvzero; + body->w = 0.0f; + } + + // If the body is added to a space already, we'll need to update some space data structures. + cpSpace *space = cpBodyGetSpace(body); + if(space != NULL){ + cpAssertSpaceUnlocked(space); + + if(oldType == CP_BODY_TYPE_STATIC){ + // TODO This is probably not necessary +// cpBodyActivateStatic(body, NULL); + } else { + cpBodyActivate(body); + } + + // Move the bodies to the correct array. + cpArray *fromArray = cpSpaceArrayForBodyType(space, oldType); + cpArray *toArray = cpSpaceArrayForBodyType(space, type); + if(fromArray != toArray){ + cpArrayDeleteObj(fromArray, body); + cpArrayPush(toArray, body); + } + + // Move the body's shapes to the correct spatial index. + cpSpatialIndex *fromIndex = (oldType == CP_BODY_TYPE_STATIC ? space->staticShapes : space->dynamicShapes); + cpSpatialIndex *toIndex = (type == CP_BODY_TYPE_STATIC ? space->staticShapes : space->dynamicShapes); + if(fromIndex != toIndex){ + CP_BODY_FOREACH_SHAPE(body, shape){ + cpSpatialIndexRemove(fromIndex, shape, shape->hashid); + cpSpatialIndexInsert(toIndex, shape, shape->hashid); + } + } + } +} + + + +// Should *only* be called when shapes with mass info are modified, added or removed. +void +cpBodyAccumulateMassFromShapes(cpBody *body) +{ + if(body == NULL || cpBodyGetType(body) != CP_BODY_TYPE_DYNAMIC) return; + + // Reset the body's mass data. + body->m = body->i = 0.0f; + body->cog = cpvzero; + + // Cache the position to realign it at the end. + cpVect pos = cpBodyGetPosition(body); + + // Accumulate mass from shapes. + CP_BODY_FOREACH_SHAPE(body, shape){ + struct cpShapeMassInfo *info = &shape->massInfo; + cpFloat m = info->m; + + if(m > 0.0f){ + cpFloat msum = body->m + m; + + body->i += m*info->i + cpvdistsq(body->cog, info->cog)*(m*body->m)/msum; + body->cog = cpvlerp(body->cog, info->cog, m/msum); + body->m = msum; + } + } + + // Recalculate the inverses. + body->m_inv = 1.0f/body->m; + body->i_inv = 1.0f/body->i; + + // Realign the body since the CoG has probably moved. + cpBodySetPosition(body, pos); + cpAssertSaneBody(body); +} + +cpSpace * +cpBodyGetSpace(const cpBody *body) +{ + return body->space; +} + +cpFloat +cpBodyGetMass(const cpBody *body) +{ + return body->m; +} + +void +cpBodySetMass(cpBody *body, cpFloat mass) +{ + cpAssertHard(cpBodyGetType(body) == CP_BODY_TYPE_DYNAMIC, "You cannot set the mass of kinematic or static bodies."); + cpAssertHard(0.0f <= mass && mass < INFINITY, "Mass must be positive and finite."); + + cpBodyActivate(body); + body->m = mass; + body->m_inv = mass == 0.0f ? INFINITY : 1.0f/mass; + cpAssertSaneBody(body); +} + +cpFloat +cpBodyGetMoment(const cpBody *body) +{ + return body->i; +} + +void +cpBodySetMoment(cpBody *body, cpFloat moment) +{ + cpAssertHard(moment >= 0.0f, "Moment of Inertia must be positive."); + + cpBodyActivate(body); + body->i = moment; + body->i_inv = moment == 0.0f ? INFINITY : 1.0f/moment; + cpAssertSaneBody(body); +} + +cpVect +cpBodyGetRotation(const cpBody *body) +{ + return cpv(body->transform.a, body->transform.b); +} + +void +cpBodyAddShape(cpBody *body, cpShape *shape) +{ + cpShape *next = body->shapeList; + if(next) next->prev = shape; + + shape->next = next; + body->shapeList = shape; + + if(shape->massInfo.m > 0.0f){ + cpBodyAccumulateMassFromShapes(body); + } +} + +void +cpBodyRemoveShape(cpBody *body, cpShape *shape) +{ + cpShape *prev = shape->prev; + cpShape *next = shape->next; + + if(prev){ + prev->next = next; + } else { + body->shapeList = next; + } + + if(next){ + next->prev = prev; + } + + shape->prev = NULL; + shape->next = NULL; + + if(cpBodyGetType(body) == CP_BODY_TYPE_DYNAMIC && shape->massInfo.m > 0.0f){ + cpBodyAccumulateMassFromShapes(body); + } +} + +static cpConstraint * +filterConstraints(cpConstraint *node, cpBody *body, cpConstraint *filter) +{ + if(node == filter){ + return cpConstraintNext(node, body); + } else if(node->a == body){ + node->next_a = filterConstraints(node->next_a, body, filter); + } else { + node->next_b = filterConstraints(node->next_b, body, filter); + } + + return node; +} + +void +cpBodyRemoveConstraint(cpBody *body, cpConstraint *constraint) +{ + body->constraintList = filterConstraints(body->constraintList, body, constraint); +} + +// 'p' is the position of the CoG +static void +SetTransform(cpBody *body, cpVect p, cpFloat a) +{ + cpVect rot = cpvforangle(a); + cpVect c = body->cog; + + body->transform = cpTransformNewTranspose( + rot.x, -rot.y, p.x - (c.x*rot.x - c.y*rot.y), + rot.y, rot.x, p.y - (c.x*rot.y + c.y*rot.x) + ); +} + +static inline cpFloat +SetAngle(cpBody *body, cpFloat a) +{ + body->a = a; + cpAssertSaneBody(body); + + return a; +} + +cpVect +cpBodyGetPosition(const cpBody *body) +{ + return cpTransformPoint(body->transform, cpvzero); +} + +void +cpBodySetPosition(cpBody *body, cpVect position) +{ + cpBodyActivate(body); + cpVect p = body->p = cpvadd(cpTransformVect(body->transform, body->cog), position); + cpAssertSaneBody(body); + + SetTransform(body, p, body->a); +} + +cpVect +cpBodyGetCenterOfGravity(const cpBody *body) +{ + return body->cog; +} + +void +cpBodySetCenterOfGravity(cpBody *body, cpVect cog) +{ + cpBodyActivate(body); + body->cog = cog; + cpAssertSaneBody(body); +} + +cpVect +cpBodyGetVelocity(const cpBody *body) +{ + return body->v; +} + +void +cpBodySetVelocity(cpBody *body, cpVect velocity) +{ + cpBodyActivate(body); + body->v = velocity; + cpAssertSaneBody(body); +} + +cpVect +cpBodyGetForce(const cpBody *body) +{ + return body->f; +} + +void +cpBodySetForce(cpBody *body, cpVect force) +{ + cpBodyActivate(body); + body->f = force; + cpAssertSaneBody(body); +} + +cpFloat +cpBodyGetAngle(const cpBody *body) +{ + return body->a; +} + +void +cpBodySetAngle(cpBody *body, cpFloat angle) +{ + cpBodyActivate(body); + SetAngle(body, angle); + + SetTransform(body, body->p, angle); +} + +cpFloat +cpBodyGetAngularVelocity(const cpBody *body) +{ + return body->w; +} + +void +cpBodySetAngularVelocity(cpBody *body, cpFloat angularVelocity) +{ + cpBodyActivate(body); + body->w = angularVelocity; + cpAssertSaneBody(body); +} + +cpFloat +cpBodyGetTorque(const cpBody *body) +{ + return body->t; +} + +void +cpBodySetTorque(cpBody *body, cpFloat torque) +{ + cpBodyActivate(body); + body->t = torque; + cpAssertSaneBody(body); +} + +cpDataPointer +cpBodyGetUserData(const cpBody *body) +{ + return body->userData; +} + +void +cpBodySetUserData(cpBody *body, cpDataPointer userData) +{ + body->userData = userData; +} + +void +cpBodySetVelocityUpdateFunc(cpBody *body, cpBodyVelocityFunc velocityFunc) +{ + body->velocity_func = velocityFunc; +} + +void +cpBodySetPositionUpdateFunc(cpBody *body, cpBodyPositionFunc positionFunc) +{ + body->position_func = positionFunc; +} + +void +cpBodyUpdateVelocity(cpBody *body, cpVect gravity, cpFloat damping, cpFloat dt) +{ + // Skip kinematic bodies. + if(cpBodyGetType(body) == CP_BODY_TYPE_KINEMATIC) return; + + cpAssertSoft(body->m > 0.0f && body->i > 0.0f, "Body's mass and moment must be positive to simulate. (Mass: %f Moment: %f)", body->m, body->i); + + body->v = cpvadd(cpvmult(body->v, damping), cpvmult(cpvadd(gravity, cpvmult(body->f, body->m_inv)), dt)); + body->w = body->w*damping + body->t*body->i_inv*dt; + + // Reset forces. + body->f = cpvzero; + body->t = 0.0f; + + cpAssertSaneBody(body); +} + +void +cpBodyUpdatePosition(cpBody *body, cpFloat dt) +{ + cpVect p = body->p = cpvadd(body->p, cpvmult(cpvadd(body->v, body->v_bias), dt)); + cpFloat a = SetAngle(body, body->a + (body->w + body->w_bias)*dt); + SetTransform(body, p, a); + + body->v_bias = cpvzero; + body->w_bias = 0.0f; + + cpAssertSaneBody(body); +} + +cpVect +cpBodyLocalToWorld(const cpBody *body, const cpVect point) +{ + return cpTransformPoint(body->transform, point); +} + +cpVect +cpBodyWorldToLocal(const cpBody *body, const cpVect point) +{ + return cpTransformPoint(cpTransformRigidInverse(body->transform), point); +} + +void +cpBodyApplyForceAtWorldPoint(cpBody *body, cpVect force, cpVect point) +{ + cpBodyActivate(body); + body->f = cpvadd(body->f, force); + + cpVect r = cpvsub(point, cpTransformPoint(body->transform, body->cog)); + body->t += cpvcross(r, force); +} + +void +cpBodyApplyForceAtLocalPoint(cpBody *body, cpVect force, cpVect point) +{ + cpBodyApplyForceAtWorldPoint(body, cpTransformVect(body->transform, force), cpTransformPoint(body->transform, point)); +} + +void +cpBodyApplyImpulseAtWorldPoint(cpBody *body, cpVect impulse, cpVect point) +{ + cpBodyActivate(body); + + cpVect r = cpvsub(point, cpTransformPoint(body->transform, body->cog)); + apply_impulse(body, impulse, r); +} + +void +cpBodyApplyImpulseAtLocalPoint(cpBody *body, cpVect impulse, cpVect point) +{ + cpBodyApplyImpulseAtWorldPoint(body, cpTransformVect(body->transform, impulse), cpTransformPoint(body->transform, point)); +} + +cpVect +cpBodyGetVelocityAtLocalPoint(const cpBody *body, cpVect point) +{ + cpVect r = cpTransformVect(body->transform, cpvsub(point, body->cog)); + return cpvadd(body->v, cpvmult(cpvperp(r), body->w)); +} + +cpVect +cpBodyGetVelocityAtWorldPoint(const cpBody *body, cpVect point) +{ + cpVect r = cpvsub(point, cpTransformPoint(body->transform, body->cog)); + return cpvadd(body->v, cpvmult(cpvperp(r), body->w)); +} + +cpFloat +cpBodyKineticEnergy(const cpBody *body) +{ + // Need to do some fudging to avoid NaNs + cpFloat vsq = cpvdot(body->v, body->v); + cpFloat wsq = body->w*body->w; + return (vsq ? vsq*body->m : 0.0f) + (wsq ? wsq*body->i : 0.0f); +} + +void +cpBodyEachShape(cpBody *body, cpBodyShapeIteratorFunc func, void *data) +{ + cpShape *shape = body->shapeList; + while(shape){ + cpShape *next = shape->next; + func(body, shape, data); + shape = next; + } +} + +void +cpBodyEachConstraint(cpBody *body, cpBodyConstraintIteratorFunc func, void *data) +{ + cpConstraint *constraint = body->constraintList; + while(constraint){ + cpConstraint *next = cpConstraintNext(constraint, body); + func(body, constraint, data); + constraint = next; + } +} + +void +cpBodyEachArbiter(cpBody *body, cpBodyArbiterIteratorFunc func, void *data) +{ + cpArbiter *arb = body->arbiterList; + while(arb){ + cpArbiter *next = cpArbiterNext(arb, body); + + cpBool swapped = arb->swapped; { + arb->swapped = (body == arb->body_b); + func(body, arb, data); + } arb->swapped = swapped; + + arb = next; + } +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpCollision.c b/source/engine/thirdparty/Chipmunk2D/src/cpCollision.c new file mode 100644 index 0000000..33b3f59 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpCollision.c @@ -0,0 +1,726 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include +#include + +#include "chipmunk/chipmunk_private.h" +#include "chipmunk/cpRobust.h" + +#if DEBUG && 0 +#include "ChipmunkDemo.h" +#define DRAW_ALL 0 +#define DRAW_GJK (0 || DRAW_ALL) +#define DRAW_EPA (0 || DRAW_ALL) +#define DRAW_CLOSEST (0 || DRAW_ALL) +#define DRAW_CLIP (0 || DRAW_ALL) + +#define PRINT_LOG 0 +#endif + +#define MAX_GJK_ITERATIONS 30 +#define MAX_EPA_ITERATIONS 30 +#define WARN_GJK_ITERATIONS 20 +#define WARN_EPA_ITERATIONS 20 + +static inline void +cpCollisionInfoPushContact(struct cpCollisionInfo *info, cpVect p1, cpVect p2, cpHashValue hash) +{ + cpAssertSoft(info->count <= CP_MAX_CONTACTS_PER_ARBITER, "Internal error: Tried to push too many contacts."); + + struct cpContact *con = &info->arr[info->count]; + con->r1 = p1; + con->r2 = p2; + con->hash = hash; + + info->count++; +} + +//MARK: Support Points and Edges: + +// Support points are the maximal points on a shape's perimeter along a certain axis. +// The GJK and EPA algorithms use support points to iteratively sample the surface of the two shapes' minkowski difference. + +static inline int +PolySupportPointIndex(const int count, const struct cpSplittingPlane *planes, const cpVect n) +{ + cpFloat max = -INFINITY; + int index = 0; + + for(int i=0; i max){ + max = d; + index = i; + } + } + + return index; +} + +struct SupportPoint { + cpVect p; + // Save an index of the point so it can be cheaply looked up as a starting point for the next frame. + cpCollisionID index; +}; + +static inline struct SupportPoint +SupportPointNew(cpVect p, cpCollisionID index) +{ + struct SupportPoint point = {p, index}; + return point; +} + +typedef struct SupportPoint (*SupportPointFunc)(const cpShape *shape, const cpVect n); + +static inline struct SupportPoint +CircleSupportPoint(const cpCircleShape *circle, const cpVect n) +{ + return SupportPointNew(circle->tc, 0); +} + +static inline struct SupportPoint +SegmentSupportPoint(const cpSegmentShape *seg, const cpVect n) +{ + if(cpvdot(seg->ta, n) > cpvdot(seg->tb, n)){ + return SupportPointNew(seg->ta, 0); + } else { + return SupportPointNew(seg->tb, 1); + } +} + +static inline struct SupportPoint +PolySupportPoint(const cpPolyShape *poly, const cpVect n) +{ + const struct cpSplittingPlane *planes = poly->planes; + int i = PolySupportPointIndex(poly->count, planes, n); + return SupportPointNew(planes[i].v0, i); +} + +// A point on the surface of two shape's minkowski difference. +struct MinkowskiPoint { + // Cache the two original support points. + cpVect a, b; + // b - a + cpVect ab; + // Concatenate the two support point indexes. + cpCollisionID id; +}; + +static inline struct MinkowskiPoint +MinkowskiPointNew(const struct SupportPoint a, const struct SupportPoint b) +{ + struct MinkowskiPoint point = {a.p, b.p, cpvsub(b.p, a.p), (a.index & 0xFF)<<8 | (b.index & 0xFF)}; + return point; +} + +struct SupportContext { + const cpShape *shape1, *shape2; + SupportPointFunc func1, func2; +}; + +// Calculate the maximal point on the minkowski difference of two shapes along a particular axis. +static inline struct MinkowskiPoint +Support(const struct SupportContext *ctx, const cpVect n) +{ + struct SupportPoint a = ctx->func1(ctx->shape1, cpvneg(n)); + struct SupportPoint b = ctx->func2(ctx->shape2, n); + return MinkowskiPointNew(a, b); +} + +struct EdgePoint { + cpVect p; + // Keep a hash value for Chipmunk's collision hashing mechanism. + cpHashValue hash; +}; + +// Support edges are the edges of a polygon or segment shape that are in contact. +struct Edge { + struct EdgePoint a, b; + cpFloat r; + cpVect n; +}; + +static struct Edge +SupportEdgeForPoly(const cpPolyShape *poly, const cpVect n) +{ + int count = poly->count; + int i1 = PolySupportPointIndex(poly->count, poly->planes, n); + + // TODO: get rid of mod eventually, very expensive on ARM + int i0 = (i1 - 1 + count)%count; + int i2 = (i1 + 1)%count; + + const struct cpSplittingPlane *planes = poly->planes; + cpHashValue hashid = poly->shape.hashid; + if(cpvdot(n, planes[i1].n) > cpvdot(n, planes[i2].n)){ + struct Edge edge = {{planes[i0].v0, CP_HASH_PAIR(hashid, i0)}, {planes[i1].v0, CP_HASH_PAIR(hashid, i1)}, poly->r, planes[i1].n}; + return edge; + } else { + struct Edge edge = {{planes[i1].v0, CP_HASH_PAIR(hashid, i1)}, {planes[i2].v0, CP_HASH_PAIR(hashid, i2)}, poly->r, planes[i2].n}; + return edge; + } +} + +static struct Edge +SupportEdgeForSegment(const cpSegmentShape *seg, const cpVect n) +{ + cpHashValue hashid = seg->shape.hashid; + if(cpvdot(seg->tn, n) > 0.0){ + struct Edge edge = {{seg->ta, CP_HASH_PAIR(hashid, 0)}, {seg->tb, CP_HASH_PAIR(hashid, 1)}, seg->r, seg->tn}; + return edge; + } else { + struct Edge edge = {{seg->tb, CP_HASH_PAIR(hashid, 1)}, {seg->ta, CP_HASH_PAIR(hashid, 0)}, seg->r, cpvneg(seg->tn)}; + return edge; + } +} + +// Find the closest p(t) to (0, 0) where p(t) = a*(1-t)/2 + b*(1+t)/2 +// The range for t is [-1, 1] to avoid floating point issues if the parameters are swapped. +static inline cpFloat +ClosestT(const cpVect a, const cpVect b) +{ + cpVect delta = cpvsub(b, a); + return -cpfclamp(cpvdot(delta, cpvadd(a, b))/(cpvlengthsq(delta) + CPFLOAT_MIN), -1.0f, 1.0f); +} + +// Basically the same as cpvlerp(), except t = [-1, 1] +static inline cpVect +LerpT(const cpVect a, const cpVect b, const cpFloat t) +{ + cpFloat ht = 0.5f*t; + return cpvadd(cpvmult(a, 0.5f - ht), cpvmult(b, 0.5f + ht)); +} + +// Closest points on the surface of two shapes. +struct ClosestPoints { + // Surface points in absolute coordinates. + cpVect a, b; + // Minimum separating axis of the two shapes. + cpVect n; + // Signed distance between the points. + cpFloat d; + // Concatenation of the id's of the minkoski points. + cpCollisionID id; +}; + +// Calculate the closest points on two shapes given the closest edge on their minkowski difference to (0, 0) +static inline struct ClosestPoints +ClosestPointsNew(const struct MinkowskiPoint v0, const struct MinkowskiPoint v1) +{ + // Find the closest p(t) on the minkowski difference to (0, 0) + cpFloat t = ClosestT(v0.ab, v1.ab); + cpVect p = LerpT(v0.ab, v1.ab, t); + + // Interpolate the original support points using the same 't' value as above. + // This gives you the closest surface points in absolute coordinates. NEAT! + cpVect pa = LerpT(v0.a, v1.a, t); + cpVect pb = LerpT(v0.b, v1.b, t); + cpCollisionID id = (v0.id & 0xFFFF)<<16 | (v1.id & 0xFFFF); + + // First try calculating the MSA from the minkowski difference edge. + // This gives us a nice, accurate MSA when the surfaces are close together. + cpVect delta = cpvsub(v1.ab, v0.ab); + cpVect n = cpvnormalize(cpvrperp(delta)); + cpFloat d = cpvdot(n, p); + + if(d <= 0.0f || (-1.0f < t && t < 1.0f)){ + // If the shapes are overlapping, or we have a regular vertex/edge collision, we are done. + struct ClosestPoints points = {pa, pb, n, d, id}; + return points; + } else { + // Vertex/vertex collisions need special treatment since the MSA won't be shared with an axis of the minkowski difference. + cpFloat d2 = cpvlength(p); + cpVect n2 = cpvmult(p, 1.0f/(d2 + CPFLOAT_MIN)); + + struct ClosestPoints points = {pa, pb, n2, d2, id}; + return points; + } +} + +//MARK: EPA Functions + +static inline cpFloat +ClosestDist(const cpVect v0,const cpVect v1) +{ + return cpvlengthsq(LerpT(v0, v1, ClosestT(v0, v1))); +} + +// Recursive implementation of the EPA loop. +// Each recursion adds a point to the convex hull until it's known that we have the closest point on the surface. +static struct ClosestPoints +EPARecurse(const struct SupportContext *ctx, const int count, const struct MinkowskiPoint *hull, const int iteration) +{ + int mini = 0; + cpFloat minDist = INFINITY; + + // TODO: precalculate this when building the hull and save a step. + // Find the closest segment hull[i] and hull[i + 1] to (0, 0) + for(int j=0, i=count-1; j MAX_GJK_ITERATIONS){ + cpAssertWarn(iteration < WARN_GJK_ITERATIONS, "High GJK iterations: %d", iteration); + return ClosestPointsNew(v0, v1); + } + + if(cpCheckPointGreater(v1.ab, v0.ab, cpvzero)){ + // Origin is behind axis. Flip and try again. + return GJKRecurse(ctx, v1, v0, iteration); + } else { + cpFloat t = ClosestT(v0.ab, v1.ab); + cpVect n = (-1.0f < t && t < 1.0f ? cpvperp(cpvsub(v1.ab, v0.ab)) : cpvneg(LerpT(v0.ab, v1.ab, t))); + struct MinkowskiPoint p = Support(ctx, n); + +#if DRAW_GJK + ChipmunkDebugDrawSegment(v0.ab, v1.ab, RGBAColor(1, 1, 1, 1)); + cpVect c = cpvlerp(v0.ab, v1.ab, 0.5); + ChipmunkDebugDrawSegment(c, cpvadd(c, cpvmult(cpvnormalize(n), 5.0)), RGBAColor(1, 0, 0, 1)); + + ChipmunkDebugDrawDot(5.0, p.ab, LAColor(1, 1)); +#endif + + if(cpCheckPointGreater(p.ab, v0.ab, cpvzero) && cpCheckPointGreater(v1.ab, p.ab, cpvzero)){ + // The triangle v0, p, v1 contains the origin. Use EPA to find the MSA. + cpAssertWarn(iteration < WARN_GJK_ITERATIONS, "High GJK->EPA iterations: %d", iteration); + return EPA(ctx, v0, p, v1); + } else { + if(cpCheckAxis(v0.ab, v1.ab, p.ab, n)){ + // The edge v0, v1 that we already have is the closest to (0, 0) since p was not closer. + cpAssertWarn(iteration < WARN_GJK_ITERATIONS, "High GJK iterations: %d", iteration); + return ClosestPointsNew(v0, v1); + } else { + // p was closer to the origin than our existing edge. + // Need to figure out which existing point to drop. + if(ClosestDist(v0.ab, p.ab) < ClosestDist(p.ab, v1.ab)){ + return GJKRecurse(ctx, v0, p, iteration + 1); + } else { + return GJKRecurse(ctx, p, v1, iteration + 1); + } + } + } + } +} + +// Get a SupportPoint from a cached shape and index. +static struct SupportPoint +ShapePoint(const cpShape *shape, const int i) +{ + switch(shape->klass->type){ + case CP_CIRCLE_SHAPE: { + return SupportPointNew(((cpCircleShape *)shape)->tc, 0); + } case CP_SEGMENT_SHAPE: { + cpSegmentShape *seg = (cpSegmentShape *)shape; + return SupportPointNew(i == 0 ? seg->ta : seg->tb, i); + } case CP_POLY_SHAPE: { + cpPolyShape *poly = (cpPolyShape *)shape; + // Poly shapes may change vertex count. + int index = (i < poly->count ? i : 0); + return SupportPointNew(poly->planes[index].v0, index); + } default: { + return SupportPointNew(cpvzero, 0); + } + } +} + +// Find the closest points between two shapes using the GJK algorithm. +static struct ClosestPoints +GJK(const struct SupportContext *ctx, cpCollisionID *id) +{ +#if DRAW_GJK || DRAW_EPA + int count1 = 1; + int count2 = 1; + + switch(ctx->shape1->klass->type){ + case CP_SEGMENT_SHAPE: count1 = 2; break; + case CP_POLY_SHAPE: count1 = ((cpPolyShape *)ctx->shape1)->count; break; + default: break; + } + + switch(ctx->shape2->klass->type){ + case CP_SEGMENT_SHAPE: count1 = 2; break; + case CP_POLY_SHAPE: count2 = ((cpPolyShape *)ctx->shape2)->count; break; + default: break; + } + + + // draw the minkowski difference origin + cpVect origin = cpvzero; + ChipmunkDebugDrawDot(5.0, origin, RGBAColor(1,0,0,1)); + + int mdiffCount = count1*count2; + cpVect *mdiffVerts = alloca(mdiffCount*sizeof(cpVect)); + + for(int i=0; ishape2, j).p, ShapePoint(ctx->shape1, i).p); + mdiffVerts[i*count2 + j] = v; + ChipmunkDebugDrawDot(2.0, v, RGBAColor(1, 0, 0, 1)); + } + } + + cpVect *hullVerts = alloca(mdiffCount*sizeof(cpVect)); + int hullCount = cpConvexHull(mdiffCount, mdiffVerts, hullVerts, NULL, 0.0); + + ChipmunkDebugDrawPolygon(hullCount, hullVerts, 0.0, RGBAColor(1, 0, 0, 1), RGBAColor(1, 0, 0, 0.25)); +#endif + + struct MinkowskiPoint v0, v1; + if(*id){ + // Use the minkowski points from the last frame as a starting point using the cached indexes. + v0 = MinkowskiPointNew(ShapePoint(ctx->shape1, (*id>>24)&0xFF), ShapePoint(ctx->shape2, (*id>>16)&0xFF)); + v1 = MinkowskiPointNew(ShapePoint(ctx->shape1, (*id>> 8)&0xFF), ShapePoint(ctx->shape2, (*id )&0xFF)); + } else { + // No cached indexes, use the shapes' bounding box centers as a guess for a starting axis. + cpVect axis = cpvperp(cpvsub(cpBBCenter(ctx->shape1->bb), cpBBCenter(ctx->shape2->bb))); + v0 = Support(ctx, axis); + v1 = Support(ctx, cpvneg(axis)); + } + + struct ClosestPoints points = GJKRecurse(ctx, v0, v1, 1); + *id = points.id; + return points; +} + +//MARK: Contact Clipping + +// Given two support edges, find contact point pairs on their surfaces. +static inline void +ContactPoints(const struct Edge e1, const struct Edge e2, const struct ClosestPoints points, struct cpCollisionInfo *info) +{ + cpFloat mindist = e1.r + e2.r; + if(points.d <= mindist){ +#ifdef DRAW_CLIP + ChipmunkDebugDrawFatSegment(e1.a.p, e1.b.p, e1.r, RGBAColor(0, 1, 0, 1), LAColor(0, 0)); + ChipmunkDebugDrawFatSegment(e2.a.p, e2.b.p, e2.r, RGBAColor(1, 0, 0, 1), LAColor(0, 0)); +#endif + cpVect n = info->n = points.n; + + // Distances along the axis parallel to n + cpFloat d_e1_a = cpvcross(e1.a.p, n); + cpFloat d_e1_b = cpvcross(e1.b.p, n); + cpFloat d_e2_a = cpvcross(e2.a.p, n); + cpFloat d_e2_b = cpvcross(e2.b.p, n); + + // TODO + min isn't a complete fix. + cpFloat e1_denom = 1.0f/(d_e1_b - d_e1_a + CPFLOAT_MIN); + cpFloat e2_denom = 1.0f/(d_e2_b - d_e2_a + CPFLOAT_MIN); + + // Project the endpoints of the two edges onto the opposing edge, clamping them as necessary. + // Compare the projected points to the collision normal to see if the shapes overlap there. + { + cpVect p1 = cpvadd(cpvmult(n, e1.r), cpvlerp(e1.a.p, e1.b.p, cpfclamp01((d_e2_b - d_e1_a)*e1_denom))); + cpVect p2 = cpvadd(cpvmult(n, -e2.r), cpvlerp(e2.a.p, e2.b.p, cpfclamp01((d_e1_a - d_e2_a)*e2_denom))); + cpFloat dist = cpvdot(cpvsub(p2, p1), n); + if(dist <= 0.0f){ + cpHashValue hash_1a2b = CP_HASH_PAIR(e1.a.hash, e2.b.hash); + cpCollisionInfoPushContact(info, p1, p2, hash_1a2b); + } + }{ + cpVect p1 = cpvadd(cpvmult(n, e1.r), cpvlerp(e1.a.p, e1.b.p, cpfclamp01((d_e2_a - d_e1_a)*e1_denom))); + cpVect p2 = cpvadd(cpvmult(n, -e2.r), cpvlerp(e2.a.p, e2.b.p, cpfclamp01((d_e1_b - d_e2_a)*e2_denom))); + cpFloat dist = cpvdot(cpvsub(p2, p1), n); + if(dist <= 0.0f){ + cpHashValue hash_1b2a = CP_HASH_PAIR(e1.b.hash, e2.a.hash); + cpCollisionInfoPushContact(info, p1, p2, hash_1b2a); + } + } + } +} + +//MARK: Collision Functions + +typedef void (*CollisionFunc)(const cpShape *a, const cpShape *b, struct cpCollisionInfo *info); + +// Collide circle shapes. +static void +CircleToCircle(const cpCircleShape *c1, const cpCircleShape *c2, struct cpCollisionInfo *info) +{ + cpFloat mindist = c1->r + c2->r; + cpVect delta = cpvsub(c2->tc, c1->tc); + cpFloat distsq = cpvlengthsq(delta); + + if(distsq < mindist*mindist){ + cpFloat dist = cpfsqrt(distsq); + cpVect n = info->n = (dist ? cpvmult(delta, 1.0f/dist) : cpv(1.0f, 0.0f)); + cpCollisionInfoPushContact(info, cpvadd(c1->tc, cpvmult(n, c1->r)), cpvadd(c2->tc, cpvmult(n, -c2->r)), 0); + } +} + +static void +CircleToSegment(const cpCircleShape *circle, const cpSegmentShape *segment, struct cpCollisionInfo *info) +{ + cpVect seg_a = segment->ta; + cpVect seg_b = segment->tb; + cpVect center = circle->tc; + + // Find the closest point on the segment to the circle. + cpVect seg_delta = cpvsub(seg_b, seg_a); + cpFloat closest_t = cpfclamp01(cpvdot(seg_delta, cpvsub(center, seg_a))/cpvlengthsq(seg_delta)); + cpVect closest = cpvadd(seg_a, cpvmult(seg_delta, closest_t)); + + // Compare the radii of the two shapes to see if they are colliding. + cpFloat mindist = circle->r + segment->r; + cpVect delta = cpvsub(closest, center); + cpFloat distsq = cpvlengthsq(delta); + if(distsq < mindist*mindist){ + cpFloat dist = cpfsqrt(distsq); + // Handle coincident shapes as gracefully as possible. + cpVect n = info->n = (dist ? cpvmult(delta, 1.0f/dist) : segment->tn); + + // Reject endcap collisions if tangents are provided. + cpVect rot = cpBodyGetRotation(segment->shape.body); + if( + (closest_t != 0.0f || cpvdot(n, cpvrotate(segment->a_tangent, rot)) >= 0.0) && + (closest_t != 1.0f || cpvdot(n, cpvrotate(segment->b_tangent, rot)) >= 0.0) + ){ + cpCollisionInfoPushContact(info, cpvadd(center, cpvmult(n, circle->r)), cpvadd(closest, cpvmult(n, -segment->r)), 0); + } + } +} + +static void +SegmentToSegment(const cpSegmentShape *seg1, const cpSegmentShape *seg2, struct cpCollisionInfo *info) +{ + struct SupportContext context = {(cpShape *)seg1, (cpShape *)seg2, (SupportPointFunc)SegmentSupportPoint, (SupportPointFunc)SegmentSupportPoint}; + struct ClosestPoints points = GJK(&context, &info->id); + +#if DRAW_CLOSEST +#if PRINT_LOG +// ChipmunkDemoPrintString("Distance: %.2f\n", points.d); +#endif + + ChipmunkDebugDrawDot(6.0, points.a, RGBAColor(1, 1, 1, 1)); + ChipmunkDebugDrawDot(6.0, points.b, RGBAColor(1, 1, 1, 1)); + ChipmunkDebugDrawSegment(points.a, points.b, RGBAColor(1, 1, 1, 1)); + ChipmunkDebugDrawSegment(points.a, cpvadd(points.a, cpvmult(points.n, 10.0)), RGBAColor(1, 0, 0, 1)); +#endif + + cpVect n = points.n; + cpVect rot1 = cpBodyGetRotation(seg1->shape.body); + cpVect rot2 = cpBodyGetRotation(seg2->shape.body); + + // If the closest points are nearer than the sum of the radii... + if( + points.d <= (seg1->r + seg2->r) && ( + // Reject endcap collisions if tangents are provided. + (!cpveql(points.a, seg1->ta) || cpvdot(n, cpvrotate(seg1->a_tangent, rot1)) <= 0.0) && + (!cpveql(points.a, seg1->tb) || cpvdot(n, cpvrotate(seg1->b_tangent, rot1)) <= 0.0) && + (!cpveql(points.b, seg2->ta) || cpvdot(n, cpvrotate(seg2->a_tangent, rot2)) >= 0.0) && + (!cpveql(points.b, seg2->tb) || cpvdot(n, cpvrotate(seg2->b_tangent, rot2)) >= 0.0) + ) + ){ + ContactPoints(SupportEdgeForSegment(seg1, n), SupportEdgeForSegment(seg2, cpvneg(n)), points, info); + } +} + +static void +PolyToPoly(const cpPolyShape *poly1, const cpPolyShape *poly2, struct cpCollisionInfo *info) +{ + struct SupportContext context = {(cpShape *)poly1, (cpShape *)poly2, (SupportPointFunc)PolySupportPoint, (SupportPointFunc)PolySupportPoint}; + struct ClosestPoints points = GJK(&context, &info->id); + +#if DRAW_CLOSEST +#if PRINT_LOG +// ChipmunkDemoPrintString("Distance: %.2f\n", points.d); +#endif + + ChipmunkDebugDrawDot(3.0, points.a, RGBAColor(1, 1, 1, 1)); + ChipmunkDebugDrawDot(3.0, points.b, RGBAColor(1, 1, 1, 1)); + ChipmunkDebugDrawSegment(points.a, points.b, RGBAColor(1, 1, 1, 1)); + ChipmunkDebugDrawSegment(points.a, cpvadd(points.a, cpvmult(points.n, 10.0)), RGBAColor(1, 0, 0, 1)); +#endif + + // If the closest points are nearer than the sum of the radii... + if(points.d - poly1->r - poly2->r <= 0.0){ + ContactPoints(SupportEdgeForPoly(poly1, points.n), SupportEdgeForPoly(poly2, cpvneg(points.n)), points, info); + } +} + +static void +SegmentToPoly(const cpSegmentShape *seg, const cpPolyShape *poly, struct cpCollisionInfo *info) +{ + struct SupportContext context = {(cpShape *)seg, (cpShape *)poly, (SupportPointFunc)SegmentSupportPoint, (SupportPointFunc)PolySupportPoint}; + struct ClosestPoints points = GJK(&context, &info->id); + +#if DRAW_CLOSEST +#if PRINT_LOG +// ChipmunkDemoPrintString("Distance: %.2f\n", points.d); +#endif + + ChipmunkDebugDrawDot(3.0, points.a, RGBAColor(1, 1, 1, 1)); + ChipmunkDebugDrawDot(3.0, points.b, RGBAColor(1, 1, 1, 1)); + ChipmunkDebugDrawSegment(points.a, points.b, RGBAColor(1, 1, 1, 1)); + ChipmunkDebugDrawSegment(points.a, cpvadd(points.a, cpvmult(points.n, 10.0)), RGBAColor(1, 0, 0, 1)); +#endif + + cpVect n = points.n; + cpVect rot = cpBodyGetRotation(seg->shape.body); + + if( + // If the closest points are nearer than the sum of the radii... + points.d - seg->r - poly->r <= 0.0 && ( + // Reject endcap collisions if tangents are provided. + (!cpveql(points.a, seg->ta) || cpvdot(n, cpvrotate(seg->a_tangent, rot)) <= 0.0) && + (!cpveql(points.a, seg->tb) || cpvdot(n, cpvrotate(seg->b_tangent, rot)) <= 0.0) + ) + ){ + ContactPoints(SupportEdgeForSegment(seg, n), SupportEdgeForPoly(poly, cpvneg(n)), points, info); + } +} + +static void +CircleToPoly(const cpCircleShape *circle, const cpPolyShape *poly, struct cpCollisionInfo *info) +{ + struct SupportContext context = {(cpShape *)circle, (cpShape *)poly, (SupportPointFunc)CircleSupportPoint, (SupportPointFunc)PolySupportPoint}; + struct ClosestPoints points = GJK(&context, &info->id); + +#if DRAW_CLOSEST + ChipmunkDebugDrawDot(3.0, points.a, RGBAColor(1, 1, 1, 1)); + ChipmunkDebugDrawDot(3.0, points.b, RGBAColor(1, 1, 1, 1)); + ChipmunkDebugDrawSegment(points.a, points.b, RGBAColor(1, 1, 1, 1)); + ChipmunkDebugDrawSegment(points.a, cpvadd(points.a, cpvmult(points.n, 10.0)), RGBAColor(1, 0, 0, 1)); +#endif + + // If the closest points are nearer than the sum of the radii... + if(points.d <= circle->r + poly->r){ + cpVect n = info->n = points.n; + cpCollisionInfoPushContact(info, cpvadd(points.a, cpvmult(n, circle->r)), cpvadd(points.b, cpvmult(n, -poly->r)), 0); + } +} + +static void +CollisionError(const cpShape *circle, const cpShape *poly, struct cpCollisionInfo *info) +{ + cpAssertHard(cpFalse, "Internal Error: Shape types are not sorted."); +} + + +static const CollisionFunc BuiltinCollisionFuncs[9] = { + (CollisionFunc)CircleToCircle, + CollisionError, + CollisionError, + (CollisionFunc)CircleToSegment, + (CollisionFunc)SegmentToSegment, + CollisionError, + (CollisionFunc)CircleToPoly, + (CollisionFunc)SegmentToPoly, + (CollisionFunc)PolyToPoly, +}; +static const CollisionFunc *CollisionFuncs = BuiltinCollisionFuncs; + +struct cpCollisionInfo +cpCollide(const cpShape *a, const cpShape *b, cpCollisionID id, struct cpContact *contacts) +{ + struct cpCollisionInfo info = {a, b, id, cpvzero, 0, contacts}; + + // Make sure the shape types are in order. + if(a->klass->type > b->klass->type){ + info.a = b; + info.b = a; + } + + CollisionFuncs[info.a->klass->type + info.b->klass->type*CP_NUM_SHAPES](info.a, info.b, &info); + +// if(0){ +// for(int i=0; iklass = klass; + + constraint->a = a; + constraint->b = b; + constraint->space = NULL; + + constraint->next_a = NULL; + constraint->next_b = NULL; + + constraint->maxForce = (cpFloat)INFINITY; + constraint->errorBias = cpfpow(1.0f - 0.1f, 60.0f); + constraint->maxBias = (cpFloat)INFINITY; + + constraint->collideBodies = cpTrue; + + constraint->preSolve = NULL; + constraint->postSolve = NULL; +} + +cpSpace * +cpConstraintGetSpace(const cpConstraint *constraint) +{ + return constraint->space; +} + +cpBody * +cpConstraintGetBodyA(const cpConstraint *constraint) +{ + return constraint->a; +} + +cpBody * +cpConstraintGetBodyB(const cpConstraint *constraint) +{ + return constraint->b; +} + +cpFloat +cpConstraintGetMaxForce(const cpConstraint *constraint) +{ + return constraint->maxForce; +} + +void +cpConstraintSetMaxForce(cpConstraint *constraint, cpFloat maxForce) +{ + cpAssertHard(maxForce >= 0.0f, "maxForce must be positive."); + cpConstraintActivateBodies(constraint); + constraint->maxForce = maxForce; +} + +cpFloat +cpConstraintGetErrorBias(const cpConstraint *constraint) +{ + return constraint->errorBias; +} + +void +cpConstraintSetErrorBias(cpConstraint *constraint, cpFloat errorBias) +{ + cpAssertHard(errorBias >= 0.0f, "errorBias must be positive."); + cpConstraintActivateBodies(constraint); + constraint->errorBias = errorBias; +} + +cpFloat +cpConstraintGetMaxBias(const cpConstraint *constraint) +{ + return constraint->maxBias; +} + +void +cpConstraintSetMaxBias(cpConstraint *constraint, cpFloat maxBias) +{ + cpAssertHard(maxBias >= 0.0f, "maxBias must be positive."); + cpConstraintActivateBodies(constraint); + constraint->maxBias = maxBias; +} + +cpBool +cpConstraintGetCollideBodies(const cpConstraint *constraint) +{ + return constraint->collideBodies; +} + +void +cpConstraintSetCollideBodies(cpConstraint *constraint, cpBool collideBodies) +{ + cpConstraintActivateBodies(constraint); + constraint->collideBodies = collideBodies; +} + +cpConstraintPreSolveFunc +cpConstraintGetPreSolveFunc(const cpConstraint *constraint) +{ + return constraint->preSolve; +} + +void +cpConstraintSetPreSolveFunc(cpConstraint *constraint, cpConstraintPreSolveFunc preSolveFunc) +{ + constraint->preSolve = preSolveFunc; +} + +cpConstraintPostSolveFunc +cpConstraintGetPostSolveFunc(const cpConstraint *constraint) +{ + return constraint->postSolve; +} + +void +cpConstraintSetPostSolveFunc(cpConstraint *constraint, cpConstraintPostSolveFunc postSolveFunc) +{ + constraint->postSolve = postSolveFunc; +} + +cpDataPointer +cpConstraintGetUserData(const cpConstraint *constraint) +{ + return constraint->userData; +} + +void +cpConstraintSetUserData(cpConstraint *constraint, cpDataPointer userData) +{ + constraint->userData = userData; +} + + +cpFloat +cpConstraintGetImpulse(cpConstraint *constraint) +{ + return constraint->klass->getImpulse(constraint); +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpDampedRotarySpring.c b/source/engine/thirdparty/Chipmunk2D/src/cpDampedRotarySpring.c new file mode 100644 index 0000000..8d38a54 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpDampedRotarySpring.c @@ -0,0 +1,178 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +static cpFloat +defaultSpringTorque(cpDampedRotarySpring *spring, cpFloat relativeAngle){ + return (relativeAngle - spring->restAngle)*spring->stiffness; +} + +static void +preStep(cpDampedRotarySpring *spring, cpFloat dt) +{ + cpBody *a = spring->constraint.a; + cpBody *b = spring->constraint.b; + + cpFloat moment = a->i_inv + b->i_inv; + cpAssertSoft(moment != 0.0, "Unsolvable spring."); + spring->iSum = 1.0f/moment; + + spring->w_coef = 1.0f - cpfexp(-spring->damping*dt*moment); + spring->target_wrn = 0.0f; + + // apply spring torque + cpFloat j_spring = spring->springTorqueFunc((cpConstraint *)spring, a->a - b->a)*dt; + spring->jAcc = j_spring; + + a->w -= j_spring*a->i_inv; + b->w += j_spring*b->i_inv; +} + +static void applyCachedImpulse(cpDampedRotarySpring *spring, cpFloat dt_coef){} + +static void +applyImpulse(cpDampedRotarySpring *spring, cpFloat dt) +{ + cpBody *a = spring->constraint.a; + cpBody *b = spring->constraint.b; + + // compute relative velocity + cpFloat wrn = a->w - b->w;//normal_relative_velocity(a, b, r1, r2, n) - spring->target_vrn; + + // compute velocity loss from drag + // not 100% certain this is derived correctly, though it makes sense + cpFloat w_damp = (spring->target_wrn - wrn)*spring->w_coef; + spring->target_wrn = wrn + w_damp; + + //apply_impulses(a, b, spring->r1, spring->r2, cpvmult(spring->n, v_damp*spring->nMass)); + cpFloat j_damp = w_damp*spring->iSum; + spring->jAcc += j_damp; + + a->w += j_damp*a->i_inv; + b->w -= j_damp*b->i_inv; +} + +static cpFloat +getImpulse(cpDampedRotarySpring *spring) +{ + return spring->jAcc; +} + +static const cpConstraintClass klass = { + (cpConstraintPreStepImpl)preStep, + (cpConstraintApplyCachedImpulseImpl)applyCachedImpulse, + (cpConstraintApplyImpulseImpl)applyImpulse, + (cpConstraintGetImpulseImpl)getImpulse, +}; + +cpDampedRotarySpring * +cpDampedRotarySpringAlloc(void) +{ + return (cpDampedRotarySpring *)cpcalloc(1, sizeof(cpDampedRotarySpring)); +} + +cpDampedRotarySpring * +cpDampedRotarySpringInit(cpDampedRotarySpring *spring, cpBody *a, cpBody *b, cpFloat restAngle, cpFloat stiffness, cpFloat damping) +{ + cpConstraintInit((cpConstraint *)spring, &klass, a, b); + + spring->restAngle = restAngle; + spring->stiffness = stiffness; + spring->damping = damping; + spring->springTorqueFunc = (cpDampedRotarySpringTorqueFunc)defaultSpringTorque; + + spring->jAcc = 0.0f; + + return spring; +} + +cpConstraint * +cpDampedRotarySpringNew(cpBody *a, cpBody *b, cpFloat restAngle, cpFloat stiffness, cpFloat damping) +{ + return (cpConstraint *)cpDampedRotarySpringInit(cpDampedRotarySpringAlloc(), a, b, restAngle, stiffness, damping); +} + +cpBool +cpConstraintIsDampedRotarySpring(const cpConstraint *constraint) +{ + return (constraint->klass == &klass); +} + +cpFloat +cpDampedRotarySpringGetRestAngle(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsDampedRotarySpring(constraint), "Constraint is not a damped rotary spring."); + return ((cpDampedRotarySpring *)constraint)->restAngle; +} + +void +cpDampedRotarySpringSetRestAngle(cpConstraint *constraint, cpFloat restAngle) +{ + cpAssertHard(cpConstraintIsDampedRotarySpring(constraint), "Constraint is not a damped rotary spring."); + cpConstraintActivateBodies(constraint); + ((cpDampedRotarySpring *)constraint)->restAngle = restAngle; +} + +cpFloat +cpDampedRotarySpringGetStiffness(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsDampedRotarySpring(constraint), "Constraint is not a damped rotary spring."); + return ((cpDampedRotarySpring *)constraint)->stiffness; +} + +void +cpDampedRotarySpringSetStiffness(cpConstraint *constraint, cpFloat stiffness) +{ + cpAssertHard(cpConstraintIsDampedRotarySpring(constraint), "Constraint is not a damped rotary spring."); + cpConstraintActivateBodies(constraint); + ((cpDampedRotarySpring *)constraint)->stiffness = stiffness; +} + +cpFloat +cpDampedRotarySpringGetDamping(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsDampedRotarySpring(constraint), "Constraint is not a damped rotary spring."); + return ((cpDampedRotarySpring *)constraint)->damping; +} + +void +cpDampedRotarySpringSetDamping(cpConstraint *constraint, cpFloat damping) +{ + cpAssertHard(cpConstraintIsDampedRotarySpring(constraint), "Constraint is not a damped rotary spring."); + cpConstraintActivateBodies(constraint); + ((cpDampedRotarySpring *)constraint)->damping = damping; +} + +cpDampedRotarySpringTorqueFunc +cpDampedRotarySpringGetSpringTorqueFunc(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsDampedRotarySpring(constraint), "Constraint is not a damped rotary spring."); + return ((cpDampedRotarySpring *)constraint)->springTorqueFunc; +} + +void +cpDampedRotarySpringSetSpringTorqueFunc(cpConstraint *constraint, cpDampedRotarySpringTorqueFunc springTorqueFunc) +{ + cpAssertHard(cpConstraintIsDampedRotarySpring(constraint), "Constraint is not a damped rotary spring."); + cpConstraintActivateBodies(constraint); + ((cpDampedRotarySpring *)constraint)->springTorqueFunc = springTorqueFunc; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpDampedSpring.c b/source/engine/thirdparty/Chipmunk2D/src/cpDampedSpring.c new file mode 100644 index 0000000..e4d019e --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpDampedSpring.c @@ -0,0 +1,216 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +static cpFloat +defaultSpringForce(cpDampedSpring *spring, cpFloat dist){ + return (spring->restLength - dist)*spring->stiffness; +} + +static void +preStep(cpDampedSpring *spring, cpFloat dt) +{ + cpBody *a = spring->constraint.a; + cpBody *b = spring->constraint.b; + + spring->r1 = cpTransformVect(a->transform, cpvsub(spring->anchorA, a->cog)); + spring->r2 = cpTransformVect(b->transform, cpvsub(spring->anchorB, b->cog)); + + cpVect delta = cpvsub(cpvadd(b->p, spring->r2), cpvadd(a->p, spring->r1)); + cpFloat dist = cpvlength(delta); + spring->n = cpvmult(delta, 1.0f/(dist ? dist : INFINITY)); + + cpFloat k = k_scalar(a, b, spring->r1, spring->r2, spring->n); + cpAssertSoft(k != 0.0, "Unsolvable spring."); + spring->nMass = 1.0f/k; + + spring->target_vrn = 0.0f; + spring->v_coef = 1.0f - cpfexp(-spring->damping*dt*k); + + // apply spring force + cpFloat f_spring = spring->springForceFunc((cpConstraint *)spring, dist); + cpFloat j_spring = spring->jAcc = f_spring*dt; + apply_impulses(a, b, spring->r1, spring->r2, cpvmult(spring->n, j_spring)); +} + +static void applyCachedImpulse(cpDampedSpring *spring, cpFloat dt_coef){} + +static void +applyImpulse(cpDampedSpring *spring, cpFloat dt) +{ + cpBody *a = spring->constraint.a; + cpBody *b = spring->constraint.b; + + cpVect n = spring->n; + cpVect r1 = spring->r1; + cpVect r2 = spring->r2; + + // compute relative velocity + cpFloat vrn = normal_relative_velocity(a, b, r1, r2, n); + + // compute velocity loss from drag + cpFloat v_damp = (spring->target_vrn - vrn)*spring->v_coef; + spring->target_vrn = vrn + v_damp; + + cpFloat j_damp = v_damp*spring->nMass; + spring->jAcc += j_damp; + apply_impulses(a, b, spring->r1, spring->r2, cpvmult(spring->n, j_damp)); +} + +static cpFloat +getImpulse(cpDampedSpring *spring) +{ + return spring->jAcc; +} + +static const cpConstraintClass klass = { + (cpConstraintPreStepImpl)preStep, + (cpConstraintApplyCachedImpulseImpl)applyCachedImpulse, + (cpConstraintApplyImpulseImpl)applyImpulse, + (cpConstraintGetImpulseImpl)getImpulse, +}; + +cpDampedSpring * +cpDampedSpringAlloc(void) +{ + return (cpDampedSpring *)cpcalloc(1, sizeof(cpDampedSpring)); +} + +cpDampedSpring * +cpDampedSpringInit(cpDampedSpring *spring, cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB, cpFloat restLength, cpFloat stiffness, cpFloat damping) +{ + cpConstraintInit((cpConstraint *)spring, &klass, a, b); + + spring->anchorA = anchorA; + spring->anchorB = anchorB; + + spring->restLength = restLength; + spring->stiffness = stiffness; + spring->damping = damping; + spring->springForceFunc = (cpDampedSpringForceFunc)defaultSpringForce; + + spring->jAcc = 0.0f; + + return spring; +} + +cpConstraint * +cpDampedSpringNew(cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB, cpFloat restLength, cpFloat stiffness, cpFloat damping) +{ + return (cpConstraint *)cpDampedSpringInit(cpDampedSpringAlloc(), a, b, anchorA, anchorB, restLength, stiffness, damping); +} + +cpBool +cpConstraintIsDampedSpring(const cpConstraint *constraint) +{ + return (constraint->klass == &klass); +} + +cpVect +cpDampedSpringGetAnchorA(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsDampedSpring(constraint), "Constraint is not a damped spring."); + return ((cpDampedSpring *)constraint)->anchorA; +} + +void +cpDampedSpringSetAnchorA(cpConstraint *constraint, cpVect anchorA) +{ + cpAssertHard(cpConstraintIsDampedSpring(constraint), "Constraint is not a damped spring."); + cpConstraintActivateBodies(constraint); + ((cpDampedSpring *)constraint)->anchorA = anchorA; +} + +cpVect +cpDampedSpringGetAnchorB(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsDampedSpring(constraint), "Constraint is not a damped spring."); + return ((cpDampedSpring *)constraint)->anchorB; +} + +void +cpDampedSpringSetAnchorB(cpConstraint *constraint, cpVect anchorB) +{ + cpAssertHard(cpConstraintIsDampedSpring(constraint), "Constraint is not a damped spring."); + cpConstraintActivateBodies(constraint); + ((cpDampedSpring *)constraint)->anchorB = anchorB; +} + +cpFloat +cpDampedSpringGetRestLength(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsDampedSpring(constraint), "Constraint is not a damped spring."); + return ((cpDampedSpring *)constraint)->restLength; +} + +void +cpDampedSpringSetRestLength(cpConstraint *constraint, cpFloat restLength) +{ + cpAssertHard(cpConstraintIsDampedSpring(constraint), "Constraint is not a damped spring."); + cpConstraintActivateBodies(constraint); + ((cpDampedSpring *)constraint)->restLength = restLength; +} + +cpFloat +cpDampedSpringGetStiffness(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsDampedSpring(constraint), "Constraint is not a damped spring."); + return ((cpDampedSpring *)constraint)->stiffness; +} + +void +cpDampedSpringSetStiffness(cpConstraint *constraint, cpFloat stiffness) +{ + cpAssertHard(cpConstraintIsDampedSpring(constraint), "Constraint is not a damped spring."); + cpConstraintActivateBodies(constraint); + ((cpDampedSpring *)constraint)->stiffness = stiffness; +} + +cpFloat +cpDampedSpringGetDamping(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsDampedSpring(constraint), "Constraint is not a damped spring."); + return ((cpDampedSpring *)constraint)->damping; +} + +void +cpDampedSpringSetDamping(cpConstraint *constraint, cpFloat damping) +{ + cpAssertHard(cpConstraintIsDampedSpring(constraint), "Constraint is not a damped spring."); + cpConstraintActivateBodies(constraint); + ((cpDampedSpring *)constraint)->damping = damping; +} + +cpDampedSpringForceFunc +cpDampedSpringGetSpringForceFunc(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsDampedSpring(constraint), "Constraint is not a damped spring."); + return ((cpDampedSpring *)constraint)->springForceFunc; +} + +void +cpDampedSpringSetSpringForceFunc(cpConstraint *constraint, cpDampedSpringForceFunc springForceFunc) +{ + cpAssertHard(cpConstraintIsDampedSpring(constraint), "Constraint is not a damped spring."); + cpConstraintActivateBodies(constraint); + ((cpDampedSpring *)constraint)->springForceFunc = springForceFunc; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpGearJoint.c b/source/engine/thirdparty/Chipmunk2D/src/cpGearJoint.c new file mode 100644 index 0000000..3670173 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpGearJoint.c @@ -0,0 +1,145 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +static void +preStep(cpGearJoint *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + // calculate moment of inertia coefficient. + joint->iSum = 1.0f/(a->i_inv*joint->ratio_inv + joint->ratio*b->i_inv); + + // calculate bias velocity + cpFloat maxBias = joint->constraint.maxBias; + joint->bias = cpfclamp(-bias_coef(joint->constraint.errorBias, dt)*(b->a*joint->ratio - a->a - joint->phase)/dt, -maxBias, maxBias); +} + +static void +applyCachedImpulse(cpGearJoint *joint, cpFloat dt_coef) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + cpFloat j = joint->jAcc*dt_coef; + a->w -= j*a->i_inv*joint->ratio_inv; + b->w += j*b->i_inv; +} + +static void +applyImpulse(cpGearJoint *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + // compute relative rotational velocity + cpFloat wr = b->w*joint->ratio - a->w; + + cpFloat jMax = joint->constraint.maxForce*dt; + + // compute normal impulse + cpFloat j = (joint->bias - wr)*joint->iSum; + cpFloat jOld = joint->jAcc; + joint->jAcc = cpfclamp(jOld + j, -jMax, jMax); + j = joint->jAcc - jOld; + + // apply impulse + a->w -= j*a->i_inv*joint->ratio_inv; + b->w += j*b->i_inv; +} + +static cpFloat +getImpulse(cpGearJoint *joint) +{ + return cpfabs(joint->jAcc); +} + +static const cpConstraintClass klass = { + (cpConstraintPreStepImpl)preStep, + (cpConstraintApplyCachedImpulseImpl)applyCachedImpulse, + (cpConstraintApplyImpulseImpl)applyImpulse, + (cpConstraintGetImpulseImpl)getImpulse, +}; + +cpGearJoint * +cpGearJointAlloc(void) +{ + return (cpGearJoint *)cpcalloc(1, sizeof(cpGearJoint)); +} + +cpGearJoint * +cpGearJointInit(cpGearJoint *joint, cpBody *a, cpBody *b, cpFloat phase, cpFloat ratio) +{ + cpConstraintInit((cpConstraint *)joint, &klass, a, b); + + joint->phase = phase; + joint->ratio = ratio; + joint->ratio_inv = 1.0f/ratio; + + joint->jAcc = 0.0f; + + return joint; +} + +cpConstraint * +cpGearJointNew(cpBody *a, cpBody *b, cpFloat phase, cpFloat ratio) +{ + return (cpConstraint *)cpGearJointInit(cpGearJointAlloc(), a, b, phase, ratio); +} + +cpBool +cpConstraintIsGearJoint(const cpConstraint *constraint) +{ + return (constraint->klass == &klass); +} + +cpFloat +cpGearJointGetPhase(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsGearJoint(constraint), "Constraint is not a ratchet joint."); + return ((cpGearJoint *)constraint)->phase; +} + +void +cpGearJointSetPhase(cpConstraint *constraint, cpFloat phase) +{ + cpAssertHard(cpConstraintIsGearJoint(constraint), "Constraint is not a ratchet joint."); + cpConstraintActivateBodies(constraint); + ((cpGearJoint *)constraint)->phase = phase; +} + +cpFloat +cpGearJointGetRatio(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsGearJoint(constraint), "Constraint is not a ratchet joint."); + return ((cpGearJoint *)constraint)->ratio; +} + +void +cpGearJointSetRatio(cpConstraint *constraint, cpFloat ratio) +{ + cpAssertHard(cpConstraintIsGearJoint(constraint), "Constraint is not a ratchet joint."); + cpConstraintActivateBodies(constraint); + ((cpGearJoint *)constraint)->ratio = ratio; + ((cpGearJoint *)constraint)->ratio_inv = 1.0f/ratio; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpGrooveJoint.c b/source/engine/thirdparty/Chipmunk2D/src/cpGrooveJoint.c new file mode 100644 index 0000000..50d1857 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpGrooveJoint.c @@ -0,0 +1,197 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +static void +preStep(cpGrooveJoint *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + // calculate endpoints in worldspace + cpVect ta = cpTransformPoint(a->transform, joint->grv_a); + cpVect tb = cpTransformPoint(a->transform, joint->grv_b); + + // calculate axis + cpVect n = cpTransformVect(a->transform, joint->grv_n); + cpFloat d = cpvdot(ta, n); + + joint->grv_tn = n; + joint->r2 = cpTransformVect(b->transform, cpvsub(joint->anchorB, b->cog)); + + // calculate tangential distance along the axis of r2 + cpFloat td = cpvcross(cpvadd(b->p, joint->r2), n); + // calculate clamping factor and r2 + if(td <= cpvcross(ta, n)){ + joint->clamp = 1.0f; + joint->r1 = cpvsub(ta, a->p); + } else if(td >= cpvcross(tb, n)){ + joint->clamp = -1.0f; + joint->r1 = cpvsub(tb, a->p); + } else { + joint->clamp = 0.0f; + joint->r1 = cpvsub(cpvadd(cpvmult(cpvperp(n), -td), cpvmult(n, d)), a->p); + } + + // Calculate mass tensor + joint->k = k_tensor(a, b, joint->r1, joint->r2); + + // calculate bias velocity + cpVect delta = cpvsub(cpvadd(b->p, joint->r2), cpvadd(a->p, joint->r1)); + joint->bias = cpvclamp(cpvmult(delta, -bias_coef(joint->constraint.errorBias, dt)/dt), joint->constraint.maxBias); +} + +static void +applyCachedImpulse(cpGrooveJoint *joint, cpFloat dt_coef) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + apply_impulses(a, b, joint->r1, joint->r2, cpvmult(joint->jAcc, dt_coef)); +} + +static inline cpVect +grooveConstrain(cpGrooveJoint *joint, cpVect j, cpFloat dt){ + cpVect n = joint->grv_tn; + cpVect jClamp = (joint->clamp*cpvcross(j, n) > 0.0f) ? j : cpvproject(j, n); + return cpvclamp(jClamp, joint->constraint.maxForce*dt); +} + +static void +applyImpulse(cpGrooveJoint *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + cpVect r1 = joint->r1; + cpVect r2 = joint->r2; + + // compute impulse + cpVect vr = relative_velocity(a, b, r1, r2); + + cpVect j = cpMat2x2Transform(joint->k, cpvsub(joint->bias, vr)); + cpVect jOld = joint->jAcc; + joint->jAcc = grooveConstrain(joint, cpvadd(jOld, j), dt); + j = cpvsub(joint->jAcc, jOld); + + // apply impulse + apply_impulses(a, b, joint->r1, joint->r2, j); +} + +static cpFloat +getImpulse(cpGrooveJoint *joint) +{ + return cpvlength(joint->jAcc); +} + +static const cpConstraintClass klass = { + (cpConstraintPreStepImpl)preStep, + (cpConstraintApplyCachedImpulseImpl)applyCachedImpulse, + (cpConstraintApplyImpulseImpl)applyImpulse, + (cpConstraintGetImpulseImpl)getImpulse, +}; + +cpGrooveJoint * +cpGrooveJointAlloc(void) +{ + return (cpGrooveJoint *)cpcalloc(1, sizeof(cpGrooveJoint)); +} + +cpGrooveJoint * +cpGrooveJointInit(cpGrooveJoint *joint, cpBody *a, cpBody *b, cpVect groove_a, cpVect groove_b, cpVect anchorB) +{ + cpConstraintInit((cpConstraint *)joint, &klass, a, b); + + joint->grv_a = groove_a; + joint->grv_b = groove_b; + joint->grv_n = cpvperp(cpvnormalize(cpvsub(groove_b, groove_a))); + joint->anchorB = anchorB; + + joint->jAcc = cpvzero; + + return joint; +} + +cpConstraint * +cpGrooveJointNew(cpBody *a, cpBody *b, cpVect groove_a, cpVect groove_b, cpVect anchorB) +{ + return (cpConstraint *)cpGrooveJointInit(cpGrooveJointAlloc(), a, b, groove_a, groove_b, anchorB); +} + +cpBool +cpConstraintIsGrooveJoint(const cpConstraint *constraint) +{ + return (constraint->klass == &klass); +} + +cpVect +cpGrooveJointGetGrooveA(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsGrooveJoint(constraint), "Constraint is not a groove joint."); + return ((cpGrooveJoint *)constraint)->grv_a; +} + +void +cpGrooveJointSetGrooveA(cpConstraint *constraint, cpVect value) +{ + cpAssertHard(cpConstraintIsGrooveJoint(constraint), "Constraint is not a groove joint."); + cpGrooveJoint *g = (cpGrooveJoint *)constraint; + + g->grv_a = value; + g->grv_n = cpvperp(cpvnormalize(cpvsub(g->grv_b, value))); + + cpConstraintActivateBodies(constraint); +} + +cpVect +cpGrooveJointGetGrooveB(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsGrooveJoint(constraint), "Constraint is not a groove joint."); + return ((cpGrooveJoint *)constraint)->grv_b; +} + +void +cpGrooveJointSetGrooveB(cpConstraint *constraint, cpVect value) +{ + cpAssertHard(cpConstraintIsGrooveJoint(constraint), "Constraint is not a groove joint."); + cpGrooveJoint *g = (cpGrooveJoint *)constraint; + + g->grv_b = value; + g->grv_n = cpvperp(cpvnormalize(cpvsub(value, g->grv_a))); + + cpConstraintActivateBodies(constraint); +} + +cpVect +cpGrooveJointGetAnchorB(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsGrooveJoint(constraint), "Constraint is not a groove joint."); + return ((cpGrooveJoint *)constraint)->anchorB; +} + +void +cpGrooveJointSetAnchorB(cpConstraint *constraint, cpVect anchorB) +{ + cpAssertHard(cpConstraintIsGrooveJoint(constraint), "Constraint is not a groove joint."); + cpConstraintActivateBodies(constraint); + ((cpGrooveJoint *)constraint)->anchorB = anchorB; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpHashSet.c b/source/engine/thirdparty/Chipmunk2D/src/cpHashSet.c new file mode 100644 index 0000000..b2918de --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpHashSet.c @@ -0,0 +1,253 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" +#include "prime.h" + +typedef struct cpHashSetBin { + void *elt; + cpHashValue hash; + struct cpHashSetBin *next; +} cpHashSetBin; + +struct cpHashSet { + unsigned int entries, size; + + cpHashSetEqlFunc eql; + void *default_value; + + cpHashSetBin **table; + cpHashSetBin *pooledBins; + + cpArray *allocatedBuffers; +}; + +void +cpHashSetFree(cpHashSet *set) +{ + if(set){ + cpfree(set->table); + + cpArrayFreeEach(set->allocatedBuffers, cpfree); + cpArrayFree(set->allocatedBuffers); + + cpfree(set); + } +} + +cpHashSet * +cpHashSetNew(int size, cpHashSetEqlFunc eqlFunc) +{ + cpHashSet *set = (cpHashSet *)cpcalloc(1, sizeof(cpHashSet)); + + set->size = next_prime(size); + set->entries = 0; + + set->eql = eqlFunc; + set->default_value = NULL; + + set->table = (cpHashSetBin **)cpcalloc(set->size, sizeof(cpHashSetBin *)); + set->pooledBins = NULL; + + set->allocatedBuffers = cpArrayNew(0); + + return set; +} + +void +cpHashSetSetDefaultValue(cpHashSet *set, void *default_value) +{ + set->default_value = default_value; +} + +static int +setIsFull(cpHashSet *set) +{ + return (set->entries >= set->size); +} + +static void +cpHashSetResize(cpHashSet *set) +{ + // Get the next approximate doubled prime. + unsigned int newSize = next_prime(set->size + 1); + // Allocate a new table. + cpHashSetBin **newTable = (cpHashSetBin **)cpcalloc(newSize, sizeof(cpHashSetBin *)); + + // Iterate over the chains. + for(unsigned int i=0; isize; i++){ + // Rehash the bins into the new table. + cpHashSetBin *bin = set->table[i]; + while(bin){ + cpHashSetBin *next = bin->next; + + cpHashValue idx = bin->hash%newSize; + bin->next = newTable[idx]; + newTable[idx] = bin; + + bin = next; + } + } + + cpfree(set->table); + + set->table = newTable; + set->size = newSize; +} + +static inline void +recycleBin(cpHashSet *set, cpHashSetBin *bin) +{ + bin->next = set->pooledBins; + set->pooledBins = bin; + bin->elt = NULL; +} + +static cpHashSetBin * +getUnusedBin(cpHashSet *set) +{ + cpHashSetBin *bin = set->pooledBins; + + if(bin){ + set->pooledBins = bin->next; + return bin; + } else { + // Pool is exhausted, make more + int count = CP_BUFFER_BYTES/sizeof(cpHashSetBin); + cpAssertHard(count, "Internal Error: Buffer size is too small."); + + cpHashSetBin *buffer = (cpHashSetBin *)cpcalloc(1, CP_BUFFER_BYTES); + cpArrayPush(set->allocatedBuffers, buffer); + + // push all but the first one, return it instead + for(int i=1; ientries; +} + +const void * +cpHashSetInsert(cpHashSet *set, cpHashValue hash, const void *ptr, cpHashSetTransFunc trans, void *data) +{ + cpHashValue idx = hash%set->size; + + // Find the bin with the matching element. + cpHashSetBin *bin = set->table[idx]; + while(bin && !set->eql(ptr, bin->elt)) + bin = bin->next; + + // Create it if necessary. + if(!bin){ + bin = getUnusedBin(set); + bin->hash = hash; + bin->elt = (trans ? trans(ptr, data) : data); + + bin->next = set->table[idx]; + set->table[idx] = bin; + + set->entries++; + if(setIsFull(set)) cpHashSetResize(set); + } + + return bin->elt; +} + +const void * +cpHashSetRemove(cpHashSet *set, cpHashValue hash, const void *ptr) +{ + cpHashValue idx = hash%set->size; + + cpHashSetBin **prev_ptr = &set->table[idx]; + cpHashSetBin *bin = set->table[idx]; + + // Find the bin + while(bin && !set->eql(ptr, bin->elt)){ + prev_ptr = &bin->next; + bin = bin->next; + } + + // Remove it if it exists. + if(bin){ + // Update the previous linked list pointer + (*prev_ptr) = bin->next; + set->entries--; + + const void *elt = bin->elt; + recycleBin(set, bin); + + return elt; + } + + return NULL; +} + +const void * +cpHashSetFind(cpHashSet *set, cpHashValue hash, const void *ptr) +{ + cpHashValue idx = hash%set->size; + cpHashSetBin *bin = set->table[idx]; + while(bin && !set->eql(ptr, bin->elt)) + bin = bin->next; + + return (bin ? bin->elt : set->default_value); +} + +void +cpHashSetEach(cpHashSet *set, cpHashSetIteratorFunc func, void *data) +{ + for(unsigned int i=0; isize; i++){ + cpHashSetBin *bin = set->table[i]; + while(bin){ + cpHashSetBin *next = bin->next; + func(bin->elt, data); + bin = next; + } + } +} + +void +cpHashSetFilter(cpHashSet *set, cpHashSetFilterFunc func, void *data) +{ + for(unsigned int i=0; isize; i++){ + // The rest works similarly to cpHashSetRemove() above. + cpHashSetBin **prev_ptr = &set->table[i]; + cpHashSetBin *bin = set->table[i]; + while(bin){ + cpHashSetBin *next = bin->next; + + if(func(bin->elt, data)){ + prev_ptr = &bin->next; + } else { + (*prev_ptr) = next; + + set->entries--; + recycleBin(set, bin); + } + + bin = next; + } + } +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpHastySpace.c b/source/engine/thirdparty/Chipmunk2D/src/cpHastySpace.c new file mode 100644 index 0000000..8422c3e --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpHastySpace.c @@ -0,0 +1,700 @@ +// Copyright 2013 Howling Moon Software. All rights reserved. +// See http://chipmunk2d.net/legal.php for more information. + +#include +#include + +//TODO: Move all the thread stuff to another file + +//#include + +#ifdef __APPLE__ +#include +#endif + +#ifndef _WIN32 +#include +#elif defined(__MINGW32__) +#include +#else +#ifndef WIN32_LEAN_AND_MEAN +#define WIN32_LEAN_AND_MEAN +#endif + +#ifndef NOMINMAX +#define NOMINMAX +#endif + +#include // _beginthreadex +#include + +#ifndef ETIMEDOUT +#define ETIMEDOUT 1 +#endif + +// Simple pthread implementation for Windows +// Made from scratch to avoid the LGPL licence from pthread-win32 +enum { + SIGNAL = 0, + BROADCAST = 1, + MAX_EVENTS = 2 +}; + +typedef HANDLE pthread_t; +typedef struct +{ + // Based on http://www.cs.wustl.edu/~schmidt/win32-cv-1.html since Windows has no condition variable until NT6 + UINT waiters_count; + // Count of the number of waiters. + + CRITICAL_SECTION waiters_count_lock; + // Serialize access to . + + HANDLE events[MAX_EVENTS]; +} pthread_cond_t; +typedef CRITICAL_SECTION pthread_mutex_t; + +typedef struct {} pthread_condattr_t; // Dummy; + +int pthread_cond_destroy(pthread_cond_t* cv) +{ + CloseHandle(cv->events[BROADCAST]); + CloseHandle(cv->events[SIGNAL]); + + DeleteCriticalSection(&cv->waiters_count_lock); + + return 0; +} + +int pthread_cond_init(pthread_cond_t* cv, const pthread_condattr_t* attr) +{ + // Initialize the count to 0. + cv->waiters_count = 0; + + // Create an auto-reset event. + cv->events[SIGNAL] = CreateEvent(NULL, // no security + FALSE, // auto-reset event + FALSE, // non-signaled initially + NULL); // unnamed + + // Create a manual-reset event. + cv->events[BROADCAST] = CreateEvent(NULL, // no security + TRUE, // manual-reset + FALSE, // non-signaled initially + NULL); // unnamed + + InitializeCriticalSection(&cv->waiters_count_lock); + + return 0; +} + +int pthread_cond_broadcast(pthread_cond_t *cv) +{ + // Avoid race conditions. + EnterCriticalSection(&cv->waiters_count_lock); + int have_waiters = cv->waiters_count > 0; + LeaveCriticalSection(&cv->waiters_count_lock); + + if (have_waiters) + SetEvent(cv->events[BROADCAST]); + + return 0; +} + +int pthread_cond_signal(pthread_cond_t* cv) +{ + // Avoid race conditions. + EnterCriticalSection(&cv->waiters_count_lock); + int have_waiters = cv->waiters_count > 0; + LeaveCriticalSection(&cv->waiters_count_lock); + + if (have_waiters) + SetEvent(cv->events[SIGNAL]); + + return 0; +} + +int pthread_cond_wait(pthread_cond_t* cv, pthread_mutex_t* external_mutex) +{ + // Avoid race conditions. + EnterCriticalSection(&cv->waiters_count_lock); + cv->waiters_count++; + LeaveCriticalSection(&cv->waiters_count_lock); + + // It's ok to release the here since Win32 + // manual-reset events maintain state when used with + // . This avoids the "lost wakeup" bug... + LeaveCriticalSection(external_mutex); + + // Wait for either event to become signaled due to + // being called or being called. + int result = WaitForMultipleObjects(2, cv->events, FALSE, INFINITE); + + EnterCriticalSection(&cv->waiters_count_lock); + cv->waiters_count--; + int last_waiter = + result == WAIT_OBJECT_0 + BROADCAST + && cv->waiters_count == 0; + LeaveCriticalSection(&cv->waiters_count_lock); + + // Some thread called . + if (last_waiter) + // We're the last waiter to be notified or to stop waiting, so + // reset the manual event. + ResetEvent(cv->events[BROADCAST]); + + // Reacquire the . + EnterCriticalSection(external_mutex); + + return result == WAIT_TIMEOUT ? ETIMEDOUT : 0; +} + +typedef struct {} pthread_mutexattr_t; //< Dummy + +int pthread_mutex_init(pthread_mutex_t* mutex, const pthread_mutexattr_t* attr) +{ + InitializeCriticalSection(mutex); + return 0; +} + +int pthread_mutex_destroy(pthread_mutex_t* mutex) +{ + DeleteCriticalSection(mutex); + return 0; +} + +int pthread_mutex_lock(pthread_mutex_t* mutex) +{ + EnterCriticalSection(mutex); + return 0; +} + +int pthread_mutex_unlock(pthread_mutex_t* mutex) +{ + LeaveCriticalSection(mutex); + return 0; +} + +typedef struct {} pthread_attr_t; + +typedef struct +{ + void *(*start_routine) (void *); + void* arg; +} pthread_internal_thread; + +unsigned int __stdcall ThreadProc(void* userdata) +{ + pthread_internal_thread* ud = (pthread_internal_thread*) userdata; + ud->start_routine(ud->arg); + + free(ud); + + return 0; +} + +int pthread_create(pthread_t* thread, const pthread_attr_t* attr, void *(*start_routine) (void *), void *arg) +{ + pthread_internal_thread* ud = (pthread_internal_thread*) malloc(sizeof(pthread_internal_thread)); + ud->start_routine = start_routine; + ud->arg = arg; + + *thread = (HANDLE) (_beginthreadex(NULL, 0, &ThreadProc, ud, 0, NULL)); + if (!*thread) + return 1; + + return 0; +} + +int pthread_join(pthread_t thread, void **value_ptr) +{ + WaitForSingleObject(thread, INFINITE); + CloseHandle(thread); + + return 0; +} + +#endif + +#include "chipmunk/chipmunk_private.h" +#include "chipmunk/cpHastySpace.h" + + +//MARK: ARM NEON Solver + +#if __ARM_NEON__ +#include + +// Tested and known to work fine with Clang 3.0 and GCC 4.2 +// Doesn't work with Clang 1.6, and I have no idea why. +#if defined(__clang_major__) && __clang_major__ < 3 + #error Compiler not supported. +#endif + +#if CP_USE_DOUBLES + #if !__arm64 + #error Cannot use CP_USE_DOUBLES on 32 bit ARM. + #endif + + typedef float64_t cpFloat_t; + typedef float64x2_t cpFloatx2_t; + #define vld vld1q_f64 + #define vdup_n vdupq_n_f64 + #define vst vst1q_f64 + #define vst_lane vst1q_lane_f64 + #define vadd vaddq_f64 + #define vsub vsubq_f64 + #define vpadd vpaddq_f64 + #define vmul vmulq_f64 + #define vmul_n vmulq_n_f64 + #define vneg vnegq_f64 + #define vget_lane vgetq_lane_f64 + #define vset_lane vsetq_lane_f64 + #define vmin vminq_f64 + #define vmax vmaxq_f64 + #define vrev(__a) __builtin_shufflevector(__a, __a, 1, 0) +#else + typedef float32_t cpFloat_t; + typedef float32x2_t cpFloatx2_t; + #define vld vld1_f32 + #define vdup_n vdup_n_f32 + #define vst vst1_f32 + #define vst_lane vst1_lane_f32 + #define vadd vadd_f32 + #define vsub vsub_f32 + #define vpadd vpadd_f32 + #define vmul vmul_f32 + #define vmul_n vmul_n_f32 + #define vneg vneg_f32 + #define vget_lane vget_lane_f32 + #define vset_lane vset_lane_f32 + #define vmin vmin_f32 + #define vmax vmax_f32 + #define vrev vrev64_f32 +#endif + +// TODO could probably do better here, maybe using vcreate? +// especially for the constants +// Maybe use the {} notation for GCC/Clang? +static inline cpFloatx2_t +vmake(cpFloat_t x, cpFloat_t y) +{ +// cpFloatx2_t v = {}; +// v = vset_lane(x, v, 0); +// v = vset_lane(y, v, 1); +// +// return v; + + // This might not be super compatible, but all the NEON headers use it... + return (cpFloatx2_t){x, y}; +} + +static void +cpArbiterApplyImpulse_NEON(cpArbiter *arb) +{ + cpBody *a = arb->body_a; + cpBody *b = arb->body_b; + cpFloatx2_t surface_vr = vld((cpFloat_t *)&arb->surface_vr); + cpFloatx2_t n = vld((cpFloat_t *)&arb->n); + cpFloat_t friction = arb->u; + + int numContacts = arb->count; + struct cpContact *contacts = arb->contacts; + for(int i=0; ir1); + cpFloatx2_t r2 = vld((cpFloat_t *)&con->r2); + + cpFloatx2_t perp = vmake(-1.0, 1.0); + cpFloatx2_t r1p = vmul(vrev(r1), perp); + cpFloatx2_t r2p = vmul(vrev(r2), perp); + + cpFloatx2_t vBias_a = vld((cpFloat_t *)&a->v_bias); + cpFloatx2_t vBias_b = vld((cpFloat_t *)&b->v_bias); + cpFloatx2_t wBias = vmake(a->w_bias, b->w_bias); + + cpFloatx2_t vb1 = vadd(vBias_a, vmul_n(r1p, vget_lane(wBias, 0))); + cpFloatx2_t vb2 = vadd(vBias_b, vmul_n(r2p, vget_lane(wBias, 1))); + cpFloatx2_t vbr = vsub(vb2, vb1); + + cpFloatx2_t v_a = vld((cpFloat_t *)&a->v); + cpFloatx2_t v_b = vld((cpFloat_t *)&b->v); + cpFloatx2_t w = vmake(a->w, b->w); + cpFloatx2_t v1 = vadd(v_a, vmul_n(r1p, vget_lane(w, 0))); + cpFloatx2_t v2 = vadd(v_b, vmul_n(r2p, vget_lane(w, 1))); + cpFloatx2_t vr = vsub(v2, v1); + + cpFloatx2_t vbn_vrn = vpadd(vmul(vbr, n), vmul(vr, n)); + + cpFloatx2_t v_offset = vmake(con->bias, -con->bounce); + cpFloatx2_t jOld = vmake(con->jBias, con->jnAcc); + cpFloatx2_t jbn_jn = vmul_n(vsub(v_offset, vbn_vrn), con->nMass); + jbn_jn = vmax(vadd(jOld, jbn_jn), vdup_n(0.0)); + cpFloatx2_t jApply = vsub(jbn_jn, jOld); + + cpFloatx2_t t = vmul(vrev(n), perp); + cpFloatx2_t vrt_tmp = vmul(vadd(vr, surface_vr), t); + cpFloatx2_t vrt = vpadd(vrt_tmp, vrt_tmp); + + cpFloatx2_t jtOld = {}; jtOld = vset_lane(con->jtAcc, jtOld, 0); + cpFloatx2_t jtMax = vrev(vmul_n(jbn_jn, friction)); + cpFloatx2_t jt = vmul_n(vrt, -con->tMass); + jt = vmax(vneg(jtMax), vmin(vadd(jtOld, jt), jtMax)); + cpFloatx2_t jtApply = vsub(jt, jtOld); + + cpFloatx2_t i_inv = vmake(-a->i_inv, b->i_inv); + cpFloatx2_t nperp = vmake(1.0, -1.0); + + cpFloatx2_t jBias = vmul_n(n, vget_lane(jApply, 0)); + cpFloatx2_t jBiasCross = vmul(vrev(jBias), nperp); + cpFloatx2_t biasCrosses = vpadd(vmul(r1, jBiasCross), vmul(r2, jBiasCross)); + wBias = vadd(wBias, vmul(i_inv, biasCrosses)); + + vBias_a = vsub(vBias_a, vmul_n(jBias, a->m_inv)); + vBias_b = vadd(vBias_b, vmul_n(jBias, b->m_inv)); + + cpFloatx2_t j = vadd(vmul_n(n, vget_lane(jApply, 1)), vmul_n(t, vget_lane(jtApply, 0))); + cpFloatx2_t jCross = vmul(vrev(j), nperp); + cpFloatx2_t crosses = vpadd(vmul(r1, jCross), vmul(r2, jCross)); + w = vadd(w, vmul(i_inv, crosses)); + + v_a = vsub(v_a, vmul_n(j, a->m_inv)); + v_b = vadd(v_b, vmul_n(j, b->m_inv)); + + // TODO would moving these earlier help pipeline them better? + vst((cpFloat_t *)&a->v_bias, vBias_a); + vst((cpFloat_t *)&b->v_bias, vBias_b); + vst_lane((cpFloat_t *)&a->w_bias, wBias, 0); + vst_lane((cpFloat_t *)&b->w_bias, wBias, 1); + + vst((cpFloat_t *)&a->v, v_a); + vst((cpFloat_t *)&b->v, v_b); + vst_lane((cpFloat_t *)&a->w, w, 0); + vst_lane((cpFloat_t *)&b->w, w, 1); + + vst_lane((cpFloat_t *)&con->jBias, jbn_jn, 0); + vst_lane((cpFloat_t *)&con->jnAcc, jbn_jn, 1); + vst_lane((cpFloat_t *)&con->jtAcc, jt, 0); + } +} + +#endif + +//MARK: PThreads + +// Right now using more than 2 threads probably wont help your performance any. +// If you are using a ridiculous number of iterations it could help though. +#define MAX_THREADS 2 + +struct ThreadContext { + pthread_t thread; + cpHastySpace *space; + unsigned long thread_num; +}; + +typedef void (*cpHastySpaceWorkFunction)(cpSpace *space, unsigned long worker, unsigned long worker_count); + +struct cpHastySpace { + cpSpace space; + + // Number of worker threads (including the main thread) + unsigned long num_threads; + + // Number of worker threads currently executing. (also including the main thread) + unsigned long num_working; + + // Number of constraints (plus contacts) that must exist per step to start the worker threads. + unsigned long constraint_count_threshold; + + pthread_mutex_t mutex; + pthread_cond_t cond_work, cond_resume; + + // Work function to invoke. + cpHastySpaceWorkFunction work; + + struct ThreadContext workers[MAX_THREADS - 1]; +}; + +static void * +WorkerThreadLoop(struct ThreadContext *context) +{ + cpHastySpace *hasty = context->space; + + unsigned long thread = context->thread_num; + unsigned long num_threads = hasty->num_threads; + + for(;;){ + pthread_mutex_lock(&hasty->mutex); { + if(--hasty->num_working == 0){ + pthread_cond_signal(&hasty->cond_resume); + } + + pthread_cond_wait(&hasty->cond_work, &hasty->mutex); + } pthread_mutex_unlock(&hasty->mutex); + + cpHastySpaceWorkFunction func = hasty->work; + if(func){ + hasty->work(&hasty->space, thread, num_threads); + } else { + break; + } + } + + return NULL; +} + +static void +RunWorkers(cpHastySpace *hasty, cpHastySpaceWorkFunction func) +{ + hasty->num_working = hasty->num_threads - 1; + hasty->work = func; + + if(hasty->num_working > 0){ + pthread_mutex_lock(&hasty->mutex); { + pthread_cond_broadcast(&hasty->cond_work); + } pthread_mutex_unlock(&hasty->mutex); + + func((cpSpace *)hasty, 0, hasty->num_threads); + + pthread_mutex_lock(&hasty->mutex); { + if(hasty->num_working > 0){ + pthread_cond_wait(&hasty->cond_resume, &hasty->mutex); + } + } pthread_mutex_unlock(&hasty->mutex); + } else { + func((cpSpace *)hasty, 0, hasty->num_threads); + } + + hasty->work = NULL; +} + +static void +Solver(cpSpace *space, unsigned long worker, unsigned long worker_count) +{ + cpArray *constraints = space->constraints; + cpArray *arbiters = space->arbiters; + + cpFloat dt = space->curr_dt; + unsigned long iterations = (space->iterations + worker_count - 1)/worker_count; + + for(unsigned long i=0; inum; j++){ + cpArbiter *arb = (cpArbiter *)arbiters->arr[j]; + #ifdef __ARM_NEON__ + cpArbiterApplyImpulse_NEON(arb); + #else + cpArbiterApplyImpulse(arb); + #endif + } + + for(int j=0; jnum; j++){ + cpConstraint *constraint = (cpConstraint *)constraints->arr[j]; + constraint->klass->applyImpulse(constraint, dt); + } + } +} + +//MARK: Thread Management Functions + +static void +HaltThreads(cpHastySpace *hasty) +{ + pthread_mutex_t *mutex = &hasty->mutex; + pthread_mutex_lock(mutex); { + hasty->work = NULL; // NULL work function means break and exit + pthread_cond_broadcast(&hasty->cond_work); + } pthread_mutex_unlock(mutex); + + for(unsigned long i=0; i<(hasty->num_threads-1); i++){ + pthread_join(hasty->workers[i].thread, NULL); + } +} + +void +cpHastySpaceSetThreads(cpSpace *space, unsigned long threads) +{ +#if TARGET_IPHONE_SIMULATOR == 1 + // Individual values appear to be written non-atomically when compiled as debug for the simulator. + // No idea why, so threads are disabled. + threads = 1; +#endif + + cpHastySpace *hasty = (cpHastySpace *)space; + HaltThreads(hasty); + +#ifdef __APPLE__ + if(threads == 0){ + size_t size = sizeof(threads); + sysctlbyname("hw.ncpu", &threads, &size, NULL, 0); + } +#else + if(threads == 0) threads = 1; +#endif + + hasty->num_threads = (threads < MAX_THREADS ? threads : MAX_THREADS); + hasty->num_working = hasty->num_threads - 1; + + // Create the worker threads and wait for them to signal ready. + if(hasty->num_working > 0){ + pthread_mutex_lock(&hasty->mutex); + for(unsigned long i=0; i<(hasty->num_threads-1); i++){ + hasty->workers[i].space = hasty; + hasty->workers[i].thread_num = i + 1; + + pthread_create(&hasty->workers[i].thread, NULL, (void*(*)(void*))WorkerThreadLoop, &hasty->workers[i]); + } + + pthread_cond_wait(&hasty->cond_resume, &hasty->mutex); + pthread_mutex_unlock(&hasty->mutex); + } +} + +unsigned long +cpHastySpaceGetThreads(cpSpace *space) +{ + return ((cpHastySpace *)space)->num_threads; +} + +//MARK: Overriden cpSpace Functions. + +cpSpace * +cpHastySpaceNew(void) +{ + cpHastySpace *hasty = (cpHastySpace *)cpcalloc(1, sizeof(cpHastySpace)); + cpSpaceInit((cpSpace *)hasty); + + pthread_mutex_init(&hasty->mutex, NULL); + pthread_cond_init(&hasty->cond_work, NULL); + pthread_cond_init(&hasty->cond_resume, NULL); + + // TODO magic number, should test this more thoroughly. + hasty->constraint_count_threshold = 50; + + // Default to 1 thread for determinism. + hasty->num_threads = 1; + cpHastySpaceSetThreads((cpSpace *)hasty, 1); + + return (cpSpace *)hasty; +} + +void +cpHastySpaceFree(cpSpace *space) +{ + cpHastySpace *hasty = (cpHastySpace *)space; + + HaltThreads(hasty); + + pthread_mutex_destroy(&hasty->mutex); + pthread_cond_destroy(&hasty->cond_work); + pthread_cond_destroy(&hasty->cond_resume); + + cpSpaceFree(space); +} + +void +cpHastySpaceStep(cpSpace *space, cpFloat dt) +{ + // don't step if the timestep is 0! + if(dt == 0.0f) return; + + space->stamp++; + + cpFloat prev_dt = space->curr_dt; + space->curr_dt = dt; + + cpArray *bodies = space->dynamicBodies; + cpArray *constraints = space->constraints; + cpArray *arbiters = space->arbiters; + + // Reset and empty the arbiter list. + for(int i=0; inum; i++){ + cpArbiter *arb = (cpArbiter *)arbiters->arr[i]; + arb->state = CP_ARBITER_STATE_NORMAL; + + // If both bodies are awake, unthread the arbiter from the contact graph. + if(!cpBodyIsSleeping(arb->body_a) && !cpBodyIsSleeping(arb->body_b)){ + cpArbiterUnthread(arb); + } + } + arbiters->num = 0; + + cpSpaceLock(space); { + // Integrate positions + for(int i=0; inum; i++){ + cpBody *body = (cpBody *)bodies->arr[i]; + body->position_func(body, dt); + } + + // Find colliding pairs. + cpSpacePushFreshContactBuffer(space); + cpSpatialIndexEach(space->dynamicShapes, (cpSpatialIndexIteratorFunc)cpShapeUpdateFunc, NULL); + cpSpatialIndexReindexQuery(space->dynamicShapes, (cpSpatialIndexQueryFunc)cpSpaceCollideShapes, space); + } cpSpaceUnlock(space, cpFalse); + + // Rebuild the contact graph (and detect sleeping components if sleeping is enabled) + cpSpaceProcessComponents(space, dt); + + cpSpaceLock(space); { + // Clear out old cached arbiters and call separate callbacks + cpHashSetFilter(space->cachedArbiters, (cpHashSetFilterFunc)cpSpaceArbiterSetFilter, space); + + // Prestep the arbiters and constraints. + cpFloat slop = space->collisionSlop; + cpFloat biasCoef = 1.0f - cpfpow(space->collisionBias, dt); + for(int i=0; inum; i++){ + cpArbiterPreStep((cpArbiter *)arbiters->arr[i], dt, slop, biasCoef); + } + + for(int i=0; inum; i++){ + cpConstraint *constraint = (cpConstraint *)constraints->arr[i]; + + cpConstraintPreSolveFunc preSolve = constraint->preSolve; + if(preSolve) preSolve(constraint, space); + + constraint->klass->preStep(constraint, dt); + } + + // Integrate velocities. + cpFloat damping = cpfpow(space->damping, dt); + cpVect gravity = space->gravity; + for(int i=0; inum; i++){ + cpBody *body = (cpBody *)bodies->arr[i]; + body->velocity_func(body, gravity, damping, dt); + } + + // Apply cached impulses + cpFloat dt_coef = (prev_dt == 0.0f ? 0.0f : dt/prev_dt); + for(int i=0; inum; i++){ + cpArbiterApplyCachedImpulse((cpArbiter *)arbiters->arr[i], dt_coef); + } + + for(int i=0; inum; i++){ + cpConstraint *constraint = (cpConstraint *)constraints->arr[i]; + constraint->klass->applyCachedImpulse(constraint, dt_coef); + } + + // Run the impulse solver. + cpHastySpace *hasty = (cpHastySpace *)space; + if((unsigned long)(arbiters->num + constraints->num) > hasty->constraint_count_threshold){ + RunWorkers(hasty, Solver); + } else { + Solver(space, 0, 1); + } + + // Run the constraint post-solve callbacks + for(int i=0; inum; i++){ + cpConstraint *constraint = (cpConstraint *)constraints->arr[i]; + + cpConstraintPostSolveFunc postSolve = constraint->postSolve; + if(postSolve) postSolve(constraint, space); + } + + // run the post-solve callbacks + for(int i=0; inum; i++){ + cpArbiter *arb = (cpArbiter *) arbiters->arr[i]; + + cpCollisionHandler *handler = arb->handler; + handler->postSolveFunc(arb, space, handler->userData); + } + } cpSpaceUnlock(space, cpTrue); +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpMarch.c b/source/engine/thirdparty/Chipmunk2D/src/cpMarch.c new file mode 100644 index 0000000..1ba0dab --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpMarch.c @@ -0,0 +1,157 @@ +// Copyright 2013 Howling Moon Software. All rights reserved. +// See http://chipmunk2d.net/legal.php for more information. + +#include +#include +#include + +#include "chipmunk/chipmunk.h" +#include "chipmunk/cpMarch.h" + + +typedef void (*cpMarchCellFunc)( + cpFloat t, cpFloat a, cpFloat b, cpFloat c, cpFloat d, + cpFloat x0, cpFloat x1, cpFloat y0, cpFloat y1, + cpMarchSegmentFunc segment, void *segment_data +); + +// The looping and sample caching code is shared between cpMarchHard() and cpMarchSoft(). +static void +cpMarchCells( + cpBB bb, unsigned long x_samples, unsigned long y_samples, cpFloat t, + cpMarchSegmentFunc segment, void *segment_data, + cpMarchSampleFunc sample, void *sample_data, + cpMarchCellFunc cell +){ + cpFloat x_denom = 1.0/(cpFloat)(x_samples - 1); + cpFloat y_denom = 1.0/(cpFloat)(y_samples - 1); + + // TODO range assertions and short circuit for 0 sized windows. + + // Keep a copy of the previous row to avoid double lookups. + cpFloat *buffer = (cpFloat *)cpcalloc(x_samples, sizeof(cpFloat)); + for(unsigned long i=0; it)<<0 | (b>t)<<1 | (c>t)<<2 | (d>t)<<3){ + case 0x1: seg(cpv(x0, midlerp(y0,y1,a,c,t)), cpv(midlerp(x0,x1,a,b,t), y0), segment, segment_data); break; + case 0x2: seg(cpv(midlerp(x0,x1,a,b,t), y0), cpv(x1, midlerp(y0,y1,b,d,t)), segment, segment_data); break; + case 0x3: seg(cpv(x0, midlerp(y0,y1,a,c,t)), cpv(x1, midlerp(y0,y1,b,d,t)), segment, segment_data); break; + case 0x4: seg(cpv(midlerp(x0,x1,c,d,t), y1), cpv(x0, midlerp(y0,y1,a,c,t)), segment, segment_data); break; + case 0x5: seg(cpv(midlerp(x0,x1,c,d,t), y1), cpv(midlerp(x0,x1,a,b,t), y0), segment, segment_data); break; + case 0x6: seg(cpv(midlerp(x0,x1,a,b,t), y0), cpv(x1, midlerp(y0,y1,b,d,t)), segment, segment_data); + seg(cpv(midlerp(x0,x1,c,d,t), y1), cpv(x0, midlerp(y0,y1,a,c,t)), segment, segment_data); break; + case 0x7: seg(cpv(midlerp(x0,x1,c,d,t), y1), cpv(x1, midlerp(y0,y1,b,d,t)), segment, segment_data); break; + case 0x8: seg(cpv(x1, midlerp(y0,y1,b,d,t)), cpv(midlerp(x0,x1,c,d,t), y1), segment, segment_data); break; + case 0x9: seg(cpv(x0, midlerp(y0,y1,a,c,t)), cpv(midlerp(x0,x1,a,b,t), y0), segment, segment_data); + seg(cpv(x1, midlerp(y0,y1,b,d,t)), cpv(midlerp(x0,x1,c,d,t), y1), segment, segment_data); break; + case 0xA: seg(cpv(midlerp(x0,x1,a,b,t), y0), cpv(midlerp(x0,x1,c,d,t), y1), segment, segment_data); break; + case 0xB: seg(cpv(x0, midlerp(y0,y1,a,c,t)), cpv(midlerp(x0,x1,c,d,t), y1), segment, segment_data); break; + case 0xC: seg(cpv(x1, midlerp(y0,y1,b,d,t)), cpv(x0, midlerp(y0,y1,a,c,t)), segment, segment_data); break; + case 0xD: seg(cpv(x1, midlerp(y0,y1,b,d,t)), cpv(midlerp(x0,x1,a,b,t), y0), segment, segment_data); break; + case 0xE: seg(cpv(midlerp(x0,x1,a,b,t), y0), cpv(x0, midlerp(y0,y1,a,c,t)), segment, segment_data); break; + default: break; // 0x0 and 0xF + } +} + +void +cpMarchSoft( + cpBB bb, unsigned long x_samples, unsigned long y_samples, cpFloat t, + cpMarchSegmentFunc segment, void *segment_data, + cpMarchSampleFunc sample, void *sample_data +){ + cpMarchCells(bb, x_samples, y_samples, t, segment, segment_data, sample, sample_data, cpMarchCellSoft); +} + + +// TODO should flip this around eventually. +static inline void +segs(cpVect a, cpVect b, cpVect c, cpMarchSegmentFunc f, void *data) +{ + seg(b, c, f, data); + seg(a, b, f, data); +} + +static void +cpMarchCellHard( + cpFloat t, cpFloat a, cpFloat b, cpFloat c, cpFloat d, + cpFloat x0, cpFloat x1, cpFloat y0, cpFloat y1, + cpMarchSegmentFunc segment, void *segment_data +){ + // midpoints + cpFloat xm = cpflerp(x0, x1, 0.5f); + cpFloat ym = cpflerp(y0, y1, 0.5f); + + switch((a>t)<<0 | (b>t)<<1 | (c>t)<<2 | (d>t)<<3){ + case 0x1: segs(cpv(x0, ym), cpv(xm, ym), cpv(xm, y0), segment, segment_data); break; + case 0x2: segs(cpv(xm, y0), cpv(xm, ym), cpv(x1, ym), segment, segment_data); break; + case 0x3: seg(cpv(x0, ym), cpv(x1, ym), segment, segment_data); break; + case 0x4: segs(cpv(xm, y1), cpv(xm, ym), cpv(x0, ym), segment, segment_data); break; + case 0x5: seg(cpv(xm, y1), cpv(xm, y0), segment, segment_data); break; + case 0x6: segs(cpv(xm, y0), cpv(xm, ym), cpv(x0, ym), segment, segment_data); + segs(cpv(xm, y1), cpv(xm, ym), cpv(x1, ym), segment, segment_data); break; + case 0x7: segs(cpv(xm, y1), cpv(xm, ym), cpv(x1, ym), segment, segment_data); break; + case 0x8: segs(cpv(x1, ym), cpv(xm, ym), cpv(xm, y1), segment, segment_data); break; + case 0x9: segs(cpv(x1, ym), cpv(xm, ym), cpv(xm, y0), segment, segment_data); + segs(cpv(x0, ym), cpv(xm, ym), cpv(xm, y1), segment, segment_data); break; + case 0xA: seg(cpv(xm, y0), cpv(xm, y1), segment, segment_data); break; + case 0xB: segs(cpv(x0, ym), cpv(xm, ym), cpv(xm, y1), segment, segment_data); break; + case 0xC: seg(cpv(x1, ym), cpv(x0, ym), segment, segment_data); break; + case 0xD: segs(cpv(x1, ym), cpv(xm, ym), cpv(xm, y0), segment, segment_data); break; + case 0xE: segs(cpv(xm, y0), cpv(xm, ym), cpv(x0, ym), segment, segment_data); break; + default: break; // 0x0 and 0xF + } +} + +void +cpMarchHard( + cpBB bb, unsigned long x_samples, unsigned long y_samples, cpFloat t, + cpMarchSegmentFunc segment, void *segment_data, + cpMarchSampleFunc sample, void *sample_data +){ + cpMarchCells(bb, x_samples, y_samples, t, segment, segment_data, sample, sample_data, cpMarchCellHard); +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpPinJoint.c b/source/engine/thirdparty/Chipmunk2D/src/cpPinJoint.c new file mode 100644 index 0000000..545e78b --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpPinJoint.c @@ -0,0 +1,172 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +static void +preStep(cpPinJoint *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + joint->r1 = cpTransformVect(a->transform, cpvsub(joint->anchorA, a->cog)); + joint->r2 = cpTransformVect(b->transform, cpvsub(joint->anchorB, b->cog)); + + cpVect delta = cpvsub(cpvadd(b->p, joint->r2), cpvadd(a->p, joint->r1)); + cpFloat dist = cpvlength(delta); + joint->n = cpvmult(delta, 1.0f/(dist ? dist : (cpFloat)INFINITY)); + + // calculate mass normal + joint->nMass = 1.0f/k_scalar(a, b, joint->r1, joint->r2, joint->n); + + // calculate bias velocity + cpFloat maxBias = joint->constraint.maxBias; + joint->bias = cpfclamp(-bias_coef(joint->constraint.errorBias, dt)*(dist - joint->dist)/dt, -maxBias, maxBias); +} + +static void +applyCachedImpulse(cpPinJoint *joint, cpFloat dt_coef) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + cpVect j = cpvmult(joint->n, joint->jnAcc*dt_coef); + apply_impulses(a, b, joint->r1, joint->r2, j); +} + +static void +applyImpulse(cpPinJoint *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + cpVect n = joint->n; + + // compute relative velocity + cpFloat vrn = normal_relative_velocity(a, b, joint->r1, joint->r2, n); + + cpFloat jnMax = joint->constraint.maxForce*dt; + + // compute normal impulse + cpFloat jn = (joint->bias - vrn)*joint->nMass; + cpFloat jnOld = joint->jnAcc; + joint->jnAcc = cpfclamp(jnOld + jn, -jnMax, jnMax); + jn = joint->jnAcc - jnOld; + + // apply impulse + apply_impulses(a, b, joint->r1, joint->r2, cpvmult(n, jn)); +} + +static cpFloat +getImpulse(cpPinJoint *joint) +{ + return cpfabs(joint->jnAcc); +} + +static const cpConstraintClass klass = { + (cpConstraintPreStepImpl)preStep, + (cpConstraintApplyCachedImpulseImpl)applyCachedImpulse, + (cpConstraintApplyImpulseImpl)applyImpulse, + (cpConstraintGetImpulseImpl)getImpulse, +}; + + +cpPinJoint * +cpPinJointAlloc(void) +{ + return (cpPinJoint *)cpcalloc(1, sizeof(cpPinJoint)); +} + +cpPinJoint * +cpPinJointInit(cpPinJoint *joint, cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB) +{ + cpConstraintInit((cpConstraint *)joint, &klass, a, b); + + joint->anchorA = anchorA; + joint->anchorB = anchorB; + + // STATIC_BODY_CHECK + cpVect p1 = (a ? cpTransformPoint(a->transform, anchorA) : anchorA); + cpVect p2 = (b ? cpTransformPoint(b->transform, anchorB) : anchorB); + joint->dist = cpvlength(cpvsub(p2, p1)); + + cpAssertWarn(joint->dist > 0.0, "You created a 0 length pin joint. A pivot joint will be much more stable."); + + joint->jnAcc = 0.0f; + + return joint; +} + +cpConstraint * +cpPinJointNew(cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB) +{ + return (cpConstraint *)cpPinJointInit(cpPinJointAlloc(), a, b, anchorA, anchorB); +} + +cpBool +cpConstraintIsPinJoint(const cpConstraint *constraint) +{ + return (constraint->klass == &klass); +} + +cpVect +cpPinJointGetAnchorA(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsPinJoint(constraint), "Constraint is not a pin joint."); + return ((cpPinJoint *)constraint)->anchorA; +} + +void +cpPinJointSetAnchorA(cpConstraint *constraint, cpVect anchorA) +{ + cpAssertHard(cpConstraintIsPinJoint(constraint), "Constraint is not a pin joint."); + cpConstraintActivateBodies(constraint); + ((cpPinJoint *)constraint)->anchorA = anchorA; +} + +cpVect +cpPinJointGetAnchorB(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsPinJoint(constraint), "Constraint is not a pin joint."); + return ((cpPinJoint *)constraint)->anchorB; +} + +void +cpPinJointSetAnchorB(cpConstraint *constraint, cpVect anchorB) +{ + cpAssertHard(cpConstraintIsPinJoint(constraint), "Constraint is not a pin joint."); + cpConstraintActivateBodies(constraint); + ((cpPinJoint *)constraint)->anchorB = anchorB; +} + +cpFloat +cpPinJointGetDist(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsPinJoint(constraint), "Constraint is not a pin joint."); + return ((cpPinJoint *)constraint)->dist; +} + +void +cpPinJointSetDist(cpConstraint *constraint, cpFloat dist) +{ + cpAssertHard(cpConstraintIsPinJoint(constraint), "Constraint is not a pin joint."); + cpConstraintActivateBodies(constraint); + ((cpPinJoint *)constraint)->dist = dist; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpPivotJoint.c b/source/engine/thirdparty/Chipmunk2D/src/cpPivotJoint.c new file mode 100644 index 0000000..e45ba07 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpPivotJoint.c @@ -0,0 +1,152 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +static void +preStep(cpPivotJoint *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + joint->r1 = cpTransformVect(a->transform, cpvsub(joint->anchorA, a->cog)); + joint->r2 = cpTransformVect(b->transform, cpvsub(joint->anchorB, b->cog)); + + // Calculate mass tensor + joint-> k = k_tensor(a, b, joint->r1, joint->r2); + + // calculate bias velocity + cpVect delta = cpvsub(cpvadd(b->p, joint->r2), cpvadd(a->p, joint->r1)); + joint->bias = cpvclamp(cpvmult(delta, -bias_coef(joint->constraint.errorBias, dt)/dt), joint->constraint.maxBias); +} + +static void +applyCachedImpulse(cpPivotJoint *joint, cpFloat dt_coef) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + apply_impulses(a, b, joint->r1, joint->r2, cpvmult(joint->jAcc, dt_coef)); +} + +static void +applyImpulse(cpPivotJoint *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + cpVect r1 = joint->r1; + cpVect r2 = joint->r2; + + // compute relative velocity + cpVect vr = relative_velocity(a, b, r1, r2); + + // compute normal impulse + cpVect j = cpMat2x2Transform(joint->k, cpvsub(joint->bias, vr)); + cpVect jOld = joint->jAcc; + joint->jAcc = cpvclamp(cpvadd(joint->jAcc, j), joint->constraint.maxForce*dt); + j = cpvsub(joint->jAcc, jOld); + + // apply impulse + apply_impulses(a, b, joint->r1, joint->r2, j); +} + +static cpFloat +getImpulse(cpConstraint *joint) +{ + return cpvlength(((cpPivotJoint *)joint)->jAcc); +} + +static const cpConstraintClass klass = { + (cpConstraintPreStepImpl)preStep, + (cpConstraintApplyCachedImpulseImpl)applyCachedImpulse, + (cpConstraintApplyImpulseImpl)applyImpulse, + (cpConstraintGetImpulseImpl)getImpulse, +}; + +cpPivotJoint * +cpPivotJointAlloc(void) +{ + return (cpPivotJoint *)cpcalloc(1, sizeof(cpPivotJoint)); +} + +cpPivotJoint * +cpPivotJointInit(cpPivotJoint *joint, cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB) +{ + cpConstraintInit((cpConstraint *)joint, &klass, a, b); + + joint->anchorA = anchorA; + joint->anchorB = anchorB; + + joint->jAcc = cpvzero; + + return joint; +} + +cpConstraint * +cpPivotJointNew2(cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB) +{ + return (cpConstraint *)cpPivotJointInit(cpPivotJointAlloc(), a, b, anchorA, anchorB); +} + +cpConstraint * +cpPivotJointNew(cpBody *a, cpBody *b, cpVect pivot) +{ + cpVect anchorA = (a ? cpBodyWorldToLocal(a, pivot) : pivot); + cpVect anchorB = (b ? cpBodyWorldToLocal(b, pivot) : pivot); + return cpPivotJointNew2(a, b, anchorA, anchorB); +} + +cpBool +cpConstraintIsPivotJoint(const cpConstraint *constraint) +{ + return (constraint->klass == &klass); +} + +cpVect +cpPivotJointGetAnchorA(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsPivotJoint(constraint), "Constraint is not a pivot joint."); + return ((cpPivotJoint *)constraint)->anchorA; +} + +void +cpPivotJointSetAnchorA(cpConstraint *constraint, cpVect anchorA) +{ + cpAssertHard(cpConstraintIsPivotJoint(constraint), "Constraint is not a pivot joint."); + cpConstraintActivateBodies(constraint); + ((cpPivotJoint *)constraint)->anchorA = anchorA; +} + +cpVect +cpPivotJointGetAnchorB(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsPivotJoint(constraint), "Constraint is not a pivot joint."); + return ((cpPivotJoint *)constraint)->anchorB; +} + +void +cpPivotJointSetAnchorB(cpConstraint *constraint, cpVect anchorB) +{ + cpAssertHard(cpConstraintIsPivotJoint(constraint), "Constraint is not a pivot joint."); + cpConstraintActivateBodies(constraint); + ((cpPivotJoint *)constraint)->anchorB = anchorB; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpPolyShape.c b/source/engine/thirdparty/Chipmunk2D/src/cpPolyShape.c new file mode 100644 index 0000000..8fd4519 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpPolyShape.c @@ -0,0 +1,324 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" +#include "chipmunk/chipmunk_unsafe.h" + +cpPolyShape * +cpPolyShapeAlloc(void) +{ + return (cpPolyShape *)cpcalloc(1, sizeof(cpPolyShape)); +} + +static void +cpPolyShapeDestroy(cpPolyShape *poly) +{ + if(poly->count > CP_POLY_SHAPE_INLINE_ALLOC){ + cpfree(poly->planes); + } +} + +static cpBB +cpPolyShapeCacheData(cpPolyShape *poly, cpTransform transform) +{ + int count = poly->count; + struct cpSplittingPlane *dst = poly->planes; + struct cpSplittingPlane *src = dst + count; + + cpFloat l = (cpFloat)INFINITY, r = -(cpFloat)INFINITY; + cpFloat b = (cpFloat)INFINITY, t = -(cpFloat)INFINITY; + + for(int i=0; ir; + return (poly->shape.bb = cpBBNew(l - radius, b - radius, r + radius, t + radius)); +} + +static void +cpPolyShapePointQuery(cpPolyShape *poly, cpVect p, cpPointQueryInfo *info){ + int count = poly->count; + struct cpSplittingPlane *planes = poly->planes; + cpFloat r = poly->r; + + cpVect v0 = planes[count - 1].v0; + cpFloat minDist = INFINITY; + cpVect closestPoint = cpvzero; + cpVect closestNormal = cpvzero; + cpBool outside = cpFalse; + + for(int i=0; i 0.0f); + + cpVect closest = cpClosetPointOnSegment(p, v0, v1); + + cpFloat dist = cpvdist(p, closest); + if(dist < minDist){ + minDist = dist; + closestPoint = closest; + closestNormal = planes[i].n; + } + + v0 = v1; + } + + cpFloat dist = (outside ? minDist : -minDist); + cpVect g = cpvmult(cpvsub(p, closestPoint), 1.0f/dist); + + info->shape = (cpShape *)poly; + info->point = cpvadd(closestPoint, cpvmult(g, r)); + info->distance = dist - r; + + // Use the normal of the closest segment if the distance is small. + info->gradient = (minDist > MAGIC_EPSILON ? g : closestNormal); +} + +static void +cpPolyShapeSegmentQuery(cpPolyShape *poly, cpVect a, cpVect b, cpFloat r2, cpSegmentQueryInfo *info) +{ + struct cpSplittingPlane *planes = poly->planes; + int count = poly->count; + cpFloat r = poly->r; + cpFloat rsum = r + r2; + + for(int i=0; ishape = (cpShape *)poly; + info->point = cpvsub(cpvlerp(a, b, t), cpvmult(n, r2)); + info->normal = n; + info->alpha = t; + } + } + + // Also check against the beveled vertexes. + if(rsum > 0.0f){ + for(int i=0; ishape, planes[i].v0, r, a, b, r2, &circle_info); + if(circle_info.alpha < info->alpha) (*info) = circle_info; + } + } +} + +static void +SetVerts(cpPolyShape *poly, int count, const cpVect *verts) +{ + poly->count = count; + if(count <= CP_POLY_SHAPE_INLINE_ALLOC){ + poly->planes = poly->_planes; + } else { + poly->planes = (struct cpSplittingPlane *)cpcalloc(2*count, sizeof(struct cpSplittingPlane)); + } + + for(int i=0; iplanes[i + count].v0 = b; + poly->planes[i + count].n = n; + } +} + +static struct cpShapeMassInfo +cpPolyShapeMassInfo(cpFloat mass, int count, const cpVect *verts, cpFloat radius) +{ + // TODO moment is approximate due to radius. + + cpVect centroid = cpCentroidForPoly(count, verts); + struct cpShapeMassInfo info = { + mass, cpMomentForPoly(1.0f, count, verts, cpvneg(centroid), radius), + centroid, + cpAreaForPoly(count, verts, radius), + }; + + return info; +} + +static const cpShapeClass polyClass = { + CP_POLY_SHAPE, + (cpShapeCacheDataImpl)cpPolyShapeCacheData, + (cpShapeDestroyImpl)cpPolyShapeDestroy, + (cpShapePointQueryImpl)cpPolyShapePointQuery, + (cpShapeSegmentQueryImpl)cpPolyShapeSegmentQuery, +}; + +cpPolyShape * +cpPolyShapeInit(cpPolyShape *poly, cpBody *body, int count, const cpVect *verts, cpTransform transform, cpFloat radius) +{ + cpVect *hullVerts = (cpVect *)alloca(count*sizeof(cpVect)); + + // Transform the verts before building the hull in case of a negative scale. + for(int i=0; ir = radius; + + return poly; +} + +cpShape * +cpPolyShapeNew(cpBody *body, int count, const cpVect *verts, cpTransform transform, cpFloat radius) +{ + return (cpShape *)cpPolyShapeInit(cpPolyShapeAlloc(), body, count, verts, transform, radius); +} + +cpShape * +cpPolyShapeNewRaw(cpBody *body, int count, const cpVect *verts, cpFloat radius) +{ + return (cpShape *)cpPolyShapeInitRaw(cpPolyShapeAlloc(), body, count, verts, radius); +} + +cpPolyShape * +cpBoxShapeInit(cpPolyShape *poly, cpBody *body, cpFloat width, cpFloat height, cpFloat radius) +{ + cpFloat hw = width/2.0f; + cpFloat hh = height/2.0f; + + return cpBoxShapeInit2(poly, body, cpBBNew(-hw, -hh, hw, hh), radius); +} + +cpPolyShape * +cpBoxShapeInit2(cpPolyShape *poly, cpBody *body, cpBB box, cpFloat radius) +{ + cpVect verts[] = { + cpv(box.r, box.b), + cpv(box.r, box.t), + cpv(box.l, box.t), + cpv(box.l, box.b), + }; + + return cpPolyShapeInitRaw(poly, body, 4, verts, radius); +} + +cpShape * +cpBoxShapeNew(cpBody *body, cpFloat width, cpFloat height, cpFloat radius) +{ + return (cpShape *)cpBoxShapeInit(cpPolyShapeAlloc(), body, width, height, radius); +} + +cpShape * +cpBoxShapeNew2(cpBody *body, cpBB box, cpFloat radius) +{ + return (cpShape *)cpBoxShapeInit2(cpPolyShapeAlloc(), body, box, radius); +} + +int +cpPolyShapeGetCount(const cpShape *shape) +{ + cpAssertHard(shape->klass == &polyClass, "Shape is not a poly shape."); + return ((cpPolyShape *)shape)->count; +} + +cpVect +cpPolyShapeGetVert(const cpShape *shape, int i) +{ + cpAssertHard(shape->klass == &polyClass, "Shape is not a poly shape."); + + int count = cpPolyShapeGetCount(shape); + cpAssertHard(0 <= i && i < count, "Index out of range."); + + return ((cpPolyShape *)shape)->planes[i + count].v0; +} + +cpFloat +cpPolyShapeGetRadius(const cpShape *shape) +{ + cpAssertHard(shape->klass == &polyClass, "Shape is not a poly shape."); + return ((cpPolyShape *)shape)->r; +} + +// Unsafe API (chipmunk_unsafe.h) + +void +cpPolyShapeSetVerts(cpShape *shape, int count, cpVect *verts, cpTransform transform) +{ + cpVect *hullVerts = (cpVect *)alloca(count*sizeof(cpVect)); + + // Transform the verts before building the hull in case of a negative scale. + for(int i=0; iklass == &polyClass, "Shape is not a poly shape."); + cpPolyShape *poly = (cpPolyShape *)shape; + cpPolyShapeDestroy(poly); + + SetVerts(poly, count, verts); + + cpFloat mass = shape->massInfo.m; + shape->massInfo = cpPolyShapeMassInfo(shape->massInfo.m, count, verts, poly->r); + if(mass > 0.0f) cpBodyAccumulateMassFromShapes(shape->body); +} + +void +cpPolyShapeSetRadius(cpShape *shape, cpFloat radius) +{ + cpAssertHard(shape->klass == &polyClass, "Shape is not a poly shape."); + cpPolyShape *poly = (cpPolyShape *)shape; + poly->r = radius; + + + // TODO radius is not handled by moment/area +// cpFloat mass = shape->massInfo.m; +// shape->massInfo = cpPolyShapeMassInfo(shape->massInfo.m, poly->count, poly->verts, poly->r); +// if(mass > 0.0f) cpBodyAccumulateMassFromShapes(shape->body); +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpPolyline.c b/source/engine/thirdparty/Chipmunk2D/src/cpPolyline.c new file mode 100644 index 0000000..5b37534 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpPolyline.c @@ -0,0 +1,652 @@ +// Copyright 2013 Howling Moon Software. All rights reserved. +// See http://chipmunk2d.net/legal.php for more information. + +#include +#include +#include +#include + +#include "chipmunk/chipmunk_private.h" +#include "chipmunk/cpPolyline.h" + + +static inline int Next(int i, int count){return (i+1)%count;} + +//MARK: Polylines + +#define DEFAULT_POLYLINE_CAPACITY 16 + +static int +cpPolylineSizeForCapacity(int capacity) +{ + return sizeof(cpPolyline) + capacity*sizeof(cpVect); +} + +static cpPolyline * +cpPolylineMake(int capacity) +{ + capacity = (capacity > DEFAULT_POLYLINE_CAPACITY ? capacity : DEFAULT_POLYLINE_CAPACITY); + + cpPolyline *line = (cpPolyline *)cpcalloc(1, cpPolylineSizeForCapacity(capacity)); + line->count = 0; + line->capacity = capacity; + + return line; +} + +static cpPolyline * +cpPolylineMake2(int capacity, cpVect a, cpVect b) +{ + cpPolyline *line = cpPolylineMake(capacity); + line->count = 2; + line->verts[0] = a; + line->verts[1] = b; + + return line; +} + +static cpPolyline * +cpPolylineShrink(cpPolyline *line) +{ + line->capacity = line->count; + return (cpPolyline*) cprealloc(line, cpPolylineSizeForCapacity(line->count)); +} + +void +cpPolylineFree(cpPolyline *line) +{ + cpfree(line); +} + +// Grow the allocated memory for a polyline. +static cpPolyline * +cpPolylineGrow(cpPolyline *line, int count) +{ + line->count += count; + + int capacity = line->capacity; + while(line->count > capacity) capacity *= 2; + + if(line->capacity < capacity){ + line->capacity = capacity; + line = (cpPolyline*) cprealloc(line, cpPolylineSizeForCapacity(capacity)); + } + + return line; +} + +// Push v onto the end of line. +static cpPolyline * +cpPolylinePush(cpPolyline *line, cpVect v) +{ + int count = line->count; + line = cpPolylineGrow(line, 1); + line->verts[count] = v; + + return line; +} + +// Push v onto the beginning of line. +static cpPolyline * +cpPolylineEnqueue(cpPolyline *line, cpVect v) +{ + // TODO could optimize this to grow in both directions. + // Probably doesn't matter though. + int count = line->count; + line = cpPolylineGrow(line, 1); + memmove(line->verts + 1, line->verts, count*sizeof(cpVect)); + line->verts[0] = v; + + return line; +} + +// Returns true if the polyline starts and ends with the same vertex. +cpBool +cpPolylineIsClosed(cpPolyline *line) +{ + return (line->count > 1 && cpveql(line->verts[0], line->verts[line->count-1])); +} + +// Check if a cpPolyline is longer than a certain length +// Takes a range which can wrap around if the polyline is looped. +static cpBool +cpPolylineIsShort(cpVect *points, int count, int start, int end, cpFloat min) +{ + cpFloat length = 0.0f; + for(int i=start; i!=end; i=Next(i, count)){ + length += cpvdist(points[i], points[Next(i, count)]); + if(length > min) return cpFalse; + } + + return cpTrue; +} + +//MARK: Polyline Simplification + +static inline cpFloat +Sharpness(cpVect a, cpVect b, cpVect c) +{ + // TODO could speed this up by caching the normals instead of calculating each twice. + return cpvdot(cpvnormalize(cpvsub(a, b)), cpvnormalize(cpvsub(c, b))); +} + +// Join similar adjacent line segments together. Works well for hard edged shapes. +// 'tol' is the minimum anglular difference in radians of a vertex. +cpPolyline * +cpPolylineSimplifyVertexes(cpPolyline *line, cpFloat tol) +{ + cpPolyline *reduced = cpPolylineMake2(0, line->verts[0], line->verts[1]); + + cpFloat minSharp = -cpfcos(tol); + + for(int i=2; icount; i++){ + cpVect vert = line->verts[i]; + cpFloat sharp = Sharpness(reduced->verts[reduced->count - 2], reduced->verts[reduced->count - 1], vert); + + if(sharp <= minSharp){ + reduced->verts[reduced->count - 1] = vert; + } else { + reduced = cpPolylinePush(reduced, vert); + } + } + + if( + cpPolylineIsClosed(line) && + Sharpness(reduced->verts[reduced->count - 2], reduced->verts[0], reduced->verts[1]) < minSharp + ){ + reduced->verts[0] = reduced->verts[reduced->count - 2]; + reduced->count--; + } + + // TODO shrink + return reduced; +} + +// Recursive function used by cpPolylineSimplifyCurves(). +static cpPolyline * +DouglasPeucker( + cpVect *verts, cpPolyline *reduced, + int length, int start, int end, + cpFloat min, cpFloat tol +){ + // Early exit if the points are adjacent + if((end - start + length)%length < 2) return reduced; + + cpVect a = verts[start]; + cpVect b = verts[end]; + + // Check if the length is below the threshold + if(cpvnear(a, b, min) && cpPolylineIsShort(verts, length, start, end, min)) return reduced; + + // Find the maximal vertex to split and recurse on + cpFloat max = 0.0; + int maxi = start; + + cpVect n = cpvnormalize(cpvperp(cpvsub(b, a))); + cpFloat d = cpvdot(n, a); + + for(int i=Next(start, length); i!=end; i=Next(i, length)){ + cpFloat dist = fabs(cpvdot(n, verts[i]) - d); + + if(dist > max){ + max = dist; + maxi = i; + } + } + + if(max > tol){ + reduced = DouglasPeucker(verts, reduced, length, start, maxi, min, tol); + reduced = cpPolylinePush(reduced, verts[maxi]); + reduced = DouglasPeucker(verts, reduced, length, maxi, end, min, tol); + } + + return reduced; +} + +// Recursively reduce the vertex count on a polyline. Works best for smooth shapes. +// 'tol' is the maximum error for the reduction. +// The reduced polyline will never be farther than this distance from the original polyline. +cpPolyline * +cpPolylineSimplifyCurves(cpPolyline *line, cpFloat tol) +{ + cpPolyline *reduced = cpPolylineMake(line->count); + + cpFloat min = tol/2.0f; + + if(cpPolylineIsClosed(line)){ + int start, end; + cpLoopIndexes(line->verts, line->count - 1, &start, &end); + + reduced = cpPolylinePush(reduced, line->verts[start]); + reduced = DouglasPeucker(line->verts, reduced, line->count - 1, start, end, min, tol); + reduced = cpPolylinePush(reduced, line->verts[end]); + reduced = DouglasPeucker(line->verts, reduced, line->count - 1, end, start, min, tol); + reduced = cpPolylinePush(reduced, line->verts[start]); + } else { + reduced = cpPolylinePush(reduced, line->verts[0]); + reduced = DouglasPeucker(line->verts, reduced, line->count, 0, line->count - 1, min, tol); + reduced = cpPolylinePush(reduced, line->verts[line->count - 1]); + } + + return cpPolylineShrink(reduced); +} + +//MARK: Polyline Sets + +cpPolylineSet * +cpPolylineSetAlloc(void) +{ + return (cpPolylineSet *)cpcalloc(1, sizeof(cpPolylineSet)); +} + +cpPolylineSet * +cpPolylineSetInit(cpPolylineSet *set) +{ + set->count = 0; + set->capacity = 8; + set->lines = (cpPolyline**) cpcalloc(set->capacity, sizeof(cpPolyline)); + + return set; +} + + +cpPolylineSet * +cpPolylineSetNew(void) +{ + return cpPolylineSetInit(cpPolylineSetAlloc()); +} + +void +cpPolylineSetDestroy(cpPolylineSet *set, cpBool freePolylines) +{ + if(freePolylines){ + for(int i=0; icount; i++){ + cpPolylineFree(set->lines[i]); + } + } + + cpfree(set->lines); +} + + +void +cpPolylineSetFree(cpPolylineSet *set, cpBool freePolylines) +{ + if(set){ + cpPolylineSetDestroy(set, freePolylines); + cpfree(set); + } +} + +// Find the polyline that ends with v. +static int +cpPolylineSetFindEnds(cpPolylineSet *set, cpVect v){ + int count = set->count; + cpPolyline **lines = set->lines; + + for(int i=0; iverts[line->count - 1], v)) return i; + } + + return -1; +} + +// Find the polyline that starts with v. +static int +cpPolylineSetFindStarts(cpPolylineSet *set, cpVect v){ + int count = set->count; + cpPolyline **lines = set->lines; + + for(int i=0; iverts[0], v)) return i; + } + + return -1; +} + +// Add a new polyline to a polyline set. +static void +cpPolylineSetPush(cpPolylineSet *set, cpPolyline *line) +{ + // grow set + set->count++; + if(set->count > set->capacity){ + set->capacity *= 2; + set->lines = (cpPolyline**) cprealloc(set->lines, set->capacity*sizeof(cpPolyline)); + } + + set->lines[set->count - 1] = line; +} + +// Add a new polyline to a polyline set. +static void +cpPolylineSetAdd(cpPolylineSet *set, cpVect v0, cpVect v1) +{ + cpPolylineSetPush(set, cpPolylineMake2(DEFAULT_POLYLINE_CAPACITY, v0, v1)); +} + +// Join two cpPolylines in a polyline set together. +static void +cpPolylineSetJoin(cpPolylineSet *set, int before, int after) +{ + cpPolyline *lbefore = set->lines[before]; + cpPolyline *lafter = set->lines[after]; + + // append + int count = lbefore->count; + lbefore = cpPolylineGrow(lbefore, lafter->count); + memmove(lbefore->verts + count, lafter->verts, lafter->count*sizeof(cpVect)); + set->lines[before] = lbefore; + + // delete lafter + set->count--; + cpPolylineFree(set->lines[after]); + set->lines[after] = set->lines[set->count]; +} + +// Add a segment to a polyline set. +// A segment will either start a new polyline, join two others, or add to or loop an existing polyline. +void +cpPolylineSetCollectSegment(cpVect v0, cpVect v1, cpPolylineSet *lines) +{ + int before = cpPolylineSetFindEnds(lines, v0); + int after = cpPolylineSetFindStarts(lines, v1); + + if(before >= 0 && after >= 0){ + if(before == after){ + // loop by pushing v1 onto before + lines->lines[before] = cpPolylinePush(lines->lines[before], v1); + } else { + // join before and after + cpPolylineSetJoin(lines, before, after); + } + } else if(before >= 0){ + // push v1 onto before + lines->lines[before] = cpPolylinePush(lines->lines[before], v1); + } else if(after >= 0){ + // enqueue v0 onto after + lines->lines[after] = cpPolylineEnqueue(lines->lines[after], v0); + } else { + // create new line from v0 and v1 + cpPolylineSetAdd(lines, v0, v1); + } +} + +//MARK: Convex Hull Functions + +cpPolyline * +cpPolylineToConvexHull(cpPolyline *line, cpFloat tol) +{ + cpPolyline *hull = cpPolylineMake(line->count + 1); + hull->count = cpConvexHull(line->count, line->verts, hull->verts, NULL, tol); + hull = cpPolylinePush(hull, hull->verts[0]); + + return cpPolylineShrink(hull); +} + +//MARK: Approximate Concave Decompostition + +struct Notch { + int i; + cpFloat d; + cpVect v; + cpVect n; +}; + +static cpFloat +FindSteiner(int count, cpVect *verts, struct Notch notch) +{ + cpFloat min = INFINITY; + cpFloat feature = -1.0; + + for(int i=1; i= 0.0 && dist <= min){ + min = dist; + feature = index + t; + } + } + } + + return feature; +} + +//static cpFloat +//FindSteiner2(cpVect *verts, int count, struct Notch notch) +//{ +// cpVect a = verts[(notch.i + count - 1)%count]; +// cpVect b = verts[(notch.i + 1)%count]; +// cpVect n = cpvnormalize(cpvadd(cpvnormalize(cpvsub(notch.v, a)), cpvnormalize(cpvsub(notch.v, b)))); +// +// cpFloat min = INFINITY; +// cpFloat feature = -1.0; +// +// for(int i=1; i= 0.0 && dist <= min){ +// min = dist; +// feature = index + t; +// } +// } +// } +// +// cpAssertSoft(feature >= 0.0, "No closest features detected. This is likely due to a self intersecting polygon."); +// return feature; +//} + +//struct Range {cpFloat min, max;}; +//static inline struct Range +//clip_range(cpVect delta_a, cpVect delta_b, cpVect clip) +//{ +// cpFloat da = cpvcross(delta_a, clip); +// cpFloat db = cpvcross(delta_b, clip); +// cpFloat clamp = da/(da - db); +// if(da > db){ +// return (struct Range){-INFINITY, clamp}; +// } else if(da < db){ +// return (struct Range){clamp, INFINITY}; +// } else { +// return (struct Range){-INFINITY, INFINITY}; +// } +//} +// +//static cpFloat +//FindSteiner3(cpVect *verts, int count, struct Notch notch) +//{ +// cpFloat min = INFINITY; +// cpFloat feature = -1.0; +// +// cpVect support_a = verts[(notch.i - 1 + count)%count]; +// cpVect support_b = verts[(notch.i + 1)%count]; +// +// cpVect clip_a = cpvlerp(support_a, support_b, 0.1); +// cpVect clip_b = cpvlerp(support_b, support_b, 0.9); +// +// for(int i=1; i 0.0){ +// struct Range range1 = clip_range(delta_a, delta_b, cpvsub(notch.v, clip_a)); +// struct Range range2 = clip_range(delta_a, delta_b, cpvsub(clip_b, notch.v)); +// +// cpFloat min_t = cpfmax(0.0, cpfmax(range1.min, range2.min)); +// cpFloat max_t = cpfmin(1.0, cpfmin(range1.max, range2.max)); +// +// // Ignore if the segment has been completely clipped away. +// if(min_t < max_t){ +// cpVect seg_delta = cpvsub(seg_b, seg_a); +// cpFloat closest_t = cpfclamp(cpvdot(seg_delta, cpvsub(notch.v, seg_a))/cpvlengthsq(seg_delta), min_t, max_t); +// cpVect closest = cpvlerp(seg_a, seg_b, closest_t); +// +// cpFloat dist = cpvdistsq(notch.v, closest); +// if(dist < min){ +// min = dist; +// feature = index + closest_t; +// } +// } +// } +// } +// +// cpAssertWarn(feature >= 0.0, "Internal Error: No closest features detected."); +// return feature; +//} + +//static cpBool +//VertexUnobscured(int count, cpVect *verts, int index, int notch_i) +//{ +// cpVect v = verts[notch_i]; +// cpVect n = cpvnormalize(cpvsub(verts[index], v)); +// +// for(int i=0; i= 0.0, "No closest features detected. This is likely due to a self intersecting polygon."); +// return feature; +//} + +static struct Notch +DeepestNotch(int count, cpVect *verts, int hullCount, cpVect *hullVerts, int first, cpFloat tol) +{ + struct Notch notch = {}; + int j = Next(first, count); + + for(int i=0; i notch.d){ + notch.d = depth; + notch.i = j; + notch.v = v; + notch.n = n; + } + + j = Next(j, count); + v = verts[j]; + } + + j = Next(j, count); + } + + return notch; +} + +static inline int IMAX(int a, int b){return (a > b ? a : b);} + +static void +ApproximateConcaveDecomposition(cpVect *verts, int count, cpFloat tol, cpPolylineSet *set) +{ + int first; + cpVect *hullVerts = (cpVect*) alloca(count*sizeof(cpVect)); + int hullCount = cpConvexHull(count, verts, hullVerts, &first, 0.0); + + if(hullCount != count){ + struct Notch notch = DeepestNotch(count, verts, hullCount, hullVerts, first, tol); + + if(notch.d > tol){ + cpFloat steiner_it = FindSteiner(count, verts, notch); + + if(steiner_it >= 0.0){ + int steiner_i = (int)steiner_it; + cpVect steiner = cpvlerp(verts[steiner_i], verts[Next(steiner_i, count)], steiner_it - steiner_i); + + // Vertex counts NOT including the steiner point. + int sub1_count = (steiner_i - notch.i + count)%count + 1; + int sub2_count = count - (steiner_i - notch.i + count)%count; + cpVect *scratch = (cpVect*) alloca((IMAX(sub1_count, sub2_count) + 1)*sizeof(cpVect)); + + for(int i=0; iverts, hullVerts, hullCount*sizeof(cpVect)); + hull->verts[hullCount] = hullVerts[0]; + hull->count = hullCount + 1; + + cpPolylineSetPush(set, hull); +} + +cpPolylineSet * +cpPolylineConvexDecomposition_BETA(cpPolyline *line, cpFloat tol) +{ + cpAssertSoft(cpPolylineIsClosed(line), "Cannot decompose an open polygon."); + cpAssertSoft(cpAreaForPoly(line->count, line->verts, 0.0) >= 0.0, "Winding is backwards. (Are you passing a hole?)"); + + cpPolylineSet *set = cpPolylineSetNew(); + ApproximateConcaveDecomposition(line->verts, line->count - 1, tol, set); + + return set; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpRatchetJoint.c b/source/engine/thirdparty/Chipmunk2D/src/cpRatchetJoint.c new file mode 100644 index 0000000..b3c9687 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpRatchetJoint.c @@ -0,0 +1,179 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +static void +preStep(cpRatchetJoint *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + cpFloat angle = joint->angle; + cpFloat phase = joint->phase; + cpFloat ratchet = joint->ratchet; + + cpFloat delta = b->a - a->a; + cpFloat diff = angle - delta; + cpFloat pdist = 0.0f; + + if(diff*ratchet > 0.0f){ + pdist = diff; + } else { + joint->angle = cpffloor((delta - phase)/ratchet)*ratchet + phase; + } + + // calculate moment of inertia coefficient. + joint->iSum = 1.0f/(a->i_inv + b->i_inv); + + // calculate bias velocity + cpFloat maxBias = joint->constraint.maxBias; + joint->bias = cpfclamp(-bias_coef(joint->constraint.errorBias, dt)*pdist/dt, -maxBias, maxBias); + + // If the bias is 0, the joint is not at a limit. Reset the impulse. + if(!joint->bias) joint->jAcc = 0.0f; +} + +static void +applyCachedImpulse(cpRatchetJoint *joint, cpFloat dt_coef) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + cpFloat j = joint->jAcc*dt_coef; + a->w -= j*a->i_inv; + b->w += j*b->i_inv; +} + +static void +applyImpulse(cpRatchetJoint *joint, cpFloat dt) +{ + if(!joint->bias) return; // early exit + + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + // compute relative rotational velocity + cpFloat wr = b->w - a->w; + cpFloat ratchet = joint->ratchet; + + cpFloat jMax = joint->constraint.maxForce*dt; + + // compute normal impulse + cpFloat j = -(joint->bias + wr)*joint->iSum; + cpFloat jOld = joint->jAcc; + joint->jAcc = cpfclamp((jOld + j)*ratchet, 0.0f, jMax*cpfabs(ratchet))/ratchet; + j = joint->jAcc - jOld; + + // apply impulse + a->w -= j*a->i_inv; + b->w += j*b->i_inv; +} + +static cpFloat +getImpulse(cpRatchetJoint *joint) +{ + return cpfabs(joint->jAcc); +} + +static const cpConstraintClass klass = { + (cpConstraintPreStepImpl)preStep, + (cpConstraintApplyCachedImpulseImpl)applyCachedImpulse, + (cpConstraintApplyImpulseImpl)applyImpulse, + (cpConstraintGetImpulseImpl)getImpulse, +}; + +cpRatchetJoint * +cpRatchetJointAlloc(void) +{ + return (cpRatchetJoint *)cpcalloc(1, sizeof(cpRatchetJoint)); +} + +cpRatchetJoint * +cpRatchetJointInit(cpRatchetJoint *joint, cpBody *a, cpBody *b, cpFloat phase, cpFloat ratchet) +{ + cpConstraintInit((cpConstraint *)joint, &klass, a, b); + + joint->angle = 0.0f; + joint->phase = phase; + joint->ratchet = ratchet; + + // STATIC_BODY_CHECK + joint->angle = (b ? b->a : 0.0f) - (a ? a->a : 0.0f); + + return joint; +} + +cpConstraint * +cpRatchetJointNew(cpBody *a, cpBody *b, cpFloat phase, cpFloat ratchet) +{ + return (cpConstraint *)cpRatchetJointInit(cpRatchetJointAlloc(), a, b, phase, ratchet); +} + +cpBool +cpConstraintIsRatchetJoint(const cpConstraint *constraint) +{ + return (constraint->klass == &klass); +} + +cpFloat +cpRatchetJointGetAngle(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsRatchetJoint(constraint), "Constraint is not a ratchet joint."); + return ((cpRatchetJoint *)constraint)->angle; +} + +void +cpRatchetJointSetAngle(cpConstraint *constraint, cpFloat angle) +{ + cpAssertHard(cpConstraintIsRatchetJoint(constraint), "Constraint is not a ratchet joint."); + cpConstraintActivateBodies(constraint); + ((cpRatchetJoint *)constraint)->angle = angle; +} + +cpFloat +cpRatchetJointGetPhase(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsRatchetJoint(constraint), "Constraint is not a ratchet joint."); + return ((cpRatchetJoint *)constraint)->phase; +} + +void +cpRatchetJointSetPhase(cpConstraint *constraint, cpFloat phase) +{ + cpAssertHard(cpConstraintIsRatchetJoint(constraint), "Constraint is not a ratchet joint."); + cpConstraintActivateBodies(constraint); + ((cpRatchetJoint *)constraint)->phase = phase; +} +cpFloat +cpRatchetJointGetRatchet(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsRatchetJoint(constraint), "Constraint is not a ratchet joint."); + return ((cpRatchetJoint *)constraint)->ratchet; +} + +void +cpRatchetJointSetRatchet(cpConstraint *constraint, cpFloat ratchet) +{ + cpAssertHard(cpConstraintIsRatchetJoint(constraint), "Constraint is not a ratchet joint."); + cpConstraintActivateBodies(constraint); + ((cpRatchetJoint *)constraint)->ratchet = ratchet; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpRobust.c b/source/engine/thirdparty/Chipmunk2D/src/cpRobust.c new file mode 100644 index 0000000..57507d1 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpRobust.c @@ -0,0 +1,13 @@ +#include "chipmunk/cpRobust.h" + + +cpBool +cpCheckPointGreater(const cpVect a, const cpVect b, const cpVect c) +{ + return (b.y - a.y)*(a.x + b.x - 2*c.x) > (b.x - a.x)*(a.y + b.y - 2*c.y); +} + +cpBool +cpCheckAxis(cpVect v0, cpVect v1, cpVect p, cpVect n){ + return cpvdot(p, n) <= cpfmax(cpvdot(v0, n), cpvdot(v1, n)); +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpRotaryLimitJoint.c b/source/engine/thirdparty/Chipmunk2D/src/cpRotaryLimitJoint.c new file mode 100644 index 0000000..548adbe --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpRotaryLimitJoint.c @@ -0,0 +1,160 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +static void +preStep(cpRotaryLimitJoint *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + cpFloat dist = b->a - a->a; + cpFloat pdist = 0.0f; + if(dist > joint->max) { + pdist = joint->max - dist; + } else if(dist < joint->min) { + pdist = joint->min - dist; + } + + // calculate moment of inertia coefficient. + joint->iSum = 1.0f/(a->i_inv + b->i_inv); + + // calculate bias velocity + cpFloat maxBias = joint->constraint.maxBias; + joint->bias = cpfclamp(-bias_coef(joint->constraint.errorBias, dt)*pdist/dt, -maxBias, maxBias); + + // If the bias is 0, the joint is not at a limit. Reset the impulse. + if(!joint->bias) joint->jAcc = 0.0f; +} + +static void +applyCachedImpulse(cpRotaryLimitJoint *joint, cpFloat dt_coef) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + cpFloat j = joint->jAcc*dt_coef; + a->w -= j*a->i_inv; + b->w += j*b->i_inv; +} + +static void +applyImpulse(cpRotaryLimitJoint *joint, cpFloat dt) +{ + if(!joint->bias) return; // early exit + + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + // compute relative rotational velocity + cpFloat wr = b->w - a->w; + + cpFloat jMax = joint->constraint.maxForce*dt; + + // compute normal impulse + cpFloat j = -(joint->bias + wr)*joint->iSum; + cpFloat jOld = joint->jAcc; + if(joint->bias < 0.0f){ + joint->jAcc = cpfclamp(jOld + j, 0.0f, jMax); + } else { + joint->jAcc = cpfclamp(jOld + j, -jMax, 0.0f); + } + j = joint->jAcc - jOld; + + // apply impulse + a->w -= j*a->i_inv; + b->w += j*b->i_inv; +} + +static cpFloat +getImpulse(cpRotaryLimitJoint *joint) +{ + return cpfabs(joint->jAcc); +} + +static const cpConstraintClass klass = { + (cpConstraintPreStepImpl)preStep, + (cpConstraintApplyCachedImpulseImpl)applyCachedImpulse, + (cpConstraintApplyImpulseImpl)applyImpulse, + (cpConstraintGetImpulseImpl)getImpulse, +}; + +cpRotaryLimitJoint * +cpRotaryLimitJointAlloc(void) +{ + return (cpRotaryLimitJoint *)cpcalloc(1, sizeof(cpRotaryLimitJoint)); +} + +cpRotaryLimitJoint * +cpRotaryLimitJointInit(cpRotaryLimitJoint *joint, cpBody *a, cpBody *b, cpFloat min, cpFloat max) +{ + cpConstraintInit((cpConstraint *)joint, &klass, a, b); + + joint->min = min; + joint->max = max; + + joint->jAcc = 0.0f; + + return joint; +} + +cpConstraint * +cpRotaryLimitJointNew(cpBody *a, cpBody *b, cpFloat min, cpFloat max) +{ + return (cpConstraint *)cpRotaryLimitJointInit(cpRotaryLimitJointAlloc(), a, b, min, max); +} + +cpBool +cpConstraintIsRotaryLimitJoint(const cpConstraint *constraint) +{ + return (constraint->klass == &klass); +} + +cpFloat +cpRotaryLimitJointGetMin(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsRotaryLimitJoint(constraint), "Constraint is not a rotary limit joint."); + return ((cpRotaryLimitJoint *)constraint)->min; +} + +void +cpRotaryLimitJointSetMin(cpConstraint *constraint, cpFloat min) +{ + cpAssertHard(cpConstraintIsRotaryLimitJoint(constraint), "Constraint is not a rotary limit joint."); + cpConstraintActivateBodies(constraint); + ((cpRotaryLimitJoint *)constraint)->min = min; +} + +cpFloat +cpRotaryLimitJointGetMax(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsRotaryLimitJoint(constraint), "Constraint is not a rotary limit joint."); + return ((cpRotaryLimitJoint *)constraint)->max; +} + +void +cpRotaryLimitJointSetMax(cpConstraint *constraint, cpFloat max) +{ + cpAssertHard(cpConstraintIsRotaryLimitJoint(constraint), "Constraint is not a rotary limit joint."); + cpConstraintActivateBodies(constraint); + ((cpRotaryLimitJoint *)constraint)->max = max; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpShape.c b/source/engine/thirdparty/Chipmunk2D/src/cpShape.c new file mode 100644 index 0000000..513b535 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpShape.c @@ -0,0 +1,604 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" +#include "chipmunk/chipmunk_unsafe.h" + +#define CP_DefineShapeGetter(struct, type, member, name) \ +CP_DeclareShapeGetter(struct, type, name){ \ + cpAssertHard(shape->klass == &struct##Class, "shape is not a "#struct); \ + return ((struct *)shape)->member; \ +} + +cpShape * +cpShapeInit(cpShape *shape, const cpShapeClass *klass, cpBody *body, struct cpShapeMassInfo massInfo) +{ + shape->klass = klass; + + shape->body = body; + shape->massInfo = massInfo; + + shape->sensor = 0; + + shape->e = 0.0f; + shape->u = 0.0f; + shape->surfaceV = cpvzero; + + shape->type = 0; + shape->filter.group = CP_NO_GROUP; + shape->filter.categories = CP_ALL_CATEGORIES; + shape->filter.mask = CP_ALL_CATEGORIES; + + shape->userData = NULL; + + shape->space = NULL; + + shape->next = NULL; + shape->prev = NULL; + + return shape; +} + +void +cpShapeDestroy(cpShape *shape) +{ + if(shape->klass && shape->klass->destroy) shape->klass->destroy(shape); +} + +void +cpShapeFree(cpShape *shape) +{ + if(shape){ + cpShapeDestroy(shape); + cpfree(shape); + } +} + +cpSpace * +cpShapeGetSpace(const cpShape *shape) +{ + return shape->space; +} + +cpBody * +cpShapeGetBody(const cpShape *shape) +{ + return shape->body; +} + +void +cpShapeSetBody(cpShape *shape, cpBody *body) +{ + cpAssertHard(!cpShapeActive(shape), "You cannot change the body on an active shape. You must remove the shape from the space before changing the body."); + shape->body = body; +} + +cpFloat cpShapeGetMass(cpShape *shape){ return shape->massInfo.m; } + +void +cpShapeSetMass(cpShape *shape, cpFloat mass){ + cpBody *body = shape->body; + cpBodyActivate(body); + + shape->massInfo.m = mass; + cpBodyAccumulateMassFromShapes(body); +} + +cpFloat cpShapeGetDensity(cpShape *shape){ return shape->massInfo.m/shape->massInfo.area; } +void cpShapeSetDensity(cpShape *shape, cpFloat density){ cpShapeSetMass(shape, density*shape->massInfo.area); } + +cpFloat cpShapeGetMoment(cpShape *shape){ return shape->massInfo.m*shape->massInfo.i; } +cpFloat cpShapeGetArea(cpShape *shape){ return shape->massInfo.area; } +cpVect cpShapeGetCenterOfGravity(cpShape *shape) { return shape->massInfo.cog; } + +cpBB +cpShapeGetBB(const cpShape *shape) +{ + return shape->bb; +} + +cpBool +cpShapeGetSensor(const cpShape *shape) +{ + return shape->sensor; +} + +void +cpShapeSetSensor(cpShape *shape, cpBool sensor) +{ + cpBodyActivate(shape->body); + shape->sensor = sensor; +} + +cpFloat +cpShapeGetElasticity(const cpShape *shape) +{ + return shape->e; +} + +void +cpShapeSetElasticity(cpShape *shape, cpFloat elasticity) +{ + cpAssertHard(elasticity >= 0.0f, "Elasticity must be positive."); + cpBodyActivate(shape->body); + shape->e = elasticity; +} + +cpFloat +cpShapeGetFriction(const cpShape *shape) +{ + return shape->u; +} + +void +cpShapeSetFriction(cpShape *shape, cpFloat friction) +{ + cpAssertHard(friction >= 0.0f, "Friction must be postive."); + cpBodyActivate(shape->body); + shape->u = friction; +} + +cpVect +cpShapeGetSurfaceVelocity(const cpShape *shape) +{ + return shape->surfaceV; +} + +void +cpShapeSetSurfaceVelocity(cpShape *shape, cpVect surfaceVelocity) +{ + cpBodyActivate(shape->body); + shape->surfaceV = surfaceVelocity; +} + +cpDataPointer +cpShapeGetUserData(const cpShape *shape) +{ + return shape->userData; +} + +void +cpShapeSetUserData(cpShape *shape, cpDataPointer userData) +{ + shape->userData = userData; +} + +cpCollisionType +cpShapeGetCollisionType(const cpShape *shape) +{ + return shape->type; +} + +void +cpShapeSetCollisionType(cpShape *shape, cpCollisionType collisionType) +{ + cpBodyActivate(shape->body); + shape->type = collisionType; +} + +cpShapeFilter +cpShapeGetFilter(const cpShape *shape) +{ + return shape->filter; +} + +void +cpShapeSetFilter(cpShape *shape, cpShapeFilter filter) +{ + cpBodyActivate(shape->body); + shape->filter = filter; +} + +cpBB +cpShapeCacheBB(cpShape *shape) +{ + return cpShapeUpdate(shape, shape->body->transform); +} + +cpBB +cpShapeUpdate(cpShape *shape, cpTransform transform) +{ + return (shape->bb = shape->klass->cacheData(shape, transform)); +} + +cpFloat +cpShapePointQuery(const cpShape *shape, cpVect p, cpPointQueryInfo *info) +{ + cpPointQueryInfo blank = {NULL, cpvzero, INFINITY, cpvzero}; + if(info){ + (*info) = blank; + } else { + info = ␣ + } + + shape->klass->pointQuery(shape, p, info); + return info->distance; +} + + +cpBool +cpShapeSegmentQuery(const cpShape *shape, cpVect a, cpVect b, cpFloat radius, cpSegmentQueryInfo *info){ + cpSegmentQueryInfo blank = {NULL, b, cpvzero, 1.0f}; + if(info){ + (*info) = blank; + } else { + info = ␣ + } + + cpPointQueryInfo nearest; + shape->klass->pointQuery(shape, a, &nearest); + if(nearest.distance <= radius){ + info->shape = shape; + info->alpha = 0.0; + info->normal = cpvnormalize(cpvsub(a, nearest.point)); + } else { + shape->klass->segmentQuery(shape, a, b, radius, info); + } + + return (info->shape != NULL); +} + +cpContactPointSet +cpShapesCollide(const cpShape *a, const cpShape *b) +{ + struct cpContact contacts[CP_MAX_CONTACTS_PER_ARBITER]; + struct cpCollisionInfo info = cpCollide(a, b, 0, contacts); + + cpContactPointSet set; + set.count = info.count; + + // cpCollideShapes() may have swapped the contact order. Flip the normal. + cpBool swapped = (a != info.a); + set.normal = (swapped ? cpvneg(info.n) : info.n); + + for(int i=0; itc = cpTransformPoint(transform, circle->c); + return cpBBNewForCircle(c, circle->r); +} + +static void +cpCircleShapePointQuery(cpCircleShape *circle, cpVect p, cpPointQueryInfo *info) +{ + cpVect delta = cpvsub(p, circle->tc); + cpFloat d = cpvlength(delta); + cpFloat r = circle->r; + + info->shape = (cpShape *)circle; + cpFloat r_over_d = d > 0.0f ? r/d : r; + info->point = cpvadd(circle->tc, cpvmult(delta, r_over_d)); // TODO: div/0 + info->distance = d - r; + + // Use up for the gradient if the distance is very small. + info->gradient = (d > MAGIC_EPSILON ? cpvmult(delta, 1.0f/d) : cpv(0.0f, 1.0f)); +} + +static void +cpCircleShapeSegmentQuery(cpCircleShape *circle, cpVect a, cpVect b, cpFloat radius, cpSegmentQueryInfo *info) +{ + CircleSegmentQuery((cpShape *)circle, circle->tc, circle->r, a, b, radius, info); +} + +static struct cpShapeMassInfo +cpCircleShapeMassInfo(cpFloat mass, cpFloat radius, cpVect center) +{ + struct cpShapeMassInfo info = { + mass, cpMomentForCircle(1.0f, 0.0f, radius, cpvzero), + center, + cpAreaForCircle(0.0f, radius), + }; + + return info; +} + +static const cpShapeClass cpCircleShapeClass = { + CP_CIRCLE_SHAPE, + (cpShapeCacheDataImpl)cpCircleShapeCacheData, + NULL, + (cpShapePointQueryImpl)cpCircleShapePointQuery, + (cpShapeSegmentQueryImpl)cpCircleShapeSegmentQuery, +}; + +cpCircleShape * +cpCircleShapeInit(cpCircleShape *circle, cpBody *body, cpFloat radius, cpVect offset) +{ + circle->c = offset; + circle->r = radius; + + cpShapeInit((cpShape *)circle, &cpCircleShapeClass, body, cpCircleShapeMassInfo(0.0f, radius, offset)); + + return circle; +} + +cpShape * +cpCircleShapeNew(cpBody *body, cpFloat radius, cpVect offset) +{ + return (cpShape *)cpCircleShapeInit(cpCircleShapeAlloc(), body, radius, offset); +} + +cpVect +cpCircleShapeGetOffset(const cpShape *shape) +{ + cpAssertHard(shape->klass == &cpCircleShapeClass, "Shape is not a circle shape."); + return ((cpCircleShape *)shape)->c; +} + +cpFloat +cpCircleShapeGetRadius(const cpShape *shape) +{ + cpAssertHard(shape->klass == &cpCircleShapeClass, "Shape is not a circle shape."); + return ((cpCircleShape *)shape)->r; +} + + +cpSegmentShape * +cpSegmentShapeAlloc(void) +{ + return (cpSegmentShape *)cpcalloc(1, sizeof(cpSegmentShape)); +} + +static cpBB +cpSegmentShapeCacheData(cpSegmentShape *seg, cpTransform transform) +{ + seg->ta = cpTransformPoint(transform, seg->a); + seg->tb = cpTransformPoint(transform, seg->b); + seg->tn = cpTransformVect(transform, seg->n); + + cpFloat l,r,b,t; + + if(seg->ta.x < seg->tb.x){ + l = seg->ta.x; + r = seg->tb.x; + } else { + l = seg->tb.x; + r = seg->ta.x; + } + + if(seg->ta.y < seg->tb.y){ + b = seg->ta.y; + t = seg->tb.y; + } else { + b = seg->tb.y; + t = seg->ta.y; + } + + cpFloat rad = seg->r; + return cpBBNew(l - rad, b - rad, r + rad, t + rad); +} + +static void +cpSegmentShapePointQuery(cpSegmentShape *seg, cpVect p, cpPointQueryInfo *info) +{ + cpVect closest = cpClosetPointOnSegment(p, seg->ta, seg->tb); + + cpVect delta = cpvsub(p, closest); + cpFloat d = cpvlength(delta); + cpFloat r = seg->r; + cpVect g = cpvmult(delta, 1.0f/d); + + info->shape = (cpShape *)seg; + info->point = (d ? cpvadd(closest, cpvmult(g, r)) : closest); + info->distance = d - r; + + // Use the segment's normal if the distance is very small. + info->gradient = (d > MAGIC_EPSILON ? g : seg->n); +} + +static void +cpSegmentShapeSegmentQuery(cpSegmentShape *seg, cpVect a, cpVect b, cpFloat r2, cpSegmentQueryInfo *info) +{ + cpVect n = seg->tn; + cpFloat d = cpvdot(cpvsub(seg->ta, a), n); + cpFloat r = seg->r + r2; + + cpVect flipped_n = (d > 0.0f ? cpvneg(n) : n); + cpVect seg_offset = cpvsub(cpvmult(flipped_n, r), a); + + // Make the endpoints relative to 'a' and move them by the thickness of the segment. + cpVect seg_a = cpvadd(seg->ta, seg_offset); + cpVect seg_b = cpvadd(seg->tb, seg_offset); + cpVect delta = cpvsub(b, a); + + if(cpvcross(delta, seg_a)*cpvcross(delta, seg_b) <= 0.0f){ + cpFloat d_offset = d + (d > 0.0f ? -r : r); + cpFloat ad = -d_offset; + cpFloat bd = cpvdot(delta, n) - d_offset; + + if(ad*bd < 0.0f){ + cpFloat t = ad/(ad - bd); + + info->shape = (cpShape *)seg; + info->point = cpvsub(cpvlerp(a, b, t), cpvmult(flipped_n, r2)); + info->normal = flipped_n; + info->alpha = t; + } + } else if(r != 0.0f){ + cpSegmentQueryInfo info1 = {NULL, b, cpvzero, 1.0f}; + cpSegmentQueryInfo info2 = {NULL, b, cpvzero, 1.0f}; + CircleSegmentQuery((cpShape *)seg, seg->ta, seg->r, a, b, r2, &info1); + CircleSegmentQuery((cpShape *)seg, seg->tb, seg->r, a, b, r2, &info2); + + if(info1.alpha < info2.alpha){ + (*info) = info1; + } else { + (*info) = info2; + } + } +} + +static struct cpShapeMassInfo +cpSegmentShapeMassInfo(cpFloat mass, cpVect a, cpVect b, cpFloat r) +{ + struct cpShapeMassInfo info = { + mass, cpMomentForBox(1.0f, cpvdist(a, b) + 2.0f*r, 2.0f*r), // TODO is an approximation. + cpvlerp(a, b, 0.5f), + cpAreaForSegment(a, b, r), + }; + + return info; +} + +static const cpShapeClass cpSegmentShapeClass = { + CP_SEGMENT_SHAPE, + (cpShapeCacheDataImpl)cpSegmentShapeCacheData, + NULL, + (cpShapePointQueryImpl)cpSegmentShapePointQuery, + (cpShapeSegmentQueryImpl)cpSegmentShapeSegmentQuery, +}; + +cpSegmentShape * +cpSegmentShapeInit(cpSegmentShape *seg, cpBody *body, cpVect a, cpVect b, cpFloat r) +{ + seg->a = a; + seg->b = b; + seg->n = cpvrperp(cpvnormalize(cpvsub(b, a))); + + seg->r = r; + + seg->a_tangent = cpvzero; + seg->b_tangent = cpvzero; + + cpShapeInit((cpShape *)seg, &cpSegmentShapeClass, body, cpSegmentShapeMassInfo(0.0f, a, b, r)); + + return seg; +} + +cpShape* +cpSegmentShapeNew(cpBody *body, cpVect a, cpVect b, cpFloat r) +{ + return (cpShape *)cpSegmentShapeInit(cpSegmentShapeAlloc(), body, a, b, r); +} + +cpVect +cpSegmentShapeGetA(const cpShape *shape) +{ + cpAssertHard(shape->klass == &cpSegmentShapeClass, "Shape is not a segment shape."); + return ((cpSegmentShape *)shape)->a; +} + +cpVect +cpSegmentShapeGetB(const cpShape *shape) +{ + cpAssertHard(shape->klass == &cpSegmentShapeClass, "Shape is not a segment shape."); + return ((cpSegmentShape *)shape)->b; +} + +cpVect +cpSegmentShapeGetNormal(const cpShape *shape) +{ + cpAssertHard(shape->klass == &cpSegmentShapeClass, "Shape is not a segment shape."); + return ((cpSegmentShape *)shape)->n; +} + +cpFloat +cpSegmentShapeGetRadius(const cpShape *shape) +{ + cpAssertHard(shape->klass == &cpSegmentShapeClass, "Shape is not a segment shape."); + return ((cpSegmentShape *)shape)->r; +} + +void +cpSegmentShapeSetNeighbors(cpShape *shape, cpVect prev, cpVect next) +{ + cpAssertHard(shape->klass == &cpSegmentShapeClass, "Shape is not a segment shape."); + cpSegmentShape *seg = (cpSegmentShape *)shape; + + seg->a_tangent = cpvsub(prev, seg->a); + seg->b_tangent = cpvsub(next, seg->b); +} + +// Unsafe API (chipmunk_unsafe.h) + +// TODO setters should wake the shape up? + +void +cpCircleShapeSetRadius(cpShape *shape, cpFloat radius) +{ + cpAssertHard(shape->klass == &cpCircleShapeClass, "Shape is not a circle shape."); + cpCircleShape *circle = (cpCircleShape *)shape; + + circle->r = radius; + + cpFloat mass = shape->massInfo.m; + shape->massInfo = cpCircleShapeMassInfo(mass, circle->r, circle->c); + if(mass > 0.0f) cpBodyAccumulateMassFromShapes(shape->body); +} + +void +cpCircleShapeSetOffset(cpShape *shape, cpVect offset) +{ + cpAssertHard(shape->klass == &cpCircleShapeClass, "Shape is not a circle shape."); + cpCircleShape *circle = (cpCircleShape *)shape; + + circle->c = offset; + + cpFloat mass = shape->massInfo.m; + shape->massInfo = cpCircleShapeMassInfo(shape->massInfo.m, circle->r, circle->c); + if(mass > 0.0f) cpBodyAccumulateMassFromShapes(shape->body); +} + +void +cpSegmentShapeSetEndpoints(cpShape *shape, cpVect a, cpVect b) +{ + cpAssertHard(shape->klass == &cpSegmentShapeClass, "Shape is not a segment shape."); + cpSegmentShape *seg = (cpSegmentShape *)shape; + + seg->a = a; + seg->b = b; + seg->n = cpvperp(cpvnormalize(cpvsub(b, a))); + + cpFloat mass = shape->massInfo.m; + shape->massInfo = cpSegmentShapeMassInfo(shape->massInfo.m, seg->a, seg->b, seg->r); + if(mass > 0.0f) cpBodyAccumulateMassFromShapes(shape->body); +} + +void +cpSegmentShapeSetRadius(cpShape *shape, cpFloat radius) +{ + cpAssertHard(shape->klass == &cpSegmentShapeClass, "Shape is not a segment shape."); + cpSegmentShape *seg = (cpSegmentShape *)shape; + + seg->r = radius; + + cpFloat mass = shape->massInfo.m; + shape->massInfo = cpSegmentShapeMassInfo(shape->massInfo.m, seg->a, seg->b, seg->r); + if(mass > 0.0f) cpBodyAccumulateMassFromShapes(shape->body); +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpSimpleMotor.c b/source/engine/thirdparty/Chipmunk2D/src/cpSimpleMotor.c new file mode 100644 index 0000000..2bea74a --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpSimpleMotor.c @@ -0,0 +1,123 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +static void +preStep(cpSimpleMotor *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + // calculate moment of inertia coefficient. + joint->iSum = 1.0f/(a->i_inv + b->i_inv); +} + +static void +applyCachedImpulse(cpSimpleMotor *joint, cpFloat dt_coef) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + cpFloat j = joint->jAcc*dt_coef; + a->w -= j*a->i_inv; + b->w += j*b->i_inv; +} + +static void +applyImpulse(cpSimpleMotor *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + // compute relative rotational velocity + cpFloat wr = b->w - a->w + joint->rate; + + cpFloat jMax = joint->constraint.maxForce*dt; + + // compute normal impulse + cpFloat j = -wr*joint->iSum; + cpFloat jOld = joint->jAcc; + joint->jAcc = cpfclamp(jOld + j, -jMax, jMax); + j = joint->jAcc - jOld; + + // apply impulse + a->w -= j*a->i_inv; + b->w += j*b->i_inv; +} + +static cpFloat +getImpulse(cpSimpleMotor *joint) +{ + return cpfabs(joint->jAcc); +} + +static const cpConstraintClass klass = { + (cpConstraintPreStepImpl)preStep, + (cpConstraintApplyCachedImpulseImpl)applyCachedImpulse, + (cpConstraintApplyImpulseImpl)applyImpulse, + (cpConstraintGetImpulseImpl)getImpulse, +}; + +cpSimpleMotor * +cpSimpleMotorAlloc(void) +{ + return (cpSimpleMotor *)cpcalloc(1, sizeof(cpSimpleMotor)); +} + +cpSimpleMotor * +cpSimpleMotorInit(cpSimpleMotor *joint, cpBody *a, cpBody *b, cpFloat rate) +{ + cpConstraintInit((cpConstraint *)joint, &klass, a, b); + + joint->rate = rate; + + joint->jAcc = 0.0f; + + return joint; +} + +cpConstraint * +cpSimpleMotorNew(cpBody *a, cpBody *b, cpFloat rate) +{ + return (cpConstraint *)cpSimpleMotorInit(cpSimpleMotorAlloc(), a, b, rate); +} + +cpBool +cpConstraintIsSimpleMotor(const cpConstraint *constraint) +{ + return (constraint->klass == &klass); +} + +cpFloat +cpSimpleMotorGetRate(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsSimpleMotor(constraint), "Constraint is not a SimpleMotor."); + return ((cpSimpleMotor *)constraint)->rate; +} + +void +cpSimpleMotorSetRate(cpConstraint *constraint, cpFloat rate) +{ + cpAssertHard(cpConstraintIsSimpleMotor(constraint), "Constraint is not a SimpleMotor."); + cpConstraintActivateBodies(constraint); + ((cpSimpleMotor *)constraint)->rate = rate; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpSlideJoint.c b/source/engine/thirdparty/Chipmunk2D/src/cpSlideJoint.c new file mode 100644 index 0000000..61afe33 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpSlideJoint.c @@ -0,0 +1,195 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +static void +preStep(cpSlideJoint *joint, cpFloat dt) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + joint->r1 = cpTransformVect(a->transform, cpvsub(joint->anchorA, a->cog)); + joint->r2 = cpTransformVect(b->transform, cpvsub(joint->anchorB, b->cog)); + + cpVect delta = cpvsub(cpvadd(b->p, joint->r2), cpvadd(a->p, joint->r1)); + cpFloat dist = cpvlength(delta); + cpFloat pdist = 0.0f; + if(dist > joint->max) { + pdist = dist - joint->max; + joint->n = cpvnormalize(delta); + } else if(dist < joint->min) { + pdist = joint->min - dist; + joint->n = cpvneg(cpvnormalize(delta)); + } else { + joint->n = cpvzero; + joint->jnAcc = 0.0f; + } + + // calculate mass normal + joint->nMass = 1.0f/k_scalar(a, b, joint->r1, joint->r2, joint->n); + + // calculate bias velocity + cpFloat maxBias = joint->constraint.maxBias; + joint->bias = cpfclamp(-bias_coef(joint->constraint.errorBias, dt)*pdist/dt, -maxBias, maxBias); +} + +static void +applyCachedImpulse(cpSlideJoint *joint, cpFloat dt_coef) +{ + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + cpVect j = cpvmult(joint->n, joint->jnAcc*dt_coef); + apply_impulses(a, b, joint->r1, joint->r2, j); +} + +static void +applyImpulse(cpSlideJoint *joint, cpFloat dt) +{ + if(cpveql(joint->n, cpvzero)) return; // early exit + + cpBody *a = joint->constraint.a; + cpBody *b = joint->constraint.b; + + cpVect n = joint->n; + cpVect r1 = joint->r1; + cpVect r2 = joint->r2; + + // compute relative velocity + cpVect vr = relative_velocity(a, b, r1, r2); + cpFloat vrn = cpvdot(vr, n); + + // compute normal impulse + cpFloat jn = (joint->bias - vrn)*joint->nMass; + cpFloat jnOld = joint->jnAcc; + joint->jnAcc = cpfclamp(jnOld + jn, -joint->constraint.maxForce*dt, 0.0f); + jn = joint->jnAcc - jnOld; + + // apply impulse + apply_impulses(a, b, joint->r1, joint->r2, cpvmult(n, jn)); +} + +static cpFloat +getImpulse(cpConstraint *joint) +{ + return cpfabs(((cpSlideJoint *)joint)->jnAcc); +} + +static const cpConstraintClass klass = { + (cpConstraintPreStepImpl)preStep, + (cpConstraintApplyCachedImpulseImpl)applyCachedImpulse, + (cpConstraintApplyImpulseImpl)applyImpulse, + (cpConstraintGetImpulseImpl)getImpulse, +}; + +cpSlideJoint * +cpSlideJointAlloc(void) +{ + return (cpSlideJoint *)cpcalloc(1, sizeof(cpSlideJoint)); +} + +cpSlideJoint * +cpSlideJointInit(cpSlideJoint *joint, cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB, cpFloat min, cpFloat max) +{ + cpConstraintInit((cpConstraint *)joint, &klass, a, b); + + joint->anchorA = anchorA; + joint->anchorB = anchorB; + joint->min = min; + joint->max = max; + + joint->jnAcc = 0.0f; + + return joint; +} + +cpConstraint * +cpSlideJointNew(cpBody *a, cpBody *b, cpVect anchorA, cpVect anchorB, cpFloat min, cpFloat max) +{ + return (cpConstraint *)cpSlideJointInit(cpSlideJointAlloc(), a, b, anchorA, anchorB, min, max); +} + +cpBool +cpConstraintIsSlideJoint(const cpConstraint *constraint) +{ + return (constraint->klass == &klass); +} + +cpVect +cpSlideJointGetAnchorA(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsSlideJoint(constraint), "Constraint is not a slide joint."); + return ((cpSlideJoint *)constraint)->anchorA; +} + +void +cpSlideJointSetAnchorA(cpConstraint *constraint, cpVect anchorA) +{ + cpAssertHard(cpConstraintIsSlideJoint(constraint), "Constraint is not a slide joint."); + cpConstraintActivateBodies(constraint); + ((cpSlideJoint *)constraint)->anchorA = anchorA; +} + +cpVect +cpSlideJointGetAnchorB(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsSlideJoint(constraint), "Constraint is not a slide joint."); + return ((cpSlideJoint *)constraint)->anchorB; +} + +void +cpSlideJointSetAnchorB(cpConstraint *constraint, cpVect anchorB) +{ + cpAssertHard(cpConstraintIsSlideJoint(constraint), "Constraint is not a slide joint."); + cpConstraintActivateBodies(constraint); + ((cpSlideJoint *)constraint)->anchorB = anchorB; +} + +cpFloat +cpSlideJointGetMin(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsSlideJoint(constraint), "Constraint is not a slide joint."); + return ((cpSlideJoint *)constraint)->min; +} + +void +cpSlideJointSetMin(cpConstraint *constraint, cpFloat min) +{ + cpAssertHard(cpConstraintIsSlideJoint(constraint), "Constraint is not a slide joint."); + cpConstraintActivateBodies(constraint); + ((cpSlideJoint *)constraint)->min = min; +} + +cpFloat +cpSlideJointGetMax(const cpConstraint *constraint) +{ + cpAssertHard(cpConstraintIsSlideJoint(constraint), "Constraint is not a slide joint."); + return ((cpSlideJoint *)constraint)->max; +} + +void +cpSlideJointSetMax(cpConstraint *constraint, cpFloat max) +{ + cpAssertHard(cpConstraintIsSlideJoint(constraint), "Constraint is not a slide joint."); + cpConstraintActivateBodies(constraint); + ((cpSlideJoint *)constraint)->max = max; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpSpace.c b/source/engine/thirdparty/Chipmunk2D/src/cpSpace.c new file mode 100644 index 0000000..b319d3a --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpSpace.c @@ -0,0 +1,701 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include +#include + +#include "chipmunk/chipmunk_private.h" + +//MARK: Contact Set Helpers + +// Equal function for arbiterSet. +static cpBool +arbiterSetEql(cpShape **shapes, cpArbiter *arb) +{ + cpShape *a = shapes[0]; + cpShape *b = shapes[1]; + + return ((a == arb->a && b == arb->b) || (b == arb->a && a == arb->b)); +} + +//MARK: Collision Handler Set HelperFunctions + +// Equals function for collisionHandlers. +static cpBool +handlerSetEql(cpCollisionHandler *check, cpCollisionHandler *pair) +{ + return ( + (check->typeA == pair->typeA && check->typeB == pair->typeB) || + (check->typeB == pair->typeA && check->typeA == pair->typeB) + ); +} + +// Transformation function for collisionHandlers. +static void * +handlerSetTrans(cpCollisionHandler *handler, void *unused) +{ + cpCollisionHandler *copy = (cpCollisionHandler *)cpcalloc(1, sizeof(cpCollisionHandler)); + memcpy(copy, handler, sizeof(cpCollisionHandler)); + + return copy; +} + +//MARK: Misc Helper Funcs + +// Default collision functions. + +static cpBool +DefaultBegin(cpArbiter *arb, cpSpace *space, cpDataPointer data){ + cpBool retA = cpArbiterCallWildcardBeginA(arb, space); + cpBool retB = cpArbiterCallWildcardBeginB(arb, space); + return retA && retB; +} + +static cpBool +DefaultPreSolve(cpArbiter *arb, cpSpace *space, cpDataPointer data){ + cpBool retA = cpArbiterCallWildcardPreSolveA(arb, space); + cpBool retB = cpArbiterCallWildcardPreSolveB(arb, space); + return retA && retB; +} + +static void +DefaultPostSolve(cpArbiter *arb, cpSpace *space, cpDataPointer data){ + cpArbiterCallWildcardPostSolveA(arb, space); + cpArbiterCallWildcardPostSolveB(arb, space); +} + +static void +DefaultSeparate(cpArbiter *arb, cpSpace *space, cpDataPointer data){ + cpArbiterCallWildcardSeparateA(arb, space); + cpArbiterCallWildcardSeparateB(arb, space); +} + +// Use the wildcard identifier since the default handler should never match any type pair. +static cpCollisionHandler cpCollisionHandlerDefault = { + CP_WILDCARD_COLLISION_TYPE, CP_WILDCARD_COLLISION_TYPE, + DefaultBegin, DefaultPreSolve, DefaultPostSolve, DefaultSeparate, NULL +}; + +static cpBool AlwaysCollide(cpArbiter *arb, cpSpace *space, cpDataPointer data){return cpTrue;} +static void DoNothing(cpArbiter *arb, cpSpace *space, cpDataPointer data){} + +cpCollisionHandler cpCollisionHandlerDoNothing = { + CP_WILDCARD_COLLISION_TYPE, CP_WILDCARD_COLLISION_TYPE, + AlwaysCollide, AlwaysCollide, DoNothing, DoNothing, NULL +}; + +// function to get the estimated velocity of a shape for the cpBBTree. +static cpVect ShapeVelocityFunc(cpShape *shape){return shape->body->v;} + +// Used for disposing of collision handlers. +static void FreeWrap(void *ptr, void *unused){cpfree(ptr);} + +//MARK: Memory Management Functions + +cpSpace * +cpSpaceAlloc(void) +{ + return (cpSpace *)cpcalloc(1, sizeof(cpSpace)); +} + +cpSpace* +cpSpaceInit(cpSpace *space) +{ +#ifndef NDEBUG + static cpBool done = cpFalse; + if(!done){ + printf("Initializing cpSpace - Chipmunk v%s (Debug Enabled)\n", cpVersionString); + printf("Compile with -DNDEBUG defined to disable debug mode and runtime assertion checks\n"); + done = cpTrue; + } +#endif + + space->iterations = 10; + + space->gravity = cpvzero; + space->damping = 1.0f; + + space->collisionSlop = 0.1f; + space->collisionBias = cpfpow(1.0f - 0.1f, 60.0f); + space->collisionPersistence = 3; + + space->locked = 0; + space->stamp = 0; + + space->shapeIDCounter = 0; + space->staticShapes = cpBBTreeNew((cpSpatialIndexBBFunc)cpShapeGetBB, NULL); + space->dynamicShapes = cpBBTreeNew((cpSpatialIndexBBFunc)cpShapeGetBB, space->staticShapes); + cpBBTreeSetVelocityFunc(space->dynamicShapes, (cpBBTreeVelocityFunc)ShapeVelocityFunc); + + space->allocatedBuffers = cpArrayNew(0); + + space->dynamicBodies = cpArrayNew(0); + space->staticBodies = cpArrayNew(0); + space->sleepingComponents = cpArrayNew(0); + space->rousedBodies = cpArrayNew(0); + + space->sleepTimeThreshold = INFINITY; + space->idleSpeedThreshold = 0.0f; + + space->arbiters = cpArrayNew(0); + space->pooledArbiters = cpArrayNew(0); + + space->contactBuffersHead = NULL; + space->cachedArbiters = cpHashSetNew(0, (cpHashSetEqlFunc)arbiterSetEql); + + space->constraints = cpArrayNew(0); + + space->usesWildcards = cpFalse; + memcpy(&space->defaultHandler, &cpCollisionHandlerDoNothing, sizeof(cpCollisionHandler)); + space->collisionHandlers = cpHashSetNew(0, (cpHashSetEqlFunc)handlerSetEql); + + space->postStepCallbacks = cpArrayNew(0); + space->skipPostStep = cpFalse; + + cpBody *staticBody = cpBodyInit(&space->_staticBody, 0.0f, 0.0f); + cpBodySetType(staticBody, CP_BODY_TYPE_STATIC); + cpSpaceSetStaticBody(space, staticBody); + + return space; +} + +cpSpace* +cpSpaceNew(void) +{ + return cpSpaceInit(cpSpaceAlloc()); +} + +static void cpBodyActivateWrap(cpBody *body, void *unused){cpBodyActivate(body);} + +void +cpSpaceDestroy(cpSpace *space) +{ + cpSpaceEachBody(space, (cpSpaceBodyIteratorFunc)cpBodyActivateWrap, NULL); + + cpSpatialIndexFree(space->staticShapes); + cpSpatialIndexFree(space->dynamicShapes); + + cpArrayFree(space->dynamicBodies); + cpArrayFree(space->staticBodies); + cpArrayFree(space->sleepingComponents); + cpArrayFree(space->rousedBodies); + + cpArrayFree(space->constraints); + + cpHashSetFree(space->cachedArbiters); + + cpArrayFree(space->arbiters); + cpArrayFree(space->pooledArbiters); + + if(space->allocatedBuffers){ + cpArrayFreeEach(space->allocatedBuffers, cpfree); + cpArrayFree(space->allocatedBuffers); + } + + if(space->postStepCallbacks){ + cpArrayFreeEach(space->postStepCallbacks, cpfree); + cpArrayFree(space->postStepCallbacks); + } + + if(space->collisionHandlers) cpHashSetEach(space->collisionHandlers, FreeWrap, NULL); + cpHashSetFree(space->collisionHandlers); +} + +void +cpSpaceFree(cpSpace *space) +{ + if(space){ + cpSpaceDestroy(space); + cpfree(space); + } +} + + +//MARK: Basic properties: + +int +cpSpaceGetIterations(const cpSpace *space) +{ + return space->iterations; +} + +void +cpSpaceSetIterations(cpSpace *space, int iterations) +{ + cpAssertHard(iterations > 0, "Iterations must be positive and non-zero."); + space->iterations = iterations; +} + +cpVect +cpSpaceGetGravity(const cpSpace *space) +{ + return space->gravity; +} + +void +cpSpaceSetGravity(cpSpace *space, cpVect gravity) +{ + space->gravity = gravity; + + // Wake up all of the bodies since the gravity changed. + cpArray *components = space->sleepingComponents; + for(int i=0; inum; i++){ + cpBodyActivate((cpBody *)components->arr[i]); + } +} + +cpFloat +cpSpaceGetDamping(const cpSpace *space) +{ + return space->damping; +} + +void +cpSpaceSetDamping(cpSpace *space, cpFloat damping) +{ + cpAssertHard(damping >= 0.0, "Damping must be positive."); + space->damping = damping; +} + +cpFloat +cpSpaceGetIdleSpeedThreshold(const cpSpace *space) +{ + return space->idleSpeedThreshold; +} + +void +cpSpaceSetIdleSpeedThreshold(cpSpace *space, cpFloat idleSpeedThreshold) +{ + space->idleSpeedThreshold = idleSpeedThreshold; +} + +cpFloat +cpSpaceGetSleepTimeThreshold(const cpSpace *space) +{ + return space->sleepTimeThreshold; +} + +void +cpSpaceSetSleepTimeThreshold(cpSpace *space, cpFloat sleepTimeThreshold) +{ + space->sleepTimeThreshold = sleepTimeThreshold; +} + +cpFloat +cpSpaceGetCollisionSlop(const cpSpace *space) +{ + return space->collisionSlop; +} + +void +cpSpaceSetCollisionSlop(cpSpace *space, cpFloat collisionSlop) +{ + space->collisionSlop = collisionSlop; +} + +cpFloat +cpSpaceGetCollisionBias(const cpSpace *space) +{ + return space->collisionBias; +} + +void +cpSpaceSetCollisionBias(cpSpace *space, cpFloat collisionBias) +{ + space->collisionBias = collisionBias; +} + +cpTimestamp +cpSpaceGetCollisionPersistence(const cpSpace *space) +{ + return space->collisionPersistence; +} + +void +cpSpaceSetCollisionPersistence(cpSpace *space, cpTimestamp collisionPersistence) +{ + space->collisionPersistence = collisionPersistence; +} + +cpDataPointer +cpSpaceGetUserData(const cpSpace *space) +{ + return space->userData; +} + +void +cpSpaceSetUserData(cpSpace *space, cpDataPointer userData) +{ + space->userData = userData; +} + +cpBody * +cpSpaceGetStaticBody(const cpSpace *space) +{ + return space->staticBody; +} + +cpFloat +cpSpaceGetCurrentTimeStep(const cpSpace *space) +{ + return space->curr_dt; +} + +void +cpSpaceSetStaticBody(cpSpace *space, cpBody *body) +{ + if(space->staticBody != NULL){ + cpAssertHard(space->staticBody->shapeList == NULL, "Internal Error: Changing the designated static body while the old one still had shapes attached."); + space->staticBody->space = NULL; + } + + space->staticBody = body; + body->space = space; +} + +cpBool +cpSpaceIsLocked(cpSpace *space) +{ + return (space->locked > 0); +} + +//MARK: Collision Handler Function Management + +static void +cpSpaceUseWildcardDefaultHandler(cpSpace *space) +{ + // Spaces default to using the slightly faster "do nothing" default handler until wildcards are potentially needed. + if(!space->usesWildcards){ + space->usesWildcards = cpTrue; + memcpy(&space->defaultHandler, &cpCollisionHandlerDefault, sizeof(cpCollisionHandler)); + } +} + +cpCollisionHandler *cpSpaceAddDefaultCollisionHandler(cpSpace *space) +{ + cpSpaceUseWildcardDefaultHandler(space); + return &space->defaultHandler; +} + +cpCollisionHandler *cpSpaceAddCollisionHandler(cpSpace *space, cpCollisionType a, cpCollisionType b) +{ + cpHashValue hash = CP_HASH_PAIR(a, b); + cpCollisionHandler handler = {a, b, DefaultBegin, DefaultPreSolve, DefaultPostSolve, DefaultSeparate, NULL}; + return (cpCollisionHandler*)cpHashSetInsert(space->collisionHandlers, hash, &handler, (cpHashSetTransFunc)handlerSetTrans, NULL); +} + +cpCollisionHandler * +cpSpaceAddWildcardHandler(cpSpace *space, cpCollisionType type) +{ + cpSpaceUseWildcardDefaultHandler(space); + + cpHashValue hash = CP_HASH_PAIR(type, CP_WILDCARD_COLLISION_TYPE); + cpCollisionHandler handler = {type, CP_WILDCARD_COLLISION_TYPE, AlwaysCollide, AlwaysCollide, DoNothing, DoNothing, NULL}; + return (cpCollisionHandler*)cpHashSetInsert(space->collisionHandlers, hash, &handler, (cpHashSetTransFunc)handlerSetTrans, NULL); +} + + +//MARK: Body, Shape, and Joint Management +cpShape * +cpSpaceAddShape(cpSpace *space, cpShape *shape) +{ + cpAssertHard(shape->space != space, "You have already added this shape to this space. You must not add it a second time."); + cpAssertHard(!shape->space, "You have already added this shape to another space. You cannot add it to a second."); + cpAssertHard(shape->body, "The shape's body is not defined."); + cpAssertHard(shape->body->space == space, "The shape's body must be added to the space before the shape."); + cpAssertSpaceUnlocked(space); + + cpBody *body = shape->body; + + cpBool isStatic = (cpBodyGetType(body) == CP_BODY_TYPE_STATIC); + if(!isStatic) cpBodyActivate(body); + cpBodyAddShape(body, shape); + + shape->hashid = space->shapeIDCounter++; + cpShapeUpdate(shape, body->transform); + cpSpatialIndexInsert(isStatic ? space->staticShapes : space->dynamicShapes, shape, shape->hashid); + shape->space = space; + + return shape; +} + +cpBody * +cpSpaceAddBody(cpSpace *space, cpBody *body) +{ + cpAssertHard(body->space != space, "You have already added this body to this space. You must not add it a second time."); + cpAssertHard(!body->space, "You have already added this body to another space. You cannot add it to a second."); + cpAssertSpaceUnlocked(space); + + cpArrayPush(cpSpaceArrayForBodyType(space, cpBodyGetType(body)), body); + body->space = space; + + return body; +} + +cpConstraint * +cpSpaceAddConstraint(cpSpace *space, cpConstraint *constraint) +{ + cpAssertHard(constraint->space != space, "You have already added this constraint to this space. You must not add it a second time."); + cpAssertHard(!constraint->space, "You have already added this constraint to another space. You cannot add it to a second."); + cpAssertSpaceUnlocked(space); + + cpBody *a = constraint->a, *b = constraint->b; + cpAssertHard(a != NULL && b != NULL, "Constraint is attached to a NULL body."); +// cpAssertHard(a->space == space && b->space == space, "The constraint's bodies must be added to the space before the constraint."); + + cpBodyActivate(a); + cpBodyActivate(b); + cpArrayPush(space->constraints, constraint); + + // Push onto the heads of the bodies' constraint lists + constraint->next_a = a->constraintList; a->constraintList = constraint; + constraint->next_b = b->constraintList; b->constraintList = constraint; + constraint->space = space; + + return constraint; +} + +struct arbiterFilterContext { + cpSpace *space; + cpBody *body; + cpShape *shape; +}; + +static cpBool +cachedArbitersFilter(cpArbiter *arb, struct arbiterFilterContext *context) +{ + cpShape *shape = context->shape; + cpBody *body = context->body; + + + // Match on the filter shape, or if it's NULL the filter body + if( + (body == arb->body_a && (shape == arb->a || shape == NULL)) || + (body == arb->body_b && (shape == arb->b || shape == NULL)) + ){ + // Call separate when removing shapes. + if(shape && arb->state != CP_ARBITER_STATE_CACHED){ + // Invalidate the arbiter since one of the shapes was removed. + arb->state = CP_ARBITER_STATE_INVALIDATED; + + cpCollisionHandler *handler = arb->handler; + handler->separateFunc(arb, context->space, handler->userData); + } + + cpArbiterUnthread(arb); + cpArrayDeleteObj(context->space->arbiters, arb); + cpArrayPush(context->space->pooledArbiters, arb); + + return cpFalse; + } + + return cpTrue; +} + +void +cpSpaceFilterArbiters(cpSpace *space, cpBody *body, cpShape *filter) +{ + cpSpaceLock(space); { + struct arbiterFilterContext context = {space, body, filter}; + cpHashSetFilter(space->cachedArbiters, (cpHashSetFilterFunc)cachedArbitersFilter, &context); + } cpSpaceUnlock(space, cpTrue); +} + +void +cpSpaceRemoveShape(cpSpace *space, cpShape *shape) +{ + cpBody *body = shape->body; + cpAssertHard(cpSpaceContainsShape(space, shape), "Cannot remove a shape that was not added to the space. (Removed twice maybe?)"); + cpAssertSpaceUnlocked(space); + + cpBool isStatic = (cpBodyGetType(body) == CP_BODY_TYPE_STATIC); + if(isStatic){ + cpBodyActivateStatic(body, shape); + } else { + cpBodyActivate(body); + } + + cpBodyRemoveShape(body, shape); + cpSpaceFilterArbiters(space, body, shape); + cpSpatialIndexRemove(isStatic ? space->staticShapes : space->dynamicShapes, shape, shape->hashid); + shape->space = NULL; + shape->hashid = 0; +} + +void +cpSpaceRemoveBody(cpSpace *space, cpBody *body) +{ + cpAssertHard(body != cpSpaceGetStaticBody(space), "Cannot remove the designated static body for the space."); + cpAssertHard(cpSpaceContainsBody(space, body), "Cannot remove a body that was not added to the space. (Removed twice maybe?)"); +// cpAssertHard(body->shapeList == NULL, "Cannot remove a body from the space before removing the bodies attached to it."); +// cpAssertHard(body->constraintList == NULL, "Cannot remove a body from the space before removing the constraints attached to it."); + cpAssertSpaceUnlocked(space); + + cpBodyActivate(body); +// cpSpaceFilterArbiters(space, body, NULL); + cpArrayDeleteObj(cpSpaceArrayForBodyType(space, cpBodyGetType(body)), body); + body->space = NULL; +} + +void +cpSpaceRemoveConstraint(cpSpace *space, cpConstraint *constraint) +{ + cpAssertHard(cpSpaceContainsConstraint(space, constraint), "Cannot remove a constraint that was not added to the space. (Removed twice maybe?)"); + cpAssertSpaceUnlocked(space); + + cpBodyActivate(constraint->a); + cpBodyActivate(constraint->b); + cpArrayDeleteObj(space->constraints, constraint); + + cpBodyRemoveConstraint(constraint->a, constraint); + cpBodyRemoveConstraint(constraint->b, constraint); + constraint->space = NULL; +} + +cpBool cpSpaceContainsShape(cpSpace *space, cpShape *shape) +{ + return (shape->space == space); +} + +cpBool cpSpaceContainsBody(cpSpace *space, cpBody *body) +{ + return (body->space == space); +} + +cpBool cpSpaceContainsConstraint(cpSpace *space, cpConstraint *constraint) +{ + return (constraint->space == space); +} + +//MARK: Iteration + +void +cpSpaceEachBody(cpSpace *space, cpSpaceBodyIteratorFunc func, void *data) +{ + cpSpaceLock(space); { + cpArray *bodies = space->dynamicBodies; + for(int i=0; inum; i++){ + func((cpBody *)bodies->arr[i], data); + } + + cpArray *otherBodies = space->staticBodies; + for(int i=0; inum; i++){ + func((cpBody *)otherBodies->arr[i], data); + } + + cpArray *components = space->sleepingComponents; + for(int i=0; inum; i++){ + cpBody *root = (cpBody *)components->arr[i]; + + cpBody *body = root; + while(body){ + cpBody *next = body->sleeping.next; + func(body, data); + body = next; + } + } + } cpSpaceUnlock(space, cpTrue); +} + +typedef struct spaceShapeContext { + cpSpaceShapeIteratorFunc func; + void *data; +} spaceShapeContext; + +static void +spaceEachShapeIterator(cpShape *shape, spaceShapeContext *context) +{ + context->func(shape, context->data); +} + +void +cpSpaceEachShape(cpSpace *space, cpSpaceShapeIteratorFunc func, void *data) +{ + cpSpaceLock(space); { + spaceShapeContext context = {func, data}; + cpSpatialIndexEach(space->dynamicShapes, (cpSpatialIndexIteratorFunc)spaceEachShapeIterator, &context); + cpSpatialIndexEach(space->staticShapes, (cpSpatialIndexIteratorFunc)spaceEachShapeIterator, &context); + } cpSpaceUnlock(space, cpTrue); +} + +void +cpSpaceEachConstraint(cpSpace *space, cpSpaceConstraintIteratorFunc func, void *data) +{ + cpSpaceLock(space); { + cpArray *constraints = space->constraints; + + for(int i=0; inum; i++){ + func((cpConstraint *)constraints->arr[i], data); + } + } cpSpaceUnlock(space, cpTrue); +} + +//MARK: Spatial Index Management + +void +cpSpaceReindexStatic(cpSpace *space) +{ + cpAssertHard(!space->locked, "You cannot manually reindex objects while the space is locked. Wait until the current query or step is complete."); + + cpSpatialIndexEach(space->staticShapes, (cpSpatialIndexIteratorFunc)&cpShapeUpdateFunc, NULL); + cpSpatialIndexReindex(space->staticShapes); +} + +void +cpSpaceReindexShape(cpSpace *space, cpShape *shape) +{ + cpAssertHard(!space->locked, "You cannot manually reindex objects while the space is locked. Wait until the current query or step is complete."); + + cpShapeCacheBB(shape); + + // attempt to rehash the shape in both hashes + cpSpatialIndexReindexObject(space->dynamicShapes, shape, shape->hashid); + cpSpatialIndexReindexObject(space->staticShapes, shape, shape->hashid); +} + +void +cpSpaceReindexShapesForBody(cpSpace *space, cpBody *body) +{ + CP_BODY_FOREACH_SHAPE(body, shape) cpSpaceReindexShape(space, shape); +} + + +static void +copyShapes(cpShape *shape, cpSpatialIndex *index) +{ + cpSpatialIndexInsert(index, shape, shape->hashid); +} + +void +cpSpaceUseSpatialHash(cpSpace *space, cpFloat dim, int count) +{ + cpSpatialIndex *staticShapes = cpSpaceHashNew(dim, count, (cpSpatialIndexBBFunc)cpShapeGetBB, NULL); + cpSpatialIndex *dynamicShapes = cpSpaceHashNew(dim, count, (cpSpatialIndexBBFunc)cpShapeGetBB, staticShapes); + + cpSpatialIndexEach(space->staticShapes, (cpSpatialIndexIteratorFunc)copyShapes, staticShapes); + cpSpatialIndexEach(space->dynamicShapes, (cpSpatialIndexIteratorFunc)copyShapes, dynamicShapes); + + cpSpatialIndexFree(space->staticShapes); + cpSpatialIndexFree(space->dynamicShapes); + + space->staticShapes = staticShapes; + space->dynamicShapes = dynamicShapes; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpSpaceComponent.c b/source/engine/thirdparty/Chipmunk2D/src/cpSpaceComponent.c new file mode 100644 index 0000000..7b2d606 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpSpaceComponent.c @@ -0,0 +1,349 @@ +/* Copyright (c) 2007 Scott Lembcke + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include + +#include "chipmunk/chipmunk_private.h" + +//MARK: Sleeping Functions + +void +cpSpaceActivateBody(cpSpace *space, cpBody *body) +{ + cpAssertHard(cpBodyGetType(body) == CP_BODY_TYPE_DYNAMIC, "Internal error: Attempting to activate a non-dynamic body."); + + if(space->locked){ + // cpSpaceActivateBody() is called again once the space is unlocked + if(!cpArrayContains(space->rousedBodies, body)) cpArrayPush(space->rousedBodies, body); + } else { + cpAssertSoft(body->sleeping.root == NULL && body->sleeping.next == NULL, "Internal error: Activating body non-NULL node pointers."); + cpArrayPush(space->dynamicBodies, body); + + CP_BODY_FOREACH_SHAPE(body, shape){ + cpSpatialIndexRemove(space->staticShapes, shape, shape->hashid); + cpSpatialIndexInsert(space->dynamicShapes, shape, shape->hashid); + } + + CP_BODY_FOREACH_ARBITER(body, arb){ + cpBody *bodyA = arb->body_a; + + // Arbiters are shared between two bodies that are always woken up together. + // You only want to restore the arbiter once, so bodyA is arbitrarily chosen to own the arbiter. + // The edge case is when static bodies are involved as the static bodies never actually sleep. + // If the static body is bodyB then all is good. If the static body is bodyA, that can easily be checked. + if(body == bodyA || cpBodyGetType(bodyA) == CP_BODY_TYPE_STATIC){ + int numContacts = arb->count; + struct cpContact *contacts = arb->contacts; + + // Restore contact values back to the space's contact buffer memory + arb->contacts = cpContactBufferGetArray(space); + memcpy(arb->contacts, contacts, numContacts*sizeof(struct cpContact)); + cpSpacePushContacts(space, numContacts); + + // Reinsert the arbiter into the arbiter cache + const cpShape *a = arb->a, *b = arb->b; + const cpShape *shape_pair[] = {a, b}; + cpHashValue arbHashID = CP_HASH_PAIR((cpHashValue)a, (cpHashValue)b); + cpHashSetInsert(space->cachedArbiters, arbHashID, shape_pair, NULL, arb); + + // Update the arbiter's state + arb->stamp = space->stamp; + cpArrayPush(space->arbiters, arb); + + cpfree(contacts); + } + } + + CP_BODY_FOREACH_CONSTRAINT(body, constraint){ + cpBody *bodyA = constraint->a; + if(body == bodyA || cpBodyGetType(bodyA) == CP_BODY_TYPE_STATIC) cpArrayPush(space->constraints, constraint); + } + } +} + +static void +cpSpaceDeactivateBody(cpSpace *space, cpBody *body) +{ + cpAssertHard(cpBodyGetType(body) == CP_BODY_TYPE_DYNAMIC, "Internal error: Attempting to deactivate a non-dynamic body."); + + cpArrayDeleteObj(space->dynamicBodies, body); + + CP_BODY_FOREACH_SHAPE(body, shape){ + cpSpatialIndexRemove(space->dynamicShapes, shape, shape->hashid); + cpSpatialIndexInsert(space->staticShapes, shape, shape->hashid); + } + + CP_BODY_FOREACH_ARBITER(body, arb){ + cpBody *bodyA = arb->body_a; + if(body == bodyA || cpBodyGetType(bodyA) == CP_BODY_TYPE_STATIC){ + cpSpaceUncacheArbiter(space, arb); + + // Save contact values to a new block of memory so they won't time out + size_t bytes = arb->count*sizeof(struct cpContact); + struct cpContact *contacts = (struct cpContact *)cpcalloc(1, bytes); + memcpy(contacts, arb->contacts, bytes); + arb->contacts = contacts; + } + } + + CP_BODY_FOREACH_CONSTRAINT(body, constraint){ + cpBody *bodyA = constraint->a; + if(body == bodyA || cpBodyGetType(bodyA) == CP_BODY_TYPE_STATIC) cpArrayDeleteObj(space->constraints, constraint); + } +} + +static inline cpBody * +ComponentRoot(cpBody *body) +{ + return (body ? body->sleeping.root : NULL); +} + +void +cpBodyActivate(cpBody *body) +{ + if(body != NULL && cpBodyGetType(body) == CP_BODY_TYPE_DYNAMIC){ + body->sleeping.idleTime = 0.0f; + + cpBody *root = ComponentRoot(body); + if(root && cpBodyIsSleeping(root)){ + // TODO should cpBodyIsSleeping(root) be an assertion? + cpAssertSoft(cpBodyGetType(root) == CP_BODY_TYPE_DYNAMIC, "Internal Error: Non-dynamic body component root detected."); + + cpSpace *space = root->space; + cpBody *body = root; + while(body){ + cpBody *next = body->sleeping.next; + + body->sleeping.idleTime = 0.0f; + body->sleeping.root = NULL; + body->sleeping.next = NULL; + cpSpaceActivateBody(space, body); + + body = next; + } + + cpArrayDeleteObj(space->sleepingComponents, root); + } + + CP_BODY_FOREACH_ARBITER(body, arb){ + // Reset the idle timer of things the body is touching as well. + // That way things don't get left hanging in the air. + cpBody *other = (arb->body_a == body ? arb->body_b : arb->body_a); + if(cpBodyGetType(other) != CP_BODY_TYPE_STATIC) other->sleeping.idleTime = 0.0f; + } + } +} + +void +cpBodyActivateStatic(cpBody *body, cpShape *filter) +{ + cpAssertHard(cpBodyGetType(body) == CP_BODY_TYPE_STATIC, "cpBodyActivateStatic() called on a non-static body."); + + CP_BODY_FOREACH_ARBITER(body, arb){ + if(!filter || filter == arb->a || filter == arb->b){ + cpBodyActivate(arb->body_a == body ? arb->body_b : arb->body_a); + } + } + + // TODO: should also activate joints? +} + +static inline void +cpBodyPushArbiter(cpBody *body, cpArbiter *arb) +{ + cpAssertSoft(cpArbiterThreadForBody(arb, body)->next == NULL, "Internal Error: Dangling contact graph pointers detected. (A)"); + cpAssertSoft(cpArbiterThreadForBody(arb, body)->prev == NULL, "Internal Error: Dangling contact graph pointers detected. (B)"); + + cpArbiter *next = body->arbiterList; + cpAssertSoft(next == NULL || cpArbiterThreadForBody(next, body)->prev == NULL, "Internal Error: Dangling contact graph pointers detected. (C)"); + cpArbiterThreadForBody(arb, body)->next = next; + + if(next) cpArbiterThreadForBody(next, body)->prev = arb; + body->arbiterList = arb; +} + +static inline void +ComponentAdd(cpBody *root, cpBody *body){ + body->sleeping.root = root; + + if(body != root){ + body->sleeping.next = root->sleeping.next; + root->sleeping.next = body; + } +} + +static inline void +FloodFillComponent(cpBody *root, cpBody *body) +{ + // Kinematic bodies cannot be put to sleep and prevent bodies they are touching from sleeping. + // Static bodies are effectively sleeping all the time. + if(cpBodyGetType(body) == CP_BODY_TYPE_DYNAMIC){ + cpBody *other_root = ComponentRoot(body); + if(other_root == NULL){ + ComponentAdd(root, body); + CP_BODY_FOREACH_ARBITER(body, arb) FloodFillComponent(root, (body == arb->body_a ? arb->body_b : arb->body_a)); + CP_BODY_FOREACH_CONSTRAINT(body, constraint) FloodFillComponent(root, (body == constraint->a ? constraint->b : constraint->a)); + } else { + cpAssertSoft(other_root == root, "Internal Error: Inconsistency dectected in the contact graph."); + } + } +} + +static inline cpBool +ComponentActive(cpBody *root, cpFloat threshold) +{ + CP_BODY_FOREACH_COMPONENT(root, body){ + if(body->sleeping.idleTime < threshold) return cpTrue; + } + + return cpFalse; +} + +void +cpSpaceProcessComponents(cpSpace *space, cpFloat dt) +{ + cpBool sleep = (space->sleepTimeThreshold != INFINITY); + cpArray *bodies = space->dynamicBodies; + +#ifndef NDEBUG + for(int i=0; inum; i++){ + cpBody *body = (cpBody*)bodies->arr[i]; + + cpAssertSoft(body->sleeping.next == NULL, "Internal Error: Dangling next pointer detected in contact graph."); + cpAssertSoft(body->sleeping.root == NULL, "Internal Error: Dangling root pointer detected in contact graph."); + } +#endif + + // Calculate the kinetic energy of all the bodies. + if(sleep){ + cpFloat dv = space->idleSpeedThreshold; + cpFloat dvsq = (dv ? dv*dv : cpvlengthsq(space->gravity)*dt*dt); + + // update idling and reset component nodes + for(int i=0; inum; i++){ + cpBody *body = (cpBody*)bodies->arr[i]; + + // TODO should make a separate array for kinematic bodies. + if(cpBodyGetType(body) != CP_BODY_TYPE_DYNAMIC) continue; + + // Need to deal with infinite mass objects + cpFloat keThreshold = (dvsq ? body->m*dvsq : 0.0f); + body->sleeping.idleTime = (cpBodyKineticEnergy(body) > keThreshold ? 0.0f : body->sleeping.idleTime + dt); + } + } + + // Awaken any sleeping bodies found and then push arbiters to the bodies' lists. + cpArray *arbiters = space->arbiters; + for(int i=0, count=arbiters->num; iarr[i]; + cpBody *a = arb->body_a, *b = arb->body_b; + + if(sleep){ + // TODO checking cpBodyIsSleepin() redundant? + if(cpBodyGetType(b) == CP_BODY_TYPE_KINEMATIC || cpBodyIsSleeping(a)) cpBodyActivate(a); + if(cpBodyGetType(a) == CP_BODY_TYPE_KINEMATIC || cpBodyIsSleeping(b)) cpBodyActivate(b); + } + + cpBodyPushArbiter(a, arb); + cpBodyPushArbiter(b, arb); + } + + if(sleep){ + // Bodies should be held active if connected by a joint to a kinematic. + cpArray *constraints = space->constraints; + for(int i=0; inum; i++){ + cpConstraint *constraint = (cpConstraint *)constraints->arr[i]; + cpBody *a = constraint->a, *b = constraint->b; + + if(cpBodyGetType(b) == CP_BODY_TYPE_KINEMATIC) cpBodyActivate(a); + if(cpBodyGetType(a) == CP_BODY_TYPE_KINEMATIC) cpBodyActivate(b); + } + + // Generate components and deactivate sleeping ones + for(int i=0; inum;){ + cpBody *body = (cpBody*)bodies->arr[i]; + + if(ComponentRoot(body) == NULL){ + // Body not in a component yet. Perform a DFS to flood fill mark + // the component in the contact graph using this body as the root. + FloodFillComponent(body, body); + + // Check if the component should be put to sleep. + if(!ComponentActive(body, space->sleepTimeThreshold)){ + cpArrayPush(space->sleepingComponents, body); + CP_BODY_FOREACH_COMPONENT(body, other) cpSpaceDeactivateBody(space, other); + + // cpSpaceDeactivateBody() removed the current body from the list. + // Skip incrementing the index counter. + continue; + } + } + + i++; + + // Only sleeping bodies retain their component node pointers. + body->sleeping.root = NULL; + body->sleeping.next = NULL; + } + } +} + +void +cpBodySleep(cpBody *body) +{ + cpBodySleepWithGroup(body, NULL); +} + +void +cpBodySleepWithGroup(cpBody *body, cpBody *group){ + cpAssertHard(cpBodyGetType(body) == CP_BODY_TYPE_DYNAMIC, "Non-dynamic bodies cannot be put to sleep."); + + cpSpace *space = body->space; + cpAssertHard(!cpSpaceIsLocked(space), "Bodies cannot be put to sleep during a query or a call to cpSpaceStep(). Put these calls into a post-step callback."); + cpAssertHard(cpSpaceGetSleepTimeThreshold(space) < INFINITY, "Sleeping is not enabled on the space. You cannot sleep a body without setting a sleep time threshold on the space."); + cpAssertHard(group == NULL || cpBodyIsSleeping(group), "Cannot use a non-sleeping body as a group identifier."); + + if(cpBodyIsSleeping(body)){ + cpAssertHard(ComponentRoot(body) == ComponentRoot(group), "The body is already sleeping and it's group cannot be reassigned."); + return; + } + + CP_BODY_FOREACH_SHAPE(body, shape) cpShapeCacheBB(shape); + cpSpaceDeactivateBody(space, body); + + if(group){ + cpBody *root = ComponentRoot(group); + + body->sleeping.root = root; + body->sleeping.next = root->sleeping.next; + body->sleeping.idleTime = 0.0f; + + root->sleeping.next = body; + } else { + body->sleeping.root = body; + body->sleeping.next = NULL; + body->sleeping.idleTime = 0.0f; + + cpArrayPush(space->sleepingComponents, body); + } + + cpArrayDeleteObj(space->dynamicBodies, body); +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpSpaceDebug.c b/source/engine/thirdparty/Chipmunk2D/src/cpSpaceDebug.c new file mode 100644 index 0000000..6b80894 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpSpaceDebug.c @@ -0,0 +1,187 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +#ifndef CP_SPACE_DISABLE_DEBUG_API + +static void +cpSpaceDebugDrawShape(cpShape *shape, cpSpaceDebugDrawOptions *options) +{ + cpBody *body = shape->body; + cpDataPointer data = options->data; + + cpSpaceDebugColor outline_color = options->shapeOutlineColor; + cpSpaceDebugColor fill_color = options->colorForShape(shape, data); + + switch(shape->klass->type){ + case CP_CIRCLE_SHAPE: { + cpCircleShape *circle = (cpCircleShape *)shape; + options->drawCircle(circle->tc, body->a, circle->r, outline_color, fill_color, data); + break; + } + case CP_SEGMENT_SHAPE: { + cpSegmentShape *seg = (cpSegmentShape *)shape; + options->drawFatSegment(seg->ta, seg->tb, seg->r, outline_color, fill_color, data); + break; + } + case CP_POLY_SHAPE: { + cpPolyShape *poly = (cpPolyShape *)shape; + + int count = poly->count; + struct cpSplittingPlane *planes = poly->planes; + cpVect *verts = (cpVect *)alloca(count*sizeof(cpVect)); + + for(int i=0; idrawPolygon(count, verts, poly->r, outline_color, fill_color, data); + break; + } + default: break; + } +} + +static const cpVect spring_verts[] = { + {0.00f, 0.0f}, + {0.20f, 0.0f}, + {0.25f, 3.0f}, + {0.30f,-6.0f}, + {0.35f, 6.0f}, + {0.40f,-6.0f}, + {0.45f, 6.0f}, + {0.50f,-6.0f}, + {0.55f, 6.0f}, + {0.60f,-6.0f}, + {0.65f, 6.0f}, + {0.70f,-3.0f}, + {0.75f, 6.0f}, + {0.80f, 0.0f}, + {1.00f, 0.0f}, +}; +static const int spring_count = sizeof(spring_verts)/sizeof(cpVect); + +static void +cpSpaceDebugDrawConstraint(cpConstraint *constraint, cpSpaceDebugDrawOptions *options) +{ + cpDataPointer data = options->data; + cpSpaceDebugColor color = options->constraintColor; + + cpBody *body_a = constraint->a; + cpBody *body_b = constraint->b; + + if(cpConstraintIsPinJoint(constraint)){ + cpPinJoint *joint = (cpPinJoint *)constraint; + + cpVect a = cpTransformPoint(body_a->transform, joint->anchorA); + cpVect b = cpTransformPoint(body_b->transform, joint->anchorB); + + options->drawDot(5, a, color, data); + options->drawDot(5, b, color, data); + options->drawSegment(a, b, color, data); + } else if(cpConstraintIsSlideJoint(constraint)){ + cpSlideJoint *joint = (cpSlideJoint *)constraint; + + cpVect a = cpTransformPoint(body_a->transform, joint->anchorA); + cpVect b = cpTransformPoint(body_b->transform, joint->anchorB); + + options->drawDot(5, a, color, data); + options->drawDot(5, b, color, data); + options->drawSegment(a, b, color, data); + } else if(cpConstraintIsPivotJoint(constraint)){ + cpPivotJoint *joint = (cpPivotJoint *)constraint; + + cpVect a = cpTransformPoint(body_a->transform, joint->anchorA); + cpVect b = cpTransformPoint(body_b->transform, joint->anchorB); + + options->drawDot(5, a, color, data); + options->drawDot(5, b, color, data); + } else if(cpConstraintIsGrooveJoint(constraint)){ + cpGrooveJoint *joint = (cpGrooveJoint *)constraint; + + cpVect a = cpTransformPoint(body_a->transform, joint->grv_a); + cpVect b = cpTransformPoint(body_a->transform, joint->grv_b); + cpVect c = cpTransformPoint(body_b->transform, joint->anchorB); + + options->drawDot(5, c, color, data); + options->drawSegment(a, b, color, data); + } else if(cpConstraintIsDampedSpring(constraint)){ + cpDampedSpring *spring = (cpDampedSpring *)constraint; + + cpVect a = cpTransformPoint(body_a->transform, spring->anchorA); + cpVect b = cpTransformPoint(body_b->transform, spring->anchorB); + + options->drawDot(5, a, color, data); + options->drawDot(5, b, color, data); + + cpVect delta = cpvsub(b, a); + cpFloat cos = delta.x; + cpFloat sin = delta.y; + cpFloat s = 1.0f/cpvlength(delta); + + cpVect r1 = cpv(cos, -sin*s); + cpVect r2 = cpv(sin, cos*s); + + cpVect *verts = (cpVect *)alloca(spring_count*sizeof(cpVect)); + for(int i=0; idrawSegment(verts[i], verts[i + 1], color, data); + } + } +} + +void +cpSpaceDebugDraw(cpSpace *space, cpSpaceDebugDrawOptions *options) +{ + if(options->flags & CP_SPACE_DEBUG_DRAW_SHAPES){ + cpSpaceEachShape(space, (cpSpaceShapeIteratorFunc)cpSpaceDebugDrawShape, options); + } + + if(options->flags & CP_SPACE_DEBUG_DRAW_CONSTRAINTS){ + cpSpaceEachConstraint(space, (cpSpaceConstraintIteratorFunc)cpSpaceDebugDrawConstraint, options); + } + + if(options->flags & CP_SPACE_DEBUG_DRAW_COLLISION_POINTS){ + cpArray *arbiters = space->arbiters; + cpSpaceDebugColor color = options->collisionPointColor; + cpSpaceDebugDrawSegmentImpl draw_seg = options->drawSegment; + cpDataPointer data = options->data; + + for(int i=0; inum; i++){ + cpArbiter *arb = (cpArbiter*)arbiters->arr[i]; + cpVect n = arb->n; + + for(int j=0; jcount; j++){ + cpVect p1 = cpvadd(arb->body_a->p, arb->contacts[j].r1); + cpVect p2 = cpvadd(arb->body_b->p, arb->contacts[j].r2); + + cpFloat d = 2.0f; + cpVect a = cpvadd(p1, cpvmult(n, -d)); + cpVect b = cpvadd(p2, cpvmult(n, d)); + draw_seg(a, b, color, data); + } + } + } +} + +#endif diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpSpaceHash.c b/source/engine/thirdparty/Chipmunk2D/src/cpSpaceHash.c new file mode 100644 index 0000000..556c8d3 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpSpaceHash.c @@ -0,0 +1,634 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" +#include "prime.h" + +typedef struct cpSpaceHashBin cpSpaceHashBin; +typedef struct cpHandle cpHandle; + +struct cpSpaceHash { + cpSpatialIndex spatialIndex; + + int numcells; + cpFloat celldim; + + cpSpaceHashBin **table; + cpHashSet *handleSet; + + cpSpaceHashBin *pooledBins; + cpArray *pooledHandles; + cpArray *allocatedBuffers; + + cpTimestamp stamp; +}; + + +//MARK: Handle Functions + +struct cpHandle { + void *obj; + int retain; + cpTimestamp stamp; +}; + +static cpHandle* +cpHandleInit(cpHandle *hand, void *obj) +{ + hand->obj = obj; + hand->retain = 0; + hand->stamp = 0; + + return hand; +} + +static inline void cpHandleRetain(cpHandle *hand){hand->retain++;} + +static inline void +cpHandleRelease(cpHandle *hand, cpArray *pooledHandles) +{ + hand->retain--; + if(hand->retain == 0) cpArrayPush(pooledHandles, hand); +} + +static int handleSetEql(void *obj, cpHandle *hand){return (obj == hand->obj);} + +static void * +handleSetTrans(void *obj, cpSpaceHash *hash) +{ + if(hash->pooledHandles->num == 0){ + // handle pool is exhausted, make more + int count = CP_BUFFER_BYTES/sizeof(cpHandle); + cpAssertHard(count, "Internal Error: Buffer size is too small."); + + cpHandle *buffer = (cpHandle *)cpcalloc(1, CP_BUFFER_BYTES); + cpArrayPush(hash->allocatedBuffers, buffer); + + for(int i=0; ipooledHandles, buffer + i); + } + + cpHandle *hand = cpHandleInit((cpHandle *)cpArrayPop(hash->pooledHandles), obj); + cpHandleRetain(hand); + + return hand; +} + +//MARK: Bin Functions + +struct cpSpaceHashBin { + cpHandle *handle; + cpSpaceHashBin *next; +}; + +static inline void +recycleBin(cpSpaceHash *hash, cpSpaceHashBin *bin) +{ + bin->next = hash->pooledBins; + hash->pooledBins = bin; +} + +static inline void +clearTableCell(cpSpaceHash *hash, int idx) +{ + cpSpaceHashBin *bin = hash->table[idx]; + while(bin){ + cpSpaceHashBin *next = bin->next; + + cpHandleRelease(bin->handle, hash->pooledHandles); + recycleBin(hash, bin); + + bin = next; + } + + hash->table[idx] = NULL; +} + +static void +clearTable(cpSpaceHash *hash) +{ + for(int i=0; inumcells; i++) clearTableCell(hash, i); +} + +// Get a recycled or new bin. +static inline cpSpaceHashBin * +getEmptyBin(cpSpaceHash *hash) +{ + cpSpaceHashBin *bin = hash->pooledBins; + + if(bin){ + hash->pooledBins = bin->next; + return bin; + } else { + // Pool is exhausted, make more + int count = CP_BUFFER_BYTES/sizeof(cpSpaceHashBin); + cpAssertHard(count, "Internal Error: Buffer size is too small."); + + cpSpaceHashBin *buffer = (cpSpaceHashBin *)cpcalloc(1, CP_BUFFER_BYTES); + cpArrayPush(hash->allocatedBuffers, buffer); + + // push all but the first one, return the first instead + for(int i=1; itable); + + hash->numcells = numcells; + hash->table = (cpSpaceHashBin **)cpcalloc(numcells, sizeof(cpSpaceHashBin *)); +} + +static inline cpSpatialIndexClass *Klass(void); + +cpSpatialIndex * +cpSpaceHashInit(cpSpaceHash *hash, cpFloat celldim, int numcells, cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex) +{ + cpSpatialIndexInit((cpSpatialIndex *)hash, Klass(), bbfunc, staticIndex); + + cpSpaceHashAllocTable(hash, next_prime(numcells)); + hash->celldim = celldim; + + hash->handleSet = cpHashSetNew(0, (cpHashSetEqlFunc)handleSetEql); + + hash->pooledHandles = cpArrayNew(0); + + hash->pooledBins = NULL; + hash->allocatedBuffers = cpArrayNew(0); + + hash->stamp = 1; + + return (cpSpatialIndex *)hash; +} + +cpSpatialIndex * +cpSpaceHashNew(cpFloat celldim, int cells, cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex) +{ + return cpSpaceHashInit(cpSpaceHashAlloc(), celldim, cells, bbfunc, staticIndex); +} + +static void +cpSpaceHashDestroy(cpSpaceHash *hash) +{ + if(hash->table) clearTable(hash); + cpfree(hash->table); + + cpHashSetFree(hash->handleSet); + + cpArrayFreeEach(hash->allocatedBuffers, cpfree); + cpArrayFree(hash->allocatedBuffers); + cpArrayFree(hash->pooledHandles); +} + +//MARK: Helper Functions + +static inline cpBool +containsHandle(cpSpaceHashBin *bin, cpHandle *hand) +{ + while(bin){ + if(bin->handle == hand) return cpTrue; + bin = bin->next; + } + + return cpFalse; +} + +// The hash function itself. +static inline cpHashValue +hash_func(cpHashValue x, cpHashValue y, cpHashValue n) +{ + return (x*1640531513ul ^ y*2654435789ul) % n; +} + +// Much faster than (int)floor(f) +// Profiling showed floor() to be a sizable performance hog +static inline int +floor_int(cpFloat f) +{ + int i = (int)f; + return (f < 0.0f && f != i ? i - 1 : i); +} + +static inline void +hashHandle(cpSpaceHash *hash, cpHandle *hand, cpBB bb) +{ + // Find the dimensions in cell coordinates. + cpFloat dim = hash->celldim; + int l = floor_int(bb.l/dim); // Fix by ShiftZ + int r = floor_int(bb.r/dim); + int b = floor_int(bb.b/dim); + int t = floor_int(bb.t/dim); + + int n = hash->numcells; + for(int i=l; i<=r; i++){ + for(int j=b; j<=t; j++){ + cpHashValue idx = hash_func(i,j,n); + cpSpaceHashBin *bin = hash->table[idx]; + + // Don't add an object twice to the same cell. + if(containsHandle(bin, hand)) continue; + + cpHandleRetain(hand); + // Insert a new bin for the handle in this cell. + cpSpaceHashBin *newBin = getEmptyBin(hash); + newBin->handle = hand; + newBin->next = bin; + hash->table[idx] = newBin; + } + } +} + +//MARK: Basic Operations + +static void +cpSpaceHashInsert(cpSpaceHash *hash, void *obj, cpHashValue hashid) +{ + cpHandle *hand = (cpHandle *)cpHashSetInsert(hash->handleSet, hashid, obj, (cpHashSetTransFunc)handleSetTrans, hash); + hashHandle(hash, hand, hash->spatialIndex.bbfunc(obj)); +} + +static void +cpSpaceHashRehashObject(cpSpaceHash *hash, void *obj, cpHashValue hashid) +{ + cpHandle *hand = (cpHandle *)cpHashSetRemove(hash->handleSet, hashid, obj); + + if(hand){ + hand->obj = NULL; + cpHandleRelease(hand, hash->pooledHandles); + + cpSpaceHashInsert(hash, obj, hashid); + } +} + +static void +rehash_helper(cpHandle *hand, cpSpaceHash *hash) +{ + hashHandle(hash, hand, hash->spatialIndex.bbfunc(hand->obj)); +} + +static void +cpSpaceHashRehash(cpSpaceHash *hash) +{ + clearTable(hash); + cpHashSetEach(hash->handleSet, (cpHashSetIteratorFunc)rehash_helper, hash); +} + +static void +cpSpaceHashRemove(cpSpaceHash *hash, void *obj, cpHashValue hashid) +{ + cpHandle *hand = (cpHandle *)cpHashSetRemove(hash->handleSet, hashid, obj); + + if(hand){ + hand->obj = NULL; + cpHandleRelease(hand, hash->pooledHandles); + } +} + +typedef struct eachContext { + cpSpatialIndexIteratorFunc func; + void *data; +} eachContext; + +static void eachHelper(cpHandle *hand, eachContext *context){context->func(hand->obj, context->data);} + +static void +cpSpaceHashEach(cpSpaceHash *hash, cpSpatialIndexIteratorFunc func, void *data) +{ + eachContext context = {func, data}; + cpHashSetEach(hash->handleSet, (cpHashSetIteratorFunc)eachHelper, &context); +} + +static void +remove_orphaned_handles(cpSpaceHash *hash, cpSpaceHashBin **bin_ptr) +{ + cpSpaceHashBin *bin = *bin_ptr; + while(bin){ + cpHandle *hand = bin->handle; + cpSpaceHashBin *next = bin->next; + + if(!hand->obj){ + // orphaned handle, unlink and recycle the bin + (*bin_ptr) = bin->next; + recycleBin(hash, bin); + + cpHandleRelease(hand, hash->pooledHandles); + } else { + bin_ptr = &bin->next; + } + + bin = next; + } +} + +//MARK: Query Functions + +static inline void +query_helper(cpSpaceHash *hash, cpSpaceHashBin **bin_ptr, void *obj, cpSpatialIndexQueryFunc func, void *data) +{ + restart: + for(cpSpaceHashBin *bin = *bin_ptr; bin; bin = bin->next){ + cpHandle *hand = bin->handle; + void *other = hand->obj; + + if(hand->stamp == hash->stamp || obj == other){ + continue; + } else if(other){ + func(obj, other, 0, data); + hand->stamp = hash->stamp; + } else { + // The object for this handle has been removed + // cleanup this cell and restart the query + remove_orphaned_handles(hash, bin_ptr); + goto restart; // GCC not smart enough/able to tail call an inlined function. + } + } +} + +static void +cpSpaceHashQuery(cpSpaceHash *hash, void *obj, cpBB bb, cpSpatialIndexQueryFunc func, void *data) +{ + // Get the dimensions in cell coordinates. + cpFloat dim = hash->celldim; + int l = floor_int(bb.l/dim); // Fix by ShiftZ + int r = floor_int(bb.r/dim); + int b = floor_int(bb.b/dim); + int t = floor_int(bb.t/dim); + + int n = hash->numcells; + cpSpaceHashBin **table = hash->table; + + // Iterate over the cells and query them. + for(int i=l; i<=r; i++){ + for(int j=b; j<=t; j++){ + query_helper(hash, &table[hash_func(i,j,n)], obj, func, data); + } + } + + hash->stamp++; +} + +// Similar to struct eachPair above. +typedef struct queryRehashContext { + cpSpaceHash *hash; + cpSpatialIndexQueryFunc func; + void *data; +} queryRehashContext; + +// Hashset iterator func used with cpSpaceHashQueryRehash(). +static void +queryRehash_helper(cpHandle *hand, queryRehashContext *context) +{ + cpSpaceHash *hash = context->hash; + cpSpatialIndexQueryFunc func = context->func; + void *data = context->data; + + cpFloat dim = hash->celldim; + int n = hash->numcells; + + void *obj = hand->obj; + cpBB bb = hash->spatialIndex.bbfunc(obj); + + int l = floor_int(bb.l/dim); + int r = floor_int(bb.r/dim); + int b = floor_int(bb.b/dim); + int t = floor_int(bb.t/dim); + + cpSpaceHashBin **table = hash->table; + + for(int i=l; i<=r; i++){ + for(int j=b; j<=t; j++){ + cpHashValue idx = hash_func(i,j,n); + cpSpaceHashBin *bin = table[idx]; + + if(containsHandle(bin, hand)) continue; + + cpHandleRetain(hand); // this MUST be done first in case the object is removed in func() + query_helper(hash, &bin, obj, func, data); + + cpSpaceHashBin *newBin = getEmptyBin(hash); + newBin->handle = hand; + newBin->next = bin; + table[idx] = newBin; + } + } + + // Increment the stamp for each object hashed. + hash->stamp++; +} + +static void +cpSpaceHashReindexQuery(cpSpaceHash *hash, cpSpatialIndexQueryFunc func, void *data) +{ + clearTable(hash); + + queryRehashContext context = {hash, func, data}; + cpHashSetEach(hash->handleSet, (cpHashSetIteratorFunc)queryRehash_helper, &context); + + cpSpatialIndexCollideStatic((cpSpatialIndex *)hash, hash->spatialIndex.staticIndex, func, data); +} + +static inline cpFloat +segmentQuery_helper(cpSpaceHash *hash, cpSpaceHashBin **bin_ptr, void *obj, cpSpatialIndexSegmentQueryFunc func, void *data) +{ + cpFloat t = 1.0f; + + restart: + for(cpSpaceHashBin *bin = *bin_ptr; bin; bin = bin->next){ + cpHandle *hand = bin->handle; + void *other = hand->obj; + + // Skip over certain conditions + if(hand->stamp == hash->stamp){ + continue; + } else if(other){ + t = cpfmin(t, func(obj, other, data)); + hand->stamp = hash->stamp; + } else { + // The object for this handle has been removed + // cleanup this cell and restart the query + remove_orphaned_handles(hash, bin_ptr); + goto restart; // GCC not smart enough/able to tail call an inlined function. + } + } + + return t; +} + +// modified from http://playtechs.blogspot.com/2007/03/raytracing-on-grid.html +static void +cpSpaceHashSegmentQuery(cpSpaceHash *hash, void *obj, cpVect a, cpVect b, cpFloat t_exit, cpSpatialIndexSegmentQueryFunc func, void *data) +{ + a = cpvmult(a, 1.0f/hash->celldim); + b = cpvmult(b, 1.0f/hash->celldim); + + int cell_x = floor_int(a.x), cell_y = floor_int(a.y); + + cpFloat t = 0; + + int x_inc, y_inc; + cpFloat temp_v, temp_h; + + if (b.x > a.x){ + x_inc = 1; + temp_h = (cpffloor(a.x + 1.0f) - a.x); + } else { + x_inc = -1; + temp_h = (a.x - cpffloor(a.x)); + } + + if (b.y > a.y){ + y_inc = 1; + temp_v = (cpffloor(a.y + 1.0f) - a.y); + } else { + y_inc = -1; + temp_v = (a.y - cpffloor(a.y)); + } + + // Division by zero is *very* slow on ARM + cpFloat dx = cpfabs(b.x - a.x), dy = cpfabs(b.y - a.y); + cpFloat dt_dx = (dx ? 1.0f/dx : INFINITY), dt_dy = (dy ? 1.0f/dy : INFINITY); + + // fix NANs in horizontal directions + cpFloat next_h = (temp_h ? temp_h*dt_dx : dt_dx); + cpFloat next_v = (temp_v ? temp_v*dt_dy : dt_dy); + + int n = hash->numcells; + cpSpaceHashBin **table = hash->table; + + while(t < t_exit){ + cpHashValue idx = hash_func(cell_x, cell_y, n); + t_exit = cpfmin(t_exit, segmentQuery_helper(hash, &table[idx], obj, func, data)); + + if (next_v < next_h){ + cell_y += y_inc; + t = next_v; + next_v += dt_dy; + } else { + cell_x += x_inc; + t = next_h; + next_h += dt_dx; + } + } + + hash->stamp++; +} + +//MARK: Misc + +void +cpSpaceHashResize(cpSpaceHash *hash, cpFloat celldim, int numcells) +{ + if(hash->spatialIndex.klass != Klass()){ + cpAssertWarn(cpFalse, "Ignoring cpSpaceHashResize() call to non-cpSpaceHash spatial index."); + return; + } + + clearTable(hash); + + hash->celldim = celldim; + cpSpaceHashAllocTable(hash, next_prime(numcells)); +} + +static int +cpSpaceHashCount(cpSpaceHash *hash) +{ + return cpHashSetCount(hash->handleSet); +} + +static int +cpSpaceHashContains(cpSpaceHash *hash, void *obj, cpHashValue hashid) +{ + return cpHashSetFind(hash->handleSet, hashid, obj) != NULL; +} + +static cpSpatialIndexClass klass = { + (cpSpatialIndexDestroyImpl)cpSpaceHashDestroy, + + (cpSpatialIndexCountImpl)cpSpaceHashCount, + (cpSpatialIndexEachImpl)cpSpaceHashEach, + (cpSpatialIndexContainsImpl)cpSpaceHashContains, + + (cpSpatialIndexInsertImpl)cpSpaceHashInsert, + (cpSpatialIndexRemoveImpl)cpSpaceHashRemove, + + (cpSpatialIndexReindexImpl)cpSpaceHashRehash, + (cpSpatialIndexReindexObjectImpl)cpSpaceHashRehashObject, + (cpSpatialIndexReindexQueryImpl)cpSpaceHashReindexQuery, + + (cpSpatialIndexQueryImpl)cpSpaceHashQuery, + (cpSpatialIndexSegmentQueryImpl)cpSpaceHashSegmentQuery, +}; + +static inline cpSpatialIndexClass *Klass(){return &klass;} + +//MARK: Debug Drawing + +//#define CP_BBTREE_DEBUG_DRAW +#ifdef CP_BBTREE_DEBUG_DRAW +#include "OpenGL/gl.h" +#include "OpenGL/glu.h" +#include + +void +cpSpaceHashRenderDebug(cpSpatialIndex *index) +{ + if(index->klass != &klass){ + cpAssertWarn(cpFalse, "Ignoring cpSpaceHashRenderDebug() call to non-spatial hash spatial index."); + return; + } + + cpSpaceHash *hash = (cpSpaceHash *)index; + cpBB bb = cpBBNew(-320, -240, 320, 240); + + cpFloat dim = hash->celldim; + int n = hash->numcells; + + int l = (int)floor(bb.l/dim); + int r = (int)floor(bb.r/dim); + int b = (int)floor(bb.b/dim); + int t = (int)floor(bb.t/dim); + + for(int i=l; i<=r; i++){ + for(int j=b; j<=t; j++){ + int cell_count = 0; + + int index = hash_func(i,j,n); + for(cpSpaceHashBin *bin = hash->table[index]; bin; bin = bin->next) + cell_count++; + + GLfloat v = 1.0f - (GLfloat)cell_count/10.0f; + glColor3f(v,v,v); + glRectf(i*dim, j*dim, (i + 1)*dim, (j + 1)*dim); + } + } +} +#endif diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpSpaceQuery.c b/source/engine/thirdparty/Chipmunk2D/src/cpSpaceQuery.c new file mode 100644 index 0000000..1ce4a10 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpSpaceQuery.c @@ -0,0 +1,246 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +//MARK: Nearest Point Query Functions + +struct PointQueryContext { + cpVect point; + cpFloat maxDistance; + cpShapeFilter filter; + cpSpacePointQueryFunc func; +}; + +static cpCollisionID +NearestPointQuery(struct PointQueryContext *context, cpShape *shape, cpCollisionID id, void *data) +{ + if( + !cpShapeFilterReject(shape->filter, context->filter) + ){ + cpPointQueryInfo info; + cpShapePointQuery(shape, context->point, &info); + + if(info.shape && info.distance < context->maxDistance) context->func(shape, info.point, info.distance, info.gradient, data); + } + + return id; +} + +void +cpSpacePointQuery(cpSpace *space, cpVect point, cpFloat maxDistance, cpShapeFilter filter, cpSpacePointQueryFunc func, void *data) +{ + struct PointQueryContext context = {point, maxDistance, filter, func}; + cpBB bb = cpBBNewForCircle(point, cpfmax(maxDistance, 0.0f)); + + cpSpaceLock(space); { + cpSpatialIndexQuery(space->dynamicShapes, &context, bb, (cpSpatialIndexQueryFunc)NearestPointQuery, data); + cpSpatialIndexQuery(space->staticShapes, &context, bb, (cpSpatialIndexQueryFunc)NearestPointQuery, data); + } cpSpaceUnlock(space, cpTrue); +} + +static cpCollisionID +NearestPointQueryNearest(struct PointQueryContext *context, cpShape *shape, cpCollisionID id, cpPointQueryInfo *out) +{ + if( + !cpShapeFilterReject(shape->filter, context->filter) && !shape->sensor + ){ + cpPointQueryInfo info; + cpShapePointQuery(shape, context->point, &info); + + if(info.distance < out->distance) (*out) = info; + } + + return id; +} + +cpShape * +cpSpacePointQueryNearest(cpSpace *space, cpVect point, cpFloat maxDistance, cpShapeFilter filter, cpPointQueryInfo *out) +{ + cpPointQueryInfo info = {NULL, cpvzero, maxDistance, cpvzero}; + if(out){ + (*out) = info; + } else { + out = &info; + } + + struct PointQueryContext context = { + point, maxDistance, + filter, + NULL + }; + + cpBB bb = cpBBNewForCircle(point, cpfmax(maxDistance, 0.0f)); + cpSpatialIndexQuery(space->dynamicShapes, &context, bb, (cpSpatialIndexQueryFunc)NearestPointQueryNearest, out); + cpSpatialIndexQuery(space->staticShapes, &context, bb, (cpSpatialIndexQueryFunc)NearestPointQueryNearest, out); + + return (cpShape *)out->shape; +} + + +//MARK: Segment Query Functions + +struct SegmentQueryContext { + cpVect start, end; + cpFloat radius; + cpShapeFilter filter; + cpSpaceSegmentQueryFunc func; +}; + +static cpFloat +SegmentQuery(struct SegmentQueryContext *context, cpShape *shape, void *data) +{ + cpSegmentQueryInfo info; + + if( + !cpShapeFilterReject(shape->filter, context->filter) && + cpShapeSegmentQuery(shape, context->start, context->end, context->radius, &info) + ){ + context->func(shape, info.point, info.normal, info.alpha, data); + } + + return 1.0f; +} + +void +cpSpaceSegmentQuery(cpSpace *space, cpVect start, cpVect end, cpFloat radius, cpShapeFilter filter, cpSpaceSegmentQueryFunc func, void *data) +{ + struct SegmentQueryContext context = { + start, end, + radius, + filter, + func, + }; + + cpSpaceLock(space); { + cpSpatialIndexSegmentQuery(space->staticShapes, &context, start, end, 1.0f, (cpSpatialIndexSegmentQueryFunc)SegmentQuery, data); + cpSpatialIndexSegmentQuery(space->dynamicShapes, &context, start, end, 1.0f, (cpSpatialIndexSegmentQueryFunc)SegmentQuery, data); + } cpSpaceUnlock(space, cpTrue); +} + +static cpFloat +SegmentQueryFirst(struct SegmentQueryContext *context, cpShape *shape, cpSegmentQueryInfo *out) +{ + cpSegmentQueryInfo info; + + if( + !cpShapeFilterReject(shape->filter, context->filter) && !shape->sensor && + cpShapeSegmentQuery(shape, context->start, context->end, context->radius, &info) && + info.alpha < out->alpha + ){ + (*out) = info; + } + + return out->alpha; +} + +cpShape * +cpSpaceSegmentQueryFirst(cpSpace *space, cpVect start, cpVect end, cpFloat radius, cpShapeFilter filter, cpSegmentQueryInfo *out) +{ + cpSegmentQueryInfo info = {NULL, end, cpvzero, 1.0f}; + if(out){ + (*out) = info; + } else { + out = &info; + } + + struct SegmentQueryContext context = { + start, end, + radius, + filter, + NULL + }; + + cpSpatialIndexSegmentQuery(space->staticShapes, &context, start, end, 1.0f, (cpSpatialIndexSegmentQueryFunc)SegmentQueryFirst, out); + cpSpatialIndexSegmentQuery(space->dynamicShapes, &context, start, end, out->alpha, (cpSpatialIndexSegmentQueryFunc)SegmentQueryFirst, out); + + return (cpShape *)out->shape; +} + +//MARK: BB Query Functions + +struct BBQueryContext { + cpBB bb; + cpShapeFilter filter; + cpSpaceBBQueryFunc func; +}; + +static cpCollisionID +BBQuery(struct BBQueryContext *context, cpShape *shape, cpCollisionID id, void *data) +{ + if( + !cpShapeFilterReject(shape->filter, context->filter) && + cpBBIntersects(context->bb, shape->bb) + ){ + context->func(shape, data); + } + + return id; +} + +void +cpSpaceBBQuery(cpSpace *space, cpBB bb, cpShapeFilter filter, cpSpaceBBQueryFunc func, void *data) +{ + struct BBQueryContext context = {bb, filter, func}; + + cpSpaceLock(space); { + cpSpatialIndexQuery(space->dynamicShapes, &context, bb, (cpSpatialIndexQueryFunc)BBQuery, data); + cpSpatialIndexQuery(space->staticShapes, &context, bb, (cpSpatialIndexQueryFunc)BBQuery, data); + } cpSpaceUnlock(space, cpTrue); +} + +//MARK: Shape Query Functions + +struct ShapeQueryContext { + cpSpaceShapeQueryFunc func; + void *data; + cpBool anyCollision; +}; + +// Callback from the spatial hash. +static cpCollisionID +ShapeQuery(cpShape *a, cpShape *b, cpCollisionID id, struct ShapeQueryContext *context) +{ + if(cpShapeFilterReject(a->filter, b->filter) || a == b) return id; + + cpContactPointSet set = cpShapesCollide(a, b); + if(set.count){ + if(context->func) context->func(b, &set, context->data); + context->anyCollision = !(a->sensor || b->sensor); + } + + return id; +} + +cpBool +cpSpaceShapeQuery(cpSpace *space, cpShape *shape, cpSpaceShapeQueryFunc func, void *data) +{ + cpBody *body = shape->body; + cpBB bb = (body ? cpShapeUpdate(shape, body->transform) : shape->bb); + struct ShapeQueryContext context = {func, data, cpFalse}; + + cpSpaceLock(space); { + cpSpatialIndexQuery(space->dynamicShapes, shape, bb, (cpSpatialIndexQueryFunc)ShapeQuery, &context); + cpSpatialIndexQuery(space->staticShapes, shape, bb, (cpSpatialIndexQueryFunc)ShapeQuery, &context); + } cpSpaceUnlock(space, cpTrue); + + return context.anyCollision; +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpSpaceStep.c b/source/engine/thirdparty/Chipmunk2D/src/cpSpaceStep.c new file mode 100644 index 0000000..85cbb3d --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpSpaceStep.c @@ -0,0 +1,445 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +//MARK: Post Step Callback Functions + +cpPostStepCallback * +cpSpaceGetPostStepCallback(cpSpace *space, void *key) +{ + cpArray *arr = space->postStepCallbacks; + for(int i=0; inum; i++){ + cpPostStepCallback *callback = (cpPostStepCallback *)arr->arr[i]; + if(callback && callback->key == key) return callback; + } + + return NULL; +} + +static void PostStepDoNothing(cpSpace *space, void *obj, void *data){} + +cpBool +cpSpaceAddPostStepCallback(cpSpace *space, cpPostStepFunc func, void *key, void *data) +{ + cpAssertWarn(space->locked, + "Adding a post-step callback when the space is not locked is unnecessary. " + "Post-step callbacks will not called until the end of the next call to cpSpaceStep() or the next query."); + + if(!cpSpaceGetPostStepCallback(space, key)){ + cpPostStepCallback *callback = (cpPostStepCallback *)cpcalloc(1, sizeof(cpPostStepCallback)); + callback->func = (func ? func : PostStepDoNothing); + callback->key = key; + callback->data = data; + + cpArrayPush(space->postStepCallbacks, callback); + return cpTrue; + } else { + return cpFalse; + } +} + +//MARK: Locking Functions + +void +cpSpaceLock(cpSpace *space) +{ + space->locked++; +} + +void +cpSpaceUnlock(cpSpace *space, cpBool runPostStep) +{ + space->locked--; + cpAssertHard(space->locked >= 0, "Internal Error: Space lock underflow."); + + if(space->locked == 0){ + cpArray *waking = space->rousedBodies; + + for(int i=0, count=waking->num; iarr[i]); + waking->arr[i] = NULL; + } + + waking->num = 0; + + if(space->locked == 0 && runPostStep && !space->skipPostStep){ + space->skipPostStep = cpTrue; + + cpArray *arr = space->postStepCallbacks; + for(int i=0; inum; i++){ + cpPostStepCallback *callback = (cpPostStepCallback *)arr->arr[i]; + cpPostStepFunc func = callback->func; + + // Mark the func as NULL in case calling it calls cpSpaceRunPostStepCallbacks() again. + // TODO: need more tests around this case I think. + callback->func = NULL; + if(func) func(space, callback->key, callback->data); + + arr->arr[i] = NULL; + cpfree(callback); + } + + arr->num = 0; + space->skipPostStep = cpFalse; + } + } +} + +//MARK: Contact Buffer Functions + +struct cpContactBufferHeader { + cpTimestamp stamp; + cpContactBufferHeader *next; + unsigned int numContacts; +}; + +#define CP_CONTACTS_BUFFER_SIZE ((CP_BUFFER_BYTES - sizeof(cpContactBufferHeader))/sizeof(struct cpContact)) +typedef struct cpContactBuffer { + cpContactBufferHeader header; + struct cpContact contacts[CP_CONTACTS_BUFFER_SIZE]; +} cpContactBuffer; + +static cpContactBufferHeader * +cpSpaceAllocContactBuffer(cpSpace *space) +{ + cpContactBuffer *buffer = (cpContactBuffer *)cpcalloc(1, sizeof(cpContactBuffer)); + cpArrayPush(space->allocatedBuffers, buffer); + return (cpContactBufferHeader *)buffer; +} + +static cpContactBufferHeader * +cpContactBufferHeaderInit(cpContactBufferHeader *header, cpTimestamp stamp, cpContactBufferHeader *splice) +{ + header->stamp = stamp; + header->next = (splice ? splice->next : header); + header->numContacts = 0; + + return header; +} + +void +cpSpacePushFreshContactBuffer(cpSpace *space) +{ + cpTimestamp stamp = space->stamp; + + cpContactBufferHeader *head = space->contactBuffersHead; + + if(!head){ + // No buffers have been allocated, make one + space->contactBuffersHead = cpContactBufferHeaderInit(cpSpaceAllocContactBuffer(space), stamp, NULL); + } else if(stamp - head->next->stamp > space->collisionPersistence){ + // The tail buffer is available, rotate the ring + cpContactBufferHeader *tail = head->next; + space->contactBuffersHead = cpContactBufferHeaderInit(tail, stamp, tail); + } else { + // Allocate a new buffer and push it into the ring + cpContactBufferHeader *buffer = cpContactBufferHeaderInit(cpSpaceAllocContactBuffer(space), stamp, head); + space->contactBuffersHead = head->next = buffer; + } +} + + +struct cpContact * +cpContactBufferGetArray(cpSpace *space) +{ + if(space->contactBuffersHead->numContacts + CP_MAX_CONTACTS_PER_ARBITER > CP_CONTACTS_BUFFER_SIZE){ + // contact buffer could overflow on the next collision, push a fresh one. + cpSpacePushFreshContactBuffer(space); + } + + cpContactBufferHeader *head = space->contactBuffersHead; + return ((cpContactBuffer *)head)->contacts + head->numContacts; +} + +void +cpSpacePushContacts(cpSpace *space, int count) +{ + cpAssertHard(count <= CP_MAX_CONTACTS_PER_ARBITER, "Internal Error: Contact buffer overflow!"); + space->contactBuffersHead->numContacts += count; +} + +static void +cpSpacePopContacts(cpSpace *space, int count){ + space->contactBuffersHead->numContacts -= count; +} + +//MARK: Collision Detection Functions + +static void * +cpSpaceArbiterSetTrans(cpShape **shapes, cpSpace *space) +{ + if(space->pooledArbiters->num == 0){ + // arbiter pool is exhausted, make more + int count = CP_BUFFER_BYTES/sizeof(cpArbiter); + cpAssertHard(count, "Internal Error: Buffer size too small."); + + cpArbiter *buffer = (cpArbiter *)cpcalloc(1, CP_BUFFER_BYTES); + cpArrayPush(space->allocatedBuffers, buffer); + + for(int i=0; ipooledArbiters, buffer + i); + } + + return cpArbiterInit((cpArbiter *)cpArrayPop(space->pooledArbiters), shapes[0], shapes[1]); +} + +static inline cpBool +QueryRejectConstraint(cpBody *a, cpBody *b) +{ + CP_BODY_FOREACH_CONSTRAINT(a, constraint){ + if( + !constraint->collideBodies && ( + (constraint->a == a && constraint->b == b) || + (constraint->a == b && constraint->b == a) + ) + ) return cpTrue; + } + + return cpFalse; +} + +static inline cpBool +QueryReject(cpShape *a, cpShape *b) +{ + return ( + // BBoxes must overlap + !cpBBIntersects(a->bb, b->bb) + // Don't collide shapes attached to the same body. + || a->body == b->body + // Don't collide shapes that are filtered. + || cpShapeFilterReject(a->filter, b->filter) + // Don't collide bodies if they have a constraint with collideBodies == cpFalse. + || QueryRejectConstraint(a->body, b->body) + ); +} + +// Callback from the spatial hash. +cpCollisionID +cpSpaceCollideShapes(cpShape *a, cpShape *b, cpCollisionID id, cpSpace *space) +{ + // Reject any of the simple cases + if(QueryReject(a,b)) return id; + + // Narrow-phase collision detection. + struct cpCollisionInfo info = cpCollide(a, b, id, cpContactBufferGetArray(space)); + + if(info.count == 0) return info.id; // Shapes are not colliding. + cpSpacePushContacts(space, info.count); + + // Get an arbiter from space->arbiterSet for the two shapes. + // This is where the persistant contact magic comes from. + const cpShape *shape_pair[] = {info.a, info.b}; + cpHashValue arbHashID = CP_HASH_PAIR((cpHashValue)info.a, (cpHashValue)info.b); + cpArbiter *arb = (cpArbiter *)cpHashSetInsert(space->cachedArbiters, arbHashID, shape_pair, (cpHashSetTransFunc)cpSpaceArbiterSetTrans, space); + cpArbiterUpdate(arb, &info, space); + + cpCollisionHandler *handler = arb->handler; + + // Call the begin function first if it's the first step + if(arb->state == CP_ARBITER_STATE_FIRST_COLLISION && !handler->beginFunc(arb, space, handler->userData)){ + cpArbiterIgnore(arb); // permanently ignore the collision until separation + } + + if( + // Ignore the arbiter if it has been flagged + (arb->state != CP_ARBITER_STATE_IGNORE) && + // Call preSolve + handler->preSolveFunc(arb, space, handler->userData) && + // Check (again) in case the pre-solve() callback called cpArbiterIgnored(). + arb->state != CP_ARBITER_STATE_IGNORE && + // Process, but don't add collisions for sensors. + !(a->sensor || b->sensor) && + // Don't process collisions between two infinite mass bodies. + // This includes collisions between two kinematic bodies, or a kinematic body and a static body. + !(a->body->m == INFINITY && b->body->m == INFINITY) + ){ + cpArrayPush(space->arbiters, arb); + } else { + cpSpacePopContacts(space, info.count); + + arb->contacts = NULL; + arb->count = 0; + + // Normally arbiters are set as used after calling the post-solve callback. + // However, post-solve() callbacks are not called for sensors or arbiters rejected from pre-solve. + if(arb->state != CP_ARBITER_STATE_IGNORE) arb->state = CP_ARBITER_STATE_NORMAL; + } + + // Time stamp the arbiter so we know it was used recently. + arb->stamp = space->stamp; + return info.id; +} + +// Hashset filter func to throw away old arbiters. +cpBool +cpSpaceArbiterSetFilter(cpArbiter *arb, cpSpace *space) +{ + cpTimestamp ticks = space->stamp - arb->stamp; + + cpBody *a = arb->body_a, *b = arb->body_b; + + // TODO: should make an arbiter state for this so it doesn't require filtering arbiters for dangling body pointers on body removal. + // Preserve arbiters on sensors and rejected arbiters for sleeping objects. + // This prevents errant separate callbacks from happenening. + if( + (cpBodyGetType(a) == CP_BODY_TYPE_STATIC || cpBodyIsSleeping(a)) && + (cpBodyGetType(b) == CP_BODY_TYPE_STATIC || cpBodyIsSleeping(b)) + ){ + return cpTrue; + } + + // Arbiter was used last frame, but not this one + if(ticks >= 1 && arb->state != CP_ARBITER_STATE_CACHED){ + arb->state = CP_ARBITER_STATE_CACHED; + cpCollisionHandler *handler = arb->handler; + handler->separateFunc(arb, space, handler->userData); + } + + if(ticks >= space->collisionPersistence){ + arb->contacts = NULL; + arb->count = 0; + + cpArrayPush(space->pooledArbiters, arb); + return cpFalse; + } + + return cpTrue; +} + +//MARK: All Important cpSpaceStep() Function + + void +cpShapeUpdateFunc(cpShape *shape, void *unused) +{ + cpShapeCacheBB(shape); +} + +void +cpSpaceStep(cpSpace *space, cpFloat dt) +{ + // don't step if the timestep is 0! + if(dt == 0.0f) return; + + space->stamp++; + + cpFloat prev_dt = space->curr_dt; + space->curr_dt = dt; + + cpArray *bodies = space->dynamicBodies; + cpArray *constraints = space->constraints; + cpArray *arbiters = space->arbiters; + + // Reset and empty the arbiter lists. + for(int i=0; inum; i++){ + cpArbiter *arb = (cpArbiter *)arbiters->arr[i]; + arb->state = CP_ARBITER_STATE_NORMAL; + + // If both bodies are awake, unthread the arbiter from the contact graph. + if(!cpBodyIsSleeping(arb->body_a) && !cpBodyIsSleeping(arb->body_b)){ + cpArbiterUnthread(arb); + } + } + arbiters->num = 0; + + cpSpaceLock(space); { + // Integrate positions + for(int i=0; inum; i++){ + cpBody *body = (cpBody *)bodies->arr[i]; + body->position_func(body, dt); + } + + // Find colliding pairs. + cpSpacePushFreshContactBuffer(space); + cpSpatialIndexEach(space->dynamicShapes, (cpSpatialIndexIteratorFunc)cpShapeUpdateFunc, NULL); + cpSpatialIndexReindexQuery(space->dynamicShapes, (cpSpatialIndexQueryFunc)cpSpaceCollideShapes, space); + } cpSpaceUnlock(space, cpFalse); + + // Rebuild the contact graph (and detect sleeping components if sleeping is enabled) + cpSpaceProcessComponents(space, dt); + + cpSpaceLock(space); { + // Clear out old cached arbiters and call separate callbacks + cpHashSetFilter(space->cachedArbiters, (cpHashSetFilterFunc)cpSpaceArbiterSetFilter, space); + + // Prestep the arbiters and constraints. + cpFloat slop = space->collisionSlop; + cpFloat biasCoef = 1.0f - cpfpow(space->collisionBias, dt); + for(int i=0; inum; i++){ + cpArbiterPreStep((cpArbiter *)arbiters->arr[i], dt, slop, biasCoef); + } + + for(int i=0; inum; i++){ + cpConstraint *constraint = (cpConstraint *)constraints->arr[i]; + + cpConstraintPreSolveFunc preSolve = constraint->preSolve; + if(preSolve) preSolve(constraint, space); + + constraint->klass->preStep(constraint, dt); + } + + // Integrate velocities. + cpFloat damping = cpfpow(space->damping, dt); + cpVect gravity = space->gravity; + for(int i=0; inum; i++){ + cpBody *body = (cpBody *)bodies->arr[i]; + body->velocity_func(body, gravity, damping, dt); + } + + // Apply cached impulses + cpFloat dt_coef = (prev_dt == 0.0f ? 0.0f : dt/prev_dt); + for(int i=0; inum; i++){ + cpArbiterApplyCachedImpulse((cpArbiter *)arbiters->arr[i], dt_coef); + } + + for(int i=0; inum; i++){ + cpConstraint *constraint = (cpConstraint *)constraints->arr[i]; + constraint->klass->applyCachedImpulse(constraint, dt_coef); + } + + // Run the impulse solver. + for(int i=0; iiterations; i++){ + for(int j=0; jnum; j++){ + cpArbiterApplyImpulse((cpArbiter *)arbiters->arr[j]); + } + + for(int j=0; jnum; j++){ + cpConstraint *constraint = (cpConstraint *)constraints->arr[j]; + constraint->klass->applyImpulse(constraint, dt); + } + } + + // Run the constraint post-solve callbacks + for(int i=0; inum; i++){ + cpConstraint *constraint = (cpConstraint *)constraints->arr[i]; + + cpConstraintPostSolveFunc postSolve = constraint->postSolve; + if(postSolve) postSolve(constraint, space); + } + + // run the post-solve callbacks + for(int i=0; inum; i++){ + cpArbiter *arb = (cpArbiter *) arbiters->arr[i]; + + cpCollisionHandler *handler = arb->handler; + handler->postSolveFunc(arb, space, handler->userData); + } + } cpSpaceUnlock(space, cpTrue); +} diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpSpatialIndex.c b/source/engine/thirdparty/Chipmunk2D/src/cpSpatialIndex.c new file mode 100644 index 0000000..3fb7cb5 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpSpatialIndex.c @@ -0,0 +1,69 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +void +cpSpatialIndexFree(cpSpatialIndex *index) +{ + if(index){ + cpSpatialIndexDestroy(index); + cpfree(index); + } +} + +cpSpatialIndex * +cpSpatialIndexInit(cpSpatialIndex *index, cpSpatialIndexClass *klass, cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex) +{ + index->klass = klass; + index->bbfunc = bbfunc; + index->staticIndex = staticIndex; + + if(staticIndex){ + cpAssertHard(!staticIndex->dynamicIndex, "This static index is already associated with a dynamic index."); + staticIndex->dynamicIndex = index; + } + + return index; +} + +typedef struct dynamicToStaticContext { + cpSpatialIndexBBFunc bbfunc; + cpSpatialIndex *staticIndex; + cpSpatialIndexQueryFunc queryFunc; + void *data; +} dynamicToStaticContext; + +static void +dynamicToStaticIter(void *obj, dynamicToStaticContext *context) +{ + cpSpatialIndexQuery(context->staticIndex, obj, context->bbfunc(obj), context->queryFunc, context->data); +} + +void +cpSpatialIndexCollideStatic(cpSpatialIndex *dynamicIndex, cpSpatialIndex *staticIndex, cpSpatialIndexQueryFunc func, void *data) +{ + if(staticIndex && cpSpatialIndexCount(staticIndex) > 0){ + dynamicToStaticContext context = {dynamicIndex->bbfunc, staticIndex, func, data}; + cpSpatialIndexEach(dynamicIndex, (cpSpatialIndexIteratorFunc)dynamicToStaticIter, &context); + } +} + diff --git a/source/engine/thirdparty/Chipmunk2D/src/cpSweep1D.c b/source/engine/thirdparty/Chipmunk2D/src/cpSweep1D.c new file mode 100644 index 0000000..94c4e22 --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/cpSweep1D.c @@ -0,0 +1,254 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +#include "chipmunk/chipmunk_private.h" + +static inline cpSpatialIndexClass *Klass(void); + +//MARK: Basic Structures + +typedef struct Bounds { + cpFloat min, max; +} Bounds; + +typedef struct TableCell { + void *obj; + Bounds bounds; +} TableCell; + +struct cpSweep1D +{ + cpSpatialIndex spatialIndex; + + int num; + int max; + TableCell *table; +}; + +static inline cpBool +BoundsOverlap(Bounds a, Bounds b) +{ + return (a.min <= b.max && b.min <= a.max); +} + +static inline Bounds +BBToBounds(cpSweep1D *sweep, cpBB bb) +{ + Bounds bounds = {bb.l, bb.r}; + return bounds; +} + +static inline TableCell +MakeTableCell(cpSweep1D *sweep, void *obj) +{ + TableCell cell = {obj, BBToBounds(sweep, sweep->spatialIndex.bbfunc(obj))}; + return cell; +} + +//MARK: Memory Management Functions + +cpSweep1D * +cpSweep1DAlloc(void) +{ + return (cpSweep1D *)cpcalloc(1, sizeof(cpSweep1D)); +} + +static void +ResizeTable(cpSweep1D *sweep, int size) +{ + sweep->max = size; + sweep->table = (TableCell *)cprealloc(sweep->table, size*sizeof(TableCell)); +} + +cpSpatialIndex * +cpSweep1DInit(cpSweep1D *sweep, cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex) +{ + cpSpatialIndexInit((cpSpatialIndex *)sweep, Klass(), bbfunc, staticIndex); + + sweep->num = 0; + ResizeTable(sweep, 32); + + return (cpSpatialIndex *)sweep; +} + +cpSpatialIndex * +cpSweep1DNew(cpSpatialIndexBBFunc bbfunc, cpSpatialIndex *staticIndex) +{ + return cpSweep1DInit(cpSweep1DAlloc(), bbfunc, staticIndex); +} + +static void +cpSweep1DDestroy(cpSweep1D *sweep) +{ + cpfree(sweep->table); + sweep->table = NULL; +} + +//MARK: Misc + +static int +cpSweep1DCount(cpSweep1D *sweep) +{ + return sweep->num; +} + +static void +cpSweep1DEach(cpSweep1D *sweep, cpSpatialIndexIteratorFunc func, void *data) +{ + TableCell *table = sweep->table; + for(int i=0, count=sweep->num; itable; + for(int i=0, count=sweep->num; inum == sweep->max) ResizeTable(sweep, sweep->max*2); + + sweep->table[sweep->num] = MakeTableCell(sweep, obj); + sweep->num++; +} + +static void +cpSweep1DRemove(cpSweep1D *sweep, void *obj, cpHashValue hashid) +{ + TableCell *table = sweep->table; + for(int i=0, count=sweep->num; inum; + + table[i] = table[num]; + table[num].obj = NULL; + + return; + } + } +} + +//MARK: Reindexing Functions + +static void +cpSweep1DReindexObject(cpSweep1D *sweep, void *obj, cpHashValue hashid) +{ + // Nothing to do here +} + +static void +cpSweep1DReindex(cpSweep1D *sweep) +{ + // Nothing to do here + // Could perform a sort, but queries are not accelerated anyway. +} + +//MARK: Query Functions + +static void +cpSweep1DQuery(cpSweep1D *sweep, void *obj, cpBB bb, cpSpatialIndexQueryFunc func, void *data) +{ + // Implementing binary search here would allow you to find an upper limit + // but not a lower limit. Probably not worth the hassle. + + Bounds bounds = BBToBounds(sweep, bb); + + TableCell *table = sweep->table; + for(int i=0, count=sweep->num; itable; + for(int i=0, count=sweep->num; ibounds.min < b->bounds.min ? -1 : (a->bounds.min > b->bounds.min ? 1 : 0)); +} + +static void +cpSweep1DReindexQuery(cpSweep1D *sweep, cpSpatialIndexQueryFunc func, void *data) +{ + TableCell *table = sweep->table; + int count = sweep->num; + + // Update bounds and sort + for(int i=0; ispatialIndex.staticIndex, func, data); +} + +static cpSpatialIndexClass klass = { + (cpSpatialIndexDestroyImpl)cpSweep1DDestroy, + + (cpSpatialIndexCountImpl)cpSweep1DCount, + (cpSpatialIndexEachImpl)cpSweep1DEach, + (cpSpatialIndexContainsImpl)cpSweep1DContains, + + (cpSpatialIndexInsertImpl)cpSweep1DInsert, + (cpSpatialIndexRemoveImpl)cpSweep1DRemove, + + (cpSpatialIndexReindexImpl)cpSweep1DReindex, + (cpSpatialIndexReindexObjectImpl)cpSweep1DReindexObject, + (cpSpatialIndexReindexQueryImpl)cpSweep1DReindexQuery, + + (cpSpatialIndexQueryImpl)cpSweep1DQuery, + (cpSpatialIndexSegmentQueryImpl)cpSweep1DSegmentQuery, +}; + +static inline cpSpatialIndexClass *Klass(){return &klass;} + diff --git a/source/engine/thirdparty/Chipmunk2D/src/prime.h b/source/engine/thirdparty/Chipmunk2D/src/prime.h new file mode 100644 index 0000000..d470c2c --- /dev/null +++ b/source/engine/thirdparty/Chipmunk2D/src/prime.h @@ -0,0 +1,68 @@ +/* Copyright (c) 2013 Scott Lembcke and Howling Moon Software + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ + +// Used for resizing hash tables. +// Values approximately double. +// http://planetmath.org/encyclopedia/GoodHashTablePrimes.html +static int primes[] = { + 5, + 13, + 23, + 47, + 97, + 193, + 389, + 769, + 1543, + 3079, + 6151, + 12289, + 24593, + 49157, + 98317, + 196613, + 393241, + 786433, + 1572869, + 3145739, + 6291469, + 12582917, + 25165843, + 50331653, + 100663319, + 201326611, + 402653189, + 805306457, + 1610612741, + 0, +}; + +static inline int +next_prime(int n) +{ + int i = 0; + while(n > primes[i]){ + i++; + cpAssertHard(primes[i], "Tried to resize a hash table to a size greater than 1610612741 O_o"); // realistically this should never happen + } + + return primes[i]; +} diff --git a/source/engine/thirdparty/bitmap-outliner/LICENSE b/source/engine/thirdparty/bitmap-outliner/LICENSE new file mode 100644 index 0000000..b6b1990 --- /dev/null +++ b/source/engine/thirdparty/bitmap-outliner/LICENSE @@ -0,0 +1,20 @@ +The MIT License (MIT) + +Copyright (c) 2017 Simon Schoenenberger + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS +FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR +COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER +IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/source/engine/thirdparty/bitmap-outliner/README.md b/source/engine/thirdparty/bitmap-outliner/README.md new file mode 100644 index 0000000..622457d --- /dev/null +++ b/source/engine/thirdparty/bitmap-outliner/README.md @@ -0,0 +1,123 @@ +# Bitmap Outliner + +This algorithm converts a bitmap image to vector paths enclosing the pixel groups. + +![Conversion Diagram](assets/conversion-diagram.svg) + +*The outlined paths on the right side are slightly shifted to show their way around the pixels; they will, of course, be aligned with the pixel borders.* + +## SVG Paths + +Given the following bitmap from the above image: + +```c +0, 1, 1, 1, 0, 0, +1, 0, 1, 0, 0, 1, +1, 1, 0, 0, 1, 1, +1, 0, 0, 1, 0, 1, +0, 0, 1, 0, 1, 1, +1, 0, 1, 1, 1, 0, +``` + +The generated SVG path will look like this (line breaks are added to separate the path loops): + +```xml + + + +``` + +## C Example + +```c +#include +#include "bitmap-outliner.h" + +// the bitmap size +int const width = 6; +int const height = 6; + +// the bitmap data +uint8_t const data[] = { + 0, 1, 1, 1, 0, 0, + 1, 0, 1, 0, 0, 1, + 1, 1, 0, 0, 1, 1, + 1, 0, 0, 1, 0, 1, + 0, 0, 1, 0, 1, 1, + 1, 0, 1, 1, 1, 0, +}; + +int main() { + // allocate outliner + bmol_outliner* outliner = bmol_alloc(width, height, data); + + // find paths in bitmap + bmol_find_paths(outliner, NULL); + + // calculate SVG path length (needs some performance). + // for numerous calls to `bmol_svg_path`, + // better use a large enough buffer directly. + size_t path_len = bmol_svg_path_len(outliner); + + // ok for small bitmaps; be aware to not use large buffers on the stack! + char path[path_len]; + + // write SVG path to `path` + bmol_svg_path(outliner, path, path_len); + + // output SVG + printf( + "\n" + " \n" + "\n", width, height, path); + + // free outliner + bmol_free(outliner); + + return 0; +} +``` + +### Run + +Execute the following command to run `main.c`: + +```sh +$ sh main.c +``` + +## Javascript Example + +```js +import 'src/bitmap-outliner'; + +// the bitmap size +const width = 6; +const height = 6; + +// data can be any indexable array +const data = new Uint8Array([ + 0, 1, 1, 1, 0, 0, + 1, 0, 1, 0, 0, 1, + 1, 1, 0, 0, 1, 1, + 1, 0, 0, 1, 0, 1, + 0, 0, 1, 0, 1, 1, + 1, 0, 1, 1, 1, 0, +]); + +// create outliner +let outliner = new BitmapOutliner(width, height, data); + +// get SVG path; implicitly calls `outliner.findPaths()` +let path = outliner.svgPath(); + +// output SVG +console.log( +` + +`); +``` \ No newline at end of file diff --git a/source/engine/thirdparty/bitmap-outliner/bitmap-outliner-print.c b/source/engine/thirdparty/bitmap-outliner/bitmap-outliner-print.c new file mode 100644 index 0000000..2078598 --- /dev/null +++ b/source/engine/thirdparty/bitmap-outliner/bitmap-outliner-print.c @@ -0,0 +1,77 @@ +#include +#include "bitmap-outliner.h" + +/** + * Terminal colors. + */ +enum { + COLOR_RESET = 0, + COLOR_RED, + COLOR_GREEN, + COLOR_YELLOW, +}; + +/** + * Terminal color escape sequences. + */ +static char const* const colors[] = { + [COLOR_RESET] = "\033[0m", + [COLOR_RED] = "\033[31m", + [COLOR_GREEN] = "\033[32m", + [COLOR_YELLOW] = "\033[33m", +}; + +/** + * Print arrow grid. + * + * @param width Width of bitmap. + * @param height Height of bitmap. + * @param data The bitmap to print. + * @param grid The arrow grid to print. + */ +static void print_grid(int width, int height, uint8_t const data[height][width], bmol_arrow const grid[height * 2 + 3][width + 3]) { + static char const* arrows[] = { + [BMOL_ARR_NONE] = "∙", + [BMOL_ARR_RIGHT] = "→", + [BMOL_ARR_LEFT] = "←", + [BMOL_ARR_DOWN] = "↓", + [BMOL_ARR_UP] = "↑", + }; + + int gridWidth = width + 3; + int gridHeight = height * 2 + 3; + + for (int y = 0; y < gridHeight; y++) { + if (y % 2 != 0) { + printf(" "); + } + + for (int x = 0; x < gridWidth - (y % 2 != 0); x++) { + bmol_arrow a = grid[y][x]; + int type = a.type; + char const* color = ""; + + if (type) { + color = colors[a.inner ? COLOR_RED : COLOR_GREEN]; + } + + printf("%s%s%s", color, arrows[(int)type], colors[COLOR_RESET]); + + if (x > 0 && y >= 2 && x < gridWidth - 2 && y < gridHeight - 2 && (y % 2) == 0) { + printf(" %c ", data[(y - 2) / 2][x - 1] ? '#' : ' '); + } + else { + printf(" "); + } + } + + printf("\n"); + } +} + +void bmol_print_grid(bmol_outliner const* outliner) { + int width = outliner->width; + int height = outliner->height; + + print_grid(width, height, (uint8_t const (*)[width])outliner->data, (bmol_arrow (*)[width])outliner->arrow_grid); +} diff --git a/source/engine/thirdparty/bitmap-outliner/bitmap-outliner-print.h b/source/engine/thirdparty/bitmap-outliner/bitmap-outliner-print.h new file mode 100644 index 0000000..a8cf0d9 --- /dev/null +++ b/source/engine/thirdparty/bitmap-outliner/bitmap-outliner-print.h @@ -0,0 +1,10 @@ +#pragma once + +#include "bitmap-outliner.h" + +/** + * Print arrow grid + * + * @param The outliner object. + */ +extern void bmol_print_grid(bmol_outliner const* outliner); diff --git a/source/engine/thirdparty/bitmap-outliner/bitmap-outliner.c b/source/engine/thirdparty/bitmap-outliner/bitmap-outliner.c new file mode 100644 index 0000000..c8703c9 --- /dev/null +++ b/source/engine/thirdparty/bitmap-outliner/bitmap-outliner.c @@ -0,0 +1,628 @@ +#include +#include +#include +#include +#include +#include "bitmap-outliner.h" + +#define MIN_SEGMENTS_COUNT 64 + +/** + * Information about how to proceed to next arrow. + */ +typedef struct { + bmol_arr_type arrow:8; ///< Type of arrow. + int8_t dx; ///< Relative to current position. + int8_t dy; ///< Relative to current position. +} const arrow_next; + +/** + * String buffer context. + */ +typedef struct { + char* buffer; ///< A string buffer. + size_t buf_size; ///< The remaining buffer size + size_t size; ///< The buffer size. +} buffer_ctx; + +/** + * The arrow states. + */ +static arrow_next const states[][2][4] = { + [BMOL_ARR_RIGHT] = { + { + {BMOL_ARR_LEFT, +1, 0}, {BMOL_ARR_UP, +1, -1}, + {BMOL_ARR_RIGHT, +1, 0}, {BMOL_ARR_DOWN, +1, +1}, + }, { + {BMOL_ARR_DOWN, +1, +1}, {BMOL_ARR_DOWN, +1, +1}, + {BMOL_ARR_RIGHT, +1, 0}, {BMOL_ARR_UP, +1, -1}, + }, + }, + [BMOL_ARR_LEFT] = { + { + {BMOL_ARR_RIGHT, -1, 0}, {BMOL_ARR_DOWN, 0, +1}, + {BMOL_ARR_LEFT, -1, 0}, {BMOL_ARR_UP, 0, -1}, + }, { + {BMOL_ARR_UP, 0, -1}, {BMOL_ARR_UP, 0, -1}, + {BMOL_ARR_LEFT, -1, 0}, {BMOL_ARR_DOWN, 0, +1}, + }, + }, + [BMOL_ARR_DOWN] = { + { + {BMOL_ARR_UP, 0, +2}, {BMOL_ARR_RIGHT, 0, +1}, + {BMOL_ARR_DOWN, 0, +2}, {BMOL_ARR_LEFT, -1, +1} + }, { + {BMOL_ARR_LEFT, -1, +1}, {BMOL_ARR_LEFT, -1, +1}, + {BMOL_ARR_DOWN, 0, +2}, {BMOL_ARR_RIGHT, 0, +1}, + }, + }, + [BMOL_ARR_UP] = { + { + {BMOL_ARR_DOWN, 0, -2}, {BMOL_ARR_LEFT, -1, -1}, + {BMOL_ARR_UP, 0, -2}, {BMOL_ARR_RIGHT, 0, -1}, + }, { + {BMOL_ARR_RIGHT, 0, -1}, {BMOL_ARR_RIGHT, 0, -1}, + {BMOL_ARR_UP, 0, -2}, {BMOL_ARR_LEFT, -1, -1}, + }, + }, +}; + +/** + * Convert arrow grid coordinates to path coordinates. + * + * @param type Arrow type. + * @param gx Grid X-coordinate. + * @param gy Grid Y-coordinate. + * @param rx Path X-coordinates. + * @param ry Path Y-coordinates. + */ +static void real_coords(bmol_arr_type type, int gx, int gy, int* rx, int* ry) { + /** + * Defines coordinates. + */ + typedef struct { + int8_t x; ///< X-coordinate. + int8_t y; ///< Y-coordinate. + } coords; + + /** + * Delta to add to convert to real coordinates. + */ + static coords const real_delta[] = { + [BMOL_ARR_RIGHT] = {0, 0}, + [BMOL_ARR_LEFT] = {1, 0}, + [BMOL_ARR_DOWN] = {0, 0}, + [BMOL_ARR_UP] = {0, 1}, + }; + + coords const* real = &real_delta[type]; + + *rx = gx - 1 + real->x; + *ry = (gy - 1) / 2 + real->y; +} + +/** + * Allocate more segments. + * + * @param outliner The outline object. + * @return 0 on success. + */ +static int grow_segments(bmol_outliner* outliner) { + bmol_path_seg* segments = outliner->segments; + int segments_cap = outliner->segments_cap * 2 + 1; + + if (segments_cap < MIN_SEGMENTS_COUNT) { + segments_cap = MIN_SEGMENTS_COUNT; + } + + segments = realloc(segments, sizeof(*segments) * segments_cap); + + if (!segments) { + return -1; + } + + outliner->segments = segments; + outliner->segments_cap = segments_cap; + + return 0; +} + +/** + * Add segment to segment list. + * + * @param outliner The outline object. + * @param type The arrow type. + * @param dx Path segment X-coordinate. + * @param dy Path segment Y-coordinate. + * @return 0 on success. + */ +static int push_segment(bmol_outliner* outliner, bmol_arr_type type, int dx, int dy) { + bmol_path_seg* segments = outliner->segments; + + if (outliner->segments_size >= outliner->segments_cap) { + if (grow_segments(outliner) < 0) { + return -1; + } + + segments = outliner->segments; + } + + bmol_path_seg* segment = &segments[outliner->segments_size++]; + + segment->type = type; + segment->dx = dx; + segment->dy = dy; + + return 0; +} + +/** + * Search adjacent arrow relative to given position. + * + * @param width Width of bitmap. + * @param height Height of bitmap. + * @param grid Arrow grid. + * @param type Current arrow type. + * @param inner Is inner path. + * @param xd Arrow X-coordinate. + * @param yd Arrow Y-coordinate. + */ +static bmol_arrow* search_adjacent_arrow(int width, int height, bmol_arrow grid[height * 2 + 3][width + 3], bmol_arr_type type, int inner, int* xd, int* yd) { + arrow_next* arrows = &states[type][inner][0]; + + // search for adjacent arrows in precedence order + for (int n = 0; n < 4; n++) { + arrow_next const* search = &arrows[n]; + int const xn = *xd + search->dx; + int const yn = *yd + search->dy; + bmol_arrow* nextArrow = &grid[yn][xn]; + + // follow adjacent arrow + if (nextArrow->type == search->arrow && !nextArrow->seen) { + // is opposite arrow + if (n == 0) { + if (!inner && nextArrow->inner) { + *xd = xn; + *yd = yn; + + nextArrow->seen = 0; // do not mark opposite arrow as seen + type = nextArrow->type; + + // search next inner arrow relative to opposite arrow + return search_adjacent_arrow(width, height, grid, type, 1, xd, yd); + } + else { + continue; + } + } + // ignore arrows not in path type + else if (nextArrow->inner != inner) { + continue; + } + + *xd = xn; + *yd = yn; + + return nextArrow; + } + } + + // switch to outer path if no more inner path arrows found + if (inner) { + return search_adjacent_arrow(width, height, grid, type, 0, xd, yd); + } + + return NULL; +} + +/** + * Make path segments. + * + * @param x First path arrow. + * @param y First path arrow. + * @param width Width of bitmap. + * @param height Height of bitmap. + * @param grid Grid to search for paths. + */ +static int make_path(bmol_outliner* outliner, int x, int y, int width, int height, bmol_arrow grid[height * 2 + 3][width + 3]) { + int xd = x; + int yd = y; + int xr, yr; + int xp, yp; + bmol_arrow* arrow = &grid[yd][xd]; + bmol_arrow* nextArrow = arrow; + bmol_arr_type type = arrow->type; + int inner = (type == BMOL_ARR_LEFT); + bmol_arr_type prevType = type; + + real_coords(type, xd, yd, &xr, &yr); + + xp = xr; + yp = yr; + + // begin path + if (push_segment(outliner, BMOL_ARR_NONE, xr, yr) != 0) { + return -1; + } + + do { + arrow = nextArrow; + arrow->seen = 1; // mark as seen + + nextArrow = search_adjacent_arrow(width, height, grid, type, inner, &xd, &yd); + type = BMOL_ARR_NONE; + + if (nextArrow) { + type = nextArrow->type; + inner = nextArrow->inner; // switch arrow type + } + + // end path segment if arrow changes + // and ignore last path segment + if (type != prevType && type) { + int dx, dy; + + real_coords(type, xd, yd, &xr, &yr); + + dx = xr - xp; + dy = yr - yp; + xp = xr; + yp = yr; + + // add path segment + if (push_segment(outliner, prevType, dx, dy) < 0) { + return-1; + } + + prevType = type; + } + } + while (type); + + return 0; +} + +/** + * Mark arrow as outer and inner. + * + * @param x First path arrow. + * @param y First path arrow. + * @param width Width of bitmap. + * @param height Height of bitmap. + * @param grid Grid to search for paths. + */ +static void set_path_type(bmol_outliner* outliner, int x, int y, int width, int height, bmol_arrow grid[height * 2 + 3][width + 3]) { + bmol_arrow* arrow = &grid[y][x]; + bmol_arr_type type = arrow->type; + int const inner = (type == BMOL_ARR_LEFT); + + do { + arrow_next* arrows = &states[type][inner][1]; // ignore opponent arrow + + // mark as visited + arrow->visited = 1; + arrow->inner = inner; + + type = BMOL_ARR_NONE; + + // search for adjacent arrows in precedence order + for (int n = 0; n < 3; n++) { + arrow_next* search = &arrows[n]; + int xn = x + search->dx; + int yn = y + search->dy; + bmol_arrow* nextArrow = &grid[yn][xn]; + + // follow adjacent arrow + if (nextArrow->type == search->arrow && !nextArrow->visited) { + x = xn; + y = yn; + type = nextArrow->type; + arrow = nextArrow; + break; + } + } + } + while (type); +} + +/** + * Search all paths in arrow grid. + * + * @param width Width of bitmap. + * @param height Height of bitmap. + * @param grid Grid to search for paths. + */ +static int search_paths(bmol_outliner* outliner, int width, int height, bmol_arrow grid[height * 2 + 3][width + 3]) { + int const gridWidth = width + 3; + int const gridHeight = height * 2 + 3; + + // set arrow types + for (int y = 1; y < gridHeight - 1; y += 2) { + for (int x = 1; x < gridWidth - 1; x++) { + bmol_arrow arrow = grid[y][x]; + + if (arrow.type && !arrow.visited) { + set_path_type(outliner, x, y, width, height, grid); + } + } + } + + // search right and left arrows in grid + for (int y = 1; y < gridHeight - 1; y += 2) { + for (int x = 1; x < gridWidth - 1; x++) { + bmol_arrow arrow = grid[y][x]; + + if (arrow.type && !arrow.seen) { + if (make_path(outliner, x, y, width, height, grid) < 0) { + return -1; + } + } + } + } + + return 0; +} + +/** + * Fill arrow grid. + * + * @param width Width of bitmap. + * @param height Height of bitmap. + * @param map The bitmap. + * @param grid Grid to fill with arrows. + */ +static void set_arrows(int width, int height, uint8_t const map[height][width], bmol_arrow grid[height * 2 + 3][width + 3]) { + int x, y, t; + + for (x = 0; x < width; x++) { + for (y = 0, t = 0; y < height; y++) { + int p = map[y][x] != 0; + + if (p != t) { + grid[y * 2 + 1][x + 1].type = t ? BMOL_ARR_LEFT : BMOL_ARR_RIGHT; + t = p; + } + } + + if (map[y - 1][x]) { + grid[y * 2 + 1][x + 1].type = BMOL_ARR_LEFT; + } + } + + for (y = 0; y < height; y++) { + for (x = 0, t = 0; x < width; x++) { + int p = map[y][x] != 0; + + if (p != t) { + grid[y * 2 + 2][x + 1].type = t ? BMOL_ARR_DOWN : BMOL_ARR_UP; + t = p; + } + } + + if (map[y][x - 1]) { + grid[y * 2 + 2][x + 1].type = BMOL_ARR_DOWN; + } + } +} + +bmol_outliner* bmol_alloc(int width, int height, uint8_t const* data) { + bmol_outliner* outliner; + size_t const size = (width + 3) * (height * 2 + 3) * sizeof(outliner->arrow_grid[0]); + + outliner = calloc(1, sizeof(*outliner) + size); + + if (!outliner) { + return NULL; + } + + outliner->width = width; + outliner->height = height; + outliner->data = data; + + if (grow_segments(outliner) != 0) { + bmol_free(outliner); + + return NULL; + } + + return outliner; +} + +void bmol_free(bmol_outliner* outliner) { + free(outliner->segments); + free(outliner); +} + +bmol_path_seg const* bmol_find_paths(bmol_outliner* outliner, int* out_size) { + int const width = outliner->width; + int const height = outliner->height; + bmol_arrow* grid = outliner->arrow_grid; + uint8_t const* data = outliner->data; + + if (!data) { + return NULL; + } + + outliner->segments_size = 0; + + set_arrows(width, height, (const uint8_t (*)[width])data, (bmol_arrow (*)[width])grid); + + if (search_paths(outliner, width, height, (bmol_arrow (*)[width])grid) < 0) { + return NULL; + } + + if (out_size) { + *out_size = outliner->segments_size; + } + + return outliner->segments; +} + +/** + * Append formated string to buffer. + * + * @param buffer_ref A reference to the buffer. + * @param size_ref A reference to the buffer size. + * @param format The number format. + */ +static void append_string(buffer_ctx* ctx, char const* format, ...) { + int size; + va_list args; + + va_start(args, format); + size = vsnprintf(ctx->buffer, ctx->buf_size, format, args); + va_end(args); + + if (size > 0) { + if (size >= ctx->buf_size) { + size = ctx->buf_size - 1; + } + + ctx->buf_size -= size; + ctx->buffer += size; + ctx->size += size; + } +} + +/** + * Calculate log2 of an integer. + * + * https://graphics.stanford.edu/~seander/bithacks.html#IntegerLog + * + * @param n The value to get the log2 from. + * @return log2 of the given integer. + */ +static uint32_t log2_fast(uint32_t n) { + uint32_t r; + uint32_t shift; + + r = (n > 0xFFFF) << 4; n >>= r; + shift = (n > 0xFF ) << 3; n >>= shift; r |= shift; + shift = (n > 0xF ) << 2; n >>= shift; r |= shift; + shift = (n > 0x3 ) << 1; n >>= shift; r |= shift; + r |= (n >> 1); + + return r; +} + +/** + * Calculate log10 of an integer. + * + * https://graphics.stanford.edu/~seander/bithacks.html#IntegerLog10 + * + * @param n The value to get the log10 from. + * @return log10 of the given integer. + */ +static int log10_fast(uint32_t n) { + static uint32_t const pow_10[] = { + 1, 10, 100, 1000, 10000, 100000, + 1000000, 10000000, 100000000, 1000000000 + }; + + int t = (log2_fast(n) + 1) * 1233 >> 12; + int r = t - (n < pow_10[t]); + + return r; +} + +/** + * Write SVG path to string buffer. + * + * @param segments The path segments. + * @param count The number of path segments. + * @param buffer_ref A reference to the buffer. + * @param size_ref A reference to the buffer size. + */ +static void write_svg(bmol_path_seg const* segments, int count, buffer_ctx* ctx) { + for (int i = 0; i < count; i++) { + bmol_path_seg const* segment = &segments[i]; + + switch (segment->type) { + case BMOL_ARR_NONE: { + if (i > 0) { + append_string(ctx, "z"); + } + + append_string(ctx, "M%d,%d", segment->dx, segment->dy); + break; + } + case BMOL_ARR_RIGHT: + case BMOL_ARR_LEFT: { + append_string(ctx, "h%d", segment->dx); + break; + } + case BMOL_ARR_DOWN: + case BMOL_ARR_UP: { + append_string(ctx, "v%d", segment->dy); + break; + } + default: { + break; + } + } + } + + append_string(ctx, "z"); +} + +size_t bmol_svg_path_len(bmol_outliner* outliner) { + int len = 0; + + for (int i = 0; i < outliner->segments_size; i++) { + bmol_path_seg const* segment = &outliner->segments[i]; + int dx = segment->dx; + int dy = segment->dy; + + switch (segment->type) { + case BMOL_ARR_NONE: { + len += 4 + log10_fast(dx > 0 ? dx : 1) + 1 + log10_fast(dy > 0 ? dy : 1) + 1; + break; + } + case BMOL_ARR_RIGHT: + case BMOL_ARR_LEFT: + case BMOL_ARR_DOWN: + case BMOL_ARR_UP: { + if (dx < 0) { + dx = -dx; + len++; + } + + if (dx > 0) { + len += 1 + log10_fast(dx) + 1; + } + + if (dy < 0) { + dy = -dy; + len++; + } + + if (dy > 0) { + len += 1 + log10_fast(dy) + 1; + } + + break; + } + default: { + break; + } + } + } + + return len + 1; +} + +size_t bmol_svg_path(bmol_outliner* outliner, char buffer[], size_t buf_size) { + buffer_ctx ctx = { + .buffer = buffer, + .buf_size = buf_size, + .size = 0, + }; + + write_svg(outliner->segments, outliner->segments_size, &ctx); + + return ctx.size; +} + +void bmol_set_bitmap(bmol_outliner* outliner, uint8_t const* data) { + outliner->data = data; +} diff --git a/source/engine/thirdparty/bitmap-outliner/bitmap-outliner.h b/source/engine/thirdparty/bitmap-outliner/bitmap-outliner.h new file mode 100644 index 0000000..7dba0bd --- /dev/null +++ b/source/engine/thirdparty/bitmap-outliner/bitmap-outliner.h @@ -0,0 +1,98 @@ +#pragma once + +#include +#include + +/** + * Arrow types. + */ +typedef enum { + BMOL_ARR_NONE = 0, + BMOL_ARR_RIGHT, + BMOL_ARR_LEFT, + BMOL_ARR_DOWN, + BMOL_ARR_UP +} bmol_arr_type; + +/** + * Defines arrow. + */ +typedef struct { + uint8_t type:3; ///< Arrow type. + uint8_t inner:1; ///< Associated path is inner path. + uint8_t seen:1; ///< Has been seen. + uint8_t visited:1; ///< Has been visited. +} bmol_arrow; + +/** + * Defines path segment. + */ +typedef struct { + uint8_t type; ///< Arrow type. + int dx; ///< Path segment width. + int dy; ///< Path segment height. +} bmol_path_seg; + +/** + * Defines outliner object. + */ +typedef struct { + int width; ///< Bitmap width. + int height; ///< Bitmap height. + uint8_t const* data; ///< Bitmap data. + bmol_path_seg* segments; ///< Path segment buffer. + int segments_size; ///< Path segment buffer length. + int segments_cap; ///< Path segment buffer capacity. + bmol_arrow arrow_grid[]; ///< Grid arrows. +} bmol_outliner; + +/** + * Allocate outliner object. + * + * @param width The bitmap width. + * @param height The bitmap height. + * @param data The bitmap data. + * @return Outliner object on success. + */ +extern bmol_outliner* bmol_alloc(int width, int height, uint8_t const* data); + +/** + * Free outliner object. + * + * @param outliner The outline object. + */ +extern void bmol_free(bmol_outliner* outliner); + +/** + * Find paths in bitmap data. + * + * @param outliner The outliner object. + * @param out_size The number of path fragments. + * @return The path fragments. + */ +extern bmol_path_seg const* bmol_find_paths(bmol_outliner* outliner, int* out_size); + +/** + * Calculate the SVG path length. + * + * @return The length of the SVG path string. + */ +extern size_t bmol_svg_path_len(bmol_outliner* outliner); + +/** + * Create SVG path from segments. + * + * @param outliner The outline object. + * @param buffer The buffer to write the SVG path into. + * @param buf_size The buffer capacity. + * @return The length of the generated SVG path. + */ +extern size_t bmol_svg_path(bmol_outliner* outliner, char buffer[], size_t buf_size); + +/** + * Set bitmap data. Must have the same dimensions as the current one. + * + * @param outliner The outline robject. + * @param data The new bitmap data. + */ +extern void bmol_set_bitmap(bmol_outliner* outliner, uint8_t const* data); diff --git a/source/engine/thirdparty/cgltf/LICENSE b/source/engine/thirdparty/cgltf/LICENSE new file mode 100644 index 0000000..599d934 --- /dev/null +++ b/source/engine/thirdparty/cgltf/LICENSE @@ -0,0 +1,7 @@ +Copyright (c) 2018-2021 Johannes Kuhlmann + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/source/engine/thirdparty/cgltf/README.md b/source/engine/thirdparty/cgltf/README.md new file mode 100644 index 0000000..1a406c7 --- /dev/null +++ b/source/engine/thirdparty/cgltf/README.md @@ -0,0 +1,156 @@ +# :diamond_shape_with_a_dot_inside: cgltf +**Single-file/stb-style C glTF loader and writer** + +[![Build Status](https://github.com/jkuhlmann/cgltf/workflows/build/badge.svg)](https://github.com/jkuhlmann/cgltf/actions) + +Used in: [bgfx](https://github.com/bkaradzic/bgfx), [Filament](https://github.com/google/filament), [gltfpack](https://github.com/zeux/meshoptimizer/tree/master/gltf), [raylib](https://github.com/raysan5/raylib), [Unigine](https://developer.unigine.com/en/docs/2.14.1/third_party?rlang=cpp#cgltf), and more! + +## Usage: Loading +Loading from file: +```c +#define CGLTF_IMPLEMENTATION +#include "cgltf.h" + +cgltf_options options = {0}; +cgltf_data* data = NULL; +cgltf_result result = cgltf_parse_file(&options, "scene.gltf", &data); +if (result == cgltf_result_success) +{ + /* TODO make awesome stuff */ + cgltf_free(data); +} +``` + +Loading from memory: +```c +#define CGLTF_IMPLEMENTATION +#include "cgltf.h" + +void* buf; /* Pointer to glb or gltf file data */ +size_t size; /* Size of the file data */ + +cgltf_options options = {0}; +cgltf_data* data = NULL; +cgltf_result result = cgltf_parse(&options, buf, size, &data); +if (result == cgltf_result_success) +{ + /* TODO make awesome stuff */ + cgltf_free(data); +} +``` + +Note that cgltf does not load the contents of extra files such as buffers or images into memory by default. You'll need to read these files yourself using URIs from `data.buffers[]` or `data.images[]` respectively. +For buffer data, you can alternatively call `cgltf_load_buffers`, which will use `FILE*` APIs to open and read buffer files. This automatically decodes base64 data URIs in buffers. For data URIs in images, you will need to use `cgltf_load_buffer_base64`. + +**For more in-depth documentation and a description of the public interface refer to the top of the `cgltf.h` file.** + +## Usage: Writing +When writing glTF data, you need a valid `cgltf_data` structure that represents a valid glTF document. You can construct such a structure yourself or load it using the loader functions described above. The writer functions do not deallocate any memory. So, you either have to do it manually or call `cgltf_free()` if you got the data by loading it from a glTF document. + +Writing to file: +```c +#define CGLTF_IMPLEMENTATION +#define CGLTF_WRITE_IMPLEMENTATION +#include "cgltf_write.h" + +cgltf_options options = {0}; +cgltf_data* data = /* TODO must be valid data */; +cgltf_result result = cgltf_write_file(&options, "out.gltf", data); +if (result != cgltf_result_success) +{ + /* TODO handle error */ +} +``` + +Writing to memory: +```c +#define CGLTF_IMPLEMENTATION +#define CGLTF_WRITE_IMPLEMENTATION +#include "cgltf_write.h" +cgltf_options options = {0}; +cgltf_data* data = /* TODO must be valid data */; + +cgltf_size size = cgltf_write(&options, NULL, 0, data); + +char* buf = malloc(size); + +cgltf_size written = cgltf_write(&options, buf, size, data); +if (written != size) +{ + /* TODO handle error */ +} +``` + +Note that cgltf does not write the contents of extra files such as buffers or images. You'll need to write this data yourself. + +**For more in-depth documentation and a description of the public interface refer to the top of the `cgltf_write.h` file.** + + +## Features +cgltf supports core glTF 2.0: +- glb (binary files) and gltf (JSON files) +- meshes (including accessors, buffer views, buffers) +- materials (including textures, samplers, images) +- scenes and nodes +- skins +- animations +- cameras +- morph targets +- extras data + +cgltf also supports some glTF extensions: +- EXT_meshopt_compression +- KHR_draco_mesh_compression (requires a library like [Google's Draco](https://github.com/google/draco) for decompression though) +- KHR_lights_punctual +- KHR_materials_clearcoat +- KHR_materials_ior +- KHR_materials_pbrSpecularGlossiness +- KHR_materials_sheen +- KHR_materials_specular +- KHR_materials_transmission +- KHR_materials_unlit +- KHR_materials_variants +- KHR_materials_volume +- KHR_texture_transform + +cgltf does **not** yet support unlisted extensions. However, unlisted extensions can be accessed via "extensions" member on objects. + +## Building +The easiest approach is to integrate the `cgltf.h` header file into your project. If you are unfamiliar with single-file C libraries (also known as stb-style libraries), this is how it goes: + +1. Include `cgltf.h` where you need the functionality. +1. Have exactly one source file that defines `CGLTF_IMPLEMENTATION` before including `cgltf.h`. +1. Use the cgltf functions as described above. + +Support for writing can be found in a separate file called `cgltf_write.h` (which includes `cgltf.h`). Building it works analogously using the `CGLTF_WRITE_IMPLEMENTATION` define. + +## Contributing +Everyone is welcome to contribute to the library. If you find any problems, you can submit them using [GitHub's issue system](https://github.com/jkuhlmann/cgltf/issues). If you want to contribute code, you should fork the project and then send a pull request. + + +## Dependencies +None. + +C headers being used by implementation: +``` +#include +#include +#include +#include +#include +#include +``` + +Note, this library has a copy of the [JSMN JSON parser](https://github.com/zserge/jsmn) embedded in its source. + +## Testing +There is a Python script in the `test/` folder that retrieves the glTF 2.0 sample files from the glTF-Sample-Models repository (https://github.com/KhronosGroup/glTF-Sample-Models/tree/master/2.0) and runs the library against all gltf and glb files. + +Here's one way to build and run the test: + + cd test ; mkdir build ; cd build ; cmake .. -DCMAKE_BUILD_TYPE=Debug + make -j + cd .. + ./test_all.py + +There is also a llvm-fuzz test in `fuzz/`. See http://llvm.org/docs/LibFuzzer.html for more information. diff --git a/source/engine/thirdparty/cgltf/cgltf.h b/source/engine/thirdparty/cgltf/cgltf.h new file mode 100644 index 0000000..7858697 --- /dev/null +++ b/source/engine/thirdparty/cgltf/cgltf.h @@ -0,0 +1,6434 @@ +/** + * cgltf - a single-file glTF 2.0 parser written in C99. + * + * Version: 1.11 + * + * Website: https://github.com/jkuhlmann/cgltf + * + * Distributed under the MIT License, see notice at the end of this file. + * + * Building: + * Include this file where you need the struct and function + * declarations. Have exactly one source file where you define + * `CGLTF_IMPLEMENTATION` before including this file to get the + * function definitions. + * + * Reference: + * `cgltf_result cgltf_parse(const cgltf_options*, const void*, + * cgltf_size, cgltf_data**)` parses both glTF and GLB data. If + * this function returns `cgltf_result_success`, you have to call + * `cgltf_free()` on the created `cgltf_data*` variable. + * Note that contents of external files for buffers and images are not + * automatically loaded. You'll need to read these files yourself using + * URIs in the `cgltf_data` structure. + * + * `cgltf_options` is the struct passed to `cgltf_parse()` to control + * parts of the parsing process. You can use it to force the file type + * and provide memory allocation as well as file operation callbacks. + * Should be zero-initialized to trigger default behavior. + * + * `cgltf_data` is the struct allocated and filled by `cgltf_parse()`. + * It generally mirrors the glTF format as described by the spec (see + * https://github.com/KhronosGroup/glTF/tree/master/specification/2.0). + * + * `void cgltf_free(cgltf_data*)` frees the allocated `cgltf_data` + * variable. + * + * `cgltf_result cgltf_load_buffers(const cgltf_options*, cgltf_data*, + * const char* gltf_path)` can be optionally called to open and read buffer + * files using the `FILE*` APIs. The `gltf_path` argument is the path to + * the original glTF file, which allows the parser to resolve the path to + * buffer files. + * + * `cgltf_result cgltf_load_buffer_base64(const cgltf_options* options, + * cgltf_size size, const char* base64, void** out_data)` decodes + * base64-encoded data content. Used internally by `cgltf_load_buffers()`. + * This is useful when decoding data URIs in images. + * + * `cgltf_result cgltf_parse_file(const cgltf_options* options, const + * char* path, cgltf_data** out_data)` can be used to open the given + * file using `FILE*` APIs and parse the data using `cgltf_parse()`. + * + * `cgltf_result cgltf_validate(cgltf_data*)` can be used to do additional + * checks to make sure the parsed glTF data is valid. + * + * `cgltf_node_transform_local` converts the translation / rotation / scale properties of a node + * into a mat4. + * + * `cgltf_node_transform_world` calls `cgltf_node_transform_local` on every ancestor in order + * to compute the root-to-node transformation. + * + * `cgltf_accessor_unpack_floats` reads in the data from an accessor, applies sparse data (if any), + * and converts them to floating point. Assumes that `cgltf_load_buffers` has already been called. + * By passing null for the output pointer, users can find out how many floats are required in the + * output buffer. + * + * `cgltf_accessor_num_components` is a tiny utility that tells you the dimensionality of + * a certain accessor type. This can be used before `cgltf_accessor_unpack_floats` to help allocate + * the necessary amount of memory. + * + * `cgltf_accessor_read_float` reads a certain element from a non-sparse accessor and converts it to + * floating point, assuming that `cgltf_load_buffers` has already been called. The passed-in element + * size is the number of floats in the output buffer, which should be in the range [1, 16]. Returns + * false if the passed-in element_size is too small, or if the accessor is sparse. + * + * `cgltf_accessor_read_uint` is similar to its floating-point counterpart, but limited to reading + * vector types and does not support matrix types. The passed-in element size is the number of uints + * in the output buffer, which should be in the range [1, 4]. Returns false if the passed-in + * element_size is too small, or if the accessor is sparse. + * + * `cgltf_accessor_read_index` is similar to its floating-point counterpart, but it returns size_t + * and only works with single-component data types. + * + * `cgltf_result cgltf_copy_extras_json(const cgltf_data*, const cgltf_extras*, + * char* dest, cgltf_size* dest_size)` allows users to retrieve the "extras" data that + * can be attached to many glTF objects (which can be arbitrary JSON data). The + * `cgltf_extras` struct stores the offsets of the start and end of the extras JSON data + * as it appears in the complete glTF JSON data. This function copies the extras data + * into the provided buffer. If `dest` is NULL, the length of the data is written into + * `dest_size`. You can then parse this data using your own JSON parser + * or, if you've included the cgltf implementation using the integrated JSMN JSON parser. + */ +#ifndef CGLTF_H_INCLUDED__ +#define CGLTF_H_INCLUDED__ + +#include + +#ifdef __cplusplus +extern "C" { +#endif + +typedef size_t cgltf_size; +typedef float cgltf_float; +typedef int cgltf_int; +typedef unsigned int cgltf_uint; +typedef int cgltf_bool; + +typedef enum cgltf_file_type +{ + cgltf_file_type_invalid, + cgltf_file_type_gltf, + cgltf_file_type_glb, +} cgltf_file_type; + +typedef enum cgltf_result +{ + cgltf_result_success, + cgltf_result_data_too_short, + cgltf_result_unknown_format, + cgltf_result_invalid_json, + cgltf_result_invalid_gltf, + cgltf_result_invalid_options, + cgltf_result_file_not_found, + cgltf_result_io_error, + cgltf_result_out_of_memory, + cgltf_result_legacy_gltf, +} cgltf_result; + +typedef struct cgltf_memory_options +{ + void* (*alloc)(void* user, cgltf_size size); + void (*free) (void* user, void* ptr); + void* user_data; +} cgltf_memory_options; + +typedef struct cgltf_file_options +{ + cgltf_result(*read)(const struct cgltf_memory_options* memory_options, const struct cgltf_file_options* file_options, const char* path, cgltf_size* size, void** data); + void (*release)(const struct cgltf_memory_options* memory_options, const struct cgltf_file_options* file_options, void* data); + void* user_data; +} cgltf_file_options; + +typedef struct cgltf_options +{ + cgltf_file_type type; /* invalid == auto detect */ + cgltf_size json_token_count; /* 0 == auto */ + cgltf_memory_options memory; + cgltf_file_options file; +} cgltf_options; + +typedef enum cgltf_buffer_view_type +{ + cgltf_buffer_view_type_invalid, + cgltf_buffer_view_type_indices, + cgltf_buffer_view_type_vertices, +} cgltf_buffer_view_type; + +typedef enum cgltf_attribute_type +{ + cgltf_attribute_type_invalid, + cgltf_attribute_type_position, + cgltf_attribute_type_normal, + cgltf_attribute_type_tangent, + cgltf_attribute_type_texcoord, + cgltf_attribute_type_color, + cgltf_attribute_type_joints, + cgltf_attribute_type_weights, +} cgltf_attribute_type; + +typedef enum cgltf_component_type +{ + cgltf_component_type_invalid, + cgltf_component_type_r_8, /* BYTE */ + cgltf_component_type_r_8u, /* UNSIGNED_BYTE */ + cgltf_component_type_r_16, /* SHORT */ + cgltf_component_type_r_16u, /* UNSIGNED_SHORT */ + cgltf_component_type_r_32u, /* UNSIGNED_INT */ + cgltf_component_type_r_32f, /* FLOAT */ +} cgltf_component_type; + +typedef enum cgltf_type +{ + cgltf_type_invalid, + cgltf_type_scalar, + cgltf_type_vec2, + cgltf_type_vec3, + cgltf_type_vec4, + cgltf_type_mat2, + cgltf_type_mat3, + cgltf_type_mat4, +} cgltf_type; + +typedef enum cgltf_primitive_type +{ + cgltf_primitive_type_points, + cgltf_primitive_type_lines, + cgltf_primitive_type_line_loop, + cgltf_primitive_type_line_strip, + cgltf_primitive_type_triangles, + cgltf_primitive_type_triangle_strip, + cgltf_primitive_type_triangle_fan, +} cgltf_primitive_type; + +typedef enum cgltf_alpha_mode +{ + cgltf_alpha_mode_opaque, + cgltf_alpha_mode_mask, + cgltf_alpha_mode_blend, +} cgltf_alpha_mode; + +typedef enum cgltf_animation_path_type { + cgltf_animation_path_type_invalid, + cgltf_animation_path_type_translation, + cgltf_animation_path_type_rotation, + cgltf_animation_path_type_scale, + cgltf_animation_path_type_weights, +} cgltf_animation_path_type; + +typedef enum cgltf_interpolation_type { + cgltf_interpolation_type_linear, + cgltf_interpolation_type_step, + cgltf_interpolation_type_cubic_spline, +} cgltf_interpolation_type; + +typedef enum cgltf_camera_type { + cgltf_camera_type_invalid, + cgltf_camera_type_perspective, + cgltf_camera_type_orthographic, +} cgltf_camera_type; + +typedef enum cgltf_light_type { + cgltf_light_type_invalid, + cgltf_light_type_directional, + cgltf_light_type_point, + cgltf_light_type_spot, +} cgltf_light_type; + +typedef enum cgltf_data_free_method { + cgltf_data_free_method_none, + cgltf_data_free_method_file_release, + cgltf_data_free_method_memory_free, +} cgltf_data_free_method; + +typedef struct cgltf_extras { + cgltf_size start_offset; + cgltf_size end_offset; +} cgltf_extras; + +typedef struct cgltf_extension { + char* name; + char* data; +} cgltf_extension; + +typedef struct cgltf_buffer +{ + char* name; + cgltf_size size; + char* uri; + void* data; /* loaded by cgltf_load_buffers */ + cgltf_data_free_method data_free_method; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_buffer; + +typedef enum cgltf_meshopt_compression_mode { + cgltf_meshopt_compression_mode_invalid, + cgltf_meshopt_compression_mode_attributes, + cgltf_meshopt_compression_mode_triangles, + cgltf_meshopt_compression_mode_indices, +} cgltf_meshopt_compression_mode; + +typedef enum cgltf_meshopt_compression_filter { + cgltf_meshopt_compression_filter_none, + cgltf_meshopt_compression_filter_octahedral, + cgltf_meshopt_compression_filter_quaternion, + cgltf_meshopt_compression_filter_exponential, +} cgltf_meshopt_compression_filter; + +typedef struct cgltf_meshopt_compression +{ + cgltf_buffer* buffer; + cgltf_size offset; + cgltf_size size; + cgltf_size stride; + cgltf_size count; + cgltf_meshopt_compression_mode mode; + cgltf_meshopt_compression_filter filter; +} cgltf_meshopt_compression; + +typedef struct cgltf_buffer_view +{ + char *name; + cgltf_buffer* buffer; + cgltf_size offset; + cgltf_size size; + cgltf_size stride; /* 0 == automatically determined by accessor */ + cgltf_buffer_view_type type; + void* data; /* overrides buffer->data if present, filled by extensions */ + cgltf_bool has_meshopt_compression; + cgltf_meshopt_compression meshopt_compression; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_buffer_view; + +typedef struct cgltf_accessor_sparse +{ + cgltf_size count; + cgltf_buffer_view* indices_buffer_view; + cgltf_size indices_byte_offset; + cgltf_component_type indices_component_type; + cgltf_buffer_view* values_buffer_view; + cgltf_size values_byte_offset; + cgltf_extras extras; + cgltf_extras indices_extras; + cgltf_extras values_extras; + cgltf_size extensions_count; + cgltf_extension* extensions; + cgltf_size indices_extensions_count; + cgltf_extension* indices_extensions; + cgltf_size values_extensions_count; + cgltf_extension* values_extensions; +} cgltf_accessor_sparse; + +typedef struct cgltf_accessor +{ + char* name; + cgltf_component_type component_type; + cgltf_bool normalized; + cgltf_type type; + cgltf_size offset; + cgltf_size count; + cgltf_size stride; + cgltf_buffer_view* buffer_view; + cgltf_bool has_min; + cgltf_float min[16]; + cgltf_bool has_max; + cgltf_float max[16]; + cgltf_bool is_sparse; + cgltf_accessor_sparse sparse; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_accessor; + +typedef struct cgltf_attribute +{ + char* name; + cgltf_attribute_type type; + cgltf_int index; + cgltf_accessor* data; +} cgltf_attribute; + +typedef struct cgltf_image +{ + char* name; + char* uri; + cgltf_buffer_view* buffer_view; + char* mime_type; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_image; + +typedef struct cgltf_sampler +{ + char* name; + cgltf_int mag_filter; + cgltf_int min_filter; + cgltf_int wrap_s; + cgltf_int wrap_t; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_sampler; + +typedef struct cgltf_texture +{ + char* name; + cgltf_image* image; + cgltf_sampler* sampler; + cgltf_bool has_basisu; + cgltf_image* basisu_image; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_texture; + +typedef struct cgltf_texture_transform +{ + cgltf_float offset[2]; + cgltf_float rotation; + cgltf_float scale[2]; + cgltf_bool has_texcoord; + cgltf_int texcoord; +} cgltf_texture_transform; + +typedef struct cgltf_texture_view +{ + cgltf_texture* texture; + cgltf_int texcoord; + cgltf_float scale; /* equivalent to strength for occlusion_texture */ + cgltf_bool has_transform; + cgltf_texture_transform transform; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_texture_view; + +typedef struct cgltf_pbr_metallic_roughness +{ + cgltf_texture_view base_color_texture; + cgltf_texture_view metallic_roughness_texture; + + cgltf_float base_color_factor[4]; + cgltf_float metallic_factor; + cgltf_float roughness_factor; + + cgltf_extras extras; +} cgltf_pbr_metallic_roughness; + +typedef struct cgltf_pbr_specular_glossiness +{ + cgltf_texture_view diffuse_texture; + cgltf_texture_view specular_glossiness_texture; + + cgltf_float diffuse_factor[4]; + cgltf_float specular_factor[3]; + cgltf_float glossiness_factor; +} cgltf_pbr_specular_glossiness; + +typedef struct cgltf_clearcoat +{ + cgltf_texture_view clearcoat_texture; + cgltf_texture_view clearcoat_roughness_texture; + cgltf_texture_view clearcoat_normal_texture; + + cgltf_float clearcoat_factor; + cgltf_float clearcoat_roughness_factor; +} cgltf_clearcoat; + +typedef struct cgltf_transmission +{ + cgltf_texture_view transmission_texture; + cgltf_float transmission_factor; +} cgltf_transmission; + +typedef struct cgltf_ior +{ + cgltf_float ior; +} cgltf_ior; + +typedef struct cgltf_specular +{ + cgltf_texture_view specular_texture; + cgltf_texture_view specular_color_texture; + cgltf_float specular_color_factor[3]; + cgltf_float specular_factor; +} cgltf_specular; + +typedef struct cgltf_volume +{ + cgltf_texture_view thickness_texture; + cgltf_float thickness_factor; + cgltf_float attenuation_color[3]; + cgltf_float attenuation_distance; +} cgltf_volume; + +typedef struct cgltf_sheen +{ + cgltf_texture_view sheen_color_texture; + cgltf_float sheen_color_factor[3]; + cgltf_texture_view sheen_roughness_texture; + cgltf_float sheen_roughness_factor; +} cgltf_sheen; + +typedef struct cgltf_material +{ + char* name; + cgltf_bool has_pbr_metallic_roughness; + cgltf_bool has_pbr_specular_glossiness; + cgltf_bool has_clearcoat; + cgltf_bool has_transmission; + cgltf_bool has_volume; + cgltf_bool has_ior; + cgltf_bool has_specular; + cgltf_bool has_sheen; + cgltf_pbr_metallic_roughness pbr_metallic_roughness; + cgltf_pbr_specular_glossiness pbr_specular_glossiness; + cgltf_clearcoat clearcoat; + cgltf_ior ior; + cgltf_specular specular; + cgltf_sheen sheen; + cgltf_transmission transmission; + cgltf_volume volume; + cgltf_texture_view normal_texture; + cgltf_texture_view occlusion_texture; + cgltf_texture_view emissive_texture; + cgltf_float emissive_factor[3]; + cgltf_alpha_mode alpha_mode; + cgltf_float alpha_cutoff; + cgltf_bool double_sided; + cgltf_bool unlit; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_material; + +typedef struct cgltf_material_mapping +{ + cgltf_size variant; + cgltf_material* material; + cgltf_extras extras; +} cgltf_material_mapping; + +typedef struct cgltf_morph_target { + cgltf_attribute* attributes; + cgltf_size attributes_count; +} cgltf_morph_target; + +typedef struct cgltf_draco_mesh_compression { + cgltf_buffer_view* buffer_view; + cgltf_attribute* attributes; + cgltf_size attributes_count; +} cgltf_draco_mesh_compression; + +typedef struct cgltf_primitive { + cgltf_primitive_type type; + cgltf_accessor* indices; + cgltf_material* material; + cgltf_attribute* attributes; + cgltf_size attributes_count; + cgltf_morph_target* targets; + cgltf_size targets_count; + cgltf_extras extras; + cgltf_bool has_draco_mesh_compression; + cgltf_draco_mesh_compression draco_mesh_compression; + cgltf_material_mapping* mappings; + cgltf_size mappings_count; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_primitive; + +typedef struct cgltf_mesh { + char* name; + cgltf_primitive* primitives; + cgltf_size primitives_count; + cgltf_float* weights; + cgltf_size weights_count; + char** target_names; + cgltf_size target_names_count; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_mesh; + +typedef struct cgltf_node cgltf_node; + +typedef struct cgltf_skin { + char* name; + cgltf_node** joints; + cgltf_size joints_count; + cgltf_node* skeleton; + cgltf_accessor* inverse_bind_matrices; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_skin; + +typedef struct cgltf_camera_perspective { + cgltf_bool has_aspect_ratio; + cgltf_float aspect_ratio; + cgltf_float yfov; + cgltf_bool has_zfar; + cgltf_float zfar; + cgltf_float znear; + cgltf_extras extras; +} cgltf_camera_perspective; + +typedef struct cgltf_camera_orthographic { + cgltf_float xmag; + cgltf_float ymag; + cgltf_float zfar; + cgltf_float znear; + cgltf_extras extras; +} cgltf_camera_orthographic; + +typedef struct cgltf_camera { + char* name; + cgltf_camera_type type; + union { + cgltf_camera_perspective perspective; + cgltf_camera_orthographic orthographic; + } data; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_camera; + +typedef struct cgltf_light { + char* name; + cgltf_float color[3]; + cgltf_float intensity; + cgltf_light_type type; + cgltf_float range; + cgltf_float spot_inner_cone_angle; + cgltf_float spot_outer_cone_angle; + cgltf_extras extras; +} cgltf_light; + +struct cgltf_node { + char* name; + cgltf_node* parent; + cgltf_node** children; + cgltf_size children_count; + cgltf_skin* skin; + cgltf_mesh* mesh; + cgltf_camera* camera; + cgltf_light* light; + cgltf_float* weights; + cgltf_size weights_count; + cgltf_bool has_translation; + cgltf_bool has_rotation; + cgltf_bool has_scale; + cgltf_bool has_matrix; + cgltf_float translation[3]; + cgltf_float rotation[4]; + cgltf_float scale[3]; + cgltf_float matrix[16]; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +}; + +typedef struct cgltf_scene { + char* name; + cgltf_node** nodes; + cgltf_size nodes_count; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_scene; + +typedef struct cgltf_animation_sampler { + cgltf_accessor* input; + cgltf_accessor* output; + cgltf_interpolation_type interpolation; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_animation_sampler; + +typedef struct cgltf_animation_channel { + cgltf_animation_sampler* sampler; + cgltf_node* target_node; + cgltf_animation_path_type target_path; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_animation_channel; + +typedef struct cgltf_animation { + char* name; + cgltf_animation_sampler* samplers; + cgltf_size samplers_count; + cgltf_animation_channel* channels; + cgltf_size channels_count; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_animation; + +typedef struct cgltf_material_variant +{ + char* name; + cgltf_extras extras; +} cgltf_material_variant; + +typedef struct cgltf_asset { + char* copyright; + char* generator; + char* version; + char* min_version; + cgltf_extras extras; + cgltf_size extensions_count; + cgltf_extension* extensions; +} cgltf_asset; + +typedef struct cgltf_data +{ + cgltf_file_type file_type; + void* file_data; + + cgltf_asset asset; + + cgltf_mesh* meshes; + cgltf_size meshes_count; + + cgltf_material* materials; + cgltf_size materials_count; + + cgltf_accessor* accessors; + cgltf_size accessors_count; + + cgltf_buffer_view* buffer_views; + cgltf_size buffer_views_count; + + cgltf_buffer* buffers; + cgltf_size buffers_count; + + cgltf_image* images; + cgltf_size images_count; + + cgltf_texture* textures; + cgltf_size textures_count; + + cgltf_sampler* samplers; + cgltf_size samplers_count; + + cgltf_skin* skins; + cgltf_size skins_count; + + cgltf_camera* cameras; + cgltf_size cameras_count; + + cgltf_light* lights; + cgltf_size lights_count; + + cgltf_node* nodes; + cgltf_size nodes_count; + + cgltf_scene* scenes; + cgltf_size scenes_count; + + cgltf_scene* scene; + + cgltf_animation* animations; + cgltf_size animations_count; + + cgltf_material_variant* variants; + cgltf_size variants_count; + + cgltf_extras extras; + + cgltf_size data_extensions_count; + cgltf_extension* data_extensions; + + char** extensions_used; + cgltf_size extensions_used_count; + + char** extensions_required; + cgltf_size extensions_required_count; + + const char* json; + cgltf_size json_size; + + const void* bin; + cgltf_size bin_size; + + cgltf_memory_options memory; + cgltf_file_options file; +} cgltf_data; + +cgltf_result cgltf_parse( + const cgltf_options* options, + const void* data, + cgltf_size size, + cgltf_data** out_data); + +cgltf_result cgltf_parse_file( + const cgltf_options* options, + const char* path, + cgltf_data** out_data); + +cgltf_result cgltf_load_buffers( + const cgltf_options* options, + cgltf_data* data, + const char* gltf_path); + +cgltf_result cgltf_load_buffer_base64(const cgltf_options* options, cgltf_size size, const char* base64, void** out_data); + +void cgltf_decode_uri(char* uri); + +cgltf_result cgltf_validate(cgltf_data* data); + +void cgltf_free(cgltf_data* data); + +void cgltf_node_transform_local(const cgltf_node* node, cgltf_float* out_matrix); +void cgltf_node_transform_world(const cgltf_node* node, cgltf_float* out_matrix); + +cgltf_bool cgltf_accessor_read_float(const cgltf_accessor* accessor, cgltf_size index, cgltf_float* out, cgltf_size element_size); +cgltf_bool cgltf_accessor_read_uint(const cgltf_accessor* accessor, cgltf_size index, cgltf_uint* out, cgltf_size element_size); +cgltf_size cgltf_accessor_read_index(const cgltf_accessor* accessor, cgltf_size index); + +cgltf_size cgltf_num_components(cgltf_type type); + +cgltf_size cgltf_accessor_unpack_floats(const cgltf_accessor* accessor, cgltf_float* out, cgltf_size float_count); + +cgltf_result cgltf_copy_extras_json(const cgltf_data* data, const cgltf_extras* extras, char* dest, cgltf_size* dest_size); + +#ifdef __cplusplus +} +#endif + +#endif /* #ifndef CGLTF_H_INCLUDED__ */ + +/* + * + * Stop now, if you are only interested in the API. + * Below, you find the implementation. + * + */ + +#if defined(__INTELLISENSE__) || defined(__JETBRAINS_IDE__) +/* This makes MSVC/CLion intellisense work. */ +#define CGLTF_IMPLEMENTATION +#endif + +#ifdef CGLTF_IMPLEMENTATION + +#include /* For uint8_t, uint32_t */ +#include /* For strncpy */ +#include /* For fopen */ +#include /* For UINT_MAX etc */ +#include /* For FLT_MAX */ + +#if !defined(CGLTF_MALLOC) || !defined(CGLTF_FREE) || !defined(CGLTF_ATOI) || !defined(CGLTF_ATOF) || !defined(CGLTF_ATOLL) +#include /* For malloc, free, atoi, atof */ +#endif + +/* JSMN_PARENT_LINKS is necessary to make parsing large structures linear in input size */ +#define JSMN_PARENT_LINKS + +/* JSMN_STRICT is necessary to reject invalid JSON documents */ +#define JSMN_STRICT + +/* + * -- jsmn.h start -- + * Source: https://github.com/zserge/jsmn + * License: MIT + */ +typedef enum { + JSMN_UNDEFINED = 0, + JSMN_OBJECT = 1, + JSMN_ARRAY = 2, + JSMN_STRING = 3, + JSMN_PRIMITIVE = 4 +} jsmntype_t; +enum jsmnerr { + /* Not enough tokens were provided */ + JSMN_ERROR_NOMEM = -1, + /* Invalid character inside JSON string */ + JSMN_ERROR_INVAL = -2, + /* The string is not a full JSON packet, more bytes expected */ + JSMN_ERROR_PART = -3 +}; +typedef struct { + jsmntype_t type; + int start; + int end; + int size; +#ifdef JSMN_PARENT_LINKS + int parent; +#endif +} jsmntok_t; +typedef struct { + unsigned int pos; /* offset in the JSON string */ + unsigned int toknext; /* next token to allocate */ + int toksuper; /* superior token node, e.g parent object or array */ +} jsmn_parser; +static void jsmn_init(jsmn_parser *parser); +static int jsmn_parse(jsmn_parser *parser, const char *js, size_t len, jsmntok_t *tokens, size_t num_tokens); +/* + * -- jsmn.h end -- + */ + + +static const cgltf_size GlbHeaderSize = 12; +static const cgltf_size GlbChunkHeaderSize = 8; +static const uint32_t GlbVersion = 2; +static const uint32_t GlbMagic = 0x46546C67; +static const uint32_t GlbMagicJsonChunk = 0x4E4F534A; +static const uint32_t GlbMagicBinChunk = 0x004E4942; + +#ifndef CGLTF_MALLOC +#define CGLTF_MALLOC(size) malloc(size) +#endif +#ifndef CGLTF_FREE +#define CGLTF_FREE(ptr) free(ptr) +#endif +#ifndef CGLTF_ATOI +#define CGLTF_ATOI(str) atoi(str) +#endif +#ifndef CGLTF_ATOF +#define CGLTF_ATOF(str) atof(str) +#endif +#ifndef CGLTF_ATOLL +#define CGLTF_ATOLL(str) atoll(str) +#endif +#ifndef CGLTF_VALIDATE_ENABLE_ASSERTS +#define CGLTF_VALIDATE_ENABLE_ASSERTS 0 +#endif + +static void* cgltf_default_alloc(void* user, cgltf_size size) +{ + (void)user; + return CGLTF_MALLOC(size); +} + +static void cgltf_default_free(void* user, void* ptr) +{ + (void)user; + CGLTF_FREE(ptr); +} + +static void* cgltf_calloc(cgltf_options* options, size_t element_size, cgltf_size count) +{ + if (SIZE_MAX / element_size < count) + { + return NULL; + } + void* result = options->memory.alloc(options->memory.user_data, element_size * count); + if (!result) + { + return NULL; + } + memset(result, 0, element_size * count); + return result; +} + +static cgltf_result cgltf_default_file_read(const struct cgltf_memory_options* memory_options, const struct cgltf_file_options* file_options, const char* path, cgltf_size* size, void** data) +{ + (void)file_options; + void* (*memory_alloc)(void*, cgltf_size) = memory_options->alloc ? memory_options->alloc : &cgltf_default_alloc; + void (*memory_free)(void*, void*) = memory_options->free ? memory_options->free : &cgltf_default_free; + + FILE* file = fopen(path, "rb"); + if (!file) + { + return cgltf_result_file_not_found; + } + + cgltf_size file_size = size ? *size : 0; + + if (file_size == 0) + { + fseek(file, 0, SEEK_END); + +#ifdef _WIN32 + __int64 length = _ftelli64(file); +#else + long length = ftell(file); +#endif + + if (length < 0) + { + fclose(file); + return cgltf_result_io_error; + } + + fseek(file, 0, SEEK_SET); + file_size = (cgltf_size)length; + } + + char* file_data = (char*)memory_alloc(memory_options->user_data, file_size); + if (!file_data) + { + fclose(file); + return cgltf_result_out_of_memory; + } + + cgltf_size read_size = fread(file_data, 1, file_size, file); + + fclose(file); + + if (read_size != file_size) + { + memory_free(memory_options->user_data, file_data); + return cgltf_result_io_error; + } + + if (size) + { + *size = file_size; + } + if (data) + { + *data = file_data; + } + + return cgltf_result_success; +} + +static void cgltf_default_file_release(const struct cgltf_memory_options* memory_options, const struct cgltf_file_options* file_options, void* data) +{ + (void)file_options; + void (*memfree)(void*, void*) = memory_options->free ? memory_options->free : &cgltf_default_free; + memfree(memory_options->user_data, data); +} + +static cgltf_result cgltf_parse_json(cgltf_options* options, const uint8_t* json_chunk, cgltf_size size, cgltf_data** out_data); + +cgltf_result cgltf_parse(const cgltf_options* options, const void* data, cgltf_size size, cgltf_data** out_data) +{ + if (size < GlbHeaderSize) + { + return cgltf_result_data_too_short; + } + + if (options == NULL) + { + return cgltf_result_invalid_options; + } + + cgltf_options fixed_options = *options; + if (fixed_options.memory.alloc == NULL) + { + fixed_options.memory.alloc = &cgltf_default_alloc; + } + if (fixed_options.memory.free == NULL) + { + fixed_options.memory.free = &cgltf_default_free; + } + + uint32_t tmp; + // Magic + memcpy(&tmp, data, 4); + if (tmp != GlbMagic) + { + if (fixed_options.type == cgltf_file_type_invalid) + { + fixed_options.type = cgltf_file_type_gltf; + } + else if (fixed_options.type == cgltf_file_type_glb) + { + return cgltf_result_unknown_format; + } + } + + if (fixed_options.type == cgltf_file_type_gltf) + { + cgltf_result json_result = cgltf_parse_json(&fixed_options, (const uint8_t*)data, size, out_data); + if (json_result != cgltf_result_success) + { + return json_result; + } + + (*out_data)->file_type = cgltf_file_type_gltf; + + return cgltf_result_success; + } + + const uint8_t* ptr = (const uint8_t*)data; + // Version + memcpy(&tmp, ptr + 4, 4); + uint32_t version = tmp; + if (version != GlbVersion) + { + return version < GlbVersion ? cgltf_result_legacy_gltf : cgltf_result_unknown_format; + } + + // Total length + memcpy(&tmp, ptr + 8, 4); + if (tmp > size) + { + return cgltf_result_data_too_short; + } + + const uint8_t* json_chunk = ptr + GlbHeaderSize; + + if (GlbHeaderSize + GlbChunkHeaderSize > size) + { + return cgltf_result_data_too_short; + } + + // JSON chunk: length + uint32_t json_length; + memcpy(&json_length, json_chunk, 4); + if (GlbHeaderSize + GlbChunkHeaderSize + json_length > size) + { + return cgltf_result_data_too_short; + } + + // JSON chunk: magic + memcpy(&tmp, json_chunk + 4, 4); + if (tmp != GlbMagicJsonChunk) + { + return cgltf_result_unknown_format; + } + + json_chunk += GlbChunkHeaderSize; + + const void* bin = 0; + cgltf_size bin_size = 0; + + if (GlbHeaderSize + GlbChunkHeaderSize + json_length + GlbChunkHeaderSize <= size) + { + // We can read another chunk + const uint8_t* bin_chunk = json_chunk + json_length; + + // Bin chunk: length + uint32_t bin_length; + memcpy(&bin_length, bin_chunk, 4); + if (GlbHeaderSize + GlbChunkHeaderSize + json_length + GlbChunkHeaderSize + bin_length > size) + { + return cgltf_result_data_too_short; + } + + // Bin chunk: magic + memcpy(&tmp, bin_chunk + 4, 4); + if (tmp != GlbMagicBinChunk) + { + return cgltf_result_unknown_format; + } + + bin_chunk += GlbChunkHeaderSize; + + bin = bin_chunk; + bin_size = bin_length; + } + + cgltf_result json_result = cgltf_parse_json(&fixed_options, json_chunk, json_length, out_data); + if (json_result != cgltf_result_success) + { + return json_result; + } + + (*out_data)->file_type = cgltf_file_type_glb; + (*out_data)->bin = bin; + (*out_data)->bin_size = bin_size; + + return cgltf_result_success; +} + +cgltf_result cgltf_parse_file(const cgltf_options* options, const char* path, cgltf_data** out_data) +{ + if (options == NULL) + { + return cgltf_result_invalid_options; + } + + cgltf_result (*file_read)(const struct cgltf_memory_options*, const struct cgltf_file_options*, const char*, cgltf_size*, void**) = options->file.read ? options->file.read : &cgltf_default_file_read; + void (*file_release)(const struct cgltf_memory_options*, const struct cgltf_file_options*, void* data) = options->file.release ? options->file.release : cgltf_default_file_release; + + void* file_data = NULL; + cgltf_size file_size = 0; + cgltf_result result = file_read(&options->memory, &options->file, path, &file_size, &file_data); + if (result != cgltf_result_success) + { + return result; + } + + result = cgltf_parse(options, file_data, file_size, out_data); + + if (result != cgltf_result_success) + { + file_release(&options->memory, &options->file, file_data); + return result; + } + + (*out_data)->file_data = file_data; + + return cgltf_result_success; +} + +static void cgltf_combine_paths(char* path, const char* base, const char* uri) +{ + const char* s0 = strrchr(base, '/'); + const char* s1 = strrchr(base, '\\'); + const char* slash = s0 ? (s1 && s1 > s0 ? s1 : s0) : s1; + + if (slash) + { + size_t prefix = slash - base + 1; + + strncpy(path, base, prefix); + strcpy(path + prefix, uri); + } + else + { + strcpy(path, uri); + } +} + +static cgltf_result cgltf_load_buffer_file(const cgltf_options* options, cgltf_size size, const char* uri, const char* gltf_path, void** out_data) +{ + void* (*memory_alloc)(void*, cgltf_size) = options->memory.alloc ? options->memory.alloc : &cgltf_default_alloc; + void (*memory_free)(void*, void*) = options->memory.free ? options->memory.free : &cgltf_default_free; + cgltf_result (*file_read)(const struct cgltf_memory_options*, const struct cgltf_file_options*, const char*, cgltf_size*, void**) = options->file.read ? options->file.read : &cgltf_default_file_read; + + char* path = (char*)memory_alloc(options->memory.user_data, strlen(uri) + strlen(gltf_path) + 1); + if (!path) + { + return cgltf_result_out_of_memory; + } + + cgltf_combine_paths(path, gltf_path, uri); + + // after combining, the tail of the resulting path is a uri; decode_uri converts it into path + cgltf_decode_uri(path + strlen(path) - strlen(uri)); + + void* file_data = NULL; + cgltf_result result = file_read(&options->memory, &options->file, path, &size, &file_data); + + memory_free(options->memory.user_data, path); + + *out_data = (result == cgltf_result_success) ? file_data : NULL; + + return result; +} + +cgltf_result cgltf_load_buffer_base64(const cgltf_options* options, cgltf_size size, const char* base64, void** out_data) +{ + void* (*memory_alloc)(void*, cgltf_size) = options->memory.alloc ? options->memory.alloc : &cgltf_default_alloc; + void (*memory_free)(void*, void*) = options->memory.free ? options->memory.free : &cgltf_default_free; + + unsigned char* data = (unsigned char*)memory_alloc(options->memory.user_data, size); + if (!data) + { + return cgltf_result_out_of_memory; + } + + unsigned int buffer = 0; + unsigned int buffer_bits = 0; + + for (cgltf_size i = 0; i < size; ++i) + { + while (buffer_bits < 8) + { + char ch = *base64++; + + int index = + (unsigned)(ch - 'A') < 26 ? (ch - 'A') : + (unsigned)(ch - 'a') < 26 ? (ch - 'a') + 26 : + (unsigned)(ch - '0') < 10 ? (ch - '0') + 52 : + ch == '+' ? 62 : + ch == '/' ? 63 : + -1; + + if (index < 0) + { + memory_free(options->memory.user_data, data); + return cgltf_result_io_error; + } + + buffer = (buffer << 6) | index; + buffer_bits += 6; + } + + data[i] = (unsigned char)(buffer >> (buffer_bits - 8)); + buffer_bits -= 8; + } + + *out_data = data; + + return cgltf_result_success; +} + +static int cgltf_unhex(char ch) +{ + return + (unsigned)(ch - '0') < 10 ? (ch - '0') : + (unsigned)(ch - 'A') < 6 ? (ch - 'A') + 10 : + (unsigned)(ch - 'a') < 6 ? (ch - 'a') + 10 : + -1; +} + +void cgltf_decode_uri(char* uri) +{ + char* write = uri; + char* i = uri; + + while (*i) + { + if (*i == '%') + { + int ch1 = cgltf_unhex(i[1]); + + if (ch1 >= 0) + { + int ch2 = cgltf_unhex(i[2]); + + if (ch2 >= 0) + { + *write++ = (char)(ch1 * 16 + ch2); + i += 3; + continue; + } + } + } + + *write++ = *i++; + } + + *write = 0; +} + +cgltf_result cgltf_load_buffers(const cgltf_options* options, cgltf_data* data, const char* gltf_path) +{ + if (options == NULL) + { + return cgltf_result_invalid_options; + } + + if (data->buffers_count && data->buffers[0].data == NULL && data->buffers[0].uri == NULL && data->bin) + { + if (data->bin_size < data->buffers[0].size) + { + return cgltf_result_data_too_short; + } + + data->buffers[0].data = (void*)data->bin; + data->buffers[0].data_free_method = cgltf_data_free_method_none; + } + + for (cgltf_size i = 0; i < data->buffers_count; ++i) + { + if (data->buffers[i].data) + { + continue; + } + + const char* uri = data->buffers[i].uri; + + if (uri == NULL) + { + continue; + } + + if (strncmp(uri, "data:", 5) == 0) + { + const char* comma = strchr(uri, ','); + + if (comma && comma - uri >= 7 && strncmp(comma - 7, ";base64", 7) == 0) + { + cgltf_result res = cgltf_load_buffer_base64(options, data->buffers[i].size, comma + 1, &data->buffers[i].data); + data->buffers[i].data_free_method = cgltf_data_free_method_memory_free; + + if (res != cgltf_result_success) + { + return res; + } + } + else + { + return cgltf_result_unknown_format; + } + } + else if (strstr(uri, "://") == NULL && gltf_path) + { + cgltf_result res = cgltf_load_buffer_file(options, data->buffers[i].size, uri, gltf_path, &data->buffers[i].data); + data->buffers[i].data_free_method = cgltf_data_free_method_file_release; + + if (res != cgltf_result_success) + { + return res; + } + } + else + { + return cgltf_result_unknown_format; + } + } + + return cgltf_result_success; +} + +static cgltf_size cgltf_calc_size(cgltf_type type, cgltf_component_type component_type); + +static cgltf_size cgltf_calc_index_bound(cgltf_buffer_view* buffer_view, cgltf_size offset, cgltf_component_type component_type, cgltf_size count) +{ + char* data = (char*)buffer_view->buffer->data + offset + buffer_view->offset; + cgltf_size bound = 0; + + switch (component_type) + { + case cgltf_component_type_r_8u: + for (size_t i = 0; i < count; ++i) + { + cgltf_size v = ((unsigned char*)data)[i]; + bound = bound > v ? bound : v; + } + break; + + case cgltf_component_type_r_16u: + for (size_t i = 0; i < count; ++i) + { + cgltf_size v = ((unsigned short*)data)[i]; + bound = bound > v ? bound : v; + } + break; + + case cgltf_component_type_r_32u: + for (size_t i = 0; i < count; ++i) + { + cgltf_size v = ((unsigned int*)data)[i]; + bound = bound > v ? bound : v; + } + break; + + default: + ; + } + + return bound; +} + +#if CGLTF_VALIDATE_ENABLE_ASSERTS +#define CGLTF_ASSERT_IF(cond, result) assert(!(cond)); if (cond) return result; +#else +#define CGLTF_ASSERT_IF(cond, result) if (cond) return result; +#endif + +cgltf_result cgltf_validate(cgltf_data* data) +{ + for (cgltf_size i = 0; i < data->accessors_count; ++i) + { + cgltf_accessor* accessor = &data->accessors[i]; + + cgltf_size element_size = cgltf_calc_size(accessor->type, accessor->component_type); + + if (accessor->buffer_view) + { + cgltf_size req_size = accessor->offset + accessor->stride * (accessor->count - 1) + element_size; + + CGLTF_ASSERT_IF(accessor->buffer_view->size < req_size, cgltf_result_data_too_short); + } + + if (accessor->is_sparse) + { + cgltf_accessor_sparse* sparse = &accessor->sparse; + + cgltf_size indices_component_size = cgltf_calc_size(cgltf_type_scalar, sparse->indices_component_type); + cgltf_size indices_req_size = sparse->indices_byte_offset + indices_component_size * sparse->count; + cgltf_size values_req_size = sparse->values_byte_offset + element_size * sparse->count; + + CGLTF_ASSERT_IF(sparse->indices_buffer_view->size < indices_req_size || + sparse->values_buffer_view->size < values_req_size, cgltf_result_data_too_short); + + CGLTF_ASSERT_IF(sparse->indices_component_type != cgltf_component_type_r_8u && + sparse->indices_component_type != cgltf_component_type_r_16u && + sparse->indices_component_type != cgltf_component_type_r_32u, cgltf_result_invalid_gltf); + + if (sparse->indices_buffer_view->buffer->data) + { + cgltf_size index_bound = cgltf_calc_index_bound(sparse->indices_buffer_view, sparse->indices_byte_offset, sparse->indices_component_type, sparse->count); + + CGLTF_ASSERT_IF(index_bound >= accessor->count, cgltf_result_data_too_short); + } + } + } + + for (cgltf_size i = 0; i < data->buffer_views_count; ++i) + { + cgltf_size req_size = data->buffer_views[i].offset + data->buffer_views[i].size; + + CGLTF_ASSERT_IF(data->buffer_views[i].buffer && data->buffer_views[i].buffer->size < req_size, cgltf_result_data_too_short); + + if (data->buffer_views[i].has_meshopt_compression) + { + cgltf_meshopt_compression* mc = &data->buffer_views[i].meshopt_compression; + + CGLTF_ASSERT_IF(mc->buffer == NULL || mc->buffer->size < mc->offset + mc->size, cgltf_result_data_too_short); + + CGLTF_ASSERT_IF(data->buffer_views[i].stride && mc->stride != data->buffer_views[i].stride, cgltf_result_invalid_gltf); + + CGLTF_ASSERT_IF(data->buffer_views[i].size != mc->stride * mc->count, cgltf_result_invalid_gltf); + + CGLTF_ASSERT_IF(mc->mode == cgltf_meshopt_compression_mode_invalid, cgltf_result_invalid_gltf); + + CGLTF_ASSERT_IF(mc->mode == cgltf_meshopt_compression_mode_attributes && !(mc->stride % 4 == 0 && mc->stride <= 256), cgltf_result_invalid_gltf); + + CGLTF_ASSERT_IF(mc->mode == cgltf_meshopt_compression_mode_triangles && mc->count % 3 != 0, cgltf_result_invalid_gltf); + + CGLTF_ASSERT_IF((mc->mode == cgltf_meshopt_compression_mode_triangles || mc->mode == cgltf_meshopt_compression_mode_indices) && mc->stride != 2 && mc->stride != 4, cgltf_result_invalid_gltf); + + CGLTF_ASSERT_IF((mc->mode == cgltf_meshopt_compression_mode_triangles || mc->mode == cgltf_meshopt_compression_mode_indices) && mc->filter != cgltf_meshopt_compression_filter_none, cgltf_result_invalid_gltf); + + CGLTF_ASSERT_IF(mc->filter == cgltf_meshopt_compression_filter_octahedral && mc->stride != 4 && mc->stride != 8, cgltf_result_invalid_gltf); + + CGLTF_ASSERT_IF(mc->filter == cgltf_meshopt_compression_filter_quaternion && mc->stride != 8, cgltf_result_invalid_gltf); + } + } + + for (cgltf_size i = 0; i < data->meshes_count; ++i) + { + if (data->meshes[i].weights) + { + CGLTF_ASSERT_IF(data->meshes[i].primitives_count && data->meshes[i].primitives[0].targets_count != data->meshes[i].weights_count, cgltf_result_invalid_gltf); + } + + if (data->meshes[i].target_names) + { + CGLTF_ASSERT_IF(data->meshes[i].primitives_count && data->meshes[i].primitives[0].targets_count != data->meshes[i].target_names_count, cgltf_result_invalid_gltf); + } + + for (cgltf_size j = 0; j < data->meshes[i].primitives_count; ++j) + { + CGLTF_ASSERT_IF(data->meshes[i].primitives[j].targets_count != data->meshes[i].primitives[0].targets_count, cgltf_result_invalid_gltf); + + if (data->meshes[i].primitives[j].attributes_count) + { + cgltf_accessor* first = data->meshes[i].primitives[j].attributes[0].data; + + for (cgltf_size k = 0; k < data->meshes[i].primitives[j].attributes_count; ++k) + { + CGLTF_ASSERT_IF(data->meshes[i].primitives[j].attributes[k].data->count != first->count, cgltf_result_invalid_gltf); + } + + for (cgltf_size k = 0; k < data->meshes[i].primitives[j].targets_count; ++k) + { + for (cgltf_size m = 0; m < data->meshes[i].primitives[j].targets[k].attributes_count; ++m) + { + CGLTF_ASSERT_IF(data->meshes[i].primitives[j].targets[k].attributes[m].data->count != first->count, cgltf_result_invalid_gltf); + } + } + + cgltf_accessor* indices = data->meshes[i].primitives[j].indices; + + CGLTF_ASSERT_IF(indices && + indices->component_type != cgltf_component_type_r_8u && + indices->component_type != cgltf_component_type_r_16u && + indices->component_type != cgltf_component_type_r_32u, cgltf_result_invalid_gltf); + + if (indices && indices->buffer_view && indices->buffer_view->buffer->data) + { + cgltf_size index_bound = cgltf_calc_index_bound(indices->buffer_view, indices->offset, indices->component_type, indices->count); + + CGLTF_ASSERT_IF(index_bound >= first->count, cgltf_result_data_too_short); + } + + for (cgltf_size k = 0; k < data->meshes[i].primitives[j].mappings_count; ++k) + { + CGLTF_ASSERT_IF(data->meshes[i].primitives[j].mappings[k].variant >= data->variants_count, cgltf_result_invalid_gltf); + } + } + } + } + + for (cgltf_size i = 0; i < data->nodes_count; ++i) + { + if (data->nodes[i].weights && data->nodes[i].mesh) + { + CGLTF_ASSERT_IF (data->nodes[i].mesh->primitives_count && data->nodes[i].mesh->primitives[0].targets_count != data->nodes[i].weights_count, cgltf_result_invalid_gltf); + } + } + + for (cgltf_size i = 0; i < data->nodes_count; ++i) + { + cgltf_node* p1 = data->nodes[i].parent; + cgltf_node* p2 = p1 ? p1->parent : NULL; + + while (p1 && p2) + { + CGLTF_ASSERT_IF(p1 == p2, cgltf_result_invalid_gltf); + + p1 = p1->parent; + p2 = p2->parent ? p2->parent->parent : NULL; + } + } + + for (cgltf_size i = 0; i < data->scenes_count; ++i) + { + for (cgltf_size j = 0; j < data->scenes[i].nodes_count; ++j) + { + CGLTF_ASSERT_IF(data->scenes[i].nodes[j]->parent, cgltf_result_invalid_gltf); + } + } + + for (cgltf_size i = 0; i < data->animations_count; ++i) + { + for (cgltf_size j = 0; j < data->animations[i].channels_count; ++j) + { + cgltf_animation_channel* channel = &data->animations[i].channels[j]; + + if (!channel->target_node) + { + continue; + } + + cgltf_size components = 1; + + if (channel->target_path == cgltf_animation_path_type_weights) + { + CGLTF_ASSERT_IF(!channel->target_node->mesh || !channel->target_node->mesh->primitives_count, cgltf_result_invalid_gltf); + + components = channel->target_node->mesh->primitives[0].targets_count; + } + + cgltf_size values = channel->sampler->interpolation == cgltf_interpolation_type_cubic_spline ? 3 : 1; + + CGLTF_ASSERT_IF(channel->sampler->input->count * components * values != channel->sampler->output->count, cgltf_result_data_too_short); + } + } + + return cgltf_result_success; +} + +cgltf_result cgltf_copy_extras_json(const cgltf_data* data, const cgltf_extras* extras, char* dest, cgltf_size* dest_size) +{ + cgltf_size json_size = extras->end_offset - extras->start_offset; + + if (!dest) + { + if (dest_size) + { + *dest_size = json_size + 1; + return cgltf_result_success; + } + return cgltf_result_invalid_options; + } + + if (*dest_size + 1 < json_size) + { + strncpy(dest, data->json + extras->start_offset, *dest_size - 1); + dest[*dest_size - 1] = 0; + } + else + { + strncpy(dest, data->json + extras->start_offset, json_size); + dest[json_size] = 0; + } + + return cgltf_result_success; +} + +void cgltf_free_extensions(cgltf_data* data, cgltf_extension* extensions, cgltf_size extensions_count) +{ + for (cgltf_size i = 0; i < extensions_count; ++i) + { + data->memory.free(data->memory.user_data, extensions[i].name); + data->memory.free(data->memory.user_data, extensions[i].data); + } + data->memory.free(data->memory.user_data, extensions); +} + +void cgltf_free(cgltf_data* data) +{ + if (!data) + { + return; + } + + void (*file_release)(const struct cgltf_memory_options*, const struct cgltf_file_options*, void* data) = data->file.release ? data->file.release : cgltf_default_file_release; + + data->memory.free(data->memory.user_data, data->asset.copyright); + data->memory.free(data->memory.user_data, data->asset.generator); + data->memory.free(data->memory.user_data, data->asset.version); + data->memory.free(data->memory.user_data, data->asset.min_version); + + cgltf_free_extensions(data, data->asset.extensions, data->asset.extensions_count); + + for (cgltf_size i = 0; i < data->accessors_count; ++i) + { + data->memory.free(data->memory.user_data, data->accessors[i].name); + + if(data->accessors[i].is_sparse) + { + cgltf_free_extensions(data, data->accessors[i].sparse.extensions, data->accessors[i].sparse.extensions_count); + cgltf_free_extensions(data, data->accessors[i].sparse.indices_extensions, data->accessors[i].sparse.indices_extensions_count); + cgltf_free_extensions(data, data->accessors[i].sparse.values_extensions, data->accessors[i].sparse.values_extensions_count); + } + cgltf_free_extensions(data, data->accessors[i].extensions, data->accessors[i].extensions_count); + } + data->memory.free(data->memory.user_data, data->accessors); + + for (cgltf_size i = 0; i < data->buffer_views_count; ++i) + { + data->memory.free(data->memory.user_data, data->buffer_views[i].name); + data->memory.free(data->memory.user_data, data->buffer_views[i].data); + + cgltf_free_extensions(data, data->buffer_views[i].extensions, data->buffer_views[i].extensions_count); + } + data->memory.free(data->memory.user_data, data->buffer_views); + + for (cgltf_size i = 0; i < data->buffers_count; ++i) + { + data->memory.free(data->memory.user_data, data->buffers[i].name); + + if (data->buffers[i].data_free_method == cgltf_data_free_method_file_release) + { + file_release(&data->memory, &data->file, data->buffers[i].data); + } + else if (data->buffers[i].data_free_method == cgltf_data_free_method_memory_free) + { + data->memory.free(data->memory.user_data, data->buffers[i].data); + } + + data->memory.free(data->memory.user_data, data->buffers[i].uri); + + cgltf_free_extensions(data, data->buffers[i].extensions, data->buffers[i].extensions_count); + } + + data->memory.free(data->memory.user_data, data->buffers); + + for (cgltf_size i = 0; i < data->meshes_count; ++i) + { + data->memory.free(data->memory.user_data, data->meshes[i].name); + + for (cgltf_size j = 0; j < data->meshes[i].primitives_count; ++j) + { + for (cgltf_size k = 0; k < data->meshes[i].primitives[j].attributes_count; ++k) + { + data->memory.free(data->memory.user_data, data->meshes[i].primitives[j].attributes[k].name); + } + + data->memory.free(data->memory.user_data, data->meshes[i].primitives[j].attributes); + + for (cgltf_size k = 0; k < data->meshes[i].primitives[j].targets_count; ++k) + { + for (cgltf_size m = 0; m < data->meshes[i].primitives[j].targets[k].attributes_count; ++m) + { + data->memory.free(data->memory.user_data, data->meshes[i].primitives[j].targets[k].attributes[m].name); + } + + data->memory.free(data->memory.user_data, data->meshes[i].primitives[j].targets[k].attributes); + } + + data->memory.free(data->memory.user_data, data->meshes[i].primitives[j].targets); + + if (data->meshes[i].primitives[j].has_draco_mesh_compression) + { + for (cgltf_size k = 0; k < data->meshes[i].primitives[j].draco_mesh_compression.attributes_count; ++k) + { + data->memory.free(data->memory.user_data, data->meshes[i].primitives[j].draco_mesh_compression.attributes[k].name); + } + + data->memory.free(data->memory.user_data, data->meshes[i].primitives[j].draco_mesh_compression.attributes); + } + + data->memory.free(data->memory.user_data, data->meshes[i].primitives[j].mappings); + + cgltf_free_extensions(data, data->meshes[i].primitives[j].extensions, data->meshes[i].primitives[j].extensions_count); + } + + data->memory.free(data->memory.user_data, data->meshes[i].primitives); + data->memory.free(data->memory.user_data, data->meshes[i].weights); + + for (cgltf_size j = 0; j < data->meshes[i].target_names_count; ++j) + { + data->memory.free(data->memory.user_data, data->meshes[i].target_names[j]); + } + + cgltf_free_extensions(data, data->meshes[i].extensions, data->meshes[i].extensions_count); + + data->memory.free(data->memory.user_data, data->meshes[i].target_names); + } + + data->memory.free(data->memory.user_data, data->meshes); + + for (cgltf_size i = 0; i < data->materials_count; ++i) + { + data->memory.free(data->memory.user_data, data->materials[i].name); + + if(data->materials[i].has_pbr_metallic_roughness) + { + cgltf_free_extensions(data, data->materials[i].pbr_metallic_roughness.metallic_roughness_texture.extensions, data->materials[i].pbr_metallic_roughness.metallic_roughness_texture.extensions_count); + cgltf_free_extensions(data, data->materials[i].pbr_metallic_roughness.base_color_texture.extensions, data->materials[i].pbr_metallic_roughness.base_color_texture.extensions_count); + } + if(data->materials[i].has_pbr_specular_glossiness) + { + cgltf_free_extensions(data, data->materials[i].pbr_specular_glossiness.diffuse_texture.extensions, data->materials[i].pbr_specular_glossiness.diffuse_texture.extensions_count); + cgltf_free_extensions(data, data->materials[i].pbr_specular_glossiness.specular_glossiness_texture.extensions, data->materials[i].pbr_specular_glossiness.specular_glossiness_texture.extensions_count); + } + if(data->materials[i].has_clearcoat) + { + cgltf_free_extensions(data, data->materials[i].clearcoat.clearcoat_texture.extensions, data->materials[i].clearcoat.clearcoat_texture.extensions_count); + cgltf_free_extensions(data, data->materials[i].clearcoat.clearcoat_roughness_texture.extensions, data->materials[i].clearcoat.clearcoat_roughness_texture.extensions_count); + cgltf_free_extensions(data, data->materials[i].clearcoat.clearcoat_normal_texture.extensions, data->materials[i].clearcoat.clearcoat_normal_texture.extensions_count); + } + if(data->materials[i].has_specular) + { + cgltf_free_extensions(data, data->materials[i].specular.specular_texture.extensions, data->materials[i].specular.specular_texture.extensions_count); + cgltf_free_extensions(data, data->materials[i].specular.specular_color_texture.extensions, data->materials[i].specular.specular_color_texture.extensions_count); + } + if(data->materials[i].has_transmission) + { + cgltf_free_extensions(data, data->materials[i].transmission.transmission_texture.extensions, data->materials[i].transmission.transmission_texture.extensions_count); + } + if (data->materials[i].has_volume) + { + cgltf_free_extensions(data, data->materials[i].volume.thickness_texture.extensions, data->materials[i].volume.thickness_texture.extensions_count); + } + if(data->materials[i].has_sheen) + { + cgltf_free_extensions(data, data->materials[i].sheen.sheen_color_texture.extensions, data->materials[i].sheen.sheen_color_texture.extensions_count); + cgltf_free_extensions(data, data->materials[i].sheen.sheen_roughness_texture.extensions, data->materials[i].sheen.sheen_roughness_texture.extensions_count); + } + + cgltf_free_extensions(data, data->materials[i].normal_texture.extensions, data->materials[i].normal_texture.extensions_count); + cgltf_free_extensions(data, data->materials[i].occlusion_texture.extensions, data->materials[i].occlusion_texture.extensions_count); + cgltf_free_extensions(data, data->materials[i].emissive_texture.extensions, data->materials[i].emissive_texture.extensions_count); + + cgltf_free_extensions(data, data->materials[i].extensions, data->materials[i].extensions_count); + } + + data->memory.free(data->memory.user_data, data->materials); + + for (cgltf_size i = 0; i < data->images_count; ++i) + { + data->memory.free(data->memory.user_data, data->images[i].name); + data->memory.free(data->memory.user_data, data->images[i].uri); + data->memory.free(data->memory.user_data, data->images[i].mime_type); + + cgltf_free_extensions(data, data->images[i].extensions, data->images[i].extensions_count); + } + + data->memory.free(data->memory.user_data, data->images); + + for (cgltf_size i = 0; i < data->textures_count; ++i) + { + data->memory.free(data->memory.user_data, data->textures[i].name); + cgltf_free_extensions(data, data->textures[i].extensions, data->textures[i].extensions_count); + } + + data->memory.free(data->memory.user_data, data->textures); + + for (cgltf_size i = 0; i < data->samplers_count; ++i) + { + data->memory.free(data->memory.user_data, data->samplers[i].name); + cgltf_free_extensions(data, data->samplers[i].extensions, data->samplers[i].extensions_count); + } + + data->memory.free(data->memory.user_data, data->samplers); + + for (cgltf_size i = 0; i < data->skins_count; ++i) + { + data->memory.free(data->memory.user_data, data->skins[i].name); + data->memory.free(data->memory.user_data, data->skins[i].joints); + + cgltf_free_extensions(data, data->skins[i].extensions, data->skins[i].extensions_count); + } + + data->memory.free(data->memory.user_data, data->skins); + + for (cgltf_size i = 0; i < data->cameras_count; ++i) + { + data->memory.free(data->memory.user_data, data->cameras[i].name); + cgltf_free_extensions(data, data->cameras[i].extensions, data->cameras[i].extensions_count); + } + + data->memory.free(data->memory.user_data, data->cameras); + + for (cgltf_size i = 0; i < data->lights_count; ++i) + { + data->memory.free(data->memory.user_data, data->lights[i].name); + } + + data->memory.free(data->memory.user_data, data->lights); + + for (cgltf_size i = 0; i < data->nodes_count; ++i) + { + data->memory.free(data->memory.user_data, data->nodes[i].name); + data->memory.free(data->memory.user_data, data->nodes[i].children); + data->memory.free(data->memory.user_data, data->nodes[i].weights); + cgltf_free_extensions(data, data->nodes[i].extensions, data->nodes[i].extensions_count); + } + + data->memory.free(data->memory.user_data, data->nodes); + + for (cgltf_size i = 0; i < data->scenes_count; ++i) + { + data->memory.free(data->memory.user_data, data->scenes[i].name); + data->memory.free(data->memory.user_data, data->scenes[i].nodes); + + cgltf_free_extensions(data, data->scenes[i].extensions, data->scenes[i].extensions_count); + } + + data->memory.free(data->memory.user_data, data->scenes); + + for (cgltf_size i = 0; i < data->animations_count; ++i) + { + data->memory.free(data->memory.user_data, data->animations[i].name); + for (cgltf_size j = 0; j < data->animations[i].samplers_count; ++j) + { + cgltf_free_extensions(data, data->animations[i].samplers[j].extensions, data->animations[i].samplers[j].extensions_count); + } + data->memory.free(data->memory.user_data, data->animations[i].samplers); + + for (cgltf_size j = 0; j < data->animations[i].channels_count; ++j) + { + cgltf_free_extensions(data, data->animations[i].channels[j].extensions, data->animations[i].channels[j].extensions_count); + } + data->memory.free(data->memory.user_data, data->animations[i].channels); + + cgltf_free_extensions(data, data->animations[i].extensions, data->animations[i].extensions_count); + } + + data->memory.free(data->memory.user_data, data->animations); + + for (cgltf_size i = 0; i < data->variants_count; ++i) + { + data->memory.free(data->memory.user_data, data->variants[i].name); + } + + data->memory.free(data->memory.user_data, data->variants); + + cgltf_free_extensions(data, data->data_extensions, data->data_extensions_count); + + for (cgltf_size i = 0; i < data->extensions_used_count; ++i) + { + data->memory.free(data->memory.user_data, data->extensions_used[i]); + } + + data->memory.free(data->memory.user_data, data->extensions_used); + + for (cgltf_size i = 0; i < data->extensions_required_count; ++i) + { + data->memory.free(data->memory.user_data, data->extensions_required[i]); + } + + data->memory.free(data->memory.user_data, data->extensions_required); + + file_release(&data->memory, &data->file, data->file_data); + + data->memory.free(data->memory.user_data, data); +} + +void cgltf_node_transform_local(const cgltf_node* node, cgltf_float* out_matrix) +{ + cgltf_float* lm = out_matrix; + + if (node->has_matrix) + { + memcpy(lm, node->matrix, sizeof(float) * 16); + } + else + { + float tx = node->translation[0]; + float ty = node->translation[1]; + float tz = node->translation[2]; + + float qx = node->rotation[0]; + float qy = node->rotation[1]; + float qz = node->rotation[2]; + float qw = node->rotation[3]; + + float sx = node->scale[0]; + float sy = node->scale[1]; + float sz = node->scale[2]; + + lm[0] = (1 - 2 * qy*qy - 2 * qz*qz) * sx; + lm[1] = (2 * qx*qy + 2 * qz*qw) * sx; + lm[2] = (2 * qx*qz - 2 * qy*qw) * sx; + lm[3] = 0.f; + + lm[4] = (2 * qx*qy - 2 * qz*qw) * sy; + lm[5] = (1 - 2 * qx*qx - 2 * qz*qz) * sy; + lm[6] = (2 * qy*qz + 2 * qx*qw) * sy; + lm[7] = 0.f; + + lm[8] = (2 * qx*qz + 2 * qy*qw) * sz; + lm[9] = (2 * qy*qz - 2 * qx*qw) * sz; + lm[10] = (1 - 2 * qx*qx - 2 * qy*qy) * sz; + lm[11] = 0.f; + + lm[12] = tx; + lm[13] = ty; + lm[14] = tz; + lm[15] = 1.f; + } +} + +void cgltf_node_transform_world(const cgltf_node* node, cgltf_float* out_matrix) +{ + cgltf_float* lm = out_matrix; + cgltf_node_transform_local(node, lm); + + const cgltf_node* parent = node->parent; + + while (parent) + { + float pm[16]; + cgltf_node_transform_local(parent, pm); + + for (int i = 0; i < 4; ++i) + { + float l0 = lm[i * 4 + 0]; + float l1 = lm[i * 4 + 1]; + float l2 = lm[i * 4 + 2]; + + float r0 = l0 * pm[0] + l1 * pm[4] + l2 * pm[8]; + float r1 = l0 * pm[1] + l1 * pm[5] + l2 * pm[9]; + float r2 = l0 * pm[2] + l1 * pm[6] + l2 * pm[10]; + + lm[i * 4 + 0] = r0; + lm[i * 4 + 1] = r1; + lm[i * 4 + 2] = r2; + } + + lm[12] += pm[12]; + lm[13] += pm[13]; + lm[14] += pm[14]; + + parent = parent->parent; + } +} + +static cgltf_size cgltf_component_read_index(const void* in, cgltf_component_type component_type) +{ + switch (component_type) + { + case cgltf_component_type_r_16: + return *((const int16_t*) in); + case cgltf_component_type_r_16u: + return *((const uint16_t*) in); + case cgltf_component_type_r_32u: + return *((const uint32_t*) in); + case cgltf_component_type_r_32f: + return (cgltf_size)*((const float*) in); + case cgltf_component_type_r_8: + return *((const int8_t*) in); + case cgltf_component_type_r_8u: + return *((const uint8_t*) in); + default: + return 0; + } +} + +static cgltf_float cgltf_component_read_float(const void* in, cgltf_component_type component_type, cgltf_bool normalized) +{ + if (component_type == cgltf_component_type_r_32f) + { + return *((const float*) in); + } + + if (normalized) + { + switch (component_type) + { + // note: glTF spec doesn't currently define normalized conversions for 32-bit integers + case cgltf_component_type_r_16: + return *((const int16_t*) in) / (cgltf_float)32767; + case cgltf_component_type_r_16u: + return *((const uint16_t*) in) / (cgltf_float)65535; + case cgltf_component_type_r_8: + return *((const int8_t*) in) / (cgltf_float)127; + case cgltf_component_type_r_8u: + return *((const uint8_t*) in) / (cgltf_float)255; + default: + return 0; + } + } + + return (cgltf_float)cgltf_component_read_index(in, component_type); +} + +static cgltf_size cgltf_component_size(cgltf_component_type component_type); + +static cgltf_bool cgltf_element_read_float(const uint8_t* element, cgltf_type type, cgltf_component_type component_type, cgltf_bool normalized, cgltf_float* out, cgltf_size element_size) +{ + cgltf_size num_components = cgltf_num_components(type); + + if (element_size < num_components) { + return 0; + } + + // There are three special cases for component extraction, see #data-alignment in the 2.0 spec. + + cgltf_size component_size = cgltf_component_size(component_type); + + if (type == cgltf_type_mat2 && component_size == 1) + { + out[0] = cgltf_component_read_float(element, component_type, normalized); + out[1] = cgltf_component_read_float(element + 1, component_type, normalized); + out[2] = cgltf_component_read_float(element + 4, component_type, normalized); + out[3] = cgltf_component_read_float(element + 5, component_type, normalized); + return 1; + } + + if (type == cgltf_type_mat3 && component_size == 1) + { + out[0] = cgltf_component_read_float(element, component_type, normalized); + out[1] = cgltf_component_read_float(element + 1, component_type, normalized); + out[2] = cgltf_component_read_float(element + 2, component_type, normalized); + out[3] = cgltf_component_read_float(element + 4, component_type, normalized); + out[4] = cgltf_component_read_float(element + 5, component_type, normalized); + out[5] = cgltf_component_read_float(element + 6, component_type, normalized); + out[6] = cgltf_component_read_float(element + 8, component_type, normalized); + out[7] = cgltf_component_read_float(element + 9, component_type, normalized); + out[8] = cgltf_component_read_float(element + 10, component_type, normalized); + return 1; + } + + if (type == cgltf_type_mat3 && component_size == 2) + { + out[0] = cgltf_component_read_float(element, component_type, normalized); + out[1] = cgltf_component_read_float(element + 2, component_type, normalized); + out[2] = cgltf_component_read_float(element + 4, component_type, normalized); + out[3] = cgltf_component_read_float(element + 8, component_type, normalized); + out[4] = cgltf_component_read_float(element + 10, component_type, normalized); + out[5] = cgltf_component_read_float(element + 12, component_type, normalized); + out[6] = cgltf_component_read_float(element + 16, component_type, normalized); + out[7] = cgltf_component_read_float(element + 18, component_type, normalized); + out[8] = cgltf_component_read_float(element + 20, component_type, normalized); + return 1; + } + + for (cgltf_size i = 0; i < num_components; ++i) + { + out[i] = cgltf_component_read_float(element + component_size * i, component_type, normalized); + } + return 1; +} + +const uint8_t* cgltf_buffer_view_data(const cgltf_buffer_view* view) +{ + if (view->data) + return (const uint8_t*)view->data; + + if (!view->buffer->data) + return NULL; + + const uint8_t* result = (const uint8_t*)view->buffer->data; + result += view->offset; + return result; +} + +cgltf_bool cgltf_accessor_read_float(const cgltf_accessor* accessor, cgltf_size index, cgltf_float* out, cgltf_size element_size) +{ + if (accessor->is_sparse) + { + return 0; + } + if (accessor->buffer_view == NULL) + { + memset(out, 0, element_size * sizeof(cgltf_float)); + return 1; + } + const uint8_t* element = cgltf_buffer_view_data(accessor->buffer_view); + if (element == NULL) + { + return 0; + } + element += accessor->offset + accessor->stride * index; + return cgltf_element_read_float(element, accessor->type, accessor->component_type, accessor->normalized, out, element_size); +} + +cgltf_size cgltf_accessor_unpack_floats(const cgltf_accessor* accessor, cgltf_float* out, cgltf_size float_count) +{ + cgltf_size floats_per_element = cgltf_num_components(accessor->type); + cgltf_size available_floats = accessor->count * floats_per_element; + if (out == NULL) + { + return available_floats; + } + + float_count = available_floats < float_count ? available_floats : float_count; + cgltf_size element_count = float_count / floats_per_element; + + // First pass: convert each element in the base accessor. + cgltf_float* dest = out; + cgltf_accessor dense = *accessor; + dense.is_sparse = 0; + for (cgltf_size index = 0; index < element_count; index++, dest += floats_per_element) + { + if (!cgltf_accessor_read_float(&dense, index, dest, floats_per_element)) + { + return 0; + } + } + + // Second pass: write out each element in the sparse accessor. + if (accessor->is_sparse) + { + const cgltf_accessor_sparse* sparse = &dense.sparse; + + const uint8_t* index_data = cgltf_buffer_view_data(sparse->indices_buffer_view); + const uint8_t* reader_head = cgltf_buffer_view_data(sparse->values_buffer_view); + + if (index_data == NULL || reader_head == NULL) + { + return 0; + } + + index_data += sparse->indices_byte_offset; + reader_head += sparse->values_byte_offset; + + cgltf_size index_stride = cgltf_component_size(sparse->indices_component_type); + for (cgltf_size reader_index = 0; reader_index < sparse->count; reader_index++, index_data += index_stride) + { + size_t writer_index = cgltf_component_read_index(index_data, sparse->indices_component_type); + float* writer_head = out + writer_index * floats_per_element; + + if (!cgltf_element_read_float(reader_head, dense.type, dense.component_type, dense.normalized, writer_head, floats_per_element)) + { + return 0; + } + + reader_head += dense.stride; + } + } + + return element_count * floats_per_element; +} + +static cgltf_uint cgltf_component_read_uint(const void* in, cgltf_component_type component_type) +{ + switch (component_type) + { + case cgltf_component_type_r_8: + return *((const int8_t*) in); + + case cgltf_component_type_r_8u: + return *((const uint8_t*) in); + + case cgltf_component_type_r_16: + return *((const int16_t*) in); + + case cgltf_component_type_r_16u: + return *((const uint16_t*) in); + + case cgltf_component_type_r_32u: + return *((const uint32_t*) in); + + default: + return 0; + } +} + +static cgltf_bool cgltf_element_read_uint(const uint8_t* element, cgltf_type type, cgltf_component_type component_type, cgltf_uint* out, cgltf_size element_size) +{ + cgltf_size num_components = cgltf_num_components(type); + + if (element_size < num_components) + { + return 0; + } + + // Reading integer matrices is not a valid use case + if (type == cgltf_type_mat2 || type == cgltf_type_mat3 || type == cgltf_type_mat4) + { + return 0; + } + + cgltf_size component_size = cgltf_component_size(component_type); + + for (cgltf_size i = 0; i < num_components; ++i) + { + out[i] = cgltf_component_read_uint(element + component_size * i, component_type); + } + return 1; +} + +cgltf_bool cgltf_accessor_read_uint(const cgltf_accessor* accessor, cgltf_size index, cgltf_uint* out, cgltf_size element_size) +{ + if (accessor->is_sparse) + { + return 0; + } + if (accessor->buffer_view == NULL) + { + memset(out, 0, element_size * sizeof( cgltf_uint )); + return 1; + } + const uint8_t* element = cgltf_buffer_view_data(accessor->buffer_view); + if (element == NULL) + { + return 0; + } + element += accessor->offset + accessor->stride * index; + return cgltf_element_read_uint(element, accessor->type, accessor->component_type, out, element_size); +} + +cgltf_size cgltf_accessor_read_index(const cgltf_accessor* accessor, cgltf_size index) +{ + if (accessor->is_sparse) + { + return 0; // This is an error case, but we can't communicate the error with existing interface. + } + if (accessor->buffer_view == NULL) + { + return 0; + } + const uint8_t* element = cgltf_buffer_view_data(accessor->buffer_view); + if (element == NULL) + { + return 0; // This is an error case, but we can't communicate the error with existing interface. + } + element += accessor->offset + accessor->stride * index; + return cgltf_component_read_index(element, accessor->component_type); +} + +#define CGLTF_ERROR_JSON -1 +#define CGLTF_ERROR_NOMEM -2 +#define CGLTF_ERROR_LEGACY -3 + +#define CGLTF_CHECK_TOKTYPE(tok_, type_) if ((tok_).type != (type_)) { return CGLTF_ERROR_JSON; } +#define CGLTF_CHECK_TOKTYPE_RETTYPE(tok_, type_, ret_) if ((tok_).type != (type_)) { return (ret_)CGLTF_ERROR_JSON; } +#define CGLTF_CHECK_KEY(tok_) if ((tok_).type != JSMN_STRING || (tok_).size == 0) { return CGLTF_ERROR_JSON; } /* checking size for 0 verifies that a value follows the key */ + +#define CGLTF_PTRINDEX(type, idx) (type*)((cgltf_size)idx + 1) +#define CGLTF_PTRFIXUP(var, data, size) if (var) { if ((cgltf_size)var > size) { return CGLTF_ERROR_JSON; } var = &data[(cgltf_size)var-1]; } +#define CGLTF_PTRFIXUP_REQ(var, data, size) if (!var || (cgltf_size)var > size) { return CGLTF_ERROR_JSON; } var = &data[(cgltf_size)var-1]; + +static int cgltf_json_strcmp(jsmntok_t const* tok, const uint8_t* json_chunk, const char* str) +{ + CGLTF_CHECK_TOKTYPE(*tok, JSMN_STRING); + size_t const str_len = strlen(str); + size_t const name_length = tok->end - tok->start; + return (str_len == name_length) ? strncmp((const char*)json_chunk + tok->start, str, str_len) : 128; +} + +static int cgltf_json_to_int(jsmntok_t const* tok, const uint8_t* json_chunk) +{ + CGLTF_CHECK_TOKTYPE(*tok, JSMN_PRIMITIVE); + char tmp[128]; + int size = (cgltf_size)(tok->end - tok->start) < sizeof(tmp) ? tok->end - tok->start : (int)(sizeof(tmp) - 1); + strncpy(tmp, (const char*)json_chunk + tok->start, size); + tmp[size] = 0; + return CGLTF_ATOI(tmp); +} + +static cgltf_size cgltf_json_to_size(jsmntok_t const* tok, const uint8_t* json_chunk) +{ + CGLTF_CHECK_TOKTYPE_RETTYPE(*tok, JSMN_PRIMITIVE, cgltf_size); + char tmp[128]; + int size = (cgltf_size)(tok->end - tok->start) < sizeof(tmp) ? tok->end - tok->start : (int)(sizeof(tmp) - 1); + strncpy(tmp, (const char*)json_chunk + tok->start, size); + tmp[size] = 0; + return (cgltf_size)CGLTF_ATOLL(tmp); +} + +static cgltf_float cgltf_json_to_float(jsmntok_t const* tok, const uint8_t* json_chunk) +{ + CGLTF_CHECK_TOKTYPE(*tok, JSMN_PRIMITIVE); + char tmp[128]; + int size = (cgltf_size)(tok->end - tok->start) < sizeof(tmp) ? tok->end - tok->start : (int)(sizeof(tmp) - 1); + strncpy(tmp, (const char*)json_chunk + tok->start, size); + tmp[size] = 0; + return (cgltf_float)CGLTF_ATOF(tmp); +} + +static cgltf_bool cgltf_json_to_bool(jsmntok_t const* tok, const uint8_t* json_chunk) +{ + int size = tok->end - tok->start; + return size == 4 && memcmp(json_chunk + tok->start, "true", 4) == 0; +} + +static int cgltf_skip_json(jsmntok_t const* tokens, int i) +{ + int end = i + 1; + + while (i < end) + { + switch (tokens[i].type) + { + case JSMN_OBJECT: + end += tokens[i].size * 2; + break; + + case JSMN_ARRAY: + end += tokens[i].size; + break; + + case JSMN_PRIMITIVE: + case JSMN_STRING: + break; + + default: + return -1; + } + + i++; + } + + return i; +} + +static void cgltf_fill_float_array(float* out_array, int size, float value) +{ + for (int j = 0; j < size; ++j) + { + out_array[j] = value; + } +} + +static int cgltf_parse_json_float_array(jsmntok_t const* tokens, int i, const uint8_t* json_chunk, float* out_array, int size) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_ARRAY); + if (tokens[i].size != size) + { + return CGLTF_ERROR_JSON; + } + ++i; + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_PRIMITIVE); + out_array[j] = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + return i; +} + +static int cgltf_parse_json_string(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, char** out_string) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_STRING); + if (*out_string) + { + return CGLTF_ERROR_JSON; + } + int size = tokens[i].end - tokens[i].start; + char* result = (char*)options->memory.alloc(options->memory.user_data, size + 1); + if (!result) + { + return CGLTF_ERROR_NOMEM; + } + strncpy(result, (const char*)json_chunk + tokens[i].start, size); + result[size] = 0; + *out_string = result; + return i + 1; +} + +static int cgltf_parse_json_array(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, size_t element_size, void** out_array, cgltf_size* out_size) +{ + (void)json_chunk; + if (tokens[i].type != JSMN_ARRAY) + { + return tokens[i].type == JSMN_OBJECT ? CGLTF_ERROR_LEGACY : CGLTF_ERROR_JSON; + } + if (*out_array) + { + return CGLTF_ERROR_JSON; + } + int size = tokens[i].size; + void* result = cgltf_calloc(options, element_size, size); + if (!result) + { + return CGLTF_ERROR_NOMEM; + } + *out_array = result; + *out_size = size; + return i + 1; +} + +static int cgltf_parse_json_string_array(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, char*** out_array, cgltf_size* out_size) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_ARRAY); + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(char*), (void**)out_array, out_size); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < *out_size; ++j) + { + i = cgltf_parse_json_string(options, tokens, i, json_chunk, j + (*out_array)); + if (i < 0) + { + return i; + } + } + return i; +} + +static void cgltf_parse_attribute_type(const char* name, cgltf_attribute_type* out_type, int* out_index) +{ + const char* us = strchr(name, '_'); + size_t len = us ? (size_t)(us - name) : strlen(name); + + if (len == 8 && strncmp(name, "POSITION", 8) == 0) + { + *out_type = cgltf_attribute_type_position; + } + else if (len == 6 && strncmp(name, "NORMAL", 6) == 0) + { + *out_type = cgltf_attribute_type_normal; + } + else if (len == 7 && strncmp(name, "TANGENT", 7) == 0) + { + *out_type = cgltf_attribute_type_tangent; + } + else if (len == 8 && strncmp(name, "TEXCOORD", 8) == 0) + { + *out_type = cgltf_attribute_type_texcoord; + } + else if (len == 5 && strncmp(name, "COLOR", 5) == 0) + { + *out_type = cgltf_attribute_type_color; + } + else if (len == 6 && strncmp(name, "JOINTS", 6) == 0) + { + *out_type = cgltf_attribute_type_joints; + } + else if (len == 7 && strncmp(name, "WEIGHTS", 7) == 0) + { + *out_type = cgltf_attribute_type_weights; + } + else + { + *out_type = cgltf_attribute_type_invalid; + } + + if (us && *out_type != cgltf_attribute_type_invalid) + { + *out_index = CGLTF_ATOI(us + 1); + } +} + +static int cgltf_parse_json_attribute_list(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_attribute** out_attributes, cgltf_size* out_attributes_count) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + if (*out_attributes) + { + return CGLTF_ERROR_JSON; + } + + *out_attributes_count = tokens[i].size; + *out_attributes = (cgltf_attribute*)cgltf_calloc(options, sizeof(cgltf_attribute), *out_attributes_count); + ++i; + + if (!*out_attributes) + { + return CGLTF_ERROR_NOMEM; + } + + for (cgltf_size j = 0; j < *out_attributes_count; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + i = cgltf_parse_json_string(options, tokens, i, json_chunk, &(*out_attributes)[j].name); + if (i < 0) + { + return CGLTF_ERROR_JSON; + } + + cgltf_parse_attribute_type((*out_attributes)[j].name, &(*out_attributes)[j].type, &(*out_attributes)[j].index); + + (*out_attributes)[j].data = CGLTF_PTRINDEX(cgltf_accessor, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + + return i; +} + +static int cgltf_parse_json_extras(jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_extras* out_extras) +{ + (void)json_chunk; + out_extras->start_offset = tokens[i].start; + out_extras->end_offset = tokens[i].end; + i = cgltf_skip_json(tokens, i); + return i; +} + +static int cgltf_parse_json_unprocessed_extension(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_extension* out_extension) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_STRING); + CGLTF_CHECK_TOKTYPE(tokens[i+1], JSMN_OBJECT); + if (out_extension->name) + { + return CGLTF_ERROR_JSON; + } + + cgltf_size name_length = tokens[i].end - tokens[i].start; + out_extension->name = (char*)options->memory.alloc(options->memory.user_data, name_length + 1); + if (!out_extension->name) + { + return CGLTF_ERROR_NOMEM; + } + strncpy(out_extension->name, (const char*)json_chunk + tokens[i].start, name_length); + out_extension->name[name_length] = 0; + i++; + + size_t start = tokens[i].start; + size_t size = tokens[i].end - start; + out_extension->data = (char*)options->memory.alloc(options->memory.user_data, size + 1); + if (!out_extension->data) + { + return CGLTF_ERROR_NOMEM; + } + strncpy(out_extension->data, (const char*)json_chunk + start, size); + out_extension->data[size] = '\0'; + + i = cgltf_skip_json(tokens, i); + + return i; +} + +static int cgltf_parse_json_unprocessed_extensions(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_size* out_extensions_count, cgltf_extension** out_extensions) +{ + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + if(*out_extensions) + { + return CGLTF_ERROR_JSON; + } + + int extensions_size = tokens[i].size; + *out_extensions_count = 0; + *out_extensions = (cgltf_extension*)cgltf_calloc(options, sizeof(cgltf_extension), extensions_size); + + if (!*out_extensions) + { + return CGLTF_ERROR_NOMEM; + } + + ++i; + + for (int j = 0; j < extensions_size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + cgltf_size extension_index = (*out_extensions_count)++; + cgltf_extension* extension = &((*out_extensions)[extension_index]); + i = cgltf_parse_json_unprocessed_extension(options, tokens, i, json_chunk, extension); + + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_draco_mesh_compression(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_draco_mesh_compression* out_draco_mesh_compression) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "attributes") == 0) + { + i = cgltf_parse_json_attribute_list(options, tokens, i + 1, json_chunk, &out_draco_mesh_compression->attributes, &out_draco_mesh_compression->attributes_count); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "bufferView") == 0) + { + ++i; + out_draco_mesh_compression->buffer_view = CGLTF_PTRINDEX(cgltf_buffer_view, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_material_mapping_data(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_material_mapping* out_mappings, cgltf_size* offset) +{ + (void)options; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_ARRAY); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int obj_size = tokens[i].size; + ++i; + + int material = -1; + int variants_tok = -1; + cgltf_extras extras = {0, 0}; + + for (int k = 0; k < obj_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "material") == 0) + { + ++i; + material = cgltf_json_to_int(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "variants") == 0) + { + variants_tok = i+1; + CGLTF_CHECK_TOKTYPE(tokens[variants_tok], JSMN_ARRAY); + + i = cgltf_skip_json(tokens, i+1); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &extras); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + if (material < 0 || variants_tok < 0) + { + return CGLTF_ERROR_JSON; + } + + if (out_mappings) + { + for (int k = 0; k < tokens[variants_tok].size; ++k) + { + int variant = cgltf_json_to_int(&tokens[variants_tok + 1 + k], json_chunk); + if (variant < 0) + return variant; + + out_mappings[*offset].material = CGLTF_PTRINDEX(cgltf_material, material); + out_mappings[*offset].variant = variant; + out_mappings[*offset].extras = extras; + + (*offset)++; + } + } + else + { + (*offset) += tokens[variants_tok].size; + } + } + + return i; +} + +static int cgltf_parse_json_material_mappings(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_primitive* out_prim) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "mappings") == 0) + { + if (out_prim->mappings) + { + return CGLTF_ERROR_JSON; + } + + cgltf_size mappings_offset = 0; + int k = cgltf_parse_json_material_mapping_data(options, tokens, i + 1, json_chunk, NULL, &mappings_offset); + if (k < 0) + { + return k; + } + + out_prim->mappings_count = mappings_offset; + out_prim->mappings = (cgltf_material_mapping*)cgltf_calloc(options, sizeof(cgltf_material_mapping), out_prim->mappings_count); + + mappings_offset = 0; + i = cgltf_parse_json_material_mapping_data(options, tokens, i + 1, json_chunk, out_prim->mappings, &mappings_offset); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_primitive(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_primitive* out_prim) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + out_prim->type = cgltf_primitive_type_triangles; + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "mode") == 0) + { + ++i; + out_prim->type + = (cgltf_primitive_type) + cgltf_json_to_int(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "indices") == 0) + { + ++i; + out_prim->indices = CGLTF_PTRINDEX(cgltf_accessor, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "material") == 0) + { + ++i; + out_prim->material = CGLTF_PTRINDEX(cgltf_material, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "attributes") == 0) + { + i = cgltf_parse_json_attribute_list(options, tokens, i + 1, json_chunk, &out_prim->attributes, &out_prim->attributes_count); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "targets") == 0) + { + i = cgltf_parse_json_array(options, tokens, i + 1, json_chunk, sizeof(cgltf_morph_target), (void**)&out_prim->targets, &out_prim->targets_count); + if (i < 0) + { + return i; + } + + for (cgltf_size k = 0; k < out_prim->targets_count; ++k) + { + i = cgltf_parse_json_attribute_list(options, tokens, i, json_chunk, &out_prim->targets[k].attributes, &out_prim->targets[k].attributes_count); + if (i < 0) + { + return i; + } + } + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_prim->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + if(out_prim->extensions) + { + return CGLTF_ERROR_JSON; + } + + int extensions_size = tokens[i].size; + out_prim->extensions_count = 0; + out_prim->extensions = (cgltf_extension*)cgltf_calloc(options, sizeof(cgltf_extension), extensions_size); + + if (!out_prim->extensions) + { + return CGLTF_ERROR_NOMEM; + } + + ++i; + for (int k = 0; k < extensions_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_draco_mesh_compression") == 0) + { + out_prim->has_draco_mesh_compression = 1; + i = cgltf_parse_json_draco_mesh_compression(options, tokens, i + 1, json_chunk, &out_prim->draco_mesh_compression); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_materials_variants") == 0) + { + i = cgltf_parse_json_material_mappings(options, tokens, i + 1, json_chunk, out_prim); + } + else + { + i = cgltf_parse_json_unprocessed_extension(options, tokens, i, json_chunk, &(out_prim->extensions[out_prim->extensions_count++])); + } + + if (i < 0) + { + return i; + } + } + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_mesh(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_mesh* out_mesh) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_mesh->name); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "primitives") == 0) + { + i = cgltf_parse_json_array(options, tokens, i + 1, json_chunk, sizeof(cgltf_primitive), (void**)&out_mesh->primitives, &out_mesh->primitives_count); + if (i < 0) + { + return i; + } + + for (cgltf_size prim_index = 0; prim_index < out_mesh->primitives_count; ++prim_index) + { + i = cgltf_parse_json_primitive(options, tokens, i, json_chunk, &out_mesh->primitives[prim_index]); + if (i < 0) + { + return i; + } + } + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "weights") == 0) + { + i = cgltf_parse_json_array(options, tokens, i + 1, json_chunk, sizeof(cgltf_float), (void**)&out_mesh->weights, &out_mesh->weights_count); + if (i < 0) + { + return i; + } + + i = cgltf_parse_json_float_array(tokens, i - 1, json_chunk, out_mesh->weights, (int)out_mesh->weights_count); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + ++i; + + out_mesh->extras.start_offset = tokens[i].start; + out_mesh->extras.end_offset = tokens[i].end; + + if (tokens[i].type == JSMN_OBJECT) + { + int extras_size = tokens[i].size; + ++i; + + for (int k = 0; k < extras_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "targetNames") == 0 && tokens[i+1].type == JSMN_ARRAY) + { + i = cgltf_parse_json_string_array(options, tokens, i + 1, json_chunk, &out_mesh->target_names, &out_mesh->target_names_count); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + } + else + { + i = cgltf_skip_json(tokens, i); + } + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_mesh->extensions_count, &out_mesh->extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_meshes(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_mesh), (void**)&out_data->meshes, &out_data->meshes_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->meshes_count; ++j) + { + i = cgltf_parse_json_mesh(options, tokens, i, json_chunk, &out_data->meshes[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static cgltf_component_type cgltf_json_to_component_type(jsmntok_t const* tok, const uint8_t* json_chunk) +{ + int type = cgltf_json_to_int(tok, json_chunk); + + switch (type) + { + case 5120: + return cgltf_component_type_r_8; + case 5121: + return cgltf_component_type_r_8u; + case 5122: + return cgltf_component_type_r_16; + case 5123: + return cgltf_component_type_r_16u; + case 5125: + return cgltf_component_type_r_32u; + case 5126: + return cgltf_component_type_r_32f; + default: + return cgltf_component_type_invalid; + } +} + +static int cgltf_parse_json_accessor_sparse(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_accessor_sparse* out_sparse) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "count") == 0) + { + ++i; + out_sparse->count = cgltf_json_to_int(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "indices") == 0) + { + ++i; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int indices_size = tokens[i].size; + ++i; + + for (int k = 0; k < indices_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "bufferView") == 0) + { + ++i; + out_sparse->indices_buffer_view = CGLTF_PTRINDEX(cgltf_buffer_view, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "byteOffset") == 0) + { + ++i; + out_sparse->indices_byte_offset = cgltf_json_to_size(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "componentType") == 0) + { + ++i; + out_sparse->indices_component_type = cgltf_json_to_component_type(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_sparse->indices_extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_sparse->indices_extensions_count, &out_sparse->indices_extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "values") == 0) + { + ++i; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int values_size = tokens[i].size; + ++i; + + for (int k = 0; k < values_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "bufferView") == 0) + { + ++i; + out_sparse->values_buffer_view = CGLTF_PTRINDEX(cgltf_buffer_view, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "byteOffset") == 0) + { + ++i; + out_sparse->values_byte_offset = cgltf_json_to_size(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_sparse->values_extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_sparse->values_extensions_count, &out_sparse->values_extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_sparse->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_sparse->extensions_count, &out_sparse->extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_accessor(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_accessor* out_accessor) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_accessor->name); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "bufferView") == 0) + { + ++i; + out_accessor->buffer_view = CGLTF_PTRINDEX(cgltf_buffer_view, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "byteOffset") == 0) + { + ++i; + out_accessor->offset = + cgltf_json_to_size(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "componentType") == 0) + { + ++i; + out_accessor->component_type = cgltf_json_to_component_type(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "normalized") == 0) + { + ++i; + out_accessor->normalized = cgltf_json_to_bool(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "count") == 0) + { + ++i; + out_accessor->count = + cgltf_json_to_int(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "type") == 0) + { + ++i; + if (cgltf_json_strcmp(tokens+i, json_chunk, "SCALAR") == 0) + { + out_accessor->type = cgltf_type_scalar; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "VEC2") == 0) + { + out_accessor->type = cgltf_type_vec2; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "VEC3") == 0) + { + out_accessor->type = cgltf_type_vec3; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "VEC4") == 0) + { + out_accessor->type = cgltf_type_vec4; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "MAT2") == 0) + { + out_accessor->type = cgltf_type_mat2; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "MAT3") == 0) + { + out_accessor->type = cgltf_type_mat3; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "MAT4") == 0) + { + out_accessor->type = cgltf_type_mat4; + } + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "min") == 0) + { + ++i; + out_accessor->has_min = 1; + // note: we can't parse the precise number of elements since type may not have been computed yet + int min_size = tokens[i].size > 16 ? 16 : tokens[i].size; + i = cgltf_parse_json_float_array(tokens, i, json_chunk, out_accessor->min, min_size); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "max") == 0) + { + ++i; + out_accessor->has_max = 1; + // note: we can't parse the precise number of elements since type may not have been computed yet + int max_size = tokens[i].size > 16 ? 16 : tokens[i].size; + i = cgltf_parse_json_float_array(tokens, i, json_chunk, out_accessor->max, max_size); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "sparse") == 0) + { + out_accessor->is_sparse = 1; + i = cgltf_parse_json_accessor_sparse(options, tokens, i + 1, json_chunk, &out_accessor->sparse); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_accessor->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_accessor->extensions_count, &out_accessor->extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_texture_transform(jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_texture_transform* out_texture_transform) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "offset") == 0) + { + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_texture_transform->offset, 2); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "rotation") == 0) + { + ++i; + out_texture_transform->rotation = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "scale") == 0) + { + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_texture_transform->scale, 2); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "texCoord") == 0) + { + ++i; + out_texture_transform->has_texcoord = 1; + out_texture_transform->texcoord = cgltf_json_to_int(tokens + i, json_chunk); + ++i; + } + else + { + i = cgltf_skip_json(tokens, i + 1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_texture_view(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_texture_view* out_texture_view) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + out_texture_view->scale = 1.0f; + cgltf_fill_float_array(out_texture_view->transform.scale, 2, 1.0f); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "index") == 0) + { + ++i; + out_texture_view->texture = CGLTF_PTRINDEX(cgltf_texture, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "texCoord") == 0) + { + ++i; + out_texture_view->texcoord = cgltf_json_to_int(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "scale") == 0) + { + ++i; + out_texture_view->scale = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "strength") == 0) + { + ++i; + out_texture_view->scale = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_texture_view->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + if(out_texture_view->extensions) + { + return CGLTF_ERROR_JSON; + } + + int extensions_size = tokens[i].size; + out_texture_view->extensions_count = 0; + out_texture_view->extensions = (cgltf_extension*)cgltf_calloc(options, sizeof(cgltf_extension), extensions_size); + + if (!out_texture_view->extensions) + { + return CGLTF_ERROR_NOMEM; + } + + ++i; + + for (int k = 0; k < extensions_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_texture_transform") == 0) + { + out_texture_view->has_transform = 1; + i = cgltf_parse_json_texture_transform(tokens, i + 1, json_chunk, &out_texture_view->transform); + } + else + { + i = cgltf_parse_json_unprocessed_extension(options, tokens, i, json_chunk, &(out_texture_view->extensions[out_texture_view->extensions_count++])); + } + + if (i < 0) + { + return i; + } + } + } + else + { + i = cgltf_skip_json(tokens, i + 1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_pbr_metallic_roughness(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_pbr_metallic_roughness* out_pbr) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "metallicFactor") == 0) + { + ++i; + out_pbr->metallic_factor = + cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "roughnessFactor") == 0) + { + ++i; + out_pbr->roughness_factor = + cgltf_json_to_float(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "baseColorFactor") == 0) + { + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_pbr->base_color_factor, 4); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "baseColorTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, + &out_pbr->base_color_texture); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "metallicRoughnessTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, + &out_pbr->metallic_roughness_texture); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_pbr->extras); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_pbr_specular_glossiness(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_pbr_specular_glossiness* out_pbr) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "diffuseFactor") == 0) + { + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_pbr->diffuse_factor, 4); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "specularFactor") == 0) + { + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_pbr->specular_factor, 3); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "glossinessFactor") == 0) + { + ++i; + out_pbr->glossiness_factor = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "diffuseTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, &out_pbr->diffuse_texture); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "specularGlossinessTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, &out_pbr->specular_glossiness_texture); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_clearcoat(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_clearcoat* out_clearcoat) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "clearcoatFactor") == 0) + { + ++i; + out_clearcoat->clearcoat_factor = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "clearcoatRoughnessFactor") == 0) + { + ++i; + out_clearcoat->clearcoat_roughness_factor = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "clearcoatTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, &out_clearcoat->clearcoat_texture); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "clearcoatRoughnessTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, &out_clearcoat->clearcoat_roughness_texture); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "clearcoatNormalTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, &out_clearcoat->clearcoat_normal_texture); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_ior(jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_ior* out_ior) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + int size = tokens[i].size; + ++i; + + // Default values + out_ior->ior = 1.5f; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "ior") == 0) + { + ++i; + out_ior->ior = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_specular(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_specular* out_specular) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + int size = tokens[i].size; + ++i; + + // Default values + out_specular->specular_factor = 1.0f; + cgltf_fill_float_array(out_specular->specular_color_factor, 3, 1.0f); + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "specularFactor") == 0) + { + ++i; + out_specular->specular_factor = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "specularColorFactor") == 0) + { + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_specular->specular_color_factor, 3); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "specularTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, &out_specular->specular_texture); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "specularColorTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, &out_specular->specular_color_texture); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_transmission(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_transmission* out_transmission) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "transmissionFactor") == 0) + { + ++i; + out_transmission->transmission_factor = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "transmissionTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, &out_transmission->transmission_texture); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_volume(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_volume* out_volume) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "thicknessFactor") == 0) + { + ++i; + out_volume->thickness_factor = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "thicknessTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, &out_volume->thickness_texture); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "attenuationColor") == 0) + { + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_volume->attenuation_color, 3); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "attenuationDistance") == 0) + { + ++i; + out_volume->attenuation_distance = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else + { + i = cgltf_skip_json(tokens, i + 1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_sheen(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_sheen* out_sheen) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "sheenColorFactor") == 0) + { + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_sheen->sheen_color_factor, 3); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "sheenColorTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, &out_sheen->sheen_color_texture); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "sheenRoughnessFactor") == 0) + { + ++i; + out_sheen->sheen_roughness_factor = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "sheenRoughnessTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, &out_sheen->sheen_roughness_texture); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_image(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_image* out_image) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "uri") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_image->uri); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "bufferView") == 0) + { + ++i; + out_image->buffer_view = CGLTF_PTRINDEX(cgltf_buffer_view, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "mimeType") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_image->mime_type); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_image->name); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_image->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_image->extensions_count, &out_image->extensions); + } + else + { + i = cgltf_skip_json(tokens, i + 1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_sampler(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_sampler* out_sampler) +{ + (void)options; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + out_sampler->wrap_s = 10497; + out_sampler->wrap_t = 10497; + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_sampler->name); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "magFilter") == 0) + { + ++i; + out_sampler->mag_filter + = cgltf_json_to_int(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "minFilter") == 0) + { + ++i; + out_sampler->min_filter + = cgltf_json_to_int(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "wrapS") == 0) + { + ++i; + out_sampler->wrap_s + = cgltf_json_to_int(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "wrapT") == 0) + { + ++i; + out_sampler->wrap_t + = cgltf_json_to_int(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_sampler->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_sampler->extensions_count, &out_sampler->extensions); + } + else + { + i = cgltf_skip_json(tokens, i + 1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_texture(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_texture* out_texture) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_texture->name); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "sampler") == 0) + { + ++i; + out_texture->sampler = CGLTF_PTRINDEX(cgltf_sampler, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "source") == 0) + { + ++i; + out_texture->image = CGLTF_PTRINDEX(cgltf_image, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_texture->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + if (out_texture->extensions) + { + return CGLTF_ERROR_JSON; + } + + int extensions_size = tokens[i].size; + ++i; + out_texture->extensions = (cgltf_extension*)cgltf_calloc(options, sizeof(cgltf_extension), extensions_size); + out_texture->extensions_count = 0; + + if (!out_texture->extensions) + { + return CGLTF_ERROR_NOMEM; + } + + for (int k = 0; k < extensions_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "KHR_texture_basisu") == 0) + { + out_texture->has_basisu = 1; + ++i; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + int num_properties = tokens[i].size; + ++i; + + for (int t = 0; t < num_properties; ++t) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "source") == 0) + { + ++i; + out_texture->basisu_image = CGLTF_PTRINDEX(cgltf_image, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else + { + i = cgltf_skip_json(tokens, i + 1); + } + } + } + else + { + i = cgltf_parse_json_unprocessed_extension(options, tokens, i, json_chunk, &(out_texture->extensions[out_texture->extensions_count++])); + } + + if (i < 0) + { + return i; + } + } + } + else + { + i = cgltf_skip_json(tokens, i + 1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_material(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_material* out_material) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + cgltf_fill_float_array(out_material->pbr_metallic_roughness.base_color_factor, 4, 1.0f); + out_material->pbr_metallic_roughness.metallic_factor = 1.0f; + out_material->pbr_metallic_roughness.roughness_factor = 1.0f; + + cgltf_fill_float_array(out_material->pbr_specular_glossiness.diffuse_factor, 4, 1.0f); + cgltf_fill_float_array(out_material->pbr_specular_glossiness.specular_factor, 3, 1.0f); + out_material->pbr_specular_glossiness.glossiness_factor = 1.0f; + + cgltf_fill_float_array(out_material->volume.attenuation_color, 3, 1.0f); + out_material->volume.attenuation_distance = FLT_MAX; + + out_material->alpha_cutoff = 0.5f; + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_material->name); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "pbrMetallicRoughness") == 0) + { + out_material->has_pbr_metallic_roughness = 1; + i = cgltf_parse_json_pbr_metallic_roughness(options, tokens, i + 1, json_chunk, &out_material->pbr_metallic_roughness); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "emissiveFactor") == 0) + { + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_material->emissive_factor, 3); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "normalTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, + &out_material->normal_texture); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "occlusionTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, + &out_material->occlusion_texture); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "emissiveTexture") == 0) + { + i = cgltf_parse_json_texture_view(options, tokens, i + 1, json_chunk, + &out_material->emissive_texture); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "alphaMode") == 0) + { + ++i; + if (cgltf_json_strcmp(tokens + i, json_chunk, "OPAQUE") == 0) + { + out_material->alpha_mode = cgltf_alpha_mode_opaque; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "MASK") == 0) + { + out_material->alpha_mode = cgltf_alpha_mode_mask; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "BLEND") == 0) + { + out_material->alpha_mode = cgltf_alpha_mode_blend; + } + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "alphaCutoff") == 0) + { + ++i; + out_material->alpha_cutoff = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "doubleSided") == 0) + { + ++i; + out_material->double_sided = + cgltf_json_to_bool(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_material->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + if(out_material->extensions) + { + return CGLTF_ERROR_JSON; + } + + int extensions_size = tokens[i].size; + ++i; + out_material->extensions = (cgltf_extension*)cgltf_calloc(options, sizeof(cgltf_extension), extensions_size); + out_material->extensions_count= 0; + + if (!out_material->extensions) + { + return CGLTF_ERROR_NOMEM; + } + + for (int k = 0; k < extensions_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_materials_pbrSpecularGlossiness") == 0) + { + out_material->has_pbr_specular_glossiness = 1; + i = cgltf_parse_json_pbr_specular_glossiness(options, tokens, i + 1, json_chunk, &out_material->pbr_specular_glossiness); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_materials_unlit") == 0) + { + out_material->unlit = 1; + i = cgltf_skip_json(tokens, i+1); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_materials_clearcoat") == 0) + { + out_material->has_clearcoat = 1; + i = cgltf_parse_json_clearcoat(options, tokens, i + 1, json_chunk, &out_material->clearcoat); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_materials_ior") == 0) + { + out_material->has_ior = 1; + i = cgltf_parse_json_ior(tokens, i + 1, json_chunk, &out_material->ior); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_materials_specular") == 0) + { + out_material->has_specular = 1; + i = cgltf_parse_json_specular(options, tokens, i + 1, json_chunk, &out_material->specular); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_materials_transmission") == 0) + { + out_material->has_transmission = 1; + i = cgltf_parse_json_transmission(options, tokens, i + 1, json_chunk, &out_material->transmission); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "KHR_materials_volume") == 0) + { + out_material->has_volume = 1; + i = cgltf_parse_json_volume(options, tokens, i + 1, json_chunk, &out_material->volume); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_materials_sheen") == 0) + { + out_material->has_sheen = 1; + i = cgltf_parse_json_sheen(options, tokens, i + 1, json_chunk, &out_material->sheen); + } + else + { + i = cgltf_parse_json_unprocessed_extension(options, tokens, i, json_chunk, &(out_material->extensions[out_material->extensions_count++])); + } + + if (i < 0) + { + return i; + } + } + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_accessors(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_accessor), (void**)&out_data->accessors, &out_data->accessors_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->accessors_count; ++j) + { + i = cgltf_parse_json_accessor(options, tokens, i, json_chunk, &out_data->accessors[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_materials(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_material), (void**)&out_data->materials, &out_data->materials_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->materials_count; ++j) + { + i = cgltf_parse_json_material(options, tokens, i, json_chunk, &out_data->materials[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_images(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_image), (void**)&out_data->images, &out_data->images_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->images_count; ++j) + { + i = cgltf_parse_json_image(options, tokens, i, json_chunk, &out_data->images[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_textures(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_texture), (void**)&out_data->textures, &out_data->textures_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->textures_count; ++j) + { + i = cgltf_parse_json_texture(options, tokens, i, json_chunk, &out_data->textures[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_samplers(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_sampler), (void**)&out_data->samplers, &out_data->samplers_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->samplers_count; ++j) + { + i = cgltf_parse_json_sampler(options, tokens, i, json_chunk, &out_data->samplers[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_meshopt_compression(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_meshopt_compression* out_meshopt_compression) +{ + (void)options; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "buffer") == 0) + { + ++i; + out_meshopt_compression->buffer = CGLTF_PTRINDEX(cgltf_buffer, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "byteOffset") == 0) + { + ++i; + out_meshopt_compression->offset = cgltf_json_to_size(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "byteLength") == 0) + { + ++i; + out_meshopt_compression->size = cgltf_json_to_size(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "byteStride") == 0) + { + ++i; + out_meshopt_compression->stride = cgltf_json_to_size(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "count") == 0) + { + ++i; + out_meshopt_compression->count = cgltf_json_to_int(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "mode") == 0) + { + ++i; + if (cgltf_json_strcmp(tokens+i, json_chunk, "ATTRIBUTES") == 0) + { + out_meshopt_compression->mode = cgltf_meshopt_compression_mode_attributes; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "TRIANGLES") == 0) + { + out_meshopt_compression->mode = cgltf_meshopt_compression_mode_triangles; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "INDICES") == 0) + { + out_meshopt_compression->mode = cgltf_meshopt_compression_mode_indices; + } + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "filter") == 0) + { + ++i; + if (cgltf_json_strcmp(tokens+i, json_chunk, "NONE") == 0) + { + out_meshopt_compression->filter = cgltf_meshopt_compression_filter_none; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "OCTAHEDRAL") == 0) + { + out_meshopt_compression->filter = cgltf_meshopt_compression_filter_octahedral; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "QUATERNION") == 0) + { + out_meshopt_compression->filter = cgltf_meshopt_compression_filter_quaternion; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "EXPONENTIAL") == 0) + { + out_meshopt_compression->filter = cgltf_meshopt_compression_filter_exponential; + } + ++i; + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_buffer_view(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_buffer_view* out_buffer_view) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_buffer_view->name); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "buffer") == 0) + { + ++i; + out_buffer_view->buffer = CGLTF_PTRINDEX(cgltf_buffer, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "byteOffset") == 0) + { + ++i; + out_buffer_view->offset = + cgltf_json_to_size(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "byteLength") == 0) + { + ++i; + out_buffer_view->size = + cgltf_json_to_size(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "byteStride") == 0) + { + ++i; + out_buffer_view->stride = + cgltf_json_to_size(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "target") == 0) + { + ++i; + int type = cgltf_json_to_int(tokens+i, json_chunk); + switch (type) + { + case 34962: + type = cgltf_buffer_view_type_vertices; + break; + case 34963: + type = cgltf_buffer_view_type_indices; + break; + default: + type = cgltf_buffer_view_type_invalid; + break; + } + out_buffer_view->type = (cgltf_buffer_view_type)type; + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_buffer_view->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + if(out_buffer_view->extensions) + { + return CGLTF_ERROR_JSON; + } + + int extensions_size = tokens[i].size; + out_buffer_view->extensions_count = 0; + out_buffer_view->extensions = (cgltf_extension*)cgltf_calloc(options, sizeof(cgltf_extension), extensions_size); + + if (!out_buffer_view->extensions) + { + return CGLTF_ERROR_NOMEM; + } + + ++i; + for (int k = 0; k < extensions_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "EXT_meshopt_compression") == 0) + { + out_buffer_view->has_meshopt_compression = 1; + i = cgltf_parse_json_meshopt_compression(options, tokens, i + 1, json_chunk, &out_buffer_view->meshopt_compression); + } + else + { + i = cgltf_parse_json_unprocessed_extension(options, tokens, i, json_chunk, &(out_buffer_view->extensions[out_buffer_view->extensions_count++])); + } + + if (i < 0) + { + return i; + } + } + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_buffer_views(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_buffer_view), (void**)&out_data->buffer_views, &out_data->buffer_views_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->buffer_views_count; ++j) + { + i = cgltf_parse_json_buffer_view(options, tokens, i, json_chunk, &out_data->buffer_views[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_buffer(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_buffer* out_buffer) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_buffer->name); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "byteLength") == 0) + { + ++i; + out_buffer->size = + cgltf_json_to_size(tokens+i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "uri") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_buffer->uri); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_buffer->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_buffer->extensions_count, &out_buffer->extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_buffers(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_buffer), (void**)&out_data->buffers, &out_data->buffers_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->buffers_count; ++j) + { + i = cgltf_parse_json_buffer(options, tokens, i, json_chunk, &out_data->buffers[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_skin(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_skin* out_skin) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_skin->name); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "joints") == 0) + { + i = cgltf_parse_json_array(options, tokens, i + 1, json_chunk, sizeof(cgltf_node*), (void**)&out_skin->joints, &out_skin->joints_count); + if (i < 0) + { + return i; + } + + for (cgltf_size k = 0; k < out_skin->joints_count; ++k) + { + out_skin->joints[k] = CGLTF_PTRINDEX(cgltf_node, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "skeleton") == 0) + { + ++i; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_PRIMITIVE); + out_skin->skeleton = CGLTF_PTRINDEX(cgltf_node, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "inverseBindMatrices") == 0) + { + ++i; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_PRIMITIVE); + out_skin->inverse_bind_matrices = CGLTF_PTRINDEX(cgltf_accessor, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_skin->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_skin->extensions_count, &out_skin->extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_skins(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_skin), (void**)&out_data->skins, &out_data->skins_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->skins_count; ++j) + { + i = cgltf_parse_json_skin(options, tokens, i, json_chunk, &out_data->skins[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_camera(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_camera* out_camera) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_camera->name); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "type") == 0) + { + ++i; + if (cgltf_json_strcmp(tokens + i, json_chunk, "perspective") == 0) + { + out_camera->type = cgltf_camera_type_perspective; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "orthographic") == 0) + { + out_camera->type = cgltf_camera_type_orthographic; + } + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "perspective") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int data_size = tokens[i].size; + ++i; + + out_camera->type = cgltf_camera_type_perspective; + + for (int k = 0; k < data_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "aspectRatio") == 0) + { + ++i; + out_camera->data.perspective.has_aspect_ratio = 1; + out_camera->data.perspective.aspect_ratio = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "yfov") == 0) + { + ++i; + out_camera->data.perspective.yfov = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "zfar") == 0) + { + ++i; + out_camera->data.perspective.has_zfar = 1; + out_camera->data.perspective.zfar = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "znear") == 0) + { + ++i; + out_camera->data.perspective.znear = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_camera->data.perspective.extras); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "orthographic") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int data_size = tokens[i].size; + ++i; + + out_camera->type = cgltf_camera_type_orthographic; + + for (int k = 0; k < data_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "xmag") == 0) + { + ++i; + out_camera->data.orthographic.xmag = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "ymag") == 0) + { + ++i; + out_camera->data.orthographic.ymag = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "zfar") == 0) + { + ++i; + out_camera->data.orthographic.zfar = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "znear") == 0) + { + ++i; + out_camera->data.orthographic.znear = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_camera->data.orthographic.extras); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_camera->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_camera->extensions_count, &out_camera->extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_cameras(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_camera), (void**)&out_data->cameras, &out_data->cameras_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->cameras_count; ++j) + { + i = cgltf_parse_json_camera(options, tokens, i, json_chunk, &out_data->cameras[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_light(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_light* out_light) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + out_light->color[0] = 1.f; + out_light->color[1] = 1.f; + out_light->color[2] = 1.f; + out_light->intensity = 1.f; + + out_light->spot_inner_cone_angle = 0.f; + out_light->spot_outer_cone_angle = 3.1415926535f / 4.0f; + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_light->name); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "color") == 0) + { + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_light->color, 3); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "intensity") == 0) + { + ++i; + out_light->intensity = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "type") == 0) + { + ++i; + if (cgltf_json_strcmp(tokens + i, json_chunk, "directional") == 0) + { + out_light->type = cgltf_light_type_directional; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "point") == 0) + { + out_light->type = cgltf_light_type_point; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "spot") == 0) + { + out_light->type = cgltf_light_type_spot; + } + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "range") == 0) + { + ++i; + out_light->range = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "spot") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int data_size = tokens[i].size; + ++i; + + for (int k = 0; k < data_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "innerConeAngle") == 0) + { + ++i; + out_light->spot_inner_cone_angle = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "outerConeAngle") == 0) + { + ++i; + out_light->spot_outer_cone_angle = cgltf_json_to_float(tokens + i, json_chunk); + ++i; + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_light->extras); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_lights(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_light), (void**)&out_data->lights, &out_data->lights_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->lights_count; ++j) + { + i = cgltf_parse_json_light(options, tokens, i, json_chunk, &out_data->lights[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_node(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_node* out_node) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + out_node->rotation[3] = 1.0f; + out_node->scale[0] = 1.0f; + out_node->scale[1] = 1.0f; + out_node->scale[2] = 1.0f; + out_node->matrix[0] = 1.0f; + out_node->matrix[5] = 1.0f; + out_node->matrix[10] = 1.0f; + out_node->matrix[15] = 1.0f; + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_node->name); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "children") == 0) + { + i = cgltf_parse_json_array(options, tokens, i + 1, json_chunk, sizeof(cgltf_node*), (void**)&out_node->children, &out_node->children_count); + if (i < 0) + { + return i; + } + + for (cgltf_size k = 0; k < out_node->children_count; ++k) + { + out_node->children[k] = CGLTF_PTRINDEX(cgltf_node, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "mesh") == 0) + { + ++i; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_PRIMITIVE); + out_node->mesh = CGLTF_PTRINDEX(cgltf_mesh, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "skin") == 0) + { + ++i; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_PRIMITIVE); + out_node->skin = CGLTF_PTRINDEX(cgltf_skin, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "camera") == 0) + { + ++i; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_PRIMITIVE); + out_node->camera = CGLTF_PTRINDEX(cgltf_camera, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "translation") == 0) + { + out_node->has_translation = 1; + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_node->translation, 3); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "rotation") == 0) + { + out_node->has_rotation = 1; + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_node->rotation, 4); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "scale") == 0) + { + out_node->has_scale = 1; + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_node->scale, 3); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "matrix") == 0) + { + out_node->has_matrix = 1; + i = cgltf_parse_json_float_array(tokens, i + 1, json_chunk, out_node->matrix, 16); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "weights") == 0) + { + i = cgltf_parse_json_array(options, tokens, i + 1, json_chunk, sizeof(cgltf_float), (void**)&out_node->weights, &out_node->weights_count); + if (i < 0) + { + return i; + } + + i = cgltf_parse_json_float_array(tokens, i - 1, json_chunk, out_node->weights, (int)out_node->weights_count); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_node->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + if(out_node->extensions) + { + return CGLTF_ERROR_JSON; + } + + int extensions_size = tokens[i].size; + out_node->extensions_count= 0; + out_node->extensions = (cgltf_extension*)cgltf_calloc(options, sizeof(cgltf_extension), extensions_size); + + if (!out_node->extensions) + { + return CGLTF_ERROR_NOMEM; + } + + ++i; + + for (int k = 0; k < extensions_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_lights_punctual") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int data_size = tokens[i].size; + ++i; + + for (int m = 0; m < data_size; ++m) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "light") == 0) + { + ++i; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_PRIMITIVE); + out_node->light = CGLTF_PTRINDEX(cgltf_light, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else + { + i = cgltf_skip_json(tokens, i + 1); + } + + if (i < 0) + { + return i; + } + } + } + else + { + i = cgltf_parse_json_unprocessed_extension(options, tokens, i, json_chunk, &(out_node->extensions[out_node->extensions_count++])); + } + + if (i < 0) + { + return i; + } + } + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_nodes(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_node), (void**)&out_data->nodes, &out_data->nodes_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->nodes_count; ++j) + { + i = cgltf_parse_json_node(options, tokens, i, json_chunk, &out_data->nodes[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_scene(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_scene* out_scene) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_scene->name); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "nodes") == 0) + { + i = cgltf_parse_json_array(options, tokens, i + 1, json_chunk, sizeof(cgltf_node*), (void**)&out_scene->nodes, &out_scene->nodes_count); + if (i < 0) + { + return i; + } + + for (cgltf_size k = 0; k < out_scene->nodes_count; ++k) + { + out_scene->nodes[k] = CGLTF_PTRINDEX(cgltf_node, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_scene->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_scene->extensions_count, &out_scene->extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_scenes(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_scene), (void**)&out_data->scenes, &out_data->scenes_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->scenes_count; ++j) + { + i = cgltf_parse_json_scene(options, tokens, i, json_chunk, &out_data->scenes[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_animation_sampler(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_animation_sampler* out_sampler) +{ + (void)options; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "input") == 0) + { + ++i; + out_sampler->input = CGLTF_PTRINDEX(cgltf_accessor, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "output") == 0) + { + ++i; + out_sampler->output = CGLTF_PTRINDEX(cgltf_accessor, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "interpolation") == 0) + { + ++i; + if (cgltf_json_strcmp(tokens + i, json_chunk, "LINEAR") == 0) + { + out_sampler->interpolation = cgltf_interpolation_type_linear; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "STEP") == 0) + { + out_sampler->interpolation = cgltf_interpolation_type_step; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "CUBICSPLINE") == 0) + { + out_sampler->interpolation = cgltf_interpolation_type_cubic_spline; + } + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_sampler->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_sampler->extensions_count, &out_sampler->extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_animation_channel(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_animation_channel* out_channel) +{ + (void)options; + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "sampler") == 0) + { + ++i; + out_channel->sampler = CGLTF_PTRINDEX(cgltf_animation_sampler, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "target") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int target_size = tokens[i].size; + ++i; + + for (int k = 0; k < target_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "node") == 0) + { + ++i; + out_channel->target_node = CGLTF_PTRINDEX(cgltf_node, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "path") == 0) + { + ++i; + if (cgltf_json_strcmp(tokens+i, json_chunk, "translation") == 0) + { + out_channel->target_path = cgltf_animation_path_type_translation; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "rotation") == 0) + { + out_channel->target_path = cgltf_animation_path_type_rotation; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "scale") == 0) + { + out_channel->target_path = cgltf_animation_path_type_scale; + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "weights") == 0) + { + out_channel->target_path = cgltf_animation_path_type_weights; + } + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_channel->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_channel->extensions_count, &out_channel->extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_animation(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_animation* out_animation) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_animation->name); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "samplers") == 0) + { + i = cgltf_parse_json_array(options, tokens, i + 1, json_chunk, sizeof(cgltf_animation_sampler), (void**)&out_animation->samplers, &out_animation->samplers_count); + if (i < 0) + { + return i; + } + + for (cgltf_size k = 0; k < out_animation->samplers_count; ++k) + { + i = cgltf_parse_json_animation_sampler(options, tokens, i, json_chunk, &out_animation->samplers[k]); + if (i < 0) + { + return i; + } + } + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "channels") == 0) + { + i = cgltf_parse_json_array(options, tokens, i + 1, json_chunk, sizeof(cgltf_animation_channel), (void**)&out_animation->channels, &out_animation->channels_count); + if (i < 0) + { + return i; + } + + for (cgltf_size k = 0; k < out_animation->channels_count; ++k) + { + i = cgltf_parse_json_animation_channel(options, tokens, i, json_chunk, &out_animation->channels[k]); + if (i < 0) + { + return i; + } + } + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_animation->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_animation->extensions_count, &out_animation->extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_animations(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_animation), (void**)&out_data->animations, &out_data->animations_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->animations_count; ++j) + { + i = cgltf_parse_json_animation(options, tokens, i, json_chunk, &out_data->animations[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_variant(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_material_variant* out_variant) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "name") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_variant->name); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_variant->extras); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +static int cgltf_parse_json_variants(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + i = cgltf_parse_json_array(options, tokens, i, json_chunk, sizeof(cgltf_material_variant), (void**)&out_data->variants, &out_data->variants_count); + if (i < 0) + { + return i; + } + + for (cgltf_size j = 0; j < out_data->variants_count; ++j) + { + i = cgltf_parse_json_variant(options, tokens, i, json_chunk, &out_data->variants[j]); + if (i < 0) + { + return i; + } + } + return i; +} + +static int cgltf_parse_json_asset(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_asset* out_asset) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "copyright") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_asset->copyright); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "generator") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_asset->generator); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "version") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_asset->version); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "minVersion") == 0) + { + i = cgltf_parse_json_string(options, tokens, i + 1, json_chunk, &out_asset->min_version); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_asset->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + i = cgltf_parse_json_unprocessed_extensions(options, tokens, i, json_chunk, &out_asset->extensions_count, &out_asset->extensions); + } + else + { + i = cgltf_skip_json(tokens, i+1); + } + + if (i < 0) + { + return i; + } + } + + if (out_asset->version && CGLTF_ATOF(out_asset->version) < 2) + { + return CGLTF_ERROR_LEGACY; + } + + return i; +} + +cgltf_size cgltf_num_components(cgltf_type type) { + switch (type) + { + case cgltf_type_vec2: + return 2; + case cgltf_type_vec3: + return 3; + case cgltf_type_vec4: + return 4; + case cgltf_type_mat2: + return 4; + case cgltf_type_mat3: + return 9; + case cgltf_type_mat4: + return 16; + case cgltf_type_invalid: + case cgltf_type_scalar: + default: + return 1; + } +} + +static cgltf_size cgltf_component_size(cgltf_component_type component_type) { + switch (component_type) + { + case cgltf_component_type_r_8: + case cgltf_component_type_r_8u: + return 1; + case cgltf_component_type_r_16: + case cgltf_component_type_r_16u: + return 2; + case cgltf_component_type_r_32u: + case cgltf_component_type_r_32f: + return 4; + case cgltf_component_type_invalid: + default: + return 0; + } +} + +static cgltf_size cgltf_calc_size(cgltf_type type, cgltf_component_type component_type) +{ + cgltf_size component_size = cgltf_component_size(component_type); + if (type == cgltf_type_mat2 && component_size == 1) + { + return 8 * component_size; + } + else if (type == cgltf_type_mat3 && (component_size == 1 || component_size == 2)) + { + return 12 * component_size; + } + return component_size * cgltf_num_components(type); +} + +static int cgltf_fixup_pointers(cgltf_data* out_data); + +static int cgltf_parse_json_root(cgltf_options* options, jsmntok_t const* tokens, int i, const uint8_t* json_chunk, cgltf_data* out_data) +{ + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int size = tokens[i].size; + ++i; + + for (int j = 0; j < size; ++j) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "asset") == 0) + { + i = cgltf_parse_json_asset(options, tokens, i + 1, json_chunk, &out_data->asset); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "meshes") == 0) + { + i = cgltf_parse_json_meshes(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "accessors") == 0) + { + i = cgltf_parse_json_accessors(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "bufferViews") == 0) + { + i = cgltf_parse_json_buffer_views(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "buffers") == 0) + { + i = cgltf_parse_json_buffers(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "materials") == 0) + { + i = cgltf_parse_json_materials(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "images") == 0) + { + i = cgltf_parse_json_images(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "textures") == 0) + { + i = cgltf_parse_json_textures(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "samplers") == 0) + { + i = cgltf_parse_json_samplers(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "skins") == 0) + { + i = cgltf_parse_json_skins(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "cameras") == 0) + { + i = cgltf_parse_json_cameras(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "nodes") == 0) + { + i = cgltf_parse_json_nodes(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "scenes") == 0) + { + i = cgltf_parse_json_scenes(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "scene") == 0) + { + ++i; + out_data->scene = CGLTF_PTRINDEX(cgltf_scene, cgltf_json_to_int(tokens + i, json_chunk)); + ++i; + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "animations") == 0) + { + i = cgltf_parse_json_animations(options, tokens, i + 1, json_chunk, out_data); + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "extras") == 0) + { + i = cgltf_parse_json_extras(tokens, i + 1, json_chunk, &out_data->extras); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensions") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + if(out_data->data_extensions) + { + return CGLTF_ERROR_JSON; + } + + int extensions_size = tokens[i].size; + out_data->data_extensions_count = 0; + out_data->data_extensions = (cgltf_extension*)cgltf_calloc(options, sizeof(cgltf_extension), extensions_size); + + if (!out_data->data_extensions) + { + return CGLTF_ERROR_NOMEM; + } + + ++i; + + for (int k = 0; k < extensions_size; ++k) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_lights_punctual") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int data_size = tokens[i].size; + ++i; + + for (int m = 0; m < data_size; ++m) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "lights") == 0) + { + i = cgltf_parse_json_lights(options, tokens, i + 1, json_chunk, out_data); + } + else + { + i = cgltf_skip_json(tokens, i + 1); + } + + if (i < 0) + { + return i; + } + } + } + else if (cgltf_json_strcmp(tokens+i, json_chunk, "KHR_materials_variants") == 0) + { + ++i; + + CGLTF_CHECK_TOKTYPE(tokens[i], JSMN_OBJECT); + + int data_size = tokens[i].size; + ++i; + + for (int m = 0; m < data_size; ++m) + { + CGLTF_CHECK_KEY(tokens[i]); + + if (cgltf_json_strcmp(tokens + i, json_chunk, "variants") == 0) + { + i = cgltf_parse_json_variants(options, tokens, i + 1, json_chunk, out_data); + } + else + { + i = cgltf_skip_json(tokens, i + 1); + } + + if (i < 0) + { + return i; + } + } + } + else + { + i = cgltf_parse_json_unprocessed_extension(options, tokens, i, json_chunk, &(out_data->data_extensions[out_data->data_extensions_count++])); + } + + if (i < 0) + { + return i; + } + } + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensionsUsed") == 0) + { + i = cgltf_parse_json_string_array(options, tokens, i + 1, json_chunk, &out_data->extensions_used, &out_data->extensions_used_count); + } + else if (cgltf_json_strcmp(tokens + i, json_chunk, "extensionsRequired") == 0) + { + i = cgltf_parse_json_string_array(options, tokens, i + 1, json_chunk, &out_data->extensions_required, &out_data->extensions_required_count); + } + else + { + i = cgltf_skip_json(tokens, i + 1); + } + + if (i < 0) + { + return i; + } + } + + return i; +} + +cgltf_result cgltf_parse_json(cgltf_options* options, const uint8_t* json_chunk, cgltf_size size, cgltf_data** out_data) +{ + jsmn_parser parser = { 0, 0, 0 }; + + if (options->json_token_count == 0) + { + int token_count = jsmn_parse(&parser, (const char*)json_chunk, size, NULL, 0); + + if (token_count <= 0) + { + return cgltf_result_invalid_json; + } + + options->json_token_count = token_count; + } + + jsmntok_t* tokens = (jsmntok_t*)options->memory.alloc(options->memory.user_data, sizeof(jsmntok_t) * (options->json_token_count + 1)); + + if (!tokens) + { + return cgltf_result_out_of_memory; + } + + jsmn_init(&parser); + + int token_count = jsmn_parse(&parser, (const char*)json_chunk, size, tokens, options->json_token_count); + + if (token_count <= 0) + { + options->memory.free(options->memory.user_data, tokens); + return cgltf_result_invalid_json; + } + + // this makes sure that we always have an UNDEFINED token at the end of the stream + // for invalid JSON inputs this makes sure we don't perform out of bound reads of token data + tokens[token_count].type = JSMN_UNDEFINED; + + cgltf_data* data = (cgltf_data*)options->memory.alloc(options->memory.user_data, sizeof(cgltf_data)); + + if (!data) + { + options->memory.free(options->memory.user_data, tokens); + return cgltf_result_out_of_memory; + } + + memset(data, 0, sizeof(cgltf_data)); + data->memory = options->memory; + data->file = options->file; + + int i = cgltf_parse_json_root(options, tokens, 0, json_chunk, data); + + options->memory.free(options->memory.user_data, tokens); + + if (i < 0) + { + cgltf_free(data); + + switch (i) + { + case CGLTF_ERROR_NOMEM: return cgltf_result_out_of_memory; + case CGLTF_ERROR_LEGACY: return cgltf_result_legacy_gltf; + default: return cgltf_result_invalid_gltf; + } + } + + if (cgltf_fixup_pointers(data) < 0) + { + cgltf_free(data); + return cgltf_result_invalid_gltf; + } + + data->json = (const char*)json_chunk; + data->json_size = size; + + *out_data = data; + + return cgltf_result_success; +} + +static int cgltf_fixup_pointers(cgltf_data* data) +{ + for (cgltf_size i = 0; i < data->meshes_count; ++i) + { + for (cgltf_size j = 0; j < data->meshes[i].primitives_count; ++j) + { + CGLTF_PTRFIXUP(data->meshes[i].primitives[j].indices, data->accessors, data->accessors_count); + CGLTF_PTRFIXUP(data->meshes[i].primitives[j].material, data->materials, data->materials_count); + + for (cgltf_size k = 0; k < data->meshes[i].primitives[j].attributes_count; ++k) + { + CGLTF_PTRFIXUP_REQ(data->meshes[i].primitives[j].attributes[k].data, data->accessors, data->accessors_count); + } + + for (cgltf_size k = 0; k < data->meshes[i].primitives[j].targets_count; ++k) + { + for (cgltf_size m = 0; m < data->meshes[i].primitives[j].targets[k].attributes_count; ++m) + { + CGLTF_PTRFIXUP_REQ(data->meshes[i].primitives[j].targets[k].attributes[m].data, data->accessors, data->accessors_count); + } + } + + if (data->meshes[i].primitives[j].has_draco_mesh_compression) + { + CGLTF_PTRFIXUP_REQ(data->meshes[i].primitives[j].draco_mesh_compression.buffer_view, data->buffer_views, data->buffer_views_count); + for (cgltf_size m = 0; m < data->meshes[i].primitives[j].draco_mesh_compression.attributes_count; ++m) + { + CGLTF_PTRFIXUP_REQ(data->meshes[i].primitives[j].draco_mesh_compression.attributes[m].data, data->accessors, data->accessors_count); + } + } + + for (cgltf_size k = 0; k < data->meshes[i].primitives[j].mappings_count; ++k) + { + CGLTF_PTRFIXUP_REQ(data->meshes[i].primitives[j].mappings[k].material, data->materials, data->materials_count); + } + } + } + + for (cgltf_size i = 0; i < data->accessors_count; ++i) + { + CGLTF_PTRFIXUP(data->accessors[i].buffer_view, data->buffer_views, data->buffer_views_count); + + if (data->accessors[i].is_sparse) + { + CGLTF_PTRFIXUP_REQ(data->accessors[i].sparse.indices_buffer_view, data->buffer_views, data->buffer_views_count); + CGLTF_PTRFIXUP_REQ(data->accessors[i].sparse.values_buffer_view, data->buffer_views, data->buffer_views_count); + } + + if (data->accessors[i].buffer_view) + { + data->accessors[i].stride = data->accessors[i].buffer_view->stride; + } + + if (data->accessors[i].stride == 0) + { + data->accessors[i].stride = cgltf_calc_size(data->accessors[i].type, data->accessors[i].component_type); + } + } + + for (cgltf_size i = 0; i < data->textures_count; ++i) + { + CGLTF_PTRFIXUP(data->textures[i].image, data->images, data->images_count); + CGLTF_PTRFIXUP(data->textures[i].basisu_image, data->images, data->images_count); + CGLTF_PTRFIXUP(data->textures[i].sampler, data->samplers, data->samplers_count); + } + + for (cgltf_size i = 0; i < data->images_count; ++i) + { + CGLTF_PTRFIXUP(data->images[i].buffer_view, data->buffer_views, data->buffer_views_count); + } + + for (cgltf_size i = 0; i < data->materials_count; ++i) + { + CGLTF_PTRFIXUP(data->materials[i].normal_texture.texture, data->textures, data->textures_count); + CGLTF_PTRFIXUP(data->materials[i].emissive_texture.texture, data->textures, data->textures_count); + CGLTF_PTRFIXUP(data->materials[i].occlusion_texture.texture, data->textures, data->textures_count); + + CGLTF_PTRFIXUP(data->materials[i].pbr_metallic_roughness.base_color_texture.texture, data->textures, data->textures_count); + CGLTF_PTRFIXUP(data->materials[i].pbr_metallic_roughness.metallic_roughness_texture.texture, data->textures, data->textures_count); + + CGLTF_PTRFIXUP(data->materials[i].pbr_specular_glossiness.diffuse_texture.texture, data->textures, data->textures_count); + CGLTF_PTRFIXUP(data->materials[i].pbr_specular_glossiness.specular_glossiness_texture.texture, data->textures, data->textures_count); + + CGLTF_PTRFIXUP(data->materials[i].clearcoat.clearcoat_texture.texture, data->textures, data->textures_count); + CGLTF_PTRFIXUP(data->materials[i].clearcoat.clearcoat_roughness_texture.texture, data->textures, data->textures_count); + CGLTF_PTRFIXUP(data->materials[i].clearcoat.clearcoat_normal_texture.texture, data->textures, data->textures_count); + + CGLTF_PTRFIXUP(data->materials[i].specular.specular_texture.texture, data->textures, data->textures_count); + CGLTF_PTRFIXUP(data->materials[i].specular.specular_color_texture.texture, data->textures, data->textures_count); + + CGLTF_PTRFIXUP(data->materials[i].transmission.transmission_texture.texture, data->textures, data->textures_count); + + CGLTF_PTRFIXUP(data->materials[i].volume.thickness_texture.texture, data->textures, data->textures_count); + + CGLTF_PTRFIXUP(data->materials[i].sheen.sheen_color_texture.texture, data->textures, data->textures_count); + CGLTF_PTRFIXUP(data->materials[i].sheen.sheen_roughness_texture.texture, data->textures, data->textures_count); + } + + for (cgltf_size i = 0; i < data->buffer_views_count; ++i) + { + CGLTF_PTRFIXUP_REQ(data->buffer_views[i].buffer, data->buffers, data->buffers_count); + + if (data->buffer_views[i].has_meshopt_compression) + { + CGLTF_PTRFIXUP_REQ(data->buffer_views[i].meshopt_compression.buffer, data->buffers, data->buffers_count); + } + } + + for (cgltf_size i = 0; i < data->skins_count; ++i) + { + for (cgltf_size j = 0; j < data->skins[i].joints_count; ++j) + { + CGLTF_PTRFIXUP_REQ(data->skins[i].joints[j], data->nodes, data->nodes_count); + } + + CGLTF_PTRFIXUP(data->skins[i].skeleton, data->nodes, data->nodes_count); + CGLTF_PTRFIXUP(data->skins[i].inverse_bind_matrices, data->accessors, data->accessors_count); + } + + for (cgltf_size i = 0; i < data->nodes_count; ++i) + { + for (cgltf_size j = 0; j < data->nodes[i].children_count; ++j) + { + CGLTF_PTRFIXUP_REQ(data->nodes[i].children[j], data->nodes, data->nodes_count); + + if (data->nodes[i].children[j]->parent) + { + return CGLTF_ERROR_JSON; + } + + data->nodes[i].children[j]->parent = &data->nodes[i]; + } + + CGLTF_PTRFIXUP(data->nodes[i].mesh, data->meshes, data->meshes_count); + CGLTF_PTRFIXUP(data->nodes[i].skin, data->skins, data->skins_count); + CGLTF_PTRFIXUP(data->nodes[i].camera, data->cameras, data->cameras_count); + CGLTF_PTRFIXUP(data->nodes[i].light, data->lights, data->lights_count); + } + + for (cgltf_size i = 0; i < data->scenes_count; ++i) + { + for (cgltf_size j = 0; j < data->scenes[i].nodes_count; ++j) + { + CGLTF_PTRFIXUP_REQ(data->scenes[i].nodes[j], data->nodes, data->nodes_count); + + if (data->scenes[i].nodes[j]->parent) + { + return CGLTF_ERROR_JSON; + } + } + } + + CGLTF_PTRFIXUP(data->scene, data->scenes, data->scenes_count); + + for (cgltf_size i = 0; i < data->animations_count; ++i) + { + for (cgltf_size j = 0; j < data->animations[i].samplers_count; ++j) + { + CGLTF_PTRFIXUP_REQ(data->animations[i].samplers[j].input, data->accessors, data->accessors_count); + CGLTF_PTRFIXUP_REQ(data->animations[i].samplers[j].output, data->accessors, data->accessors_count); + } + + for (cgltf_size j = 0; j < data->animations[i].channels_count; ++j) + { + CGLTF_PTRFIXUP_REQ(data->animations[i].channels[j].sampler, data->animations[i].samplers, data->animations[i].samplers_count); + CGLTF_PTRFIXUP(data->animations[i].channels[j].target_node, data->nodes, data->nodes_count); + } + } + + return 0; +} + +/* + * -- jsmn.c start -- + * Source: https://github.com/zserge/jsmn + * License: MIT + * + * Copyright (c) 2010 Serge A. Zaitsev + + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + * THE SOFTWARE. + */ + +/** + * Allocates a fresh unused token from the token pull. + */ +static jsmntok_t *jsmn_alloc_token(jsmn_parser *parser, + jsmntok_t *tokens, size_t num_tokens) { + jsmntok_t *tok; + if (parser->toknext >= num_tokens) { + return NULL; + } + tok = &tokens[parser->toknext++]; + tok->start = tok->end = -1; + tok->size = 0; +#ifdef JSMN_PARENT_LINKS + tok->parent = -1; +#endif + return tok; +} + +/** + * Fills token type and boundaries. + */ +static void jsmn_fill_token(jsmntok_t *token, jsmntype_t type, + int start, int end) { + token->type = type; + token->start = start; + token->end = end; + token->size = 0; +} + +/** + * Fills next available token with JSON primitive. + */ +static int jsmn_parse_primitive(jsmn_parser *parser, const char *js, + size_t len, jsmntok_t *tokens, size_t num_tokens) { + jsmntok_t *token; + int start; + + start = parser->pos; + + for (; parser->pos < len && js[parser->pos] != '\0'; parser->pos++) { + switch (js[parser->pos]) { +#ifndef JSMN_STRICT + /* In strict mode primitive must be followed by "," or "}" or "]" */ + case ':': +#endif + case '\t' : case '\r' : case '\n' : case ' ' : + case ',' : case ']' : case '}' : + goto found; + } + if (js[parser->pos] < 32 || js[parser->pos] >= 127) { + parser->pos = start; + return JSMN_ERROR_INVAL; + } + } +#ifdef JSMN_STRICT + /* In strict mode primitive must be followed by a comma/object/array */ + parser->pos = start; + return JSMN_ERROR_PART; +#endif + +found: + if (tokens == NULL) { + parser->pos--; + return 0; + } + token = jsmn_alloc_token(parser, tokens, num_tokens); + if (token == NULL) { + parser->pos = start; + return JSMN_ERROR_NOMEM; + } + jsmn_fill_token(token, JSMN_PRIMITIVE, start, parser->pos); +#ifdef JSMN_PARENT_LINKS + token->parent = parser->toksuper; +#endif + parser->pos--; + return 0; +} + +/** + * Fills next token with JSON string. + */ +static int jsmn_parse_string(jsmn_parser *parser, const char *js, + size_t len, jsmntok_t *tokens, size_t num_tokens) { + jsmntok_t *token; + + int start = parser->pos; + + parser->pos++; + + /* Skip starting quote */ + for (; parser->pos < len && js[parser->pos] != '\0'; parser->pos++) { + char c = js[parser->pos]; + + /* Quote: end of string */ + if (c == '\"') { + if (tokens == NULL) { + return 0; + } + token = jsmn_alloc_token(parser, tokens, num_tokens); + if (token == NULL) { + parser->pos = start; + return JSMN_ERROR_NOMEM; + } + jsmn_fill_token(token, JSMN_STRING, start+1, parser->pos); +#ifdef JSMN_PARENT_LINKS + token->parent = parser->toksuper; +#endif + return 0; + } + + /* Backslash: Quoted symbol expected */ + if (c == '\\' && parser->pos + 1 < len) { + int i; + parser->pos++; + switch (js[parser->pos]) { + /* Allowed escaped symbols */ + case '\"': case '/' : case '\\' : case 'b' : + case 'f' : case 'r' : case 'n' : case 't' : + break; + /* Allows escaped symbol \uXXXX */ + case 'u': + parser->pos++; + for(i = 0; i < 4 && parser->pos < len && js[parser->pos] != '\0'; i++) { + /* If it isn't a hex character we have an error */ + if(!((js[parser->pos] >= 48 && js[parser->pos] <= 57) || /* 0-9 */ + (js[parser->pos] >= 65 && js[parser->pos] <= 70) || /* A-F */ + (js[parser->pos] >= 97 && js[parser->pos] <= 102))) { /* a-f */ + parser->pos = start; + return JSMN_ERROR_INVAL; + } + parser->pos++; + } + parser->pos--; + break; + /* Unexpected symbol */ + default: + parser->pos = start; + return JSMN_ERROR_INVAL; + } + } + } + parser->pos = start; + return JSMN_ERROR_PART; +} + +/** + * Parse JSON string and fill tokens. + */ +static int jsmn_parse(jsmn_parser *parser, const char *js, size_t len, + jsmntok_t *tokens, size_t num_tokens) { + int r; + int i; + jsmntok_t *token; + int count = parser->toknext; + + for (; parser->pos < len && js[parser->pos] != '\0'; parser->pos++) { + char c; + jsmntype_t type; + + c = js[parser->pos]; + switch (c) { + case '{': case '[': + count++; + if (tokens == NULL) { + break; + } + token = jsmn_alloc_token(parser, tokens, num_tokens); + if (token == NULL) + return JSMN_ERROR_NOMEM; + if (parser->toksuper != -1) { + tokens[parser->toksuper].size++; +#ifdef JSMN_PARENT_LINKS + token->parent = parser->toksuper; +#endif + } + token->type = (c == '{' ? JSMN_OBJECT : JSMN_ARRAY); + token->start = parser->pos; + parser->toksuper = parser->toknext - 1; + break; + case '}': case ']': + if (tokens == NULL) + break; + type = (c == '}' ? JSMN_OBJECT : JSMN_ARRAY); +#ifdef JSMN_PARENT_LINKS + if (parser->toknext < 1) { + return JSMN_ERROR_INVAL; + } + token = &tokens[parser->toknext - 1]; + for (;;) { + if (token->start != -1 && token->end == -1) { + if (token->type != type) { + return JSMN_ERROR_INVAL; + } + token->end = parser->pos + 1; + parser->toksuper = token->parent; + break; + } + if (token->parent == -1) { + if(token->type != type || parser->toksuper == -1) { + return JSMN_ERROR_INVAL; + } + break; + } + token = &tokens[token->parent]; + } +#else + for (i = parser->toknext - 1; i >= 0; i--) { + token = &tokens[i]; + if (token->start != -1 && token->end == -1) { + if (token->type != type) { + return JSMN_ERROR_INVAL; + } + parser->toksuper = -1; + token->end = parser->pos + 1; + break; + } + } + /* Error if unmatched closing bracket */ + if (i == -1) return JSMN_ERROR_INVAL; + for (; i >= 0; i--) { + token = &tokens[i]; + if (token->start != -1 && token->end == -1) { + parser->toksuper = i; + break; + } + } +#endif + break; + case '\"': + r = jsmn_parse_string(parser, js, len, tokens, num_tokens); + if (r < 0) return r; + count++; + if (parser->toksuper != -1 && tokens != NULL) + tokens[parser->toksuper].size++; + break; + case '\t' : case '\r' : case '\n' : case ' ': + break; + case ':': + parser->toksuper = parser->toknext - 1; + break; + case ',': + if (tokens != NULL && parser->toksuper != -1 && + tokens[parser->toksuper].type != JSMN_ARRAY && + tokens[parser->toksuper].type != JSMN_OBJECT) { +#ifdef JSMN_PARENT_LINKS + parser->toksuper = tokens[parser->toksuper].parent; +#else + for (i = parser->toknext - 1; i >= 0; i--) { + if (tokens[i].type == JSMN_ARRAY || tokens[i].type == JSMN_OBJECT) { + if (tokens[i].start != -1 && tokens[i].end == -1) { + parser->toksuper = i; + break; + } + } + } +#endif + } + break; +#ifdef JSMN_STRICT + /* In strict mode primitives are: numbers and booleans */ + case '-': case '0': case '1' : case '2': case '3' : case '4': + case '5': case '6': case '7' : case '8': case '9': + case 't': case 'f': case 'n' : + /* And they must not be keys of the object */ + if (tokens != NULL && parser->toksuper != -1) { + jsmntok_t *t = &tokens[parser->toksuper]; + if (t->type == JSMN_OBJECT || + (t->type == JSMN_STRING && t->size != 0)) { + return JSMN_ERROR_INVAL; + } + } +#else + /* In non-strict mode every unquoted value is a primitive */ + default: +#endif + r = jsmn_parse_primitive(parser, js, len, tokens, num_tokens); + if (r < 0) return r; + count++; + if (parser->toksuper != -1 && tokens != NULL) + tokens[parser->toksuper].size++; + break; + +#ifdef JSMN_STRICT + /* Unexpected char in strict mode */ + default: + return JSMN_ERROR_INVAL; +#endif + } + } + + if (tokens != NULL) { + for (i = parser->toknext - 1; i >= 0; i--) { + /* Unmatched opened object or array */ + if (tokens[i].start != -1 && tokens[i].end == -1) { + return JSMN_ERROR_PART; + } + } + } + + return count; +} + +/** + * Creates a new parser based over a given buffer with an array of tokens + * available. + */ +static void jsmn_init(jsmn_parser *parser) { + parser->pos = 0; + parser->toknext = 0; + parser->toksuper = -1; +} +/* + * -- jsmn.c end -- + */ + +#endif /* #ifdef CGLTF_IMPLEMENTATION */ + +/* cgltf is distributed under MIT license: + * + * Copyright (c) 2018-2021 Johannes Kuhlmann + + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + + * The above copyright notice and this permission notice shall be included in all + * copies or substantial portions of the Software. + + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ diff --git a/source/engine/thirdparty/cgltf/cgltf_write.h b/source/engine/thirdparty/cgltf/cgltf_write.h new file mode 100644 index 0000000..8b96eb2 --- /dev/null +++ b/source/engine/thirdparty/cgltf/cgltf_write.h @@ -0,0 +1,1333 @@ +/** + * cgltf_write - a single-file glTF 2.0 writer written in C99. + * + * Version: 1.11 + * + * Website: https://github.com/jkuhlmann/cgltf + * + * Distributed under the MIT License, see notice at the end of this file. + * + * Building: + * Include this file where you need the struct and function + * declarations. Have exactly one source file where you define + * `CGLTF_WRITE_IMPLEMENTATION` before including this file to get the + * function definitions. + * + * Reference: + * `cgltf_result cgltf_write_file(const cgltf_options* options, const char* + * path, const cgltf_data* data)` writes JSON to the given file path. Buffer + * files and external images are not written out. `data` is not deallocated. + * + * `cgltf_size cgltf_write(const cgltf_options* options, char* buffer, + * cgltf_size size, const cgltf_data* data)` writes JSON into the given memory + * buffer. Returns the number of bytes written to `buffer`, including a null + * terminator. If buffer is null, returns the number of bytes that would have + * been written. `data` is not deallocated. + * + * To write custom JSON into the `extras` field, aggregate all the custom JSON + * into a single buffer, then set `file_data` to this buffer. By supplying + * start_offset and end_offset values for various objects, you can select a + * range of characters within the aggregated buffer. + */ +#ifndef CGLTF_WRITE_H_INCLUDED__ +#define CGLTF_WRITE_H_INCLUDED__ + +#include "cgltf.h" + +#include +#include + +#ifdef __cplusplus +extern "C" { +#endif + +cgltf_result cgltf_write_file(const cgltf_options* options, const char* path, const cgltf_data* data); +cgltf_size cgltf_write(const cgltf_options* options, char* buffer, cgltf_size size, const cgltf_data* data); + +#ifdef __cplusplus +} +#endif + +#endif /* #ifndef CGLTF_WRITE_H_INCLUDED__ */ + +/* + * + * Stop now, if you are only interested in the API. + * Below, you find the implementation. + * + */ + +#if defined(__INTELLISENSE__) || defined(__JETBRAINS_IDE__) +/* This makes MSVC/CLion intellisense work. */ +#define CGLTF_IMPLEMENTATION +#endif + +#ifdef CGLTF_WRITE_IMPLEMENTATION + +#include +#include +#include +#include +#include +#include + +#define CGLTF_EXTENSION_FLAG_TEXTURE_TRANSFORM (1 << 0) +#define CGLTF_EXTENSION_FLAG_MATERIALS_UNLIT (1 << 1) +#define CGLTF_EXTENSION_FLAG_SPECULAR_GLOSSINESS (1 << 2) +#define CGLTF_EXTENSION_FLAG_LIGHTS_PUNCTUAL (1 << 3) +#define CGLTF_EXTENSION_FLAG_DRACO_MESH_COMPRESSION (1 << 4) +#define CGLTF_EXTENSION_FLAG_MATERIALS_CLEARCOAT (1 << 5) +#define CGLTF_EXTENSION_FLAG_MATERIALS_IOR (1 << 6) +#define CGLTF_EXTENSION_FLAG_MATERIALS_SPECULAR (1 << 7) +#define CGLTF_EXTENSION_FLAG_MATERIALS_TRANSMISSION (1 << 8) +#define CGLTF_EXTENSION_FLAG_MATERIALS_SHEEN (1 << 9) +#define CGLTF_EXTENSION_FLAG_MATERIALS_VARIANTS (1 << 10) +#define CGLTF_EXTENSION_FLAG_MATERIALS_VOLUME (1 << 11) +#define CGLTF_EXTENSION_FLAG_TEXTURE_BASISU (1 << 12) + +typedef struct { + char* buffer; + cgltf_size buffer_size; + cgltf_size remaining; + char* cursor; + cgltf_size tmp; + cgltf_size chars_written; + const cgltf_data* data; + int depth; + const char* indent; + int needs_comma; + uint32_t extension_flags; + uint32_t required_extension_flags; +} cgltf_write_context; + +#define CGLTF_MIN(a, b) (a < b ? a : b) + +#ifdef FLT_DECIMAL_DIG + // FLT_DECIMAL_DIG is C11 + #define CGLTF_DECIMAL_DIG (FLT_DECIMAL_DIG) +#else + #define CGLTF_DECIMAL_DIG 9 +#endif + +#define CGLTF_SPRINTF(...) { \ + assert(context->cursor || (!context->cursor && context->remaining == 0)); \ + context->tmp = snprintf ( context->cursor, context->remaining, __VA_ARGS__ ); \ + context->chars_written += context->tmp; \ + if (context->cursor) { \ + context->cursor += context->tmp; \ + context->remaining -= context->tmp; \ + } } + +#define CGLTF_SNPRINTF(length, ...) { \ + assert(context->cursor || (!context->cursor && context->remaining == 0)); \ + context->tmp = snprintf ( context->cursor, CGLTF_MIN(length + 1, context->remaining), __VA_ARGS__ ); \ + context->chars_written += length; \ + if (context->cursor) { \ + context->cursor += length; \ + context->remaining -= length; \ + } } + +#define CGLTF_WRITE_IDXPROP(label, val, start) if (val) { \ + cgltf_write_indent(context); \ + CGLTF_SPRINTF("\"%s\": %d", label, (int) (val - start)); \ + context->needs_comma = 1; } + +#define CGLTF_WRITE_IDXARRPROP(label, dim, vals, start) if (vals) { \ + cgltf_write_indent(context); \ + CGLTF_SPRINTF("\"%s\": [", label); \ + for (int i = 0; i < (int)(dim); ++i) { \ + int idx = (int) (vals[i] - start); \ + if (i != 0) CGLTF_SPRINTF(","); \ + CGLTF_SPRINTF(" %d", idx); \ + } \ + CGLTF_SPRINTF(" ]"); \ + context->needs_comma = 1; } + +#define CGLTF_WRITE_TEXTURE_INFO(label, info) if (info.texture) { \ + cgltf_write_line(context, "\"" label "\": {"); \ + CGLTF_WRITE_IDXPROP("index", info.texture, context->data->textures); \ + cgltf_write_intprop(context, "texCoord", info.texcoord, 0); \ + cgltf_write_floatprop(context, "scale", info.scale, 1.0f); \ + if (info.has_transform) { \ + context->extension_flags |= CGLTF_EXTENSION_FLAG_TEXTURE_TRANSFORM; \ + cgltf_write_texture_transform(context, &info.transform); \ + } \ + cgltf_write_extras(context, &info.extras); \ + cgltf_write_line(context, "}"); } + +static void cgltf_write_indent(cgltf_write_context* context) +{ + if (context->needs_comma) + { + CGLTF_SPRINTF(",\n"); + context->needs_comma = 0; + } + else + { + CGLTF_SPRINTF("\n"); + } + for (int i = 0; i < context->depth; ++i) + { + CGLTF_SPRINTF("%s", context->indent); + } +} + +static void cgltf_write_line(cgltf_write_context* context, const char* line) +{ + if (line[0] == ']' || line[0] == '}') + { + --context->depth; + context->needs_comma = 0; + } + cgltf_write_indent(context); + CGLTF_SPRINTF("%s", line); + cgltf_size last = (cgltf_size)(strlen(line) - 1); + if (line[0] == ']' || line[0] == '}') + { + context->needs_comma = 1; + } + if (line[last] == '[' || line[last] == '{') + { + ++context->depth; + context->needs_comma = 0; + } +} + +static void cgltf_write_strprop(cgltf_write_context* context, const char* label, const char* val) +{ + if (val) + { + cgltf_write_indent(context); + CGLTF_SPRINTF("\"%s\": \"%s\"", label, val); + context->needs_comma = 1; + } +} + +static void cgltf_write_extras(cgltf_write_context* context, const cgltf_extras* extras) +{ + cgltf_size length = extras->end_offset - extras->start_offset; + if (length > 0 && context->data->file_data) + { + char* json_string = ((char*) context->data->file_data) + extras->start_offset; + cgltf_write_indent(context); + CGLTF_SPRINTF("%s", "\"extras\": "); + CGLTF_SNPRINTF(length, "%.*s", (int)(extras->end_offset - extras->start_offset), json_string); + context->needs_comma = 1; + } +} + +static void cgltf_write_stritem(cgltf_write_context* context, const char* item) +{ + cgltf_write_indent(context); + CGLTF_SPRINTF("\"%s\"", item); + context->needs_comma = 1; +} + +static void cgltf_write_intprop(cgltf_write_context* context, const char* label, int val, int def) +{ + if (val != def) + { + cgltf_write_indent(context); + CGLTF_SPRINTF("\"%s\": %d", label, val); + context->needs_comma = 1; + } +} + +static void cgltf_write_sizeprop(cgltf_write_context* context, const char* label, cgltf_size val, cgltf_size def) +{ + if (val != def) + { + cgltf_write_indent(context); + CGLTF_SPRINTF("\"%s\": %zu", label, val); + context->needs_comma = 1; + } +} + +static void cgltf_write_floatprop(cgltf_write_context* context, const char* label, float val, float def) +{ + if (val != def) + { + cgltf_write_indent(context); + CGLTF_SPRINTF("\"%s\": ", label); + CGLTF_SPRINTF("%.*g", CGLTF_DECIMAL_DIG, val); + context->needs_comma = 1; + + if (context->cursor) + { + char *decimal_comma = strchr(context->cursor - context->tmp, ','); + if (decimal_comma) + { + *decimal_comma = '.'; + } + } + } +} + +static void cgltf_write_boolprop_optional(cgltf_write_context* context, const char* label, bool val, bool def) +{ + if (val != def) + { + cgltf_write_indent(context); + CGLTF_SPRINTF("\"%s\": %s", label, val ? "true" : "false"); + context->needs_comma = 1; + } +} + +static void cgltf_write_floatarrayprop(cgltf_write_context* context, const char* label, const cgltf_float* vals, cgltf_size dim) +{ + cgltf_write_indent(context); + CGLTF_SPRINTF("\"%s\": [", label); + for (cgltf_size i = 0; i < dim; ++i) + { + if (i != 0) + { + CGLTF_SPRINTF(", %.*g", CGLTF_DECIMAL_DIG, vals[i]); + } + else + { + CGLTF_SPRINTF("%.*g", CGLTF_DECIMAL_DIG, vals[i]); + } + } + CGLTF_SPRINTF("]"); + context->needs_comma = 1; +} + +static bool cgltf_check_floatarray(const float* vals, int dim, float val) { + while (dim--) + { + if (vals[dim] != val) + { + return true; + } + } + return false; +} + +static int cgltf_int_from_component_type(cgltf_component_type ctype) +{ + switch (ctype) + { + case cgltf_component_type_r_8: return 5120; + case cgltf_component_type_r_8u: return 5121; + case cgltf_component_type_r_16: return 5122; + case cgltf_component_type_r_16u: return 5123; + case cgltf_component_type_r_32u: return 5125; + case cgltf_component_type_r_32f: return 5126; + default: return 0; + } +} + +static const char* cgltf_str_from_alpha_mode(cgltf_alpha_mode alpha_mode) +{ + switch (alpha_mode) + { + case cgltf_alpha_mode_mask: return "MASK"; + case cgltf_alpha_mode_blend: return "BLEND"; + default: return NULL; + } +} + +static const char* cgltf_str_from_type(cgltf_type type) +{ + switch (type) + { + case cgltf_type_scalar: return "SCALAR"; + case cgltf_type_vec2: return "VEC2"; + case cgltf_type_vec3: return "VEC3"; + case cgltf_type_vec4: return "VEC4"; + case cgltf_type_mat2: return "MAT2"; + case cgltf_type_mat3: return "MAT3"; + case cgltf_type_mat4: return "MAT4"; + default: return NULL; + } +} + +static cgltf_size cgltf_dim_from_type(cgltf_type type) +{ + switch (type) + { + case cgltf_type_scalar: return 1; + case cgltf_type_vec2: return 2; + case cgltf_type_vec3: return 3; + case cgltf_type_vec4: return 4; + case cgltf_type_mat2: return 4; + case cgltf_type_mat3: return 9; + case cgltf_type_mat4: return 16; + default: return 0; + } +} + +static const char* cgltf_str_from_camera_type(cgltf_camera_type camera_type) +{ + switch (camera_type) + { + case cgltf_camera_type_perspective: return "perspective"; + case cgltf_camera_type_orthographic: return "orthographic"; + default: return NULL; + } +} + +static const char* cgltf_str_from_light_type(cgltf_light_type light_type) +{ + switch (light_type) + { + case cgltf_light_type_directional: return "directional"; + case cgltf_light_type_point: return "point"; + case cgltf_light_type_spot: return "spot"; + default: return NULL; + } +} + +static void cgltf_write_texture_transform(cgltf_write_context* context, const cgltf_texture_transform* transform) +{ + cgltf_write_line(context, "\"extensions\": {"); + cgltf_write_line(context, "\"KHR_texture_transform\": {"); + if (cgltf_check_floatarray(transform->offset, 2, 0.0f)) + { + cgltf_write_floatarrayprop(context, "offset", transform->offset, 2); + } + cgltf_write_floatprop(context, "rotation", transform->rotation, 0.0f); + if (cgltf_check_floatarray(transform->scale, 2, 1.0f)) + { + cgltf_write_floatarrayprop(context, "scale", transform->scale, 2); + } + if (transform->has_texcoord) + { + cgltf_write_intprop(context, "texCoord", transform->texcoord, -1); + } + cgltf_write_line(context, "}"); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_asset(cgltf_write_context* context, const cgltf_asset* asset) +{ + cgltf_write_line(context, "\"asset\": {"); + cgltf_write_strprop(context, "copyright", asset->copyright); + cgltf_write_strprop(context, "generator", asset->generator); + cgltf_write_strprop(context, "version", asset->version); + cgltf_write_strprop(context, "min_version", asset->min_version); + cgltf_write_extras(context, &asset->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_primitive(cgltf_write_context* context, const cgltf_primitive* prim) +{ + cgltf_write_intprop(context, "mode", (int) prim->type, 4); + CGLTF_WRITE_IDXPROP("indices", prim->indices, context->data->accessors); + CGLTF_WRITE_IDXPROP("material", prim->material, context->data->materials); + cgltf_write_line(context, "\"attributes\": {"); + for (cgltf_size i = 0; i < prim->attributes_count; ++i) + { + const cgltf_attribute* attr = prim->attributes + i; + CGLTF_WRITE_IDXPROP(attr->name, attr->data, context->data->accessors); + } + cgltf_write_line(context, "}"); + + if (prim->targets_count) + { + cgltf_write_line(context, "\"targets\": ["); + for (cgltf_size i = 0; i < prim->targets_count; ++i) + { + cgltf_write_line(context, "{"); + for (cgltf_size j = 0; j < prim->targets[i].attributes_count; ++j) + { + const cgltf_attribute* attr = prim->targets[i].attributes + j; + CGLTF_WRITE_IDXPROP(attr->name, attr->data, context->data->accessors); + } + cgltf_write_line(context, "}"); + } + cgltf_write_line(context, "]"); + } + cgltf_write_extras(context, &prim->extras); + + if (prim->has_draco_mesh_compression || prim->mappings_count > 0) + { + cgltf_write_line(context, "\"extensions\": {"); + + if (prim->has_draco_mesh_compression) + { + context->extension_flags |= CGLTF_EXTENSION_FLAG_DRACO_MESH_COMPRESSION; + if (prim->attributes_count == 0 || prim->indices == 0) + { + context->required_extension_flags |= CGLTF_EXTENSION_FLAG_DRACO_MESH_COMPRESSION; + } + + cgltf_write_line(context, "\"KHR_draco_mesh_compression\": {"); + CGLTF_WRITE_IDXPROP("bufferView", prim->draco_mesh_compression.buffer_view, context->data->buffer_views); + cgltf_write_line(context, "\"attributes\": {"); + for (cgltf_size i = 0; i < prim->draco_mesh_compression.attributes_count; ++i) + { + const cgltf_attribute* attr = prim->draco_mesh_compression.attributes + i; + CGLTF_WRITE_IDXPROP(attr->name, attr->data, context->data->accessors); + } + cgltf_write_line(context, "}"); + cgltf_write_line(context, "}"); + } + + if (prim->mappings_count > 0) + { + context->extension_flags |= CGLTF_EXTENSION_FLAG_MATERIALS_VARIANTS; + cgltf_write_line(context, "\"KHR_materials_variants\": {"); + cgltf_write_line(context, "\"mappings\": ["); + for (cgltf_size i = 0; i < prim->mappings_count; ++i) + { + const cgltf_material_mapping* map = prim->mappings + i; + cgltf_write_line(context, "{"); + CGLTF_WRITE_IDXPROP("material", map->material, context->data->materials); + + cgltf_write_indent(context); + CGLTF_SPRINTF("\"variants\": [%d]", (int)map->variant); + context->needs_comma = 1; + + cgltf_write_extras(context, &map->extras); + cgltf_write_line(context, "}"); + } + cgltf_write_line(context, "]"); + cgltf_write_line(context, "}"); + } + + cgltf_write_line(context, "}"); + } +} + +static void cgltf_write_mesh(cgltf_write_context* context, const cgltf_mesh* mesh) +{ + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "name", mesh->name); + + cgltf_write_line(context, "\"primitives\": ["); + for (cgltf_size i = 0; i < mesh->primitives_count; ++i) + { + cgltf_write_line(context, "{"); + cgltf_write_primitive(context, mesh->primitives + i); + cgltf_write_line(context, "}"); + } + cgltf_write_line(context, "]"); + + if (mesh->weights_count > 0) + { + cgltf_write_floatarrayprop(context, "weights", mesh->weights, mesh->weights_count); + } + cgltf_write_extras(context, &mesh->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_buffer_view(cgltf_write_context* context, const cgltf_buffer_view* view) +{ + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "name", view->name); + CGLTF_WRITE_IDXPROP("buffer", view->buffer, context->data->buffers); + cgltf_write_sizeprop(context, "byteLength", view->size, (cgltf_size)-1); + cgltf_write_sizeprop(context, "byteOffset", view->offset, 0); + cgltf_write_sizeprop(context, "byteStride", view->stride, 0); + // NOTE: We skip writing "target" because the spec says its usage can be inferred. + cgltf_write_extras(context, &view->extras); + cgltf_write_line(context, "}"); +} + + +static void cgltf_write_buffer(cgltf_write_context* context, const cgltf_buffer* buffer) +{ + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "name", buffer->name); + cgltf_write_strprop(context, "uri", buffer->uri); + cgltf_write_sizeprop(context, "byteLength", buffer->size, (cgltf_size)-1); + cgltf_write_extras(context, &buffer->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_material(cgltf_write_context* context, const cgltf_material* material) +{ + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "name", material->name); + if (material->alpha_mode == cgltf_alpha_mode_mask) + { + cgltf_write_floatprop(context, "alphaCutoff", material->alpha_cutoff, 0.5f); + } + cgltf_write_boolprop_optional(context, "doubleSided", material->double_sided, false); + // cgltf_write_boolprop_optional(context, "unlit", material->unlit, false); + + if (material->unlit) + { + context->extension_flags |= CGLTF_EXTENSION_FLAG_MATERIALS_UNLIT; + } + + if (material->has_pbr_specular_glossiness) + { + context->extension_flags |= CGLTF_EXTENSION_FLAG_SPECULAR_GLOSSINESS; + } + + if (material->has_clearcoat) + { + context->extension_flags |= CGLTF_EXTENSION_FLAG_MATERIALS_CLEARCOAT; + } + + if (material->has_transmission) + { + context->extension_flags |= CGLTF_EXTENSION_FLAG_MATERIALS_TRANSMISSION; + } + + if (material->has_volume) + { + context->extension_flags |= CGLTF_EXTENSION_FLAG_MATERIALS_VOLUME; + } + + if (material->has_ior) + { + context->extension_flags |= CGLTF_EXTENSION_FLAG_MATERIALS_IOR; + } + + if (material->has_specular) + { + context->extension_flags |= CGLTF_EXTENSION_FLAG_MATERIALS_SPECULAR; + } + + if (material->has_sheen) + { + context->extension_flags |= CGLTF_EXTENSION_FLAG_MATERIALS_SHEEN; + } + + if (material->has_pbr_metallic_roughness) + { + const cgltf_pbr_metallic_roughness* params = &material->pbr_metallic_roughness; + cgltf_write_line(context, "\"pbrMetallicRoughness\": {"); + CGLTF_WRITE_TEXTURE_INFO("baseColorTexture", params->base_color_texture); + CGLTF_WRITE_TEXTURE_INFO("metallicRoughnessTexture", params->metallic_roughness_texture); + cgltf_write_floatprop(context, "metallicFactor", params->metallic_factor, 1.0f); + cgltf_write_floatprop(context, "roughnessFactor", params->roughness_factor, 1.0f); + if (cgltf_check_floatarray(params->base_color_factor, 4, 1.0f)) + { + cgltf_write_floatarrayprop(context, "baseColorFactor", params->base_color_factor, 4); + } + cgltf_write_extras(context, ¶ms->extras); + cgltf_write_line(context, "}"); + } + + if (material->unlit || material->has_pbr_specular_glossiness || material->has_clearcoat || material->has_ior || material->has_specular || material->has_transmission || material->has_sheen || material->has_volume) + { + cgltf_write_line(context, "\"extensions\": {"); + if (material->has_clearcoat) + { + const cgltf_clearcoat* params = &material->clearcoat; + cgltf_write_line(context, "\"KHR_materials_clearcoat\": {"); + CGLTF_WRITE_TEXTURE_INFO("clearcoatTexture", params->clearcoat_texture); + CGLTF_WRITE_TEXTURE_INFO("clearcoatRoughnessTexture", params->clearcoat_roughness_texture); + CGLTF_WRITE_TEXTURE_INFO("clearcoatNormalTexture", params->clearcoat_normal_texture); + cgltf_write_floatprop(context, "clearcoatFactor", params->clearcoat_factor, 0.0f); + cgltf_write_floatprop(context, "clearcoatRoughnessFactor", params->clearcoat_roughness_factor, 0.0f); + cgltf_write_line(context, "}"); + } + if (material->has_ior) + { + const cgltf_ior* params = &material->ior; + cgltf_write_line(context, "\"KHR_materials_ior\": {"); + cgltf_write_floatprop(context, "ior", params->ior, 1.5f); + cgltf_write_line(context, "}"); + } + if (material->has_specular) + { + const cgltf_specular* params = &material->specular; + cgltf_write_line(context, "\"KHR_materials_specular\": {"); + CGLTF_WRITE_TEXTURE_INFO("specularTexture", params->specular_texture); + CGLTF_WRITE_TEXTURE_INFO("specularColorTexture", params->specular_color_texture); + cgltf_write_floatprop(context, "specularFactor", params->specular_factor, 1.0f); + if (cgltf_check_floatarray(params->specular_color_factor, 3, 1.0f)) + { + cgltf_write_floatarrayprop(context, "specularColorFactor", params->specular_color_factor, 3); + } + cgltf_write_line(context, "}"); + } + if (material->has_transmission) + { + const cgltf_transmission* params = &material->transmission; + cgltf_write_line(context, "\"KHR_materials_transmission\": {"); + CGLTF_WRITE_TEXTURE_INFO("transmissionTexture", params->transmission_texture); + cgltf_write_floatprop(context, "transmissionFactor", params->transmission_factor, 0.0f); + cgltf_write_line(context, "}"); + } + if (material->has_volume) + { + const cgltf_volume* params = &material->volume; + cgltf_write_line(context, "\"KHR_materials_volume\": {"); + CGLTF_WRITE_TEXTURE_INFO("thicknessTexture", params->thickness_texture); + cgltf_write_floatprop(context, "thicknessFactor", params->thickness_factor, 0.0f); + if (cgltf_check_floatarray(params->attenuation_color, 3, 1.0f)) + { + cgltf_write_floatarrayprop(context, "attenuationColor", params->attenuation_color, 3); + } + if (params->attenuation_distance < FLT_MAX) + { + cgltf_write_floatprop(context, "attenuationDistance", params->attenuation_distance, FLT_MAX); + } + cgltf_write_line(context, "}"); + } + if (material->has_sheen) + { + const cgltf_sheen* params = &material->sheen; + cgltf_write_line(context, "\"KHR_materials_sheen\": {"); + CGLTF_WRITE_TEXTURE_INFO("sheenColorTexture", params->sheen_color_texture); + CGLTF_WRITE_TEXTURE_INFO("sheenRoughnessTexture", params->sheen_roughness_texture); + if (cgltf_check_floatarray(params->sheen_color_factor, 3, 0.0f)) + { + cgltf_write_floatarrayprop(context, "sheenColorFactor", params->sheen_color_factor, 3); + } + cgltf_write_floatprop(context, "sheenRoughnessFactor", params->sheen_roughness_factor, 0.0f); + cgltf_write_line(context, "}"); + } + if (material->has_pbr_specular_glossiness) + { + const cgltf_pbr_specular_glossiness* params = &material->pbr_specular_glossiness; + cgltf_write_line(context, "\"KHR_materials_pbrSpecularGlossiness\": {"); + CGLTF_WRITE_TEXTURE_INFO("diffuseTexture", params->diffuse_texture); + CGLTF_WRITE_TEXTURE_INFO("specularGlossinessTexture", params->specular_glossiness_texture); + if (cgltf_check_floatarray(params->diffuse_factor, 4, 1.0f)) + { + cgltf_write_floatarrayprop(context, "diffuseFactor", params->diffuse_factor, 4); + } + if (cgltf_check_floatarray(params->specular_factor, 3, 1.0f)) + { + cgltf_write_floatarrayprop(context, "specularFactor", params->specular_factor, 3); + } + cgltf_write_floatprop(context, "glossinessFactor", params->glossiness_factor, 1.0f); + cgltf_write_line(context, "}"); + } + if (material->unlit) + { + cgltf_write_line(context, "\"KHR_materials_unlit\": {}"); + } + cgltf_write_line(context, "}"); + } + + CGLTF_WRITE_TEXTURE_INFO("normalTexture", material->normal_texture); + CGLTF_WRITE_TEXTURE_INFO("occlusionTexture", material->occlusion_texture); + CGLTF_WRITE_TEXTURE_INFO("emissiveTexture", material->emissive_texture); + if (cgltf_check_floatarray(material->emissive_factor, 3, 0.0f)) + { + cgltf_write_floatarrayprop(context, "emissiveFactor", material->emissive_factor, 3); + } + cgltf_write_strprop(context, "alphaMode", cgltf_str_from_alpha_mode(material->alpha_mode)); + cgltf_write_extras(context, &material->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_image(cgltf_write_context* context, const cgltf_image* image) +{ + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "name", image->name); + cgltf_write_strprop(context, "uri", image->uri); + CGLTF_WRITE_IDXPROP("bufferView", image->buffer_view, context->data->buffer_views); + cgltf_write_strprop(context, "mimeType", image->mime_type); + cgltf_write_extras(context, &image->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_texture(cgltf_write_context* context, const cgltf_texture* texture) +{ + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "name", texture->name); + CGLTF_WRITE_IDXPROP("source", texture->image, context->data->images); + CGLTF_WRITE_IDXPROP("sampler", texture->sampler, context->data->samplers); + + if (texture->has_basisu) + { + cgltf_write_line(context, "\"extensions\": {"); + { + context->extension_flags |= CGLTF_EXTENSION_FLAG_TEXTURE_BASISU; + cgltf_write_line(context, "\"KHR_texture_basisu\": {"); + CGLTF_WRITE_IDXPROP("source", texture->basisu_image, context->data->images); + cgltf_write_line(context, "}"); + } + cgltf_write_line(context, "}"); + } + cgltf_write_extras(context, &texture->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_skin(cgltf_write_context* context, const cgltf_skin* skin) +{ + cgltf_write_line(context, "{"); + CGLTF_WRITE_IDXPROP("skeleton", skin->skeleton, context->data->nodes); + CGLTF_WRITE_IDXPROP("inverseBindMatrices", skin->inverse_bind_matrices, context->data->accessors); + CGLTF_WRITE_IDXARRPROP("joints", skin->joints_count, skin->joints, context->data->nodes); + cgltf_write_strprop(context, "name", skin->name); + cgltf_write_extras(context, &skin->extras); + cgltf_write_line(context, "}"); +} + +static const char* cgltf_write_str_path_type(cgltf_animation_path_type path_type) +{ + switch (path_type) + { + case cgltf_animation_path_type_translation: + return "translation"; + case cgltf_animation_path_type_rotation: + return "rotation"; + case cgltf_animation_path_type_scale: + return "scale"; + case cgltf_animation_path_type_weights: + return "weights"; + case cgltf_animation_path_type_invalid: + break; + } + return "invalid"; +} + +static const char* cgltf_write_str_interpolation_type(cgltf_interpolation_type interpolation_type) +{ + switch (interpolation_type) + { + case cgltf_interpolation_type_linear: + return "LINEAR"; + case cgltf_interpolation_type_step: + return "STEP"; + case cgltf_interpolation_type_cubic_spline: + return "CUBICSPLINE"; + } + return "invalid"; +} + +static void cgltf_write_path_type(cgltf_write_context* context, const char *label, cgltf_animation_path_type path_type) +{ + cgltf_write_strprop(context, label, cgltf_write_str_path_type(path_type)); +} + +static void cgltf_write_interpolation_type(cgltf_write_context* context, const char *label, cgltf_interpolation_type interpolation_type) +{ + cgltf_write_strprop(context, label, cgltf_write_str_interpolation_type(interpolation_type)); +} + +static void cgltf_write_animation_sampler(cgltf_write_context* context, const cgltf_animation_sampler* animation_sampler) +{ + cgltf_write_line(context, "{"); + cgltf_write_interpolation_type(context, "interpolation", animation_sampler->interpolation); + CGLTF_WRITE_IDXPROP("input", animation_sampler->input, context->data->accessors); + CGLTF_WRITE_IDXPROP("output", animation_sampler->output, context->data->accessors); + cgltf_write_extras(context, &animation_sampler->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_animation_channel(cgltf_write_context* context, const cgltf_animation* animation, const cgltf_animation_channel* animation_channel) +{ + cgltf_write_line(context, "{"); + CGLTF_WRITE_IDXPROP("sampler", animation_channel->sampler, animation->samplers); + cgltf_write_line(context, "\"target\": {"); + CGLTF_WRITE_IDXPROP("node", animation_channel->target_node, context->data->nodes); + cgltf_write_path_type(context, "path", animation_channel->target_path); + cgltf_write_line(context, "}"); + cgltf_write_extras(context, &animation_channel->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_animation(cgltf_write_context* context, const cgltf_animation* animation) +{ + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "name", animation->name); + + if (animation->samplers_count > 0) + { + cgltf_write_line(context, "\"samplers\": ["); + for (cgltf_size i = 0; i < animation->samplers_count; ++i) + { + cgltf_write_animation_sampler(context, animation->samplers + i); + } + cgltf_write_line(context, "]"); + } + if (animation->channels_count > 0) + { + cgltf_write_line(context, "\"channels\": ["); + for (cgltf_size i = 0; i < animation->channels_count; ++i) + { + cgltf_write_animation_channel(context, animation, animation->channels + i); + } + cgltf_write_line(context, "]"); + } + cgltf_write_extras(context, &animation->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_sampler(cgltf_write_context* context, const cgltf_sampler* sampler) +{ + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "name", sampler->name); + cgltf_write_intprop(context, "magFilter", sampler->mag_filter, 0); + cgltf_write_intprop(context, "minFilter", sampler->min_filter, 0); + cgltf_write_intprop(context, "wrapS", sampler->wrap_s, 10497); + cgltf_write_intprop(context, "wrapT", sampler->wrap_t, 10497); + cgltf_write_extras(context, &sampler->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_node(cgltf_write_context* context, const cgltf_node* node) +{ + cgltf_write_line(context, "{"); + CGLTF_WRITE_IDXARRPROP("children", node->children_count, node->children, context->data->nodes); + CGLTF_WRITE_IDXPROP("mesh", node->mesh, context->data->meshes); + cgltf_write_strprop(context, "name", node->name); + if (node->has_matrix) + { + cgltf_write_floatarrayprop(context, "matrix", node->matrix, 16); + } + if (node->has_translation) + { + cgltf_write_floatarrayprop(context, "translation", node->translation, 3); + } + if (node->has_rotation) + { + cgltf_write_floatarrayprop(context, "rotation", node->rotation, 4); + } + if (node->has_scale) + { + cgltf_write_floatarrayprop(context, "scale", node->scale, 3); + } + if (node->skin) + { + CGLTF_WRITE_IDXPROP("skin", node->skin, context->data->skins); + } + + if (node->light) + { + context->extension_flags |= CGLTF_EXTENSION_FLAG_LIGHTS_PUNCTUAL; + cgltf_write_line(context, "\"extensions\": {"); + cgltf_write_line(context, "\"KHR_lights_punctual\": {"); + CGLTF_WRITE_IDXPROP("light", node->light, context->data->lights); + cgltf_write_line(context, "}"); + cgltf_write_line(context, "}"); + } + + if (node->weights_count > 0) + { + cgltf_write_floatarrayprop(context, "weights", node->weights, node->weights_count); + } + + if (node->camera) + { + CGLTF_WRITE_IDXPROP("camera", node->camera, context->data->cameras); + } + + cgltf_write_extras(context, &node->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_scene(cgltf_write_context* context, const cgltf_scene* scene) +{ + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "name", scene->name); + CGLTF_WRITE_IDXARRPROP("nodes", scene->nodes_count, scene->nodes, context->data->nodes); + cgltf_write_extras(context, &scene->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_accessor(cgltf_write_context* context, const cgltf_accessor* accessor) +{ + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "name", accessor->name); + CGLTF_WRITE_IDXPROP("bufferView", accessor->buffer_view, context->data->buffer_views); + cgltf_write_intprop(context, "componentType", cgltf_int_from_component_type(accessor->component_type), 0); + cgltf_write_strprop(context, "type", cgltf_str_from_type(accessor->type)); + cgltf_size dim = cgltf_dim_from_type(accessor->type); + cgltf_write_boolprop_optional(context, "normalized", accessor->normalized, false); + cgltf_write_sizeprop(context, "byteOffset", (int)accessor->offset, 0); + cgltf_write_intprop(context, "count", (int)accessor->count, -1); + if (accessor->has_min) + { + cgltf_write_floatarrayprop(context, "min", accessor->min, dim); + } + if (accessor->has_max) + { + cgltf_write_floatarrayprop(context, "max", accessor->max, dim); + } + if (accessor->is_sparse) + { + cgltf_write_line(context, "\"sparse\": {"); + cgltf_write_intprop(context, "count", (int)accessor->sparse.count, 0); + cgltf_write_line(context, "\"indices\": {"); + cgltf_write_sizeprop(context, "byteOffset", (int)accessor->sparse.indices_byte_offset, 0); + CGLTF_WRITE_IDXPROP("bufferView", accessor->sparse.indices_buffer_view, context->data->buffer_views); + cgltf_write_intprop(context, "componentType", cgltf_int_from_component_type(accessor->sparse.indices_component_type), 0); + cgltf_write_extras(context, &accessor->sparse.indices_extras); + cgltf_write_line(context, "}"); + cgltf_write_line(context, "\"values\": {"); + cgltf_write_sizeprop(context, "byteOffset", (int)accessor->sparse.values_byte_offset, 0); + CGLTF_WRITE_IDXPROP("bufferView", accessor->sparse.values_buffer_view, context->data->buffer_views); + cgltf_write_extras(context, &accessor->sparse.values_extras); + cgltf_write_line(context, "}"); + cgltf_write_extras(context, &accessor->sparse.extras); + cgltf_write_line(context, "}"); + } + cgltf_write_extras(context, &accessor->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_camera(cgltf_write_context* context, const cgltf_camera* camera) +{ + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "type", cgltf_str_from_camera_type(camera->type)); + if (camera->name) + { + cgltf_write_strprop(context, "name", camera->name); + } + + if (camera->type == cgltf_camera_type_orthographic) + { + cgltf_write_line(context, "\"orthographic\": {"); + cgltf_write_floatprop(context, "xmag", camera->data.orthographic.xmag, -1.0f); + cgltf_write_floatprop(context, "ymag", camera->data.orthographic.ymag, -1.0f); + cgltf_write_floatprop(context, "zfar", camera->data.orthographic.zfar, -1.0f); + cgltf_write_floatprop(context, "znear", camera->data.orthographic.znear, -1.0f); + cgltf_write_extras(context, &camera->data.orthographic.extras); + cgltf_write_line(context, "}"); + } + else if (camera->type == cgltf_camera_type_perspective) + { + cgltf_write_line(context, "\"perspective\": {"); + + if (camera->data.perspective.has_aspect_ratio) { + cgltf_write_floatprop(context, "aspectRatio", camera->data.perspective.aspect_ratio, -1.0f); + } + + cgltf_write_floatprop(context, "yfov", camera->data.perspective.yfov, -1.0f); + + if (camera->data.perspective.has_zfar) { + cgltf_write_floatprop(context, "zfar", camera->data.perspective.zfar, -1.0f); + } + + cgltf_write_floatprop(context, "znear", camera->data.perspective.znear, -1.0f); + cgltf_write_extras(context, &camera->data.perspective.extras); + cgltf_write_line(context, "}"); + } + cgltf_write_extras(context, &camera->extras); + cgltf_write_line(context, "}"); +} + +static void cgltf_write_light(cgltf_write_context* context, const cgltf_light* light) +{ + context->extension_flags |= CGLTF_EXTENSION_FLAG_LIGHTS_PUNCTUAL; + + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "type", cgltf_str_from_light_type(light->type)); + if (light->name) + { + cgltf_write_strprop(context, "name", light->name); + } + if (cgltf_check_floatarray(light->color, 3, 1.0f)) + { + cgltf_write_floatarrayprop(context, "color", light->color, 3); + } + cgltf_write_floatprop(context, "intensity", light->intensity, 1.0f); + cgltf_write_floatprop(context, "range", light->range, 0.0f); + + if (light->type == cgltf_light_type_spot) + { + cgltf_write_line(context, "\"spot\": {"); + cgltf_write_floatprop(context, "innerConeAngle", light->spot_inner_cone_angle, 0.0f); + cgltf_write_floatprop(context, "outerConeAngle", light->spot_outer_cone_angle, 3.14159265358979323846f/4.0f); + cgltf_write_line(context, "}"); + } + cgltf_write_line(context, "}"); +} + +static void cgltf_write_variant(cgltf_write_context* context, const cgltf_material_variant* variant) +{ + context->extension_flags |= CGLTF_EXTENSION_FLAG_MATERIALS_VARIANTS; + + cgltf_write_line(context, "{"); + cgltf_write_strprop(context, "name", variant->name); + cgltf_write_extras(context, &variant->extras); + cgltf_write_line(context, "}"); +} + +cgltf_result cgltf_write_file(const cgltf_options* options, const char* path, const cgltf_data* data) +{ + cgltf_size expected = cgltf_write(options, NULL, 0, data); + char* buffer = (char*) malloc(expected); + cgltf_size actual = cgltf_write(options, buffer, expected, data); + if (expected != actual) { + fprintf(stderr, "Error: expected %zu bytes but wrote %zu bytes.\n", expected, actual); + } + FILE* file = fopen(path, "wt"); + if (!file) + { + return cgltf_result_file_not_found; + } + // Note that cgltf_write() includes a null terminator, which we omit from the file content. + fwrite(buffer, actual - 1, 1, file); + fclose(file); + free(buffer); + return cgltf_result_success; +} + +static void cgltf_write_extensions(cgltf_write_context* context, uint32_t extension_flags) +{ + if (extension_flags & CGLTF_EXTENSION_FLAG_TEXTURE_TRANSFORM) { + cgltf_write_stritem(context, "KHR_texture_transform"); + } + if (extension_flags & CGLTF_EXTENSION_FLAG_MATERIALS_UNLIT) { + cgltf_write_stritem(context, "KHR_materials_unlit"); + } + if (extension_flags & CGLTF_EXTENSION_FLAG_SPECULAR_GLOSSINESS) { + cgltf_write_stritem(context, "KHR_materials_pbrSpecularGlossiness"); + } + if (extension_flags & CGLTF_EXTENSION_FLAG_LIGHTS_PUNCTUAL) { + cgltf_write_stritem(context, "KHR_lights_punctual"); + } + if (extension_flags & CGLTF_EXTENSION_FLAG_DRACO_MESH_COMPRESSION) { + cgltf_write_stritem(context, "KHR_draco_mesh_compression"); + } + if (extension_flags & CGLTF_EXTENSION_FLAG_MATERIALS_CLEARCOAT) { + cgltf_write_stritem(context, "KHR_materials_clearcoat"); + } + if (extension_flags & CGLTF_EXTENSION_FLAG_MATERIALS_IOR) { + cgltf_write_stritem(context, "KHR_materials_ior"); + } + if (extension_flags & CGLTF_EXTENSION_FLAG_MATERIALS_SPECULAR) { + cgltf_write_stritem(context, "KHR_materials_specular"); + } + if (extension_flags & CGLTF_EXTENSION_FLAG_MATERIALS_TRANSMISSION) { + cgltf_write_stritem(context, "KHR_materials_transmission"); + } + if (extension_flags & CGLTF_EXTENSION_FLAG_MATERIALS_SHEEN) { + cgltf_write_stritem(context, "KHR_materials_sheen"); + } + if (extension_flags & CGLTF_EXTENSION_FLAG_MATERIALS_VARIANTS) { + cgltf_write_stritem(context, "KHR_materials_variants"); + } + if (extension_flags & CGLTF_EXTENSION_FLAG_MATERIALS_VOLUME) { + cgltf_write_stritem(context, "KHR_materials_volume"); + } + if (extension_flags & CGLTF_EXTENSION_FLAG_TEXTURE_BASISU) { + cgltf_write_stritem(context, "KHR_texture_basisu"); + } +} + +cgltf_size cgltf_write(const cgltf_options* options, char* buffer, cgltf_size size, const cgltf_data* data) +{ + (void)options; + cgltf_write_context ctx; + ctx.buffer = buffer; + ctx.buffer_size = size; + ctx.remaining = size; + ctx.cursor = buffer; + ctx.chars_written = 0; + ctx.data = data; + ctx.depth = 1; + ctx.indent = " "; + ctx.needs_comma = 0; + ctx.extension_flags = 0; + ctx.required_extension_flags = 0; + + cgltf_write_context* context = &ctx; + + CGLTF_SPRINTF("{"); + + if (data->accessors_count > 0) + { + cgltf_write_line(context, "\"accessors\": ["); + for (cgltf_size i = 0; i < data->accessors_count; ++i) + { + cgltf_write_accessor(context, data->accessors + i); + } + cgltf_write_line(context, "]"); + } + + cgltf_write_asset(context, &data->asset); + + if (data->buffer_views_count > 0) + { + cgltf_write_line(context, "\"bufferViews\": ["); + for (cgltf_size i = 0; i < data->buffer_views_count; ++i) + { + cgltf_write_buffer_view(context, data->buffer_views + i); + } + cgltf_write_line(context, "]"); + } + + if (data->buffers_count > 0) + { + cgltf_write_line(context, "\"buffers\": ["); + for (cgltf_size i = 0; i < data->buffers_count; ++i) + { + cgltf_write_buffer(context, data->buffers + i); + } + cgltf_write_line(context, "]"); + } + + if (data->images_count > 0) + { + cgltf_write_line(context, "\"images\": ["); + for (cgltf_size i = 0; i < data->images_count; ++i) + { + cgltf_write_image(context, data->images + i); + } + cgltf_write_line(context, "]"); + } + + if (data->meshes_count > 0) + { + cgltf_write_line(context, "\"meshes\": ["); + for (cgltf_size i = 0; i < data->meshes_count; ++i) + { + cgltf_write_mesh(context, data->meshes + i); + } + cgltf_write_line(context, "]"); + } + + if (data->materials_count > 0) + { + cgltf_write_line(context, "\"materials\": ["); + for (cgltf_size i = 0; i < data->materials_count; ++i) + { + cgltf_write_material(context, data->materials + i); + } + cgltf_write_line(context, "]"); + } + + if (data->nodes_count > 0) + { + cgltf_write_line(context, "\"nodes\": ["); + for (cgltf_size i = 0; i < data->nodes_count; ++i) + { + cgltf_write_node(context, data->nodes + i); + } + cgltf_write_line(context, "]"); + } + + if (data->samplers_count > 0) + { + cgltf_write_line(context, "\"samplers\": ["); + for (cgltf_size i = 0; i < data->samplers_count; ++i) + { + cgltf_write_sampler(context, data->samplers + i); + } + cgltf_write_line(context, "]"); + } + + CGLTF_WRITE_IDXPROP("scene", data->scene, data->scenes); + + if (data->scenes_count > 0) + { + cgltf_write_line(context, "\"scenes\": ["); + for (cgltf_size i = 0; i < data->scenes_count; ++i) + { + cgltf_write_scene(context, data->scenes + i); + } + cgltf_write_line(context, "]"); + } + + if (data->textures_count > 0) + { + cgltf_write_line(context, "\"textures\": ["); + for (cgltf_size i = 0; i < data->textures_count; ++i) + { + cgltf_write_texture(context, data->textures + i); + } + cgltf_write_line(context, "]"); + } + + if (data->skins_count > 0) + { + cgltf_write_line(context, "\"skins\": ["); + for (cgltf_size i = 0; i < data->skins_count; ++i) + { + cgltf_write_skin(context, data->skins + i); + } + cgltf_write_line(context, "]"); + } + + if (data->animations_count > 0) + { + cgltf_write_line(context, "\"animations\": ["); + for (cgltf_size i = 0; i < data->animations_count; ++i) + { + cgltf_write_animation(context, data->animations + i); + } + cgltf_write_line(context, "]"); + } + + if (data->cameras_count > 0) + { + cgltf_write_line(context, "\"cameras\": ["); + for (cgltf_size i = 0; i < data->cameras_count; ++i) + { + cgltf_write_camera(context, data->cameras + i); + } + cgltf_write_line(context, "]"); + } + + if (data->lights_count > 0 || data->variants_count > 0) + { + cgltf_write_line(context, "\"extensions\": {"); + + if (data->lights_count > 0) + { + cgltf_write_line(context, "\"KHR_lights_punctual\": {"); + cgltf_write_line(context, "\"lights\": ["); + for (cgltf_size i = 0; i < data->lights_count; ++i) + { + cgltf_write_light(context, data->lights + i); + } + cgltf_write_line(context, "]"); + cgltf_write_line(context, "}"); + } + + if (data->variants_count) + { + cgltf_write_line(context, "\"KHR_materials_variants\": {"); + cgltf_write_line(context, "\"variants\": ["); + for (cgltf_size i = 0; i < data->variants_count; ++i) + { + cgltf_write_variant(context, data->variants + i); + } + cgltf_write_line(context, "]"); + cgltf_write_line(context, "}"); + } + + cgltf_write_line(context, "}"); + } + + if (context->extension_flags != 0) + { + cgltf_write_line(context, "\"extensionsUsed\": ["); + cgltf_write_extensions(context, context->extension_flags); + cgltf_write_line(context, "]"); + } + + if (context->required_extension_flags != 0) + { + cgltf_write_line(context, "\"extensionsRequired\": ["); + cgltf_write_extensions(context, context->required_extension_flags); + cgltf_write_line(context, "]"); + } + + cgltf_write_extras(context, &data->extras); + + CGLTF_SPRINTF("\n}\n"); + + // snprintf does not include the null terminator in its return value, so be sure to include it + // in the returned byte count. + return 1 + ctx.chars_written; +} + +#endif /* #ifdef CGLTF_WRITE_IMPLEMENTATION */ + +/* cgltf is distributed under MIT license: + * + * Copyright (c) 2019-2021 Philip Rideout + + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + + * The above copyright notice and this permission notice shall be included in all + * copies or substantial portions of the Software. + + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE + * SOFTWARE. + */ diff --git a/source/engine/thirdparty/enet/ChangeLog b/source/engine/thirdparty/enet/ChangeLog new file mode 100644 index 0000000..e182076 --- /dev/null +++ b/source/engine/thirdparty/enet/ChangeLog @@ -0,0 +1,200 @@ +ENet 1.3.17 (November 15, 2020): + +* fixes for sender getting too far ahead of receiver that can cause instability with reliable packets + +ENet 1.3.16 (September 8, 2020): + +* fix bug in unreliable fragment queuing +* use single output queue for reliable and unreliable packets for saner ordering +* revert experimental throttle changes that were less stable than prior algorithm + +ENet 1.3.15 (April 20, 2020): + +* quicker RTT initialization +* use fractional precision for RTT calculations +* fixes for packet throttle with low RTT variance +* miscellaneous socket bug fixes + +ENet 1.3.14 (January 27, 2019): + +* bug fix for enet_peer_disconnect_later() +* use getaddrinfo and getnameinfo where available +* miscellaneous cleanups + +ENet 1.3.13 (April 30, 2015): + +* miscellaneous bug fixes +* added premake and cmake support +* miscellaneous documentation cleanups + +ENet 1.3.12 (April 24, 2014): + +* added maximumPacketSize and maximumWaitingData fields to ENetHost to limit the amount of +data waiting to be delivered on a peer (beware that the default maximumPacketSize is +32MB and should be set higher if desired as should maximumWaitingData) + +ENet 1.3.11 (December 26, 2013): + +* allow an ENetHost to connect to itself +* fixed possible bug with disconnect notifications during connect attempts +* fixed some preprocessor definition bugs + +ENet 1.3.10 (October 23, 2013); + +* doubled maximum reliable window size +* fixed RCVTIMEO/SNDTIMEO socket options and also added NODELAY + +ENet 1.3.9 (August 19, 2013): + +* added duplicatePeers option to ENetHost which can limit the number of peers from duplicate IPs +* added enet_socket_get_option() and ENET_SOCKOPT_ERROR +* added enet_host_random_seed() platform stub + +ENet 1.3.8 (June 2, 2013): + +* added enet_linked_version() for checking the linked version +* added enet_socket_get_address() for querying the local address of a socket +* silenced some debugging prints unless ENET_DEBUG is defined during compilation +* handle EINTR in enet_socket_wait() so that enet_host_service() doesn't propagate errors from signals +* optimized enet_host_bandwidth_throttle() to be less expensive for large numbers of peers + +ENet 1.3.7 (March 6, 2013): + +* added ENET_PACKET_FLAG_SENT to indicate that a packet is being freed because it has been sent +* added userData field to ENetPacket +* changed how random seed is generated on Windows to avoid import warnings +* fixed case where disconnects could be generated with no preceding connect event + +ENet 1.3.6 (December 11, 2012): + +* added support for intercept callback in ENetHost that can be used to process raw packets before ENet +* added enet_socket_shutdown() for issuing shutdown on a socket +* fixed enet_socket_connect() to not error on non-blocking connects +* fixed bug in MTU negotiation during connections + +ENet 1.3.5 (July 31, 2012): + +* fixed bug in unreliable packet fragment queuing + +ENet 1.3.4 (May 29, 2012): + +* added enet_peer_ping_interval() for configuring per-peer ping intervals +* added enet_peer_timeout() for configuring per-peer timeouts +* added protocol packet size limits + +ENet 1.3.3 (June 28, 2011): + +* fixed bug with simultaneous disconnects not dispatching events + +ENet 1.3.2 (May 31, 2011): + +* added support for unreliable packet fragmenting via the packet flag +ENET_PACKET_FLAG_UNRELIABLE_FRAGMENT +* fixed regression in unreliable packet queuing +* added check against received port to limit some forms of IP-spoofing + +ENet 1.3.1 (February 10, 2011): + +* fixed bug in tracking of reliable data in transit +* reliable data window size now scales with the throttle +* fixed bug in fragment length calculation when checksums are used + +ENet 1.3.0 (June 5, 2010): + +* enet_host_create() now requires the channel limit to be specified as +a parameter +* enet_host_connect() now accepts a data parameter which is supplied +to the receiving receiving host in the event data field for a connect event +* added an adaptive order-2 PPM range coder as a built-in compressor option +which can be set with enet_host_compress_with_range_coder() +* added support for packet compression configurable with a callback +* improved session number handling to not rely on the packet checksum +field, saving 4 bytes per packet unless the checksum option is used +* removed the dependence on the rand callback for session number handling + +Caveats: This version is not protocol compatible with the 1.2 series or +earlier. The enet_host_connect and enet_host_create API functions require +supplying additional parameters. + +ENet 1.2.5 (June 28, 2011): + +* fixed bug with simultaneous disconnects not dispatching events + +ENet 1.2.4 (May 31, 2011): + +* fixed regression in unreliable packet queuing +* added check against received port to limit some forms of IP-spoofing + +ENet 1.2.3 (February 10, 2011): + +* fixed bug in tracking reliable data in transit + +ENet 1.2.2 (June 5, 2010): + +* checksum functionality is now enabled by setting a checksum callback +inside ENetHost instead of being a configure script option +* added totalSentData, totalSentPackets, totalReceivedData, and +totalReceivedPackets counters inside ENetHost for getting usage +statistics +* added enet_host_channel_limit() for limiting the maximum number of +channels allowed by connected peers +* now uses dispatch queues for event dispatch rather than potentially +unscalable array walking +* added no_memory callback that is called when a malloc attempt fails, +such that if no_memory returns rather than aborts (the default behavior), +then the error is propagated to the return value of the API calls +* now uses packed attribute for protocol structures on platforms with +strange alignment rules +* improved autoconf build system contributed by Nathan Brink allowing +for easier building as a shared library + +Caveats: If you were using the compile-time option that enabled checksums, +make sure to set the checksum callback inside ENetHost to enet_crc32 to +regain the old behavior. The ENetCallbacks structure has added new fields, +so make sure to clear the structure to zero before use if +using enet_initialize_with_callbacks(). + +ENet 1.2.1 (November 12, 2009): + +* fixed bug that could cause disconnect events to be dropped +* added thin wrapper around select() for portable usage +* added ENET_SOCKOPT_REUSEADDR socket option +* factored enet_socket_bind()/enet_socket_listen() out of enet_socket_create() +* added contributed Code::Blocks build file + +ENet 1.2 (February 12, 2008): + +* fixed bug in VERIFY_CONNECT acknowledgement that could cause connect +attempts to occasionally timeout +* fixed acknowledgements to check both the outgoing and sent queues +when removing acknowledged packets +* fixed accidental bit rot in the MSVC project file +* revised sequence number overflow handling to address some possible +disconnect bugs +* added enet_host_check_events() for getting only local queued events +* factored out socket option setting into enet_socket_set_option() so +that socket options are now set separately from enet_socket_create() + +Caveats: While this release is superficially protocol compatible with 1.1, +differences in the sequence number overflow handling can potentially cause +random disconnects. + +ENet 1.1 (June 6, 2007): + +* optional CRC32 just in case someone needs a stronger checksum than UDP +provides (--enable-crc32 configure option) +* the size of packet headers are half the size they used to be (so less +overhead when sending small packets) +* enet_peer_disconnect_later() that waits till all queued outgoing +packets get sent before issuing an actual disconnect +* freeCallback field in individual packets for notification of when a +packet is about to be freed +* ENET_PACKET_FLAG_NO_ALLOCATE for supplying pre-allocated data to a +packet (can be used in concert with freeCallback to support some custom +allocation schemes that the normal memory allocation callbacks would +normally not allow) +* enet_address_get_host_ip() for printing address numbers +* promoted the enet_socket_*() functions to be part of the API now +* a few stability/crash fixes + + diff --git a/source/engine/thirdparty/enet/LICENSE b/source/engine/thirdparty/enet/LICENSE new file mode 100644 index 0000000..6906f8e --- /dev/null +++ b/source/engine/thirdparty/enet/LICENSE @@ -0,0 +1,7 @@ +Copyright (c) 2002-2020 Lee Salzman + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/source/engine/thirdparty/enet/README b/source/engine/thirdparty/enet/README new file mode 100644 index 0000000..54b2d21 --- /dev/null +++ b/source/engine/thirdparty/enet/README @@ -0,0 +1,15 @@ +Please visit the ENet homepage at http://enet.bespin.org for installation +and usage instructions. + +If you obtained this package from github, the quick description on how to build +is: + +# Generate the build system. + +autoreconf -vfi + +# Compile and install the library. + +./configure && make && make install + + diff --git a/source/engine/thirdparty/enet/docs/FAQ.dox b/source/engine/thirdparty/enet/docs/FAQ.dox new file mode 100644 index 0000000..c3f45fb --- /dev/null +++ b/source/engine/thirdparty/enet/docs/FAQ.dox @@ -0,0 +1,24 @@ +/** + @page FAQ Frequently Answered Questions + +@section Q1 Is ENet thread-safe? + +ENet does not use any significant global variables, the vast majority +of state is encapsulated in the ENetHost structure. As such, as long +as the application guards access to this structure, then ENet should +operate fine in a multi-threaded environment. + +@section Q2 Isn't ENet just re-inventing TCP?! What's the point? + +In a perfect world, that would be true. But as many have found, using +TCP either in lieu of or in conjunction with UDP can lead to all kinds +of nightmares. TCP is a good, solid protocol, however it simply isn't +up to the task of real-time games. Too much of TCP's implementation +dictates a policy that isn't practical for games. If you want to use +TCP, then do so -- this library is for people that either don't want +to use TCP or have tried and ended up being discouraged with the +performance. + +*/ + + diff --git a/source/engine/thirdparty/enet/docs/design.dox b/source/engine/thirdparty/enet/docs/design.dox new file mode 100644 index 0000000..f74a2bd --- /dev/null +++ b/source/engine/thirdparty/enet/docs/design.dox @@ -0,0 +1,126 @@ +/** +@page Features Features and Architecture + +ENet evolved specifically as a UDP networking layer for the +multiplayer first person shooter Cube. Cube necessitated low latency +communication with data sent out very frequently, so TCP was an +unsuitable choice due to its high latency and stream orientation. UDP, +however, lacks many sometimes necessary features from TCP such as +reliability, sequencing, unrestricted packet sizes, and connection +management. So UDP by itself was not suitable as a network protocol +either. No suitable freely available networking libraries existed at +the time of ENet's creation to fill this niche. + +UDP and TCP could have been used together in Cube to benefit somewhat +from both of their features, however, the resulting combinations of +protocols still leaves much to be desired. TCP lacks multiple streams +of communication without resorting to opening many sockets and +complicates delineation of packets due to its buffering behavior. UDP +lacks sequencing, connection management, management of bandwidth +resources, and imposes limitations on the size of packets. A +significant investment is required to integrate these two protocols, +and the end result is worse off in features and performance than the +uniform protocol presented by ENet. + +ENet thus attempts to address these issues and provide a single, +uniform protocol layered over UDP to the developer with the best +features of UDP and TCP as well as some useful features neither +provide, with a much cleaner integration than any resulting from a +mixture of UDP and TCP. + +@section CM Connection Management + +ENet provides a simple connection interface over which to communicate +with a foreign host. The liveness of the connection is actively +monitored by pinging the foreign host at frequent intervals, and also +monitors the network conditions from the local host to the foreign +host such as the mean round trip time and packet loss in this fashion. + +@section Sequencing Sequencing + +Rather than a single byte stream that complicates the delineation of +packets, ENet presents connections as multiple, properly sequenced +packet streams that simplify the transfer of various types of data. + +ENet provides sequencing for all packets by assigning to each sent +packet a sequence number that is incremented as packets are sent. ENet +guarantees that no packet with a higher sequence number will be +delivered before a packet with a lower sequence number, thus ensuring +packets are delivered exactly in the order they are sent. + +For unreliable packets, ENet will simply discard the lower sequence +number packet if a packet with a higher sequence number has already +been delivered. This allows the packets to be dispatched immediately +as they arrive, and reduce latency of unreliable packets to an +absolute minimum. For reliable packets, if a higher sequence number +packet arrives, but the preceding packets in the sequence have not yet +arrived, ENet will stall delivery of the higher sequence number +packets until its predecessors have arrived. + +@section Channels Channels + +Since ENet will stall delivery of reliable packets to ensure proper +sequencing, and consequently any packets of higher sequence number +whether reliable or unreliable, in the event the reliable packet's +predecessors have not yet arrived, this can introduce latency into the +delivery of other packets which may not need to be as strictly ordered +with respect to the packet that stalled their delivery. + +To combat this latency and reduce the ordering restrictions on +packets, ENet provides multiple channels of communication over a given +connection. Each channel is independently sequenced, and so the +delivery status of a packet in one channel will not stall the delivery +of other packets in another channel. + +@section Reliability Reliability + +ENet provides optional reliability of packet delivery by ensuring the +foreign host acknowledges receipt of all reliable packets. ENet will +attempt to resend the packet up to a reasonable amount of times, if no +acknowledgement of the packet's receipt happens within a specified +timeout. Retry timeouts are progressive and become more lenient with +every failed attempt to allow for temporary turbulence in network +conditions. + +@section FaR Fragmentation and Reassembly + +ENet will send and deliver packets regardless of size. Large packets +are fragmented into many smaller packets of suitable size, and +reassembled on the foreign host to recover the original packet for +delivery. The process is entirely transparent to the developer. + +@section Aggregation Aggregation + +ENet aggregates all protocol commands, including acknowledgements and +packet transfer, into larger protocol packets to ensure the proper +utilization of the connection and to limit the opportunities for +packet loss that might otherwise result in further delivery latency. + +@section Adaptability Adaptability + +ENet provides an in-flight data window for reliable packets to ensure +connections are not overwhelmed by volumes of packets. It also +provides a static bandwidth allocation mechanism to ensure the total +volume of packets sent and received to a host don't exceed the host's +capabilities. Further, ENet also provides a dynamic throttle that +responds to deviations from normal network connections to rectify +various types of network congestion by further limiting the volume of +packets sent. + +@section Portability Portability + +ENet works on Windows and any other Unix or Unix-like platform +providing a BSD sockets interface. The library has a small and stable +code base that can easily be extended to support other platforms and +integrates easily. ENet makes no assumptions about the underlying +platform's endianess or word size. + +@section Freedom Freedom + +ENet demands no royalties and doesn't carry a viral license that would +restrict you in how you might use it in your programs. ENet is +licensed under a short-and-sweet MIT-style license, which gives you +the freedom to do anything you want with it (well, almost anything). + +*/ + diff --git a/source/engine/thirdparty/enet/docs/install.dox b/source/engine/thirdparty/enet/docs/install.dox new file mode 100644 index 0000000..b9730d7 --- /dev/null +++ b/source/engine/thirdparty/enet/docs/install.dox @@ -0,0 +1,63 @@ +/** +@page Installation Installation + +ENet should be trivially simple to integrate with most applications. +First, make sure you download the latest source distribution at @ref Downloads. + +@section Unix Unix-like Operating Systems + +If you are using an ENet release, then you should simply be able to build it +by doing the following: + +./configure && make && make install + +If you obtained the package from github, you must have automake and autoconf +available to generate the build system first by doing the following command +before using the above mentioned build procedure: + +autoreconf -vfi + + +@subsection SolarisBSD Solaris and BSD + +When building ENet under Solaris, you must specify the -lsocket and +-lnsl parameters to your compiler to ensure that the sockets library +is linked in. + +@section Windows Microsoft Windows + +You may simply use the included "enet.lib" or "enet64.lib" static libraries. +However, if you wish to build the library yourself, then the following +instructions apply: + +There is an included MSVC 6 project (enet.dsp) which you may use to +build a suitable library file. Alternatively, you may simply drag all +the ENet source files into your main project. + +You will have to link to the Winsock2 libraries, so make sure to add +ws2_32.lib and winmm.lib to your library list (Project Settings | Link | +Object/library modules). + +@subsection enet.dsp Building with the included enet.dsp + +Load the included enet.dsp. MSVC may ask you to convert it if you +are on a newer version of MSVC - just allow the conversion and save +the resulting project as "enet" or similar. After you build this +project, it will output an "enet.lib" file to either the "Debug/" +or "Release/" directory, depending on which configuration you have +selected to build. By default, it should produce "Debug/enet.lib". + +You may then copy the resulting "enet.lib" file and the header files +found in the "include/" directory to your other projects and add it to +their library lists. Make sure to also link against "ws2_32.lib" and +"winmm.lib" as described above. + +@subsection DLL DLL + +If you wish to build ENet as a DLL you must first define ENET_DLL +within the project (Project Settings | C/C++ | Preprocessor | +Preprocessor definitions) or, more invasively, simply define ENET_DLL +at the top of enet.h. + +*/ + diff --git a/source/engine/thirdparty/enet/docs/license.dox b/source/engine/thirdparty/enet/docs/license.dox new file mode 100644 index 0000000..9991a7f --- /dev/null +++ b/source/engine/thirdparty/enet/docs/license.dox @@ -0,0 +1,26 @@ +/** + @page License License + +Copyright (c) 2002-2020 Lee Salzman + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +*/ + diff --git a/source/engine/thirdparty/enet/docs/mainpage.dox b/source/engine/thirdparty/enet/docs/mainpage.dox new file mode 100644 index 0000000..eb6c8b8 --- /dev/null +++ b/source/engine/thirdparty/enet/docs/mainpage.dox @@ -0,0 +1,59 @@ +/** @mainpage ENet + +ENet's purpose is to provide a relatively thin, simple and robust +network communication layer on top of UDP (User Datagram Protocol). +The primary feature it provides is optional reliable, in-order +delivery of packets. + +ENet omits certain higher level networking features such as authentication, +lobbying, server discovery, encryption, or other similar tasks that are +particularly application specific so that the library remains flexible, +portable, and easily embeddable. + +@ref Features + +@ref Downloads + +@ref Installation + +@ref Tutorial + +@ref MailingList + +@ref IRCChannel + +@ref FAQ + +@ref License + +Documentation + + */ + +/** +@page Downloads Downloads + +You can retrieve the source to ENet by downloading it in either .tar.gz form +or accessing the github distribution directly. + +The most recent stable release (1.3.17) can be downloaded here. +The last release that is protocol compatible with the 1.2 series or earlier (1.2.5) can be downloaded here. + +You can find the most recent ENet source at the github repository. + +*/ + +/** +@page MailingList Mailing List + +The enet-discuss list is for discussion of ENet, including bug reports or feature requests. + +*/ + +/** +@page IRCChannel IRC Channel + +Join the \#enet channel on the Libera Chat IRC network (irc.libera.chat) for real-time discussion about the ENet library. + +*/ + diff --git a/source/engine/thirdparty/enet/docs/tutorial.dox b/source/engine/thirdparty/enet/docs/tutorial.dox new file mode 100644 index 0000000..19a7a45 --- /dev/null +++ b/source/engine/thirdparty/enet/docs/tutorial.dox @@ -0,0 +1,366 @@ +/** +@page Tutorial Tutorial + +@ref Initialization + +@ref CreateServer + +@ref CreateClient + +@ref ManageHost + +@ref SendingPacket + +@ref Disconnecting + +@ref Connecting + +@section Initialization Initialization + +You should include the file when using ENet. Do not +include without the directory prefix, as this may cause +file name conflicts on some systems. + +Before using ENet, you must call enet_initialize() to initialize the +library. Upon program exit, you should call enet_deinitialize() so +that the library may clean up any used resources. + +@code +#include + +int +main (int argc, char ** argv) +{ + if (enet_initialize () != 0) + { + fprintf (stderr, "An error occurred while initializing ENet.\n"); + return EXIT_FAILURE; + } + atexit (enet_deinitialize); + ... + ... + ... +} +@endcode + +@section CreateServer Creating an ENet server + +Servers in ENet are constructed with enet_host_create(). You must +specify an address on which to receive data and new connections, as +well as the maximum allowable numbers of connected peers. You may +optionally specify the incoming and outgoing bandwidth of the server +in bytes per second so that ENet may try to statically manage +bandwidth resources among connected peers in addition to its dynamic +throttling algorithm; specifying 0 for these two options will cause +ENet to rely entirely upon its dynamic throttling algorithm to manage +bandwidth. + +When done with a host, the host may be destroyed with +enet_host_destroy(). All connected peers to the host will be reset, +and the resources used by the host will be freed. + +@code + ENetAddress address; + ENetHost * server; + + /* Bind the server to the default localhost. */ + /* A specific host address can be specified by */ + /* enet_address_set_host (& address, "x.x.x.x"); */ + + address.host = ENET_HOST_ANY; + /* Bind the server to port 1234. */ + address.port = 1234; + + server = enet_host_create (& address /* the address to bind the server host to */, + 32 /* allow up to 32 clients and/or outgoing connections */, + 2 /* allow up to 2 channels to be used, 0 and 1 */, + 0 /* assume any amount of incoming bandwidth */, + 0 /* assume any amount of outgoing bandwidth */); + if (server == NULL) + { + fprintf (stderr, + "An error occurred while trying to create an ENet server host.\n"); + exit (EXIT_FAILURE); + } + ... + ... + ... + enet_host_destroy(server); +@endcode + +@section CreateClient Creating an ENet client + +Clients in ENet are similarly constructed with enet_host_create() when +no address is specified to bind the host to. Bandwidth may be +specified for the client host as in the above example. The peer count +controls the maximum number of connections to other server hosts that +may be simultaneously open. + +@code + ENetHost * client; + + client = enet_host_create (NULL /* create a client host */, + 1 /* only allow 1 outgoing connection */, + 2 /* allow up 2 channels to be used, 0 and 1 */, + 0 /* assume any amount of incoming bandwidth */, + 0 /* assume any amount of outgoing bandwidth */); + + if (client == NULL) + { + fprintf (stderr, + "An error occurred while trying to create an ENet client host.\n"); + exit (EXIT_FAILURE); + } + ... + ... + ... + enet_host_destroy(client); +@endcode + +@section ManageHost Managing an ENet host + +ENet uses a polled event model to notify the programmer of significant +events. ENet hosts are polled for events with enet_host_service(), +where an optional timeout value in milliseconds may be specified to +control how long ENet will poll; if a timeout of 0 is specified, +enet_host_service() will return immediately if there are no events to +dispatch. enet_host_service() will return 1 if an event was dispatched +within the specified timeout. + +Beware that most processing of the network with the ENet stack is done +inside enet_host_service(). Both hosts that make up the sides of a connection +must regularly call this function to ensure packets are actually sent and +received. A common symptom of not actively calling enet_host_service() +on both ends is that one side receives events while the other does not. +The best way to schedule this activity to ensure adequate service is, for +example, to call enet_host_service() with a 0 timeout (meaning non-blocking) +at the beginning of every frame in a game loop. + +Currently there are only four types of significant events in ENet: + +An event of type ENET_EVENT_TYPE_NONE is returned if no event occurred +within the specified time limit. enet_host_service() will return 0 +with this event. + +An event of type ENET_EVENT_TYPE_CONNECT is returned when either a new client +host has connected to the server host or when an attempt to establish a +connection with a foreign host has succeeded. Only the "peer" field of the +event structure is valid for this event and contains the newly connected peer. + +An event of type ENET_EVENT_TYPE_RECEIVE is returned when a packet is received +from a connected peer. The "peer" field contains the peer the packet was +received from, "channelID" is the channel on which the packet was sent, and +"packet" is the packet that was sent. The packet contained in the "packet" +field must be destroyed with enet_packet_destroy() when you are done +inspecting its contents. + +An event of type ENET_EVENT_TYPE_DISCONNECT is returned when a connected peer +has either explicitly disconnected or timed out. Only the "peer" field of the +event structure is valid for this event and contains the peer that +disconnected. Only the "data" field of the peer is still valid on a +disconnect event and must be explicitly reset. + +@code + ENetEvent event; + + /* Wait up to 1000 milliseconds for an event. */ + while (enet_host_service (client, & event, 1000) > 0) + { + switch (event.type) + { + case ENET_EVENT_TYPE_CONNECT: + printf ("A new client connected from %x:%u.\n", + event.peer -> address.host, + event.peer -> address.port); + + /* Store any relevant client information here. */ + event.peer -> data = "Client information"; + + break; + + case ENET_EVENT_TYPE_RECEIVE: + printf ("A packet of length %u containing %s was received from %s on channel %u.\n", + event.packet -> dataLength, + event.packet -> data, + event.peer -> data, + event.channelID); + + /* Clean up the packet now that we're done using it. */ + enet_packet_destroy (event.packet); + + break; + + case ENET_EVENT_TYPE_DISCONNECT: + printf ("%s disconnected.\n", event.peer -> data); + + /* Reset the peer's client information. */ + + event.peer -> data = NULL; + } + } + ... + ... + ... +@endcode + +@section SendingPacket Sending a packet to an ENet peer + +Packets in ENet are created with enet_packet_create(), where the size +of the packet must be specified. Optionally, initial data may be +specified to copy into the packet. + +Certain flags may also be supplied to enet_packet_create() to control +various packet features: + +ENET_PACKET_FLAG_RELIABLE specifies that the packet must use reliable +delivery. A reliable packet is guaranteed to be delivered, and a +number of retry attempts will be made until an acknowledgement is +received from the foreign host the packet is sent to. If a certain +number of retry attempts is reached without any acknowledgement, ENet +will assume the peer has disconnected and forcefully reset the +connection. If this flag is not specified, the packet is assumed an +unreliable packet, and no retry attempts will be made nor +acknowledgements generated. + +A packet may be resized (extended or truncated) with +enet_packet_resize(). + +A packet is sent to a foreign host with +enet_peer_send(). enet_peer_send() accepts a channel id over which to +send the packet to a given peer. Once the packet is handed over to +ENet with enet_peer_send(), ENet will handle its deallocation and +enet_packet_destroy() should not be used upon it. + +One may also use enet_host_broadcast() to send a packet to all +connected peers on a given host over a specified channel id, as with +enet_peer_send(). + +Queued packets will be sent on a call to enet_host_service(). +Alternatively, enet_host_flush() will send out queued packets without +dispatching any events. + +@code + /* Create a reliable packet of size 7 containing "packet\0" */ + ENetPacket * packet = enet_packet_create ("packet", + strlen ("packet") + 1, + ENET_PACKET_FLAG_RELIABLE); + + /* Extend the packet so and append the string "foo", so it now */ + /* contains "packetfoo\0" */ + enet_packet_resize (packet, strlen ("packetfoo") + 1); + strcpy (& packet -> data [strlen ("packet")], "foo"); + + /* Send the packet to the peer over channel id 0. */ + /* One could also broadcast the packet by */ + /* enet_host_broadcast (host, 0, packet); */ + enet_peer_send (peer, 0, packet); + ... + ... + ... + /* One could just use enet_host_service() instead. */ + enet_host_flush (host); +@endcode + +@section Disconnecting Disconnecting an ENet peer + +Peers may be gently disconnected with enet_peer_disconnect(). A +disconnect request will be sent to the foreign host, and ENet will +wait for an acknowledgement from the foreign host before finally +disconnecting. An event of type ENET_EVENT_TYPE_DISCONNECT will be +generated once the disconnection succeeds. Normally timeouts apply to +the disconnect acknowledgement, and so if no acknowledgement is +received after a length of time the peer will be forcefully +disconnected. + +enet_peer_reset() will forcefully disconnect a peer. The foreign host +will get no notification of a disconnect and will time out on the +foreign host. No event is generated. + +@code + ENetEvent event; + + enet_peer_disconnect (peer, 0); + + /* Allow up to 3 seconds for the disconnect to succeed + * and drop any packets received packets. + */ + while (enet_host_service (client, & event, 3000) > 0) + { + switch (event.type) + { + case ENET_EVENT_TYPE_RECEIVE: + enet_packet_destroy (event.packet); + break; + + case ENET_EVENT_TYPE_DISCONNECT: + puts ("Disconnection succeeded."); + return; + ... + ... + ... + } + } + + /* We've arrived here, so the disconnect attempt didn't */ + /* succeed yet. Force the connection down. */ + enet_peer_reset (peer); + ... + ... + ... +@endcode + +@section Connecting Connecting to an ENet host + +A connection to a foreign host is initiated with enet_host_connect(). +It accepts the address of a foreign host to connect to, and the number +of channels that should be allocated for communication. If N channels +are allocated for use, their channel ids will be numbered 0 through +N-1. A peer representing the connection attempt is returned, or NULL +if there were no available peers over which to initiate the +connection. When the connection attempt succeeds, an event of type +ENET_EVENT_TYPE_CONNECT will be generated. If the connection attempt +times out or otherwise fails, an event of type +ENET_EVENT_TYPE_DISCONNECT will be generated. + +@code + ENetAddress address; + ENetEvent event; + ENetPeer *peer; + + /* Connect to some.server.net:1234. */ + enet_address_set_host (& address, "some.server.net"); + address.port = 1234; + + /* Initiate the connection, allocating the two channels 0 and 1. */ + peer = enet_host_connect (client, & address, 2, 0); + + if (peer == NULL) + { + fprintf (stderr, + "No available peers for initiating an ENet connection.\n"); + exit (EXIT_FAILURE); + } + + /* Wait up to 5 seconds for the connection attempt to succeed. */ + if (enet_host_service (client, & event, 5000) > 0 && + event.type == ENET_EVENT_TYPE_CONNECT) + { + puts ("Connection to some.server.net:1234 succeeded."); + ... + ... + ... + } + else + { + /* Either the 5 seconds are up or a disconnect event was */ + /* received. Reset the peer in the event the 5 seconds */ + /* had run out without any significant event. */ + enet_peer_reset (peer); + + puts ("Connection to some.server.net:1234 failed."); + } + ... + ... + ... +@endcode +*/ diff --git a/source/engine/thirdparty/enet/include/enet/callbacks.h b/source/engine/thirdparty/enet/include/enet/callbacks.h new file mode 100644 index 0000000..340a4a9 --- /dev/null +++ b/source/engine/thirdparty/enet/include/enet/callbacks.h @@ -0,0 +1,27 @@ +/** + @file callbacks.h + @brief ENet callbacks +*/ +#ifndef __ENET_CALLBACKS_H__ +#define __ENET_CALLBACKS_H__ + +#include + +typedef struct _ENetCallbacks +{ + void * (ENET_CALLBACK * malloc) (size_t size); + void (ENET_CALLBACK * free) (void * memory); + void (ENET_CALLBACK * no_memory) (void); +} ENetCallbacks; + +/** @defgroup callbacks ENet internal callbacks + @{ + @ingroup private +*/ +extern void * enet_malloc (size_t); +extern void enet_free (void *); + +/** @} */ + +#endif /* __ENET_CALLBACKS_H__ */ + diff --git a/source/engine/thirdparty/enet/include/enet/enet.h b/source/engine/thirdparty/enet/include/enet/enet.h new file mode 100644 index 0000000..d422ef5 --- /dev/null +++ b/source/engine/thirdparty/enet/include/enet/enet.h @@ -0,0 +1,613 @@ +/** + @file enet.h + @brief ENet public header file +*/ +#ifndef __ENET_ENET_H__ +#define __ENET_ENET_H__ + +#ifdef __cplusplus +extern "C" +{ +#endif + +#include + +#ifdef _WIN32 +#include "enet/win32.h" +#else +#include "enet/unix.h" +#endif + +#include "enet/types.h" +#include "enet/protocol.h" +#include "enet/list.h" +#include "enet/callbacks.h" + +#define ENET_VERSION_MAJOR 1 +#define ENET_VERSION_MINOR 3 +#define ENET_VERSION_PATCH 17 +#define ENET_VERSION_CREATE(major, minor, patch) (((major)<<16) | ((minor)<<8) | (patch)) +#define ENET_VERSION_GET_MAJOR(version) (((version)>>16)&0xFF) +#define ENET_VERSION_GET_MINOR(version) (((version)>>8)&0xFF) +#define ENET_VERSION_GET_PATCH(version) ((version)&0xFF) +#define ENET_VERSION ENET_VERSION_CREATE(ENET_VERSION_MAJOR, ENET_VERSION_MINOR, ENET_VERSION_PATCH) + +typedef enet_uint32 ENetVersion; + +struct _ENetHost; +struct _ENetEvent; +struct _ENetPacket; + +typedef enum _ENetSocketType +{ + ENET_SOCKET_TYPE_STREAM = 1, + ENET_SOCKET_TYPE_DATAGRAM = 2 +} ENetSocketType; + +typedef enum _ENetSocketWait +{ + ENET_SOCKET_WAIT_NONE = 0, + ENET_SOCKET_WAIT_SEND = (1 << 0), + ENET_SOCKET_WAIT_RECEIVE = (1 << 1), + ENET_SOCKET_WAIT_INTERRUPT = (1 << 2) +} ENetSocketWait; + +typedef enum _ENetSocketOption +{ + ENET_SOCKOPT_NONBLOCK = 1, + ENET_SOCKOPT_BROADCAST = 2, + ENET_SOCKOPT_RCVBUF = 3, + ENET_SOCKOPT_SNDBUF = 4, + ENET_SOCKOPT_REUSEADDR = 5, + ENET_SOCKOPT_RCVTIMEO = 6, + ENET_SOCKOPT_SNDTIMEO = 7, + ENET_SOCKOPT_ERROR = 8, + ENET_SOCKOPT_NODELAY = 9 +} ENetSocketOption; + +typedef enum _ENetSocketShutdown +{ + ENET_SOCKET_SHUTDOWN_READ = 0, + ENET_SOCKET_SHUTDOWN_WRITE = 1, + ENET_SOCKET_SHUTDOWN_READ_WRITE = 2 +} ENetSocketShutdown; + +#define ENET_HOST_ANY 0 +#define ENET_HOST_BROADCAST 0xFFFFFFFFU +#define ENET_PORT_ANY 0 + +/** + * Portable internet address structure. + * + * The host must be specified in network byte-order, and the port must be in host + * byte-order. The constant ENET_HOST_ANY may be used to specify the default + * server host. The constant ENET_HOST_BROADCAST may be used to specify the + * broadcast address (255.255.255.255). This makes sense for enet_host_connect, + * but not for enet_host_create. Once a server responds to a broadcast, the + * address is updated from ENET_HOST_BROADCAST to the server's actual IP address. + */ +typedef struct _ENetAddress +{ + enet_uint32 host; + enet_uint16 port; +} ENetAddress; + +/** + * Packet flag bit constants. + * + * The host must be specified in network byte-order, and the port must be in + * host byte-order. The constant ENET_HOST_ANY may be used to specify the + * default server host. + + @sa ENetPacket +*/ +typedef enum _ENetPacketFlag +{ + /** packet must be received by the target peer and resend attempts should be + * made until the packet is delivered */ + ENET_PACKET_FLAG_RELIABLE = (1 << 0), + /** packet will not be sequenced with other packets + * not supported for reliable packets + */ + ENET_PACKET_FLAG_UNSEQUENCED = (1 << 1), + /** packet will not allocate data, and user must supply it instead */ + ENET_PACKET_FLAG_NO_ALLOCATE = (1 << 2), + /** packet will be fragmented using unreliable (instead of reliable) sends + * if it exceeds the MTU */ + ENET_PACKET_FLAG_UNRELIABLE_FRAGMENT = (1 << 3), + + /** whether the packet has been sent from all queues it has been entered into */ + ENET_PACKET_FLAG_SENT = (1<<8) +} ENetPacketFlag; + +typedef void (ENET_CALLBACK * ENetPacketFreeCallback) (struct _ENetPacket *); + +/** + * ENet packet structure. + * + * An ENet data packet that may be sent to or received from a peer. The shown + * fields should only be read and never modified. The data field contains the + * allocated data for the packet. The dataLength fields specifies the length + * of the allocated data. The flags field is either 0 (specifying no flags), + * or a bitwise-or of any combination of the following flags: + * + * ENET_PACKET_FLAG_RELIABLE - packet must be received by the target peer + * and resend attempts should be made until the packet is delivered + * + * ENET_PACKET_FLAG_UNSEQUENCED - packet will not be sequenced with other packets + * (not supported for reliable packets) + * + * ENET_PACKET_FLAG_NO_ALLOCATE - packet will not allocate data, and user must supply it instead + * + * ENET_PACKET_FLAG_UNRELIABLE_FRAGMENT - packet will be fragmented using unreliable + * (instead of reliable) sends if it exceeds the MTU + * + * ENET_PACKET_FLAG_SENT - whether the packet has been sent from all queues it has been entered into + @sa ENetPacketFlag + */ +typedef struct _ENetPacket +{ + size_t referenceCount; /**< internal use only */ + enet_uint32 flags; /**< bitwise-or of ENetPacketFlag constants */ + enet_uint8 * data; /**< allocated data for packet */ + size_t dataLength; /**< length of data */ + ENetPacketFreeCallback freeCallback; /**< function to be called when the packet is no longer in use */ + void * userData; /**< application private data, may be freely modified */ +} ENetPacket; + +typedef struct _ENetAcknowledgement +{ + ENetListNode acknowledgementList; + enet_uint32 sentTime; + ENetProtocol command; +} ENetAcknowledgement; + +typedef struct _ENetOutgoingCommand +{ + ENetListNode outgoingCommandList; + enet_uint16 reliableSequenceNumber; + enet_uint16 unreliableSequenceNumber; + enet_uint32 sentTime; + enet_uint32 roundTripTimeout; + enet_uint32 roundTripTimeoutLimit; + enet_uint32 fragmentOffset; + enet_uint16 fragmentLength; + enet_uint16 sendAttempts; + ENetProtocol command; + ENetPacket * packet; +} ENetOutgoingCommand; + +typedef struct _ENetIncomingCommand +{ + ENetListNode incomingCommandList; + enet_uint16 reliableSequenceNumber; + enet_uint16 unreliableSequenceNumber; + ENetProtocol command; + enet_uint32 fragmentCount; + enet_uint32 fragmentsRemaining; + enet_uint32 * fragments; + ENetPacket * packet; +} ENetIncomingCommand; + +typedef enum _ENetPeerState +{ + ENET_PEER_STATE_DISCONNECTED = 0, + ENET_PEER_STATE_CONNECTING = 1, + ENET_PEER_STATE_ACKNOWLEDGING_CONNECT = 2, + ENET_PEER_STATE_CONNECTION_PENDING = 3, + ENET_PEER_STATE_CONNECTION_SUCCEEDED = 4, + ENET_PEER_STATE_CONNECTED = 5, + ENET_PEER_STATE_DISCONNECT_LATER = 6, + ENET_PEER_STATE_DISCONNECTING = 7, + ENET_PEER_STATE_ACKNOWLEDGING_DISCONNECT = 8, + ENET_PEER_STATE_ZOMBIE = 9 +} ENetPeerState; + +#ifndef ENET_BUFFER_MAXIMUM +#define ENET_BUFFER_MAXIMUM (1 + 2 * ENET_PROTOCOL_MAXIMUM_PACKET_COMMANDS) +#endif + +enum +{ + ENET_HOST_RECEIVE_BUFFER_SIZE = 256 * 1024, + ENET_HOST_SEND_BUFFER_SIZE = 256 * 1024, + ENET_HOST_BANDWIDTH_THROTTLE_INTERVAL = 1000, + ENET_HOST_DEFAULT_MTU = 1400, + ENET_HOST_DEFAULT_MAXIMUM_PACKET_SIZE = 32 * 1024 * 1024, + ENET_HOST_DEFAULT_MAXIMUM_WAITING_DATA = 32 * 1024 * 1024, + + ENET_PEER_DEFAULT_ROUND_TRIP_TIME = 500, + ENET_PEER_DEFAULT_PACKET_THROTTLE = 32, + ENET_PEER_PACKET_THROTTLE_SCALE = 32, + ENET_PEER_PACKET_THROTTLE_COUNTER = 7, + ENET_PEER_PACKET_THROTTLE_ACCELERATION = 2, + ENET_PEER_PACKET_THROTTLE_DECELERATION = 2, + ENET_PEER_PACKET_THROTTLE_INTERVAL = 5000, + ENET_PEER_PACKET_LOSS_SCALE = (1 << 16), + ENET_PEER_PACKET_LOSS_INTERVAL = 10000, + ENET_PEER_WINDOW_SIZE_SCALE = 64 * 1024, + ENET_PEER_TIMEOUT_LIMIT = 32, + ENET_PEER_TIMEOUT_MINIMUM = 5000, + ENET_PEER_TIMEOUT_MAXIMUM = 30000, + ENET_PEER_PING_INTERVAL = 500, + ENET_PEER_UNSEQUENCED_WINDOWS = 64, + ENET_PEER_UNSEQUENCED_WINDOW_SIZE = 1024, + ENET_PEER_FREE_UNSEQUENCED_WINDOWS = 32, + ENET_PEER_RELIABLE_WINDOWS = 16, + ENET_PEER_RELIABLE_WINDOW_SIZE = 0x1000, + ENET_PEER_FREE_RELIABLE_WINDOWS = 8 +}; + +typedef struct _ENetChannel +{ + enet_uint16 outgoingReliableSequenceNumber; + enet_uint16 outgoingUnreliableSequenceNumber; + enet_uint16 usedReliableWindows; + enet_uint16 reliableWindows [ENET_PEER_RELIABLE_WINDOWS]; + enet_uint16 incomingReliableSequenceNumber; + enet_uint16 incomingUnreliableSequenceNumber; + ENetList incomingReliableCommands; + ENetList incomingUnreliableCommands; +} ENetChannel; + +typedef enum _ENetPeerFlag +{ + ENET_PEER_FLAG_NEEDS_DISPATCH = (1 << 0) +} ENetPeerFlag; + +/** + * An ENet peer which data packets may be sent or received from. + * + * No fields should be modified unless otherwise specified. + */ +typedef struct _ENetPeer +{ + ENetListNode dispatchList; + struct _ENetHost * host; + enet_uint16 outgoingPeerID; + enet_uint16 incomingPeerID; + enet_uint32 connectID; + enet_uint8 outgoingSessionID; + enet_uint8 incomingSessionID; + ENetAddress address; /**< Internet address of the peer */ + void * data; /**< Application private data, may be freely modified */ + ENetPeerState state; + ENetChannel * channels; + size_t channelCount; /**< Number of channels allocated for communication with peer */ + enet_uint32 incomingBandwidth; /**< Downstream bandwidth of the client in bytes/second */ + enet_uint32 outgoingBandwidth; /**< Upstream bandwidth of the client in bytes/second */ + enet_uint32 incomingBandwidthThrottleEpoch; + enet_uint32 outgoingBandwidthThrottleEpoch; + enet_uint32 incomingDataTotal; + enet_uint32 outgoingDataTotal; + enet_uint32 lastSendTime; + enet_uint32 lastReceiveTime; + enet_uint32 nextTimeout; + enet_uint32 earliestTimeout; + enet_uint32 packetLossEpoch; + enet_uint32 packetsSent; + enet_uint32 packetsLost; + enet_uint32 packetLoss; /**< mean packet loss of reliable packets as a ratio with respect to the constant ENET_PEER_PACKET_LOSS_SCALE */ + enet_uint32 packetLossVariance; + enet_uint32 packetThrottle; + enet_uint32 packetThrottleLimit; + enet_uint32 packetThrottleCounter; + enet_uint32 packetThrottleEpoch; + enet_uint32 packetThrottleAcceleration; + enet_uint32 packetThrottleDeceleration; + enet_uint32 packetThrottleInterval; + enet_uint32 pingInterval; + enet_uint32 timeoutLimit; + enet_uint32 timeoutMinimum; + enet_uint32 timeoutMaximum; + enet_uint32 lastRoundTripTime; + enet_uint32 lowestRoundTripTime; + enet_uint32 lastRoundTripTimeVariance; + enet_uint32 highestRoundTripTimeVariance; + enet_uint32 roundTripTime; /**< mean round trip time (RTT), in milliseconds, between sending a reliable packet and receiving its acknowledgement */ + enet_uint32 roundTripTimeVariance; + enet_uint32 mtu; + enet_uint32 windowSize; + enet_uint32 reliableDataInTransit; + enet_uint16 outgoingReliableSequenceNumber; + ENetList acknowledgements; + ENetList sentReliableCommands; + ENetList sentUnreliableCommands; + ENetList outgoingCommands; + ENetList dispatchedCommands; + enet_uint16 flags; + enet_uint16 reserved; + enet_uint16 incomingUnsequencedGroup; + enet_uint16 outgoingUnsequencedGroup; + enet_uint32 unsequencedWindow [ENET_PEER_UNSEQUENCED_WINDOW_SIZE / 32]; + enet_uint32 eventData; + size_t totalWaitingData; +} ENetPeer; + +/** An ENet packet compressor for compressing UDP packets before socket sends or receives. + */ +typedef struct _ENetCompressor +{ + /** Context data for the compressor. Must be non-NULL. */ + void * context; + /** Compresses from inBuffers[0:inBufferCount-1], containing inLimit bytes, to outData, outputting at most outLimit bytes. Should return 0 on failure. */ + size_t (ENET_CALLBACK * compress) (void * context, const ENetBuffer * inBuffers, size_t inBufferCount, size_t inLimit, enet_uint8 * outData, size_t outLimit); + /** Decompresses from inData, containing inLimit bytes, to outData, outputting at most outLimit bytes. Should return 0 on failure. */ + size_t (ENET_CALLBACK * decompress) (void * context, const enet_uint8 * inData, size_t inLimit, enet_uint8 * outData, size_t outLimit); + /** Destroys the context when compression is disabled or the host is destroyed. May be NULL. */ + void (ENET_CALLBACK * destroy) (void * context); +} ENetCompressor; + +/** Callback that computes the checksum of the data held in buffers[0:bufferCount-1] */ +typedef enet_uint32 (ENET_CALLBACK * ENetChecksumCallback) (const ENetBuffer * buffers, size_t bufferCount); + +/** Callback for intercepting received raw UDP packets. Should return 1 to intercept, 0 to ignore, or -1 to propagate an error. */ +typedef int (ENET_CALLBACK * ENetInterceptCallback) (struct _ENetHost * host, struct _ENetEvent * event); + +/** An ENet host for communicating with peers. + * + * No fields should be modified unless otherwise stated. + + @sa enet_host_create() + @sa enet_host_destroy() + @sa enet_host_connect() + @sa enet_host_service() + @sa enet_host_flush() + @sa enet_host_broadcast() + @sa enet_host_compress() + @sa enet_host_compress_with_range_coder() + @sa enet_host_channel_limit() + @sa enet_host_bandwidth_limit() + @sa enet_host_bandwidth_throttle() + */ +typedef struct _ENetHost +{ + ENetSocket socket; + ENetAddress address; /**< Internet address of the host */ + enet_uint32 incomingBandwidth; /**< downstream bandwidth of the host */ + enet_uint32 outgoingBandwidth; /**< upstream bandwidth of the host */ + enet_uint32 bandwidthThrottleEpoch; + enet_uint32 mtu; + enet_uint32 randomSeed; + int recalculateBandwidthLimits; + ENetPeer * peers; /**< array of peers allocated for this host */ + size_t peerCount; /**< number of peers allocated for this host */ + size_t channelLimit; /**< maximum number of channels allowed for connected peers */ + enet_uint32 serviceTime; + ENetList dispatchQueue; + int continueSending; + size_t packetSize; + enet_uint16 headerFlags; + ENetProtocol commands [ENET_PROTOCOL_MAXIMUM_PACKET_COMMANDS]; + size_t commandCount; + ENetBuffer buffers [ENET_BUFFER_MAXIMUM]; + size_t bufferCount; + ENetChecksumCallback checksum; /**< callback the user can set to enable packet checksums for this host */ + ENetCompressor compressor; + enet_uint8 packetData [2][ENET_PROTOCOL_MAXIMUM_MTU]; + ENetAddress receivedAddress; + enet_uint8 * receivedData; + size_t receivedDataLength; + enet_uint32 totalSentData; /**< total data sent, user should reset to 0 as needed to prevent overflow */ + enet_uint32 totalSentPackets; /**< total UDP packets sent, user should reset to 0 as needed to prevent overflow */ + enet_uint32 totalReceivedData; /**< total data received, user should reset to 0 as needed to prevent overflow */ + enet_uint32 totalReceivedPackets; /**< total UDP packets received, user should reset to 0 as needed to prevent overflow */ + ENetInterceptCallback intercept; /**< callback the user can set to intercept received raw UDP packets */ + size_t connectedPeers; + size_t bandwidthLimitedPeers; + size_t duplicatePeers; /**< optional number of allowed peers from duplicate IPs, defaults to ENET_PROTOCOL_MAXIMUM_PEER_ID */ + size_t maximumPacketSize; /**< the maximum allowable packet size that may be sent or received on a peer */ + size_t maximumWaitingData; /**< the maximum aggregate amount of buffer space a peer may use waiting for packets to be delivered */ +} ENetHost; + +/** + * An ENet event type, as specified in @ref ENetEvent. + */ +typedef enum _ENetEventType +{ + /** no event occurred within the specified time limit */ + ENET_EVENT_TYPE_NONE = 0, + + /** a connection request initiated by enet_host_connect has completed. + * The peer field contains the peer which successfully connected. + */ + ENET_EVENT_TYPE_CONNECT = 1, + + /** a peer has disconnected. This event is generated on a successful + * completion of a disconnect initiated by enet_peer_disconnect, if + * a peer has timed out, or if a connection request intialized by + * enet_host_connect has timed out. The peer field contains the peer + * which disconnected. The data field contains user supplied data + * describing the disconnection, or 0, if none is available. + */ + ENET_EVENT_TYPE_DISCONNECT = 2, + + /** a packet has been received from a peer. The peer field specifies the + * peer which sent the packet. The channelID field specifies the channel + * number upon which the packet was received. The packet field contains + * the packet that was received; this packet must be destroyed with + * enet_packet_destroy after use. + */ + ENET_EVENT_TYPE_RECEIVE = 3 +} ENetEventType; + +/** + * An ENet event as returned by enet_host_service(). + + @sa enet_host_service + */ +typedef struct _ENetEvent +{ + ENetEventType type; /**< type of the event */ + ENetPeer * peer; /**< peer that generated a connect, disconnect or receive event */ + enet_uint8 channelID; /**< channel on the peer that generated the event, if appropriate */ + enet_uint32 data; /**< data associated with the event, if appropriate */ + ENetPacket * packet; /**< packet associated with the event, if appropriate */ +} ENetEvent; + +/** @defgroup global ENet global functions + @{ +*/ + +/** + Initializes ENet globally. Must be called prior to using any functions in + ENet. + @returns 0 on success, < 0 on failure +*/ +ENET_API int enet_initialize (void); + +/** + Initializes ENet globally and supplies user-overridden callbacks. Must be called prior to using any functions in ENet. Do not use enet_initialize() if you use this variant. Make sure the ENetCallbacks structure is zeroed out so that any additional callbacks added in future versions will be properly ignored. + + @param version the constant ENET_VERSION should be supplied so ENet knows which version of ENetCallbacks struct to use + @param inits user-overridden callbacks where any NULL callbacks will use ENet's defaults + @returns 0 on success, < 0 on failure +*/ +ENET_API int enet_initialize_with_callbacks (ENetVersion version, const ENetCallbacks * inits); + +/** + Shuts down ENet globally. Should be called when a program that has + initialized ENet exits. +*/ +ENET_API void enet_deinitialize (void); + +/** + Gives the linked version of the ENet library. + @returns the version number +*/ +ENET_API ENetVersion enet_linked_version (void); + +/** @} */ + +/** @defgroup private ENet private implementation functions */ + +/** + Returns the wall-time in milliseconds. Its initial value is unspecified + unless otherwise set. + */ +ENET_API enet_uint32 enet_time_get (void); +/** + Sets the current wall-time in milliseconds. + */ +ENET_API void enet_time_set (enet_uint32); + +/** @defgroup socket ENet socket functions + @{ +*/ +ENET_API ENetSocket enet_socket_create (ENetSocketType); +ENET_API int enet_socket_bind (ENetSocket, const ENetAddress *); +ENET_API int enet_socket_get_address (ENetSocket, ENetAddress *); +ENET_API int enet_socket_listen (ENetSocket, int); +ENET_API ENetSocket enet_socket_accept (ENetSocket, ENetAddress *); +ENET_API int enet_socket_connect (ENetSocket, const ENetAddress *); +ENET_API int enet_socket_send (ENetSocket, const ENetAddress *, const ENetBuffer *, size_t); +ENET_API int enet_socket_receive (ENetSocket, ENetAddress *, ENetBuffer *, size_t); +ENET_API int enet_socket_wait (ENetSocket, enet_uint32 *, enet_uint32); +ENET_API int enet_socket_set_option (ENetSocket, ENetSocketOption, int); +ENET_API int enet_socket_get_option (ENetSocket, ENetSocketOption, int *); +ENET_API int enet_socket_shutdown (ENetSocket, ENetSocketShutdown); +ENET_API void enet_socket_destroy (ENetSocket); +ENET_API int enet_socketset_select (ENetSocket, ENetSocketSet *, ENetSocketSet *, enet_uint32); + +/** @} */ + +/** @defgroup Address ENet address functions + @{ +*/ + +/** Attempts to parse the printable form of the IP address in the parameter hostName + and sets the host field in the address parameter if successful. + @param address destination to store the parsed IP address + @param hostName IP address to parse + @retval 0 on success + @retval < 0 on failure + @returns the address of the given hostName in address on success +*/ +ENET_API int enet_address_set_host_ip (ENetAddress * address, const char * hostName); + +/** Attempts to resolve the host named by the parameter hostName and sets + the host field in the address parameter if successful. + @param address destination to store resolved address + @param hostName host name to lookup + @retval 0 on success + @retval < 0 on failure + @returns the address of the given hostName in address on success +*/ +ENET_API int enet_address_set_host (ENetAddress * address, const char * hostName); + +/** Gives the printable form of the IP address specified in the address parameter. + @param address address printed + @param hostName destination for name, must not be NULL + @param nameLength maximum length of hostName. + @returns the null-terminated name of the host in hostName on success + @retval 0 on success + @retval < 0 on failure +*/ +ENET_API int enet_address_get_host_ip (const ENetAddress * address, char * hostName, size_t nameLength); + +/** Attempts to do a reverse lookup of the host field in the address parameter. + @param address address used for reverse lookup + @param hostName destination for name, must not be NULL + @param nameLength maximum length of hostName. + @returns the null-terminated name of the host in hostName on success + @retval 0 on success + @retval < 0 on failure +*/ +ENET_API int enet_address_get_host (const ENetAddress * address, char * hostName, size_t nameLength); + +/** @} */ + +ENET_API ENetPacket * enet_packet_create (const void *, size_t, enet_uint32); +ENET_API void enet_packet_destroy (ENetPacket *); +ENET_API int enet_packet_resize (ENetPacket *, size_t); +ENET_API enet_uint32 enet_crc32 (const ENetBuffer *, size_t); + +ENET_API ENetHost * enet_host_create (const ENetAddress *, size_t, size_t, enet_uint32, enet_uint32); +ENET_API void enet_host_destroy (ENetHost *); +ENET_API ENetPeer * enet_host_connect (ENetHost *, const ENetAddress *, size_t, enet_uint32); +ENET_API int enet_host_check_events (ENetHost *, ENetEvent *); +ENET_API int enet_host_service (ENetHost *, ENetEvent *, enet_uint32); +ENET_API void enet_host_flush (ENetHost *); +ENET_API void enet_host_broadcast (ENetHost *, enet_uint8, ENetPacket *); +ENET_API void enet_host_compress (ENetHost *, const ENetCompressor *); +ENET_API int enet_host_compress_with_range_coder (ENetHost * host); +ENET_API void enet_host_channel_limit (ENetHost *, size_t); +ENET_API void enet_host_bandwidth_limit (ENetHost *, enet_uint32, enet_uint32); +extern void enet_host_bandwidth_throttle (ENetHost *); +extern enet_uint32 enet_host_random_seed (void); +extern enet_uint32 enet_host_random (ENetHost *); + +ENET_API int enet_peer_send (ENetPeer *, enet_uint8, ENetPacket *); +ENET_API ENetPacket * enet_peer_receive (ENetPeer *, enet_uint8 * channelID); +ENET_API void enet_peer_ping (ENetPeer *); +ENET_API void enet_peer_ping_interval (ENetPeer *, enet_uint32); +ENET_API void enet_peer_timeout (ENetPeer *, enet_uint32, enet_uint32, enet_uint32); +ENET_API void enet_peer_reset (ENetPeer *); +ENET_API void enet_peer_disconnect (ENetPeer *, enet_uint32); +ENET_API void enet_peer_disconnect_now (ENetPeer *, enet_uint32); +ENET_API void enet_peer_disconnect_later (ENetPeer *, enet_uint32); +ENET_API void enet_peer_throttle_configure (ENetPeer *, enet_uint32, enet_uint32, enet_uint32); +extern int enet_peer_throttle (ENetPeer *, enet_uint32); +extern void enet_peer_reset_queues (ENetPeer *); +extern void enet_peer_setup_outgoing_command (ENetPeer *, ENetOutgoingCommand *); +extern ENetOutgoingCommand * enet_peer_queue_outgoing_command (ENetPeer *, const ENetProtocol *, ENetPacket *, enet_uint32, enet_uint16); +extern ENetIncomingCommand * enet_peer_queue_incoming_command (ENetPeer *, const ENetProtocol *, const void *, size_t, enet_uint32, enet_uint32); +extern ENetAcknowledgement * enet_peer_queue_acknowledgement (ENetPeer *, const ENetProtocol *, enet_uint16); +extern void enet_peer_dispatch_incoming_unreliable_commands (ENetPeer *, ENetChannel *, ENetIncomingCommand *); +extern void enet_peer_dispatch_incoming_reliable_commands (ENetPeer *, ENetChannel *, ENetIncomingCommand *); +extern void enet_peer_on_connect (ENetPeer *); +extern void enet_peer_on_disconnect (ENetPeer *); + +ENET_API void * enet_range_coder_create (void); +ENET_API void enet_range_coder_destroy (void *); +ENET_API size_t enet_range_coder_compress (void *, const ENetBuffer *, size_t, size_t, enet_uint8 *, size_t); +ENET_API size_t enet_range_coder_decompress (void *, const enet_uint8 *, size_t, enet_uint8 *, size_t); + +extern size_t enet_protocol_command_size (enet_uint8); + +#ifdef __cplusplus +} +#endif + +#endif /* __ENET_ENET_H__ */ + diff --git a/source/engine/thirdparty/enet/include/enet/list.h b/source/engine/thirdparty/enet/include/enet/list.h new file mode 100644 index 0000000..d7b2600 --- /dev/null +++ b/source/engine/thirdparty/enet/include/enet/list.h @@ -0,0 +1,43 @@ +/** + @file list.h + @brief ENet list management +*/ +#ifndef __ENET_LIST_H__ +#define __ENET_LIST_H__ + +#include + +typedef struct _ENetListNode +{ + struct _ENetListNode * next; + struct _ENetListNode * previous; +} ENetListNode; + +typedef ENetListNode * ENetListIterator; + +typedef struct _ENetList +{ + ENetListNode sentinel; +} ENetList; + +extern void enet_list_clear (ENetList *); + +extern ENetListIterator enet_list_insert (ENetListIterator, void *); +extern void * enet_list_remove (ENetListIterator); +extern ENetListIterator enet_list_move (ENetListIterator, void *, void *); + +extern size_t enet_list_size (ENetList *); + +#define enet_list_begin(list) ((list) -> sentinel.next) +#define enet_list_end(list) (& (list) -> sentinel) + +#define enet_list_empty(list) (enet_list_begin (list) == enet_list_end (list)) + +#define enet_list_next(iterator) ((iterator) -> next) +#define enet_list_previous(iterator) ((iterator) -> previous) + +#define enet_list_front(list) ((void *) (list) -> sentinel.next) +#define enet_list_back(list) ((void *) (list) -> sentinel.previous) + +#endif /* __ENET_LIST_H__ */ + diff --git a/source/engine/thirdparty/enet/include/enet/protocol.h b/source/engine/thirdparty/enet/include/enet/protocol.h new file mode 100644 index 0000000..f8c73d8 --- /dev/null +++ b/source/engine/thirdparty/enet/include/enet/protocol.h @@ -0,0 +1,198 @@ +/** + @file protocol.h + @brief ENet protocol +*/ +#ifndef __ENET_PROTOCOL_H__ +#define __ENET_PROTOCOL_H__ + +#include "enet/types.h" + +enum +{ + ENET_PROTOCOL_MINIMUM_MTU = 576, + ENET_PROTOCOL_MAXIMUM_MTU = 4096, + ENET_PROTOCOL_MAXIMUM_PACKET_COMMANDS = 32, + ENET_PROTOCOL_MINIMUM_WINDOW_SIZE = 4096, + ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE = 65536, + ENET_PROTOCOL_MINIMUM_CHANNEL_COUNT = 1, + ENET_PROTOCOL_MAXIMUM_CHANNEL_COUNT = 255, + ENET_PROTOCOL_MAXIMUM_PEER_ID = 0xFFF, + ENET_PROTOCOL_MAXIMUM_FRAGMENT_COUNT = 1024 * 1024 +}; + +typedef enum _ENetProtocolCommand +{ + ENET_PROTOCOL_COMMAND_NONE = 0, + ENET_PROTOCOL_COMMAND_ACKNOWLEDGE = 1, + ENET_PROTOCOL_COMMAND_CONNECT = 2, + ENET_PROTOCOL_COMMAND_VERIFY_CONNECT = 3, + ENET_PROTOCOL_COMMAND_DISCONNECT = 4, + ENET_PROTOCOL_COMMAND_PING = 5, + ENET_PROTOCOL_COMMAND_SEND_RELIABLE = 6, + ENET_PROTOCOL_COMMAND_SEND_UNRELIABLE = 7, + ENET_PROTOCOL_COMMAND_SEND_FRAGMENT = 8, + ENET_PROTOCOL_COMMAND_SEND_UNSEQUENCED = 9, + ENET_PROTOCOL_COMMAND_BANDWIDTH_LIMIT = 10, + ENET_PROTOCOL_COMMAND_THROTTLE_CONFIGURE = 11, + ENET_PROTOCOL_COMMAND_SEND_UNRELIABLE_FRAGMENT = 12, + ENET_PROTOCOL_COMMAND_COUNT = 13, + + ENET_PROTOCOL_COMMAND_MASK = 0x0F +} ENetProtocolCommand; + +typedef enum _ENetProtocolFlag +{ + ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE = (1 << 7), + ENET_PROTOCOL_COMMAND_FLAG_UNSEQUENCED = (1 << 6), + + ENET_PROTOCOL_HEADER_FLAG_COMPRESSED = (1 << 14), + ENET_PROTOCOL_HEADER_FLAG_SENT_TIME = (1 << 15), + ENET_PROTOCOL_HEADER_FLAG_MASK = ENET_PROTOCOL_HEADER_FLAG_COMPRESSED | ENET_PROTOCOL_HEADER_FLAG_SENT_TIME, + + ENET_PROTOCOL_HEADER_SESSION_MASK = (3 << 12), + ENET_PROTOCOL_HEADER_SESSION_SHIFT = 12 +} ENetProtocolFlag; + +#ifdef _MSC_VER +#pragma pack(push, 1) +#define ENET_PACKED +#elif defined(__GNUC__) || defined(__clang__) +#define ENET_PACKED __attribute__ ((packed)) +#else +#define ENET_PACKED +#endif + +typedef struct _ENetProtocolHeader +{ + enet_uint16 peerID; + enet_uint16 sentTime; +} ENET_PACKED ENetProtocolHeader; + +typedef struct _ENetProtocolCommandHeader +{ + enet_uint8 command; + enet_uint8 channelID; + enet_uint16 reliableSequenceNumber; +} ENET_PACKED ENetProtocolCommandHeader; + +typedef struct _ENetProtocolAcknowledge +{ + ENetProtocolCommandHeader header; + enet_uint16 receivedReliableSequenceNumber; + enet_uint16 receivedSentTime; +} ENET_PACKED ENetProtocolAcknowledge; + +typedef struct _ENetProtocolConnect +{ + ENetProtocolCommandHeader header; + enet_uint16 outgoingPeerID; + enet_uint8 incomingSessionID; + enet_uint8 outgoingSessionID; + enet_uint32 mtu; + enet_uint32 windowSize; + enet_uint32 channelCount; + enet_uint32 incomingBandwidth; + enet_uint32 outgoingBandwidth; + enet_uint32 packetThrottleInterval; + enet_uint32 packetThrottleAcceleration; + enet_uint32 packetThrottleDeceleration; + enet_uint32 connectID; + enet_uint32 data; +} ENET_PACKED ENetProtocolConnect; + +typedef struct _ENetProtocolVerifyConnect +{ + ENetProtocolCommandHeader header; + enet_uint16 outgoingPeerID; + enet_uint8 incomingSessionID; + enet_uint8 outgoingSessionID; + enet_uint32 mtu; + enet_uint32 windowSize; + enet_uint32 channelCount; + enet_uint32 incomingBandwidth; + enet_uint32 outgoingBandwidth; + enet_uint32 packetThrottleInterval; + enet_uint32 packetThrottleAcceleration; + enet_uint32 packetThrottleDeceleration; + enet_uint32 connectID; +} ENET_PACKED ENetProtocolVerifyConnect; + +typedef struct _ENetProtocolBandwidthLimit +{ + ENetProtocolCommandHeader header; + enet_uint32 incomingBandwidth; + enet_uint32 outgoingBandwidth; +} ENET_PACKED ENetProtocolBandwidthLimit; + +typedef struct _ENetProtocolThrottleConfigure +{ + ENetProtocolCommandHeader header; + enet_uint32 packetThrottleInterval; + enet_uint32 packetThrottleAcceleration; + enet_uint32 packetThrottleDeceleration; +} ENET_PACKED ENetProtocolThrottleConfigure; + +typedef struct _ENetProtocolDisconnect +{ + ENetProtocolCommandHeader header; + enet_uint32 data; +} ENET_PACKED ENetProtocolDisconnect; + +typedef struct _ENetProtocolPing +{ + ENetProtocolCommandHeader header; +} ENET_PACKED ENetProtocolPing; + +typedef struct _ENetProtocolSendReliable +{ + ENetProtocolCommandHeader header; + enet_uint16 dataLength; +} ENET_PACKED ENetProtocolSendReliable; + +typedef struct _ENetProtocolSendUnreliable +{ + ENetProtocolCommandHeader header; + enet_uint16 unreliableSequenceNumber; + enet_uint16 dataLength; +} ENET_PACKED ENetProtocolSendUnreliable; + +typedef struct _ENetProtocolSendUnsequenced +{ + ENetProtocolCommandHeader header; + enet_uint16 unsequencedGroup; + enet_uint16 dataLength; +} ENET_PACKED ENetProtocolSendUnsequenced; + +typedef struct _ENetProtocolSendFragment +{ + ENetProtocolCommandHeader header; + enet_uint16 startSequenceNumber; + enet_uint16 dataLength; + enet_uint32 fragmentCount; + enet_uint32 fragmentNumber; + enet_uint32 totalLength; + enet_uint32 fragmentOffset; +} ENET_PACKED ENetProtocolSendFragment; + +typedef union _ENetProtocol +{ + ENetProtocolCommandHeader header; + ENetProtocolAcknowledge acknowledge; + ENetProtocolConnect connect; + ENetProtocolVerifyConnect verifyConnect; + ENetProtocolDisconnect disconnect; + ENetProtocolPing ping; + ENetProtocolSendReliable sendReliable; + ENetProtocolSendUnreliable sendUnreliable; + ENetProtocolSendUnsequenced sendUnsequenced; + ENetProtocolSendFragment sendFragment; + ENetProtocolBandwidthLimit bandwidthLimit; + ENetProtocolThrottleConfigure throttleConfigure; +} ENET_PACKED ENetProtocol; + +#ifdef _MSC_VER +#pragma pack(pop) +#endif + +#endif /* __ENET_PROTOCOL_H__ */ + diff --git a/source/engine/thirdparty/enet/include/enet/time.h b/source/engine/thirdparty/enet/include/enet/time.h new file mode 100644 index 0000000..c82a546 --- /dev/null +++ b/source/engine/thirdparty/enet/include/enet/time.h @@ -0,0 +1,18 @@ +/** + @file time.h + @brief ENet time constants and macros +*/ +#ifndef __ENET_TIME_H__ +#define __ENET_TIME_H__ + +#define ENET_TIME_OVERFLOW 86400000 + +#define ENET_TIME_LESS(a, b) ((a) - (b) >= ENET_TIME_OVERFLOW) +#define ENET_TIME_GREATER(a, b) ((b) - (a) >= ENET_TIME_OVERFLOW) +#define ENET_TIME_LESS_EQUAL(a, b) (! ENET_TIME_GREATER (a, b)) +#define ENET_TIME_GREATER_EQUAL(a, b) (! ENET_TIME_LESS (a, b)) + +#define ENET_TIME_DIFFERENCE(a, b) ((a) - (b) >= ENET_TIME_OVERFLOW ? (b) - (a) : (a) - (b)) + +#endif /* __ENET_TIME_H__ */ + diff --git a/source/engine/thirdparty/enet/include/enet/types.h b/source/engine/thirdparty/enet/include/enet/types.h new file mode 100644 index 0000000..ab010a4 --- /dev/null +++ b/source/engine/thirdparty/enet/include/enet/types.h @@ -0,0 +1,13 @@ +/** + @file types.h + @brief type definitions for ENet +*/ +#ifndef __ENET_TYPES_H__ +#define __ENET_TYPES_H__ + +typedef unsigned char enet_uint8; /**< unsigned 8-bit type */ +typedef unsigned short enet_uint16; /**< unsigned 16-bit type */ +typedef unsigned int enet_uint32; /**< unsigned 32-bit type */ + +#endif /* __ENET_TYPES_H__ */ + diff --git a/source/engine/thirdparty/enet/include/enet/unix.h b/source/engine/thirdparty/enet/include/enet/unix.h new file mode 100644 index 0000000..b55be33 --- /dev/null +++ b/source/engine/thirdparty/enet/include/enet/unix.h @@ -0,0 +1,48 @@ +/** + @file unix.h + @brief ENet Unix header +*/ +#ifndef __ENET_UNIX_H__ +#define __ENET_UNIX_H__ + +#include +#include +#include +#include +#include +#include +#include + +#ifdef MSG_MAXIOVLEN +#define ENET_BUFFER_MAXIMUM MSG_MAXIOVLEN +#endif + +typedef int ENetSocket; + +#define ENET_SOCKET_NULL -1 + +#define ENET_HOST_TO_NET_16(value) (htons (value)) /**< macro that converts host to net byte-order of a 16-bit value */ +#define ENET_HOST_TO_NET_32(value) (htonl (value)) /**< macro that converts host to net byte-order of a 32-bit value */ + +#define ENET_NET_TO_HOST_16(value) (ntohs (value)) /**< macro that converts net to host byte-order of a 16-bit value */ +#define ENET_NET_TO_HOST_32(value) (ntohl (value)) /**< macro that converts net to host byte-order of a 32-bit value */ + +typedef struct +{ + void * data; + size_t dataLength; +} ENetBuffer; + +#define ENET_CALLBACK + +#define ENET_API extern + +typedef fd_set ENetSocketSet; + +#define ENET_SOCKETSET_EMPTY(sockset) FD_ZERO (& (sockset)) +#define ENET_SOCKETSET_ADD(sockset, socket) FD_SET (socket, & (sockset)) +#define ENET_SOCKETSET_REMOVE(sockset, socket) FD_CLR (socket, & (sockset)) +#define ENET_SOCKETSET_CHECK(sockset, socket) FD_ISSET (socket, & (sockset)) + +#endif /* __ENET_UNIX_H__ */ + diff --git a/source/engine/thirdparty/enet/include/enet/utility.h b/source/engine/thirdparty/enet/include/enet/utility.h new file mode 100644 index 0000000..b04bb7a --- /dev/null +++ b/source/engine/thirdparty/enet/include/enet/utility.h @@ -0,0 +1,13 @@ +/** + @file utility.h + @brief ENet utility header +*/ +#ifndef __ENET_UTILITY_H__ +#define __ENET_UTILITY_H__ + +#define ENET_MAX(x, y) ((x) > (y) ? (x) : (y)) +#define ENET_MIN(x, y) ((x) < (y) ? (x) : (y)) +#define ENET_DIFFERENCE(x, y) ((x) < (y) ? (y) - (x) : (x) - (y)) + +#endif /* __ENET_UTILITY_H__ */ + diff --git a/source/engine/thirdparty/enet/include/enet/win32.h b/source/engine/thirdparty/enet/include/enet/win32.h new file mode 100644 index 0000000..6fbd7c0 --- /dev/null +++ b/source/engine/thirdparty/enet/include/enet/win32.h @@ -0,0 +1,59 @@ +/** + @file win32.h + @brief ENet Win32 header +*/ +#ifndef __ENET_WIN32_H__ +#define __ENET_WIN32_H__ + +#ifdef _MSC_VER +#ifdef ENET_BUILDING_LIB +#pragma warning (disable: 4267) // size_t to int conversion +#pragma warning (disable: 4244) // 64bit to 32bit int +#pragma warning (disable: 4018) // signed/unsigned mismatch +#pragma warning (disable: 4146) // unary minus operator applied to unsigned type +#define _CRT_SECURE_NO_DEPRECATE +#define _CRT_SECURE_NO_WARNINGS +#endif +#endif + +#include +#include + +typedef SOCKET ENetSocket; + +#define ENET_SOCKET_NULL INVALID_SOCKET + +#define ENET_HOST_TO_NET_16(value) (htons (value)) +#define ENET_HOST_TO_NET_32(value) (htonl (value)) + +#define ENET_NET_TO_HOST_16(value) (ntohs (value)) +#define ENET_NET_TO_HOST_32(value) (ntohl (value)) + +typedef struct +{ + size_t dataLength; + void * data; +} ENetBuffer; + +#define ENET_CALLBACK __cdecl + +#ifdef ENET_DLL +#ifdef ENET_BUILDING_LIB +#define ENET_API __declspec( dllexport ) +#else +#define ENET_API __declspec( dllimport ) +#endif /* ENET_BUILDING_LIB */ +#else /* !ENET_DLL */ +#define ENET_API extern +#endif /* ENET_DLL */ + +typedef fd_set ENetSocketSet; + +#define ENET_SOCKETSET_EMPTY(sockset) FD_ZERO (& (sockset)) +#define ENET_SOCKETSET_ADD(sockset, socket) FD_SET (socket, & (sockset)) +#define ENET_SOCKETSET_REMOVE(sockset, socket) FD_CLR (socket, & (sockset)) +#define ENET_SOCKETSET_CHECK(sockset, socket) FD_ISSET (socket, & (sockset)) + +#endif /* __ENET_WIN32_H__ */ + + diff --git a/source/engine/thirdparty/enet/src/callbacks.c b/source/engine/thirdparty/enet/src/callbacks.c new file mode 100644 index 0000000..b3990af --- /dev/null +++ b/source/engine/thirdparty/enet/src/callbacks.c @@ -0,0 +1,53 @@ +/** + @file callbacks.c + @brief ENet callback functions +*/ +#define ENET_BUILDING_LIB 1 +#include "enet/enet.h" + +static ENetCallbacks callbacks = { malloc, free, abort }; + +int +enet_initialize_with_callbacks (ENetVersion version, const ENetCallbacks * inits) +{ + if (version < ENET_VERSION_CREATE (1, 3, 0)) + return -1; + + if (inits -> malloc != NULL || inits -> free != NULL) + { + if (inits -> malloc == NULL || inits -> free == NULL) + return -1; + + callbacks.malloc = inits -> malloc; + callbacks.free = inits -> free; + } + + if (inits -> no_memory != NULL) + callbacks.no_memory = inits -> no_memory; + + return enet_initialize (); +} + +ENetVersion +enet_linked_version (void) +{ + return ENET_VERSION; +} + +void * +enet_malloc (size_t size) +{ + void * memory = callbacks.malloc (size); + + if (memory == NULL) + callbacks.no_memory (); + + return memory; +} + +void +enet_free (void * memory) +{ + callbacks.free (memory); +} + diff --git a/source/engine/thirdparty/enet/src/compress.c b/source/engine/thirdparty/enet/src/compress.c new file mode 100644 index 0000000..784489a --- /dev/null +++ b/source/engine/thirdparty/enet/src/compress.c @@ -0,0 +1,654 @@ +/** + @file compress.c + @brief An adaptive order-2 PPM range coder +*/ +#define ENET_BUILDING_LIB 1 +#include +#include "enet/enet.h" + +typedef struct _ENetSymbol +{ + /* binary indexed tree of symbols */ + enet_uint8 value; + enet_uint8 count; + enet_uint16 under; + enet_uint16 left, right; + + /* context defined by this symbol */ + enet_uint16 symbols; + enet_uint16 escapes; + enet_uint16 total; + enet_uint16 parent; +} ENetSymbol; + +/* adaptation constants tuned aggressively for small packet sizes rather than large file compression */ +enum +{ + ENET_RANGE_CODER_TOP = 1<<24, + ENET_RANGE_CODER_BOTTOM = 1<<16, + + ENET_CONTEXT_SYMBOL_DELTA = 3, + ENET_CONTEXT_SYMBOL_MINIMUM = 1, + ENET_CONTEXT_ESCAPE_MINIMUM = 1, + + ENET_SUBCONTEXT_ORDER = 2, + ENET_SUBCONTEXT_SYMBOL_DELTA = 2, + ENET_SUBCONTEXT_ESCAPE_DELTA = 5 +}; + +/* context exclusion roughly halves compression speed, so disable for now */ +#undef ENET_CONTEXT_EXCLUSION + +typedef struct _ENetRangeCoder +{ + /* only allocate enough symbols for reasonable MTUs, would need to be larger for large file compression */ + ENetSymbol symbols[4096]; +} ENetRangeCoder; + +void * +enet_range_coder_create (void) +{ + ENetRangeCoder * rangeCoder = (ENetRangeCoder *) enet_malloc (sizeof (ENetRangeCoder)); + if (rangeCoder == NULL) + return NULL; + + return rangeCoder; +} + +void +enet_range_coder_destroy (void * context) +{ + ENetRangeCoder * rangeCoder = (ENetRangeCoder *) context; + if (rangeCoder == NULL) + return; + + enet_free (rangeCoder); +} + +#define ENET_SYMBOL_CREATE(symbol, value_, count_) \ +{ \ + symbol = & rangeCoder -> symbols [nextSymbol ++]; \ + symbol -> value = value_; \ + symbol -> count = count_; \ + symbol -> under = count_; \ + symbol -> left = 0; \ + symbol -> right = 0; \ + symbol -> symbols = 0; \ + symbol -> escapes = 0; \ + symbol -> total = 0; \ + symbol -> parent = 0; \ +} + +#define ENET_CONTEXT_CREATE(context, escapes_, minimum) \ +{ \ + ENET_SYMBOL_CREATE (context, 0, 0); \ + (context) -> escapes = escapes_; \ + (context) -> total = escapes_ + 256*minimum; \ + (context) -> symbols = 0; \ +} + +static enet_uint16 +enet_symbol_rescale (ENetSymbol * symbol) +{ + enet_uint16 total = 0; + for (;;) + { + symbol -> count -= symbol->count >> 1; + symbol -> under = symbol -> count; + if (symbol -> left) + symbol -> under += enet_symbol_rescale (symbol + symbol -> left); + total += symbol -> under; + if (! symbol -> right) break; + symbol += symbol -> right; + } + return total; +} + +#define ENET_CONTEXT_RESCALE(context, minimum) \ +{ \ + (context) -> total = (context) -> symbols ? enet_symbol_rescale ((context) + (context) -> symbols) : 0; \ + (context) -> escapes -= (context) -> escapes >> 1; \ + (context) -> total += (context) -> escapes + 256*minimum; \ +} + +#define ENET_RANGE_CODER_OUTPUT(value) \ +{ \ + if (outData >= outEnd) \ + return 0; \ + * outData ++ = value; \ +} + +#define ENET_RANGE_CODER_ENCODE(under, count, total) \ +{ \ + encodeRange /= (total); \ + encodeLow += (under) * encodeRange; \ + encodeRange *= (count); \ + for (;;) \ + { \ + if((encodeLow ^ (encodeLow + encodeRange)) >= ENET_RANGE_CODER_TOP) \ + { \ + if(encodeRange >= ENET_RANGE_CODER_BOTTOM) break; \ + encodeRange = -encodeLow & (ENET_RANGE_CODER_BOTTOM - 1); \ + } \ + ENET_RANGE_CODER_OUTPUT (encodeLow >> 24); \ + encodeRange <<= 8; \ + encodeLow <<= 8; \ + } \ +} + +#define ENET_RANGE_CODER_FLUSH \ +{ \ + while (encodeLow) \ + { \ + ENET_RANGE_CODER_OUTPUT (encodeLow >> 24); \ + encodeLow <<= 8; \ + } \ +} + +#define ENET_RANGE_CODER_FREE_SYMBOLS \ +{ \ + if (nextSymbol >= sizeof (rangeCoder -> symbols) / sizeof (ENetSymbol) - ENET_SUBCONTEXT_ORDER ) \ + { \ + nextSymbol = 0; \ + ENET_CONTEXT_CREATE (root, ENET_CONTEXT_ESCAPE_MINIMUM, ENET_CONTEXT_SYMBOL_MINIMUM); \ + predicted = 0; \ + order = 0; \ + } \ +} + +#define ENET_CONTEXT_ENCODE(context, symbol_, value_, under_, count_, update, minimum) \ +{ \ + under_ = value*minimum; \ + count_ = minimum; \ + if (! (context) -> symbols) \ + { \ + ENET_SYMBOL_CREATE (symbol_, value_, update); \ + (context) -> symbols = symbol_ - (context); \ + } \ + else \ + { \ + ENetSymbol * node = (context) + (context) -> symbols; \ + for (;;) \ + { \ + if (value_ < node -> value) \ + { \ + node -> under += update; \ + if (node -> left) { node += node -> left; continue; } \ + ENET_SYMBOL_CREATE (symbol_, value_, update); \ + node -> left = symbol_ - node; \ + } \ + else \ + if (value_ > node -> value) \ + { \ + under_ += node -> under; \ + if (node -> right) { node += node -> right; continue; } \ + ENET_SYMBOL_CREATE (symbol_, value_, update); \ + node -> right = symbol_ - node; \ + } \ + else \ + { \ + count_ += node -> count; \ + under_ += node -> under - node -> count; \ + node -> under += update; \ + node -> count += update; \ + symbol_ = node; \ + } \ + break; \ + } \ + } \ +} + +#ifdef ENET_CONTEXT_EXCLUSION +static const ENetSymbol emptyContext = { 0, 0, 0, 0, 0, 0, 0, 0, 0 }; + +#define ENET_CONTEXT_WALK(context, body) \ +{ \ + const ENetSymbol * node = (context) + (context) -> symbols; \ + const ENetSymbol * stack [256]; \ + size_t stackSize = 0; \ + while (node -> left) \ + { \ + stack [stackSize ++] = node; \ + node += node -> left; \ + } \ + for (;;) \ + { \ + body; \ + if (node -> right) \ + { \ + node += node -> right; \ + while (node -> left) \ + { \ + stack [stackSize ++] = node; \ + node += node -> left; \ + } \ + } \ + else \ + if (stackSize <= 0) \ + break; \ + else \ + node = stack [-- stackSize]; \ + } \ +} + +#define ENET_CONTEXT_ENCODE_EXCLUDE(context, value_, under, total, minimum) \ +ENET_CONTEXT_WALK(context, { \ + if (node -> value != value_) \ + { \ + enet_uint16 parentCount = rangeCoder -> symbols [node -> parent].count + minimum; \ + if (node -> value < value_) \ + under -= parentCount; \ + total -= parentCount; \ + } \ +}) +#endif + +size_t +enet_range_coder_compress (void * context, const ENetBuffer * inBuffers, size_t inBufferCount, size_t inLimit, enet_uint8 * outData, size_t outLimit) +{ + ENetRangeCoder * rangeCoder = (ENetRangeCoder *) context; + enet_uint8 * outStart = outData, * outEnd = & outData [outLimit]; + const enet_uint8 * inData, * inEnd; + enet_uint32 encodeLow = 0, encodeRange = ~0; + ENetSymbol * root; + enet_uint16 predicted = 0; + size_t order = 0, nextSymbol = 0; + + if (rangeCoder == NULL || inBufferCount <= 0 || inLimit <= 0) + return 0; + + inData = (const enet_uint8 *) inBuffers -> data; + inEnd = & inData [inBuffers -> dataLength]; + inBuffers ++; + inBufferCount --; + + ENET_CONTEXT_CREATE (root, ENET_CONTEXT_ESCAPE_MINIMUM, ENET_CONTEXT_SYMBOL_MINIMUM); + + for (;;) + { + ENetSymbol * subcontext, * symbol; +#ifdef ENET_CONTEXT_EXCLUSION + const ENetSymbol * childContext = & emptyContext; +#endif + enet_uint8 value; + enet_uint16 count, under, * parent = & predicted, total; + if (inData >= inEnd) + { + if (inBufferCount <= 0) + break; + inData = (const enet_uint8 *) inBuffers -> data; + inEnd = & inData [inBuffers -> dataLength]; + inBuffers ++; + inBufferCount --; + } + value = * inData ++; + + for (subcontext = & rangeCoder -> symbols [predicted]; + subcontext != root; +#ifdef ENET_CONTEXT_EXCLUSION + childContext = subcontext, +#endif + subcontext = & rangeCoder -> symbols [subcontext -> parent]) + { + ENET_CONTEXT_ENCODE (subcontext, symbol, value, under, count, ENET_SUBCONTEXT_SYMBOL_DELTA, 0); + * parent = symbol - rangeCoder -> symbols; + parent = & symbol -> parent; + total = subcontext -> total; +#ifdef ENET_CONTEXT_EXCLUSION + if (childContext -> total > ENET_SUBCONTEXT_SYMBOL_DELTA + ENET_SUBCONTEXT_ESCAPE_DELTA) + ENET_CONTEXT_ENCODE_EXCLUDE (childContext, value, under, total, 0); +#endif + if (count > 0) + { + ENET_RANGE_CODER_ENCODE (subcontext -> escapes + under, count, total); + } + else + { + if (subcontext -> escapes > 0 && subcontext -> escapes < total) + ENET_RANGE_CODER_ENCODE (0, subcontext -> escapes, total); + subcontext -> escapes += ENET_SUBCONTEXT_ESCAPE_DELTA; + subcontext -> total += ENET_SUBCONTEXT_ESCAPE_DELTA; + } + subcontext -> total += ENET_SUBCONTEXT_SYMBOL_DELTA; + if (count > 0xFF - 2*ENET_SUBCONTEXT_SYMBOL_DELTA || subcontext -> total > ENET_RANGE_CODER_BOTTOM - 0x100) + ENET_CONTEXT_RESCALE (subcontext, 0); + if (count > 0) goto nextInput; + } + + ENET_CONTEXT_ENCODE (root, symbol, value, under, count, ENET_CONTEXT_SYMBOL_DELTA, ENET_CONTEXT_SYMBOL_MINIMUM); + * parent = symbol - rangeCoder -> symbols; + parent = & symbol -> parent; + total = root -> total; +#ifdef ENET_CONTEXT_EXCLUSION + if (childContext -> total > ENET_SUBCONTEXT_SYMBOL_DELTA + ENET_SUBCONTEXT_ESCAPE_DELTA) + ENET_CONTEXT_ENCODE_EXCLUDE (childContext, value, under, total, ENET_CONTEXT_SYMBOL_MINIMUM); +#endif + ENET_RANGE_CODER_ENCODE (root -> escapes + under, count, total); + root -> total += ENET_CONTEXT_SYMBOL_DELTA; + if (count > 0xFF - 2*ENET_CONTEXT_SYMBOL_DELTA + ENET_CONTEXT_SYMBOL_MINIMUM || root -> total > ENET_RANGE_CODER_BOTTOM - 0x100) + ENET_CONTEXT_RESCALE (root, ENET_CONTEXT_SYMBOL_MINIMUM); + + nextInput: + if (order >= ENET_SUBCONTEXT_ORDER) + predicted = rangeCoder -> symbols [predicted].parent; + else + order ++; + ENET_RANGE_CODER_FREE_SYMBOLS; + } + + ENET_RANGE_CODER_FLUSH; + + return (size_t) (outData - outStart); +} + +#define ENET_RANGE_CODER_SEED \ +{ \ + if (inData < inEnd) decodeCode |= * inData ++ << 24; \ + if (inData < inEnd) decodeCode |= * inData ++ << 16; \ + if (inData < inEnd) decodeCode |= * inData ++ << 8; \ + if (inData < inEnd) decodeCode |= * inData ++; \ +} + +#define ENET_RANGE_CODER_READ(total) ((decodeCode - decodeLow) / (decodeRange /= (total))) + +#define ENET_RANGE_CODER_DECODE(under, count, total) \ +{ \ + decodeLow += (under) * decodeRange; \ + decodeRange *= (count); \ + for (;;) \ + { \ + if((decodeLow ^ (decodeLow + decodeRange)) >= ENET_RANGE_CODER_TOP) \ + { \ + if(decodeRange >= ENET_RANGE_CODER_BOTTOM) break; \ + decodeRange = -decodeLow & (ENET_RANGE_CODER_BOTTOM - 1); \ + } \ + decodeCode <<= 8; \ + if (inData < inEnd) \ + decodeCode |= * inData ++; \ + decodeRange <<= 8; \ + decodeLow <<= 8; \ + } \ +} + +#define ENET_CONTEXT_DECODE(context, symbol_, code, value_, under_, count_, update, minimum, createRoot, visitNode, createRight, createLeft) \ +{ \ + under_ = 0; \ + count_ = minimum; \ + if (! (context) -> symbols) \ + { \ + createRoot; \ + } \ + else \ + { \ + ENetSymbol * node = (context) + (context) -> symbols; \ + for (;;) \ + { \ + enet_uint16 after = under_ + node -> under + (node -> value + 1)*minimum, before = node -> count + minimum; \ + visitNode; \ + if (code >= after) \ + { \ + under_ += node -> under; \ + if (node -> right) { node += node -> right; continue; } \ + createRight; \ + } \ + else \ + if (code < after - before) \ + { \ + node -> under += update; \ + if (node -> left) { node += node -> left; continue; } \ + createLeft; \ + } \ + else \ + { \ + value_ = node -> value; \ + count_ += node -> count; \ + under_ = after - before; \ + node -> under += update; \ + node -> count += update; \ + symbol_ = node; \ + } \ + break; \ + } \ + } \ +} + +#define ENET_CONTEXT_TRY_DECODE(context, symbol_, code, value_, under_, count_, update, minimum, exclude) \ +ENET_CONTEXT_DECODE (context, symbol_, code, value_, under_, count_, update, minimum, return 0, exclude (node -> value, after, before), return 0, return 0) + +#define ENET_CONTEXT_ROOT_DECODE(context, symbol_, code, value_, under_, count_, update, minimum, exclude) \ +ENET_CONTEXT_DECODE (context, symbol_, code, value_, under_, count_, update, minimum, \ + { \ + value_ = code / minimum; \ + under_ = code - code%minimum; \ + ENET_SYMBOL_CREATE (symbol_, value_, update); \ + (context) -> symbols = symbol_ - (context); \ + }, \ + exclude (node -> value, after, before), \ + { \ + value_ = node->value + 1 + (code - after)/minimum; \ + under_ = code - (code - after)%minimum; \ + ENET_SYMBOL_CREATE (symbol_, value_, update); \ + node -> right = symbol_ - node; \ + }, \ + { \ + value_ = node->value - 1 - (after - before - code - 1)/minimum; \ + under_ = code - (after - before - code - 1)%minimum; \ + ENET_SYMBOL_CREATE (symbol_, value_, update); \ + node -> left = symbol_ - node; \ + }) \ + +#ifdef ENET_CONTEXT_EXCLUSION +typedef struct _ENetExclude +{ + enet_uint8 value; + enet_uint16 under; +} ENetExclude; + +#define ENET_CONTEXT_DECODE_EXCLUDE(context, total, minimum) \ +{ \ + enet_uint16 under = 0; \ + nextExclude = excludes; \ + ENET_CONTEXT_WALK (context, { \ + under += rangeCoder -> symbols [node -> parent].count + minimum; \ + nextExclude -> value = node -> value; \ + nextExclude -> under = under; \ + nextExclude ++; \ + }); \ + total -= under; \ +} + +#define ENET_CONTEXT_EXCLUDED(value_, after, before) \ +{ \ + size_t low = 0, high = nextExclude - excludes; \ + for(;;) \ + { \ + size_t mid = (low + high) >> 1; \ + const ENetExclude * exclude = & excludes [mid]; \ + if (value_ < exclude -> value) \ + { \ + if (low + 1 < high) \ + { \ + high = mid; \ + continue; \ + } \ + if (exclude > excludes) \ + after -= exclude [-1].under; \ + } \ + else \ + { \ + if (value_ > exclude -> value) \ + { \ + if (low + 1 < high) \ + { \ + low = mid; \ + continue; \ + } \ + } \ + else \ + before = 0; \ + after -= exclude -> under; \ + } \ + break; \ + } \ +} +#endif + +#define ENET_CONTEXT_NOT_EXCLUDED(value_, after, before) + +size_t +enet_range_coder_decompress (void * context, const enet_uint8 * inData, size_t inLimit, enet_uint8 * outData, size_t outLimit) +{ + ENetRangeCoder * rangeCoder = (ENetRangeCoder *) context; + enet_uint8 * outStart = outData, * outEnd = & outData [outLimit]; + const enet_uint8 * inEnd = & inData [inLimit]; + enet_uint32 decodeLow = 0, decodeCode = 0, decodeRange = ~0; + ENetSymbol * root; + enet_uint16 predicted = 0; + size_t order = 0, nextSymbol = 0; +#ifdef ENET_CONTEXT_EXCLUSION + ENetExclude excludes [256]; + ENetExclude * nextExclude = excludes; +#endif + + if (rangeCoder == NULL || inLimit <= 0) + return 0; + + ENET_CONTEXT_CREATE (root, ENET_CONTEXT_ESCAPE_MINIMUM, ENET_CONTEXT_SYMBOL_MINIMUM); + + ENET_RANGE_CODER_SEED; + + for (;;) + { + ENetSymbol * subcontext, * symbol, * patch; +#ifdef ENET_CONTEXT_EXCLUSION + const ENetSymbol * childContext = & emptyContext; +#endif + enet_uint8 value = 0; + enet_uint16 code, under, count, bottom, * parent = & predicted, total; + + for (subcontext = & rangeCoder -> symbols [predicted]; + subcontext != root; +#ifdef ENET_CONTEXT_EXCLUSION + childContext = subcontext, +#endif + subcontext = & rangeCoder -> symbols [subcontext -> parent]) + { + if (subcontext -> escapes <= 0) + continue; + total = subcontext -> total; +#ifdef ENET_CONTEXT_EXCLUSION + if (childContext -> total > 0) + ENET_CONTEXT_DECODE_EXCLUDE (childContext, total, 0); +#endif + if (subcontext -> escapes >= total) + continue; + code = ENET_RANGE_CODER_READ (total); + if (code < subcontext -> escapes) + { + ENET_RANGE_CODER_DECODE (0, subcontext -> escapes, total); + continue; + } + code -= subcontext -> escapes; +#ifdef ENET_CONTEXT_EXCLUSION + if (childContext -> total > 0) + { + ENET_CONTEXT_TRY_DECODE (subcontext, symbol, code, value, under, count, ENET_SUBCONTEXT_SYMBOL_DELTA, 0, ENET_CONTEXT_EXCLUDED); + } + else +#endif + { + ENET_CONTEXT_TRY_DECODE (subcontext, symbol, code, value, under, count, ENET_SUBCONTEXT_SYMBOL_DELTA, 0, ENET_CONTEXT_NOT_EXCLUDED); + } + bottom = symbol - rangeCoder -> symbols; + ENET_RANGE_CODER_DECODE (subcontext -> escapes + under, count, total); + subcontext -> total += ENET_SUBCONTEXT_SYMBOL_DELTA; + if (count > 0xFF - 2*ENET_SUBCONTEXT_SYMBOL_DELTA || subcontext -> total > ENET_RANGE_CODER_BOTTOM - 0x100) + ENET_CONTEXT_RESCALE (subcontext, 0); + goto patchContexts; + } + + total = root -> total; +#ifdef ENET_CONTEXT_EXCLUSION + if (childContext -> total > 0) + ENET_CONTEXT_DECODE_EXCLUDE (childContext, total, ENET_CONTEXT_SYMBOL_MINIMUM); +#endif + code = ENET_RANGE_CODER_READ (total); + if (code < root -> escapes) + { + ENET_RANGE_CODER_DECODE (0, root -> escapes, total); + break; + } + code -= root -> escapes; +#ifdef ENET_CONTEXT_EXCLUSION + if (childContext -> total > 0) + { + ENET_CONTEXT_ROOT_DECODE (root, symbol, code, value, under, count, ENET_CONTEXT_SYMBOL_DELTA, ENET_CONTEXT_SYMBOL_MINIMUM, ENET_CONTEXT_EXCLUDED); + } + else +#endif + { + ENET_CONTEXT_ROOT_DECODE (root, symbol, code, value, under, count, ENET_CONTEXT_SYMBOL_DELTA, ENET_CONTEXT_SYMBOL_MINIMUM, ENET_CONTEXT_NOT_EXCLUDED); + } + bottom = symbol - rangeCoder -> symbols; + ENET_RANGE_CODER_DECODE (root -> escapes + under, count, total); + root -> total += ENET_CONTEXT_SYMBOL_DELTA; + if (count > 0xFF - 2*ENET_CONTEXT_SYMBOL_DELTA + ENET_CONTEXT_SYMBOL_MINIMUM || root -> total > ENET_RANGE_CODER_BOTTOM - 0x100) + ENET_CONTEXT_RESCALE (root, ENET_CONTEXT_SYMBOL_MINIMUM); + + patchContexts: + for (patch = & rangeCoder -> symbols [predicted]; + patch != subcontext; + patch = & rangeCoder -> symbols [patch -> parent]) + { + ENET_CONTEXT_ENCODE (patch, symbol, value, under, count, ENET_SUBCONTEXT_SYMBOL_DELTA, 0); + * parent = symbol - rangeCoder -> symbols; + parent = & symbol -> parent; + if (count <= 0) + { + patch -> escapes += ENET_SUBCONTEXT_ESCAPE_DELTA; + patch -> total += ENET_SUBCONTEXT_ESCAPE_DELTA; + } + patch -> total += ENET_SUBCONTEXT_SYMBOL_DELTA; + if (count > 0xFF - 2*ENET_SUBCONTEXT_SYMBOL_DELTA || patch -> total > ENET_RANGE_CODER_BOTTOM - 0x100) + ENET_CONTEXT_RESCALE (patch, 0); + } + * parent = bottom; + + ENET_RANGE_CODER_OUTPUT (value); + + if (order >= ENET_SUBCONTEXT_ORDER) + predicted = rangeCoder -> symbols [predicted].parent; + else + order ++; + ENET_RANGE_CODER_FREE_SYMBOLS; + } + + return (size_t) (outData - outStart); +} + +/** @defgroup host ENet host functions + @{ +*/ + +/** Sets the packet compressor the host should use to the default range coder. + @param host host to enable the range coder for + @returns 0 on success, < 0 on failure +*/ +int +enet_host_compress_with_range_coder (ENetHost * host) +{ + ENetCompressor compressor; + memset (& compressor, 0, sizeof (compressor)); + compressor.context = enet_range_coder_create(); + if (compressor.context == NULL) + return -1; + compressor.compress = enet_range_coder_compress; + compressor.decompress = enet_range_coder_decompress; + compressor.destroy = enet_range_coder_destroy; + enet_host_compress (host, & compressor); + return 0; +} + +/** @} */ + + diff --git a/source/engine/thirdparty/enet/src/host.c b/source/engine/thirdparty/enet/src/host.c new file mode 100644 index 0000000..ed0c0eb --- /dev/null +++ b/source/engine/thirdparty/enet/src/host.c @@ -0,0 +1,501 @@ +/** + @file host.c + @brief ENet host management functions +*/ +#define ENET_BUILDING_LIB 1 +#include +#include "enet/enet.h" + +/** @defgroup host ENet host functions + @{ +*/ + +/** Creates a host for communicating to peers. + + @param address the address at which other peers may connect to this host. If NULL, then no peers may connect to the host. + @param peerCount the maximum number of peers that should be allocated for the host. + @param channelLimit the maximum number of channels allowed; if 0, then this is equivalent to ENET_PROTOCOL_MAXIMUM_CHANNEL_COUNT + @param incomingBandwidth downstream bandwidth of the host in bytes/second; if 0, ENet will assume unlimited bandwidth. + @param outgoingBandwidth upstream bandwidth of the host in bytes/second; if 0, ENet will assume unlimited bandwidth. + + @returns the host on success and NULL on failure + + @remarks ENet will strategically drop packets on specific sides of a connection between hosts + to ensure the host's bandwidth is not overwhelmed. The bandwidth parameters also determine + the window size of a connection which limits the amount of reliable packets that may be in transit + at any given time. +*/ +ENetHost * +enet_host_create (const ENetAddress * address, size_t peerCount, size_t channelLimit, enet_uint32 incomingBandwidth, enet_uint32 outgoingBandwidth) +{ + ENetHost * host; + ENetPeer * currentPeer; + + if (peerCount > ENET_PROTOCOL_MAXIMUM_PEER_ID) + return NULL; + + host = (ENetHost *) enet_malloc (sizeof (ENetHost)); + if (host == NULL) + return NULL; + memset (host, 0, sizeof (ENetHost)); + + host -> peers = (ENetPeer *) enet_malloc (peerCount * sizeof (ENetPeer)); + if (host -> peers == NULL) + { + enet_free (host); + + return NULL; + } + memset (host -> peers, 0, peerCount * sizeof (ENetPeer)); + + host -> socket = enet_socket_create (ENET_SOCKET_TYPE_DATAGRAM); + if (host -> socket == ENET_SOCKET_NULL || (address != NULL && enet_socket_bind (host -> socket, address) < 0)) + { + if (host -> socket != ENET_SOCKET_NULL) + enet_socket_destroy (host -> socket); + + enet_free (host -> peers); + enet_free (host); + + return NULL; + } + + enet_socket_set_option (host -> socket, ENET_SOCKOPT_NONBLOCK, 1); + enet_socket_set_option (host -> socket, ENET_SOCKOPT_BROADCAST, 1); + enet_socket_set_option (host -> socket, ENET_SOCKOPT_RCVBUF, ENET_HOST_RECEIVE_BUFFER_SIZE); + enet_socket_set_option (host -> socket, ENET_SOCKOPT_SNDBUF, ENET_HOST_SEND_BUFFER_SIZE); + + if (address != NULL && enet_socket_get_address (host -> socket, & host -> address) < 0) + host -> address = * address; + + if (! channelLimit || channelLimit > ENET_PROTOCOL_MAXIMUM_CHANNEL_COUNT) + channelLimit = ENET_PROTOCOL_MAXIMUM_CHANNEL_COUNT; + else + if (channelLimit < ENET_PROTOCOL_MINIMUM_CHANNEL_COUNT) + channelLimit = ENET_PROTOCOL_MINIMUM_CHANNEL_COUNT; + + host -> randomSeed = (enet_uint32) (size_t) host; + host -> randomSeed += enet_host_random_seed (); + host -> randomSeed = (host -> randomSeed << 16) | (host -> randomSeed >> 16); + host -> channelLimit = channelLimit; + host -> incomingBandwidth = incomingBandwidth; + host -> outgoingBandwidth = outgoingBandwidth; + host -> bandwidthThrottleEpoch = 0; + host -> recalculateBandwidthLimits = 0; + host -> mtu = ENET_HOST_DEFAULT_MTU; + host -> peerCount = peerCount; + host -> commandCount = 0; + host -> bufferCount = 0; + host -> checksum = NULL; + host -> receivedAddress.host = ENET_HOST_ANY; + host -> receivedAddress.port = 0; + host -> receivedData = NULL; + host -> receivedDataLength = 0; + + host -> totalSentData = 0; + host -> totalSentPackets = 0; + host -> totalReceivedData = 0; + host -> totalReceivedPackets = 0; + + host -> connectedPeers = 0; + host -> bandwidthLimitedPeers = 0; + host -> duplicatePeers = ENET_PROTOCOL_MAXIMUM_PEER_ID; + host -> maximumPacketSize = ENET_HOST_DEFAULT_MAXIMUM_PACKET_SIZE; + host -> maximumWaitingData = ENET_HOST_DEFAULT_MAXIMUM_WAITING_DATA; + + host -> compressor.context = NULL; + host -> compressor.compress = NULL; + host -> compressor.decompress = NULL; + host -> compressor.destroy = NULL; + + host -> intercept = NULL; + + enet_list_clear (& host -> dispatchQueue); + + for (currentPeer = host -> peers; + currentPeer < & host -> peers [host -> peerCount]; + ++ currentPeer) + { + currentPeer -> host = host; + currentPeer -> incomingPeerID = currentPeer - host -> peers; + currentPeer -> outgoingSessionID = currentPeer -> incomingSessionID = 0xFF; + currentPeer -> data = NULL; + + enet_list_clear (& currentPeer -> acknowledgements); + enet_list_clear (& currentPeer -> sentReliableCommands); + enet_list_clear (& currentPeer -> sentUnreliableCommands); + enet_list_clear (& currentPeer -> outgoingCommands); + enet_list_clear (& currentPeer -> dispatchedCommands); + + enet_peer_reset (currentPeer); + } + + return host; +} + +/** Destroys the host and all resources associated with it. + @param host pointer to the host to destroy +*/ +void +enet_host_destroy (ENetHost * host) +{ + ENetPeer * currentPeer; + + if (host == NULL) + return; + + enet_socket_destroy (host -> socket); + + for (currentPeer = host -> peers; + currentPeer < & host -> peers [host -> peerCount]; + ++ currentPeer) + { + enet_peer_reset (currentPeer); + } + + if (host -> compressor.context != NULL && host -> compressor.destroy) + (* host -> compressor.destroy) (host -> compressor.context); + + enet_free (host -> peers); + enet_free (host); +} + +enet_uint32 +enet_host_random (ENetHost * host) +{ + /* Mulberry32 by Tommy Ettinger */ + enet_uint32 n = (host -> randomSeed += 0x6D2B79F5U); + n = (n ^ (n >> 15)) * (n | 1U); + n ^= n + (n ^ (n >> 7)) * (n | 61U); + return n ^ (n >> 14); +} + +/** Initiates a connection to a foreign host. + @param host host seeking the connection + @param address destination for the connection + @param channelCount number of channels to allocate + @param data user data supplied to the receiving host + @returns a peer representing the foreign host on success, NULL on failure + @remarks The peer returned will have not completed the connection until enet_host_service() + notifies of an ENET_EVENT_TYPE_CONNECT event for the peer. +*/ +ENetPeer * +enet_host_connect (ENetHost * host, const ENetAddress * address, size_t channelCount, enet_uint32 data) +{ + ENetPeer * currentPeer; + ENetChannel * channel; + ENetProtocol command; + + if (channelCount < ENET_PROTOCOL_MINIMUM_CHANNEL_COUNT) + channelCount = ENET_PROTOCOL_MINIMUM_CHANNEL_COUNT; + else + if (channelCount > ENET_PROTOCOL_MAXIMUM_CHANNEL_COUNT) + channelCount = ENET_PROTOCOL_MAXIMUM_CHANNEL_COUNT; + + for (currentPeer = host -> peers; + currentPeer < & host -> peers [host -> peerCount]; + ++ currentPeer) + { + if (currentPeer -> state == ENET_PEER_STATE_DISCONNECTED) + break; + } + + if (currentPeer >= & host -> peers [host -> peerCount]) + return NULL; + + currentPeer -> channels = (ENetChannel *) enet_malloc (channelCount * sizeof (ENetChannel)); + if (currentPeer -> channels == NULL) + return NULL; + currentPeer -> channelCount = channelCount; + currentPeer -> state = ENET_PEER_STATE_CONNECTING; + currentPeer -> address = * address; + currentPeer -> connectID = enet_host_random (host); + + if (host -> outgoingBandwidth == 0) + currentPeer -> windowSize = ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE; + else + currentPeer -> windowSize = (host -> outgoingBandwidth / + ENET_PEER_WINDOW_SIZE_SCALE) * + ENET_PROTOCOL_MINIMUM_WINDOW_SIZE; + + if (currentPeer -> windowSize < ENET_PROTOCOL_MINIMUM_WINDOW_SIZE) + currentPeer -> windowSize = ENET_PROTOCOL_MINIMUM_WINDOW_SIZE; + else + if (currentPeer -> windowSize > ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE) + currentPeer -> windowSize = ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE; + + for (channel = currentPeer -> channels; + channel < & currentPeer -> channels [channelCount]; + ++ channel) + { + channel -> outgoingReliableSequenceNumber = 0; + channel -> outgoingUnreliableSequenceNumber = 0; + channel -> incomingReliableSequenceNumber = 0; + channel -> incomingUnreliableSequenceNumber = 0; + + enet_list_clear (& channel -> incomingReliableCommands); + enet_list_clear (& channel -> incomingUnreliableCommands); + + channel -> usedReliableWindows = 0; + memset (channel -> reliableWindows, 0, sizeof (channel -> reliableWindows)); + } + + command.header.command = ENET_PROTOCOL_COMMAND_CONNECT | ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE; + command.header.channelID = 0xFF; + command.connect.outgoingPeerID = ENET_HOST_TO_NET_16 (currentPeer -> incomingPeerID); + command.connect.incomingSessionID = currentPeer -> incomingSessionID; + command.connect.outgoingSessionID = currentPeer -> outgoingSessionID; + command.connect.mtu = ENET_HOST_TO_NET_32 (currentPeer -> mtu); + command.connect.windowSize = ENET_HOST_TO_NET_32 (currentPeer -> windowSize); + command.connect.channelCount = ENET_HOST_TO_NET_32 (channelCount); + command.connect.incomingBandwidth = ENET_HOST_TO_NET_32 (host -> incomingBandwidth); + command.connect.outgoingBandwidth = ENET_HOST_TO_NET_32 (host -> outgoingBandwidth); + command.connect.packetThrottleInterval = ENET_HOST_TO_NET_32 (currentPeer -> packetThrottleInterval); + command.connect.packetThrottleAcceleration = ENET_HOST_TO_NET_32 (currentPeer -> packetThrottleAcceleration); + command.connect.packetThrottleDeceleration = ENET_HOST_TO_NET_32 (currentPeer -> packetThrottleDeceleration); + command.connect.connectID = currentPeer -> connectID; + command.connect.data = ENET_HOST_TO_NET_32 (data); + + enet_peer_queue_outgoing_command (currentPeer, & command, NULL, 0, 0); + + return currentPeer; +} + +/** Queues a packet to be sent to all peers associated with the host. + @param host host on which to broadcast the packet + @param channelID channel on which to broadcast + @param packet packet to broadcast +*/ +void +enet_host_broadcast (ENetHost * host, enet_uint8 channelID, ENetPacket * packet) +{ + ENetPeer * currentPeer; + + for (currentPeer = host -> peers; + currentPeer < & host -> peers [host -> peerCount]; + ++ currentPeer) + { + if (currentPeer -> state != ENET_PEER_STATE_CONNECTED) + continue; + + enet_peer_send (currentPeer, channelID, packet); + } + + if (packet -> referenceCount == 0) + enet_packet_destroy (packet); +} + +/** Sets the packet compressor the host should use to compress and decompress packets. + @param host host to enable or disable compression for + @param compressor callbacks for for the packet compressor; if NULL, then compression is disabled +*/ +void +enet_host_compress (ENetHost * host, const ENetCompressor * compressor) +{ + if (host -> compressor.context != NULL && host -> compressor.destroy) + (* host -> compressor.destroy) (host -> compressor.context); + + if (compressor) + host -> compressor = * compressor; + else + host -> compressor.context = NULL; +} + +/** Limits the maximum allowed channels of future incoming connections. + @param host host to limit + @param channelLimit the maximum number of channels allowed; if 0, then this is equivalent to ENET_PROTOCOL_MAXIMUM_CHANNEL_COUNT +*/ +void +enet_host_channel_limit (ENetHost * host, size_t channelLimit) +{ + if (! channelLimit || channelLimit > ENET_PROTOCOL_MAXIMUM_CHANNEL_COUNT) + channelLimit = ENET_PROTOCOL_MAXIMUM_CHANNEL_COUNT; + else + if (channelLimit < ENET_PROTOCOL_MINIMUM_CHANNEL_COUNT) + channelLimit = ENET_PROTOCOL_MINIMUM_CHANNEL_COUNT; + + host -> channelLimit = channelLimit; +} + + +/** Adjusts the bandwidth limits of a host. + @param host host to adjust + @param incomingBandwidth new incoming bandwidth + @param outgoingBandwidth new outgoing bandwidth + @remarks the incoming and outgoing bandwidth parameters are identical in function to those + specified in enet_host_create(). +*/ +void +enet_host_bandwidth_limit (ENetHost * host, enet_uint32 incomingBandwidth, enet_uint32 outgoingBandwidth) +{ + host -> incomingBandwidth = incomingBandwidth; + host -> outgoingBandwidth = outgoingBandwidth; + host -> recalculateBandwidthLimits = 1; +} + +void +enet_host_bandwidth_throttle (ENetHost * host) +{ + enet_uint32 timeCurrent = enet_time_get (), + elapsedTime = timeCurrent - host -> bandwidthThrottleEpoch, + peersRemaining = (enet_uint32) host -> connectedPeers, + dataTotal = ~0, + bandwidth = ~0, + throttle = 0, + bandwidthLimit = 0; + int needsAdjustment = host -> bandwidthLimitedPeers > 0 ? 1 : 0; + ENetPeer * peer; + ENetProtocol command; + + if (elapsedTime < ENET_HOST_BANDWIDTH_THROTTLE_INTERVAL) + return; + + host -> bandwidthThrottleEpoch = timeCurrent; + + if (peersRemaining == 0) + return; + + if (host -> outgoingBandwidth != 0) + { + dataTotal = 0; + bandwidth = (host -> outgoingBandwidth * elapsedTime) / 1000; + + for (peer = host -> peers; + peer < & host -> peers [host -> peerCount]; + ++ peer) + { + if (peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER) + continue; + + dataTotal += peer -> outgoingDataTotal; + } + } + + while (peersRemaining > 0 && needsAdjustment != 0) + { + needsAdjustment = 0; + + if (dataTotal <= bandwidth) + throttle = ENET_PEER_PACKET_THROTTLE_SCALE; + else + throttle = (bandwidth * ENET_PEER_PACKET_THROTTLE_SCALE) / dataTotal; + + for (peer = host -> peers; + peer < & host -> peers [host -> peerCount]; + ++ peer) + { + enet_uint32 peerBandwidth; + + if ((peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER) || + peer -> incomingBandwidth == 0 || + peer -> outgoingBandwidthThrottleEpoch == timeCurrent) + continue; + + peerBandwidth = (peer -> incomingBandwidth * elapsedTime) / 1000; + if ((throttle * peer -> outgoingDataTotal) / ENET_PEER_PACKET_THROTTLE_SCALE <= peerBandwidth) + continue; + + peer -> packetThrottleLimit = (peerBandwidth * + ENET_PEER_PACKET_THROTTLE_SCALE) / peer -> outgoingDataTotal; + + if (peer -> packetThrottleLimit == 0) + peer -> packetThrottleLimit = 1; + + if (peer -> packetThrottle > peer -> packetThrottleLimit) + peer -> packetThrottle = peer -> packetThrottleLimit; + + peer -> outgoingBandwidthThrottleEpoch = timeCurrent; + + peer -> incomingDataTotal = 0; + peer -> outgoingDataTotal = 0; + + needsAdjustment = 1; + -- peersRemaining; + bandwidth -= peerBandwidth; + dataTotal -= peerBandwidth; + } + } + + if (peersRemaining > 0) + { + if (dataTotal <= bandwidth) + throttle = ENET_PEER_PACKET_THROTTLE_SCALE; + else + throttle = (bandwidth * ENET_PEER_PACKET_THROTTLE_SCALE) / dataTotal; + + for (peer = host -> peers; + peer < & host -> peers [host -> peerCount]; + ++ peer) + { + if ((peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER) || + peer -> outgoingBandwidthThrottleEpoch == timeCurrent) + continue; + + peer -> packetThrottleLimit = throttle; + + if (peer -> packetThrottle > peer -> packetThrottleLimit) + peer -> packetThrottle = peer -> packetThrottleLimit; + + peer -> incomingDataTotal = 0; + peer -> outgoingDataTotal = 0; + } + } + + if (host -> recalculateBandwidthLimits) + { + host -> recalculateBandwidthLimits = 0; + + peersRemaining = (enet_uint32) host -> connectedPeers; + bandwidth = host -> incomingBandwidth; + needsAdjustment = 1; + + if (bandwidth == 0) + bandwidthLimit = 0; + else + while (peersRemaining > 0 && needsAdjustment != 0) + { + needsAdjustment = 0; + bandwidthLimit = bandwidth / peersRemaining; + + for (peer = host -> peers; + peer < & host -> peers [host -> peerCount]; + ++ peer) + { + if ((peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER) || + peer -> incomingBandwidthThrottleEpoch == timeCurrent) + continue; + + if (peer -> outgoingBandwidth > 0 && + peer -> outgoingBandwidth >= bandwidthLimit) + continue; + + peer -> incomingBandwidthThrottleEpoch = timeCurrent; + + needsAdjustment = 1; + -- peersRemaining; + bandwidth -= peer -> outgoingBandwidth; + } + } + + for (peer = host -> peers; + peer < & host -> peers [host -> peerCount]; + ++ peer) + { + if (peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER) + continue; + + command.header.command = ENET_PROTOCOL_COMMAND_BANDWIDTH_LIMIT | ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE; + command.header.channelID = 0xFF; + command.bandwidthLimit.outgoingBandwidth = ENET_HOST_TO_NET_32 (host -> outgoingBandwidth); + + if (peer -> incomingBandwidthThrottleEpoch == timeCurrent) + command.bandwidthLimit.incomingBandwidth = ENET_HOST_TO_NET_32 (peer -> outgoingBandwidth); + else + command.bandwidthLimit.incomingBandwidth = ENET_HOST_TO_NET_32 (bandwidthLimit); + + enet_peer_queue_outgoing_command (peer, & command, NULL, 0, 0); + } + } +} + +/** @} */ diff --git a/source/engine/thirdparty/enet/src/list.c b/source/engine/thirdparty/enet/src/list.c new file mode 100644 index 0000000..1c1a8df --- /dev/null +++ b/source/engine/thirdparty/enet/src/list.c @@ -0,0 +1,75 @@ +/** + @file list.c + @brief ENet linked list functions +*/ +#define ENET_BUILDING_LIB 1 +#include "enet/enet.h" + +/** + @defgroup list ENet linked list utility functions + @ingroup private + @{ +*/ +void +enet_list_clear (ENetList * list) +{ + list -> sentinel.next = & list -> sentinel; + list -> sentinel.previous = & list -> sentinel; +} + +ENetListIterator +enet_list_insert (ENetListIterator position, void * data) +{ + ENetListIterator result = (ENetListIterator) data; + + result -> previous = position -> previous; + result -> next = position; + + result -> previous -> next = result; + position -> previous = result; + + return result; +} + +void * +enet_list_remove (ENetListIterator position) +{ + position -> previous -> next = position -> next; + position -> next -> previous = position -> previous; + + return position; +} + +ENetListIterator +enet_list_move (ENetListIterator position, void * dataFirst, void * dataLast) +{ + ENetListIterator first = (ENetListIterator) dataFirst, + last = (ENetListIterator) dataLast; + + first -> previous -> next = last -> next; + last -> next -> previous = first -> previous; + + first -> previous = position -> previous; + last -> next = position; + + first -> previous -> next = first; + position -> previous = last; + + return first; +} + +size_t +enet_list_size (ENetList * list) +{ + size_t size = 0; + ENetListIterator position; + + for (position = enet_list_begin (list); + position != enet_list_end (list); + position = enet_list_next (position)) + ++ size; + + return size; +} + +/** @} */ diff --git a/source/engine/thirdparty/enet/src/packet.c b/source/engine/thirdparty/enet/src/packet.c new file mode 100644 index 0000000..5fa78b2 --- /dev/null +++ b/source/engine/thirdparty/enet/src/packet.c @@ -0,0 +1,165 @@ +/** + @file packet.c + @brief ENet packet management functions +*/ +#include +#define ENET_BUILDING_LIB 1 +#include "enet/enet.h" + +/** @defgroup Packet ENet packet functions + @{ +*/ + +/** Creates a packet that may be sent to a peer. + @param data initial contents of the packet's data; the packet's data will remain uninitialized if data is NULL. + @param dataLength size of the data allocated for this packet + @param flags flags for this packet as described for the ENetPacket structure. + @returns the packet on success, NULL on failure +*/ +ENetPacket * +enet_packet_create (const void * data, size_t dataLength, enet_uint32 flags) +{ + ENetPacket * packet = (ENetPacket *) enet_malloc (sizeof (ENetPacket)); + if (packet == NULL) + return NULL; + + if (flags & ENET_PACKET_FLAG_NO_ALLOCATE) + packet -> data = (enet_uint8 *) data; + else + if (dataLength <= 0) + packet -> data = NULL; + else + { + packet -> data = (enet_uint8 *) enet_malloc (dataLength); + if (packet -> data == NULL) + { + enet_free (packet); + return NULL; + } + + if (data != NULL) + memcpy (packet -> data, data, dataLength); + } + + packet -> referenceCount = 0; + packet -> flags = flags; + packet -> dataLength = dataLength; + packet -> freeCallback = NULL; + packet -> userData = NULL; + + return packet; +} + +/** Destroys the packet and deallocates its data. + @param packet packet to be destroyed +*/ +void +enet_packet_destroy (ENetPacket * packet) +{ + if (packet == NULL) + return; + + if (packet -> freeCallback != NULL) + (* packet -> freeCallback) (packet); + if (! (packet -> flags & ENET_PACKET_FLAG_NO_ALLOCATE) && + packet -> data != NULL) + enet_free (packet -> data); + enet_free (packet); +} + +/** Attempts to resize the data in the packet to length specified in the + dataLength parameter + @param packet packet to resize + @param dataLength new size for the packet data + @returns 0 on success, < 0 on failure +*/ +int +enet_packet_resize (ENetPacket * packet, size_t dataLength) +{ + enet_uint8 * newData; + + if (dataLength <= packet -> dataLength || (packet -> flags & ENET_PACKET_FLAG_NO_ALLOCATE)) + { + packet -> dataLength = dataLength; + + return 0; + } + + newData = (enet_uint8 *) enet_malloc (dataLength); + if (newData == NULL) + return -1; + + memcpy (newData, packet -> data, packet -> dataLength); + enet_free (packet -> data); + + packet -> data = newData; + packet -> dataLength = dataLength; + + return 0; +} + +static int initializedCRC32 = 0; +static enet_uint32 crcTable [256]; + +static enet_uint32 +reflect_crc (int val, int bits) +{ + int result = 0, bit; + + for (bit = 0; bit < bits; bit ++) + { + if(val & 1) result |= 1 << (bits - 1 - bit); + val >>= 1; + } + + return result; +} + +static void +initialize_crc32 (void) +{ + int byte; + + for (byte = 0; byte < 256; ++ byte) + { + enet_uint32 crc = reflect_crc (byte, 8) << 24; + int offset; + + for(offset = 0; offset < 8; ++ offset) + { + if (crc & 0x80000000) + crc = (crc << 1) ^ 0x04c11db7; + else + crc <<= 1; + } + + crcTable [byte] = reflect_crc (crc, 32); + } + + initializedCRC32 = 1; +} + +enet_uint32 +enet_crc32 (const ENetBuffer * buffers, size_t bufferCount) +{ + enet_uint32 crc = 0xFFFFFFFF; + + if (! initializedCRC32) initialize_crc32 (); + + while (bufferCount -- > 0) + { + const enet_uint8 * data = (const enet_uint8 *) buffers -> data, + * dataEnd = & data [buffers -> dataLength]; + + while (data < dataEnd) + { + crc = (crc >> 8) ^ crcTable [(crc & 0xFF) ^ *data++]; + } + + ++ buffers; + } + + return ENET_HOST_TO_NET_32 (~ crc); +} + +/** @} */ diff --git a/source/engine/thirdparty/enet/src/peer.c b/source/engine/thirdparty/enet/src/peer.c new file mode 100644 index 0000000..32f9809 --- /dev/null +++ b/source/engine/thirdparty/enet/src/peer.c @@ -0,0 +1,1004 @@ +/** + @file peer.c + @brief ENet peer management functions +*/ +#include +#define ENET_BUILDING_LIB 1 +#include "enet/enet.h" + +/** @defgroup peer ENet peer functions + @{ +*/ + +/** Configures throttle parameter for a peer. + + Unreliable packets are dropped by ENet in response to the varying conditions + of the Internet connection to the peer. The throttle represents a probability + that an unreliable packet should not be dropped and thus sent by ENet to the peer. + The lowest mean round trip time from the sending of a reliable packet to the + receipt of its acknowledgement is measured over an amount of time specified by + the interval parameter in milliseconds. If a measured round trip time happens to + be significantly less than the mean round trip time measured over the interval, + then the throttle probability is increased to allow more traffic by an amount + specified in the acceleration parameter, which is a ratio to the ENET_PEER_PACKET_THROTTLE_SCALE + constant. If a measured round trip time happens to be significantly greater than + the mean round trip time measured over the interval, then the throttle probability + is decreased to limit traffic by an amount specified in the deceleration parameter, which + is a ratio to the ENET_PEER_PACKET_THROTTLE_SCALE constant. When the throttle has + a value of ENET_PEER_PACKET_THROTTLE_SCALE, no unreliable packets are dropped by + ENet, and so 100% of all unreliable packets will be sent. When the throttle has a + value of 0, all unreliable packets are dropped by ENet, and so 0% of all unreliable + packets will be sent. Intermediate values for the throttle represent intermediate + probabilities between 0% and 100% of unreliable packets being sent. The bandwidth + limits of the local and foreign hosts are taken into account to determine a + sensible limit for the throttle probability above which it should not raise even in + the best of conditions. + + @param peer peer to configure + @param interval interval, in milliseconds, over which to measure lowest mean RTT; the default value is ENET_PEER_PACKET_THROTTLE_INTERVAL. + @param acceleration rate at which to increase the throttle probability as mean RTT declines + @param deceleration rate at which to decrease the throttle probability as mean RTT increases +*/ +void +enet_peer_throttle_configure (ENetPeer * peer, enet_uint32 interval, enet_uint32 acceleration, enet_uint32 deceleration) +{ + ENetProtocol command; + + peer -> packetThrottleInterval = interval; + peer -> packetThrottleAcceleration = acceleration; + peer -> packetThrottleDeceleration = deceleration; + + command.header.command = ENET_PROTOCOL_COMMAND_THROTTLE_CONFIGURE | ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE; + command.header.channelID = 0xFF; + + command.throttleConfigure.packetThrottleInterval = ENET_HOST_TO_NET_32 (interval); + command.throttleConfigure.packetThrottleAcceleration = ENET_HOST_TO_NET_32 (acceleration); + command.throttleConfigure.packetThrottleDeceleration = ENET_HOST_TO_NET_32 (deceleration); + + enet_peer_queue_outgoing_command (peer, & command, NULL, 0, 0); +} + +int +enet_peer_throttle (ENetPeer * peer, enet_uint32 rtt) +{ + if (peer -> lastRoundTripTime <= peer -> lastRoundTripTimeVariance) + { + peer -> packetThrottle = peer -> packetThrottleLimit; + } + else + if (rtt <= peer -> lastRoundTripTime) + { + peer -> packetThrottle += peer -> packetThrottleAcceleration; + + if (peer -> packetThrottle > peer -> packetThrottleLimit) + peer -> packetThrottle = peer -> packetThrottleLimit; + + return 1; + } + else + if (rtt > peer -> lastRoundTripTime + 2 * peer -> lastRoundTripTimeVariance) + { + if (peer -> packetThrottle > peer -> packetThrottleDeceleration) + peer -> packetThrottle -= peer -> packetThrottleDeceleration; + else + peer -> packetThrottle = 0; + + return -1; + } + + return 0; +} + +/** Queues a packet to be sent. + @param peer destination for the packet + @param channelID channel on which to send + @param packet packet to send + @retval 0 on success + @retval < 0 on failure +*/ +int +enet_peer_send (ENetPeer * peer, enet_uint8 channelID, ENetPacket * packet) +{ + ENetChannel * channel; + ENetProtocol command; + size_t fragmentLength; + + if (peer -> state != ENET_PEER_STATE_CONNECTED || + channelID >= peer -> channelCount || + packet -> dataLength > peer -> host -> maximumPacketSize) + return -1; + + channel = & peer -> channels [channelID]; + fragmentLength = peer -> mtu - sizeof (ENetProtocolHeader) - sizeof (ENetProtocolSendFragment); + if (peer -> host -> checksum != NULL) + fragmentLength -= sizeof(enet_uint32); + + if (packet -> dataLength > fragmentLength) + { + enet_uint32 fragmentCount = (packet -> dataLength + fragmentLength - 1) / fragmentLength, + fragmentNumber, + fragmentOffset; + enet_uint8 commandNumber; + enet_uint16 startSequenceNumber; + ENetList fragments; + ENetOutgoingCommand * fragment; + + if (fragmentCount > ENET_PROTOCOL_MAXIMUM_FRAGMENT_COUNT) + return -1; + + if ((packet -> flags & (ENET_PACKET_FLAG_RELIABLE | ENET_PACKET_FLAG_UNRELIABLE_FRAGMENT)) == ENET_PACKET_FLAG_UNRELIABLE_FRAGMENT && + channel -> outgoingUnreliableSequenceNumber < 0xFFFF) + { + commandNumber = ENET_PROTOCOL_COMMAND_SEND_UNRELIABLE_FRAGMENT; + startSequenceNumber = ENET_HOST_TO_NET_16 (channel -> outgoingUnreliableSequenceNumber + 1); + } + else + { + commandNumber = ENET_PROTOCOL_COMMAND_SEND_FRAGMENT | ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE; + startSequenceNumber = ENET_HOST_TO_NET_16 (channel -> outgoingReliableSequenceNumber + 1); + } + + enet_list_clear (& fragments); + + for (fragmentNumber = 0, + fragmentOffset = 0; + fragmentOffset < packet -> dataLength; + ++ fragmentNumber, + fragmentOffset += fragmentLength) + { + if (packet -> dataLength - fragmentOffset < fragmentLength) + fragmentLength = packet -> dataLength - fragmentOffset; + + fragment = (ENetOutgoingCommand *) enet_malloc (sizeof (ENetOutgoingCommand)); + if (fragment == NULL) + { + while (! enet_list_empty (& fragments)) + { + fragment = (ENetOutgoingCommand *) enet_list_remove (enet_list_begin (& fragments)); + + enet_free (fragment); + } + + return -1; + } + + fragment -> fragmentOffset = fragmentOffset; + fragment -> fragmentLength = fragmentLength; + fragment -> packet = packet; + fragment -> command.header.command = commandNumber; + fragment -> command.header.channelID = channelID; + fragment -> command.sendFragment.startSequenceNumber = startSequenceNumber; + fragment -> command.sendFragment.dataLength = ENET_HOST_TO_NET_16 (fragmentLength); + fragment -> command.sendFragment.fragmentCount = ENET_HOST_TO_NET_32 (fragmentCount); + fragment -> command.sendFragment.fragmentNumber = ENET_HOST_TO_NET_32 (fragmentNumber); + fragment -> command.sendFragment.totalLength = ENET_HOST_TO_NET_32 (packet -> dataLength); + fragment -> command.sendFragment.fragmentOffset = ENET_NET_TO_HOST_32 (fragmentOffset); + + enet_list_insert (enet_list_end (& fragments), fragment); + } + + packet -> referenceCount += fragmentNumber; + + while (! enet_list_empty (& fragments)) + { + fragment = (ENetOutgoingCommand *) enet_list_remove (enet_list_begin (& fragments)); + + enet_peer_setup_outgoing_command (peer, fragment); + } + + return 0; + } + + command.header.channelID = channelID; + + if ((packet -> flags & (ENET_PACKET_FLAG_RELIABLE | ENET_PACKET_FLAG_UNSEQUENCED)) == ENET_PACKET_FLAG_UNSEQUENCED) + { + command.header.command = ENET_PROTOCOL_COMMAND_SEND_UNSEQUENCED | ENET_PROTOCOL_COMMAND_FLAG_UNSEQUENCED; + command.sendUnsequenced.dataLength = ENET_HOST_TO_NET_16 (packet -> dataLength); + } + else + if (packet -> flags & ENET_PACKET_FLAG_RELIABLE || channel -> outgoingUnreliableSequenceNumber >= 0xFFFF) + { + command.header.command = ENET_PROTOCOL_COMMAND_SEND_RELIABLE | ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE; + command.sendReliable.dataLength = ENET_HOST_TO_NET_16 (packet -> dataLength); + } + else + { + command.header.command = ENET_PROTOCOL_COMMAND_SEND_UNRELIABLE; + command.sendUnreliable.dataLength = ENET_HOST_TO_NET_16 (packet -> dataLength); + } + + if (enet_peer_queue_outgoing_command (peer, & command, packet, 0, packet -> dataLength) == NULL) + return -1; + + return 0; +} + +/** Attempts to dequeue any incoming queued packet. + @param peer peer to dequeue packets from + @param channelID holds the channel ID of the channel the packet was received on success + @returns a pointer to the packet, or NULL if there are no available incoming queued packets +*/ +ENetPacket * +enet_peer_receive (ENetPeer * peer, enet_uint8 * channelID) +{ + ENetIncomingCommand * incomingCommand; + ENetPacket * packet; + + if (enet_list_empty (& peer -> dispatchedCommands)) + return NULL; + + incomingCommand = (ENetIncomingCommand *) enet_list_remove (enet_list_begin (& peer -> dispatchedCommands)); + + if (channelID != NULL) + * channelID = incomingCommand -> command.header.channelID; + + packet = incomingCommand -> packet; + + -- packet -> referenceCount; + + if (incomingCommand -> fragments != NULL) + enet_free (incomingCommand -> fragments); + + enet_free (incomingCommand); + + peer -> totalWaitingData -= packet -> dataLength; + + return packet; +} + +static void +enet_peer_reset_outgoing_commands (ENetList * queue) +{ + ENetOutgoingCommand * outgoingCommand; + + while (! enet_list_empty (queue)) + { + outgoingCommand = (ENetOutgoingCommand *) enet_list_remove (enet_list_begin (queue)); + + if (outgoingCommand -> packet != NULL) + { + -- outgoingCommand -> packet -> referenceCount; + + if (outgoingCommand -> packet -> referenceCount == 0) + enet_packet_destroy (outgoingCommand -> packet); + } + + enet_free (outgoingCommand); + } +} + +static void +enet_peer_remove_incoming_commands (ENetList * queue, ENetListIterator startCommand, ENetListIterator endCommand, ENetIncomingCommand * excludeCommand) +{ + ENetListIterator currentCommand; + + for (currentCommand = startCommand; currentCommand != endCommand; ) + { + ENetIncomingCommand * incomingCommand = (ENetIncomingCommand *) currentCommand; + + currentCommand = enet_list_next (currentCommand); + + if (incomingCommand == excludeCommand) + continue; + + enet_list_remove (& incomingCommand -> incomingCommandList); + + if (incomingCommand -> packet != NULL) + { + -- incomingCommand -> packet -> referenceCount; + + if (incomingCommand -> packet -> referenceCount == 0) + enet_packet_destroy (incomingCommand -> packet); + } + + if (incomingCommand -> fragments != NULL) + enet_free (incomingCommand -> fragments); + + enet_free (incomingCommand); + } +} + +static void +enet_peer_reset_incoming_commands (ENetList * queue) +{ + enet_peer_remove_incoming_commands(queue, enet_list_begin (queue), enet_list_end (queue), NULL); +} + +void +enet_peer_reset_queues (ENetPeer * peer) +{ + ENetChannel * channel; + + if (peer -> flags & ENET_PEER_FLAG_NEEDS_DISPATCH) + { + enet_list_remove (& peer -> dispatchList); + + peer -> flags &= ~ ENET_PEER_FLAG_NEEDS_DISPATCH; + } + + while (! enet_list_empty (& peer -> acknowledgements)) + enet_free (enet_list_remove (enet_list_begin (& peer -> acknowledgements))); + + enet_peer_reset_outgoing_commands (& peer -> sentReliableCommands); + enet_peer_reset_outgoing_commands (& peer -> sentUnreliableCommands); + enet_peer_reset_outgoing_commands (& peer -> outgoingCommands); + enet_peer_reset_incoming_commands (& peer -> dispatchedCommands); + + if (peer -> channels != NULL && peer -> channelCount > 0) + { + for (channel = peer -> channels; + channel < & peer -> channels [peer -> channelCount]; + ++ channel) + { + enet_peer_reset_incoming_commands (& channel -> incomingReliableCommands); + enet_peer_reset_incoming_commands (& channel -> incomingUnreliableCommands); + } + + enet_free (peer -> channels); + } + + peer -> channels = NULL; + peer -> channelCount = 0; +} + +void +enet_peer_on_connect (ENetPeer * peer) +{ + if (peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER) + { + if (peer -> incomingBandwidth != 0) + ++ peer -> host -> bandwidthLimitedPeers; + + ++ peer -> host -> connectedPeers; + } +} + +void +enet_peer_on_disconnect (ENetPeer * peer) +{ + if (peer -> state == ENET_PEER_STATE_CONNECTED || peer -> state == ENET_PEER_STATE_DISCONNECT_LATER) + { + if (peer -> incomingBandwidth != 0) + -- peer -> host -> bandwidthLimitedPeers; + + -- peer -> host -> connectedPeers; + } +} + +/** Forcefully disconnects a peer. + @param peer peer to forcefully disconnect + @remarks The foreign host represented by the peer is not notified of the disconnection and will timeout + on its connection to the local host. +*/ +void +enet_peer_reset (ENetPeer * peer) +{ + enet_peer_on_disconnect (peer); + + peer -> outgoingPeerID = ENET_PROTOCOL_MAXIMUM_PEER_ID; + peer -> connectID = 0; + + peer -> state = ENET_PEER_STATE_DISCONNECTED; + + peer -> incomingBandwidth = 0; + peer -> outgoingBandwidth = 0; + peer -> incomingBandwidthThrottleEpoch = 0; + peer -> outgoingBandwidthThrottleEpoch = 0; + peer -> incomingDataTotal = 0; + peer -> outgoingDataTotal = 0; + peer -> lastSendTime = 0; + peer -> lastReceiveTime = 0; + peer -> nextTimeout = 0; + peer -> earliestTimeout = 0; + peer -> packetLossEpoch = 0; + peer -> packetsSent = 0; + peer -> packetsLost = 0; + peer -> packetLoss = 0; + peer -> packetLossVariance = 0; + peer -> packetThrottle = ENET_PEER_DEFAULT_PACKET_THROTTLE; + peer -> packetThrottleLimit = ENET_PEER_PACKET_THROTTLE_SCALE; + peer -> packetThrottleCounter = 0; + peer -> packetThrottleEpoch = 0; + peer -> packetThrottleAcceleration = ENET_PEER_PACKET_THROTTLE_ACCELERATION; + peer -> packetThrottleDeceleration = ENET_PEER_PACKET_THROTTLE_DECELERATION; + peer -> packetThrottleInterval = ENET_PEER_PACKET_THROTTLE_INTERVAL; + peer -> pingInterval = ENET_PEER_PING_INTERVAL; + peer -> timeoutLimit = ENET_PEER_TIMEOUT_LIMIT; + peer -> timeoutMinimum = ENET_PEER_TIMEOUT_MINIMUM; + peer -> timeoutMaximum = ENET_PEER_TIMEOUT_MAXIMUM; + peer -> lastRoundTripTime = ENET_PEER_DEFAULT_ROUND_TRIP_TIME; + peer -> lowestRoundTripTime = ENET_PEER_DEFAULT_ROUND_TRIP_TIME; + peer -> lastRoundTripTimeVariance = 0; + peer -> highestRoundTripTimeVariance = 0; + peer -> roundTripTime = ENET_PEER_DEFAULT_ROUND_TRIP_TIME; + peer -> roundTripTimeVariance = 0; + peer -> mtu = peer -> host -> mtu; + peer -> reliableDataInTransit = 0; + peer -> outgoingReliableSequenceNumber = 0; + peer -> windowSize = ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE; + peer -> incomingUnsequencedGroup = 0; + peer -> outgoingUnsequencedGroup = 0; + peer -> eventData = 0; + peer -> totalWaitingData = 0; + peer -> flags = 0; + + memset (peer -> unsequencedWindow, 0, sizeof (peer -> unsequencedWindow)); + + enet_peer_reset_queues (peer); +} + +/** Sends a ping request to a peer. + @param peer destination for the ping request + @remarks ping requests factor into the mean round trip time as designated by the + roundTripTime field in the ENetPeer structure. ENet automatically pings all connected + peers at regular intervals, however, this function may be called to ensure more + frequent ping requests. +*/ +void +enet_peer_ping (ENetPeer * peer) +{ + ENetProtocol command; + + if (peer -> state != ENET_PEER_STATE_CONNECTED) + return; + + command.header.command = ENET_PROTOCOL_COMMAND_PING | ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE; + command.header.channelID = 0xFF; + + enet_peer_queue_outgoing_command (peer, & command, NULL, 0, 0); +} + +/** Sets the interval at which pings will be sent to a peer. + + Pings are used both to monitor the liveness of the connection and also to dynamically + adjust the throttle during periods of low traffic so that the throttle has reasonable + responsiveness during traffic spikes. + + @param peer the peer to adjust + @param pingInterval the interval at which to send pings; defaults to ENET_PEER_PING_INTERVAL if 0 +*/ +void +enet_peer_ping_interval (ENetPeer * peer, enet_uint32 pingInterval) +{ + peer -> pingInterval = pingInterval ? pingInterval : ENET_PEER_PING_INTERVAL; +} + +/** Sets the timeout parameters for a peer. + + The timeout parameter control how and when a peer will timeout from a failure to acknowledge + reliable traffic. Timeout values use an exponential backoff mechanism, where if a reliable + packet is not acknowledge within some multiple of the average RTT plus a variance tolerance, + the timeout will be doubled until it reaches a set limit. If the timeout is thus at this + limit and reliable packets have been sent but not acknowledged within a certain minimum time + period, the peer will be disconnected. Alternatively, if reliable packets have been sent + but not acknowledged for a certain maximum time period, the peer will be disconnected regardless + of the current timeout limit value. + + @param peer the peer to adjust + @param timeoutLimit the timeout limit; defaults to ENET_PEER_TIMEOUT_LIMIT if 0 + @param timeoutMinimum the timeout minimum; defaults to ENET_PEER_TIMEOUT_MINIMUM if 0 + @param timeoutMaximum the timeout maximum; defaults to ENET_PEER_TIMEOUT_MAXIMUM if 0 +*/ + +void +enet_peer_timeout (ENetPeer * peer, enet_uint32 timeoutLimit, enet_uint32 timeoutMinimum, enet_uint32 timeoutMaximum) +{ + peer -> timeoutLimit = timeoutLimit ? timeoutLimit : ENET_PEER_TIMEOUT_LIMIT; + peer -> timeoutMinimum = timeoutMinimum ? timeoutMinimum : ENET_PEER_TIMEOUT_MINIMUM; + peer -> timeoutMaximum = timeoutMaximum ? timeoutMaximum : ENET_PEER_TIMEOUT_MAXIMUM; +} + +/** Force an immediate disconnection from a peer. + @param peer peer to disconnect + @param data data describing the disconnection + @remarks No ENET_EVENT_DISCONNECT event will be generated. The foreign peer is not + guaranteed to receive the disconnect notification, and is reset immediately upon + return from this function. +*/ +void +enet_peer_disconnect_now (ENetPeer * peer, enet_uint32 data) +{ + ENetProtocol command; + + if (peer -> state == ENET_PEER_STATE_DISCONNECTED) + return; + + if (peer -> state != ENET_PEER_STATE_ZOMBIE && + peer -> state != ENET_PEER_STATE_DISCONNECTING) + { + enet_peer_reset_queues (peer); + + command.header.command = ENET_PROTOCOL_COMMAND_DISCONNECT | ENET_PROTOCOL_COMMAND_FLAG_UNSEQUENCED; + command.header.channelID = 0xFF; + command.disconnect.data = ENET_HOST_TO_NET_32 (data); + + enet_peer_queue_outgoing_command (peer, & command, NULL, 0, 0); + + enet_host_flush (peer -> host); + } + + enet_peer_reset (peer); +} + +/** Request a disconnection from a peer. + @param peer peer to request a disconnection + @param data data describing the disconnection + @remarks An ENET_EVENT_DISCONNECT event will be generated by enet_host_service() + once the disconnection is complete. +*/ +void +enet_peer_disconnect (ENetPeer * peer, enet_uint32 data) +{ + ENetProtocol command; + + if (peer -> state == ENET_PEER_STATE_DISCONNECTING || + peer -> state == ENET_PEER_STATE_DISCONNECTED || + peer -> state == ENET_PEER_STATE_ACKNOWLEDGING_DISCONNECT || + peer -> state == ENET_PEER_STATE_ZOMBIE) + return; + + enet_peer_reset_queues (peer); + + command.header.command = ENET_PROTOCOL_COMMAND_DISCONNECT; + command.header.channelID = 0xFF; + command.disconnect.data = ENET_HOST_TO_NET_32 (data); + + if (peer -> state == ENET_PEER_STATE_CONNECTED || peer -> state == ENET_PEER_STATE_DISCONNECT_LATER) + command.header.command |= ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE; + else + command.header.command |= ENET_PROTOCOL_COMMAND_FLAG_UNSEQUENCED; + + enet_peer_queue_outgoing_command (peer, & command, NULL, 0, 0); + + if (peer -> state == ENET_PEER_STATE_CONNECTED || peer -> state == ENET_PEER_STATE_DISCONNECT_LATER) + { + enet_peer_on_disconnect (peer); + + peer -> state = ENET_PEER_STATE_DISCONNECTING; + } + else + { + enet_host_flush (peer -> host); + enet_peer_reset (peer); + } +} + +/** Request a disconnection from a peer, but only after all queued outgoing packets are sent. + @param peer peer to request a disconnection + @param data data describing the disconnection + @remarks An ENET_EVENT_DISCONNECT event will be generated by enet_host_service() + once the disconnection is complete. +*/ +void +enet_peer_disconnect_later (ENetPeer * peer, enet_uint32 data) +{ + if ((peer -> state == ENET_PEER_STATE_CONNECTED || peer -> state == ENET_PEER_STATE_DISCONNECT_LATER) && + ! (enet_list_empty (& peer -> outgoingCommands) && + enet_list_empty (& peer -> sentReliableCommands))) + { + peer -> state = ENET_PEER_STATE_DISCONNECT_LATER; + peer -> eventData = data; + } + else + enet_peer_disconnect (peer, data); +} + +ENetAcknowledgement * +enet_peer_queue_acknowledgement (ENetPeer * peer, const ENetProtocol * command, enet_uint16 sentTime) +{ + ENetAcknowledgement * acknowledgement; + + if (command -> header.channelID < peer -> channelCount) + { + ENetChannel * channel = & peer -> channels [command -> header.channelID]; + enet_uint16 reliableWindow = command -> header.reliableSequenceNumber / ENET_PEER_RELIABLE_WINDOW_SIZE, + currentWindow = channel -> incomingReliableSequenceNumber / ENET_PEER_RELIABLE_WINDOW_SIZE; + + if (command -> header.reliableSequenceNumber < channel -> incomingReliableSequenceNumber) + reliableWindow += ENET_PEER_RELIABLE_WINDOWS; + + if (reliableWindow >= currentWindow + ENET_PEER_FREE_RELIABLE_WINDOWS - 1 && reliableWindow <= currentWindow + ENET_PEER_FREE_RELIABLE_WINDOWS) + return NULL; + } + + acknowledgement = (ENetAcknowledgement *) enet_malloc (sizeof (ENetAcknowledgement)); + if (acknowledgement == NULL) + return NULL; + + peer -> outgoingDataTotal += sizeof (ENetProtocolAcknowledge); + + acknowledgement -> sentTime = sentTime; + acknowledgement -> command = * command; + + enet_list_insert (enet_list_end (& peer -> acknowledgements), acknowledgement); + + return acknowledgement; +} + +void +enet_peer_setup_outgoing_command (ENetPeer * peer, ENetOutgoingCommand * outgoingCommand) +{ + ENetChannel * channel = & peer -> channels [outgoingCommand -> command.header.channelID]; + + peer -> outgoingDataTotal += enet_protocol_command_size (outgoingCommand -> command.header.command) + outgoingCommand -> fragmentLength; + + if (outgoingCommand -> command.header.channelID == 0xFF) + { + ++ peer -> outgoingReliableSequenceNumber; + + outgoingCommand -> reliableSequenceNumber = peer -> outgoingReliableSequenceNumber; + outgoingCommand -> unreliableSequenceNumber = 0; + } + else + if (outgoingCommand -> command.header.command & ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE) + { + ++ channel -> outgoingReliableSequenceNumber; + channel -> outgoingUnreliableSequenceNumber = 0; + + outgoingCommand -> reliableSequenceNumber = channel -> outgoingReliableSequenceNumber; + outgoingCommand -> unreliableSequenceNumber = 0; + } + else + if (outgoingCommand -> command.header.command & ENET_PROTOCOL_COMMAND_FLAG_UNSEQUENCED) + { + ++ peer -> outgoingUnsequencedGroup; + + outgoingCommand -> reliableSequenceNumber = 0; + outgoingCommand -> unreliableSequenceNumber = 0; + } + else + { + if (outgoingCommand -> fragmentOffset == 0) + ++ channel -> outgoingUnreliableSequenceNumber; + + outgoingCommand -> reliableSequenceNumber = channel -> outgoingReliableSequenceNumber; + outgoingCommand -> unreliableSequenceNumber = channel -> outgoingUnreliableSequenceNumber; + } + + outgoingCommand -> sendAttempts = 0; + outgoingCommand -> sentTime = 0; + outgoingCommand -> roundTripTimeout = 0; + outgoingCommand -> roundTripTimeoutLimit = 0; + outgoingCommand -> command.header.reliableSequenceNumber = ENET_HOST_TO_NET_16 (outgoingCommand -> reliableSequenceNumber); + + switch (outgoingCommand -> command.header.command & ENET_PROTOCOL_COMMAND_MASK) + { + case ENET_PROTOCOL_COMMAND_SEND_UNRELIABLE: + outgoingCommand -> command.sendUnreliable.unreliableSequenceNumber = ENET_HOST_TO_NET_16 (outgoingCommand -> unreliableSequenceNumber); + break; + + case ENET_PROTOCOL_COMMAND_SEND_UNSEQUENCED: + outgoingCommand -> command.sendUnsequenced.unsequencedGroup = ENET_HOST_TO_NET_16 (peer -> outgoingUnsequencedGroup); + break; + + default: + break; + } + + enet_list_insert (enet_list_end (& peer -> outgoingCommands), outgoingCommand); +} + +ENetOutgoingCommand * +enet_peer_queue_outgoing_command (ENetPeer * peer, const ENetProtocol * command, ENetPacket * packet, enet_uint32 offset, enet_uint16 length) +{ + ENetOutgoingCommand * outgoingCommand = (ENetOutgoingCommand *) enet_malloc (sizeof (ENetOutgoingCommand)); + if (outgoingCommand == NULL) + return NULL; + + outgoingCommand -> command = * command; + outgoingCommand -> fragmentOffset = offset; + outgoingCommand -> fragmentLength = length; + outgoingCommand -> packet = packet; + if (packet != NULL) + ++ packet -> referenceCount; + + enet_peer_setup_outgoing_command (peer, outgoingCommand); + + return outgoingCommand; +} + +void +enet_peer_dispatch_incoming_unreliable_commands (ENetPeer * peer, ENetChannel * channel, ENetIncomingCommand * queuedCommand) +{ + ENetListIterator droppedCommand, startCommand, currentCommand; + + for (droppedCommand = startCommand = currentCommand = enet_list_begin (& channel -> incomingUnreliableCommands); + currentCommand != enet_list_end (& channel -> incomingUnreliableCommands); + currentCommand = enet_list_next (currentCommand)) + { + ENetIncomingCommand * incomingCommand = (ENetIncomingCommand *) currentCommand; + + if ((incomingCommand -> command.header.command & ENET_PROTOCOL_COMMAND_MASK) == ENET_PROTOCOL_COMMAND_SEND_UNSEQUENCED) + continue; + + if (incomingCommand -> reliableSequenceNumber == channel -> incomingReliableSequenceNumber) + { + if (incomingCommand -> fragmentsRemaining <= 0) + { + channel -> incomingUnreliableSequenceNumber = incomingCommand -> unreliableSequenceNumber; + continue; + } + + if (startCommand != currentCommand) + { + enet_list_move (enet_list_end (& peer -> dispatchedCommands), startCommand, enet_list_previous (currentCommand)); + + if (! (peer -> flags & ENET_PEER_FLAG_NEEDS_DISPATCH)) + { + enet_list_insert (enet_list_end (& peer -> host -> dispatchQueue), & peer -> dispatchList); + + peer -> flags |= ENET_PEER_FLAG_NEEDS_DISPATCH; + } + + droppedCommand = currentCommand; + } + else + if (droppedCommand != currentCommand) + droppedCommand = enet_list_previous (currentCommand); + } + else + { + enet_uint16 reliableWindow = incomingCommand -> reliableSequenceNumber / ENET_PEER_RELIABLE_WINDOW_SIZE, + currentWindow = channel -> incomingReliableSequenceNumber / ENET_PEER_RELIABLE_WINDOW_SIZE; + if (incomingCommand -> reliableSequenceNumber < channel -> incomingReliableSequenceNumber) + reliableWindow += ENET_PEER_RELIABLE_WINDOWS; + if (reliableWindow >= currentWindow && reliableWindow < currentWindow + ENET_PEER_FREE_RELIABLE_WINDOWS - 1) + break; + + droppedCommand = enet_list_next (currentCommand); + + if (startCommand != currentCommand) + { + enet_list_move (enet_list_end (& peer -> dispatchedCommands), startCommand, enet_list_previous (currentCommand)); + + if (! (peer -> flags & ENET_PEER_FLAG_NEEDS_DISPATCH)) + { + enet_list_insert (enet_list_end (& peer -> host -> dispatchQueue), & peer -> dispatchList); + + peer -> flags |= ENET_PEER_FLAG_NEEDS_DISPATCH; + } + } + } + + startCommand = enet_list_next (currentCommand); + } + + if (startCommand != currentCommand) + { + enet_list_move (enet_list_end (& peer -> dispatchedCommands), startCommand, enet_list_previous (currentCommand)); + + if (! (peer -> flags & ENET_PEER_FLAG_NEEDS_DISPATCH)) + { + enet_list_insert (enet_list_end (& peer -> host -> dispatchQueue), & peer -> dispatchList); + + peer -> flags |= ENET_PEER_FLAG_NEEDS_DISPATCH; + } + + droppedCommand = currentCommand; + } + + enet_peer_remove_incoming_commands (& channel -> incomingUnreliableCommands, enet_list_begin (& channel -> incomingUnreliableCommands), droppedCommand, queuedCommand); +} + +void +enet_peer_dispatch_incoming_reliable_commands (ENetPeer * peer, ENetChannel * channel, ENetIncomingCommand * queuedCommand) +{ + ENetListIterator currentCommand; + + for (currentCommand = enet_list_begin (& channel -> incomingReliableCommands); + currentCommand != enet_list_end (& channel -> incomingReliableCommands); + currentCommand = enet_list_next (currentCommand)) + { + ENetIncomingCommand * incomingCommand = (ENetIncomingCommand *) currentCommand; + + if (incomingCommand -> fragmentsRemaining > 0 || + incomingCommand -> reliableSequenceNumber != (enet_uint16) (channel -> incomingReliableSequenceNumber + 1)) + break; + + channel -> incomingReliableSequenceNumber = incomingCommand -> reliableSequenceNumber; + + if (incomingCommand -> fragmentCount > 0) + channel -> incomingReliableSequenceNumber += incomingCommand -> fragmentCount - 1; + } + + if (currentCommand == enet_list_begin (& channel -> incomingReliableCommands)) + return; + + channel -> incomingUnreliableSequenceNumber = 0; + + enet_list_move (enet_list_end (& peer -> dispatchedCommands), enet_list_begin (& channel -> incomingReliableCommands), enet_list_previous (currentCommand)); + + if (! (peer -> flags & ENET_PEER_FLAG_NEEDS_DISPATCH)) + { + enet_list_insert (enet_list_end (& peer -> host -> dispatchQueue), & peer -> dispatchList); + + peer -> flags |= ENET_PEER_FLAG_NEEDS_DISPATCH; + } + + if (! enet_list_empty (& channel -> incomingUnreliableCommands)) + enet_peer_dispatch_incoming_unreliable_commands (peer, channel, queuedCommand); +} + +ENetIncomingCommand * +enet_peer_queue_incoming_command (ENetPeer * peer, const ENetProtocol * command, const void * data, size_t dataLength, enet_uint32 flags, enet_uint32 fragmentCount) +{ + static ENetIncomingCommand dummyCommand; + + ENetChannel * channel = & peer -> channels [command -> header.channelID]; + enet_uint32 unreliableSequenceNumber = 0, reliableSequenceNumber = 0; + enet_uint16 reliableWindow, currentWindow; + ENetIncomingCommand * incomingCommand; + ENetListIterator currentCommand; + ENetPacket * packet = NULL; + + if (peer -> state == ENET_PEER_STATE_DISCONNECT_LATER) + goto discardCommand; + + if ((command -> header.command & ENET_PROTOCOL_COMMAND_MASK) != ENET_PROTOCOL_COMMAND_SEND_UNSEQUENCED) + { + reliableSequenceNumber = command -> header.reliableSequenceNumber; + reliableWindow = reliableSequenceNumber / ENET_PEER_RELIABLE_WINDOW_SIZE; + currentWindow = channel -> incomingReliableSequenceNumber / ENET_PEER_RELIABLE_WINDOW_SIZE; + + if (reliableSequenceNumber < channel -> incomingReliableSequenceNumber) + reliableWindow += ENET_PEER_RELIABLE_WINDOWS; + + if (reliableWindow < currentWindow || reliableWindow >= currentWindow + ENET_PEER_FREE_RELIABLE_WINDOWS - 1) + goto discardCommand; + } + + switch (command -> header.command & ENET_PROTOCOL_COMMAND_MASK) + { + case ENET_PROTOCOL_COMMAND_SEND_FRAGMENT: + case ENET_PROTOCOL_COMMAND_SEND_RELIABLE: + if (reliableSequenceNumber == channel -> incomingReliableSequenceNumber) + goto discardCommand; + + for (currentCommand = enet_list_previous (enet_list_end (& channel -> incomingReliableCommands)); + currentCommand != enet_list_end (& channel -> incomingReliableCommands); + currentCommand = enet_list_previous (currentCommand)) + { + incomingCommand = (ENetIncomingCommand *) currentCommand; + + if (reliableSequenceNumber >= channel -> incomingReliableSequenceNumber) + { + if (incomingCommand -> reliableSequenceNumber < channel -> incomingReliableSequenceNumber) + continue; + } + else + if (incomingCommand -> reliableSequenceNumber >= channel -> incomingReliableSequenceNumber) + break; + + if (incomingCommand -> reliableSequenceNumber <= reliableSequenceNumber) + { + if (incomingCommand -> reliableSequenceNumber < reliableSequenceNumber) + break; + + goto discardCommand; + } + } + break; + + case ENET_PROTOCOL_COMMAND_SEND_UNRELIABLE: + case ENET_PROTOCOL_COMMAND_SEND_UNRELIABLE_FRAGMENT: + unreliableSequenceNumber = ENET_NET_TO_HOST_16 (command -> sendUnreliable.unreliableSequenceNumber); + + if (reliableSequenceNumber == channel -> incomingReliableSequenceNumber && + unreliableSequenceNumber <= channel -> incomingUnreliableSequenceNumber) + goto discardCommand; + + for (currentCommand = enet_list_previous (enet_list_end (& channel -> incomingUnreliableCommands)); + currentCommand != enet_list_end (& channel -> incomingUnreliableCommands); + currentCommand = enet_list_previous (currentCommand)) + { + incomingCommand = (ENetIncomingCommand *) currentCommand; + + if ((command -> header.command & ENET_PROTOCOL_COMMAND_MASK) == ENET_PROTOCOL_COMMAND_SEND_UNSEQUENCED) + continue; + + if (reliableSequenceNumber >= channel -> incomingReliableSequenceNumber) + { + if (incomingCommand -> reliableSequenceNumber < channel -> incomingReliableSequenceNumber) + continue; + } + else + if (incomingCommand -> reliableSequenceNumber >= channel -> incomingReliableSequenceNumber) + break; + + if (incomingCommand -> reliableSequenceNumber < reliableSequenceNumber) + break; + + if (incomingCommand -> reliableSequenceNumber > reliableSequenceNumber) + continue; + + if (incomingCommand -> unreliableSequenceNumber <= unreliableSequenceNumber) + { + if (incomingCommand -> unreliableSequenceNumber < unreliableSequenceNumber) + break; + + goto discardCommand; + } + } + break; + + case ENET_PROTOCOL_COMMAND_SEND_UNSEQUENCED: + currentCommand = enet_list_end (& channel -> incomingUnreliableCommands); + break; + + default: + goto discardCommand; + } + + if (peer -> totalWaitingData >= peer -> host -> maximumWaitingData) + goto notifyError; + + packet = enet_packet_create (data, dataLength, flags); + if (packet == NULL) + goto notifyError; + + incomingCommand = (ENetIncomingCommand *) enet_malloc (sizeof (ENetIncomingCommand)); + if (incomingCommand == NULL) + goto notifyError; + + incomingCommand -> reliableSequenceNumber = command -> header.reliableSequenceNumber; + incomingCommand -> unreliableSequenceNumber = unreliableSequenceNumber & 0xFFFF; + incomingCommand -> command = * command; + incomingCommand -> fragmentCount = fragmentCount; + incomingCommand -> fragmentsRemaining = fragmentCount; + incomingCommand -> packet = packet; + incomingCommand -> fragments = NULL; + + if (fragmentCount > 0) + { + if (fragmentCount <= ENET_PROTOCOL_MAXIMUM_FRAGMENT_COUNT) + incomingCommand -> fragments = (enet_uint32 *) enet_malloc ((fragmentCount + 31) / 32 * sizeof (enet_uint32)); + if (incomingCommand -> fragments == NULL) + { + enet_free (incomingCommand); + + goto notifyError; + } + memset (incomingCommand -> fragments, 0, (fragmentCount + 31) / 32 * sizeof (enet_uint32)); + } + + if (packet != NULL) + { + ++ packet -> referenceCount; + + peer -> totalWaitingData += packet -> dataLength; + } + + enet_list_insert (enet_list_next (currentCommand), incomingCommand); + + switch (command -> header.command & ENET_PROTOCOL_COMMAND_MASK) + { + case ENET_PROTOCOL_COMMAND_SEND_FRAGMENT: + case ENET_PROTOCOL_COMMAND_SEND_RELIABLE: + enet_peer_dispatch_incoming_reliable_commands (peer, channel, incomingCommand); + break; + + default: + enet_peer_dispatch_incoming_unreliable_commands (peer, channel, incomingCommand); + break; + } + + return incomingCommand; + +discardCommand: + if (fragmentCount > 0) + goto notifyError; + + if (packet != NULL && packet -> referenceCount == 0) + enet_packet_destroy (packet); + + return & dummyCommand; + +notifyError: + if (packet != NULL && packet -> referenceCount == 0) + enet_packet_destroy (packet); + + return NULL; +} + +/** @} */ diff --git a/source/engine/thirdparty/enet/src/protocol.c b/source/engine/thirdparty/enet/src/protocol.c new file mode 100644 index 0000000..8b3c3db --- /dev/null +++ b/source/engine/thirdparty/enet/src/protocol.c @@ -0,0 +1,1877 @@ +/** + @file protocol.c + @brief ENet protocol functions +*/ +#include +#include +#define ENET_BUILDING_LIB 1 +#include "enet/utility.h" +#include "enet/time.h" +#include "enet/enet.h" + +static size_t commandSizes [ENET_PROTOCOL_COMMAND_COUNT] = +{ + 0, + sizeof (ENetProtocolAcknowledge), + sizeof (ENetProtocolConnect), + sizeof (ENetProtocolVerifyConnect), + sizeof (ENetProtocolDisconnect), + sizeof (ENetProtocolPing), + sizeof (ENetProtocolSendReliable), + sizeof (ENetProtocolSendUnreliable), + sizeof (ENetProtocolSendFragment), + sizeof (ENetProtocolSendUnsequenced), + sizeof (ENetProtocolBandwidthLimit), + sizeof (ENetProtocolThrottleConfigure), + sizeof (ENetProtocolSendFragment) +}; + +size_t +enet_protocol_command_size (enet_uint8 commandNumber) +{ + return commandSizes [commandNumber & ENET_PROTOCOL_COMMAND_MASK]; +} + +static void +enet_protocol_change_state (ENetHost * host, ENetPeer * peer, ENetPeerState state) +{ + if (state == ENET_PEER_STATE_CONNECTED || state == ENET_PEER_STATE_DISCONNECT_LATER) + enet_peer_on_connect (peer); + else + enet_peer_on_disconnect (peer); + + peer -> state = state; +} + +static void +enet_protocol_dispatch_state (ENetHost * host, ENetPeer * peer, ENetPeerState state) +{ + enet_protocol_change_state (host, peer, state); + + if (! (peer -> flags & ENET_PEER_FLAG_NEEDS_DISPATCH)) + { + enet_list_insert (enet_list_end (& host -> dispatchQueue), & peer -> dispatchList); + + peer -> flags |= ENET_PEER_FLAG_NEEDS_DISPATCH; + } +} + +static int +enet_protocol_dispatch_incoming_commands (ENetHost * host, ENetEvent * event) +{ + while (! enet_list_empty (& host -> dispatchQueue)) + { + ENetPeer * peer = (ENetPeer *) enet_list_remove (enet_list_begin (& host -> dispatchQueue)); + + peer -> flags &= ~ ENET_PEER_FLAG_NEEDS_DISPATCH; + + switch (peer -> state) + { + case ENET_PEER_STATE_CONNECTION_PENDING: + case ENET_PEER_STATE_CONNECTION_SUCCEEDED: + enet_protocol_change_state (host, peer, ENET_PEER_STATE_CONNECTED); + + event -> type = ENET_EVENT_TYPE_CONNECT; + event -> peer = peer; + event -> data = peer -> eventData; + + return 1; + + case ENET_PEER_STATE_ZOMBIE: + host -> recalculateBandwidthLimits = 1; + + event -> type = ENET_EVENT_TYPE_DISCONNECT; + event -> peer = peer; + event -> data = peer -> eventData; + + enet_peer_reset (peer); + + return 1; + + case ENET_PEER_STATE_CONNECTED: + if (enet_list_empty (& peer -> dispatchedCommands)) + continue; + + event -> packet = enet_peer_receive (peer, & event -> channelID); + if (event -> packet == NULL) + continue; + + event -> type = ENET_EVENT_TYPE_RECEIVE; + event -> peer = peer; + + if (! enet_list_empty (& peer -> dispatchedCommands)) + { + peer -> flags |= ENET_PEER_FLAG_NEEDS_DISPATCH; + + enet_list_insert (enet_list_end (& host -> dispatchQueue), & peer -> dispatchList); + } + + return 1; + + default: + break; + } + } + + return 0; +} + +static void +enet_protocol_notify_connect (ENetHost * host, ENetPeer * peer, ENetEvent * event) +{ + host -> recalculateBandwidthLimits = 1; + + if (event != NULL) + { + enet_protocol_change_state (host, peer, ENET_PEER_STATE_CONNECTED); + + event -> type = ENET_EVENT_TYPE_CONNECT; + event -> peer = peer; + event -> data = peer -> eventData; + } + else + enet_protocol_dispatch_state (host, peer, peer -> state == ENET_PEER_STATE_CONNECTING ? ENET_PEER_STATE_CONNECTION_SUCCEEDED : ENET_PEER_STATE_CONNECTION_PENDING); +} + +static void +enet_protocol_notify_disconnect (ENetHost * host, ENetPeer * peer, ENetEvent * event) +{ + if (peer -> state >= ENET_PEER_STATE_CONNECTION_PENDING) + host -> recalculateBandwidthLimits = 1; + + if (peer -> state != ENET_PEER_STATE_CONNECTING && peer -> state < ENET_PEER_STATE_CONNECTION_SUCCEEDED) + enet_peer_reset (peer); + else + if (event != NULL) + { + event -> type = ENET_EVENT_TYPE_DISCONNECT; + event -> peer = peer; + event -> data = 0; + + enet_peer_reset (peer); + } + else + { + peer -> eventData = 0; + + enet_protocol_dispatch_state (host, peer, ENET_PEER_STATE_ZOMBIE); + } +} + +static void +enet_protocol_remove_sent_unreliable_commands (ENetPeer * peer) +{ + ENetOutgoingCommand * outgoingCommand; + + if (enet_list_empty (& peer -> sentUnreliableCommands)) + return; + + do + { + outgoingCommand = (ENetOutgoingCommand *) enet_list_front (& peer -> sentUnreliableCommands); + + enet_list_remove (& outgoingCommand -> outgoingCommandList); + + if (outgoingCommand -> packet != NULL) + { + -- outgoingCommand -> packet -> referenceCount; + + if (outgoingCommand -> packet -> referenceCount == 0) + { + outgoingCommand -> packet -> flags |= ENET_PACKET_FLAG_SENT; + + enet_packet_destroy (outgoingCommand -> packet); + } + } + + enet_free (outgoingCommand); + } while (! enet_list_empty (& peer -> sentUnreliableCommands)); + + if (peer -> state == ENET_PEER_STATE_DISCONNECT_LATER && + enet_list_empty (& peer -> outgoingCommands) && + enet_list_empty (& peer -> sentReliableCommands)) + enet_peer_disconnect (peer, peer -> eventData); +} + +static ENetProtocolCommand +enet_protocol_remove_sent_reliable_command (ENetPeer * peer, enet_uint16 reliableSequenceNumber, enet_uint8 channelID) +{ + ENetOutgoingCommand * outgoingCommand = NULL; + ENetListIterator currentCommand; + ENetProtocolCommand commandNumber; + int wasSent = 1; + + for (currentCommand = enet_list_begin (& peer -> sentReliableCommands); + currentCommand != enet_list_end (& peer -> sentReliableCommands); + currentCommand = enet_list_next (currentCommand)) + { + outgoingCommand = (ENetOutgoingCommand *) currentCommand; + + if (outgoingCommand -> reliableSequenceNumber == reliableSequenceNumber && + outgoingCommand -> command.header.channelID == channelID) + break; + } + + if (currentCommand == enet_list_end (& peer -> sentReliableCommands)) + { + for (currentCommand = enet_list_begin (& peer -> outgoingCommands); + currentCommand != enet_list_end (& peer -> outgoingCommands); + currentCommand = enet_list_next (currentCommand)) + { + outgoingCommand = (ENetOutgoingCommand *) currentCommand; + + if (! (outgoingCommand -> command.header.command & ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE)) + continue; + + if (outgoingCommand -> sendAttempts < 1) return ENET_PROTOCOL_COMMAND_NONE; + + if (outgoingCommand -> reliableSequenceNumber == reliableSequenceNumber && + outgoingCommand -> command.header.channelID == channelID) + break; + } + + if (currentCommand == enet_list_end (& peer -> outgoingCommands)) + return ENET_PROTOCOL_COMMAND_NONE; + + wasSent = 0; + } + + if (outgoingCommand == NULL) + return ENET_PROTOCOL_COMMAND_NONE; + + if (channelID < peer -> channelCount) + { + ENetChannel * channel = & peer -> channels [channelID]; + enet_uint16 reliableWindow = reliableSequenceNumber / ENET_PEER_RELIABLE_WINDOW_SIZE; + if (channel -> reliableWindows [reliableWindow] > 0) + { + -- channel -> reliableWindows [reliableWindow]; + if (! channel -> reliableWindows [reliableWindow]) + channel -> usedReliableWindows &= ~ (1 << reliableWindow); + } + } + + commandNumber = (ENetProtocolCommand) (outgoingCommand -> command.header.command & ENET_PROTOCOL_COMMAND_MASK); + + enet_list_remove (& outgoingCommand -> outgoingCommandList); + + if (outgoingCommand -> packet != NULL) + { + if (wasSent) + peer -> reliableDataInTransit -= outgoingCommand -> fragmentLength; + + -- outgoingCommand -> packet -> referenceCount; + + if (outgoingCommand -> packet -> referenceCount == 0) + { + outgoingCommand -> packet -> flags |= ENET_PACKET_FLAG_SENT; + + enet_packet_destroy (outgoingCommand -> packet); + } + } + + enet_free (outgoingCommand); + + if (enet_list_empty (& peer -> sentReliableCommands)) + return commandNumber; + + outgoingCommand = (ENetOutgoingCommand *) enet_list_front (& peer -> sentReliableCommands); + + peer -> nextTimeout = outgoingCommand -> sentTime + outgoingCommand -> roundTripTimeout; + + return commandNumber; +} + +static ENetPeer * +enet_protocol_handle_connect (ENetHost * host, ENetProtocolHeader * header, ENetProtocol * command) +{ + enet_uint8 incomingSessionID, outgoingSessionID; + enet_uint32 mtu, windowSize; + ENetChannel * channel; + size_t channelCount, duplicatePeers = 0; + ENetPeer * currentPeer, * peer = NULL; + ENetProtocol verifyCommand; + + channelCount = ENET_NET_TO_HOST_32 (command -> connect.channelCount); + + if (channelCount < ENET_PROTOCOL_MINIMUM_CHANNEL_COUNT || + channelCount > ENET_PROTOCOL_MAXIMUM_CHANNEL_COUNT) + return NULL; + + for (currentPeer = host -> peers; + currentPeer < & host -> peers [host -> peerCount]; + ++ currentPeer) + { + if (currentPeer -> state == ENET_PEER_STATE_DISCONNECTED) + { + if (peer == NULL) + peer = currentPeer; + } + else + if (currentPeer -> state != ENET_PEER_STATE_CONNECTING && + currentPeer -> address.host == host -> receivedAddress.host) + { + if (currentPeer -> address.port == host -> receivedAddress.port && + currentPeer -> connectID == command -> connect.connectID) + return NULL; + + ++ duplicatePeers; + } + } + + if (peer == NULL || duplicatePeers >= host -> duplicatePeers) + return NULL; + + if (channelCount > host -> channelLimit) + channelCount = host -> channelLimit; + peer -> channels = (ENetChannel *) enet_malloc (channelCount * sizeof (ENetChannel)); + if (peer -> channels == NULL) + return NULL; + peer -> channelCount = channelCount; + peer -> state = ENET_PEER_STATE_ACKNOWLEDGING_CONNECT; + peer -> connectID = command -> connect.connectID; + peer -> address = host -> receivedAddress; + peer -> outgoingPeerID = ENET_NET_TO_HOST_16 (command -> connect.outgoingPeerID); + peer -> incomingBandwidth = ENET_NET_TO_HOST_32 (command -> connect.incomingBandwidth); + peer -> outgoingBandwidth = ENET_NET_TO_HOST_32 (command -> connect.outgoingBandwidth); + peer -> packetThrottleInterval = ENET_NET_TO_HOST_32 (command -> connect.packetThrottleInterval); + peer -> packetThrottleAcceleration = ENET_NET_TO_HOST_32 (command -> connect.packetThrottleAcceleration); + peer -> packetThrottleDeceleration = ENET_NET_TO_HOST_32 (command -> connect.packetThrottleDeceleration); + peer -> eventData = ENET_NET_TO_HOST_32 (command -> connect.data); + + incomingSessionID = command -> connect.incomingSessionID == 0xFF ? peer -> outgoingSessionID : command -> connect.incomingSessionID; + incomingSessionID = (incomingSessionID + 1) & (ENET_PROTOCOL_HEADER_SESSION_MASK >> ENET_PROTOCOL_HEADER_SESSION_SHIFT); + if (incomingSessionID == peer -> outgoingSessionID) + incomingSessionID = (incomingSessionID + 1) & (ENET_PROTOCOL_HEADER_SESSION_MASK >> ENET_PROTOCOL_HEADER_SESSION_SHIFT); + peer -> outgoingSessionID = incomingSessionID; + + outgoingSessionID = command -> connect.outgoingSessionID == 0xFF ? peer -> incomingSessionID : command -> connect.outgoingSessionID; + outgoingSessionID = (outgoingSessionID + 1) & (ENET_PROTOCOL_HEADER_SESSION_MASK >> ENET_PROTOCOL_HEADER_SESSION_SHIFT); + if (outgoingSessionID == peer -> incomingSessionID) + outgoingSessionID = (outgoingSessionID + 1) & (ENET_PROTOCOL_HEADER_SESSION_MASK >> ENET_PROTOCOL_HEADER_SESSION_SHIFT); + peer -> incomingSessionID = outgoingSessionID; + + for (channel = peer -> channels; + channel < & peer -> channels [channelCount]; + ++ channel) + { + channel -> outgoingReliableSequenceNumber = 0; + channel -> outgoingUnreliableSequenceNumber = 0; + channel -> incomingReliableSequenceNumber = 0; + channel -> incomingUnreliableSequenceNumber = 0; + + enet_list_clear (& channel -> incomingReliableCommands); + enet_list_clear (& channel -> incomingUnreliableCommands); + + channel -> usedReliableWindows = 0; + memset (channel -> reliableWindows, 0, sizeof (channel -> reliableWindows)); + } + + mtu = ENET_NET_TO_HOST_32 (command -> connect.mtu); + + if (mtu < ENET_PROTOCOL_MINIMUM_MTU) + mtu = ENET_PROTOCOL_MINIMUM_MTU; + else + if (mtu > ENET_PROTOCOL_MAXIMUM_MTU) + mtu = ENET_PROTOCOL_MAXIMUM_MTU; + + peer -> mtu = mtu; + + if (host -> outgoingBandwidth == 0 && + peer -> incomingBandwidth == 0) + peer -> windowSize = ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE; + else + if (host -> outgoingBandwidth == 0 || + peer -> incomingBandwidth == 0) + peer -> windowSize = (ENET_MAX (host -> outgoingBandwidth, peer -> incomingBandwidth) / + ENET_PEER_WINDOW_SIZE_SCALE) * + ENET_PROTOCOL_MINIMUM_WINDOW_SIZE; + else + peer -> windowSize = (ENET_MIN (host -> outgoingBandwidth, peer -> incomingBandwidth) / + ENET_PEER_WINDOW_SIZE_SCALE) * + ENET_PROTOCOL_MINIMUM_WINDOW_SIZE; + + if (peer -> windowSize < ENET_PROTOCOL_MINIMUM_WINDOW_SIZE) + peer -> windowSize = ENET_PROTOCOL_MINIMUM_WINDOW_SIZE; + else + if (peer -> windowSize > ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE) + peer -> windowSize = ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE; + + if (host -> incomingBandwidth == 0) + windowSize = ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE; + else + windowSize = (host -> incomingBandwidth / ENET_PEER_WINDOW_SIZE_SCALE) * + ENET_PROTOCOL_MINIMUM_WINDOW_SIZE; + + if (windowSize > ENET_NET_TO_HOST_32 (command -> connect.windowSize)) + windowSize = ENET_NET_TO_HOST_32 (command -> connect.windowSize); + + if (windowSize < ENET_PROTOCOL_MINIMUM_WINDOW_SIZE) + windowSize = ENET_PROTOCOL_MINIMUM_WINDOW_SIZE; + else + if (windowSize > ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE) + windowSize = ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE; + + verifyCommand.header.command = ENET_PROTOCOL_COMMAND_VERIFY_CONNECT | ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE; + verifyCommand.header.channelID = 0xFF; + verifyCommand.verifyConnect.outgoingPeerID = ENET_HOST_TO_NET_16 (peer -> incomingPeerID); + verifyCommand.verifyConnect.incomingSessionID = incomingSessionID; + verifyCommand.verifyConnect.outgoingSessionID = outgoingSessionID; + verifyCommand.verifyConnect.mtu = ENET_HOST_TO_NET_32 (peer -> mtu); + verifyCommand.verifyConnect.windowSize = ENET_HOST_TO_NET_32 (windowSize); + verifyCommand.verifyConnect.channelCount = ENET_HOST_TO_NET_32 (channelCount); + verifyCommand.verifyConnect.incomingBandwidth = ENET_HOST_TO_NET_32 (host -> incomingBandwidth); + verifyCommand.verifyConnect.outgoingBandwidth = ENET_HOST_TO_NET_32 (host -> outgoingBandwidth); + verifyCommand.verifyConnect.packetThrottleInterval = ENET_HOST_TO_NET_32 (peer -> packetThrottleInterval); + verifyCommand.verifyConnect.packetThrottleAcceleration = ENET_HOST_TO_NET_32 (peer -> packetThrottleAcceleration); + verifyCommand.verifyConnect.packetThrottleDeceleration = ENET_HOST_TO_NET_32 (peer -> packetThrottleDeceleration); + verifyCommand.verifyConnect.connectID = peer -> connectID; + + enet_peer_queue_outgoing_command (peer, & verifyCommand, NULL, 0, 0); + + return peer; +} + +static int +enet_protocol_handle_send_reliable (ENetHost * host, ENetPeer * peer, const ENetProtocol * command, enet_uint8 ** currentData) +{ + size_t dataLength; + + if (command -> header.channelID >= peer -> channelCount || + (peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER)) + return -1; + + dataLength = ENET_NET_TO_HOST_16 (command -> sendReliable.dataLength); + * currentData += dataLength; + if (dataLength > host -> maximumPacketSize || + * currentData < host -> receivedData || + * currentData > & host -> receivedData [host -> receivedDataLength]) + return -1; + + if (enet_peer_queue_incoming_command (peer, command, (const enet_uint8 *) command + sizeof (ENetProtocolSendReliable), dataLength, ENET_PACKET_FLAG_RELIABLE, 0) == NULL) + return -1; + + return 0; +} + +static int +enet_protocol_handle_send_unsequenced (ENetHost * host, ENetPeer * peer, const ENetProtocol * command, enet_uint8 ** currentData) +{ + enet_uint32 unsequencedGroup, index; + size_t dataLength; + + if (command -> header.channelID >= peer -> channelCount || + (peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER)) + return -1; + + dataLength = ENET_NET_TO_HOST_16 (command -> sendUnsequenced.dataLength); + * currentData += dataLength; + if (dataLength > host -> maximumPacketSize || + * currentData < host -> receivedData || + * currentData > & host -> receivedData [host -> receivedDataLength]) + return -1; + + unsequencedGroup = ENET_NET_TO_HOST_16 (command -> sendUnsequenced.unsequencedGroup); + index = unsequencedGroup % ENET_PEER_UNSEQUENCED_WINDOW_SIZE; + + if (unsequencedGroup < peer -> incomingUnsequencedGroup) + unsequencedGroup += 0x10000; + + if (unsequencedGroup >= (enet_uint32) peer -> incomingUnsequencedGroup + ENET_PEER_FREE_UNSEQUENCED_WINDOWS * ENET_PEER_UNSEQUENCED_WINDOW_SIZE) + return 0; + + unsequencedGroup &= 0xFFFF; + + if (unsequencedGroup - index != peer -> incomingUnsequencedGroup) + { + peer -> incomingUnsequencedGroup = unsequencedGroup - index; + + memset (peer -> unsequencedWindow, 0, sizeof (peer -> unsequencedWindow)); + } + else + if (peer -> unsequencedWindow [index / 32] & (1 << (index % 32))) + return 0; + + if (enet_peer_queue_incoming_command (peer, command, (const enet_uint8 *) command + sizeof (ENetProtocolSendUnsequenced), dataLength, ENET_PACKET_FLAG_UNSEQUENCED, 0) == NULL) + return -1; + + peer -> unsequencedWindow [index / 32] |= 1 << (index % 32); + + return 0; +} + +static int +enet_protocol_handle_send_unreliable (ENetHost * host, ENetPeer * peer, const ENetProtocol * command, enet_uint8 ** currentData) +{ + size_t dataLength; + + if (command -> header.channelID >= peer -> channelCount || + (peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER)) + return -1; + + dataLength = ENET_NET_TO_HOST_16 (command -> sendUnreliable.dataLength); + * currentData += dataLength; + if (dataLength > host -> maximumPacketSize || + * currentData < host -> receivedData || + * currentData > & host -> receivedData [host -> receivedDataLength]) + return -1; + + if (enet_peer_queue_incoming_command (peer, command, (const enet_uint8 *) command + sizeof (ENetProtocolSendUnreliable), dataLength, 0, 0) == NULL) + return -1; + + return 0; +} + +static int +enet_protocol_handle_send_fragment (ENetHost * host, ENetPeer * peer, const ENetProtocol * command, enet_uint8 ** currentData) +{ + enet_uint32 fragmentNumber, + fragmentCount, + fragmentOffset, + fragmentLength, + startSequenceNumber, + totalLength; + ENetChannel * channel; + enet_uint16 startWindow, currentWindow; + ENetListIterator currentCommand; + ENetIncomingCommand * startCommand = NULL; + + if (command -> header.channelID >= peer -> channelCount || + (peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER)) + return -1; + + fragmentLength = ENET_NET_TO_HOST_16 (command -> sendFragment.dataLength); + * currentData += fragmentLength; + if (fragmentLength > host -> maximumPacketSize || + * currentData < host -> receivedData || + * currentData > & host -> receivedData [host -> receivedDataLength]) + return -1; + + channel = & peer -> channels [command -> header.channelID]; + startSequenceNumber = ENET_NET_TO_HOST_16 (command -> sendFragment.startSequenceNumber); + startWindow = startSequenceNumber / ENET_PEER_RELIABLE_WINDOW_SIZE; + currentWindow = channel -> incomingReliableSequenceNumber / ENET_PEER_RELIABLE_WINDOW_SIZE; + + if (startSequenceNumber < channel -> incomingReliableSequenceNumber) + startWindow += ENET_PEER_RELIABLE_WINDOWS; + + if (startWindow < currentWindow || startWindow >= currentWindow + ENET_PEER_FREE_RELIABLE_WINDOWS - 1) + return 0; + + fragmentNumber = ENET_NET_TO_HOST_32 (command -> sendFragment.fragmentNumber); + fragmentCount = ENET_NET_TO_HOST_32 (command -> sendFragment.fragmentCount); + fragmentOffset = ENET_NET_TO_HOST_32 (command -> sendFragment.fragmentOffset); + totalLength = ENET_NET_TO_HOST_32 (command -> sendFragment.totalLength); + + if (fragmentCount > ENET_PROTOCOL_MAXIMUM_FRAGMENT_COUNT || + fragmentNumber >= fragmentCount || + totalLength > host -> maximumPacketSize || + fragmentOffset >= totalLength || + fragmentLength > totalLength - fragmentOffset) + return -1; + + for (currentCommand = enet_list_previous (enet_list_end (& channel -> incomingReliableCommands)); + currentCommand != enet_list_end (& channel -> incomingReliableCommands); + currentCommand = enet_list_previous (currentCommand)) + { + ENetIncomingCommand * incomingCommand = (ENetIncomingCommand *) currentCommand; + + if (startSequenceNumber >= channel -> incomingReliableSequenceNumber) + { + if (incomingCommand -> reliableSequenceNumber < channel -> incomingReliableSequenceNumber) + continue; + } + else + if (incomingCommand -> reliableSequenceNumber >= channel -> incomingReliableSequenceNumber) + break; + + if (incomingCommand -> reliableSequenceNumber <= startSequenceNumber) + { + if (incomingCommand -> reliableSequenceNumber < startSequenceNumber) + break; + + if ((incomingCommand -> command.header.command & ENET_PROTOCOL_COMMAND_MASK) != ENET_PROTOCOL_COMMAND_SEND_FRAGMENT || + totalLength != incomingCommand -> packet -> dataLength || + fragmentCount != incomingCommand -> fragmentCount) + return -1; + + startCommand = incomingCommand; + break; + } + } + + if (startCommand == NULL) + { + ENetProtocol hostCommand = * command; + + hostCommand.header.reliableSequenceNumber = startSequenceNumber; + + startCommand = enet_peer_queue_incoming_command (peer, & hostCommand, NULL, totalLength, ENET_PACKET_FLAG_RELIABLE, fragmentCount); + if (startCommand == NULL) + return -1; + } + + if ((startCommand -> fragments [fragmentNumber / 32] & (1 << (fragmentNumber % 32))) == 0) + { + -- startCommand -> fragmentsRemaining; + + startCommand -> fragments [fragmentNumber / 32] |= (1 << (fragmentNumber % 32)); + + if (fragmentOffset + fragmentLength > startCommand -> packet -> dataLength) + fragmentLength = startCommand -> packet -> dataLength - fragmentOffset; + + memcpy (startCommand -> packet -> data + fragmentOffset, + (enet_uint8 *) command + sizeof (ENetProtocolSendFragment), + fragmentLength); + + if (startCommand -> fragmentsRemaining <= 0) + enet_peer_dispatch_incoming_reliable_commands (peer, channel, NULL); + } + + return 0; +} + +static int +enet_protocol_handle_send_unreliable_fragment (ENetHost * host, ENetPeer * peer, const ENetProtocol * command, enet_uint8 ** currentData) +{ + enet_uint32 fragmentNumber, + fragmentCount, + fragmentOffset, + fragmentLength, + reliableSequenceNumber, + startSequenceNumber, + totalLength; + enet_uint16 reliableWindow, currentWindow; + ENetChannel * channel; + ENetListIterator currentCommand; + ENetIncomingCommand * startCommand = NULL; + + if (command -> header.channelID >= peer -> channelCount || + (peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER)) + return -1; + + fragmentLength = ENET_NET_TO_HOST_16 (command -> sendFragment.dataLength); + * currentData += fragmentLength; + if (fragmentLength > host -> maximumPacketSize || + * currentData < host -> receivedData || + * currentData > & host -> receivedData [host -> receivedDataLength]) + return -1; + + channel = & peer -> channels [command -> header.channelID]; + reliableSequenceNumber = command -> header.reliableSequenceNumber; + startSequenceNumber = ENET_NET_TO_HOST_16 (command -> sendFragment.startSequenceNumber); + + reliableWindow = reliableSequenceNumber / ENET_PEER_RELIABLE_WINDOW_SIZE; + currentWindow = channel -> incomingReliableSequenceNumber / ENET_PEER_RELIABLE_WINDOW_SIZE; + + if (reliableSequenceNumber < channel -> incomingReliableSequenceNumber) + reliableWindow += ENET_PEER_RELIABLE_WINDOWS; + + if (reliableWindow < currentWindow || reliableWindow >= currentWindow + ENET_PEER_FREE_RELIABLE_WINDOWS - 1) + return 0; + + if (reliableSequenceNumber == channel -> incomingReliableSequenceNumber && + startSequenceNumber <= channel -> incomingUnreliableSequenceNumber) + return 0; + + fragmentNumber = ENET_NET_TO_HOST_32 (command -> sendFragment.fragmentNumber); + fragmentCount = ENET_NET_TO_HOST_32 (command -> sendFragment.fragmentCount); + fragmentOffset = ENET_NET_TO_HOST_32 (command -> sendFragment.fragmentOffset); + totalLength = ENET_NET_TO_HOST_32 (command -> sendFragment.totalLength); + + if (fragmentCount > ENET_PROTOCOL_MAXIMUM_FRAGMENT_COUNT || + fragmentNumber >= fragmentCount || + totalLength > host -> maximumPacketSize || + fragmentOffset >= totalLength || + fragmentLength > totalLength - fragmentOffset) + return -1; + + for (currentCommand = enet_list_previous (enet_list_end (& channel -> incomingUnreliableCommands)); + currentCommand != enet_list_end (& channel -> incomingUnreliableCommands); + currentCommand = enet_list_previous (currentCommand)) + { + ENetIncomingCommand * incomingCommand = (ENetIncomingCommand *) currentCommand; + + if (reliableSequenceNumber >= channel -> incomingReliableSequenceNumber) + { + if (incomingCommand -> reliableSequenceNumber < channel -> incomingReliableSequenceNumber) + continue; + } + else + if (incomingCommand -> reliableSequenceNumber >= channel -> incomingReliableSequenceNumber) + break; + + if (incomingCommand -> reliableSequenceNumber < reliableSequenceNumber) + break; + + if (incomingCommand -> reliableSequenceNumber > reliableSequenceNumber) + continue; + + if (incomingCommand -> unreliableSequenceNumber <= startSequenceNumber) + { + if (incomingCommand -> unreliableSequenceNumber < startSequenceNumber) + break; + + if ((incomingCommand -> command.header.command & ENET_PROTOCOL_COMMAND_MASK) != ENET_PROTOCOL_COMMAND_SEND_UNRELIABLE_FRAGMENT || + totalLength != incomingCommand -> packet -> dataLength || + fragmentCount != incomingCommand -> fragmentCount) + return -1; + + startCommand = incomingCommand; + break; + } + } + + if (startCommand == NULL) + { + startCommand = enet_peer_queue_incoming_command (peer, command, NULL, totalLength, ENET_PACKET_FLAG_UNRELIABLE_FRAGMENT, fragmentCount); + if (startCommand == NULL) + return -1; + } + + if ((startCommand -> fragments [fragmentNumber / 32] & (1 << (fragmentNumber % 32))) == 0) + { + -- startCommand -> fragmentsRemaining; + + startCommand -> fragments [fragmentNumber / 32] |= (1 << (fragmentNumber % 32)); + + if (fragmentOffset + fragmentLength > startCommand -> packet -> dataLength) + fragmentLength = startCommand -> packet -> dataLength - fragmentOffset; + + memcpy (startCommand -> packet -> data + fragmentOffset, + (enet_uint8 *) command + sizeof (ENetProtocolSendFragment), + fragmentLength); + + if (startCommand -> fragmentsRemaining <= 0) + enet_peer_dispatch_incoming_unreliable_commands (peer, channel, NULL); + } + + return 0; +} + +static int +enet_protocol_handle_ping (ENetHost * host, ENetPeer * peer, const ENetProtocol * command) +{ + if (peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER) + return -1; + + return 0; +} + +static int +enet_protocol_handle_bandwidth_limit (ENetHost * host, ENetPeer * peer, const ENetProtocol * command) +{ + if (peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER) + return -1; + + if (peer -> incomingBandwidth != 0) + -- host -> bandwidthLimitedPeers; + + peer -> incomingBandwidth = ENET_NET_TO_HOST_32 (command -> bandwidthLimit.incomingBandwidth); + peer -> outgoingBandwidth = ENET_NET_TO_HOST_32 (command -> bandwidthLimit.outgoingBandwidth); + + if (peer -> incomingBandwidth != 0) + ++ host -> bandwidthLimitedPeers; + + if (peer -> incomingBandwidth == 0 && host -> outgoingBandwidth == 0) + peer -> windowSize = ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE; + else + if (peer -> incomingBandwidth == 0 || host -> outgoingBandwidth == 0) + peer -> windowSize = (ENET_MAX (peer -> incomingBandwidth, host -> outgoingBandwidth) / + ENET_PEER_WINDOW_SIZE_SCALE) * ENET_PROTOCOL_MINIMUM_WINDOW_SIZE; + else + peer -> windowSize = (ENET_MIN (peer -> incomingBandwidth, host -> outgoingBandwidth) / + ENET_PEER_WINDOW_SIZE_SCALE) * ENET_PROTOCOL_MINIMUM_WINDOW_SIZE; + + if (peer -> windowSize < ENET_PROTOCOL_MINIMUM_WINDOW_SIZE) + peer -> windowSize = ENET_PROTOCOL_MINIMUM_WINDOW_SIZE; + else + if (peer -> windowSize > ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE) + peer -> windowSize = ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE; + + return 0; +} + +static int +enet_protocol_handle_throttle_configure (ENetHost * host, ENetPeer * peer, const ENetProtocol * command) +{ + if (peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER) + return -1; + + peer -> packetThrottleInterval = ENET_NET_TO_HOST_32 (command -> throttleConfigure.packetThrottleInterval); + peer -> packetThrottleAcceleration = ENET_NET_TO_HOST_32 (command -> throttleConfigure.packetThrottleAcceleration); + peer -> packetThrottleDeceleration = ENET_NET_TO_HOST_32 (command -> throttleConfigure.packetThrottleDeceleration); + + return 0; +} + +static int +enet_protocol_handle_disconnect (ENetHost * host, ENetPeer * peer, const ENetProtocol * command) +{ + if (peer -> state == ENET_PEER_STATE_DISCONNECTED || peer -> state == ENET_PEER_STATE_ZOMBIE || peer -> state == ENET_PEER_STATE_ACKNOWLEDGING_DISCONNECT) + return 0; + + enet_peer_reset_queues (peer); + + if (peer -> state == ENET_PEER_STATE_CONNECTION_SUCCEEDED || peer -> state == ENET_PEER_STATE_DISCONNECTING || peer -> state == ENET_PEER_STATE_CONNECTING) + enet_protocol_dispatch_state (host, peer, ENET_PEER_STATE_ZOMBIE); + else + if (peer -> state != ENET_PEER_STATE_CONNECTED && peer -> state != ENET_PEER_STATE_DISCONNECT_LATER) + { + if (peer -> state == ENET_PEER_STATE_CONNECTION_PENDING) host -> recalculateBandwidthLimits = 1; + + enet_peer_reset (peer); + } + else + if (command -> header.command & ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE) + enet_protocol_change_state (host, peer, ENET_PEER_STATE_ACKNOWLEDGING_DISCONNECT); + else + enet_protocol_dispatch_state (host, peer, ENET_PEER_STATE_ZOMBIE); + + if (peer -> state != ENET_PEER_STATE_DISCONNECTED) + peer -> eventData = ENET_NET_TO_HOST_32 (command -> disconnect.data); + + return 0; +} + +static int +enet_protocol_handle_acknowledge (ENetHost * host, ENetEvent * event, ENetPeer * peer, const ENetProtocol * command) +{ + enet_uint32 roundTripTime, + receivedSentTime, + receivedReliableSequenceNumber; + ENetProtocolCommand commandNumber; + + if (peer -> state == ENET_PEER_STATE_DISCONNECTED || peer -> state == ENET_PEER_STATE_ZOMBIE) + return 0; + + receivedSentTime = ENET_NET_TO_HOST_16 (command -> acknowledge.receivedSentTime); + receivedSentTime |= host -> serviceTime & 0xFFFF0000; + if ((receivedSentTime & 0x8000) > (host -> serviceTime & 0x8000)) + receivedSentTime -= 0x10000; + + if (ENET_TIME_LESS (host -> serviceTime, receivedSentTime)) + return 0; + + roundTripTime = ENET_TIME_DIFFERENCE (host -> serviceTime, receivedSentTime); + roundTripTime = ENET_MAX (roundTripTime, 1); + + if (peer -> lastReceiveTime > 0) + { + enet_peer_throttle (peer, roundTripTime); + + peer -> roundTripTimeVariance -= peer -> roundTripTimeVariance / 4; + + if (roundTripTime >= peer -> roundTripTime) + { + enet_uint32 diff = roundTripTime - peer -> roundTripTime; + peer -> roundTripTimeVariance += diff / 4; + peer -> roundTripTime += diff / 8; + } + else + { + enet_uint32 diff = peer -> roundTripTime - roundTripTime; + peer -> roundTripTimeVariance += diff / 4; + peer -> roundTripTime -= diff / 8; + } + } + else + { + peer -> roundTripTime = roundTripTime; + peer -> roundTripTimeVariance = (roundTripTime + 1) / 2; + } + + if (peer -> roundTripTime < peer -> lowestRoundTripTime) + peer -> lowestRoundTripTime = peer -> roundTripTime; + + if (peer -> roundTripTimeVariance > peer -> highestRoundTripTimeVariance) + peer -> highestRoundTripTimeVariance = peer -> roundTripTimeVariance; + + if (peer -> packetThrottleEpoch == 0 || + ENET_TIME_DIFFERENCE (host -> serviceTime, peer -> packetThrottleEpoch) >= peer -> packetThrottleInterval) + { + peer -> lastRoundTripTime = peer -> lowestRoundTripTime; + peer -> lastRoundTripTimeVariance = ENET_MAX (peer -> highestRoundTripTimeVariance, 1); + peer -> lowestRoundTripTime = peer -> roundTripTime; + peer -> highestRoundTripTimeVariance = peer -> roundTripTimeVariance; + peer -> packetThrottleEpoch = host -> serviceTime; + } + + peer -> lastReceiveTime = ENET_MAX (host -> serviceTime, 1); + peer -> earliestTimeout = 0; + + receivedReliableSequenceNumber = ENET_NET_TO_HOST_16 (command -> acknowledge.receivedReliableSequenceNumber); + + commandNumber = enet_protocol_remove_sent_reliable_command (peer, receivedReliableSequenceNumber, command -> header.channelID); + + switch (peer -> state) + { + case ENET_PEER_STATE_ACKNOWLEDGING_CONNECT: + if (commandNumber != ENET_PROTOCOL_COMMAND_VERIFY_CONNECT) + return -1; + + enet_protocol_notify_connect (host, peer, event); + break; + + case ENET_PEER_STATE_DISCONNECTING: + if (commandNumber != ENET_PROTOCOL_COMMAND_DISCONNECT) + return -1; + + enet_protocol_notify_disconnect (host, peer, event); + break; + + case ENET_PEER_STATE_DISCONNECT_LATER: + if (enet_list_empty (& peer -> outgoingCommands) && + enet_list_empty (& peer -> sentReliableCommands)) + enet_peer_disconnect (peer, peer -> eventData); + break; + + default: + break; + } + + return 0; +} + +static int +enet_protocol_handle_verify_connect (ENetHost * host, ENetEvent * event, ENetPeer * peer, const ENetProtocol * command) +{ + enet_uint32 mtu, windowSize; + size_t channelCount; + + if (peer -> state != ENET_PEER_STATE_CONNECTING) + return 0; + + channelCount = ENET_NET_TO_HOST_32 (command -> verifyConnect.channelCount); + + if (channelCount < ENET_PROTOCOL_MINIMUM_CHANNEL_COUNT || channelCount > ENET_PROTOCOL_MAXIMUM_CHANNEL_COUNT || + ENET_NET_TO_HOST_32 (command -> verifyConnect.packetThrottleInterval) != peer -> packetThrottleInterval || + ENET_NET_TO_HOST_32 (command -> verifyConnect.packetThrottleAcceleration) != peer -> packetThrottleAcceleration || + ENET_NET_TO_HOST_32 (command -> verifyConnect.packetThrottleDeceleration) != peer -> packetThrottleDeceleration || + command -> verifyConnect.connectID != peer -> connectID) + { + peer -> eventData = 0; + + enet_protocol_dispatch_state (host, peer, ENET_PEER_STATE_ZOMBIE); + + return -1; + } + + enet_protocol_remove_sent_reliable_command (peer, 1, 0xFF); + + if (channelCount < peer -> channelCount) + peer -> channelCount = channelCount; + + peer -> outgoingPeerID = ENET_NET_TO_HOST_16 (command -> verifyConnect.outgoingPeerID); + peer -> incomingSessionID = command -> verifyConnect.incomingSessionID; + peer -> outgoingSessionID = command -> verifyConnect.outgoingSessionID; + + mtu = ENET_NET_TO_HOST_32 (command -> verifyConnect.mtu); + + if (mtu < ENET_PROTOCOL_MINIMUM_MTU) + mtu = ENET_PROTOCOL_MINIMUM_MTU; + else + if (mtu > ENET_PROTOCOL_MAXIMUM_MTU) + mtu = ENET_PROTOCOL_MAXIMUM_MTU; + + if (mtu < peer -> mtu) + peer -> mtu = mtu; + + windowSize = ENET_NET_TO_HOST_32 (command -> verifyConnect.windowSize); + + if (windowSize < ENET_PROTOCOL_MINIMUM_WINDOW_SIZE) + windowSize = ENET_PROTOCOL_MINIMUM_WINDOW_SIZE; + + if (windowSize > ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE) + windowSize = ENET_PROTOCOL_MAXIMUM_WINDOW_SIZE; + + if (windowSize < peer -> windowSize) + peer -> windowSize = windowSize; + + peer -> incomingBandwidth = ENET_NET_TO_HOST_32 (command -> verifyConnect.incomingBandwidth); + peer -> outgoingBandwidth = ENET_NET_TO_HOST_32 (command -> verifyConnect.outgoingBandwidth); + + enet_protocol_notify_connect (host, peer, event); + return 0; +} + +static int +enet_protocol_handle_incoming_commands (ENetHost * host, ENetEvent * event) +{ + ENetProtocolHeader * header; + ENetProtocol * command; + ENetPeer * peer; + enet_uint8 * currentData; + size_t headerSize; + enet_uint16 peerID, flags; + enet_uint8 sessionID; + + if (host -> receivedDataLength < (size_t) & ((ENetProtocolHeader *) 0) -> sentTime) + return 0; + + header = (ENetProtocolHeader *) host -> receivedData; + + peerID = ENET_NET_TO_HOST_16 (header -> peerID); + sessionID = (peerID & ENET_PROTOCOL_HEADER_SESSION_MASK) >> ENET_PROTOCOL_HEADER_SESSION_SHIFT; + flags = peerID & ENET_PROTOCOL_HEADER_FLAG_MASK; + peerID &= ~ (ENET_PROTOCOL_HEADER_FLAG_MASK | ENET_PROTOCOL_HEADER_SESSION_MASK); + + headerSize = (flags & ENET_PROTOCOL_HEADER_FLAG_SENT_TIME ? sizeof (ENetProtocolHeader) : (size_t) & ((ENetProtocolHeader *) 0) -> sentTime); + if (host -> checksum != NULL) + headerSize += sizeof (enet_uint32); + + if (peerID == ENET_PROTOCOL_MAXIMUM_PEER_ID) + peer = NULL; + else + if (peerID >= host -> peerCount) + return 0; + else + { + peer = & host -> peers [peerID]; + + if (peer -> state == ENET_PEER_STATE_DISCONNECTED || + peer -> state == ENET_PEER_STATE_ZOMBIE || + ((host -> receivedAddress.host != peer -> address.host || + host -> receivedAddress.port != peer -> address.port) && + peer -> address.host != ENET_HOST_BROADCAST) || + (peer -> outgoingPeerID < ENET_PROTOCOL_MAXIMUM_PEER_ID && + sessionID != peer -> incomingSessionID)) + return 0; + } + + if (flags & ENET_PROTOCOL_HEADER_FLAG_COMPRESSED) + { + size_t originalSize; + if (host -> compressor.context == NULL || host -> compressor.decompress == NULL) + return 0; + + originalSize = host -> compressor.decompress (host -> compressor.context, + host -> receivedData + headerSize, + host -> receivedDataLength - headerSize, + host -> packetData [1] + headerSize, + sizeof (host -> packetData [1]) - headerSize); + if (originalSize <= 0 || originalSize > sizeof (host -> packetData [1]) - headerSize) + return 0; + + memcpy (host -> packetData [1], header, headerSize); + host -> receivedData = host -> packetData [1]; + host -> receivedDataLength = headerSize + originalSize; + } + + if (host -> checksum != NULL) + { + enet_uint32 * checksum = (enet_uint32 *) & host -> receivedData [headerSize - sizeof (enet_uint32)], + desiredChecksum = * checksum; + ENetBuffer buffer; + + * checksum = peer != NULL ? peer -> connectID : 0; + + buffer.data = host -> receivedData; + buffer.dataLength = host -> receivedDataLength; + + if (host -> checksum (& buffer, 1) != desiredChecksum) + return 0; + } + + if (peer != NULL) + { + peer -> address.host = host -> receivedAddress.host; + peer -> address.port = host -> receivedAddress.port; + peer -> incomingDataTotal += host -> receivedDataLength; + } + + currentData = host -> receivedData + headerSize; + + while (currentData < & host -> receivedData [host -> receivedDataLength]) + { + enet_uint8 commandNumber; + size_t commandSize; + + command = (ENetProtocol *) currentData; + + if (currentData + sizeof (ENetProtocolCommandHeader) > & host -> receivedData [host -> receivedDataLength]) + break; + + commandNumber = command -> header.command & ENET_PROTOCOL_COMMAND_MASK; + if (commandNumber >= ENET_PROTOCOL_COMMAND_COUNT) + break; + + commandSize = commandSizes [commandNumber]; + if (commandSize == 0 || currentData + commandSize > & host -> receivedData [host -> receivedDataLength]) + break; + + currentData += commandSize; + + if (peer == NULL && commandNumber != ENET_PROTOCOL_COMMAND_CONNECT) + break; + + command -> header.reliableSequenceNumber = ENET_NET_TO_HOST_16 (command -> header.reliableSequenceNumber); + + switch (commandNumber) + { + case ENET_PROTOCOL_COMMAND_ACKNOWLEDGE: + if (enet_protocol_handle_acknowledge (host, event, peer, command)) + goto commandError; + break; + + case ENET_PROTOCOL_COMMAND_CONNECT: + if (peer != NULL) + goto commandError; + peer = enet_protocol_handle_connect (host, header, command); + if (peer == NULL) + goto commandError; + break; + + case ENET_PROTOCOL_COMMAND_VERIFY_CONNECT: + if (enet_protocol_handle_verify_connect (host, event, peer, command)) + goto commandError; + break; + + case ENET_PROTOCOL_COMMAND_DISCONNECT: + if (enet_protocol_handle_disconnect (host, peer, command)) + goto commandError; + break; + + case ENET_PROTOCOL_COMMAND_PING: + if (enet_protocol_handle_ping (host, peer, command)) + goto commandError; + break; + + case ENET_PROTOCOL_COMMAND_SEND_RELIABLE: + if (enet_protocol_handle_send_reliable (host, peer, command, & currentData)) + goto commandError; + break; + + case ENET_PROTOCOL_COMMAND_SEND_UNRELIABLE: + if (enet_protocol_handle_send_unreliable (host, peer, command, & currentData)) + goto commandError; + break; + + case ENET_PROTOCOL_COMMAND_SEND_UNSEQUENCED: + if (enet_protocol_handle_send_unsequenced (host, peer, command, & currentData)) + goto commandError; + break; + + case ENET_PROTOCOL_COMMAND_SEND_FRAGMENT: + if (enet_protocol_handle_send_fragment (host, peer, command, & currentData)) + goto commandError; + break; + + case ENET_PROTOCOL_COMMAND_BANDWIDTH_LIMIT: + if (enet_protocol_handle_bandwidth_limit (host, peer, command)) + goto commandError; + break; + + case ENET_PROTOCOL_COMMAND_THROTTLE_CONFIGURE: + if (enet_protocol_handle_throttle_configure (host, peer, command)) + goto commandError; + break; + + case ENET_PROTOCOL_COMMAND_SEND_UNRELIABLE_FRAGMENT: + if (enet_protocol_handle_send_unreliable_fragment (host, peer, command, & currentData)) + goto commandError; + break; + + default: + goto commandError; + } + + if (peer != NULL && + (command -> header.command & ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE) != 0) + { + enet_uint16 sentTime; + + if (! (flags & ENET_PROTOCOL_HEADER_FLAG_SENT_TIME)) + break; + + sentTime = ENET_NET_TO_HOST_16 (header -> sentTime); + + switch (peer -> state) + { + case ENET_PEER_STATE_DISCONNECTING: + case ENET_PEER_STATE_ACKNOWLEDGING_CONNECT: + case ENET_PEER_STATE_DISCONNECTED: + case ENET_PEER_STATE_ZOMBIE: + break; + + case ENET_PEER_STATE_ACKNOWLEDGING_DISCONNECT: + if ((command -> header.command & ENET_PROTOCOL_COMMAND_MASK) == ENET_PROTOCOL_COMMAND_DISCONNECT) + enet_peer_queue_acknowledgement (peer, command, sentTime); + break; + + default: + enet_peer_queue_acknowledgement (peer, command, sentTime); + break; + } + } + } + +commandError: + if (event != NULL && event -> type != ENET_EVENT_TYPE_NONE) + return 1; + + return 0; +} + +static int +enet_protocol_receive_incoming_commands (ENetHost * host, ENetEvent * event) +{ + int packets; + + for (packets = 0; packets < 256; ++ packets) + { + int receivedLength; + ENetBuffer buffer; + + buffer.data = host -> packetData [0]; + buffer.dataLength = sizeof (host -> packetData [0]); + + receivedLength = enet_socket_receive (host -> socket, + & host -> receivedAddress, + & buffer, + 1); + + if (receivedLength < 0) + return -1; + + if (receivedLength == 0) + return 0; + + host -> receivedData = host -> packetData [0]; + host -> receivedDataLength = receivedLength; + + host -> totalReceivedData += receivedLength; + host -> totalReceivedPackets ++; + + if (host -> intercept != NULL) + { + switch (host -> intercept (host, event)) + { + case 1: + if (event != NULL && event -> type != ENET_EVENT_TYPE_NONE) + return 1; + + continue; + + case -1: + return -1; + + default: + break; + } + } + + switch (enet_protocol_handle_incoming_commands (host, event)) + { + case 1: + return 1; + + case -1: + return -1; + + default: + break; + } + } + + return 0; +} + +static void +enet_protocol_send_acknowledgements (ENetHost * host, ENetPeer * peer) +{ + ENetProtocol * command = & host -> commands [host -> commandCount]; + ENetBuffer * buffer = & host -> buffers [host -> bufferCount]; + ENetAcknowledgement * acknowledgement; + ENetListIterator currentAcknowledgement; + enet_uint16 reliableSequenceNumber; + + currentAcknowledgement = enet_list_begin (& peer -> acknowledgements); + + while (currentAcknowledgement != enet_list_end (& peer -> acknowledgements)) + { + if (command >= & host -> commands [sizeof (host -> commands) / sizeof (ENetProtocol)] || + buffer >= & host -> buffers [sizeof (host -> buffers) / sizeof (ENetBuffer)] || + peer -> mtu - host -> packetSize < sizeof (ENetProtocolAcknowledge)) + { + host -> continueSending = 1; + + break; + } + + acknowledgement = (ENetAcknowledgement *) currentAcknowledgement; + + currentAcknowledgement = enet_list_next (currentAcknowledgement); + + buffer -> data = command; + buffer -> dataLength = sizeof (ENetProtocolAcknowledge); + + host -> packetSize += buffer -> dataLength; + + reliableSequenceNumber = ENET_HOST_TO_NET_16 (acknowledgement -> command.header.reliableSequenceNumber); + + command -> header.command = ENET_PROTOCOL_COMMAND_ACKNOWLEDGE; + command -> header.channelID = acknowledgement -> command.header.channelID; + command -> header.reliableSequenceNumber = reliableSequenceNumber; + command -> acknowledge.receivedReliableSequenceNumber = reliableSequenceNumber; + command -> acknowledge.receivedSentTime = ENET_HOST_TO_NET_16 (acknowledgement -> sentTime); + + if ((acknowledgement -> command.header.command & ENET_PROTOCOL_COMMAND_MASK) == ENET_PROTOCOL_COMMAND_DISCONNECT) + enet_protocol_dispatch_state (host, peer, ENET_PEER_STATE_ZOMBIE); + + enet_list_remove (& acknowledgement -> acknowledgementList); + enet_free (acknowledgement); + + ++ command; + ++ buffer; + } + + host -> commandCount = command - host -> commands; + host -> bufferCount = buffer - host -> buffers; +} + +static int +enet_protocol_check_timeouts (ENetHost * host, ENetPeer * peer, ENetEvent * event) +{ + ENetOutgoingCommand * outgoingCommand; + ENetListIterator currentCommand, insertPosition; + + currentCommand = enet_list_begin (& peer -> sentReliableCommands); + insertPosition = enet_list_begin (& peer -> outgoingCommands); + + while (currentCommand != enet_list_end (& peer -> sentReliableCommands)) + { + outgoingCommand = (ENetOutgoingCommand *) currentCommand; + + currentCommand = enet_list_next (currentCommand); + + if (ENET_TIME_DIFFERENCE (host -> serviceTime, outgoingCommand -> sentTime) < outgoingCommand -> roundTripTimeout) + continue; + + if (peer -> earliestTimeout == 0 || + ENET_TIME_LESS (outgoingCommand -> sentTime, peer -> earliestTimeout)) + peer -> earliestTimeout = outgoingCommand -> sentTime; + + if (peer -> earliestTimeout != 0 && + (ENET_TIME_DIFFERENCE (host -> serviceTime, peer -> earliestTimeout) >= peer -> timeoutMaximum || + (outgoingCommand -> roundTripTimeout >= outgoingCommand -> roundTripTimeoutLimit && + ENET_TIME_DIFFERENCE (host -> serviceTime, peer -> earliestTimeout) >= peer -> timeoutMinimum))) + { + enet_protocol_notify_disconnect (host, peer, event); + + return 1; + } + + if (outgoingCommand -> packet != NULL) + peer -> reliableDataInTransit -= outgoingCommand -> fragmentLength; + + ++ peer -> packetsLost; + + outgoingCommand -> roundTripTimeout *= 2; + + enet_list_insert (insertPosition, enet_list_remove (& outgoingCommand -> outgoingCommandList)); + + if (currentCommand == enet_list_begin (& peer -> sentReliableCommands) && + ! enet_list_empty (& peer -> sentReliableCommands)) + { + outgoingCommand = (ENetOutgoingCommand *) currentCommand; + + peer -> nextTimeout = outgoingCommand -> sentTime + outgoingCommand -> roundTripTimeout; + } + } + + return 0; +} + +static int +enet_protocol_check_outgoing_commands (ENetHost * host, ENetPeer * peer) +{ + ENetProtocol * command = & host -> commands [host -> commandCount]; + ENetBuffer * buffer = & host -> buffers [host -> bufferCount]; + ENetOutgoingCommand * outgoingCommand; + ENetListIterator currentCommand; + ENetChannel *channel = NULL; + enet_uint16 reliableWindow = 0; + size_t commandSize; + int windowExceeded = 0, windowWrap = 0, canPing = 1; + + currentCommand = enet_list_begin (& peer -> outgoingCommands); + + while (currentCommand != enet_list_end (& peer -> outgoingCommands)) + { + outgoingCommand = (ENetOutgoingCommand *) currentCommand; + + if (outgoingCommand -> command.header.command & ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE) + { + channel = outgoingCommand -> command.header.channelID < peer -> channelCount ? & peer -> channels [outgoingCommand -> command.header.channelID] : NULL; + reliableWindow = outgoingCommand -> reliableSequenceNumber / ENET_PEER_RELIABLE_WINDOW_SIZE; + if (channel != NULL) + { + if (! windowWrap && + outgoingCommand -> sendAttempts < 1 && + ! (outgoingCommand -> reliableSequenceNumber % ENET_PEER_RELIABLE_WINDOW_SIZE) && + (channel -> reliableWindows [(reliableWindow + ENET_PEER_RELIABLE_WINDOWS - 1) % ENET_PEER_RELIABLE_WINDOWS] >= ENET_PEER_RELIABLE_WINDOW_SIZE || + channel -> usedReliableWindows & ((((1 << (ENET_PEER_FREE_RELIABLE_WINDOWS + 2)) - 1) << reliableWindow) | + (((1 << (ENET_PEER_FREE_RELIABLE_WINDOWS + 2)) - 1) >> (ENET_PEER_RELIABLE_WINDOWS - reliableWindow))))) + windowWrap = 1; + if (windowWrap) + { + currentCommand = enet_list_next (currentCommand); + + continue; + } + } + + if (outgoingCommand -> packet != NULL) + { + if (! windowExceeded) + { + enet_uint32 windowSize = (peer -> packetThrottle * peer -> windowSize) / ENET_PEER_PACKET_THROTTLE_SCALE; + + if (peer -> reliableDataInTransit + outgoingCommand -> fragmentLength > ENET_MAX (windowSize, peer -> mtu)) + windowExceeded = 1; + } + if (windowExceeded) + { + currentCommand = enet_list_next (currentCommand); + + continue; + } + } + + canPing = 0; + } + + commandSize = commandSizes [outgoingCommand -> command.header.command & ENET_PROTOCOL_COMMAND_MASK]; + if (command >= & host -> commands [sizeof (host -> commands) / sizeof (ENetProtocol)] || + buffer + 1 >= & host -> buffers [sizeof (host -> buffers) / sizeof (ENetBuffer)] || + peer -> mtu - host -> packetSize < commandSize || + (outgoingCommand -> packet != NULL && + (enet_uint16) (peer -> mtu - host -> packetSize) < (enet_uint16) (commandSize + outgoingCommand -> fragmentLength))) + { + host -> continueSending = 1; + + break; + } + + currentCommand = enet_list_next (currentCommand); + + if (outgoingCommand -> command.header.command & ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE) + { + if (channel != NULL && outgoingCommand -> sendAttempts < 1) + { + channel -> usedReliableWindows |= 1 << reliableWindow; + ++ channel -> reliableWindows [reliableWindow]; + } + + ++ outgoingCommand -> sendAttempts; + + if (outgoingCommand -> roundTripTimeout == 0) + { + outgoingCommand -> roundTripTimeout = peer -> roundTripTime + 4 * peer -> roundTripTimeVariance; + outgoingCommand -> roundTripTimeoutLimit = peer -> timeoutLimit * outgoingCommand -> roundTripTimeout; + } + + if (enet_list_empty (& peer -> sentReliableCommands)) + peer -> nextTimeout = host -> serviceTime + outgoingCommand -> roundTripTimeout; + + enet_list_insert (enet_list_end (& peer -> sentReliableCommands), + enet_list_remove (& outgoingCommand -> outgoingCommandList)); + + outgoingCommand -> sentTime = host -> serviceTime; + + host -> headerFlags |= ENET_PROTOCOL_HEADER_FLAG_SENT_TIME; + + peer -> reliableDataInTransit += outgoingCommand -> fragmentLength; + } + else + { + if (outgoingCommand -> packet != NULL && outgoingCommand -> fragmentOffset == 0) + { + peer -> packetThrottleCounter += ENET_PEER_PACKET_THROTTLE_COUNTER; + peer -> packetThrottleCounter %= ENET_PEER_PACKET_THROTTLE_SCALE; + + if (peer -> packetThrottleCounter > peer -> packetThrottle) + { + enet_uint16 reliableSequenceNumber = outgoingCommand -> reliableSequenceNumber, + unreliableSequenceNumber = outgoingCommand -> unreliableSequenceNumber; + for (;;) + { + -- outgoingCommand -> packet -> referenceCount; + + if (outgoingCommand -> packet -> referenceCount == 0) + enet_packet_destroy (outgoingCommand -> packet); + + enet_list_remove (& outgoingCommand -> outgoingCommandList); + enet_free (outgoingCommand); + + if (currentCommand == enet_list_end (& peer -> outgoingCommands)) + break; + + outgoingCommand = (ENetOutgoingCommand *) currentCommand; + if (outgoingCommand -> reliableSequenceNumber != reliableSequenceNumber || + outgoingCommand -> unreliableSequenceNumber != unreliableSequenceNumber) + break; + + currentCommand = enet_list_next (currentCommand); + } + + continue; + } + } + + enet_list_remove (& outgoingCommand -> outgoingCommandList); + + if (outgoingCommand -> packet != NULL) + enet_list_insert (enet_list_end (& peer -> sentUnreliableCommands), outgoingCommand); + } + + buffer -> data = command; + buffer -> dataLength = commandSize; + + host -> packetSize += buffer -> dataLength; + + * command = outgoingCommand -> command; + + if (outgoingCommand -> packet != NULL) + { + ++ buffer; + + buffer -> data = outgoingCommand -> packet -> data + outgoingCommand -> fragmentOffset; + buffer -> dataLength = outgoingCommand -> fragmentLength; + + host -> packetSize += outgoingCommand -> fragmentLength; + } + else + if (! (outgoingCommand -> command.header.command & ENET_PROTOCOL_COMMAND_FLAG_ACKNOWLEDGE)) + enet_free (outgoingCommand); + + ++ peer -> packetsSent; + + ++ command; + ++ buffer; + } + + host -> commandCount = command - host -> commands; + host -> bufferCount = buffer - host -> buffers; + + if (peer -> state == ENET_PEER_STATE_DISCONNECT_LATER && + enet_list_empty (& peer -> outgoingCommands) && + enet_list_empty (& peer -> sentReliableCommands) && + enet_list_empty (& peer -> sentUnreliableCommands)) + enet_peer_disconnect (peer, peer -> eventData); + + return canPing; +} + +static int +enet_protocol_send_outgoing_commands (ENetHost * host, ENetEvent * event, int checkForTimeouts) +{ + enet_uint8 headerData [sizeof (ENetProtocolHeader) + sizeof (enet_uint32)]; + ENetProtocolHeader * header = (ENetProtocolHeader *) headerData; + ENetPeer * currentPeer; + int sentLength; + size_t shouldCompress = 0; + + host -> continueSending = 1; + + while (host -> continueSending) + for (host -> continueSending = 0, + currentPeer = host -> peers; + currentPeer < & host -> peers [host -> peerCount]; + ++ currentPeer) + { + if (currentPeer -> state == ENET_PEER_STATE_DISCONNECTED || + currentPeer -> state == ENET_PEER_STATE_ZOMBIE) + continue; + + host -> headerFlags = 0; + host -> commandCount = 0; + host -> bufferCount = 1; + host -> packetSize = sizeof (ENetProtocolHeader); + + if (! enet_list_empty (& currentPeer -> acknowledgements)) + enet_protocol_send_acknowledgements (host, currentPeer); + + if (checkForTimeouts != 0 && + ! enet_list_empty (& currentPeer -> sentReliableCommands) && + ENET_TIME_GREATER_EQUAL (host -> serviceTime, currentPeer -> nextTimeout) && + enet_protocol_check_timeouts (host, currentPeer, event) == 1) + { + if (event != NULL && event -> type != ENET_EVENT_TYPE_NONE) + return 1; + else + continue; + } + + if ((enet_list_empty (& currentPeer -> outgoingCommands) || + enet_protocol_check_outgoing_commands (host, currentPeer)) && + enet_list_empty (& currentPeer -> sentReliableCommands) && + ENET_TIME_DIFFERENCE (host -> serviceTime, currentPeer -> lastReceiveTime) >= currentPeer -> pingInterval && + currentPeer -> mtu - host -> packetSize >= sizeof (ENetProtocolPing)) + { + enet_peer_ping (currentPeer); + enet_protocol_check_outgoing_commands (host, currentPeer); + } + + if (host -> commandCount == 0) + continue; + + if (currentPeer -> packetLossEpoch == 0) + currentPeer -> packetLossEpoch = host -> serviceTime; + else + if (ENET_TIME_DIFFERENCE (host -> serviceTime, currentPeer -> packetLossEpoch) >= ENET_PEER_PACKET_LOSS_INTERVAL && + currentPeer -> packetsSent > 0) + { + enet_uint32 packetLoss = currentPeer -> packetsLost * ENET_PEER_PACKET_LOSS_SCALE / currentPeer -> packetsSent; + +#ifdef ENET_DEBUG + printf ("peer %u: %f%%+-%f%% packet loss, %u+-%u ms round trip time, %f%% throttle, %u outgoing, %u/%u incoming\n", currentPeer -> incomingPeerID, currentPeer -> packetLoss / (float) ENET_PEER_PACKET_LOSS_SCALE, currentPeer -> packetLossVariance / (float) ENET_PEER_PACKET_LOSS_SCALE, currentPeer -> roundTripTime, currentPeer -> roundTripTimeVariance, currentPeer -> packetThrottle / (float) ENET_PEER_PACKET_THROTTLE_SCALE, enet_list_size (& currentPeer -> outgoingCommands), currentPeer -> channels != NULL ? enet_list_size (& currentPeer -> channels -> incomingReliableCommands) : 0, currentPeer -> channels != NULL ? enet_list_size (& currentPeer -> channels -> incomingUnreliableCommands) : 0); +#endif + + currentPeer -> packetLossVariance = (currentPeer -> packetLossVariance * 3 + ENET_DIFFERENCE (packetLoss, currentPeer -> packetLoss)) / 4; + currentPeer -> packetLoss = (currentPeer -> packetLoss * 7 + packetLoss) / 8; + + currentPeer -> packetLossEpoch = host -> serviceTime; + currentPeer -> packetsSent = 0; + currentPeer -> packetsLost = 0; + } + + host -> buffers -> data = headerData; + if (host -> headerFlags & ENET_PROTOCOL_HEADER_FLAG_SENT_TIME) + { + header -> sentTime = ENET_HOST_TO_NET_16 (host -> serviceTime & 0xFFFF); + + host -> buffers -> dataLength = sizeof (ENetProtocolHeader); + } + else + host -> buffers -> dataLength = (size_t) & ((ENetProtocolHeader *) 0) -> sentTime; + + shouldCompress = 0; + if (host -> compressor.context != NULL && host -> compressor.compress != NULL) + { + size_t originalSize = host -> packetSize - sizeof(ENetProtocolHeader), + compressedSize = host -> compressor.compress (host -> compressor.context, + & host -> buffers [1], host -> bufferCount - 1, + originalSize, + host -> packetData [1], + originalSize); + if (compressedSize > 0 && compressedSize < originalSize) + { + host -> headerFlags |= ENET_PROTOCOL_HEADER_FLAG_COMPRESSED; + shouldCompress = compressedSize; +#ifdef ENET_DEBUG_COMPRESS + printf ("peer %u: compressed %u -> %u (%u%%)\n", currentPeer -> incomingPeerID, originalSize, compressedSize, (compressedSize * 100) / originalSize); +#endif + } + } + + if (currentPeer -> outgoingPeerID < ENET_PROTOCOL_MAXIMUM_PEER_ID) + host -> headerFlags |= currentPeer -> outgoingSessionID << ENET_PROTOCOL_HEADER_SESSION_SHIFT; + header -> peerID = ENET_HOST_TO_NET_16 (currentPeer -> outgoingPeerID | host -> headerFlags); + if (host -> checksum != NULL) + { + enet_uint32 * checksum = (enet_uint32 *) & headerData [host -> buffers -> dataLength]; + * checksum = currentPeer -> outgoingPeerID < ENET_PROTOCOL_MAXIMUM_PEER_ID ? currentPeer -> connectID : 0; + host -> buffers -> dataLength += sizeof (enet_uint32); + * checksum = host -> checksum (host -> buffers, host -> bufferCount); + } + + if (shouldCompress > 0) + { + host -> buffers [1].data = host -> packetData [1]; + host -> buffers [1].dataLength = shouldCompress; + host -> bufferCount = 2; + } + + currentPeer -> lastSendTime = host -> serviceTime; + + sentLength = enet_socket_send (host -> socket, & currentPeer -> address, host -> buffers, host -> bufferCount); + + enet_protocol_remove_sent_unreliable_commands (currentPeer); + + if (sentLength < 0) + return -1; + + host -> totalSentData += sentLength; + host -> totalSentPackets ++; + } + + return 0; +} + +/** Sends any queued packets on the host specified to its designated peers. + + @param host host to flush + @remarks this function need only be used in circumstances where one wishes to send queued packets earlier than in a call to enet_host_service(). + @ingroup host +*/ +void +enet_host_flush (ENetHost * host) +{ + host -> serviceTime = enet_time_get (); + + enet_protocol_send_outgoing_commands (host, NULL, 0); +} + +/** Checks for any queued events on the host and dispatches one if available. + + @param host host to check for events + @param event an event structure where event details will be placed if available + @retval > 0 if an event was dispatched + @retval 0 if no events are available + @retval < 0 on failure + @ingroup host +*/ +int +enet_host_check_events (ENetHost * host, ENetEvent * event) +{ + if (event == NULL) return -1; + + event -> type = ENET_EVENT_TYPE_NONE; + event -> peer = NULL; + event -> packet = NULL; + + return enet_protocol_dispatch_incoming_commands (host, event); +} + +/** Waits for events on the host specified and shuttles packets between + the host and its peers. + + @param host host to service + @param event an event structure where event details will be placed if one occurs + if event == NULL then no events will be delivered + @param timeout number of milliseconds that ENet should wait for events + @retval > 0 if an event occurred within the specified time limit + @retval 0 if no event occurred + @retval < 0 on failure + @remarks enet_host_service should be called fairly regularly for adequate performance + @ingroup host +*/ +int +enet_host_service (ENetHost * host, ENetEvent * event, enet_uint32 timeout) +{ + enet_uint32 waitCondition; + + if (event != NULL) + { + event -> type = ENET_EVENT_TYPE_NONE; + event -> peer = NULL; + event -> packet = NULL; + + switch (enet_protocol_dispatch_incoming_commands (host, event)) + { + case 1: + return 1; + + case -1: +#ifdef ENET_DEBUG + perror ("Error dispatching incoming packets"); +#endif + + return -1; + + default: + break; + } + } + + host -> serviceTime = enet_time_get (); + + timeout += host -> serviceTime; + + do + { + if (ENET_TIME_DIFFERENCE (host -> serviceTime, host -> bandwidthThrottleEpoch) >= ENET_HOST_BANDWIDTH_THROTTLE_INTERVAL) + enet_host_bandwidth_throttle (host); + + switch (enet_protocol_send_outgoing_commands (host, event, 1)) + { + case 1: + return 1; + + case -1: +#ifdef ENET_DEBUG + perror ("Error sending outgoing packets"); +#endif + + return -1; + + default: + break; + } + + switch (enet_protocol_receive_incoming_commands (host, event)) + { + case 1: + return 1; + + case -1: +#ifdef ENET_DEBUG + perror ("Error receiving incoming packets"); +#endif + + return -1; + + default: + break; + } + + switch (enet_protocol_send_outgoing_commands (host, event, 1)) + { + case 1: + return 1; + + case -1: +#ifdef ENET_DEBUG + perror ("Error sending outgoing packets"); +#endif + + return -1; + + default: + break; + } + + if (event != NULL) + { + switch (enet_protocol_dispatch_incoming_commands (host, event)) + { + case 1: + return 1; + + case -1: +#ifdef ENET_DEBUG + perror ("Error dispatching incoming packets"); +#endif + + return -1; + + default: + break; + } + } + + if (ENET_TIME_GREATER_EQUAL (host -> serviceTime, timeout)) + return 0; + + do + { + host -> serviceTime = enet_time_get (); + + if (ENET_TIME_GREATER_EQUAL (host -> serviceTime, timeout)) + return 0; + + waitCondition = ENET_SOCKET_WAIT_RECEIVE | ENET_SOCKET_WAIT_INTERRUPT; + + if (enet_socket_wait (host -> socket, & waitCondition, ENET_TIME_DIFFERENCE (timeout, host -> serviceTime)) != 0) + return -1; + } + while (waitCondition & ENET_SOCKET_WAIT_INTERRUPT); + + host -> serviceTime = enet_time_get (); + } while (waitCondition & ENET_SOCKET_WAIT_RECEIVE); + + return 0; +} + diff --git a/source/engine/thirdparty/enet/src/unix.c b/source/engine/thirdparty/enet/src/unix.c new file mode 100644 index 0000000..491a259 --- /dev/null +++ b/source/engine/thirdparty/enet/src/unix.c @@ -0,0 +1,615 @@ +/** + @file unix.c + @brief ENet Unix system specific functions +*/ +#ifndef _WIN32 + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#define ENET_BUILDING_LIB 1 +#include "enet/enet.h" + +#ifdef __APPLE__ +#ifdef HAS_POLL +#undef HAS_POLL +#endif +#ifndef HAS_FCNTL +#define HAS_FCNTL 1 +#endif +#ifndef HAS_INET_PTON +#define HAS_INET_PTON 1 +#endif +#ifndef HAS_INET_NTOP +#define HAS_INET_NTOP 1 +#endif +#ifndef HAS_MSGHDR_FLAGS +#define HAS_MSGHDR_FLAGS 1 +#endif +#ifndef HAS_SOCKLEN_T +#define HAS_SOCKLEN_T 1 +#endif +#ifndef HAS_GETADDRINFO +#define HAS_GETADDRINFO 1 +#endif +#ifndef HAS_GETNAMEINFO +#define HAS_GETNAMEINFO 1 +#endif +#endif + +#ifdef HAS_FCNTL +#include +#endif + +#ifdef HAS_POLL +#include +#endif + +#if !defined(HAS_SOCKLEN_T) && !defined(__socklen_t_defined) +typedef int socklen_t; +#endif + +#ifndef MSG_NOSIGNAL +#define MSG_NOSIGNAL 0 +#endif + +static enet_uint32 timeBase = 0; + +int +enet_initialize (void) +{ + return 0; +} + +void +enet_deinitialize (void) +{ +} + +enet_uint32 +enet_host_random_seed (void) +{ + return (enet_uint32) time (NULL); +} + +enet_uint32 +enet_time_get (void) +{ + struct timeval timeVal; + + gettimeofday (& timeVal, NULL); + + return timeVal.tv_sec * 1000 + timeVal.tv_usec / 1000 - timeBase; +} + +void +enet_time_set (enet_uint32 newTimeBase) +{ + struct timeval timeVal; + + gettimeofday (& timeVal, NULL); + + timeBase = timeVal.tv_sec * 1000 + timeVal.tv_usec / 1000 - newTimeBase; +} + +int +enet_address_set_host_ip (ENetAddress * address, const char * name) +{ +#ifdef HAS_INET_PTON + if (! inet_pton (AF_INET, name, & address -> host)) +#else + if (! inet_aton (name, (struct in_addr *) & address -> host)) +#endif + return -1; + + return 0; +} + +int +enet_address_set_host (ENetAddress * address, const char * name) +{ +#ifdef HAS_GETADDRINFO + struct addrinfo hints, * resultList = NULL, * result = NULL; + + memset (& hints, 0, sizeof (hints)); + hints.ai_family = AF_INET; + + if (getaddrinfo (name, NULL, NULL, & resultList) != 0) + return -1; + + for (result = resultList; result != NULL; result = result -> ai_next) + { + if (result -> ai_family == AF_INET && result -> ai_addr != NULL && result -> ai_addrlen >= sizeof (struct sockaddr_in)) + { + struct sockaddr_in * sin = (struct sockaddr_in *) result -> ai_addr; + + address -> host = sin -> sin_addr.s_addr; + + freeaddrinfo (resultList); + + return 0; + } + } + + if (resultList != NULL) + freeaddrinfo (resultList); +#else + struct hostent * hostEntry = NULL; +#ifdef HAS_GETHOSTBYNAME_R + struct hostent hostData; + char buffer [2048]; + int errnum; + +#if defined(linux) || defined(__linux) || defined(__linux__) || defined(__FreeBSD__) || defined(__FreeBSD_kernel__) || defined(__DragonFly__) + gethostbyname_r (name, & hostData, buffer, sizeof (buffer), & hostEntry, & errnum); +#else + hostEntry = gethostbyname_r (name, & hostData, buffer, sizeof (buffer), & errnum); +#endif +#else + hostEntry = gethostbyname (name); +#endif + + if (hostEntry != NULL && hostEntry -> h_addrtype == AF_INET) + { + address -> host = * (enet_uint32 *) hostEntry -> h_addr_list [0]; + + return 0; + } +#endif + + return enet_address_set_host_ip (address, name); +} + +int +enet_address_get_host_ip (const ENetAddress * address, char * name, size_t nameLength) +{ +#ifdef HAS_INET_NTOP + if (inet_ntop (AF_INET, & address -> host, name, nameLength) == NULL) +#else + char * addr = inet_ntoa (* (struct in_addr *) & address -> host); + if (addr != NULL) + { + size_t addrLen = strlen(addr); + if (addrLen >= nameLength) + return -1; + memcpy (name, addr, addrLen + 1); + } + else +#endif + return -1; + return 0; +} + +int +enet_address_get_host (const ENetAddress * address, char * name, size_t nameLength) +{ +#ifdef HAS_GETNAMEINFO + struct sockaddr_in sin; + int err; + + memset (& sin, 0, sizeof (struct sockaddr_in)); + + sin.sin_family = AF_INET; + sin.sin_port = ENET_HOST_TO_NET_16 (address -> port); + sin.sin_addr.s_addr = address -> host; + + err = getnameinfo ((struct sockaddr *) & sin, sizeof (sin), name, nameLength, NULL, 0, NI_NAMEREQD); + if (! err) + { + if (name != NULL && nameLength > 0 && ! memchr (name, '\0', nameLength)) + return -1; + return 0; + } + if (err != EAI_NONAME) + return -1; +#else + struct in_addr in; + struct hostent * hostEntry = NULL; +#ifdef HAS_GETHOSTBYADDR_R + struct hostent hostData; + char buffer [2048]; + int errnum; + + in.s_addr = address -> host; + +#if defined(linux) || defined(__linux) || defined(__linux__) || defined(__FreeBSD__) || defined(__FreeBSD_kernel__) || defined(__DragonFly__) + gethostbyaddr_r ((char *) & in, sizeof (struct in_addr), AF_INET, & hostData, buffer, sizeof (buffer), & hostEntry, & errnum); +#else + hostEntry = gethostbyaddr_r ((char *) & in, sizeof (struct in_addr), AF_INET, & hostData, buffer, sizeof (buffer), & errnum); +#endif +#else + in.s_addr = address -> host; + + hostEntry = gethostbyaddr ((char *) & in, sizeof (struct in_addr), AF_INET); +#endif + + if (hostEntry != NULL) + { + size_t hostLen = strlen (hostEntry -> h_name); + if (hostLen >= nameLength) + return -1; + memcpy (name, hostEntry -> h_name, hostLen + 1); + return 0; + } +#endif + + return enet_address_get_host_ip (address, name, nameLength); +} + +int +enet_socket_bind (ENetSocket socket, const ENetAddress * address) +{ + struct sockaddr_in sin; + + memset (& sin, 0, sizeof (struct sockaddr_in)); + + sin.sin_family = AF_INET; + + if (address != NULL) + { + sin.sin_port = ENET_HOST_TO_NET_16 (address -> port); + sin.sin_addr.s_addr = address -> host; + } + else + { + sin.sin_port = 0; + sin.sin_addr.s_addr = INADDR_ANY; + } + + return bind (socket, + (struct sockaddr *) & sin, + sizeof (struct sockaddr_in)); +} + +int +enet_socket_get_address (ENetSocket socket, ENetAddress * address) +{ + struct sockaddr_in sin; + socklen_t sinLength = sizeof (struct sockaddr_in); + + if (getsockname (socket, (struct sockaddr *) & sin, & sinLength) == -1) + return -1; + + address -> host = (enet_uint32) sin.sin_addr.s_addr; + address -> port = ENET_NET_TO_HOST_16 (sin.sin_port); + + return 0; +} + +int +enet_socket_listen (ENetSocket socket, int backlog) +{ + return listen (socket, backlog < 0 ? SOMAXCONN : backlog); +} + +ENetSocket +enet_socket_create (ENetSocketType type) +{ + return socket (PF_INET, type == ENET_SOCKET_TYPE_DATAGRAM ? SOCK_DGRAM : SOCK_STREAM, 0); +} + +int +enet_socket_set_option (ENetSocket socket, ENetSocketOption option, int value) +{ + int result = -1; + switch (option) + { + case ENET_SOCKOPT_NONBLOCK: +#ifdef HAS_FCNTL + result = fcntl (socket, F_SETFL, (value ? O_NONBLOCK : 0) | (fcntl (socket, F_GETFL) & ~O_NONBLOCK)); +#else + result = ioctl (socket, FIONBIO, & value); +#endif + break; + + case ENET_SOCKOPT_BROADCAST: + result = setsockopt (socket, SOL_SOCKET, SO_BROADCAST, (char *) & value, sizeof (int)); + break; + + case ENET_SOCKOPT_REUSEADDR: + result = setsockopt (socket, SOL_SOCKET, SO_REUSEADDR, (char *) & value, sizeof (int)); + break; + + case ENET_SOCKOPT_RCVBUF: + result = setsockopt (socket, SOL_SOCKET, SO_RCVBUF, (char *) & value, sizeof (int)); + break; + + case ENET_SOCKOPT_SNDBUF: + result = setsockopt (socket, SOL_SOCKET, SO_SNDBUF, (char *) & value, sizeof (int)); + break; + + case ENET_SOCKOPT_RCVTIMEO: + { + struct timeval timeVal; + timeVal.tv_sec = value / 1000; + timeVal.tv_usec = (value % 1000) * 1000; + result = setsockopt (socket, SOL_SOCKET, SO_RCVTIMEO, (char *) & timeVal, sizeof (struct timeval)); + break; + } + + case ENET_SOCKOPT_SNDTIMEO: + { + struct timeval timeVal; + timeVal.tv_sec = value / 1000; + timeVal.tv_usec = (value % 1000) * 1000; + result = setsockopt (socket, SOL_SOCKET, SO_SNDTIMEO, (char *) & timeVal, sizeof (struct timeval)); + break; + } + + case ENET_SOCKOPT_NODELAY: + result = setsockopt (socket, IPPROTO_TCP, TCP_NODELAY, (char *) & value, sizeof (int)); + break; + + default: + break; + } + return result == -1 ? -1 : 0; +} + +int +enet_socket_get_option (ENetSocket socket, ENetSocketOption option, int * value) +{ + int result = -1; + socklen_t len; + switch (option) + { + case ENET_SOCKOPT_ERROR: + len = sizeof (int); + result = getsockopt (socket, SOL_SOCKET, SO_ERROR, value, & len); + break; + + default: + break; + } + return result == -1 ? -1 : 0; +} + +int +enet_socket_connect (ENetSocket socket, const ENetAddress * address) +{ + struct sockaddr_in sin; + int result; + + memset (& sin, 0, sizeof (struct sockaddr_in)); + + sin.sin_family = AF_INET; + sin.sin_port = ENET_HOST_TO_NET_16 (address -> port); + sin.sin_addr.s_addr = address -> host; + + result = connect (socket, (struct sockaddr *) & sin, sizeof (struct sockaddr_in)); + if (result == -1 && errno == EINPROGRESS) + return 0; + + return result; +} + +ENetSocket +enet_socket_accept (ENetSocket socket, ENetAddress * address) +{ + int result; + struct sockaddr_in sin; + socklen_t sinLength = sizeof (struct sockaddr_in); + + result = accept (socket, + address != NULL ? (struct sockaddr *) & sin : NULL, + address != NULL ? & sinLength : NULL); + + if (result == -1) + return ENET_SOCKET_NULL; + + if (address != NULL) + { + address -> host = (enet_uint32) sin.sin_addr.s_addr; + address -> port = ENET_NET_TO_HOST_16 (sin.sin_port); + } + + return result; +} + +int +enet_socket_shutdown (ENetSocket socket, ENetSocketShutdown how) +{ + return shutdown (socket, (int) how); +} + +void +enet_socket_destroy (ENetSocket socket) +{ + if (socket != -1) + close (socket); +} + +int +enet_socket_send (ENetSocket socket, + const ENetAddress * address, + const ENetBuffer * buffers, + size_t bufferCount) +{ + struct msghdr msgHdr; + struct sockaddr_in sin; + int sentLength; + + memset (& msgHdr, 0, sizeof (struct msghdr)); + + if (address != NULL) + { + memset (& sin, 0, sizeof (struct sockaddr_in)); + + sin.sin_family = AF_INET; + sin.sin_port = ENET_HOST_TO_NET_16 (address -> port); + sin.sin_addr.s_addr = address -> host; + + msgHdr.msg_name = & sin; + msgHdr.msg_namelen = sizeof (struct sockaddr_in); + } + + msgHdr.msg_iov = (struct iovec *) buffers; + msgHdr.msg_iovlen = bufferCount; + + sentLength = sendmsg (socket, & msgHdr, MSG_NOSIGNAL); + + if (sentLength == -1) + { + if (errno == EWOULDBLOCK) + return 0; + + return -1; + } + + return sentLength; +} + +int +enet_socket_receive (ENetSocket socket, + ENetAddress * address, + ENetBuffer * buffers, + size_t bufferCount) +{ + struct msghdr msgHdr; + struct sockaddr_in sin; + int recvLength; + + memset (& msgHdr, 0, sizeof (struct msghdr)); + + if (address != NULL) + { + msgHdr.msg_name = & sin; + msgHdr.msg_namelen = sizeof (struct sockaddr_in); + } + + msgHdr.msg_iov = (struct iovec *) buffers; + msgHdr.msg_iovlen = bufferCount; + + recvLength = recvmsg (socket, & msgHdr, MSG_NOSIGNAL); + + if (recvLength == -1) + { + if (errno == EWOULDBLOCK) + return 0; + + return -1; + } + +#ifdef HAS_MSGHDR_FLAGS + if (msgHdr.msg_flags & MSG_TRUNC) + return -1; +#endif + + if (address != NULL) + { + address -> host = (enet_uint32) sin.sin_addr.s_addr; + address -> port = ENET_NET_TO_HOST_16 (sin.sin_port); + } + + return recvLength; +} + +int +enet_socketset_select (ENetSocket maxSocket, ENetSocketSet * readSet, ENetSocketSet * writeSet, enet_uint32 timeout) +{ + struct timeval timeVal; + + timeVal.tv_sec = timeout / 1000; + timeVal.tv_usec = (timeout % 1000) * 1000; + + return select (maxSocket + 1, readSet, writeSet, NULL, & timeVal); +} + +int +enet_socket_wait (ENetSocket socket, enet_uint32 * condition, enet_uint32 timeout) +{ +#ifdef HAS_POLL + struct pollfd pollSocket; + int pollCount; + + pollSocket.fd = socket; + pollSocket.events = 0; + + if (* condition & ENET_SOCKET_WAIT_SEND) + pollSocket.events |= POLLOUT; + + if (* condition & ENET_SOCKET_WAIT_RECEIVE) + pollSocket.events |= POLLIN; + + pollCount = poll (& pollSocket, 1, timeout); + + if (pollCount < 0) + { + if (errno == EINTR && * condition & ENET_SOCKET_WAIT_INTERRUPT) + { + * condition = ENET_SOCKET_WAIT_INTERRUPT; + + return 0; + } + + return -1; + } + + * condition = ENET_SOCKET_WAIT_NONE; + + if (pollCount == 0) + return 0; + + if (pollSocket.revents & POLLOUT) + * condition |= ENET_SOCKET_WAIT_SEND; + + if (pollSocket.revents & POLLIN) + * condition |= ENET_SOCKET_WAIT_RECEIVE; + + return 0; +#else + fd_set readSet, writeSet; + struct timeval timeVal; + int selectCount; + + timeVal.tv_sec = timeout / 1000; + timeVal.tv_usec = (timeout % 1000) * 1000; + + FD_ZERO (& readSet); + FD_ZERO (& writeSet); + + if (* condition & ENET_SOCKET_WAIT_SEND) + FD_SET (socket, & writeSet); + + if (* condition & ENET_SOCKET_WAIT_RECEIVE) + FD_SET (socket, & readSet); + + selectCount = select (socket + 1, & readSet, & writeSet, NULL, & timeVal); + + if (selectCount < 0) + { + if (errno == EINTR && * condition & ENET_SOCKET_WAIT_INTERRUPT) + { + * condition = ENET_SOCKET_WAIT_INTERRUPT; + + return 0; + } + + return -1; + } + + * condition = ENET_SOCKET_WAIT_NONE; + + if (selectCount == 0) + return 0; + + if (FD_ISSET (socket, & writeSet)) + * condition |= ENET_SOCKET_WAIT_SEND; + + if (FD_ISSET (socket, & readSet)) + * condition |= ENET_SOCKET_WAIT_RECEIVE; + + return 0; +#endif +} + +#endif + diff --git a/source/engine/thirdparty/enet/src/win32.c b/source/engine/thirdparty/enet/src/win32.c new file mode 100644 index 0000000..eebdb03 --- /dev/null +++ b/source/engine/thirdparty/enet/src/win32.c @@ -0,0 +1,442 @@ +/** + @file win32.c + @brief ENet Win32 system specific functions +*/ +#ifdef _WIN32 + +#define ENET_BUILDING_LIB 1 +#include "enet/enet.h" +#include +#include + +static enet_uint32 timeBase = 0; + +int +enet_initialize (void) +{ + WORD versionRequested = MAKEWORD (1, 1); + WSADATA wsaData; + + if (WSAStartup (versionRequested, & wsaData)) + return -1; + + if (LOBYTE (wsaData.wVersion) != 1|| + HIBYTE (wsaData.wVersion) != 1) + { + WSACleanup (); + + return -1; + } + + timeBeginPeriod (1); + + return 0; +} + +void +enet_deinitialize (void) +{ + timeEndPeriod (1); + + WSACleanup (); +} + +enet_uint32 +enet_host_random_seed (void) +{ + return (enet_uint32) timeGetTime (); +} + +enet_uint32 +enet_time_get (void) +{ + return (enet_uint32) timeGetTime () - timeBase; +} + +void +enet_time_set (enet_uint32 newTimeBase) +{ + timeBase = (enet_uint32) timeGetTime () - newTimeBase; +} + +int +enet_address_set_host_ip (ENetAddress * address, const char * name) +{ + enet_uint8 vals [4] = { 0, 0, 0, 0 }; + int i; + + for (i = 0; i < 4; ++ i) + { + const char * next = name + 1; + if (* name != '0') + { + long val = strtol (name, (char **) & next, 10); + if (val < 0 || val > 255 || next == name || next - name > 3) + return -1; + vals [i] = (enet_uint8) val; + } + + if (* next != (i < 3 ? '.' : '\0')) + return -1; + name = next + 1; + } + + memcpy (& address -> host, vals, sizeof (enet_uint32)); + return 0; +} + +int +enet_address_set_host (ENetAddress * address, const char * name) +{ + struct hostent * hostEntry; + + hostEntry = gethostbyname (name); + if (hostEntry == NULL || + hostEntry -> h_addrtype != AF_INET) + return enet_address_set_host_ip (address, name); + + address -> host = * (enet_uint32 *) hostEntry -> h_addr_list [0]; + + return 0; +} + +int +enet_address_get_host_ip (const ENetAddress * address, char * name, size_t nameLength) +{ + char * addr = inet_ntoa (* (struct in_addr *) & address -> host); + if (addr == NULL) + return -1; + else + { + size_t addrLen = strlen(addr); + if (addrLen >= nameLength) + return -1; + memcpy (name, addr, addrLen + 1); + } + return 0; +} + +int +enet_address_get_host (const ENetAddress * address, char * name, size_t nameLength) +{ + struct in_addr in; + struct hostent * hostEntry; + + in.s_addr = address -> host; + + hostEntry = gethostbyaddr ((char *) & in, sizeof (struct in_addr), AF_INET); + if (hostEntry == NULL) + return enet_address_get_host_ip (address, name, nameLength); + else + { + size_t hostLen = strlen (hostEntry -> h_name); + if (hostLen >= nameLength) + return -1; + memcpy (name, hostEntry -> h_name, hostLen + 1); + } + + return 0; +} + +int +enet_socket_bind (ENetSocket socket, const ENetAddress * address) +{ + struct sockaddr_in sin; + + memset (& sin, 0, sizeof (struct sockaddr_in)); + + sin.sin_family = AF_INET; + + if (address != NULL) + { + sin.sin_port = ENET_HOST_TO_NET_16 (address -> port); + sin.sin_addr.s_addr = address -> host; + } + else + { + sin.sin_port = 0; + sin.sin_addr.s_addr = INADDR_ANY; + } + + return bind (socket, + (struct sockaddr *) & sin, + sizeof (struct sockaddr_in)) == SOCKET_ERROR ? -1 : 0; +} + +int +enet_socket_get_address (ENetSocket socket, ENetAddress * address) +{ + struct sockaddr_in sin; + int sinLength = sizeof (struct sockaddr_in); + + if (getsockname (socket, (struct sockaddr *) & sin, & sinLength) == -1) + return -1; + + address -> host = (enet_uint32) sin.sin_addr.s_addr; + address -> port = ENET_NET_TO_HOST_16 (sin.sin_port); + + return 0; +} + +int +enet_socket_listen (ENetSocket socket, int backlog) +{ + return listen (socket, backlog < 0 ? SOMAXCONN : backlog) == SOCKET_ERROR ? -1 : 0; +} + +ENetSocket +enet_socket_create (ENetSocketType type) +{ + return socket (PF_INET, type == ENET_SOCKET_TYPE_DATAGRAM ? SOCK_DGRAM : SOCK_STREAM, 0); +} + +int +enet_socket_set_option (ENetSocket socket, ENetSocketOption option, int value) +{ + int result = SOCKET_ERROR; + switch (option) + { + case ENET_SOCKOPT_NONBLOCK: + { + u_long nonBlocking = (u_long) value; + result = ioctlsocket (socket, FIONBIO, & nonBlocking); + break; + } + + case ENET_SOCKOPT_BROADCAST: + result = setsockopt (socket, SOL_SOCKET, SO_BROADCAST, (char *) & value, sizeof (int)); + break; + + case ENET_SOCKOPT_REUSEADDR: + result = setsockopt (socket, SOL_SOCKET, SO_REUSEADDR, (char *) & value, sizeof (int)); + break; + + case ENET_SOCKOPT_RCVBUF: + result = setsockopt (socket, SOL_SOCKET, SO_RCVBUF, (char *) & value, sizeof (int)); + break; + + case ENET_SOCKOPT_SNDBUF: + result = setsockopt (socket, SOL_SOCKET, SO_SNDBUF, (char *) & value, sizeof (int)); + break; + + case ENET_SOCKOPT_RCVTIMEO: + result = setsockopt (socket, SOL_SOCKET, SO_RCVTIMEO, (char *) & value, sizeof (int)); + break; + + case ENET_SOCKOPT_SNDTIMEO: + result = setsockopt (socket, SOL_SOCKET, SO_SNDTIMEO, (char *) & value, sizeof (int)); + break; + + case ENET_SOCKOPT_NODELAY: + result = setsockopt (socket, IPPROTO_TCP, TCP_NODELAY, (char *) & value, sizeof (int)); + break; + + default: + break; + } + return result == SOCKET_ERROR ? -1 : 0; +} + +int +enet_socket_get_option (ENetSocket socket, ENetSocketOption option, int * value) +{ + int result = SOCKET_ERROR, len; + switch (option) + { + case ENET_SOCKOPT_ERROR: + len = sizeof(int); + result = getsockopt (socket, SOL_SOCKET, SO_ERROR, (char *) value, & len); + break; + + default: + break; + } + return result == SOCKET_ERROR ? -1 : 0; +} + +int +enet_socket_connect (ENetSocket socket, const ENetAddress * address) +{ + struct sockaddr_in sin; + int result; + + memset (& sin, 0, sizeof (struct sockaddr_in)); + + sin.sin_family = AF_INET; + sin.sin_port = ENET_HOST_TO_NET_16 (address -> port); + sin.sin_addr.s_addr = address -> host; + + result = connect (socket, (struct sockaddr *) & sin, sizeof (struct sockaddr_in)); + if (result == SOCKET_ERROR && WSAGetLastError () != WSAEWOULDBLOCK) + return -1; + + return 0; +} + +ENetSocket +enet_socket_accept (ENetSocket socket, ENetAddress * address) +{ + SOCKET result; + struct sockaddr_in sin; + int sinLength = sizeof (struct sockaddr_in); + + result = accept (socket, + address != NULL ? (struct sockaddr *) & sin : NULL, + address != NULL ? & sinLength : NULL); + + if (result == INVALID_SOCKET) + return ENET_SOCKET_NULL; + + if (address != NULL) + { + address -> host = (enet_uint32) sin.sin_addr.s_addr; + address -> port = ENET_NET_TO_HOST_16 (sin.sin_port); + } + + return result; +} + +int +enet_socket_shutdown (ENetSocket socket, ENetSocketShutdown how) +{ + return shutdown (socket, (int) how) == SOCKET_ERROR ? -1 : 0; +} + +void +enet_socket_destroy (ENetSocket socket) +{ + if (socket != INVALID_SOCKET) + closesocket (socket); +} + +int +enet_socket_send (ENetSocket socket, + const ENetAddress * address, + const ENetBuffer * buffers, + size_t bufferCount) +{ + struct sockaddr_in sin; + DWORD sentLength = 0; + + if (address != NULL) + { + memset (& sin, 0, sizeof (struct sockaddr_in)); + + sin.sin_family = AF_INET; + sin.sin_port = ENET_HOST_TO_NET_16 (address -> port); + sin.sin_addr.s_addr = address -> host; + } + + if (WSASendTo (socket, + (LPWSABUF) buffers, + (DWORD) bufferCount, + & sentLength, + 0, + address != NULL ? (struct sockaddr *) & sin : NULL, + address != NULL ? sizeof (struct sockaddr_in) : 0, + NULL, + NULL) == SOCKET_ERROR) + { + if (WSAGetLastError () == WSAEWOULDBLOCK) + return 0; + + return -1; + } + + return (int) sentLength; +} + +int +enet_socket_receive (ENetSocket socket, + ENetAddress * address, + ENetBuffer * buffers, + size_t bufferCount) +{ + INT sinLength = sizeof (struct sockaddr_in); + DWORD flags = 0, + recvLength = 0; + struct sockaddr_in sin; + + if (WSARecvFrom (socket, + (LPWSABUF) buffers, + (DWORD) bufferCount, + & recvLength, + & flags, + address != NULL ? (struct sockaddr *) & sin : NULL, + address != NULL ? & sinLength : NULL, + NULL, + NULL) == SOCKET_ERROR) + { + switch (WSAGetLastError ()) + { + case WSAEWOULDBLOCK: + case WSAECONNRESET: + return 0; + } + + return -1; + } + + if (flags & MSG_PARTIAL) + return -1; + + if (address != NULL) + { + address -> host = (enet_uint32) sin.sin_addr.s_addr; + address -> port = ENET_NET_TO_HOST_16 (sin.sin_port); + } + + return (int) recvLength; +} + +int +enet_socketset_select (ENetSocket maxSocket, ENetSocketSet * readSet, ENetSocketSet * writeSet, enet_uint32 timeout) +{ + struct timeval timeVal; + + timeVal.tv_sec = timeout / 1000; + timeVal.tv_usec = (timeout % 1000) * 1000; + + return select (maxSocket + 1, readSet, writeSet, NULL, & timeVal); +} + +int +enet_socket_wait (ENetSocket socket, enet_uint32 * condition, enet_uint32 timeout) +{ + fd_set readSet, writeSet; + struct timeval timeVal; + int selectCount; + + timeVal.tv_sec = timeout / 1000; + timeVal.tv_usec = (timeout % 1000) * 1000; + + FD_ZERO (& readSet); + FD_ZERO (& writeSet); + + if (* condition & ENET_SOCKET_WAIT_SEND) + FD_SET (socket, & writeSet); + + if (* condition & ENET_SOCKET_WAIT_RECEIVE) + FD_SET (socket, & readSet); + + selectCount = select (socket + 1, & readSet, & writeSet, NULL, & timeVal); + + if (selectCount < 0) + return -1; + + * condition = ENET_SOCKET_WAIT_NONE; + + if (selectCount == 0) + return 0; + + if (FD_ISSET (socket, & writeSet)) + * condition |= ENET_SOCKET_WAIT_SEND; + + if (FD_ISSET (socket, & readSet)) + * condition |= ENET_SOCKET_WAIT_RECEIVE; + + return 0; +} + +#endif + diff --git a/source/engine/thirdparty/pl_mpeg/README.md b/source/engine/thirdparty/pl_mpeg/README.md new file mode 100644 index 0000000..915a702 --- /dev/null +++ b/source/engine/thirdparty/pl_mpeg/README.md @@ -0,0 +1,55 @@ +# PL_MPEG - MPEG1 Video decoder, MP2 Audio decoder, MPEG-PS demuxer + +Single-file MIT licensed library for C/C++ + +See [pl_mpeg.h](https://github.com/phoboslab/pl_mpeg/blob/master/pl_mpeg.h) for +the documentation. + + +## Why? + +This is meant as a simple way to get video playback into your app or game. Other +solutions, such as ffmpeg require huge libraries and a lot of glue code. + +MPEG1 is an old and inefficient codec, but it's still good enough for many use +cases. All patents related to MPEG1 and MP2 have expired, so it's completely +free now. + +This library does not make use of any SIMD instructions, but because of +the relative simplicity of the codec it still manages to decode 4k60fps video +on a single CPU core (on my i7-6700k at least). + + +## Example Usage + +- [pl_mpeg_extract_frames.c](https://github.com/phoboslab/pl_mpeg/blob/master/pl_mpeg_extract_frames.c) +extracts all frames from a video and saves them as PNG. + - [pl_mpeg_player.c](https://github.com/phoboslab/pl_mpeg/blob/master/pl_mpeg_player.c) +implements a video player using SDL2 and OpenGL for rendering. + + + +## Encoding for PL_MPEG + +Most [MPEG-PS](https://en.wikipedia.org/wiki/MPEG_program_stream) (`.mpg`) files +containing MPEG1 Video ("mpeg1") and MPEG1 Audio Layer II ("mp2") streams should +work with PL_MPEG. Note that `.mpg` files can also contain MPEG2 Video, which is +not supported by this library. + +You can encode video in a suitable format using ffmpeg: + +``` +ffmpeg -i input.mp4 -c:v mpeg1video -c:a mp2 -format mpeg output.mpg +``` + +If you just want to quickly test the library, try this file: + +https://phoboslab.org/files/bjork-all-is-full-of-love.mpg + + +## Limitations + +- no error reporting. PL_MPEG will silently ignore any invalid data. +- the pts (presentation time stamp) for packets in the MPEG-PS container is +ignored. This may cause sync issues with some files. +- bugs, probably. \ No newline at end of file diff --git a/source/engine/thirdparty/pl_mpeg/pl_mpeg.h b/source/engine/thirdparty/pl_mpeg/pl_mpeg.h new file mode 100644 index 0000000..7539fd3 --- /dev/null +++ b/source/engine/thirdparty/pl_mpeg/pl_mpeg.h @@ -0,0 +1,4273 @@ +/* +PL_MPEG - MPEG1 Video decoder, MP2 Audio decoder, MPEG-PS demuxer + +Dominic Szablewski - https://phoboslab.org + + +-- LICENSE: The MIT License(MIT) + +Copyright(c) 2019 Dominic Szablewski + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files(the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and / or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions : +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + + + + +-- Synopsis + +// Define `PL_MPEG_IMPLEMENTATION` in *one* C/C++ file before including this +// library to create the implementation. + +#define PL_MPEG_IMPLEMENTATION +#include "plmpeg.h" + +// This function gets called for each decoded video frame +void my_video_callback(plm_t *plm, plm_frame_t *frame, void *user) { + // Do something with frame->y.data, frame->cr.data, frame->cb.data +} + +// This function gets called for each decoded audio frame +void my_audio_callback(plm_t *plm, plm_samples_t *frame, void *user) { + // Do something with samples->interleaved +} + +// Load a .mpg (MPEG Program Stream) file +plm_t *plm = plm_create_with_filename("some-file.mpg"); + +// Install the video & audio decode callbacks +plm_set_video_decode_callback(plm, my_video_callback, my_data); +plm_set_audio_decode_callback(plm, my_audio_callback, my_data); + + +// Decode +do { + plm_decode(plm, time_since_last_call); +} while (!plm_has_ended(plm)); + +// All done +plm_destroy(plm); + + + +-- Documentation + +This library provides several interfaces to load, demux and decode MPEG video +and audio data. A high-level API combines the demuxer, video & audio decoders +in an easy to use wrapper. + +Lower-level APIs for accessing the demuxer, video decoder and audio decoder, +as well as providing different data sources are also available. + +Interfaces are written in an object orientet style, meaning you create object +instances via various different constructor functions (plm_*create()), +do some work on them and later dispose them via plm_*destroy(). + +plm_* ......... the high-level interface, combining demuxer and decoders +plm_buffer_* .. the data source used by all interfaces +plm_demux_* ... the MPEG-PS demuxer +plm_video_* ... the MPEG1 Video ("mpeg1") decoder +plm_audio_* ... the MPEG1 Audio Layer II ("mp2") decoder + + +With the high-level interface you have two options to decode video & audio: + + 1. Use plm_decode() and just hand over the delta time since the last call. + It will decode everything needed and call your callbacks (specified through + plm_set_{video|audio}_decode_callback()) any number of times. + + 2. Use plm_decode_video() and plm_decode_audio() to decode exactly one + frame of video or audio data at a time. How you handle the synchronization + of both streams is up to you. + +If you only want to decode video *or* audio through these functions, you should +disable the other stream (plm_set_{video|audio}_enabled(FALSE)) + +Video data is decoded into a struct with all 3 planes (Y, Cr, Cb) stored in +separate buffers. You can either convert this to RGB on the CPU (slow) via the +plm_frame_to_rgb() function or do it on the GPU with the following matrix: + +mat4 bt601 = mat4( + 1.16438, 0.00000, 1.59603, -0.87079, + 1.16438, -0.39176, -0.81297, 0.52959, + 1.16438, 2.01723, 0.00000, -1.08139, + 0, 0, 0, 1 +); +gl_FragColor = vec4(y, cb, cr, 1.0) * bt601; + +Audio data is decoded into a struct with either one single float array with the +samples for the left and right channel interleaved, or if the +PLM_AUDIO_SEPARATE_CHANNELS is defined *before* including this library, into +two separate float arrays - one for each channel. + + +Data can be supplied to the high level interface, the demuxer and the decoders +in three different ways: + + 1. Using plm_create_from_filename() or with a file handle with + plm_create_from_file(). + + 2. Using plm_create_with_memory() and supplying a pointer to memory that + contains the whole file. + + 3. Using plm_create_with_buffer(), supplying your own plm_buffer_t instance and + periodically writing to this buffer. + +When using your own plm_buffer_t instance, you can fill this buffer using +plm_buffer_write(). You can either monitor plm_buffer_get_remaining() and push +data when appropriate, or install a callback on the buffer with +plm_buffer_set_load_callback() that gets called whenever the buffer needs more +data. + +A buffer created with plm_buffer_create_with_capacity() is treated as a ring +buffer, meaning that data that has already been read, will be discarded. In +contrast, a buffer created with plm_buffer_create_for_appending() will keep all +data written to it in memory. This enables seeking in the already loaded data. + + +There should be no need to use the lower level plm_demux_*, plm_video_* and +plm_audio_* functions, if all you want to do is read/decode an MPEG-PS file. +However, if you get raw mpeg1video data or raw mp2 audio data from a different +source, these functions can be used to decode the raw data directly. Similarly, +if you only want to analyze an MPEG-PS file or extract raw video or audio +packets from it, you can use the plm_demux_* functions. + + +This library uses malloc(), realloc() and free() to manage memory. Typically +all allocation happens up-front when creating the interface. However, the +default buffer size may be too small for certain inputs. In these cases plmpeg +will realloc() the buffer with a larger size whenever needed. You can configure +the default buffer size by defining PLM_BUFFER_DEFAULT_SIZE *before* +including this library. + + +See below for detailed the API documentation. + +*/ + + +#ifndef PL_MPEG_H +#define PL_MPEG_H + +#include +#include + + +#ifdef __cplusplus +extern "C" { +#endif + +// ----------------------------------------------------------------------------- +// Public Data Types + + +// Object types for the various interfaces + +typedef struct plm_t plm_t; +typedef struct plm_buffer_t plm_buffer_t; +typedef struct plm_demux_t plm_demux_t; +typedef struct plm_video_t plm_video_t; +typedef struct plm_audio_t plm_audio_t; + + +// Demuxed MPEG PS packet +// The type maps directly to the various MPEG-PES start codes. PTS is the +// presentation time stamp of the packet in seconds. Note that not all packets +// have a PTS value, indicated by PLM_PACKET_INVALID_TS. + +#define PLM_PACKET_INVALID_TS -1 + +typedef struct { + int type; + double pts; + size_t length; + uint8_t *data; +} plm_packet_t; + + +// Decoded Video Plane +// The byte length of the data is width * height. Note that different planes +// have different sizes: the Luma plane (Y) is double the size of each of +// the two Chroma planes (Cr, Cb) - i.e. 4 times the byte length. +// Also note that the size of the plane does *not* denote the size of the +// displayed frame. The sizes of planes are always rounded up to the nearest +// macroblock (16px). + +typedef struct { + unsigned int width; + unsigned int height; + uint8_t *data; +} plm_plane_t; + + +// Decoded Video Frame +// width and height denote the desired display size of the frame. This may be +// different from the internal size of the 3 planes. + +typedef struct { + double time; + unsigned int width; + unsigned int height; + plm_plane_t y; + plm_plane_t cr; + plm_plane_t cb; +} plm_frame_t; + + +// Callback function type for decoded video frames used by the high-level +// plm_* interface + +typedef void(*plm_video_decode_callback) + (plm_t *self, plm_frame_t *frame, void *user); + + +// Decoded Audio Samples +// Samples are stored as normalized (-1, 1) float either interleaved, or if +// PLM_AUDIO_SEPARATE_CHANNELS is defined, in two separate arrays. +// The `count` is always PLM_AUDIO_SAMPLES_PER_FRAME and just there for +// convenience. + +#define PLM_AUDIO_SAMPLES_PER_FRAME 1152 + +typedef struct { + double time; + unsigned int count; + #ifdef PLM_AUDIO_SEPARATE_CHANNELS + float left[PLM_AUDIO_SAMPLES_PER_FRAME]; + float right[PLM_AUDIO_SAMPLES_PER_FRAME]; + #else + float interleaved[PLM_AUDIO_SAMPLES_PER_FRAME * 2]; + #endif +} plm_samples_t; + + +// Callback function type for decoded audio samples used by the high-level +// plm_* interface + +typedef void(*plm_audio_decode_callback) + (plm_t *self, plm_samples_t *samples, void *user); + + +// Callback function for plm_buffer when it needs more data + +typedef void(*plm_buffer_load_callback)(plm_buffer_t *self, void *user); + + + +// ----------------------------------------------------------------------------- +// plm_* public API +// High-Level API for loading/demuxing/decoding MPEG-PS data + + +// Create a plmpeg instance with a filename. Returns NULL if the file could not +// be opened. + +plm_t *plm_create_with_filename(const char *filename); + + +// Create a plmpeg instance with a file handle. Pass TRUE to close_when_done to +// let plmpeg call fclose() on the handle when plm_destroy() is called. + +plm_t *plm_create_with_file(FILE *fh, int close_when_done); + + +// Create a plmpeg instance with a pointer to memory as source. This assumes the +// whole file is in memory. The memory is not copied. Pass TRUE to +// free_when_done to let plmpeg call free() on the pointer when plm_destroy() +// is called. + +plm_t *plm_create_with_memory(uint8_t *bytes, size_t length, int free_when_done); + + +// Create a plmpeg instance with a plm_buffer as source. Pass TRUE to +// destroy_when_done to let plmpeg call plm_buffer_destroy() on the buffer when +// plm_destroy() is called. + +plm_t *plm_create_with_buffer(plm_buffer_t *buffer, int destroy_when_done); + + +// Destroy a plmpeg instance and free all data. + +void plm_destroy(plm_t *self); + + +// Get whether we have headers on all available streams and we can accurately +// report the number of video/audio streams, video dimensions, framerate and +// audio samplerate. +// This returns FALSE if the file is not an MPEG-PS file or - when not using a +// file as source - when not enough data is available yet. + +int plm_has_headers(plm_t *self); + + +// Get or set whether video decoding is enabled. Default TRUE. + +int plm_get_video_enabled(plm_t *self); +void plm_set_video_enabled(plm_t *self, int enabled); + + +// Get the number of video streams (0--1) reported in the system header. + +int plm_get_num_video_streams(plm_t *self); + + +// Get the display width/height of the video stream. + +int plm_get_width(plm_t *self); +int plm_get_height(plm_t *self); + + +// Get the framerate of the video stream in frames per second. + +double plm_get_framerate(plm_t *self); + + +// Get or set whether audio decoding is enabled. Default TRUE. + +int plm_get_audio_enabled(plm_t *self); +void plm_set_audio_enabled(plm_t *self, int enabled); + + +// Get the number of audio streams (0--4) reported in the system header. + +int plm_get_num_audio_streams(plm_t *self); + + +// Set the desired audio stream (0--3). Default 0. + +void plm_set_audio_stream(plm_t *self, int stream_index); + + +// Get the samplerate of the audio stream in samples per second. + +int plm_get_samplerate(plm_t *self); + + +// Get or set the audio lead time in seconds - the time in which audio samples +// are decoded in advance (or behind) the video decode time. Typically this +// should be set to the duration of the buffer of the audio API that you use +// for output. E.g. for SDL2: (SDL_AudioSpec.samples / samplerate) + +double plm_get_audio_lead_time(plm_t *self); +void plm_set_audio_lead_time(plm_t *self, double lead_time); + + +// Get the current internal time in seconds. + +double plm_get_time(plm_t *self); + + +// Get the video duration of the underlying source in seconds. + +double plm_get_duration(plm_t *self); + + +// Rewind all buffers back to the beginning. + +void plm_rewind(plm_t *self); + + +// Get or set looping. Default FALSE. + +int plm_get_loop(plm_t *self); +void plm_set_loop(plm_t *self, int loop); + + +// Get whether the file has ended. If looping is enabled, this will always +// return FALSE. + +int plm_has_ended(plm_t *self); + + +// Set the callback for decoded video frames used with plm_decode(). If no +// callback is set, video data will be ignored and not be decoded. The *user +// Parameter will be passed to your callback. + +void plm_set_video_decode_callback(plm_t *self, plm_video_decode_callback fp, void *user); + + +// Set the callback for decoded audio samples used with plm_decode(). If no +// callback is set, audio data will be ignored and not be decoded. The *user +// Parameter will be passed to your callback. + +void plm_set_audio_decode_callback(plm_t *self, plm_audio_decode_callback fp, void *user); + + +// Advance the internal timer by seconds and decode video/audio up to this time. +// This will call the video_decode_callback and audio_decode_callback any number +// of times. A frame-skip is not implemented, i.e. everything up to current time +// will be decoded. + +void plm_decode(plm_t *self, double seconds); + + +// Decode and return one video frame. Returns NULL if no frame could be decoded +// (either because the source ended or data is corrupt). If you only want to +// decode video, you should disable audio via plm_set_audio_enabled(). +// The returned plm_frame_t is valid until the next call to plm_decode_video() +// or until plm_destroy() is called. + +plm_frame_t *plm_decode_video(plm_t *self); + + +// Decode and return one audio frame. Returns NULL if no frame could be decoded +// (either because the source ended or data is corrupt). If you only want to +// decode audio, you should disable video via plm_set_video_enabled(). +// The returned plm_samples_t is valid until the next call to plm_decode_audio() +// or until plm_destroy() is called. + +plm_samples_t *plm_decode_audio(plm_t *self); + + +// Seek to the specified time, clamped between 0 -- duration. This can only be +// used when the underlying plm_buffer is seekable, i.e. for files, fixed +// memory buffers or _for_appending buffers. +// If seek_exact is TRUE this will seek to the exact time, otherwise it will +// seek to the last intra frame just before the desired time. Exact seeking can +// be slow, because all frames up to the seeked one have to be decoded on top of +// the previous intra frame. +// If seeking succeeds, this function will call the video_decode_callback +// exactly once with the target frame. If audio is enabled, it will also call +// the audio_decode_callback any number of times, until the audio_lead_time is +// satisfied. +// Returns TRUE if seeking succeeded or FALSE if no frame could be found. + +int plm_seek(plm_t *self, double time, int seek_exact); + + +// Similar to plm_seek(), but will not call the video_decode_callback, +// audio_decode_callback or make any attempts to sync audio. +// Returns the found frame or NULL if no frame could be found. + +plm_frame_t *plm_seek_frame(plm_t *self, double time, int seek_exact); + + + +// ----------------------------------------------------------------------------- +// plm_buffer public API +// Provides the data source for all other plm_* interfaces + + +// The default size for buffers created from files or by the high-level API + +#ifndef PLM_BUFFER_DEFAULT_SIZE +#define PLM_BUFFER_DEFAULT_SIZE (128 * 1024) +#endif + + +// Create a buffer instance with a filename. Returns NULL if the file could not +// be opened. + +plm_buffer_t *plm_buffer_create_with_filename(const char *filename); + + +// Create a buffer instance with a file handle. Pass TRUE to close_when_done +// to let plmpeg call fclose() on the handle when plm_destroy() is called. + +plm_buffer_t *plm_buffer_create_with_file(FILE *fh, int close_when_done); + + +// Create a buffer instance with a pointer to memory as source. This assumes +// the whole file is in memory. The bytes are not copied. Pass 1 to +// free_when_done to let plmpeg call free() on the pointer when plm_destroy() +// is called. + +plm_buffer_t *plm_buffer_create_with_memory(uint8_t *bytes, size_t length, int free_when_done); + + +// Create an empty buffer with an initial capacity. The buffer will grow +// as needed. Data that has already been read, will be discarded. + +plm_buffer_t *plm_buffer_create_with_capacity(size_t capacity); + + +// Create an empty buffer with an initial capacity. The buffer will grow +// as needed. Decoded data will *not* be discarded. This can be used when +// loading a file over the network, without needing to throttle the download. +// It also allows for seeking in the already loaded data. + +plm_buffer_t *plm_buffer_create_for_appending(size_t initial_capacity); + + +// Destroy a buffer instance and free all data + +void plm_buffer_destroy(plm_buffer_t *self); + + +// Copy data into the buffer. If the data to be written is larger than the +// available space, the buffer will realloc() with a larger capacity. +// Returns the number of bytes written. This will always be the same as the +// passed in length, except when the buffer was created _with_memory() for +// which _write() is forbidden. + +size_t plm_buffer_write(plm_buffer_t *self, uint8_t *bytes, size_t length); + + +// Mark the current byte length as the end of this buffer and signal that no +// more data is expected to be written to it. This function should be called +// just after the last plm_buffer_write(). +// For _with_capacity buffers, this is cleared on a plm_buffer_rewind(). + +void plm_buffer_signal_end(plm_buffer_t *self); + + +// Set a callback that is called whenever the buffer needs more data + +void plm_buffer_set_load_callback(plm_buffer_t *self, plm_buffer_load_callback fp, void *user); + + +// Rewind the buffer back to the beginning. When loading from a file handle, +// this also seeks to the beginning of the file. + +void plm_buffer_rewind(plm_buffer_t *self); + + +// Get the total size. For files, this returns the file size. For all other +// types it returns the number of bytes currently in the buffer. + +size_t plm_buffer_get_size(plm_buffer_t *self); + + +// Get the number of remaining (yet unread) bytes in the buffer. This can be +// useful to throttle writing. + +size_t plm_buffer_get_remaining(plm_buffer_t *self); + + +// Get whether the read position of the buffer is at the end and no more data +// is expected. + +int plm_buffer_has_ended(plm_buffer_t *self); + + + +// ----------------------------------------------------------------------------- +// plm_demux public API +// Demux an MPEG Program Stream (PS) data into separate packages + + +// Various Packet Types + +static const int PLM_DEMUX_PACKET_PRIVATE = 0xBD; +static const int PLM_DEMUX_PACKET_AUDIO_1 = 0xC0; +static const int PLM_DEMUX_PACKET_AUDIO_2 = 0xC1; +static const int PLM_DEMUX_PACKET_AUDIO_3 = 0xC2; +static const int PLM_DEMUX_PACKET_AUDIO_4 = 0xC2; +static const int PLM_DEMUX_PACKET_VIDEO_1 = 0xE0; + + +// Create a demuxer with a plm_buffer as source. This will also attempt to read +// the pack and system headers from the buffer. + +plm_demux_t *plm_demux_create(plm_buffer_t *buffer, int destroy_when_done); + + +// Destroy a demuxer and free all data. + +void plm_demux_destroy(plm_demux_t *self); + + +// Returns TRUE/FALSE whether pack and system headers have been found. This will +// attempt to read the headers if non are present yet. + +int plm_demux_has_headers(plm_demux_t *self); + + +// Returns the number of video streams found in the system header. This will +// attempt to read the system header if non is present yet. + +int plm_demux_get_num_video_streams(plm_demux_t *self); + + +// Returns the number of audio streams found in the system header. This will +// attempt to read the system header if non is present yet. + +int plm_demux_get_num_audio_streams(plm_demux_t *self); + + +// Rewind the internal buffer. See plm_buffer_rewind(). + +void plm_demux_rewind(plm_demux_t *self); + + +// Get whether the file has ended. This will be cleared on seeking or rewind. + +int plm_demux_has_ended(plm_demux_t *self); + + +// Seek to a packet of the specified type with a PTS just before specified time. +// If force_intra is TRUE, only packets containing an intra frame will be +// considered - this only makes sense when the type is PLM_DEMUX_PACKET_VIDEO_1. +// Note that the specified time is considered 0-based, regardless of the first +// PTS in the data source. + +plm_packet_t *plm_demux_seek(plm_demux_t *self, double time, int type, int force_intra); + + +// Get the PTS of the first packet of this type. Returns PLM_PACKET_INVALID_TS +// if not packet of this packet type can be found. + +double plm_demux_get_start_time(plm_demux_t *self, int type); + + +// Get the duration for the specified packet type - i.e. the span between the +// the first PTS and the last PTS in the data source. This only makes sense when +// the underlying data source is a file or fixed memory. + +double plm_demux_get_duration(plm_demux_t *self, int type); + + +// Decode and return the next packet. The returned packet_t is valid until +// the next call to plm_demux_decode() or until the demuxer is destroyed. + +plm_packet_t *plm_demux_decode(plm_demux_t *self); + + + +// ----------------------------------------------------------------------------- +// plm_video public API +// Decode MPEG1 Video ("mpeg1") data into raw YCrCb frames + + +// Create a video decoder with a plm_buffer as source. + +plm_video_t *plm_video_create_with_buffer(plm_buffer_t *buffer, int destroy_when_done); + + +// Destroy a video decoder and free all data. + +void plm_video_destroy(plm_video_t *self); + + +// Get whether a sequence header was found and we can accurately report on +// dimensions and framerate. + +int plm_video_has_header(plm_video_t *self); + + +// Get the framerate in frames per second. + +double plm_video_get_framerate(plm_video_t *self); + + +// Get the display width/height. + +int plm_video_get_width(plm_video_t *self); +int plm_video_get_height(plm_video_t *self); + + +// Set "no delay" mode. When enabled, the decoder assumes that the video does +// *not* contain any B-Frames. This is useful for reducing lag when streaming. +// The default is FALSE. + +void plm_video_set_no_delay(plm_video_t *self, int no_delay); + + +// Get the current internal time in seconds. + +double plm_video_get_time(plm_video_t *self); + + +// Set the current internal time in seconds. This is only useful when you +// manipulate the underlying video buffer and want to enforce a correct +// timestamps. + +void plm_video_set_time(plm_video_t *self, double time); + + +// Rewind the internal buffer. See plm_buffer_rewind(). + +void plm_video_rewind(plm_video_t *self); + + +// Get whether the file has ended. This will be cleared on rewind. + +int plm_video_has_ended(plm_video_t *self); + + +// Decode and return one frame of video and advance the internal time by +// 1/framerate seconds. The returned frame_t is valid until the next call of +// plm_video_decode() or until the video decoder is destroyed. + +plm_frame_t *plm_video_decode(plm_video_t *self); + + +// Convert the YCrCb data of a frame into interleaved R G B data. The stride +// specifies the width in bytes of the destination buffer. I.e. the number of +// bytes from one line to the next. The stride must be at least +// (frame->width * bytes_per_pixel). The buffer pointed to by *dest must have a +// size of at least (stride * frame->height). +// Note that the alpha component of the dest buffer is always left untouched. + +void plm_frame_to_rgb(plm_frame_t *frame, uint8_t *dest, int stride); +void plm_frame_to_bgr(plm_frame_t *frame, uint8_t *dest, int stride); +void plm_frame_to_rgba(plm_frame_t *frame, uint8_t *dest, int stride); +void plm_frame_to_bgra(plm_frame_t *frame, uint8_t *dest, int stride); +void plm_frame_to_argb(plm_frame_t *frame, uint8_t *dest, int stride); +void plm_frame_to_abgr(plm_frame_t *frame, uint8_t *dest, int stride); + + +// ----------------------------------------------------------------------------- +// plm_audio public API +// Decode MPEG-1 Audio Layer II ("mp2") data into raw samples + + +// Create an audio decoder with a plm_buffer as source. + +plm_audio_t *plm_audio_create_with_buffer(plm_buffer_t *buffer, int destroy_when_done); + + +// Destroy an audio decoder and free all data. + +void plm_audio_destroy(plm_audio_t *self); + + +// Get whether a frame header was found and we can accurately report on +// samplerate. + +int plm_audio_has_header(plm_audio_t *self); + + +// Get the samplerate in samples per second. + +int plm_audio_get_samplerate(plm_audio_t *self); + + +// Get the current internal time in seconds. + +double plm_audio_get_time(plm_audio_t *self); + + +// Set the current internal time in seconds. This is only useful when you +// manipulate the underlying video buffer and want to enforce a correct +// timestamps. + +void plm_audio_set_time(plm_audio_t *self, double time); + + +// Rewind the internal buffer. See plm_buffer_rewind(). + +void plm_audio_rewind(plm_audio_t *self); + + +// Get whether the file has ended. This will be cleared on rewind. + +int plm_audio_has_ended(plm_audio_t *self); + + +// Decode and return one "frame" of audio and advance the internal time by +// (PLM_AUDIO_SAMPLES_PER_FRAME/samplerate) seconds. The returned samples_t +// is valid until the next call of plm_audio_decode() or until the audio +// decoder is destroyed. + +plm_samples_t *plm_audio_decode(plm_audio_t *self); + + + +#ifdef __cplusplus +} +#endif + +#endif // PL_MPEG_H + + + + + +// ----------------------------------------------------------------------------- +// ----------------------------------------------------------------------------- +// IMPLEMENTATION + +#ifdef PL_MPEG_IMPLEMENTATION + +#include +#include + +#ifndef TRUE +#define TRUE 1 +#define FALSE 0 +#endif + +#define PLM_UNUSED(expr) (void)(expr) + + +// ----------------------------------------------------------------------------- +// plm (high-level interface) implementation + +typedef struct plm_t { + plm_demux_t *demux; + double time; + int has_ended; + int loop; + int has_decoders; + + int video_enabled; + int video_packet_type; + plm_buffer_t *video_buffer; + plm_video_t *video_decoder; + + int audio_enabled; + int audio_stream_index; + int audio_packet_type; + double audio_lead_time; + plm_buffer_t *audio_buffer; + plm_audio_t *audio_decoder; + + plm_video_decode_callback video_decode_callback; + void *video_decode_callback_user_data; + + plm_audio_decode_callback audio_decode_callback; + void *audio_decode_callback_user_data; +} plm_t; + +int plm_init_decoders(plm_t *self); +void plm_handle_end(plm_t *self); +void plm_read_video_packet(plm_buffer_t *buffer, void *user); +void plm_read_audio_packet(plm_buffer_t *buffer, void *user); +void plm_read_packets(plm_t *self, int requested_type); + +plm_t *plm_create_with_filename(const char *filename) { + plm_buffer_t *buffer = plm_buffer_create_with_filename(filename); + if (!buffer) { + return NULL; + } + return plm_create_with_buffer(buffer, TRUE); +} + +plm_t *plm_create_with_file(FILE *fh, int close_when_done) { + plm_buffer_t *buffer = plm_buffer_create_with_file(fh, close_when_done); + return plm_create_with_buffer(buffer, TRUE); +} + +plm_t *plm_create_with_memory(uint8_t *bytes, size_t length, int free_when_done) { + plm_buffer_t *buffer = plm_buffer_create_with_memory(bytes, length, free_when_done); + return plm_create_with_buffer(buffer, TRUE); +} + +plm_t *plm_create_with_buffer(plm_buffer_t *buffer, int destroy_when_done) { + plm_t *self = (plm_t *)malloc(sizeof(plm_t)); + memset(self, 0, sizeof(plm_t)); + + self->demux = plm_demux_create(buffer, destroy_when_done); + self->video_enabled = TRUE; + self->audio_enabled = TRUE; + plm_init_decoders(self); + + return self; +} + +int plm_init_decoders(plm_t *self) { + if (self->has_decoders) { + return TRUE; + } + + if (!plm_demux_has_headers(self->demux)) { + return FALSE; + } + + if (plm_demux_get_num_video_streams(self->demux) > 0) { + if (self->video_enabled) { + self->video_packet_type = PLM_DEMUX_PACKET_VIDEO_1; + } + self->video_buffer = plm_buffer_create_with_capacity(PLM_BUFFER_DEFAULT_SIZE); + plm_buffer_set_load_callback(self->video_buffer, plm_read_video_packet, self); + } + + if (plm_demux_get_num_audio_streams(self->demux) > 0) { + if (self->audio_enabled) { + self->audio_packet_type = PLM_DEMUX_PACKET_AUDIO_1 + self->audio_stream_index; + } + self->audio_buffer = plm_buffer_create_with_capacity(PLM_BUFFER_DEFAULT_SIZE); + plm_buffer_set_load_callback(self->audio_buffer, plm_read_audio_packet, self); + } + + if (self->video_buffer) { + self->video_decoder = plm_video_create_with_buffer(self->video_buffer, TRUE); + } + + if (self->audio_buffer) { + self->audio_decoder = plm_audio_create_with_buffer(self->audio_buffer, TRUE); + } + + self->has_decoders = TRUE; + return TRUE; +} + +void plm_destroy(plm_t *self) { + if (self->video_decoder) { + plm_video_destroy(self->video_decoder); + } + if (self->audio_decoder) { + plm_audio_destroy(self->audio_decoder); + } + + plm_demux_destroy(self->demux); + free(self); +} + +int plm_get_audio_enabled(plm_t *self) { + return self->audio_enabled; +} + +int plm_has_headers(plm_t *self) { + if (!plm_demux_has_headers(self->demux)) { + return FALSE; + } + + if (!plm_init_decoders(self)) { + return FALSE; + } + + if ( + (self->video_decoder && !plm_video_has_header(self->video_decoder)) || + (self->audio_decoder && !plm_audio_has_header(self->audio_decoder)) + ) { + return FALSE; + } + + return TRUE; +} + +void plm_set_audio_enabled(plm_t *self, int enabled) { + self->audio_enabled = enabled; + + if (!enabled) { + self->audio_packet_type = 0; + return; + } + + self->audio_packet_type = (plm_init_decoders(self) && self->audio_decoder) + ? PLM_DEMUX_PACKET_AUDIO_1 + self->audio_stream_index + : 0; +} + +void plm_set_audio_stream(plm_t *self, int stream_index) { + if (stream_index < 0 || stream_index > 3) { + return; + } + self->audio_stream_index = stream_index; + + // Set the correct audio_packet_type + plm_set_audio_enabled(self, self->audio_enabled); +} + +int plm_get_video_enabled(plm_t *self) { + return self->video_enabled; +} + +void plm_set_video_enabled(plm_t *self, int enabled) { + self->video_enabled = enabled; + + if (!enabled) { + self->video_packet_type = 0; + return; + } + + self->video_packet_type = (plm_init_decoders(self) && self->video_decoder) + ? PLM_DEMUX_PACKET_VIDEO_1 + : 0; +} + +int plm_get_num_video_streams(plm_t *self) { + return plm_demux_get_num_video_streams(self->demux); +} + +int plm_get_width(plm_t *self) { + return (plm_init_decoders(self) && self->video_decoder) + ? plm_video_get_width(self->video_decoder) + : 0; +} + +int plm_get_height(plm_t *self) { + return (plm_init_decoders(self) && self->video_decoder) + ? plm_video_get_height(self->video_decoder) + : 0; +} + +double plm_get_framerate(plm_t *self) { + return (plm_init_decoders(self) && self->video_decoder) + ? plm_video_get_framerate(self->video_decoder) + : 0; +} + +int plm_get_num_audio_streams(plm_t *self) { + return plm_demux_get_num_audio_streams(self->demux); +} + +int plm_get_samplerate(plm_t *self) { + return (plm_init_decoders(self) && self->audio_decoder) + ? plm_audio_get_samplerate(self->audio_decoder) + : 0; +} + +double plm_get_audio_lead_time(plm_t *self) { + return self->audio_lead_time; +} + +void plm_set_audio_lead_time(plm_t *self, double lead_time) { + self->audio_lead_time = lead_time; +} + +double plm_get_time(plm_t *self) { + return self->time; +} + +double plm_get_duration(plm_t *self) { + return plm_demux_get_duration(self->demux, PLM_DEMUX_PACKET_VIDEO_1); +} + +void plm_rewind(plm_t *self) { + if (self->video_decoder) { + plm_video_rewind(self->video_decoder); + } + + if (self->audio_decoder) { + plm_audio_rewind(self->audio_decoder); + } + + plm_demux_rewind(self->demux); + self->time = 0; +} + +int plm_get_loop(plm_t *self) { + return self->loop; +} + +void plm_set_loop(plm_t *self, int loop) { + self->loop = loop; +} + +int plm_has_ended(plm_t *self) { + return self->has_ended; +} + +void plm_set_video_decode_callback(plm_t *self, plm_video_decode_callback fp, void *user) { + self->video_decode_callback = fp; + self->video_decode_callback_user_data = user; +} + +void plm_set_audio_decode_callback(plm_t *self, plm_audio_decode_callback fp, void *user) { + self->audio_decode_callback = fp; + self->audio_decode_callback_user_data = user; +} + +void plm_decode(plm_t *self, double tick) { + if (!plm_init_decoders(self)) { + return; + } + + int decode_video = (self->video_decode_callback && self->video_packet_type); + int decode_audio = (self->audio_decode_callback && self->audio_packet_type); + + if (!decode_video && !decode_audio) { + // Nothing to do here + return; + } + + int did_decode = FALSE; + int decode_video_failed = FALSE; + int decode_audio_failed = FALSE; + + double video_target_time = self->time + tick; + double audio_target_time = self->time + tick + self->audio_lead_time; + + do { + did_decode = FALSE; + + if (decode_video && plm_video_get_time(self->video_decoder) < video_target_time) { + plm_frame_t *frame = plm_video_decode(self->video_decoder); + if (frame) { + self->video_decode_callback(self, frame, self->video_decode_callback_user_data); + did_decode = TRUE; + } + else { + decode_video_failed = TRUE; + } + } + + if (decode_audio && plm_audio_get_time(self->audio_decoder) < audio_target_time) { + plm_samples_t *samples = plm_audio_decode(self->audio_decoder); + if (samples) { + self->audio_decode_callback(self, samples, self->audio_decode_callback_user_data); + did_decode = TRUE; + } + else { + decode_audio_failed = TRUE; + } + } + } while (did_decode); + + // Did all sources we wanted to decode fail and the demuxer is at the end? + if ( + (!decode_video || decode_video_failed) && + (!decode_audio || decode_audio_failed) && + plm_demux_has_ended(self->demux) + ) { + plm_handle_end(self); + return; + } + + self->time += tick; +} + +plm_frame_t *plm_decode_video(plm_t *self) { + if (!plm_init_decoders(self)) { + return NULL; + } + + if (!self->video_packet_type) { + return NULL; + } + + plm_frame_t *frame = plm_video_decode(self->video_decoder); + if (frame) { + self->time = frame->time; + } + else if (plm_demux_has_ended(self->demux)) { + plm_handle_end(self); + } + return frame; +} + +plm_samples_t *plm_decode_audio(plm_t *self) { + if (!plm_init_decoders(self)) { + return NULL; + } + + if (!self->audio_packet_type) { + return NULL; + } + + plm_samples_t *samples = plm_audio_decode(self->audio_decoder); + if (samples) { + self->time = samples->time; + } + else if (plm_demux_has_ended(self->demux)) { + plm_handle_end(self); + } + return samples; +} + +void plm_handle_end(plm_t *self) { + if (self->loop) { + plm_rewind(self); + } + else { + self->has_ended = TRUE; + } +} + +void plm_read_video_packet(plm_buffer_t *buffer, void *user) { + PLM_UNUSED(buffer); + plm_t *self = (plm_t *)user; + plm_read_packets(self, self->video_packet_type); +} + +void plm_read_audio_packet(plm_buffer_t *buffer, void *user) { + PLM_UNUSED(buffer); + plm_t *self = (plm_t *)user; + plm_read_packets(self, self->audio_packet_type); +} + +void plm_read_packets(plm_t *self, int requested_type) { + plm_packet_t *packet; + while ((packet = plm_demux_decode(self->demux))) { + if (packet->type == self->video_packet_type) { + plm_buffer_write(self->video_buffer, packet->data, packet->length); + } + else if (packet->type == self->audio_packet_type) { + plm_buffer_write(self->audio_buffer, packet->data, packet->length); + } + + if (packet->type == requested_type) { + return; + } + } + + if (plm_demux_has_ended(self->demux)) { + if (self->video_buffer) { + plm_buffer_signal_end(self->video_buffer); + } + if (self->audio_buffer) { + plm_buffer_signal_end(self->audio_buffer); + } + } +} + +plm_frame_t *plm_seek_frame(plm_t *self, double time, int seek_exact) { + if (!plm_init_decoders(self)) { + return NULL; + } + + if (!self->video_packet_type) { + return NULL; + } + + int type = self->video_packet_type; + + double start_time = plm_demux_get_start_time(self->demux, type); + double duration = plm_demux_get_duration(self->demux, type); + + if (time < 0) { + time = 0; + } + else if (time > duration) { + time = duration; + } + + plm_packet_t *packet = plm_demux_seek(self->demux, time, type, TRUE); + if (!packet) { + return NULL; + } + + // Disable writing to the audio buffer while decoding video + int previous_audio_packet_type = self->audio_packet_type; + self->audio_packet_type = 0; + + // Clear video buffer and decode the found packet + plm_video_rewind(self->video_decoder); + plm_video_set_time(self->video_decoder, packet->pts - start_time); + plm_buffer_write(self->video_buffer, packet->data, packet->length); + plm_frame_t *frame = plm_video_decode(self->video_decoder); + + // If we want to seek to an exact frame, we have to decode all frames + // on top of the intra frame we just jumped to. + if (seek_exact) { + while (frame && frame->time < time) { + frame = plm_video_decode(self->video_decoder); + } + } + + // Enable writing to the audio buffer again? + self->audio_packet_type = previous_audio_packet_type; + + if (frame) { + self->time = frame->time; + } + + self->has_ended = FALSE; + return frame; +} + +int plm_seek(plm_t *self, double time, int seek_exact) { + plm_frame_t *frame = plm_seek_frame(self, time, seek_exact); + + if (!frame) { + return FALSE; + } + + if (self->video_decode_callback) { + self->video_decode_callback(self, frame, self->video_decode_callback_user_data); + } + + // If audio is not enabled we are done here. + if (!self->audio_packet_type) { + return TRUE; + } + + // Sync up Audio. This demuxes more packets until the first audio packet + // with a PTS greater than the current time is found. plm_decode() is then + // called to decode enough audio data to satisfy the audio_lead_time. + + double start_time = plm_demux_get_start_time(self->demux, self->video_packet_type); + plm_audio_rewind(self->audio_decoder); + + plm_packet_t *packet = NULL; + while ((packet = plm_demux_decode(self->demux))) { + if (packet->type == self->video_packet_type) { + plm_buffer_write(self->video_buffer, packet->data, packet->length); + } + else if ( + packet->type == self->audio_packet_type && + packet->pts - start_time > self->time + ) { + plm_audio_set_time(self->audio_decoder, packet->pts - start_time); + plm_buffer_write(self->audio_buffer, packet->data, packet->length); + plm_decode(self, 0); + break; + } + } + + return TRUE; +} + + + +// ----------------------------------------------------------------------------- +// plm_buffer implementation + +enum plm_buffer_mode { + PLM_BUFFER_MODE_FILE, + PLM_BUFFER_MODE_FIXED_MEM, + PLM_BUFFER_MODE_RING, + PLM_BUFFER_MODE_APPEND +}; + +typedef struct plm_buffer_t { + size_t bit_index; + size_t capacity; + size_t length; + size_t total_size; + int discard_read_bytes; + int has_ended; + int free_when_done; + int close_when_done; + FILE *fh; + plm_buffer_load_callback load_callback; + void *load_callback_user_data; + uint8_t *bytes; + enum plm_buffer_mode mode; +} plm_buffer_t; + +typedef struct { + int16_t index; + int16_t value; +} plm_vlc_t; + +typedef struct { + int16_t index; + uint16_t value; +} plm_vlc_uint_t; + + +void plm_buffer_seek(plm_buffer_t *self, size_t pos); +size_t plm_buffer_tell(plm_buffer_t *self); +void plm_buffer_discard_read_bytes(plm_buffer_t *self); +void plm_buffer_load_file_callback(plm_buffer_t *self, void *user); + +int plm_buffer_has(plm_buffer_t *self, size_t count); +int plm_buffer_read(plm_buffer_t *self, int count); +void plm_buffer_align(plm_buffer_t *self); +void plm_buffer_skip(plm_buffer_t *self, size_t count); +int plm_buffer_skip_bytes(plm_buffer_t *self, uint8_t v); +int plm_buffer_next_start_code(plm_buffer_t *self); +int plm_buffer_find_start_code(plm_buffer_t *self, int code); +int plm_buffer_no_start_code(plm_buffer_t *self); +int16_t plm_buffer_read_vlc(plm_buffer_t *self, const plm_vlc_t *table); +uint16_t plm_buffer_read_vlc_uint(plm_buffer_t *self, const plm_vlc_uint_t *table); + +plm_buffer_t *plm_buffer_create_with_filename(const char *filename) { + FILE *fh = fopen(filename, "rb"); + if (!fh) { + return NULL; + } + return plm_buffer_create_with_file(fh, TRUE); +} + +plm_buffer_t *plm_buffer_create_with_file(FILE *fh, int close_when_done) { + plm_buffer_t *self = plm_buffer_create_with_capacity(PLM_BUFFER_DEFAULT_SIZE); + self->fh = fh; + self->close_when_done = close_when_done; + self->mode = PLM_BUFFER_MODE_FILE; + self->discard_read_bytes = TRUE; + + fseek(self->fh, 0, SEEK_END); + self->total_size = ftell(self->fh); + fseek(self->fh, 0, SEEK_SET); + + plm_buffer_set_load_callback(self, plm_buffer_load_file_callback, NULL); + return self; +} + +plm_buffer_t *plm_buffer_create_with_memory(uint8_t *bytes, size_t length, int free_when_done) { + plm_buffer_t *self = (plm_buffer_t *)malloc(sizeof(plm_buffer_t)); + memset(self, 0, sizeof(plm_buffer_t)); + self->capacity = length; + self->length = length; + self->total_size = length; + self->free_when_done = free_when_done; + self->bytes = bytes; + self->mode = PLM_BUFFER_MODE_FIXED_MEM; + self->discard_read_bytes = FALSE; + return self; +} + +plm_buffer_t *plm_buffer_create_with_capacity(size_t capacity) { + plm_buffer_t *self = (plm_buffer_t *)malloc(sizeof(plm_buffer_t)); + memset(self, 0, sizeof(plm_buffer_t)); + self->capacity = capacity; + self->free_when_done = TRUE; + self->bytes = (uint8_t *)malloc(capacity); + self->mode = PLM_BUFFER_MODE_RING; + self->discard_read_bytes = TRUE; + return self; +} + +plm_buffer_t *plm_buffer_create_for_appending(size_t initial_capacity) { + plm_buffer_t *self = plm_buffer_create_with_capacity(initial_capacity); + self->mode = PLM_BUFFER_MODE_APPEND; + self->discard_read_bytes = FALSE; + return self; +} + +void plm_buffer_destroy(plm_buffer_t *self) { + if (self->fh && self->close_when_done) { + fclose(self->fh); + } + if (self->free_when_done) { + free(self->bytes); + } + free(self); +} + +size_t plm_buffer_get_size(plm_buffer_t *self) { + return (self->mode == PLM_BUFFER_MODE_FILE) + ? self->total_size + : self->length; +} + +size_t plm_buffer_get_remaining(plm_buffer_t *self) { + return self->length - (self->bit_index >> 3); +} + +size_t plm_buffer_write(plm_buffer_t *self, uint8_t *bytes, size_t length) { + if (self->mode == PLM_BUFFER_MODE_FIXED_MEM) { + return 0; + } + + if (self->discard_read_bytes) { + // This should be a ring buffer, but instead it just shifts all unread + // data to the beginning of the buffer and appends new data at the end. + // Seems to be good enough. + + plm_buffer_discard_read_bytes(self); + if (self->mode == PLM_BUFFER_MODE_RING) { + self->total_size = 0; + } + } + + // Do we have to resize to fit the new data? + size_t bytes_available = self->capacity - self->length; + if (bytes_available < length) { + size_t new_size = self->capacity; + do { + new_size *= 2; + } while (new_size - self->length < length); + self->bytes = (uint8_t *)realloc(self->bytes, new_size); + self->capacity = new_size; + } + + memcpy(self->bytes + self->length, bytes, length); + self->length += length; + self->has_ended = FALSE; + return length; +} + +void plm_buffer_signal_end(plm_buffer_t *self) { + self->total_size = self->length; +} + +void plm_buffer_set_load_callback(plm_buffer_t *self, plm_buffer_load_callback fp, void *user) { + self->load_callback = fp; + self->load_callback_user_data = user; +} + +void plm_buffer_rewind(plm_buffer_t *self) { + plm_buffer_seek(self, 0); +} + +void plm_buffer_seek(plm_buffer_t *self, size_t pos) { + self->has_ended = FALSE; + + if (self->mode == PLM_BUFFER_MODE_FILE) { + fseek(self->fh, pos, SEEK_SET); + self->bit_index = 0; + self->length = 0; + } + else if (self->mode == PLM_BUFFER_MODE_RING) { + if (pos != 0) { + // Seeking to non-0 is forbidden for dynamic-mem buffers + return; + } + self->bit_index = 0; + self->length = 0; + self->total_size = 0; + } + else if (pos < self->length) { + self->bit_index = pos << 3; + } +} + +size_t plm_buffer_tell(plm_buffer_t *self) { + return self->mode == PLM_BUFFER_MODE_FILE + ? ftell(self->fh) + (self->bit_index >> 3) - self->length + : self->bit_index >> 3; +} + +void plm_buffer_discard_read_bytes(plm_buffer_t *self) { + size_t byte_pos = self->bit_index >> 3; + if (byte_pos == self->length) { + self->bit_index = 0; + self->length = 0; + } + else if (byte_pos > 0) { + memmove(self->bytes, self->bytes + byte_pos, self->length - byte_pos); + self->bit_index -= byte_pos << 3; + self->length -= byte_pos; + } +} + +void plm_buffer_load_file_callback(plm_buffer_t *self, void *user) { + PLM_UNUSED(user); + + if (self->discard_read_bytes) { + plm_buffer_discard_read_bytes(self); + } + + size_t bytes_available = self->capacity - self->length; + size_t bytes_read = fread(self->bytes + self->length, 1, bytes_available, self->fh); + self->length += bytes_read; + + if (bytes_read == 0) { + self->has_ended = TRUE; + } +} + +int plm_buffer_has_ended(plm_buffer_t *self) { + return self->has_ended; +} + +int plm_buffer_has(plm_buffer_t *self, size_t count) { + if (((self->length << 3) - self->bit_index) >= count) { + return TRUE; + } + + if (self->load_callback) { + self->load_callback(self, self->load_callback_user_data); + } + + if (((self->length << 3) - self->bit_index) >= count) { + return TRUE; + } + + if (self->total_size != 0 && self->length == self->total_size) { + self->has_ended = TRUE; + } + return FALSE; +} + +int plm_buffer_read(plm_buffer_t *self, int count) { + if (!plm_buffer_has(self, count)) { + return 0; + } + + int value = 0; + while (count) { + int current_byte = self->bytes[self->bit_index >> 3]; + + int remaining = 8 - (self->bit_index & 7); // Remaining bits in byte + int read = remaining < count ? remaining : count; // Bits in self run + int shift = remaining - read; + int mask = (0xff >> (8 - read)); + + value = (value << read) | ((current_byte & (mask << shift)) >> shift); + + self->bit_index += read; + count -= read; + } + + return value; +} + +void plm_buffer_align(plm_buffer_t *self) { + self->bit_index = ((self->bit_index + 7) >> 3) << 3; // Align to next byte +} + +void plm_buffer_skip(plm_buffer_t *self, size_t count) { + if (plm_buffer_has(self, count)) { + self->bit_index += count; + } +} + +int plm_buffer_skip_bytes(plm_buffer_t *self, uint8_t v) { + plm_buffer_align(self); + int skipped = 0; + while (plm_buffer_has(self, 8) && self->bytes[self->bit_index >> 3] == v) { + self->bit_index += 8; + skipped++; + } + return skipped; +} + +int plm_buffer_next_start_code(plm_buffer_t *self) { + plm_buffer_align(self); + + while (plm_buffer_has(self, (5 << 3))) { + size_t byte_index = (self->bit_index) >> 3; + if ( + self->bytes[byte_index] == 0x00 && + self->bytes[byte_index + 1] == 0x00 && + self->bytes[byte_index + 2] == 0x01 + ) { + self->bit_index = (byte_index + 4) << 3; + return self->bytes[byte_index + 3]; + } + self->bit_index += 8; + } + return -1; +} + +int plm_buffer_find_start_code(plm_buffer_t *self, int code) { + int current = 0; + while (TRUE) { + current = plm_buffer_next_start_code(self); + if (current == code || current == -1) { + return current; + } + } + return -1; +} + +int plm_buffer_has_start_code(plm_buffer_t *self, int code) { + size_t previous_bit_index = self->bit_index; + int previous_discard_read_bytes = self->discard_read_bytes; + + self->discard_read_bytes = FALSE; + int current = plm_buffer_find_start_code(self, code); + + self->bit_index = previous_bit_index; + self->discard_read_bytes = previous_discard_read_bytes; + return current; +} + +int plm_buffer_no_start_code(plm_buffer_t *self) { + if (!plm_buffer_has(self, (5 << 3))) { + return FALSE; + } + + size_t byte_index = ((self->bit_index + 7) >> 3); + return !( + self->bytes[byte_index] == 0x00 && + self->bytes[byte_index + 1] == 0x00 && + self->bytes[byte_index + 2] == 0x01 + ); +} + +int16_t plm_buffer_read_vlc(plm_buffer_t *self, const plm_vlc_t *table) { + plm_vlc_t state = {0, 0}; + do { + state = table[state.index + plm_buffer_read(self, 1)]; + } while (state.index > 0); + return state.value; +} + +uint16_t plm_buffer_read_vlc_uint(plm_buffer_t *self, const plm_vlc_uint_t *table) { + return (uint16_t)plm_buffer_read_vlc(self, (const plm_vlc_t *)table); +} + + + +// ---------------------------------------------------------------------------- +// plm_demux implementation + +static const int PLM_START_PACK = 0xBA; +static const int PLM_START_END = 0xB9; +static const int PLM_START_SYSTEM = 0xBB; + +typedef struct plm_demux_t { + plm_buffer_t *buffer; + int destroy_buffer_when_done; + double system_clock_ref; + + size_t last_file_size; + double last_decoded_pts; + double start_time; + double duration; + + int start_code; + int has_pack_header; + int has_system_header; + int has_headers; + + int num_audio_streams; + int num_video_streams; + plm_packet_t current_packet; + plm_packet_t next_packet; +} plm_demux_t; + + +void plm_demux_buffer_seek(plm_demux_t *self, size_t pos); +double plm_demux_decode_time(plm_demux_t *self); +plm_packet_t *plm_demux_decode_packet(plm_demux_t *self, int type); +plm_packet_t *plm_demux_get_packet(plm_demux_t *self); + +plm_demux_t *plm_demux_create(plm_buffer_t *buffer, int destroy_when_done) { + plm_demux_t *self = (plm_demux_t *)malloc(sizeof(plm_demux_t)); + memset(self, 0, sizeof(plm_demux_t)); + + self->buffer = buffer; + self->destroy_buffer_when_done = destroy_when_done; + + self->start_time = PLM_PACKET_INVALID_TS; + self->duration = PLM_PACKET_INVALID_TS; + self->start_code = -1; + + plm_demux_has_headers(self); + return self; +} + +void plm_demux_destroy(plm_demux_t *self) { + if (self->destroy_buffer_when_done) { + plm_buffer_destroy(self->buffer); + } + free(self); +} + +int plm_demux_has_headers(plm_demux_t *self) { + if (self->has_headers) { + return TRUE; + } + + // Decode pack header + if (!self->has_pack_header) { + if ( + self->start_code != PLM_START_PACK && + plm_buffer_find_start_code(self->buffer, PLM_START_PACK) == -1 + ) { + return FALSE; + } + + self->start_code = PLM_START_PACK; + if (!plm_buffer_has(self->buffer, 64)) { + return FALSE; + } + self->start_code = -1; + + if (plm_buffer_read(self->buffer, 4) != 0x02) { + return FALSE; + } + + self->system_clock_ref = plm_demux_decode_time(self); + plm_buffer_skip(self->buffer, 1); + plm_buffer_skip(self->buffer, 22); // mux_rate * 50 + plm_buffer_skip(self->buffer, 1); + + self->has_pack_header = TRUE; + } + + // Decode system header + if (!self->has_system_header) { + if ( + self->start_code != PLM_START_SYSTEM && + plm_buffer_find_start_code(self->buffer, PLM_START_SYSTEM) == -1 + ) { + return FALSE; + } + + self->start_code = PLM_START_SYSTEM; + if (!plm_buffer_has(self->buffer, 56)) { + return FALSE; + } + self->start_code = -1; + + plm_buffer_skip(self->buffer, 16); // header_length + plm_buffer_skip(self->buffer, 24); // rate bound + self->num_audio_streams = plm_buffer_read(self->buffer, 6); + plm_buffer_skip(self->buffer, 5); // misc flags + self->num_video_streams = plm_buffer_read(self->buffer, 5); + + self->has_system_header = TRUE; + } + + self->has_headers = TRUE; + return TRUE; +} + +int plm_demux_get_num_video_streams(plm_demux_t *self) { + return plm_demux_has_headers(self) + ? self->num_video_streams + : 0; +} + +int plm_demux_get_num_audio_streams(plm_demux_t *self) { + return plm_demux_has_headers(self) + ? self->num_audio_streams + : 0; +} + +void plm_demux_rewind(plm_demux_t *self) { + plm_buffer_rewind(self->buffer); + self->current_packet.length = 0; + self->next_packet.length = 0; + self->start_code = -1; +} + +int plm_demux_has_ended(plm_demux_t *self) { + return plm_buffer_has_ended(self->buffer); +} + +void plm_demux_buffer_seek(plm_demux_t *self, size_t pos) { + plm_buffer_seek(self->buffer, pos); + self->current_packet.length = 0; + self->next_packet.length = 0; + self->start_code = -1; +} + +double plm_demux_get_start_time(plm_demux_t *self, int type) { + if (self->start_time != PLM_PACKET_INVALID_TS) { + return self->start_time; + } + + int previous_pos = plm_buffer_tell(self->buffer); + int previous_start_code = self->start_code; + + // Find first video PTS + plm_demux_rewind(self); + do { + plm_packet_t *packet = plm_demux_decode(self); + if (!packet) { + break; + } + if (packet->type == type) { + self->start_time = packet->pts; + } + } while (self->start_time == PLM_PACKET_INVALID_TS); + + plm_demux_buffer_seek(self, previous_pos); + self->start_code = previous_start_code; + return self->start_time; +} + +double plm_demux_get_duration(plm_demux_t *self, int type) { + size_t file_size = plm_buffer_get_size(self->buffer); + + if ( + self->duration != PLM_PACKET_INVALID_TS && + self->last_file_size == file_size + ) { + return self->duration; + } + + size_t previous_pos = plm_buffer_tell(self->buffer); + int previous_start_code = self->start_code; + + // Find last video PTS. Start searching 64kb from the end and go further + // back if needed. + long start_range = 64 * 1024; + long max_range = 4096 * 1024; + for (long range = start_range; range <= max_range; range *= 2) { + long seek_pos = file_size - range; + if (seek_pos < 0) { + seek_pos = 0; + range = max_range; // Make sure to bail after this round + } + plm_demux_buffer_seek(self, seek_pos); + self->current_packet.length = 0; + + double last_pts = PLM_PACKET_INVALID_TS; + plm_packet_t *packet = NULL; + while ((packet = plm_demux_decode(self))) { + if (packet->pts != PLM_PACKET_INVALID_TS && packet->type == type) { + last_pts = packet->pts; + } + } + if (last_pts != PLM_PACKET_INVALID_TS) { + self->duration = last_pts - plm_demux_get_start_time(self, type); + break; + } + } + + plm_demux_buffer_seek(self, previous_pos); + self->start_code = previous_start_code; + self->last_file_size = file_size; + return self->duration; +} + +plm_packet_t *plm_demux_seek(plm_demux_t *self, double seek_time, int type, int force_intra) { + if (!plm_demux_has_headers(self)) { + return NULL; + } + + // Using the current time, current byte position and the average bytes per + // second for this file, try to jump to a byte position that hopefully has + // packets containing timestamps within one second before to the desired + // seek_time. + + // If we hit close to the seek_time scan through all packets to find the + // last one (just before the seek_time) containing an intra frame. + // Otherwise we should at least be closer than before. Calculate the bytes + // per second for the jumped range and jump again. + + // The number of retries here is hard-limited to a generous amount. Usually + // the correct range is found after 1--5 jumps, even for files with very + // variable bitrates. If significantly more jumps are needed, there's + // probably something wrong with the file and we just avoid getting into an + // infinite loop. 32 retries should be enough for anybody. + + double duration = plm_demux_get_duration(self, type); + long file_size = plm_buffer_get_size(self->buffer); + long byterate = file_size / duration; + + double cur_time = self->last_decoded_pts; + double scan_span = 1; + + if (seek_time > duration) { + seek_time = duration; + } + else if (seek_time < 0) { + seek_time = 0; + } + seek_time += self->start_time; + + for (int retry = 0; retry < 32; retry++) { + int found_packet_with_pts = FALSE; + int found_packet_in_range = FALSE; + long last_valid_packet_start = -1; + double first_packet_time = PLM_PACKET_INVALID_TS; + + long cur_pos = plm_buffer_tell(self->buffer); + + // Estimate byte offset and jump to it. + long offset = (seek_time - cur_time - scan_span) * byterate; + long seek_pos = cur_pos + offset; + if (seek_pos < 0) { + seek_pos = 0; + } + else if (seek_pos > file_size - 256) { + seek_pos = file_size - 256; + } + + plm_demux_buffer_seek(self, seek_pos); + + // Scan through all packets up to the seek_time to find the last packet + // containing an intra frame. + while (plm_buffer_find_start_code(self->buffer, type) != -1) { + long packet_start = plm_buffer_tell(self->buffer); + plm_packet_t *packet = plm_demux_decode_packet(self, type); + + // Skip packet if it has no PTS + if (!packet || packet->pts == PLM_PACKET_INVALID_TS) { + continue; + } + + // Bail scanning through packets if we hit one that is outside + // seek_time - scan_span. + // We also adjust the cur_time and byterate values here so the next + // iteration can be a bit more precise. + if (packet->pts > seek_time || packet->pts < seek_time - scan_span) { + found_packet_with_pts = TRUE; + byterate = (seek_pos - cur_pos) / (packet->pts - cur_time); + cur_time = packet->pts; + break; + } + + // If we are still here, it means this packet is in close range to + // the seek_time. If this is the first packet for this jump position + // record the PTS. If we later have to back off, when there was no + // intra frame in this range, we can lower the seek_time to not scan + // this range again. + if (!found_packet_in_range) { + found_packet_in_range = TRUE; + first_packet_time = packet->pts; + } + + // Check if this is an intra frame packet. If so, record the buffer + // position of the start of this packet. We want to jump back to it + // later, when we know it's the last intra frame before desired + // seek time. + if (force_intra) { + for (size_t i = 0; i < packet->length - 6; i++) { + // Find the START_PICTURE code + if ( + packet->data[i] == 0x00 && + packet->data[i + 1] == 0x00 && + packet->data[i + 2] == 0x01 && + packet->data[i + 3] == 0x00 + ) { + // Bits 11--13 in the picture header contain the frame + // type, where 1=Intra + if ((packet->data[i + 5] & 0x38) == 8) { + last_valid_packet_start = packet_start; + } + break; + } + } + } + + // If we don't want intra frames, just use the last PTS found. + else { + last_valid_packet_start = packet_start; + } + } + + // If there was at least one intra frame in the range scanned above, + // our search is over. Jump back to the packet and decode it again. + if (last_valid_packet_start != -1) { + plm_demux_buffer_seek(self, last_valid_packet_start); + return plm_demux_decode_packet(self, type); + } + + // If we hit the right range, but still found no intra frame, we have + // to increases the scan_span. This is done exponentially to also handle + // video files with very few intra frames. + else if (found_packet_in_range) { + scan_span *= 2; + seek_time = first_packet_time; + } + + // If we didn't find any packet with a PTS, it probably means we reached + // the end of the file. Estimate byterate and cur_time accordingly. + else if (!found_packet_with_pts) { + byterate = (seek_pos - cur_pos) / (duration - cur_time); + cur_time = duration; + } + } + + return NULL; +} + +plm_packet_t *plm_demux_decode(plm_demux_t *self) { + if (!plm_demux_has_headers(self)) { + return NULL; + } + + if (self->current_packet.length) { + size_t bits_till_next_packet = self->current_packet.length << 3; + if (!plm_buffer_has(self->buffer, bits_till_next_packet)) { + return NULL; + } + plm_buffer_skip(self->buffer, bits_till_next_packet); + self->current_packet.length = 0; + } + + // Pending packet waiting for data? + if (self->next_packet.length) { + return plm_demux_get_packet(self); + } + + // Pending packet waiting for header? + if (self->start_code != -1) { + return plm_demux_decode_packet(self, self->start_code); + } + + do { + self->start_code = plm_buffer_next_start_code(self->buffer); + if ( + self->start_code == PLM_DEMUX_PACKET_VIDEO_1 || + self->start_code == PLM_DEMUX_PACKET_PRIVATE || ( + self->start_code >= PLM_DEMUX_PACKET_AUDIO_1 && + self->start_code <= PLM_DEMUX_PACKET_AUDIO_4 + ) + ) { + return plm_demux_decode_packet(self, self->start_code); + } + } while (self->start_code != -1); + + return NULL; +} + +double plm_demux_decode_time(plm_demux_t *self) { + int64_t clock = plm_buffer_read(self->buffer, 3) << 30; + plm_buffer_skip(self->buffer, 1); + clock |= plm_buffer_read(self->buffer, 15) << 15; + plm_buffer_skip(self->buffer, 1); + clock |= plm_buffer_read(self->buffer, 15); + plm_buffer_skip(self->buffer, 1); + return (double)clock / 90000.0; +} + +plm_packet_t *plm_demux_decode_packet(plm_demux_t *self, int type) { + if (!plm_buffer_has(self->buffer, 16 << 3)) { + return NULL; + } + + self->start_code = -1; + + self->next_packet.type = type; + self->next_packet.length = plm_buffer_read(self->buffer, 16); + self->next_packet.length -= plm_buffer_skip_bytes(self->buffer, 0xff); // stuffing + + // skip P-STD + if (plm_buffer_read(self->buffer, 2) == 0x01) { + plm_buffer_skip(self->buffer, 16); + self->next_packet.length -= 2; + } + + int pts_dts_marker = plm_buffer_read(self->buffer, 2); + if (pts_dts_marker == 0x03) { + self->next_packet.pts = plm_demux_decode_time(self); + self->last_decoded_pts = self->next_packet.pts; + plm_buffer_skip(self->buffer, 40); // skip dts + self->next_packet.length -= 10; + } + else if (pts_dts_marker == 0x02) { + self->next_packet.pts = plm_demux_decode_time(self); + self->last_decoded_pts = self->next_packet.pts; + self->next_packet.length -= 5; + } + else if (pts_dts_marker == 0x00) { + self->next_packet.pts = PLM_PACKET_INVALID_TS; + plm_buffer_skip(self->buffer, 4); + self->next_packet.length -= 1; + } + else { + return NULL; // invalid + } + + return plm_demux_get_packet(self); +} + +plm_packet_t *plm_demux_get_packet(plm_demux_t *self) { + if (!plm_buffer_has(self->buffer, self->next_packet.length << 3)) { + return NULL; + } + + self->current_packet.data = self->buffer->bytes + (self->buffer->bit_index >> 3); + self->current_packet.length = self->next_packet.length; + self->current_packet.type = self->next_packet.type; + self->current_packet.pts = self->next_packet.pts; + + self->next_packet.length = 0; + return &self->current_packet; +} + + + +// ----------------------------------------------------------------------------- +// plm_video implementation + +// Inspired by Java MPEG-1 Video Decoder and Player by Zoltan Korandi +// https://sourceforge.net/projects/javampeg1video/ + +static const int PLM_VIDEO_PICTURE_TYPE_INTRA = 1; +static const int PLM_VIDEO_PICTURE_TYPE_PREDICTIVE = 2; +static const int PLM_VIDEO_PICTURE_TYPE_B = 3; + +static const int PLM_START_SEQUENCE = 0xB3; +static const int PLM_START_SLICE_FIRST = 0x01; +static const int PLM_START_SLICE_LAST = 0xAF; +static const int PLM_START_PICTURE = 0x00; +static const int PLM_START_EXTENSION = 0xB5; +static const int PLM_START_USER_DATA = 0xB2; + +#define PLM_START_IS_SLICE(c) \ + (c >= PLM_START_SLICE_FIRST && c <= PLM_START_SLICE_LAST) + +static const double PLM_VIDEO_PICTURE_RATE[] = { + 0.000, 23.976, 24.000, 25.000, 29.970, 30.000, 50.000, 59.940, + 60.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 +}; + +static const uint8_t PLM_VIDEO_ZIG_ZAG[] = { + 0, 1, 8, 16, 9, 2, 3, 10, + 17, 24, 32, 25, 18, 11, 4, 5, + 12, 19, 26, 33, 40, 48, 41, 34, + 27, 20, 13, 6, 7, 14, 21, 28, + 35, 42, 49, 56, 57, 50, 43, 36, + 29, 22, 15, 23, 30, 37, 44, 51, + 58, 59, 52, 45, 38, 31, 39, 46, + 53, 60, 61, 54, 47, 55, 62, 63 +}; + +static const uint8_t PLM_VIDEO_INTRA_QUANT_MATRIX[] = { + 8, 16, 19, 22, 26, 27, 29, 34, + 16, 16, 22, 24, 27, 29, 34, 37, + 19, 22, 26, 27, 29, 34, 34, 38, + 22, 22, 26, 27, 29, 34, 37, 40, + 22, 26, 27, 29, 32, 35, 40, 48, + 26, 27, 29, 32, 35, 40, 48, 58, + 26, 27, 29, 34, 38, 46, 56, 69, + 27, 29, 35, 38, 46, 56, 69, 83 +}; + +static const uint8_t PLM_VIDEO_NON_INTRA_QUANT_MATRIX[] = { + 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16, + 16, 16, 16, 16, 16, 16, 16, 16 +}; + +static const uint8_t PLM_VIDEO_PREMULTIPLIER_MATRIX[] = { + 32, 44, 42, 38, 32, 25, 17, 9, + 44, 62, 58, 52, 44, 35, 24, 12, + 42, 58, 55, 49, 42, 33, 23, 12, + 38, 52, 49, 44, 38, 30, 20, 10, + 32, 44, 42, 38, 32, 25, 17, 9, + 25, 35, 33, 30, 25, 20, 14, 7, + 17, 24, 23, 20, 17, 14, 9, 5, + 9, 12, 12, 10, 9, 7, 5, 2 +}; + +static const plm_vlc_t PLM_VIDEO_MACROBLOCK_ADDRESS_INCREMENT[] = { + { 1 << 1, 0}, { 0, 1}, // 0: x + { 2 << 1, 0}, { 3 << 1, 0}, // 1: 0x + { 4 << 1, 0}, { 5 << 1, 0}, // 2: 00x + { 0, 3}, { 0, 2}, // 3: 01x + { 6 << 1, 0}, { 7 << 1, 0}, // 4: 000x + { 0, 5}, { 0, 4}, // 5: 001x + { 8 << 1, 0}, { 9 << 1, 0}, // 6: 0000x + { 0, 7}, { 0, 6}, // 7: 0001x + { 10 << 1, 0}, { 11 << 1, 0}, // 8: 0000 0x + { 12 << 1, 0}, { 13 << 1, 0}, // 9: 0000 1x + { 14 << 1, 0}, { 15 << 1, 0}, // 10: 0000 00x + { 16 << 1, 0}, { 17 << 1, 0}, // 11: 0000 01x + { 18 << 1, 0}, { 19 << 1, 0}, // 12: 0000 10x + { 0, 9}, { 0, 8}, // 13: 0000 11x + { -1, 0}, { 20 << 1, 0}, // 14: 0000 000x + { -1, 0}, { 21 << 1, 0}, // 15: 0000 001x + { 22 << 1, 0}, { 23 << 1, 0}, // 16: 0000 010x + { 0, 15}, { 0, 14}, // 17: 0000 011x + { 0, 13}, { 0, 12}, // 18: 0000 100x + { 0, 11}, { 0, 10}, // 19: 0000 101x + { 24 << 1, 0}, { 25 << 1, 0}, // 20: 0000 0001x + { 26 << 1, 0}, { 27 << 1, 0}, // 21: 0000 0011x + { 28 << 1, 0}, { 29 << 1, 0}, // 22: 0000 0100x + { 30 << 1, 0}, { 31 << 1, 0}, // 23: 0000 0101x + { 32 << 1, 0}, { -1, 0}, // 24: 0000 0001 0x + { -1, 0}, { 33 << 1, 0}, // 25: 0000 0001 1x + { 34 << 1, 0}, { 35 << 1, 0}, // 26: 0000 0011 0x + { 36 << 1, 0}, { 37 << 1, 0}, // 27: 0000 0011 1x + { 38 << 1, 0}, { 39 << 1, 0}, // 28: 0000 0100 0x + { 0, 21}, { 0, 20}, // 29: 0000 0100 1x + { 0, 19}, { 0, 18}, // 30: 0000 0101 0x + { 0, 17}, { 0, 16}, // 31: 0000 0101 1x + { 0, 35}, { -1, 0}, // 32: 0000 0001 00x + { -1, 0}, { 0, 34}, // 33: 0000 0001 11x + { 0, 33}, { 0, 32}, // 34: 0000 0011 00x + { 0, 31}, { 0, 30}, // 35: 0000 0011 01x + { 0, 29}, { 0, 28}, // 36: 0000 0011 10x + { 0, 27}, { 0, 26}, // 37: 0000 0011 11x + { 0, 25}, { 0, 24}, // 38: 0000 0100 00x + { 0, 23}, { 0, 22}, // 39: 0000 0100 01x +}; + +static const plm_vlc_t PLM_VIDEO_MACROBLOCK_TYPE_INTRA[] = { + { 1 << 1, 0}, { 0, 0x01}, // 0: x + { -1, 0}, { 0, 0x11}, // 1: 0x +}; + +static const plm_vlc_t PLM_VIDEO_MACROBLOCK_TYPE_PREDICTIVE[] = { + { 1 << 1, 0}, { 0, 0x0a}, // 0: x + { 2 << 1, 0}, { 0, 0x02}, // 1: 0x + { 3 << 1, 0}, { 0, 0x08}, // 2: 00x + { 4 << 1, 0}, { 5 << 1, 0}, // 3: 000x + { 6 << 1, 0}, { 0, 0x12}, // 4: 0000x + { 0, 0x1a}, { 0, 0x01}, // 5: 0001x + { -1, 0}, { 0, 0x11}, // 6: 0000 0x +}; + +static const plm_vlc_t PLM_VIDEO_MACROBLOCK_TYPE_B[] = { + { 1 << 1, 0}, { 2 << 1, 0}, // 0: x + { 3 << 1, 0}, { 4 << 1, 0}, // 1: 0x + { 0, 0x0c}, { 0, 0x0e}, // 2: 1x + { 5 << 1, 0}, { 6 << 1, 0}, // 3: 00x + { 0, 0x04}, { 0, 0x06}, // 4: 01x + { 7 << 1, 0}, { 8 << 1, 0}, // 5: 000x + { 0, 0x08}, { 0, 0x0a}, // 6: 001x + { 9 << 1, 0}, { 10 << 1, 0}, // 7: 0000x + { 0, 0x1e}, { 0, 0x01}, // 8: 0001x + { -1, 0}, { 0, 0x11}, // 9: 0000 0x + { 0, 0x16}, { 0, 0x1a}, // 10: 0000 1x +}; + +static const plm_vlc_t *PLM_VIDEO_MACROBLOCK_TYPE[] = { + NULL, + PLM_VIDEO_MACROBLOCK_TYPE_INTRA, + PLM_VIDEO_MACROBLOCK_TYPE_PREDICTIVE, + PLM_VIDEO_MACROBLOCK_TYPE_B +}; + +static const plm_vlc_t PLM_VIDEO_CODE_BLOCK_PATTERN[] = { + { 1 << 1, 0}, { 2 << 1, 0}, // 0: x + { 3 << 1, 0}, { 4 << 1, 0}, // 1: 0x + { 5 << 1, 0}, { 6 << 1, 0}, // 2: 1x + { 7 << 1, 0}, { 8 << 1, 0}, // 3: 00x + { 9 << 1, 0}, { 10 << 1, 0}, // 4: 01x + { 11 << 1, 0}, { 12 << 1, 0}, // 5: 10x + { 13 << 1, 0}, { 0, 60}, // 6: 11x + { 14 << 1, 0}, { 15 << 1, 0}, // 7: 000x + { 16 << 1, 0}, { 17 << 1, 0}, // 8: 001x + { 18 << 1, 0}, { 19 << 1, 0}, // 9: 010x + { 20 << 1, 0}, { 21 << 1, 0}, // 10: 011x + { 22 << 1, 0}, { 23 << 1, 0}, // 11: 100x + { 0, 32}, { 0, 16}, // 12: 101x + { 0, 8}, { 0, 4}, // 13: 110x + { 24 << 1, 0}, { 25 << 1, 0}, // 14: 0000x + { 26 << 1, 0}, { 27 << 1, 0}, // 15: 0001x + { 28 << 1, 0}, { 29 << 1, 0}, // 16: 0010x + { 30 << 1, 0}, { 31 << 1, 0}, // 17: 0011x + { 0, 62}, { 0, 2}, // 18: 0100x + { 0, 61}, { 0, 1}, // 19: 0101x + { 0, 56}, { 0, 52}, // 20: 0110x + { 0, 44}, { 0, 28}, // 21: 0111x + { 0, 40}, { 0, 20}, // 22: 1000x + { 0, 48}, { 0, 12}, // 23: 1001x + { 32 << 1, 0}, { 33 << 1, 0}, // 24: 0000 0x + { 34 << 1, 0}, { 35 << 1, 0}, // 25: 0000 1x + { 36 << 1, 0}, { 37 << 1, 0}, // 26: 0001 0x + { 38 << 1, 0}, { 39 << 1, 0}, // 27: 0001 1x + { 40 << 1, 0}, { 41 << 1, 0}, // 28: 0010 0x + { 42 << 1, 0}, { 43 << 1, 0}, // 29: 0010 1x + { 0, 63}, { 0, 3}, // 30: 0011 0x + { 0, 36}, { 0, 24}, // 31: 0011 1x + { 44 << 1, 0}, { 45 << 1, 0}, // 32: 0000 00x + { 46 << 1, 0}, { 47 << 1, 0}, // 33: 0000 01x + { 48 << 1, 0}, { 49 << 1, 0}, // 34: 0000 10x + { 50 << 1, 0}, { 51 << 1, 0}, // 35: 0000 11x + { 52 << 1, 0}, { 53 << 1, 0}, // 36: 0001 00x + { 54 << 1, 0}, { 55 << 1, 0}, // 37: 0001 01x + { 56 << 1, 0}, { 57 << 1, 0}, // 38: 0001 10x + { 58 << 1, 0}, { 59 << 1, 0}, // 39: 0001 11x + { 0, 34}, { 0, 18}, // 40: 0010 00x + { 0, 10}, { 0, 6}, // 41: 0010 01x + { 0, 33}, { 0, 17}, // 42: 0010 10x + { 0, 9}, { 0, 5}, // 43: 0010 11x + { -1, 0}, { 60 << 1, 0}, // 44: 0000 000x + { 61 << 1, 0}, { 62 << 1, 0}, // 45: 0000 001x + { 0, 58}, { 0, 54}, // 46: 0000 010x + { 0, 46}, { 0, 30}, // 47: 0000 011x + { 0, 57}, { 0, 53}, // 48: 0000 100x + { 0, 45}, { 0, 29}, // 49: 0000 101x + { 0, 38}, { 0, 26}, // 50: 0000 110x + { 0, 37}, { 0, 25}, // 51: 0000 111x + { 0, 43}, { 0, 23}, // 52: 0001 000x + { 0, 51}, { 0, 15}, // 53: 0001 001x + { 0, 42}, { 0, 22}, // 54: 0001 010x + { 0, 50}, { 0, 14}, // 55: 0001 011x + { 0, 41}, { 0, 21}, // 56: 0001 100x + { 0, 49}, { 0, 13}, // 57: 0001 101x + { 0, 35}, { 0, 19}, // 58: 0001 110x + { 0, 11}, { 0, 7}, // 59: 0001 111x + { 0, 39}, { 0, 27}, // 60: 0000 0001x + { 0, 59}, { 0, 55}, // 61: 0000 0010x + { 0, 47}, { 0, 31}, // 62: 0000 0011x +}; + +static const plm_vlc_t PLM_VIDEO_MOTION[] = { + { 1 << 1, 0}, { 0, 0}, // 0: x + { 2 << 1, 0}, { 3 << 1, 0}, // 1: 0x + { 4 << 1, 0}, { 5 << 1, 0}, // 2: 00x + { 0, 1}, { 0, -1}, // 3: 01x + { 6 << 1, 0}, { 7 << 1, 0}, // 4: 000x + { 0, 2}, { 0, -2}, // 5: 001x + { 8 << 1, 0}, { 9 << 1, 0}, // 6: 0000x + { 0, 3}, { 0, -3}, // 7: 0001x + { 10 << 1, 0}, { 11 << 1, 0}, // 8: 0000 0x + { 12 << 1, 0}, { 13 << 1, 0}, // 9: 0000 1x + { -1, 0}, { 14 << 1, 0}, // 10: 0000 00x + { 15 << 1, 0}, { 16 << 1, 0}, // 11: 0000 01x + { 17 << 1, 0}, { 18 << 1, 0}, // 12: 0000 10x + { 0, 4}, { 0, -4}, // 13: 0000 11x + { -1, 0}, { 19 << 1, 0}, // 14: 0000 001x + { 20 << 1, 0}, { 21 << 1, 0}, // 15: 0000 010x + { 0, 7}, { 0, -7}, // 16: 0000 011x + { 0, 6}, { 0, -6}, // 17: 0000 100x + { 0, 5}, { 0, -5}, // 18: 0000 101x + { 22 << 1, 0}, { 23 << 1, 0}, // 19: 0000 0011x + { 24 << 1, 0}, { 25 << 1, 0}, // 20: 0000 0100x + { 26 << 1, 0}, { 27 << 1, 0}, // 21: 0000 0101x + { 28 << 1, 0}, { 29 << 1, 0}, // 22: 0000 0011 0x + { 30 << 1, 0}, { 31 << 1, 0}, // 23: 0000 0011 1x + { 32 << 1, 0}, { 33 << 1, 0}, // 24: 0000 0100 0x + { 0, 10}, { 0, -10}, // 25: 0000 0100 1x + { 0, 9}, { 0, -9}, // 26: 0000 0101 0x + { 0, 8}, { 0, -8}, // 27: 0000 0101 1x + { 0, 16}, { 0, -16}, // 28: 0000 0011 00x + { 0, 15}, { 0, -15}, // 29: 0000 0011 01x + { 0, 14}, { 0, -14}, // 30: 0000 0011 10x + { 0, 13}, { 0, -13}, // 31: 0000 0011 11x + { 0, 12}, { 0, -12}, // 32: 0000 0100 00x + { 0, 11}, { 0, -11}, // 33: 0000 0100 01x +}; + +static const plm_vlc_t PLM_VIDEO_DCT_SIZE_LUMINANCE[] = { + { 1 << 1, 0}, { 2 << 1, 0}, // 0: x + { 0, 1}, { 0, 2}, // 1: 0x + { 3 << 1, 0}, { 4 << 1, 0}, // 2: 1x + { 0, 0}, { 0, 3}, // 3: 10x + { 0, 4}, { 5 << 1, 0}, // 4: 11x + { 0, 5}, { 6 << 1, 0}, // 5: 111x + { 0, 6}, { 7 << 1, 0}, // 6: 1111x + { 0, 7}, { 8 << 1, 0}, // 7: 1111 1x + { 0, 8}, { -1, 0}, // 8: 1111 11x +}; + +static const plm_vlc_t PLM_VIDEO_DCT_SIZE_CHROMINANCE[] = { + { 1 << 1, 0}, { 2 << 1, 0}, // 0: x + { 0, 0}, { 0, 1}, // 1: 0x + { 0, 2}, { 3 << 1, 0}, // 2: 1x + { 0, 3}, { 4 << 1, 0}, // 3: 11x + { 0, 4}, { 5 << 1, 0}, // 4: 111x + { 0, 5}, { 6 << 1, 0}, // 5: 1111x + { 0, 6}, { 7 << 1, 0}, // 6: 1111 1x + { 0, 7}, { 8 << 1, 0}, // 7: 1111 11x + { 0, 8}, { -1, 0}, // 8: 1111 111x +}; + +static const plm_vlc_t *PLM_VIDEO_DCT_SIZE[] = { + PLM_VIDEO_DCT_SIZE_LUMINANCE, + PLM_VIDEO_DCT_SIZE_CHROMINANCE, + PLM_VIDEO_DCT_SIZE_CHROMINANCE +}; + + +// dct_coeff bitmap: +// 0xff00 run +// 0x00ff level + +// Decoded values are unsigned. Sign bit follows in the stream. + +static const plm_vlc_uint_t PLM_VIDEO_DCT_COEFF[] = { + { 1 << 1, 0}, { 0, 0x0001}, // 0: x + { 2 << 1, 0}, { 3 << 1, 0}, // 1: 0x + { 4 << 1, 0}, { 5 << 1, 0}, // 2: 00x + { 6 << 1, 0}, { 0, 0x0101}, // 3: 01x + { 7 << 1, 0}, { 8 << 1, 0}, // 4: 000x + { 9 << 1, 0}, { 10 << 1, 0}, // 5: 001x + { 0, 0x0002}, { 0, 0x0201}, // 6: 010x + { 11 << 1, 0}, { 12 << 1, 0}, // 7: 0000x + { 13 << 1, 0}, { 14 << 1, 0}, // 8: 0001x + { 15 << 1, 0}, { 0, 0x0003}, // 9: 0010x + { 0, 0x0401}, { 0, 0x0301}, // 10: 0011x + { 16 << 1, 0}, { 0, 0xffff}, // 11: 0000 0x + { 17 << 1, 0}, { 18 << 1, 0}, // 12: 0000 1x + { 0, 0x0701}, { 0, 0x0601}, // 13: 0001 0x + { 0, 0x0102}, { 0, 0x0501}, // 14: 0001 1x + { 19 << 1, 0}, { 20 << 1, 0}, // 15: 0010 0x + { 21 << 1, 0}, { 22 << 1, 0}, // 16: 0000 00x + { 0, 0x0202}, { 0, 0x0901}, // 17: 0000 10x + { 0, 0x0004}, { 0, 0x0801}, // 18: 0000 11x + { 23 << 1, 0}, { 24 << 1, 0}, // 19: 0010 00x + { 25 << 1, 0}, { 26 << 1, 0}, // 20: 0010 01x + { 27 << 1, 0}, { 28 << 1, 0}, // 21: 0000 000x + { 29 << 1, 0}, { 30 << 1, 0}, // 22: 0000 001x + { 0, 0x0d01}, { 0, 0x0006}, // 23: 0010 000x + { 0, 0x0c01}, { 0, 0x0b01}, // 24: 0010 001x + { 0, 0x0302}, { 0, 0x0103}, // 25: 0010 010x + { 0, 0x0005}, { 0, 0x0a01}, // 26: 0010 011x + { 31 << 1, 0}, { 32 << 1, 0}, // 27: 0000 0000x + { 33 << 1, 0}, { 34 << 1, 0}, // 28: 0000 0001x + { 35 << 1, 0}, { 36 << 1, 0}, // 29: 0000 0010x + { 37 << 1, 0}, { 38 << 1, 0}, // 30: 0000 0011x + { 39 << 1, 0}, { 40 << 1, 0}, // 31: 0000 0000 0x + { 41 << 1, 0}, { 42 << 1, 0}, // 32: 0000 0000 1x + { 43 << 1, 0}, { 44 << 1, 0}, // 33: 0000 0001 0x + { 45 << 1, 0}, { 46 << 1, 0}, // 34: 0000 0001 1x + { 0, 0x1001}, { 0, 0x0502}, // 35: 0000 0010 0x + { 0, 0x0007}, { 0, 0x0203}, // 36: 0000 0010 1x + { 0, 0x0104}, { 0, 0x0f01}, // 37: 0000 0011 0x + { 0, 0x0e01}, { 0, 0x0402}, // 38: 0000 0011 1x + { 47 << 1, 0}, { 48 << 1, 0}, // 39: 0000 0000 00x + { 49 << 1, 0}, { 50 << 1, 0}, // 40: 0000 0000 01x + { 51 << 1, 0}, { 52 << 1, 0}, // 41: 0000 0000 10x + { 53 << 1, 0}, { 54 << 1, 0}, // 42: 0000 0000 11x + { 55 << 1, 0}, { 56 << 1, 0}, // 43: 0000 0001 00x + { 57 << 1, 0}, { 58 << 1, 0}, // 44: 0000 0001 01x + { 59 << 1, 0}, { 60 << 1, 0}, // 45: 0000 0001 10x + { 61 << 1, 0}, { 62 << 1, 0}, // 46: 0000 0001 11x + { -1, 0}, { 63 << 1, 0}, // 47: 0000 0000 000x + { 64 << 1, 0}, { 65 << 1, 0}, // 48: 0000 0000 001x + { 66 << 1, 0}, { 67 << 1, 0}, // 49: 0000 0000 010x + { 68 << 1, 0}, { 69 << 1, 0}, // 50: 0000 0000 011x + { 70 << 1, 0}, { 71 << 1, 0}, // 51: 0000 0000 100x + { 72 << 1, 0}, { 73 << 1, 0}, // 52: 0000 0000 101x + { 74 << 1, 0}, { 75 << 1, 0}, // 53: 0000 0000 110x + { 76 << 1, 0}, { 77 << 1, 0}, // 54: 0000 0000 111x + { 0, 0x000b}, { 0, 0x0802}, // 55: 0000 0001 000x + { 0, 0x0403}, { 0, 0x000a}, // 56: 0000 0001 001x + { 0, 0x0204}, { 0, 0x0702}, // 57: 0000 0001 010x + { 0, 0x1501}, { 0, 0x1401}, // 58: 0000 0001 011x + { 0, 0x0009}, { 0, 0x1301}, // 59: 0000 0001 100x + { 0, 0x1201}, { 0, 0x0105}, // 60: 0000 0001 101x + { 0, 0x0303}, { 0, 0x0008}, // 61: 0000 0001 110x + { 0, 0x0602}, { 0, 0x1101}, // 62: 0000 0001 111x + { 78 << 1, 0}, { 79 << 1, 0}, // 63: 0000 0000 0001x + { 80 << 1, 0}, { 81 << 1, 0}, // 64: 0000 0000 0010x + { 82 << 1, 0}, { 83 << 1, 0}, // 65: 0000 0000 0011x + { 84 << 1, 0}, { 85 << 1, 0}, // 66: 0000 0000 0100x + { 86 << 1, 0}, { 87 << 1, 0}, // 67: 0000 0000 0101x + { 88 << 1, 0}, { 89 << 1, 0}, // 68: 0000 0000 0110x + { 90 << 1, 0}, { 91 << 1, 0}, // 69: 0000 0000 0111x + { 0, 0x0a02}, { 0, 0x0902}, // 70: 0000 0000 1000x + { 0, 0x0503}, { 0, 0x0304}, // 71: 0000 0000 1001x + { 0, 0x0205}, { 0, 0x0107}, // 72: 0000 0000 1010x + { 0, 0x0106}, { 0, 0x000f}, // 73: 0000 0000 1011x + { 0, 0x000e}, { 0, 0x000d}, // 74: 0000 0000 1100x + { 0, 0x000c}, { 0, 0x1a01}, // 75: 0000 0000 1101x + { 0, 0x1901}, { 0, 0x1801}, // 76: 0000 0000 1110x + { 0, 0x1701}, { 0, 0x1601}, // 77: 0000 0000 1111x + { 92 << 1, 0}, { 93 << 1, 0}, // 78: 0000 0000 0001 0x + { 94 << 1, 0}, { 95 << 1, 0}, // 79: 0000 0000 0001 1x + { 96 << 1, 0}, { 97 << 1, 0}, // 80: 0000 0000 0010 0x + { 98 << 1, 0}, { 99 << 1, 0}, // 81: 0000 0000 0010 1x + {100 << 1, 0}, {101 << 1, 0}, // 82: 0000 0000 0011 0x + {102 << 1, 0}, {103 << 1, 0}, // 83: 0000 0000 0011 1x + { 0, 0x001f}, { 0, 0x001e}, // 84: 0000 0000 0100 0x + { 0, 0x001d}, { 0, 0x001c}, // 85: 0000 0000 0100 1x + { 0, 0x001b}, { 0, 0x001a}, // 86: 0000 0000 0101 0x + { 0, 0x0019}, { 0, 0x0018}, // 87: 0000 0000 0101 1x + { 0, 0x0017}, { 0, 0x0016}, // 88: 0000 0000 0110 0x + { 0, 0x0015}, { 0, 0x0014}, // 89: 0000 0000 0110 1x + { 0, 0x0013}, { 0, 0x0012}, // 90: 0000 0000 0111 0x + { 0, 0x0011}, { 0, 0x0010}, // 91: 0000 0000 0111 1x + {104 << 1, 0}, {105 << 1, 0}, // 92: 0000 0000 0001 00x + {106 << 1, 0}, {107 << 1, 0}, // 93: 0000 0000 0001 01x + {108 << 1, 0}, {109 << 1, 0}, // 94: 0000 0000 0001 10x + {110 << 1, 0}, {111 << 1, 0}, // 95: 0000 0000 0001 11x + { 0, 0x0028}, { 0, 0x0027}, // 96: 0000 0000 0010 00x + { 0, 0x0026}, { 0, 0x0025}, // 97: 0000 0000 0010 01x + { 0, 0x0024}, { 0, 0x0023}, // 98: 0000 0000 0010 10x + { 0, 0x0022}, { 0, 0x0021}, // 99: 0000 0000 0010 11x + { 0, 0x0020}, { 0, 0x010e}, // 100: 0000 0000 0011 00x + { 0, 0x010d}, { 0, 0x010c}, // 101: 0000 0000 0011 01x + { 0, 0x010b}, { 0, 0x010a}, // 102: 0000 0000 0011 10x + { 0, 0x0109}, { 0, 0x0108}, // 103: 0000 0000 0011 11x + { 0, 0x0112}, { 0, 0x0111}, // 104: 0000 0000 0001 000x + { 0, 0x0110}, { 0, 0x010f}, // 105: 0000 0000 0001 001x + { 0, 0x0603}, { 0, 0x1002}, // 106: 0000 0000 0001 010x + { 0, 0x0f02}, { 0, 0x0e02}, // 107: 0000 0000 0001 011x + { 0, 0x0d02}, { 0, 0x0c02}, // 108: 0000 0000 0001 100x + { 0, 0x0b02}, { 0, 0x1f01}, // 109: 0000 0000 0001 101x + { 0, 0x1e01}, { 0, 0x1d01}, // 110: 0000 0000 0001 110x + { 0, 0x1c01}, { 0, 0x1b01}, // 111: 0000 0000 0001 111x +}; + +typedef struct { + int full_px; + int is_set; + int r_size; + int h; + int v; +} plm_video_motion_t; + +typedef struct plm_video_t { + double framerate; + double time; + int frames_decoded; + int width; + int height; + int mb_width; + int mb_height; + int mb_size; + + int luma_width; + int luma_height; + + int chroma_width; + int chroma_height; + + int start_code; + int picture_type; + + plm_video_motion_t motion_forward; + plm_video_motion_t motion_backward; + + int has_sequence_header; + + int quantizer_scale; + int slice_begin; + int macroblock_address; + + int mb_row; + int mb_col; + + int macroblock_type; + int macroblock_intra; + + int dc_predictor[3]; + + plm_buffer_t *buffer; + int destroy_buffer_when_done; + + plm_frame_t frame_current; + plm_frame_t frame_forward; + plm_frame_t frame_backward; + + uint8_t *frames_data; + + int block_data[64]; + uint8_t intra_quant_matrix[64]; + uint8_t non_intra_quant_matrix[64]; + + int has_reference_frame; + int assume_no_b_frames; +} plm_video_t; + +static inline uint8_t plm_clamp(int n) { + if (n > 255) { + n = 255; + } + else if (n < 0) { + n = 0; + } + return n; +} + +int plm_video_decode_sequence_header(plm_video_t *self); +void plm_video_init_frame(plm_video_t *self, plm_frame_t *frame, uint8_t *base); +void plm_video_decode_picture(plm_video_t *self); +void plm_video_decode_slice(plm_video_t *self, int slice); +void plm_video_decode_macroblock(plm_video_t *self); +void plm_video_decode_motion_vectors(plm_video_t *self); +int plm_video_decode_motion_vector(plm_video_t *self, int r_size, int motion); +void plm_video_predict_macroblock(plm_video_t *self); +void plm_video_copy_macroblock(plm_video_t *self, int motion_h, int motion_v, plm_frame_t *d); +void plm_video_interpolate_macroblock(plm_video_t *self, int motion_h, int motion_v, plm_frame_t *d); +void plm_video_process_macroblock(plm_video_t *self, uint8_t *d, uint8_t *s, int mh, int mb, int bs, int interp); +void plm_video_decode_block(plm_video_t *self, int block); +void plm_video_idct(int *block); + +plm_video_t * plm_video_create_with_buffer(plm_buffer_t *buffer, int destroy_when_done) { + plm_video_t *self = (plm_video_t *)malloc(sizeof(plm_video_t)); + memset(self, 0, sizeof(plm_video_t)); + + self->buffer = buffer; + self->destroy_buffer_when_done = destroy_when_done; + + // Attempt to decode the sequence header + self->start_code = plm_buffer_find_start_code(self->buffer, PLM_START_SEQUENCE); + if (self->start_code != -1) { + plm_video_decode_sequence_header(self); + } + return self; +} + +void plm_video_destroy(plm_video_t *self) { + if (self->destroy_buffer_when_done) { + plm_buffer_destroy(self->buffer); + } + + if (self->has_sequence_header) { + free(self->frames_data); + } + + free(self); +} + +double plm_video_get_framerate(plm_video_t *self) { + return plm_video_has_header(self) + ? self->framerate + : 0; +} + +int plm_video_get_width(plm_video_t *self) { + return plm_video_has_header(self) + ? self->width + : 0; +} + +int plm_video_get_height(plm_video_t *self) { + return plm_video_has_header(self) + ? self->height + : 0; +} + +void plm_video_set_no_delay(plm_video_t *self, int no_delay) { + self->assume_no_b_frames = no_delay; +} + +double plm_video_get_time(plm_video_t *self) { + return self->time; +} + +void plm_video_set_time(plm_video_t *self, double time) { + self->frames_decoded = self->framerate * time; + self->time = time; +} + +void plm_video_rewind(plm_video_t *self) { + plm_buffer_rewind(self->buffer); + self->time = 0; + self->frames_decoded = 0; + self->has_reference_frame = FALSE; + self->start_code = -1; +} + +int plm_video_has_ended(plm_video_t *self) { + return plm_buffer_has_ended(self->buffer); +} + +plm_frame_t *plm_video_decode(plm_video_t *self) { + if (!plm_video_has_header(self)) { + return NULL; + } + + plm_frame_t *frame = NULL; + do { + if (self->start_code != PLM_START_PICTURE) { + self->start_code = plm_buffer_find_start_code(self->buffer, PLM_START_PICTURE); + + if (self->start_code == -1) { + // If we reached the end of the file and the previously decoded + // frame was a reference frame, we still have to return it. + if ( + self->has_reference_frame && + !self->assume_no_b_frames && + plm_buffer_has_ended(self->buffer) && ( + self->picture_type == PLM_VIDEO_PICTURE_TYPE_INTRA || + self->picture_type == PLM_VIDEO_PICTURE_TYPE_PREDICTIVE + ) + ) { + self->has_reference_frame = FALSE; + frame = &self->frame_backward; + break; + } + + return NULL; + } + } + + // Make sure we have a full picture in the buffer before attempting to + // decode it. Sadly, this can only be done by seeking for the start code + // of the next picture. Also, if we didn't find the start code for the + // next picture, but the source has ended, we assume that this last + // picture is in the buffer. + if ( + plm_buffer_has_start_code(self->buffer, PLM_START_PICTURE) == -1 && + !plm_buffer_has_ended(self->buffer) + ) { + return NULL; + } + + plm_video_decode_picture(self); + + if (self->assume_no_b_frames) { + frame = &self->frame_backward; + } + else if (self->picture_type == PLM_VIDEO_PICTURE_TYPE_B) { + frame = &self->frame_current; + } + else if (self->has_reference_frame) { + frame = &self->frame_forward; + } + else { + self->has_reference_frame = TRUE; + } + } while (!frame); + + frame->time = self->time; + self->frames_decoded++; + self->time = (double)self->frames_decoded / self->framerate; + + return frame; +} + +int plm_video_has_header(plm_video_t *self) { + if (self->has_sequence_header) { + return TRUE; + } + + if (self->start_code != PLM_START_SEQUENCE) { + self->start_code = plm_buffer_find_start_code(self->buffer, PLM_START_SEQUENCE); + } + if (self->start_code == -1) { + return FALSE; + } + + if (!plm_video_decode_sequence_header(self)) { + return FALSE; + } + + return TRUE; +} + +int plm_video_decode_sequence_header(plm_video_t *self) { + int max_header_size = 64 + 2 * 64 * 8; // 64 bit header + 2x 64 byte matrix + if (!plm_buffer_has(self->buffer, max_header_size)) { + return FALSE; + } + + self->width = plm_buffer_read(self->buffer, 12); + self->height = plm_buffer_read(self->buffer, 12); + + if (self->width <= 0 || self->height <= 0) { + return FALSE; + } + + // Skip pixel aspect ratio + plm_buffer_skip(self->buffer, 4); + + self->framerate = PLM_VIDEO_PICTURE_RATE[plm_buffer_read(self->buffer, 4)]; + + // Skip bit_rate, marker, buffer_size and constrained bit + plm_buffer_skip(self->buffer, 18 + 1 + 10 + 1); + + // Load custom intra quant matrix? + if (plm_buffer_read(self->buffer, 1)) { + for (int i = 0; i < 64; i++) { + int idx = PLM_VIDEO_ZIG_ZAG[i]; + self->intra_quant_matrix[idx] = plm_buffer_read(self->buffer, 8); + } + } + else { + memcpy(self->intra_quant_matrix, PLM_VIDEO_INTRA_QUANT_MATRIX, 64); + } + + // Load custom non intra quant matrix? + if (plm_buffer_read(self->buffer, 1)) { + for (int i = 0; i < 64; i++) { + int idx = PLM_VIDEO_ZIG_ZAG[i]; + self->non_intra_quant_matrix[idx] = plm_buffer_read(self->buffer, 8); + } + } + else { + memcpy(self->non_intra_quant_matrix, PLM_VIDEO_NON_INTRA_QUANT_MATRIX, 64); + } + + self->mb_width = (self->width + 15) >> 4; + self->mb_height = (self->height + 15) >> 4; + self->mb_size = self->mb_width * self->mb_height; + + self->luma_width = self->mb_width << 4; + self->luma_height = self->mb_height << 4; + + self->chroma_width = self->mb_width << 3; + self->chroma_height = self->mb_height << 3; + + + // Allocate one big chunk of data for all 3 frames = 9 planes + size_t luma_plane_size = self->luma_width * self->luma_height; + size_t chroma_plane_size = self->chroma_width * self->chroma_height; + size_t frame_data_size = (luma_plane_size + 2 * chroma_plane_size); + + self->frames_data = (uint8_t*)malloc(frame_data_size * 3); + plm_video_init_frame(self, &self->frame_current, self->frames_data + frame_data_size * 0); + plm_video_init_frame(self, &self->frame_forward, self->frames_data + frame_data_size * 1); + plm_video_init_frame(self, &self->frame_backward, self->frames_data + frame_data_size * 2); + + self->has_sequence_header = TRUE; + return TRUE; +} + +void plm_video_init_frame(plm_video_t *self, plm_frame_t *frame, uint8_t *base) { + size_t luma_plane_size = self->luma_width * self->luma_height; + size_t chroma_plane_size = self->chroma_width * self->chroma_height; + + frame->width = self->width; + frame->height = self->height; + frame->y.width = self->luma_width; + frame->y.height = self->luma_height; + frame->y.data = base; + + frame->cr.width = self->chroma_width; + frame->cr.height = self->chroma_height; + frame->cr.data = base + luma_plane_size; + + frame->cb.width = self->chroma_width; + frame->cb.height = self->chroma_height; + frame->cb.data = base + luma_plane_size + chroma_plane_size; +} + +void plm_video_decode_picture(plm_video_t *self) { + plm_buffer_skip(self->buffer, 10); // skip temporalReference + self->picture_type = plm_buffer_read(self->buffer, 3); + plm_buffer_skip(self->buffer, 16); // skip vbv_delay + + // D frames or unknown coding type + if (self->picture_type <= 0 || self->picture_type > PLM_VIDEO_PICTURE_TYPE_B) { + return; + } + + // Forward full_px, f_code + if ( + self->picture_type == PLM_VIDEO_PICTURE_TYPE_PREDICTIVE || + self->picture_type == PLM_VIDEO_PICTURE_TYPE_B + ) { + self->motion_forward.full_px = plm_buffer_read(self->buffer, 1); + int f_code = plm_buffer_read(self->buffer, 3); + if (f_code == 0) { + // Ignore picture with zero f_code + return; + } + self->motion_forward.r_size = f_code - 1; + } + + // Backward full_px, f_code + if (self->picture_type == PLM_VIDEO_PICTURE_TYPE_B) { + self->motion_backward.full_px = plm_buffer_read(self->buffer, 1); + int f_code = plm_buffer_read(self->buffer, 3); + if (f_code == 0) { + // Ignore picture with zero f_code + return; + } + self->motion_backward.r_size = f_code - 1; + } + + plm_frame_t frame_temp = self->frame_forward; + if ( + self->picture_type == PLM_VIDEO_PICTURE_TYPE_INTRA || + self->picture_type == PLM_VIDEO_PICTURE_TYPE_PREDICTIVE + ) { + self->frame_forward = self->frame_backward; + } + + + // Find the first slice; this skips extension and user data + do { + self->start_code = plm_buffer_next_start_code(self->buffer); + } while (!PLM_START_IS_SLICE(self->start_code)); + + // Decode all slices + do { + plm_video_decode_slice(self, self->start_code & 0x000000FF); + if (self->macroblock_address == self->mb_size - 1) { + break; + } + self->start_code = plm_buffer_next_start_code(self->buffer); + } while (PLM_START_IS_SLICE(self->start_code)); + + // If this is a reference picture rotate the prediction pointers + if ( + self->picture_type == PLM_VIDEO_PICTURE_TYPE_INTRA || + self->picture_type == PLM_VIDEO_PICTURE_TYPE_PREDICTIVE + ) { + self->frame_backward = self->frame_current; + self->frame_current = frame_temp; + } +} + +void plm_video_decode_slice(plm_video_t *self, int slice) { + self->slice_begin = TRUE; + self->macroblock_address = (slice - 1) * self->mb_width - 1; + + // Reset motion vectors and DC predictors + self->motion_backward.h = self->motion_forward.h = 0; + self->motion_backward.v = self->motion_forward.v = 0; + self->dc_predictor[0] = 128; + self->dc_predictor[1] = 128; + self->dc_predictor[2] = 128; + + self->quantizer_scale = plm_buffer_read(self->buffer, 5); + + // Skip extra + while (plm_buffer_read(self->buffer, 1)) { + plm_buffer_skip(self->buffer, 8); + } + + do { + plm_video_decode_macroblock(self); + } while ( + self->macroblock_address < self->mb_size - 1 && + plm_buffer_no_start_code(self->buffer) + ); +} + +void plm_video_decode_macroblock(plm_video_t *self) { + // Decode self->macroblock_address_increment + int increment = 0; + int t = plm_buffer_read_vlc(self->buffer, PLM_VIDEO_MACROBLOCK_ADDRESS_INCREMENT); + + while (t == 34) { + // macroblock_stuffing + t = plm_buffer_read_vlc(self->buffer, PLM_VIDEO_MACROBLOCK_ADDRESS_INCREMENT); + } + while (t == 35) { + // macroblock_escape + increment += 33; + t = plm_buffer_read_vlc(self->buffer, PLM_VIDEO_MACROBLOCK_ADDRESS_INCREMENT); + } + increment += t; + + // Process any skipped macroblocks + if (self->slice_begin) { + // The first self->macroblock_address_increment of each slice is relative + // to beginning of the preverious row, not the preverious macroblock + self->slice_begin = FALSE; + self->macroblock_address += increment; + } + else { + if (self->macroblock_address + increment >= self->mb_size) { + return; // invalid + } + if (increment > 1) { + // Skipped macroblocks reset DC predictors + self->dc_predictor[0] = 128; + self->dc_predictor[1] = 128; + self->dc_predictor[2] = 128; + + // Skipped macroblocks in P-pictures reset motion vectors + if (self->picture_type == PLM_VIDEO_PICTURE_TYPE_PREDICTIVE) { + self->motion_forward.h = 0; + self->motion_forward.v = 0; + } + } + + // Predict skipped macroblocks + while (increment > 1) { + self->macroblock_address++; + self->mb_row = self->macroblock_address / self->mb_width; + self->mb_col = self->macroblock_address % self->mb_width; + + plm_video_predict_macroblock(self); + increment--; + } + self->macroblock_address++; + } + + self->mb_row = self->macroblock_address / self->mb_width; + self->mb_col = self->macroblock_address % self->mb_width; + + if (self->mb_col >= self->mb_width || self->mb_row >= self->mb_height) { + return; // corrupt stream; + } + + // Process the current macroblock + const plm_vlc_t *table = PLM_VIDEO_MACROBLOCK_TYPE[self->picture_type]; + self->macroblock_type = plm_buffer_read_vlc(self->buffer, table); + + self->macroblock_intra = (self->macroblock_type & 0x01); + self->motion_forward.is_set = (self->macroblock_type & 0x08); + self->motion_backward.is_set = (self->macroblock_type & 0x04); + + // Quantizer scale + if ((self->macroblock_type & 0x10) != 0) { + self->quantizer_scale = plm_buffer_read(self->buffer, 5); + } + + if (self->macroblock_intra) { + // Intra-coded macroblocks reset motion vectors + self->motion_backward.h = self->motion_forward.h = 0; + self->motion_backward.v = self->motion_forward.v = 0; + } + else { + // Non-intra macroblocks reset DC predictors + self->dc_predictor[0] = 128; + self->dc_predictor[1] = 128; + self->dc_predictor[2] = 128; + + plm_video_decode_motion_vectors(self); + plm_video_predict_macroblock(self); + } + + // Decode blocks + int cbp = ((self->macroblock_type & 0x02) != 0) + ? plm_buffer_read_vlc(self->buffer, PLM_VIDEO_CODE_BLOCK_PATTERN) + : (self->macroblock_intra ? 0x3f : 0); + + for (int block = 0, mask = 0x20; block < 6; block++) { + if ((cbp & mask) != 0) { + plm_video_decode_block(self, block); + } + mask >>= 1; + } +} + +void plm_video_decode_motion_vectors(plm_video_t *self) { + + // Forward + if (self->motion_forward.is_set) { + int r_size = self->motion_forward.r_size; + self->motion_forward.h = plm_video_decode_motion_vector(self, r_size, self->motion_forward.h); + self->motion_forward.v = plm_video_decode_motion_vector(self, r_size, self->motion_forward.v); + } + else if (self->picture_type == PLM_VIDEO_PICTURE_TYPE_PREDICTIVE) { + // No motion information in P-picture, reset vectors + self->motion_forward.h = 0; + self->motion_forward.v = 0; + } + + if (self->motion_backward.is_set) { + int r_size = self->motion_backward.r_size; + self->motion_backward.h = plm_video_decode_motion_vector(self, r_size, self->motion_backward.h); + self->motion_backward.v = plm_video_decode_motion_vector(self, r_size, self->motion_backward.v); + } +} + +int plm_video_decode_motion_vector(plm_video_t *self, int r_size, int motion) { + int fscale = 1 << r_size; + int m_code = plm_buffer_read_vlc(self->buffer, PLM_VIDEO_MOTION); + int r = 0; + int d; + + if ((m_code != 0) && (fscale != 1)) { + r = plm_buffer_read(self->buffer, r_size); + d = ((abs(m_code) - 1) << r_size) + r + 1; + if (m_code < 0) { + d = -d; + } + } + else { + d = m_code; + } + + motion += d; + if (motion >(fscale << 4) - 1) { + motion -= fscale << 5; + } + else if (motion < ((-fscale) << 4)) { + motion += fscale << 5; + } + + return motion; +} + +void plm_video_predict_macroblock(plm_video_t *self) { + int fw_h = self->motion_forward.h; + int fw_v = self->motion_forward.v; + + if (self->motion_forward.full_px) { + fw_h <<= 1; + fw_v <<= 1; + } + + if (self->picture_type == PLM_VIDEO_PICTURE_TYPE_B) { + int bw_h = self->motion_backward.h; + int bw_v = self->motion_backward.v; + + if (self->motion_backward.full_px) { + bw_h <<= 1; + bw_v <<= 1; + } + + if (self->motion_forward.is_set) { + plm_video_copy_macroblock(self, fw_h, fw_v, &self->frame_forward); + if (self->motion_backward.is_set) { + plm_video_interpolate_macroblock(self, bw_h, bw_v, &self->frame_backward); + } + } + else { + plm_video_copy_macroblock(self, bw_h, bw_v, &self->frame_backward); + } + } + else { + plm_video_copy_macroblock(self, fw_h, fw_v, &self->frame_forward); + } +} + +void plm_video_copy_macroblock(plm_video_t *self, int motion_h, int motion_v, plm_frame_t *d) { + plm_frame_t *s = &self->frame_current; + plm_video_process_macroblock(self, s->y.data, d->y.data, motion_h, motion_v, 16, FALSE); + plm_video_process_macroblock(self, s->cr.data, d->cr.data, motion_h / 2, motion_v / 2, 8, FALSE); + plm_video_process_macroblock(self, s->cb.data, d->cb.data, motion_h / 2, motion_v / 2, 8, FALSE); +} + +void plm_video_interpolate_macroblock(plm_video_t *self, int motion_h, int motion_v, plm_frame_t *d) { + plm_frame_t *s = &self->frame_current; + plm_video_process_macroblock(self, s->y.data, d->y.data, motion_h, motion_v, 16, TRUE); + plm_video_process_macroblock(self, s->cr.data, d->cr.data, motion_h / 2, motion_v / 2, 8, TRUE); + plm_video_process_macroblock(self, s->cb.data, d->cb.data, motion_h / 2, motion_v / 2, 8, TRUE); +} + +#define PLM_BLOCK_SET(DEST, DEST_INDEX, DEST_WIDTH, SOURCE_INDEX, SOURCE_WIDTH, BLOCK_SIZE, OP) do { \ + int dest_scan = DEST_WIDTH - BLOCK_SIZE; \ + int source_scan = SOURCE_WIDTH - BLOCK_SIZE; \ + for (int y = 0; y < BLOCK_SIZE; y++) { \ + for (int x = 0; x < BLOCK_SIZE; x++) { \ + DEST[DEST_INDEX] = OP; \ + SOURCE_INDEX++; DEST_INDEX++; \ + } \ + SOURCE_INDEX += source_scan; \ + DEST_INDEX += dest_scan; \ + }} while(FALSE) + +void plm_video_process_macroblock( + plm_video_t *self, uint8_t *d, uint8_t *s, + int motion_h, int motion_v, int block_size, int interpolate +) { + int dw = self->mb_width * block_size; + + int hp = motion_h >> 1; + int vp = motion_v >> 1; + int odd_h = (motion_h & 1) == 1; + int odd_v = (motion_v & 1) == 1; + + unsigned int si = ((self->mb_row * block_size) + vp) * dw + (self->mb_col * block_size) + hp; + unsigned int di = (self->mb_row * dw + self->mb_col) * block_size; + + unsigned int max_address = (dw * (self->mb_height * block_size - block_size + 1) - block_size); + if (si > max_address || di > max_address) { + return; // corrupt video + } + + #define PLM_MB_CASE(INTERPOLATE, ODD_H, ODD_V, OP) \ + case ((INTERPOLATE << 2) | (ODD_H << 1) | (ODD_V)): \ + PLM_BLOCK_SET(d, di, dw, si, dw, block_size, OP); \ + break + + switch ((interpolate << 2) | (odd_h << 1) | (odd_v)) { + PLM_MB_CASE(0, 0, 0, (s[si])); + PLM_MB_CASE(0, 0, 1, (s[si] + s[si + dw] + 1) >> 1); + PLM_MB_CASE(0, 1, 0, (s[si] + s[si + 1] + 1) >> 1); + PLM_MB_CASE(0, 1, 1, (s[si] + s[si + 1] + s[si + dw] + s[si + dw + 1] + 2) >> 2); + + PLM_MB_CASE(1, 0, 0, (d[di] + (s[si]) + 1) >> 1); + PLM_MB_CASE(1, 0, 1, (d[di] + ((s[si] + s[si + dw] + 1) >> 1) + 1) >> 1); + PLM_MB_CASE(1, 1, 0, (d[di] + ((s[si] + s[si + 1] + 1) >> 1) + 1) >> 1); + PLM_MB_CASE(1, 1, 1, (d[di] + ((s[si] + s[si + 1] + s[si + dw] + s[si + dw + 1] + 2) >> 2) + 1) >> 1); + } + + #undef PLM_MB_CASE +} + +void plm_video_decode_block(plm_video_t *self, int block) { + + int n = 0; + uint8_t *quant_matrix; + + // Decode DC coefficient of intra-coded blocks + if (self->macroblock_intra) { + int predictor; + int dct_size; + + // DC prediction + int plane_index = block > 3 ? block - 3 : 0; + predictor = self->dc_predictor[plane_index]; + dct_size = plm_buffer_read_vlc(self->buffer, PLM_VIDEO_DCT_SIZE[plane_index]); + + // Read DC coeff + if (dct_size > 0) { + int differential = plm_buffer_read(self->buffer, dct_size); + if ((differential & (1 << (dct_size - 1))) != 0) { + self->block_data[0] = predictor + differential; + } + else { + self->block_data[0] = predictor + (-(1 << dct_size) | (differential + 1)); + } + } + else { + self->block_data[0] = predictor; + } + + // Save predictor value + self->dc_predictor[plane_index] = self->block_data[0]; + + // Dequantize + premultiply + self->block_data[0] <<= (3 + 5); + + quant_matrix = self->intra_quant_matrix; + n = 1; + } + else { + quant_matrix = self->non_intra_quant_matrix; + } + + // Decode AC coefficients (+DC for non-intra) + int level = 0; + while (TRUE) { + int run = 0; + uint16_t coeff = plm_buffer_read_vlc_uint(self->buffer, PLM_VIDEO_DCT_COEFF); + + if ((coeff == 0x0001) && (n > 0) && (plm_buffer_read(self->buffer, 1) == 0)) { + // end_of_block + break; + } + if (coeff == 0xffff) { + // escape + run = plm_buffer_read(self->buffer, 6); + level = plm_buffer_read(self->buffer, 8); + if (level == 0) { + level = plm_buffer_read(self->buffer, 8); + } + else if (level == 128) { + level = plm_buffer_read(self->buffer, 8) - 256; + } + else if (level > 128) { + level = level - 256; + } + } + else { + run = coeff >> 8; + level = coeff & 0xff; + if (plm_buffer_read(self->buffer, 1)) { + level = -level; + } + } + + n += run; + if (n < 0 || n >= 64) { + return; // invalid + } + + int de_zig_zagged = PLM_VIDEO_ZIG_ZAG[n]; + n++; + + // Dequantize, oddify, clip + level <<= 1; + if (!self->macroblock_intra) { + level += (level < 0 ? -1 : 1); + } + level = (level * self->quantizer_scale * quant_matrix[de_zig_zagged]) >> 4; + if ((level & 1) == 0) { + level -= level > 0 ? 1 : -1; + } + if (level > 2047) { + level = 2047; + } + else if (level < -2048) { + level = -2048; + } + + // Save premultiplied coefficient + self->block_data[de_zig_zagged] = level * PLM_VIDEO_PREMULTIPLIER_MATRIX[de_zig_zagged]; + } + + // Move block to its place + uint8_t *d; + int dw; + int di; + + if (block < 4) { + d = self->frame_current.y.data; + dw = self->luma_width; + di = (self->mb_row * self->luma_width + self->mb_col) << 4; + if ((block & 1) != 0) { + di += 8; + } + if ((block & 2) != 0) { + di += self->luma_width << 3; + } + } + else { + d = (block == 4) ? self->frame_current.cb.data : self->frame_current.cr.data; + dw = self->chroma_width; + di = ((self->mb_row * self->luma_width) << 2) + (self->mb_col << 3); + } + + int *s = self->block_data; + int si = 0; + if (self->macroblock_intra) { + // Overwrite (no prediction) + if (n == 1) { + int clamped = plm_clamp((s[0] + 128) >> 8); + PLM_BLOCK_SET(d, di, dw, si, 8, 8, clamped); + s[0] = 0; + } + else { + plm_video_idct(s); + PLM_BLOCK_SET(d, di, dw, si, 8, 8, plm_clamp(s[si])); + memset(self->block_data, 0, sizeof(self->block_data)); + } + } + else { + // Add data to the predicted macroblock + if (n == 1) { + int value = (s[0] + 128) >> 8; + PLM_BLOCK_SET(d, di, dw, si, 8, 8, plm_clamp(d[di] + value)); + s[0] = 0; + } + else { + plm_video_idct(s); + PLM_BLOCK_SET(d, di, dw, si, 8, 8, plm_clamp(d[di] + s[si])); + memset(self->block_data, 0, sizeof(self->block_data)); + } + } +} + +void plm_video_idct(int *block) { + int + b1, b3, b4, b6, b7, tmp1, tmp2, m0, + x0, x1, x2, x3, x4, y3, y4, y5, y6, y7; + + // Transform columns + for (int i = 0; i < 8; ++i) { + b1 = block[4 * 8 + i]; + b3 = block[2 * 8 + i] + block[6 * 8 + i]; + b4 = block[5 * 8 + i] - block[3 * 8 + i]; + tmp1 = block[1 * 8 + i] + block[7 * 8 + i]; + tmp2 = block[3 * 8 + i] + block[5 * 8 + i]; + b6 = block[1 * 8 + i] - block[7 * 8 + i]; + b7 = tmp1 + tmp2; + m0 = block[0 * 8 + i]; + x4 = ((b6 * 473 - b4 * 196 + 128) >> 8) - b7; + x0 = x4 - (((tmp1 - tmp2) * 362 + 128) >> 8); + x1 = m0 - b1; + x2 = (((block[2 * 8 + i] - block[6 * 8 + i]) * 362 + 128) >> 8) - b3; + x3 = m0 + b1; + y3 = x1 + x2; + y4 = x3 + b3; + y5 = x1 - x2; + y6 = x3 - b3; + y7 = -x0 - ((b4 * 473 + b6 * 196 + 128) >> 8); + block[0 * 8 + i] = b7 + y4; + block[1 * 8 + i] = x4 + y3; + block[2 * 8 + i] = y5 - x0; + block[3 * 8 + i] = y6 - y7; + block[4 * 8 + i] = y6 + y7; + block[5 * 8 + i] = x0 + y5; + block[6 * 8 + i] = y3 - x4; + block[7 * 8 + i] = y4 - b7; + } + + // Transform rows + for (int i = 0; i < 64; i += 8) { + b1 = block[4 + i]; + b3 = block[2 + i] + block[6 + i]; + b4 = block[5 + i] - block[3 + i]; + tmp1 = block[1 + i] + block[7 + i]; + tmp2 = block[3 + i] + block[5 + i]; + b6 = block[1 + i] - block[7 + i]; + b7 = tmp1 + tmp2; + m0 = block[0 + i]; + x4 = ((b6 * 473 - b4 * 196 + 128) >> 8) - b7; + x0 = x4 - (((tmp1 - tmp2) * 362 + 128) >> 8); + x1 = m0 - b1; + x2 = (((block[2 + i] - block[6 + i]) * 362 + 128) >> 8) - b3; + x3 = m0 + b1; + y3 = x1 + x2; + y4 = x3 + b3; + y5 = x1 - x2; + y6 = x3 - b3; + y7 = -x0 - ((b4 * 473 + b6 * 196 + 128) >> 8); + block[0 + i] = (b7 + y4 + 128) >> 8; + block[1 + i] = (x4 + y3 + 128) >> 8; + block[2 + i] = (y5 - x0 + 128) >> 8; + block[3 + i] = (y6 - y7 + 128) >> 8; + block[4 + i] = (y6 + y7 + 128) >> 8; + block[5 + i] = (x0 + y5 + 128) >> 8; + block[6 + i] = (y3 - x4 + 128) >> 8; + block[7 + i] = (y4 - b7 + 128) >> 8; + } +} + +// YCbCr conversion following the BT.601 standard: +// https://infogalactic.com/info/YCbCr#ITU-R_BT.601_conversion + +#define PLM_PUT_PIXEL(RI, GI, BI, Y_OFFSET, DEST_OFFSET) \ + y = ((frame->y.data[y_index + Y_OFFSET]-16) * 76309) >> 16; \ + dest[d_index + DEST_OFFSET + RI] = plm_clamp(y + r); \ + dest[d_index + DEST_OFFSET + GI] = plm_clamp(y - g); \ + dest[d_index + DEST_OFFSET + BI] = plm_clamp(y + b); + +#define PLM_DEFINE_FRAME_CONVERT_FUNCTION(NAME, BYTES_PER_PIXEL, RI, GI, BI) \ + void NAME(plm_frame_t *frame, uint8_t *dest, int stride) { \ + int cols = frame->width >> 1; \ + int rows = frame->height >> 1; \ + int yw = frame->y.width; \ + int cw = frame->cb.width; \ + for (int row = 0; row < rows; row++) { \ + int c_index = row * cw; \ + int y_index = row * 2 * yw; \ + int d_index = row * 2 * stride; \ + for (int col = 0; col < cols; col++) { \ + int y; \ + int cr = frame->cr.data[c_index] - 128; \ + int cb = frame->cb.data[c_index] - 128; \ + int r = (cr * 104597) >> 16; \ + int g = (cb * 25674 + cr * 53278) >> 16; \ + int b = (cb * 132201) >> 16; \ + PLM_PUT_PIXEL(RI, GI, BI, 0, 0); \ + PLM_PUT_PIXEL(RI, GI, BI, 1, BYTES_PER_PIXEL); \ + PLM_PUT_PIXEL(RI, GI, BI, yw, stride); \ + PLM_PUT_PIXEL(RI, GI, BI, yw + 1, stride + BYTES_PER_PIXEL); \ + c_index += 1; \ + y_index += 2; \ + d_index += 2 * BYTES_PER_PIXEL; \ + } \ + } \ + } + +PLM_DEFINE_FRAME_CONVERT_FUNCTION(plm_frame_to_rgb, 3, 0, 1, 2) +PLM_DEFINE_FRAME_CONVERT_FUNCTION(plm_frame_to_bgr, 3, 2, 1, 0) +PLM_DEFINE_FRAME_CONVERT_FUNCTION(plm_frame_to_rgba, 4, 0, 1, 2) +PLM_DEFINE_FRAME_CONVERT_FUNCTION(plm_frame_to_bgra, 4, 2, 1, 0) +PLM_DEFINE_FRAME_CONVERT_FUNCTION(plm_frame_to_argb, 4, 1, 2, 3) +PLM_DEFINE_FRAME_CONVERT_FUNCTION(plm_frame_to_abgr, 4, 3, 2, 1) + + +#undef PLM_PUT_PIXEL +#undef PLM_DEFINE_FRAME_CONVERT_FUNCTION + + + +// ----------------------------------------------------------------------------- +// plm_audio implementation + +// Based on kjmp2 by Martin J. Fiedler +// http://keyj.emphy.de/kjmp2/ + +static const int PLM_AUDIO_FRAME_SYNC = 0x7ff; + +static const int PLM_AUDIO_MPEG_2_5 = 0x0; +static const int PLM_AUDIO_MPEG_2 = 0x2; +static const int PLM_AUDIO_MPEG_1 = 0x3; + +static const int PLM_AUDIO_LAYER_III = 0x1; +static const int PLM_AUDIO_LAYER_II = 0x2; +static const int PLM_AUDIO_LAYER_I = 0x3; + +static const int PLM_AUDIO_MODE_STEREO = 0x0; +static const int PLM_AUDIO_MODE_JOINT_STEREO = 0x1; +static const int PLM_AUDIO_MODE_DUAL_CHANNEL = 0x2; +static const int PLM_AUDIO_MODE_MONO = 0x3; + +static const unsigned short PLM_AUDIO_SAMPLE_RATE[] = { + 44100, 48000, 32000, 0, // MPEG-1 + 22050, 24000, 16000, 0 // MPEG-2 +}; + +static const short PLM_AUDIO_BIT_RATE[] = { + 32, 48, 56, 64, 80, 96, 112, 128, 160, 192, 224, 256, 320, 384, // MPEG-1 + 8, 16, 24, 32, 40, 48, 56, 64, 80, 96, 112, 128, 144, 160 // MPEG-2 +}; + +static const int PLM_AUDIO_SCALEFACTOR_BASE[] = { + 0x02000000, 0x01965FEA, 0x01428A30 +}; + +static const float PLM_AUDIO_SYNTHESIS_WINDOW[] = { + 0.0, -0.5, -0.5, -0.5, -0.5, -0.5, + -0.5, -1.0, -1.0, -1.0, -1.0, -1.5, + -1.5, -2.0, -2.0, -2.5, -2.5, -3.0, + -3.5, -3.5, -4.0, -4.5, -5.0, -5.5, + -6.5, -7.0, -8.0, -8.5, -9.5, -10.5, + -12.0, -13.0, -14.5, -15.5, -17.5, -19.0, + -20.5, -22.5, -24.5, -26.5, -29.0, -31.5, + -34.0, -36.5, -39.5, -42.5, -45.5, -48.5, + -52.0, -55.5, -58.5, -62.5, -66.0, -69.5, + -73.5, -77.0, -80.5, -84.5, -88.0, -91.5, + -95.0, -98.0, -101.0, -104.0, 106.5, 109.0, + 111.0, 112.5, 113.5, 114.0, 114.0, 113.5, + 112.0, 110.5, 107.5, 104.0, 100.0, 94.5, + 88.5, 81.5, 73.0, 63.5, 53.0, 41.5, + 28.5, 14.5, -1.0, -18.0, -36.0, -55.5, + -76.5, -98.5, -122.0, -147.0, -173.5, -200.5, + -229.5, -259.5, -290.5, -322.5, -355.5, -389.5, + -424.0, -459.5, -495.5, -532.0, -568.5, -605.0, + -641.5, -678.0, -714.0, -749.0, -783.5, -817.0, + -849.0, -879.5, -908.5, -935.0, -959.5, -981.0, + -1000.5, -1016.0, -1028.5, -1037.5, -1042.5, -1043.5, + -1040.0, -1031.5, 1018.5, 1000.0, 976.0, 946.5, + 911.0, 869.5, 822.0, 767.5, 707.0, 640.0, + 565.5, 485.0, 397.0, 302.5, 201.0, 92.5, + -22.5, -144.0, -272.5, -407.0, -547.5, -694.0, + -846.0, -1003.0, -1165.0, -1331.5, -1502.0, -1675.5, + -1852.5, -2031.5, -2212.5, -2394.0, -2576.5, -2758.5, + -2939.5, -3118.5, -3294.5, -3467.5, -3635.5, -3798.5, + -3955.0, -4104.5, -4245.5, -4377.5, -4499.0, -4609.5, + -4708.0, -4792.5, -4863.5, -4919.0, -4958.0, -4979.5, + -4983.0, -4967.5, -4931.5, -4875.0, -4796.0, -4694.5, + -4569.5, -4420.0, -4246.0, -4046.0, -3820.0, -3567.0, + 3287.0, 2979.5, 2644.0, 2280.5, 1888.0, 1467.5, + 1018.5, 541.0, 35.0, -499.0, -1061.0, -1650.0, + -2266.5, -2909.0, -3577.0, -4270.0, -4987.5, -5727.5, + -6490.0, -7274.0, -8077.5, -8899.5, -9739.0, -10594.5, + -11464.5, -12347.0, -13241.0, -14144.5, -15056.0, -15973.5, + -16895.5, -17820.0, -18744.5, -19668.0, -20588.0, -21503.0, + -22410.5, -23308.5, -24195.0, -25068.5, -25926.5, -26767.0, + -27589.0, -28389.0, -29166.5, -29919.0, -30644.5, -31342.0, + -32009.5, -32645.0, -33247.0, -33814.5, -34346.0, -34839.5, + -35295.0, -35710.0, -36084.5, -36417.5, -36707.5, -36954.0, + -37156.5, -37315.0, -37428.0, -37496.0, 37519.0, 37496.0, + 37428.0, 37315.0, 37156.5, 36954.0, 36707.5, 36417.5, + 36084.5, 35710.0, 35295.0, 34839.5, 34346.0, 33814.5, + 33247.0, 32645.0, 32009.5, 31342.0, 30644.5, 29919.0, + 29166.5, 28389.0, 27589.0, 26767.0, 25926.5, 25068.5, + 24195.0, 23308.5, 22410.5, 21503.0, 20588.0, 19668.0, + 18744.5, 17820.0, 16895.5, 15973.5, 15056.0, 14144.5, + 13241.0, 12347.0, 11464.5, 10594.5, 9739.0, 8899.5, + 8077.5, 7274.0, 6490.0, 5727.5, 4987.5, 4270.0, + 3577.0, 2909.0, 2266.5, 1650.0, 1061.0, 499.0, + -35.0, -541.0, -1018.5, -1467.5, -1888.0, -2280.5, + -2644.0, -2979.5, 3287.0, 3567.0, 3820.0, 4046.0, + 4246.0, 4420.0, 4569.5, 4694.5, 4796.0, 4875.0, + 4931.5, 4967.5, 4983.0, 4979.5, 4958.0, 4919.0, + 4863.5, 4792.5, 4708.0, 4609.5, 4499.0, 4377.5, + 4245.5, 4104.5, 3955.0, 3798.5, 3635.5, 3467.5, + 3294.5, 3118.5, 2939.5, 2758.5, 2576.5, 2394.0, + 2212.5, 2031.5, 1852.5, 1675.5, 1502.0, 1331.5, + 1165.0, 1003.0, 846.0, 694.0, 547.5, 407.0, + 272.5, 144.0, 22.5, -92.5, -201.0, -302.5, + -397.0, -485.0, -565.5, -640.0, -707.0, -767.5, + -822.0, -869.5, -911.0, -946.5, -976.0, -1000.0, + 1018.5, 1031.5, 1040.0, 1043.5, 1042.5, 1037.5, + 1028.5, 1016.0, 1000.5, 981.0, 959.5, 935.0, + 908.5, 879.5, 849.0, 817.0, 783.5, 749.0, + 714.0, 678.0, 641.5, 605.0, 568.5, 532.0, + 495.5, 459.5, 424.0, 389.5, 355.5, 322.5, + 290.5, 259.5, 229.5, 200.5, 173.5, 147.0, + 122.0, 98.5, 76.5, 55.5, 36.0, 18.0, + 1.0, -14.5, -28.5, -41.5, -53.0, -63.5, + -73.0, -81.5, -88.5, -94.5, -100.0, -104.0, + -107.5, -110.5, -112.0, -113.5, -114.0, -114.0, + -113.5, -112.5, -111.0, -109.0, 106.5, 104.0, + 101.0, 98.0, 95.0, 91.5, 88.0, 84.5, + 80.5, 77.0, 73.5, 69.5, 66.0, 62.5, + 58.5, 55.5, 52.0, 48.5, 45.5, 42.5, + 39.5, 36.5, 34.0, 31.5, 29.0, 26.5, + 24.5, 22.5, 20.5, 19.0, 17.5, 15.5, + 14.5, 13.0, 12.0, 10.5, 9.5, 8.5, + 8.0, 7.0, 6.5, 5.5, 5.0, 4.5, + 4.0, 3.5, 3.5, 3.0, 2.5, 2.5, + 2.0, 2.0, 1.5, 1.5, 1.0, 1.0, + 1.0, 1.0, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5 +}; + +// Quantizer lookup, step 1: bitrate classes +static const uint8_t PLM_AUDIO_QUANT_LUT_STEP_1[2][16] = { + // 32, 48, 56, 64, 80, 96,112,128,160,192,224,256,320,384 <- bitrate + { 0, 0, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2 }, // mono + // 16, 24, 28, 32, 40, 48, 56, 64, 80, 96,112,128,160,192 <- bitrate / chan + { 0, 0, 0, 0, 0, 0, 1, 1, 1, 2, 2, 2, 2, 2 } // stereo +}; + +// Quantizer lookup, step 2: bitrate class, sample rate -> B2 table idx, sblimit +static const uint8_t PLM_AUDIO_QUANT_TAB_A = (27 | 64); // Table 3-B.2a: high-rate, sblimit = 27 +static const uint8_t PLM_AUDIO_QUANT_TAB_B = (30 | 64); // Table 3-B.2b: high-rate, sblimit = 30 +static const uint8_t PLM_AUDIO_QUANT_TAB_C = 8; // Table 3-B.2c: low-rate, sblimit = 8 +static const uint8_t PLM_AUDIO_QUANT_TAB_D = 12; // Table 3-B.2d: low-rate, sblimit = 12 + +/* TODO: This doesn't compile w/ TCC for some reason? +static const uint8_t QUANT_LUT_STEP_2[3][3] = { + //44.1 kHz, 48 kHz, 32 kHz + { PLM_AUDIO_QUANT_TAB_C, PLM_AUDIO_QUANT_TAB_C, PLM_AUDIO_QUANT_TAB_D }, // 32 - 48 kbit/sec/ch + { PLM_AUDIO_QUANT_TAB_A, PLM_AUDIO_QUANT_TAB_A, PLM_AUDIO_QUANT_TAB_A }, // 56 - 80 kbit/sec/ch + { PLM_AUDIO_QUANT_TAB_B, PLM_AUDIO_QUANT_TAB_A, PLM_AUDIO_QUANT_TAB_B } // 96+ kbit/sec/ch +}; +*/ + +static const uint8_t QUANT_LUT_STEP_2[3][3] = { + //44.1 kHz, 48 kHz, 32 kHz + { 8, 8, 12 }, // 32 - 48 kbit/sec/ch + { (27 | 64), (27 | 64), (27 | 64) }, // 56 - 80 kbit/sec/ch + { (30 | 64), (27 | 64), (30 | 64) } // 96+ kbit/sec/ch +}; + +// Quantizer lookup, step 3: B2 table, subband -> nbal, row index +// (upper 4 bits: nbal, lower 4 bits: row index) +static const uint8_t PLM_AUDIO_QUANT_LUT_STEP_3[3][32] = { + // Low-rate table (3-B.2c and 3-B.2d) + { + 0x44,0x44, + 0x34,0x34,0x34,0x34,0x34,0x34,0x34,0x34,0x34,0x34 + }, + // High-rate table (3-B.2a and 3-B.2b) + { + 0x43,0x43,0x43, + 0x42,0x42,0x42,0x42,0x42,0x42,0x42,0x42, + 0x31,0x31,0x31,0x31,0x31,0x31,0x31,0x31,0x31,0x31,0x31,0x31, + 0x20,0x20,0x20,0x20,0x20,0x20,0x20 + }, + // MPEG-2 LSR table (B.2 in ISO 13818-3) + { + 0x45,0x45,0x45,0x45, + 0x34,0x34,0x34,0x34,0x34,0x34,0x34, + 0x24,0x24,0x24,0x24,0x24,0x24,0x24,0x24,0x24,0x24, + 0x24,0x24,0x24,0x24,0x24,0x24,0x24,0x24,0x24 + } +}; + +// Quantizer lookup, step 4: table row, allocation[] value -> quant table index +static const uint8_t PLM_AUDIO_QUANT_LUT_STEP4[6][16] = { + { 0, 1, 2, 17 }, + { 0, 1, 2, 3, 4, 5, 6, 17 }, + { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 17 }, + { 0, 1, 3, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17 }, + { 0, 1, 2, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 17 }, + { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 } +}; + +typedef struct plm_quantizer_spec_t { + unsigned short levels; + unsigned char group; + unsigned char bits; +} plm_quantizer_spec_t; + +static const plm_quantizer_spec_t PLM_AUDIO_QUANT_TAB[] = { + { 3, 1, 5 }, // 1 + { 5, 1, 7 }, // 2 + { 7, 0, 3 }, // 3 + { 9, 1, 10 }, // 4 + { 15, 0, 4 }, // 5 + { 31, 0, 5 }, // 6 + { 63, 0, 6 }, // 7 + { 127, 0, 7 }, // 8 + { 255, 0, 8 }, // 9 + { 511, 0, 9 }, // 10 + { 1023, 0, 10 }, // 11 + { 2047, 0, 11 }, // 12 + { 4095, 0, 12 }, // 13 + { 8191, 0, 13 }, // 14 + { 16383, 0, 14 }, // 15 + { 32767, 0, 15 }, // 16 + { 65535, 0, 16 } // 17 +}; + +typedef struct plm_audio_t { + double time; + int samples_decoded; + int samplerate_index; + int bitrate_index; + int version; + int layer; + int mode; + int bound; + int v_pos; + int next_frame_data_size; + int has_header; + + plm_buffer_t *buffer; + int destroy_buffer_when_done; + + const plm_quantizer_spec_t *allocation[2][32]; + uint8_t scale_factor_info[2][32]; + int scale_factor[2][32][3]; + int sample[2][32][3]; + + plm_samples_t samples; + float D[1024]; + float V[2][1024]; + float U[32]; +} plm_audio_t; + +int plm_audio_find_frame_sync(plm_audio_t *self); +int plm_audio_decode_header(plm_audio_t *self); +void plm_audio_decode_frame(plm_audio_t *self); +const plm_quantizer_spec_t *plm_audio_read_allocation(plm_audio_t *self, int sb, int tab3); +void plm_audio_read_samples(plm_audio_t *self, int ch, int sb, int part); +void plm_audio_matrix_transform(int s[32][3], int ss, float *d, int dp); + +plm_audio_t *plm_audio_create_with_buffer(plm_buffer_t *buffer, int destroy_when_done) { + plm_audio_t *self = (plm_audio_t *)malloc(sizeof(plm_audio_t)); + memset(self, 0, sizeof(plm_audio_t)); + + self->samples.count = PLM_AUDIO_SAMPLES_PER_FRAME; + self->buffer = buffer; + self->destroy_buffer_when_done = destroy_when_done; + self->samplerate_index = 3; // Indicates 0 + + memcpy(self->D, PLM_AUDIO_SYNTHESIS_WINDOW, 512 * sizeof(float)); + memcpy(self->D + 512, PLM_AUDIO_SYNTHESIS_WINDOW, 512 * sizeof(float)); + + // Attempt to decode first header + self->next_frame_data_size = plm_audio_decode_header(self); + + return self; +} + +void plm_audio_destroy(plm_audio_t *self) { + if (self->destroy_buffer_when_done) { + plm_buffer_destroy(self->buffer); + } + free(self); +} + +int plm_audio_has_header(plm_audio_t *self) { + if (self->has_header) { + return TRUE; + } + + self->next_frame_data_size = plm_audio_decode_header(self); + return self->has_header; +} + +int plm_audio_get_samplerate(plm_audio_t *self) { + return plm_audio_has_header(self) + ? PLM_AUDIO_SAMPLE_RATE[self->samplerate_index] + : 0; +} + +double plm_audio_get_time(plm_audio_t *self) { + return self->time; +} + +void plm_audio_set_time(plm_audio_t *self, double time) { + self->samples_decoded = time * + (double)PLM_AUDIO_SAMPLE_RATE[self->samplerate_index]; + self->time = time; +} + +void plm_audio_rewind(plm_audio_t *self) { + plm_buffer_rewind(self->buffer); + self->time = 0; + self->samples_decoded = 0; + self->next_frame_data_size = 0; +} + +int plm_audio_has_ended(plm_audio_t *self) { + return plm_buffer_has_ended(self->buffer); +} + +plm_samples_t *plm_audio_decode(plm_audio_t *self) { + // Do we have at least enough information to decode the frame header? + if (!self->next_frame_data_size) { + if (!plm_buffer_has(self->buffer, 48)) { + return NULL; + } + self->next_frame_data_size = plm_audio_decode_header(self); + } + + if ( + self->next_frame_data_size == 0 || + !plm_buffer_has(self->buffer, self->next_frame_data_size << 3) + ) { + return NULL; + } + + plm_audio_decode_frame(self); + self->next_frame_data_size = 0; + + self->samples.time = self->time; + + self->samples_decoded += PLM_AUDIO_SAMPLES_PER_FRAME; + self->time = (double)self->samples_decoded / + (double)PLM_AUDIO_SAMPLE_RATE[self->samplerate_index]; + + return &self->samples; +} + +int plm_audio_find_frame_sync(plm_audio_t *self) { + size_t i; + for (i = self->buffer->bit_index >> 3; i < self->buffer->length-1; i++) { + if ( + self->buffer->bytes[i] == 0xFF && + (self->buffer->bytes[i+1] & 0xFE) == 0xFC + ) { + self->buffer->bit_index = ((i+1) << 3) + 3; + return TRUE; + } + } + self->buffer->bit_index = (i + 1) << 3; + return FALSE; +} + +int plm_audio_decode_header(plm_audio_t *self) { + if (!plm_buffer_has(self->buffer, 48)) { + return 0; + } + + plm_buffer_skip_bytes(self->buffer, 0x00); + int sync = plm_buffer_read(self->buffer, 11); + + + // Attempt to resync if no syncword was found. This sucks balls. The MP2 + // stream contains a syncword just before every frame (11 bits set to 1). + // However, this syncword is not guaranteed to not occur elswhere in the + // stream. So, if we have to resync, we also have to check if the header + // (samplerate, bitrate) differs from the one we had before. This all + // may still lead to garbage data being decoded :/ + + if (sync != PLM_AUDIO_FRAME_SYNC && !plm_audio_find_frame_sync(self)) { + return 0; + } + + self->version = plm_buffer_read(self->buffer, 2); + self->layer = plm_buffer_read(self->buffer, 2); + int hasCRC = !plm_buffer_read(self->buffer, 1); + + if ( + self->version != PLM_AUDIO_MPEG_1 || + self->layer != PLM_AUDIO_LAYER_II + ) { + return 0; + } + + int bitrate_index = plm_buffer_read(self->buffer, 4) - 1; + if (bitrate_index > 13) { + return 0; + } + + int samplerate_index = plm_buffer_read(self->buffer, 2); + if (samplerate_index == 3) { + return 0; + } + + int padding = plm_buffer_read(self->buffer, 1); + plm_buffer_skip(self->buffer, 1); // f_private + int mode = plm_buffer_read(self->buffer, 2); + + // If we already have a header, make sure the samplerate, bitrate and mode + // are still the same, otherwise we might have missed sync. + if ( + self->has_header && ( + self->bitrate_index != bitrate_index || + self->samplerate_index != samplerate_index || + self->mode != mode + ) + ) { + return 0; + } + + self->bitrate_index = bitrate_index; + self->samplerate_index = samplerate_index; + self->mode = mode; + self->has_header = TRUE; + + // Parse the mode_extension, set up the stereo bound + if (mode == PLM_AUDIO_MODE_JOINT_STEREO) { + self->bound = (plm_buffer_read(self->buffer, 2) + 1) << 2; + } + else { + plm_buffer_skip(self->buffer, 2); + self->bound = (mode == PLM_AUDIO_MODE_MONO) ? 0 : 32; + } + + // Discard the last 4 bits of the header and the CRC value, if present + plm_buffer_skip(self->buffer, 4); + if (hasCRC) { + plm_buffer_skip(self->buffer, 16); + } + + // Compute frame size, check if we have enough data to decode the whole + // frame. + int bitrate = PLM_AUDIO_BIT_RATE[self->bitrate_index]; + int samplerate = PLM_AUDIO_SAMPLE_RATE[self->samplerate_index]; + int frame_size = (144000 * bitrate / samplerate) + padding; + return frame_size - (hasCRC ? 6 : 4); +} + +void plm_audio_decode_frame(plm_audio_t *self) { + // Prepare the quantizer table lookups + int tab3 = 0; + int sblimit = 0; + + int tab1 = (self->mode == PLM_AUDIO_MODE_MONO) ? 0 : 1; + int tab2 = PLM_AUDIO_QUANT_LUT_STEP_1[tab1][self->bitrate_index]; + tab3 = QUANT_LUT_STEP_2[tab2][self->samplerate_index]; + sblimit = tab3 & 63; + tab3 >>= 6; + + if (self->bound > sblimit) { + self->bound = sblimit; + } + + // Read the allocation information + for (int sb = 0; sb < self->bound; sb++) { + self->allocation[0][sb] = plm_audio_read_allocation(self, sb, tab3); + self->allocation[1][sb] = plm_audio_read_allocation(self, sb, tab3); + } + + for (int sb = self->bound; sb < sblimit; sb++) { + self->allocation[0][sb] = + self->allocation[1][sb] = + plm_audio_read_allocation(self, sb, tab3); + } + + // Read scale factor selector information + int channels = (self->mode == PLM_AUDIO_MODE_MONO) ? 1 : 2; + for (int sb = 0; sb < sblimit; sb++) { + for (int ch = 0; ch < channels; ch++) { + if (self->allocation[ch][sb]) { + self->scale_factor_info[ch][sb] = plm_buffer_read(self->buffer, 2); + } + } + if (self->mode == PLM_AUDIO_MODE_MONO) { + self->scale_factor_info[1][sb] = self->scale_factor_info[0][sb]; + } + } + + // Read scale factors + for (int sb = 0; sb < sblimit; sb++) { + for (int ch = 0; ch < channels; ch++) { + if (self->allocation[ch][sb]) { + int *sf = self->scale_factor[ch][sb]; + switch (self->scale_factor_info[ch][sb]) { + case 0: + sf[0] = plm_buffer_read(self->buffer, 6); + sf[1] = plm_buffer_read(self->buffer, 6); + sf[2] = plm_buffer_read(self->buffer, 6); + break; + case 1: + sf[0] = + sf[1] = plm_buffer_read(self->buffer, 6); + sf[2] = plm_buffer_read(self->buffer, 6); + break; + case 2: + sf[0] = + sf[1] = + sf[2] = plm_buffer_read(self->buffer, 6); + break; + case 3: + sf[0] = plm_buffer_read(self->buffer, 6); + sf[1] = + sf[2] = plm_buffer_read(self->buffer, 6); + break; + } + } + } + if (self->mode == PLM_AUDIO_MODE_MONO) { + self->scale_factor[1][sb][0] = self->scale_factor[0][sb][0]; + self->scale_factor[1][sb][1] = self->scale_factor[0][sb][1]; + self->scale_factor[1][sb][2] = self->scale_factor[0][sb][2]; + } + } + + // Coefficient input and reconstruction + int out_pos = 0; + for (int part = 0; part < 3; part++) { + for (int granule = 0; granule < 4; granule++) { + + // Read the samples + for (int sb = 0; sb < self->bound; sb++) { + plm_audio_read_samples(self, 0, sb, part); + plm_audio_read_samples(self, 1, sb, part); + } + for (int sb = self->bound; sb < sblimit; sb++) { + plm_audio_read_samples(self, 0, sb, part); + self->sample[1][sb][0] = self->sample[0][sb][0]; + self->sample[1][sb][1] = self->sample[0][sb][1]; + self->sample[1][sb][2] = self->sample[0][sb][2]; + } + for (int sb = sblimit; sb < 32; sb++) { + self->sample[0][sb][0] = 0; + self->sample[0][sb][1] = 0; + self->sample[0][sb][2] = 0; + self->sample[1][sb][0] = 0; + self->sample[1][sb][1] = 0; + self->sample[1][sb][2] = 0; + } + + // Synthesis loop + for (int p = 0; p < 3; p++) { + // Shifting step + self->v_pos = (self->v_pos - 64) & 1023; + + for (int ch = 0; ch < 2; ch++) { + plm_audio_matrix_transform(self->sample[ch], p, self->V[ch], self->v_pos); + + // Build U, windowing, calculate output + memset(self->U, 0, sizeof(self->U)); + + int d_index = 512 - (self->v_pos >> 1); + int v_index = (self->v_pos % 128) >> 1; + while (v_index < 1024) { + for (int i = 0; i < 32; ++i) { + self->U[i] += self->D[d_index++] * self->V[ch][v_index++]; + } + + v_index += 128 - 32; + d_index += 64 - 32; + } + + d_index -= (512 - 32); + v_index = (128 - 32 + 1024) - v_index; + while (v_index < 1024) { + for (int i = 0; i < 32; ++i) { + self->U[i] += self->D[d_index++] * self->V[ch][v_index++]; + } + + v_index += 128 - 32; + d_index += 64 - 32; + } + + // Output samples + #ifdef PLM_AUDIO_SEPARATE_CHANNELS + float *out_channel = ch == 0 + ? self->samples.left + : self->samples.right; + for (int j = 0; j < 32; j++) { + out_channel[out_pos + j] = self->U[j] / 2147418112.0f; + } + #else + for (int j = 0; j < 32; j++) { + self->samples.interleaved[((out_pos + j) << 1) + ch] = + self->U[j] / 2147418112.0f; + } + #endif + } // End of synthesis channel loop + out_pos += 32; + } // End of synthesis sub-block loop + + } // Decoding of the granule finished + } + + plm_buffer_align(self->buffer); +} + +const plm_quantizer_spec_t *plm_audio_read_allocation(plm_audio_t *self, int sb, int tab3) { + int tab4 = PLM_AUDIO_QUANT_LUT_STEP_3[tab3][sb]; + int qtab = PLM_AUDIO_QUANT_LUT_STEP4[tab4 & 15][plm_buffer_read(self->buffer, tab4 >> 4)]; + return qtab ? (&PLM_AUDIO_QUANT_TAB[qtab - 1]) : 0; +} + +void plm_audio_read_samples(plm_audio_t *self, int ch, int sb, int part) { + const plm_quantizer_spec_t *q = self->allocation[ch][sb]; + int sf = self->scale_factor[ch][sb][part]; + int *sample = self->sample[ch][sb]; + int val = 0; + + if (!q) { + // No bits allocated for this subband + sample[0] = sample[1] = sample[2] = 0; + return; + } + + // Resolve scalefactor + if (sf == 63) { + sf = 0; + } + else { + int shift = (sf / 3) | 0; + sf = (PLM_AUDIO_SCALEFACTOR_BASE[sf % 3] + ((1 << shift) >> 1)) >> shift; + } + + // Decode samples + int adj = q->levels; + if (q->group) { + // Decode grouped samples + val = plm_buffer_read(self->buffer, q->bits); + sample[0] = val % adj; + val /= adj; + sample[1] = val % adj; + sample[2] = val / adj; + } + else { + // Decode direct samples + sample[0] = plm_buffer_read(self->buffer, q->bits); + sample[1] = plm_buffer_read(self->buffer, q->bits); + sample[2] = plm_buffer_read(self->buffer, q->bits); + } + + // Postmultiply samples + int scale = 65536 / (adj + 1); + adj = ((adj + 1) >> 1) - 1; + + val = (adj - sample[0]) * scale; + sample[0] = (val * (sf >> 12) + ((val * (sf & 4095) + 2048) >> 12)) >> 12; + + val = (adj - sample[1]) * scale; + sample[1] = (val * (sf >> 12) + ((val * (sf & 4095) + 2048) >> 12)) >> 12; + + val = (adj - sample[2]) * scale; + sample[2] = (val * (sf >> 12) + ((val * (sf & 4095) + 2048) >> 12)) >> 12; +} + +void plm_audio_matrix_transform(int s[32][3], int ss, float *d, int dp) { + float t01, t02, t03, t04, t05, t06, t07, t08, t09, t10, t11, t12, + t13, t14, t15, t16, t17, t18, t19, t20, t21, t22, t23, t24, + t25, t26, t27, t28, t29, t30, t31, t32, t33; + + t01 = (float)(s[0][ss] + s[31][ss]); t02 = (float)(s[0][ss] - s[31][ss]) * 0.500602998235f; + t03 = (float)(s[1][ss] + s[30][ss]); t04 = (float)(s[1][ss] - s[30][ss]) * 0.505470959898f; + t05 = (float)(s[2][ss] + s[29][ss]); t06 = (float)(s[2][ss] - s[29][ss]) * 0.515447309923f; + t07 = (float)(s[3][ss] + s[28][ss]); t08 = (float)(s[3][ss] - s[28][ss]) * 0.53104259109f; + t09 = (float)(s[4][ss] + s[27][ss]); t10 = (float)(s[4][ss] - s[27][ss]) * 0.553103896034f; + t11 = (float)(s[5][ss] + s[26][ss]); t12 = (float)(s[5][ss] - s[26][ss]) * 0.582934968206f; + t13 = (float)(s[6][ss] + s[25][ss]); t14 = (float)(s[6][ss] - s[25][ss]) * 0.622504123036f; + t15 = (float)(s[7][ss] + s[24][ss]); t16 = (float)(s[7][ss] - s[24][ss]) * 0.674808341455f; + t17 = (float)(s[8][ss] + s[23][ss]); t18 = (float)(s[8][ss] - s[23][ss]) * 0.744536271002f; + t19 = (float)(s[9][ss] + s[22][ss]); t20 = (float)(s[9][ss] - s[22][ss]) * 0.839349645416f; + t21 = (float)(s[10][ss] + s[21][ss]); t22 = (float)(s[10][ss] - s[21][ss]) * 0.972568237862f; + t23 = (float)(s[11][ss] + s[20][ss]); t24 = (float)(s[11][ss] - s[20][ss]) * 1.16943993343f; + t25 = (float)(s[12][ss] + s[19][ss]); t26 = (float)(s[12][ss] - s[19][ss]) * 1.48416461631f; + t27 = (float)(s[13][ss] + s[18][ss]); t28 = (float)(s[13][ss] - s[18][ss]) * 2.05778100995f; + t29 = (float)(s[14][ss] + s[17][ss]); t30 = (float)(s[14][ss] - s[17][ss]) * 3.40760841847f; + t31 = (float)(s[15][ss] + s[16][ss]); t32 = (float)(s[15][ss] - s[16][ss]) * 10.1900081235f; + + t33 = t01 + t31; t31 = (t01 - t31) * 0.502419286188f; + t01 = t03 + t29; t29 = (t03 - t29) * 0.52249861494f; + t03 = t05 + t27; t27 = (t05 - t27) * 0.566944034816f; + t05 = t07 + t25; t25 = (t07 - t25) * 0.64682178336f; + t07 = t09 + t23; t23 = (t09 - t23) * 0.788154623451f; + t09 = t11 + t21; t21 = (t11 - t21) * 1.06067768599f; + t11 = t13 + t19; t19 = (t13 - t19) * 1.72244709824f; + t13 = t15 + t17; t17 = (t15 - t17) * 5.10114861869f; + t15 = t33 + t13; t13 = (t33 - t13) * 0.509795579104f; + t33 = t01 + t11; t01 = (t01 - t11) * 0.601344886935f; + t11 = t03 + t09; t09 = (t03 - t09) * 0.899976223136f; + t03 = t05 + t07; t07 = (t05 - t07) * 2.56291544774f; + t05 = t15 + t03; t15 = (t15 - t03) * 0.541196100146f; + t03 = t33 + t11; t11 = (t33 - t11) * 1.30656296488f; + t33 = t05 + t03; t05 = (t05 - t03) * 0.707106781187f; + t03 = t15 + t11; t15 = (t15 - t11) * 0.707106781187f; + t03 += t15; + t11 = t13 + t07; t13 = (t13 - t07) * 0.541196100146f; + t07 = t01 + t09; t09 = (t01 - t09) * 1.30656296488f; + t01 = t11 + t07; t07 = (t11 - t07) * 0.707106781187f; + t11 = t13 + t09; t13 = (t13 - t09) * 0.707106781187f; + t11 += t13; t01 += t11; + t11 += t07; t07 += t13; + t09 = t31 + t17; t31 = (t31 - t17) * 0.509795579104f; + t17 = t29 + t19; t29 = (t29 - t19) * 0.601344886935f; + t19 = t27 + t21; t21 = (t27 - t21) * 0.899976223136f; + t27 = t25 + t23; t23 = (t25 - t23) * 2.56291544774f; + t25 = t09 + t27; t09 = (t09 - t27) * 0.541196100146f; + t27 = t17 + t19; t19 = (t17 - t19) * 1.30656296488f; + t17 = t25 + t27; t27 = (t25 - t27) * 0.707106781187f; + t25 = t09 + t19; t19 = (t09 - t19) * 0.707106781187f; + t25 += t19; + t09 = t31 + t23; t31 = (t31 - t23) * 0.541196100146f; + t23 = t29 + t21; t21 = (t29 - t21) * 1.30656296488f; + t29 = t09 + t23; t23 = (t09 - t23) * 0.707106781187f; + t09 = t31 + t21; t31 = (t31 - t21) * 0.707106781187f; + t09 += t31; t29 += t09; t09 += t23; t23 += t31; + t17 += t29; t29 += t25; t25 += t09; t09 += t27; + t27 += t23; t23 += t19; t19 += t31; + t21 = t02 + t32; t02 = (t02 - t32) * 0.502419286188f; + t32 = t04 + t30; t04 = (t04 - t30) * 0.52249861494f; + t30 = t06 + t28; t28 = (t06 - t28) * 0.566944034816f; + t06 = t08 + t26; t08 = (t08 - t26) * 0.64682178336f; + t26 = t10 + t24; t10 = (t10 - t24) * 0.788154623451f; + t24 = t12 + t22; t22 = (t12 - t22) * 1.06067768599f; + t12 = t14 + t20; t20 = (t14 - t20) * 1.72244709824f; + t14 = t16 + t18; t16 = (t16 - t18) * 5.10114861869f; + t18 = t21 + t14; t14 = (t21 - t14) * 0.509795579104f; + t21 = t32 + t12; t32 = (t32 - t12) * 0.601344886935f; + t12 = t30 + t24; t24 = (t30 - t24) * 0.899976223136f; + t30 = t06 + t26; t26 = (t06 - t26) * 2.56291544774f; + t06 = t18 + t30; t18 = (t18 - t30) * 0.541196100146f; + t30 = t21 + t12; t12 = (t21 - t12) * 1.30656296488f; + t21 = t06 + t30; t30 = (t06 - t30) * 0.707106781187f; + t06 = t18 + t12; t12 = (t18 - t12) * 0.707106781187f; + t06 += t12; + t18 = t14 + t26; t26 = (t14 - t26) * 0.541196100146f; + t14 = t32 + t24; t24 = (t32 - t24) * 1.30656296488f; + t32 = t18 + t14; t14 = (t18 - t14) * 0.707106781187f; + t18 = t26 + t24; t24 = (t26 - t24) * 0.707106781187f; + t18 += t24; t32 += t18; + t18 += t14; t26 = t14 + t24; + t14 = t02 + t16; t02 = (t02 - t16) * 0.509795579104f; + t16 = t04 + t20; t04 = (t04 - t20) * 0.601344886935f; + t20 = t28 + t22; t22 = (t28 - t22) * 0.899976223136f; + t28 = t08 + t10; t10 = (t08 - t10) * 2.56291544774f; + t08 = t14 + t28; t14 = (t14 - t28) * 0.541196100146f; + t28 = t16 + t20; t20 = (t16 - t20) * 1.30656296488f; + t16 = t08 + t28; t28 = (t08 - t28) * 0.707106781187f; + t08 = t14 + t20; t20 = (t14 - t20) * 0.707106781187f; + t08 += t20; + t14 = t02 + t10; t02 = (t02 - t10) * 0.541196100146f; + t10 = t04 + t22; t22 = (t04 - t22) * 1.30656296488f; + t04 = t14 + t10; t10 = (t14 - t10) * 0.707106781187f; + t14 = t02 + t22; t02 = (t02 - t22) * 0.707106781187f; + t14 += t02; t04 += t14; t14 += t10; t10 += t02; + t16 += t04; t04 += t08; t08 += t14; t14 += t28; + t28 += t10; t10 += t20; t20 += t02; t21 += t16; + t16 += t32; t32 += t04; t04 += t06; t06 += t08; + t08 += t18; t18 += t14; t14 += t30; t30 += t28; + t28 += t26; t26 += t10; t10 += t12; t12 += t20; + t20 += t24; t24 += t02; + + d[dp + 48] = -t33; + d[dp + 49] = d[dp + 47] = -t21; + d[dp + 50] = d[dp + 46] = -t17; + d[dp + 51] = d[dp + 45] = -t16; + d[dp + 52] = d[dp + 44] = -t01; + d[dp + 53] = d[dp + 43] = -t32; + d[dp + 54] = d[dp + 42] = -t29; + d[dp + 55] = d[dp + 41] = -t04; + d[dp + 56] = d[dp + 40] = -t03; + d[dp + 57] = d[dp + 39] = -t06; + d[dp + 58] = d[dp + 38] = -t25; + d[dp + 59] = d[dp + 37] = -t08; + d[dp + 60] = d[dp + 36] = -t11; + d[dp + 61] = d[dp + 35] = -t18; + d[dp + 62] = d[dp + 34] = -t09; + d[dp + 63] = d[dp + 33] = -t14; + d[dp + 32] = -t05; + d[dp + 0] = t05; d[dp + 31] = -t30; + d[dp + 1] = t30; d[dp + 30] = -t27; + d[dp + 2] = t27; d[dp + 29] = -t28; + d[dp + 3] = t28; d[dp + 28] = -t07; + d[dp + 4] = t07; d[dp + 27] = -t26; + d[dp + 5] = t26; d[dp + 26] = -t23; + d[dp + 6] = t23; d[dp + 25] = -t10; + d[dp + 7] = t10; d[dp + 24] = -t15; + d[dp + 8] = t15; d[dp + 23] = -t12; + d[dp + 9] = t12; d[dp + 22] = -t19; + d[dp + 10] = t19; d[dp + 21] = -t20; + d[dp + 11] = t20; d[dp + 20] = -t13; + d[dp + 12] = t13; d[dp + 19] = -t24; + d[dp + 13] = t24; d[dp + 18] = -t31; + d[dp + 14] = t31; d[dp + 17] = -t02; + d[dp + 15] = t02; d[dp + 16] = 0.0; +} + + +#endif // PL_MPEG_IMPLEMENTATION diff --git a/source/engine/thirdparty/pl_mpeg/pl_mpeg_extract_frames.c b/source/engine/thirdparty/pl_mpeg/pl_mpeg_extract_frames.c new file mode 100644 index 0000000..44aa768 --- /dev/null +++ b/source/engine/thirdparty/pl_mpeg/pl_mpeg_extract_frames.c @@ -0,0 +1,79 @@ +/* +PL_MPEG Example - extract all frames of an mpg file and store as PNG + +Dominic Szablewski - https://phoboslab.org + + +-- LICENSE: The MIT License(MIT) + +Copyright(c) 2019 Dominic Szablewski + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files(the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and / or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions : +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + + +-- Usage + +pl_mpeg_extract_frames + + +-- About + +This program demonstrates how to extract all video frames from an MPEG-PS file. +Frames are saved as PNG via stb_image_write: https://github.com/nothings/stb + +*/ + +#include + +#define PL_MPEG_IMPLEMENTATION +#include "pl_mpeg.h" + +#define STB_IMAGE_WRITE_IMPLEMENTATION +#include "stb_image_write.h" + +int main(int argc, char *argv[]) { + if (argc < 2) { + printf("Usage: pl_mpeg_extract_frames \n"); + return 1; + } + + plm_t *plm = plm_create_with_filename(argv[1]); + if (!plm) { + printf("Couldn't open file %s\n", argv[1]); + return 1; + } + + plm_set_audio_enabled(plm, FALSE); + + int w = plm_get_width(plm); + int h = plm_get_height(plm); + uint8_t *rgb_buffer = (uint8_t *)malloc(w * h * 3); + + char png_name[16]; + plm_frame_t *frame = NULL; + + for (int i = 1; frame = plm_decode_video(plm); i++) { + plm_frame_to_rgb(frame, rgb_buffer, w * 3); + + sprintf(png_name, "%06d.png", i); + printf("Writing %s\n", png_name); + stbi_write_png(png_name, w, h, 3, rgb_buffer, w * 3); + } + + return 0; +} + diff --git a/source/engine/thirdparty/pl_mpeg/pl_mpeg_player.c b/source/engine/thirdparty/pl_mpeg/pl_mpeg_player.c new file mode 100644 index 0000000..0cf5944 --- /dev/null +++ b/source/engine/thirdparty/pl_mpeg/pl_mpeg_player.c @@ -0,0 +1,439 @@ +/* +PL_MPEG Example - Video player using SDL2/OpenGL for rendering + +Dominic Szablewski - https://phoboslab.org + + +-- LICENSE: The MIT License(MIT) + +Copyright(c) 2019 Dominic Szablewski + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files(the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and / or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions : +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + + +-- Usage + +plmpeg-player + +Use the arrow keys to seek forward/backward by 3 seconds. Click anywhere on the +window to seek to seek through the whole file. + + +-- About + +This program demonstrates a simple video/audio player using plmpeg for decoding +and SDL2 with OpenGL for rendering and sound output. It was tested on Windows +using Microsoft Visual Studio 2015 and on macOS using XCode 10.2 + +This program can be configured to either convert the raw YCrCb data to RGB on +the GPU (default), or to do it on CPU. Just pass APP_TEXTURE_MODE_RGB to +app_create() to switch to do the conversion on the CPU. + +YCrCb->RGB conversion on the CPU is a very costly operation and should be +avoided if possible. It easily takes as much time as all other mpeg1 decoding +steps combined. + +*/ + +#include +#include + +#if defined(__APPLE__) && defined(__MACH__) + // OSX + #include + #include + #include + #include + + void glCreateTextures(GLuint ignored, GLsizei n, GLuint *name) { + glGenTextures(1, name); + } +#elif defined(__unix__) + // Linux + #include + #include +#else + // WINDOWS + #include + + #define GL3_PROTOTYPES 1 + #include + #pragma comment(lib, "glew32.lib") + + #include + #pragma comment(lib, "opengl32.lib") + + #include + #include + #pragma comment(lib, "SDL2.lib") + #pragma comment(lib, "SDL2main.lib") +#endif + +#define PL_MPEG_IMPLEMENTATION +#include "pl_mpeg.h" + + +#define APP_SHADER_SOURCE(...) #__VA_ARGS__ + +const char * const APP_VERTEX_SHADER = APP_SHADER_SOURCE( + attribute vec2 vertex; + varying vec2 tex_coord; + + void main() { + tex_coord = vertex; + gl_Position = vec4((vertex * 2.0 - 1.0) * vec2(1, -1), 0.0, 1.0); + } +); + +const char * const APP_FRAGMENT_SHADER_YCRCB = APP_SHADER_SOURCE( + uniform sampler2D texture_y; + uniform sampler2D texture_cb; + uniform sampler2D texture_cr; + varying vec2 tex_coord; + + mat4 rec601 = mat4( + 1.16438, 0.00000, 1.59603, -0.87079, + 1.16438, -0.39176, -0.81297, 0.52959, + 1.16438, 2.01723, 0.00000, -1.08139, + 0, 0, 0, 1 + ); + + void main() { + float y = texture2D(texture_y, tex_coord).r; + float cb = texture2D(texture_cb, tex_coord).r; + float cr = texture2D(texture_cr, tex_coord).r; + + gl_FragColor = vec4(y, cb, cr, 1.0) * rec601; + } +); + +const char * const APP_FRAGMENT_SHADER_RGB = APP_SHADER_SOURCE( + uniform sampler2D texture_rgb; + varying vec2 tex_coord; + + void main() { + gl_FragColor = vec4(texture2D(texture_rgb, tex_coord).rgb, 1.0); + } +); + +#undef APP_SHADER_SOURCE + +#define APP_TEXTURE_MODE_YCRCB 1 +#define APP_TEXTURE_MODE_RGB 2 + +typedef struct { + plm_t *plm; + double last_time; + int wants_to_quit; + + SDL_Window *window; + SDL_AudioDeviceID audio_device; + + SDL_GLContext gl; + + GLuint shader_program; + GLuint vertex_shader; + GLuint fragment_shader; + + int texture_mode; + GLuint texture_y; + GLuint texture_cb; + GLuint texture_cr; + + GLuint texture_rgb; + uint8_t *rgb_data; +} app_t; + +app_t * app_create(const char *filename, int texture_mode); +void app_update(app_t *self); +void app_destroy(app_t *self); + +GLuint app_compile_shader(app_t *self, GLenum type, const char *source); +GLuint app_create_texture(app_t *self, GLuint index, const char *name); +void app_update_texture(app_t *self, GLuint unit, GLuint texture, plm_plane_t *plane); + +void app_on_video(plm_t *player, plm_frame_t *frame, void *user); +void app_on_audio(plm_t *player, plm_samples_t *samples, void *user); + + + +app_t * app_create(const char *filename, int texture_mode) { + app_t *self = (app_t *)malloc(sizeof(app_t)); + memset(self, 0, sizeof(app_t)); + + self->texture_mode = texture_mode; + + // Initialize plmpeg, load the video file, install decode callbacks + self->plm = plm_create_with_filename(filename); + if (!self->plm) { + SDL_Log("Couldn't open %s", filename); + exit(1); + } + + int samplerate = plm_get_samplerate(self->plm); + + SDL_Log( + "Opened %s - framerate: %f, samplerate: %d, duration: %f", + filename, + plm_get_framerate(self->plm), + plm_get_samplerate(self->plm), + plm_get_duration(self->plm) + ); + + plm_set_video_decode_callback(self->plm, app_on_video, self); + plm_set_audio_decode_callback(self->plm, app_on_audio, self); + + plm_set_loop(self->plm, TRUE); + plm_set_audio_enabled(self->plm, TRUE); + plm_set_audio_stream(self->plm, 0); + + if (plm_get_num_audio_streams(self->plm) > 0) { + // Initialize SDL Audio + SDL_Init(SDL_INIT_VIDEO | SDL_INIT_AUDIO); + SDL_AudioSpec audio_spec; + SDL_memset(&audio_spec, 0, sizeof(audio_spec)); + audio_spec.freq = samplerate; + audio_spec.format = AUDIO_F32; + audio_spec.channels = 2; + audio_spec.samples = 4096; + + self->audio_device = SDL_OpenAudioDevice(NULL, 0, &audio_spec, NULL, 0); + if (self->audio_device == 0) { + SDL_Log("Failed to open audio device: %s", SDL_GetError()); + } + SDL_PauseAudioDevice(self->audio_device, 0); + + // Adjust the audio lead time according to the audio_spec buffer size + plm_set_audio_lead_time(self->plm, (double)audio_spec.samples / (double)samplerate); + } + + // Create SDL Window + self->window = SDL_CreateWindow( + "pl_mpeg", + SDL_WINDOWPOS_CENTERED, SDL_WINDOWPOS_CENTERED, + plm_get_width(self->plm), plm_get_height(self->plm), + SDL_WINDOW_SHOWN | SDL_WINDOW_OPENGL | SDL_WINDOW_RESIZABLE + ); + self->gl = SDL_GL_CreateContext(self->window); + + SDL_GL_SetSwapInterval(1); + + #if defined(__APPLE__) && defined(__MACH__) + // OSX + // (nothing to do here) + #else + // Windows, Linux + glewExperimental = GL_TRUE; + glewInit(); + #endif + + + // Setup OpenGL shaders and textures + const char * fsh = self->texture_mode == APP_TEXTURE_MODE_YCRCB + ? APP_FRAGMENT_SHADER_YCRCB + : APP_FRAGMENT_SHADER_RGB; + + self->fragment_shader = app_compile_shader(self, GL_FRAGMENT_SHADER, fsh); + self->vertex_shader = app_compile_shader(self, GL_VERTEX_SHADER, APP_VERTEX_SHADER); + + self->shader_program = glCreateProgram(); + glAttachShader(self->shader_program, self->vertex_shader); + glAttachShader(self->shader_program, self->fragment_shader); + glLinkProgram(self->shader_program); + glUseProgram(self->shader_program); + + // Create textures for YCrCb or RGB rendering + if (self->texture_mode == APP_TEXTURE_MODE_YCRCB) { + self->texture_y = app_create_texture(self, 0, "texture_y"); + self->texture_cb = app_create_texture(self, 1, "texture_cb"); + self->texture_cr = app_create_texture(self, 2, "texture_cr"); + } + else { + self->texture_rgb = app_create_texture(self, 0, "texture_rgb"); + int num_pixels = plm_get_width(self->plm) * plm_get_height(self->plm); + self->rgb_data = (uint8_t*)malloc(num_pixels * 3); + } + + return self; +} + +void app_destroy(app_t *self) { + plm_destroy(self->plm); + + if (self->texture_mode == APP_TEXTURE_MODE_RGB) { + free(self->rgb_data); + } + + if (self->audio_device) { + SDL_CloseAudioDevice(self->audio_device); + } + + SDL_GL_DeleteContext(self->gl); + SDL_Quit(); + + free(self); +} + +void app_update(app_t *self) { + double seek_to = -1; + + SDL_Event ev; + while (SDL_PollEvent(&ev)) { + if ( + ev.type == SDL_QUIT || + (ev.type == SDL_KEYUP && ev.key.keysym.sym == SDLK_ESCAPE) + ) { + self->wants_to_quit = TRUE; + } + + if ( + ev.type == SDL_WINDOWEVENT && + ev.window.event == SDL_WINDOWEVENT_SIZE_CHANGED + ) { + glViewport(0, 0, ev.window.data1, ev.window.data2); + } + + // Seek 3sec forward/backward using arrow keys + if (ev.type == SDL_KEYDOWN && ev.key.keysym.sym == SDLK_RIGHT) { + seek_to = plm_get_time(self->plm) + 3; + } + else if (ev.type == SDL_KEYDOWN && ev.key.keysym.sym == SDLK_LEFT) { + seek_to = plm_get_time(self->plm) - 3; + } + } + + // Compute the delta time since the last app_update(), limit max step to + // 1/30th of a second + double current_time = (double)SDL_GetTicks() / 1000.0; + double elapsed_time = current_time - self->last_time; + if (elapsed_time > 1.0 / 30.0) { + elapsed_time = 1.0 / 30.0; + } + self->last_time = current_time; + + // Seek using mouse position + int mouse_x, mouse_y; + if (SDL_GetMouseState(&mouse_x, &mouse_y) & SDL_BUTTON(SDL_BUTTON_LEFT)) { + int sx, sy; + SDL_GetWindowSize(self->window, &sx, &sy); + seek_to = plm_get_duration(self->plm) * ((float)mouse_x / (float)sx); + } + + // Seek or advance decode + if (seek_to != -1) { + SDL_ClearQueuedAudio(self->audio_device); + plm_seek(self->plm, seek_to, FALSE); + } + else { + plm_decode(self->plm, elapsed_time); + } + + if (plm_has_ended(self->plm)) { + self->wants_to_quit = TRUE; + } + + glClear(GL_COLOR_BUFFER_BIT); + glRectf(0.0, 0.0, 1.0, 1.0); + SDL_GL_SwapWindow(self->window); +} + +GLuint app_compile_shader(app_t *self, GLenum type, const char *source) { + GLuint shader = glCreateShader(type); + glShaderSource(shader, 1, &source, NULL); + glCompileShader(shader); + + GLint success; + glGetShaderiv(shader, GL_COMPILE_STATUS, &success); + if (!success) { + int log_written; + char log[256]; + glGetShaderInfoLog(shader, 256, &log_written, log); + SDL_Log("Error compiling shader: %s.\n", log); + } + return shader; +} + +GLuint app_create_texture(app_t *self, GLuint index, const char *name) { + GLuint texture; + glCreateTextures(GL_TEXTURE_2D, 1, &texture); + + glBindTexture(GL_TEXTURE_2D, texture); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); + glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); + + glUniform1i(glGetUniformLocation(self->shader_program, name), index); + return texture; +} + +void app_update_texture(app_t *self, GLuint unit, GLuint texture, plm_plane_t *plane) { + glActiveTexture(unit); + glBindTexture(GL_TEXTURE_2D, texture); + glTexImage2D( + GL_TEXTURE_2D, 0, GL_LUMINANCE, plane->width, plane->height, 0, + GL_LUMINANCE, GL_UNSIGNED_BYTE, plane->data + ); +} + +void app_on_video(plm_t *mpeg, plm_frame_t *frame, void *user) { + app_t *self = (app_t *)user; + + // Hand the decoded data over to OpenGL. For the RGB texture mode, the + // YCrCb->RGB conversion is done on the CPU. + + if (self->texture_mode == APP_TEXTURE_MODE_YCRCB) { + app_update_texture(self, GL_TEXTURE0, self->texture_y, &frame->y); + app_update_texture(self, GL_TEXTURE1, self->texture_cb, &frame->cb); + app_update_texture(self, GL_TEXTURE2, self->texture_cr, &frame->cr); + } + else { + plm_frame_to_rgb(frame, self->rgb_data, frame->width * 3); + + glBindTexture(GL_TEXTURE_2D, self->texture_rgb); + glTexImage2D( + GL_TEXTURE_2D, 0, GL_RGB, frame->width, frame->height, 0, + GL_RGB, GL_UNSIGNED_BYTE, self->rgb_data + ); + } +} + +void app_on_audio(plm_t *mpeg, plm_samples_t *samples, void *user) { + app_t *self = (app_t *)user; + + // Hand the decoded samples over to SDL + + int size = sizeof(float) * samples->count * 2; + SDL_QueueAudio(self->audio_device, samples->interleaved, size); +} + + + +int main(int argc, char *argv[]) { + if (argc < 2) { + SDL_Log("Usage: pl_mpeg_player "); + exit(1); + } + + app_t *app = app_create(argv[1], APP_TEXTURE_MODE_YCRCB); + while (!app->wants_to_quit) { + app_update(app); + } + app_destroy(app); + + return EXIT_SUCCESS; +} diff --git a/source/engine/thirdparty/s7/mus-config.h b/source/engine/thirdparty/s7/mus-config.h new file mode 100644 index 0000000..c8f37da --- /dev/null +++ b/source/engine/thirdparty/s7/mus-config.h @@ -0,0 +1 @@ +#define HAVE_COMPLEX_NUMBERS 0 \ No newline at end of file diff --git a/source/engine/thirdparty/s7/s7.c b/source/engine/thirdparty/s7/s7.c new file mode 100644 index 0000000..23bee6a --- /dev/null +++ b/source/engine/thirdparty/s7/s7.c @@ -0,0 +1,114091 @@ +/* s7, a Scheme interpreter + * + * derived from TinyScheme 1.39, but not a single byte of that code remains + * SPDX-License-Identifier: 0BSD + * + * Bill Schottstaedt, bil@ccrma.stanford.edu + * + * Mike Scholz provided the FreeBSD support (complex trig funcs, etc) + * Rick Taube, Andrew Burnson, Donny Ward, and Greg Santucci provided the MS Visual C++ support + * Kjetil Matheussen provided the mingw support + * chai xiaoxiang provided the msys2 support + * + * Documentation is in s7.h and s7.html. + * s7test.scm is a regression test. + * repl.scm is a vt100-based listener. + * nrepl.scm is a notcurses-based listener. + * cload.scm and lib*.scm tie in various C libraries. + * lint.scm checks Scheme code for infelicities. + * r7rs.scm implements some of r7rs (small). + * write.scm currrently has pretty-print. + * mockery.scm has the mock-data definitions. + * reactive.scm has reactive-set and friends. + * stuff.scm has some stuff. + * profile.scm has code to display profile data. + * debug.scm has debugging aids. + * case.scm has case*, an extension of case to pattern matching. + * timing tests are in the s7 tools directory + * + * s7.c is organized as follows: + * structs and type flags + * internal debugging stuff + * constants + * GC + * stacks + * symbols and keywords + * lets + * continuations + * numbers + * characters + * strings + * ports + * format + * lists + * vectors + * hash-tables + * c-objects + * functions + * equal? + * generic length, copy, reverse, fill!, append + * error handlers + * sundry leftovers + * the optimizers + * multiple-values, quasiquote + * eval + * *s7* + * initialization and free + * repl + * + * naming conventions: s7_* usually are C accessible (s7.h), g_* are scheme accessible, + * H_* are documentation strings, Q_* are procedure signatures, + * *_1 are ancillary functions, big_* refer to gmp, + * scheme "?" corresponds to C "is_", scheme "->" to C "_to_". + * + * ---------------- compile time switches ---------------- + */ + + +/* + * Your config file goes here, or just replace that #include line with the defines you need. + * The compile-time switches involve booleans, complex numbers, and multiprecision arithmetic. + * Currently we assume we have setjmp.h (used by the error handlers). + * + * Complex number support, which is problematic in C++, Solaris, and netBSD + * is on the HAVE_COMPLEX_NUMBERS switch. In OSX or Linux, if you're not using C++, + * + * #define HAVE_COMPLEX_NUMBERS 1 + * #define HAVE_COMPLEX_TRIG 1 + * + * In C++ I use: + * + * #define HAVE_COMPLEX_NUMBERS 1 + * #define HAVE_COMPLEX_TRIG 0 + * + * In Windows, both are 0. + * + * Some systems (FreeBSD) have complex.h, but some random subset of the trig funcs, so + * HAVE_COMPLEX_NUMBERS means we can find + * cimag creal cabs csqrt carg conj + * and HAVE_COMPLEX_TRIG means we have + * cacos cacosh casin casinh catan catanh ccos ccosh cexp clog cpow csin csinh ctan ctanh + * + * When HAVE_COMPLEX_NUMBERS is 0, the complex functions are stubs that simply return their + * argument -- this will be very confusing for the s7 user because, for example, (sqrt -2) + * will return something bogus (it might not signal an error). + * + * so the incoming (non-s7-specific) compile-time switches are + * HAVE_COMPLEX_NUMBERS, HAVE_COMPLEX_TRIG, SIZEOF_VOID_P + * if SIZEOF_VOID_P is not defined, we look for __SIZEOF_POINTER__ instead, + * the default is to assume that we're running on a 64-bit machine. + * + * To get multiprecision arithmetic, set WITH_GMP to 1. + * You'll also need libgmp, libmpfr, and libmpc (version 0.8.0 or later) + * + * and we use these predefined macros: __cplusplus, _MSC_VER, __GNUC__, __clang__, __ANDROID__ + * + * if WITH_SYSTEM_EXTRAS is 1 (default is 1 unless _MSC_VER), various OS and file related functions are included. + * in openBSD I think you need to include -ftrampolines in CFLAGS. + * if you want this file to compile into a stand-alone interpreter, define WITH_MAIN + * to use nrepl, also define WITH_NOTCURSES + * + * -O3 produces segfaults, and is often slower than -O2 (at least according to callgrind) + * -march=native seems to improve tree-vectorization which is important in Snd + * -ffast-math makes a mess of NaNs, and does not appear to be faster + * for timing tests, I use: -O2 -march=native -fomit-frame-pointer -funroll-loops + * some say -funroll-loops has no effect, but it is consistently faster (according to callgrind) in s7's timing tests + * according to callgrind, clang is normally about 10% slower than gcc, and vectorization either doesn't work or is much worse than gcc's + * also g++ appears to be slightly slower than gcc + */ + +#if (defined(__GNUC__) || defined(__clang__)) /* s7 uses PRId64 so (for example) g++ 4.4 is too old */ +#define WITH_GCC 1 +#else +#define WITH_GCC 0 +#endif + + +/* ---------------- initial sizes ---------------- */ + +#ifndef INITIAL_HEAP_SIZE + /* #define INITIAL_HEAP_SIZE 128000 */ +#define INITIAL_HEAP_SIZE 64000 /* 29-Jul-21 -- seems faster */ +#endif +/* the heap grows as needed, this is its initial size. If the initial heap is small, s7 can run in about 2.5 Mbytes of memory. + * There are many cases where a bigger heap is faster (but harware cache size probably matters more). + * The heap size must be a multiple of 32. Each object takes 48 bytes. + */ + +#ifndef SYMBOL_TABLE_SIZE +#define SYMBOL_TABLE_SIZE 32749 +#endif +/* names are hashed into the symbol table (a vector) and collisions are chained as lists. */ +/* 16381: thash +80 [string->symbol] tauto +45[sublet called 4x as often?] tlet +80 [g_symbol] */ + +#ifndef INITIAL_STACK_SIZE +#define INITIAL_STACK_SIZE 4096 /* was 2048 17-Mar-21 */ +#endif +/* the stack grows as needed, each frame takes 4 entries, this is its initial size. (*s7* 'stack-top) divides size by 4 */ + +#define STACK_RESIZE_TRIGGER (INITIAL_STACK_SIZE / 2) + +#ifndef INITIAL_PROTECTED_OBJECTS_SIZE +#define INITIAL_PROTECTED_OBJECTS_SIZE 16 +#endif +/* a vector of objects that are (semi-permanently) protected from the GC, grows as needed */ + +#ifndef GC_TEMPS_SIZE +#define GC_TEMPS_SIZE 256 +#endif +/* the number of recent objects that are temporarily gc-protected; 8 works for s7test and snd-test. + * For the FFI, this sets the lag between a call on s7_cons and the first moment when its result + * might be vulnerable to the GC. + */ + + +/* ---------------- scheme choices ---------------- */ + +#ifndef WITH_GMP +#define WITH_GMP 0 + /* this includes multiprecision arithmetic for all numeric types and functions, using gmp, mpfr, and mpc + * WITH_GMP adds the following functions: bignum and bignum?, and (*s7* 'bignum-precision) + */ +#endif + +#ifndef DEFAULT_BIGNUM_PRECISION +#define DEFAULT_BIGNUM_PRECISION 128 /* (*s7* 'bignum-precision) initial value, must be >= 2 */ +#endif + +#ifndef WITH_PURE_S7 +#define WITH_PURE_S7 0 +#endif +#if WITH_PURE_S7 +#define WITH_EXTRA_EXPONENT_MARKERS 0 +#define WITH_IMMUTABLE_UNQUOTE 1 + /* also omitted: *-ci* functions, char-ready?, cond-expand, multiple-values-bind|set!, call-with-values + * and a lot more (inexact/exact, integer-length, etc) -- see s7.html. + */ +#endif + +#ifndef WITH_EXTRA_EXPONENT_MARKERS +#define WITH_EXTRA_EXPONENT_MARKERS 0 +#endif +/* if 1, s7 recognizes "d", "f", "l", and "s" as exponent markers, in addition to "e" (also "D", "F", "L", "S") */ + +#ifndef WITH_SYSTEM_EXTRAS +#define WITH_SYSTEM_EXTRAS (!_MSC_VER) + /* this adds several functions that access file info, directories, times, etc */ +#endif + +#ifndef WITH_IMMUTABLE_UNQUOTE +#define WITH_IMMUTABLE_UNQUOTE 0 + /* this removes the name "unquote" */ +#endif + +#ifndef WITH_C_LOADER +#if WITH_GCC && (!__MINGW32__) && (!__CYGWIN__) +#define WITH_C_LOADER 1 + /* (load file.so [e]) looks for (e 'init_func) and if found, calls it as the shared object init function. + * If WITH_SYSTEM_EXTRAS is 0, the caller needs to supply system and delete-file so that cload.scm works. + */ +#else +#define WITH_C_LOADER 0 + /* I think dlopen et al are available in MS C, but I have no way to test them; see load_shared_object below */ +#endif +#endif + +#ifndef WITH_HISTORY +#define WITH_HISTORY 0 + /* this includes a circular buffer of previous evaluations for debugging, ((owlet) 'error-history) and (*s7* 'history-size) */ +#endif + +#ifndef DEFAULT_HISTORY_SIZE +#define DEFAULT_HISTORY_SIZE 8 + /* this is the default length of the eval history buffer */ +#endif +#if WITH_HISTORY +#define MAX_HISTORY_SIZE 1048576 +#endif + +#ifndef DEFAULT_PRINT_LENGTH +#define DEFAULT_PRINT_LENGTH 12 /* (*s7* 'print-length) initial value, was 32 but Snd uses 12, 23-Jul-21 */ +#endif + +/* in case mus-config.h forgets these */ +#ifdef _MSC_VER +#ifndef HAVE_COMPLEX_NUMBERS +#define HAVE_COMPLEX_NUMBERS 0 +#endif +#ifndef HAVE_COMPLEX_TRIG +#define HAVE_COMPLEX_TRIG 0 +#endif +#else +#ifndef HAVE_COMPLEX_NUMBERS +#define HAVE_COMPLEX_NUMBERS 1 +#endif +#if __cplusplus +#ifndef HAVE_COMPLEX_TRIG +#define HAVE_COMPLEX_TRIG 0 +#endif +#else +#ifndef HAVE_COMPLEX_TRIG +#define HAVE_COMPLEX_TRIG 1 +#endif +#endif +#endif + +#ifndef WITH_MULTITHREAD_CHECKS +#define WITH_MULTITHREAD_CHECKS 0 + /* debugging aid if using s7 in a multithreaded program -- this code courtesy of Kjetil Matheussen */ +#endif + +#ifndef WITH_WARNINGS +#define WITH_WARNINGS 0 + /* int+int overflows to real, etc: this adds warnings which are expensive even though they are never called (procedure overhead) */ +#endif + +#ifndef S7_DEBUGGING +#define S7_DEBUGGING 0 +#endif + +#undef DEBUGGING +#define DEBUGGING typo! +#define HAVE_GMP typo! + +#define SHOW_EVAL_OPS 0 + +#ifndef _GNU_SOURCE +#define _GNU_SOURCE +/* for qsort_r, grumble... */ +#endif + +#ifndef _MSC_VER +#include +#include +#include +#include +#include +#else + /* in Snd these are in mus-config.h */ +#ifndef MUS_CONFIG_H_LOADED +#if _MSC_VER < 1900 +#define snprintf _snprintf +#endif +#if _MSC_VER > 1200 +#define _CRT_SECURE_NO_DEPRECATE 1 +#define _CRT_NONSTDC_NO_DEPRECATE 1 +#define _CRT_SECURE_CPP_OVERLOAD_STANDARD_NAMES 1 +#endif +#endif +#include +#pragma warning(disable: 4244) /* conversion might cause loss of data warning */ +#endif + +#if WITH_GCC && (!S7_DEBUGGING) +#define Inline inline __attribute__((__always_inline__)) +#else +#ifdef _MSC_VER +#define Inline __forceinline +#else +#define Inline inline +#endif +#endif + +#ifndef WITH_VECTORIZE +#define WITH_VECTORIZE 1 +#endif + +#if (WITH_VECTORIZE) && (defined(__GNUC__) && __GNUC__ >= 5) +#define Vectorized __attribute__((optimize("tree-vectorize"))) +#else +#define Vectorized +#endif + +#if WITH_GCC +#define Sentinel __attribute__((sentinel)) +#else +#define Sentinel +#endif + +#ifndef S7_ALIGNED +#define S7_ALIGNED 0 +#endif + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#ifdef _MSC_VER +#define MS_WINDOWS 1 +#else +#define MS_WINDOWS 0 +#endif + +#ifdef __MINGW32__ +#define Jmp_Buf jmp_buf +#define SetJmp(A, B) setjmp(A) +#define LongJmp(A, B) longjmp(A, B) +#else +#define Jmp_Buf jmp_buf +#define SetJmp(A, B) setjmp(A) /* Was sigX for all; sigsetjmp(A, B). Changed to compile with musl-libc */ +#define LongJmp(A, B) longjmp(A, B) + /* we need sigsetjmp, not setjmp for nrepl's interrupt (something to do with signal masks??) + * unfortunately sigsetjmp is noticeably slower than setjmp, especially when s7_optimize_1 is called a lot. + * In one case, the sigsetjmp version runs in 24 seconds, but the setjmp version takes 10 seconds, and + * yet callgrind says there is almost no difference, so I removed setjmp from s7_optimize. + */ +#endif + +#if (!MS_WINDOWS) +#include +#endif + +#if __cplusplus +#include +#else +#include +#endif + +/* there is also apparently __STDC_NO_COMPLEX__ */ +#if HAVE_COMPLEX_NUMBERS +#if __cplusplus +#include +#else +#include +#ifndef __SUNPRO_C +#if defined(__sun) && defined(__SVR4) +#undef _Complex_I +#define _Complex_I 1.0fi +#endif +#endif +#endif + +#ifndef CMPLX +#if (!(defined(__cplusplus))) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7)) && !defined(__INTEL_COMPILER) +#define CMPLX(x, y) __builtin_complex ((double) (x), (double) (y)) +#else +#define CMPLX(r, i) ((r) + ((i) * _Complex_I)) +#endif +#endif +#endif + +#include "s7.h" + +#ifndef M_PI +#define M_PI 3.1415926535897932384626433832795029L +#endif + +#ifndef INFINITY +#ifndef HUGE_VAL +#define INFINITY (1.0/0.0) /* -log(0.0) is triggering dumb complaints from cppcheck */ + /* there is sometimes a function, infinity(), MSC apparently uses HUGE_VALF, gcc has __builtin_huge_val() */ +#else +#define INFINITY HUGE_VAL +#endif +#endif + +#ifndef NAN +#define NAN (INFINITY / INFINITY) +#endif + +#define BOLD_TEXT "\033[1m" +#define UNBOLD_TEXT "\033[22m" + +#if ((!__NetBSD__) && ((_MSC_VER) || (!defined(__STC__)) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ < 199901L)))) +#define __func__ __FUNCTION__ +#endif + +#define display(Obj) string_value(s7_object_to_string(sc, Obj, false)) +#define display_80(Obj) string_value(object_to_truncated_string(sc, Obj, 80)) + +typedef intptr_t opcode_t; + +#if (((defined(SIZEOF_VOID_P)) && (SIZEOF_VOID_P == 4)) || ((defined(__SIZEOF_POINTER__)) && (__SIZEOF_POINTER__ == 4)) || (!defined(__LP64__))) +#define NUMBER_NAME_SIZE 2 /* pointless */ +#define POINTER_32 true +#else +#define NUMBER_NAME_SIZE 22 /* leave 1 for uint8_t name len (byte 0), 1 for terminating nul */ +#define POINTER_32 false +#endif + +#define WRITE_REAL_PRECISION 16 +typedef long double long_double; + +#define ld64 PRId64 +#define p64 PRIdPTR + +#define MAX_FLOAT_FORMAT_PRECISION 128 + +/* types */ +enum { T_FREE = 0, + T_PAIR, T_NIL, T_UNUSED, T_UNDEFINED, T_UNSPECIFIED, T_EOF, T_BOOLEAN, + T_CHARACTER, T_SYNTAX, T_SYMBOL, + T_INTEGER, T_RATIO, T_REAL, T_COMPLEX, T_BIG_INTEGER, T_BIG_RATIO, + T_BIG_REAL, T_BIG_COMPLEX, + T_STRING, T_C_OBJECT, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, + T_BYTE_VECTOR, + T_CATCH, T_DYNAMIC_WIND, T_HASH_TABLE, T_LET, T_ITERATOR, + T_STACK, T_COUNTER, T_SLOT, T_C_POINTER, T_OUTPUT_PORT, T_INPUT_PORT, + T_RANDOM_STATE, T_CONTINUATION, T_GOTO, + T_CLOSURE, T_CLOSURE_STAR, T_MACRO, T_MACRO_STAR, T_BACRO, + T_BACRO_STAR, T_C_MACRO, + T_C_FUNCTION_STAR, T_C_FUNCTION, T_C_ANY_ARGS_FUNCTION, + T_C_OPT_ARGS_FUNCTION, T_C_RST_ARGS_FUNCTION, + NUM_TYPES +}; +/* T_UNUSED, T_STACK, T_SLOT, T_DYNAMIC_WIND, T_CATCH, and T_COUNTER are internal */ + +#if S7_DEBUGGING || SHOW_EVAL_OPS +static const char *s7_type_names[] = + { "free", "pair", "nil", "unused", "undefined", "unspecified", + "eof_object", "boolean", "character", "syntax", "symbol", + "integer", "ratio", "real", "complex", "big_integer", "big_ratio", + "big_real", "big_complex", + "string", "c_object", "vector", "int_vector", "float_vector", + "byte_vector", + "catch", "dynamic_wind", "hash_table", "let", "iterator", + "stack", "counter", "slot", "c_pointer", "output_port", "input_port", + "random_state", "continuation", "goto", + "closure", "closure*", "macro", "macro*", "bacro", "bacro*", "c_macro", + "c_function*", "c_function", "c_any_args_function", + "c_opt_args_function", "c_rst_args_function" +}; +#endif + +typedef struct block_t { + union { + void *data; + s7_pointer d_ptr; + s7_int *i_ptr; + s7_int pos; + } dx; + int32_t index; + union { + bool needs_free; + uint32_t tag; + } ln; + s7_int size; + union { + struct block_t *next; + char *documentation; + s7_pointer ksym; + s7_int nx_int; + s7_int *ix_ptr; + struct { + uint32_t i1, i2; + } ix; + } nx; + union { + s7_pointer ex_ptr; + void *ex_info; + s7_int ckey; + } ex; +} block_t; + +#define NUM_BLOCK_LISTS 18 +#define TOP_BLOCK_LIST 17 +#define BLOCK_LIST 0 + +#define block_data(p) p->dx.data +#define block_index(p) p->index +#define block_set_index(p, Index) p->index = Index +#define block_size(p) p->size +#define block_set_size(p, Size) p->size = Size +#define block_next(p) p->nx.next +#define block_info(p) p->ex.ex_info + +typedef block_t hash_entry_t; +#define hash_entry_key(p) p->dx.d_ptr +#define hash_entry_value(p) (p)->ex.ex_ptr +#define hash_entry_set_value(p, Val) p->ex.ex_ptr = Val +#define hash_entry_next(p) block_next(p) +#define hash_entry_raw_hash(p) block_size(p) +#define hash_entry_set_raw_hash(p, Hash) block_set_size(p, Hash) + +typedef block_t vdims_t; +#define vdims_rank(p) p->size +#define vector_elements_should_be_freed(p) p->ln.needs_free +#define vdims_dims(p) p->dx.i_ptr +#define vdims_offsets(p) p->nx.ix_ptr +#define vdims_original(p) p->ex.ex_ptr + + +typedef enum { TOKEN_EOF, TOKEN_LEFT_PAREN, TOKEN_RIGHT_PAREN, TOKEN_DOT, + TOKEN_ATOM, TOKEN_QUOTE, TOKEN_DOUBLE_QUOTE, TOKEN_BACK_QUOTE, + TOKEN_COMMA, TOKEN_AT_MARK, TOKEN_SHARP_CONST, TOKEN_VECTOR, + TOKEN_BYTE_VECTOR, TOKEN_INT_VECTOR, TOKEN_FLOAT_VECTOR +} token_t; + +typedef enum { NO_ARTICLE, INDEFINITE_ARTICLE } article_t; +typedef enum { DWIND_INIT, DWIND_BODY, DWIND_FINISH } dwind_t; +enum { NO_SAFETY = 0, IMMUTABLE_VECTOR_SAFETY, MORE_SAFETY_WARNINGS }; /* (*s7* 'safety) settings */ + +/* IO ports */ +typedef enum { FILE_PORT, STRING_PORT, FUNCTION_PORT } port_type_t; + +typedef struct { + int32_t(*read_character) (s7_scheme * sc, s7_pointer port); /* function to read a character, int32_t for EOF */ + void (*write_character)(s7_scheme * sc, uint8_t c, s7_pointer port); /* function to write a character */ + void (*write_string)(s7_scheme * sc, const char *str, s7_int len, s7_pointer port); /* function to write a string of known length */ + token_t(*read_semicolon) (s7_scheme * sc, s7_pointer port); /* internal skip-to-semicolon reader */ + int32_t(*read_white_space) (s7_scheme * sc, s7_pointer port); /* internal skip white space reader */ + s7_pointer(*read_name) (s7_scheme * sc, s7_pointer pt); /* internal get-next-name reader */ + s7_pointer(*read_sharp) (s7_scheme * sc, s7_pointer pt); /* internal get-next-sharp-constant reader */ + s7_pointer(*read_line) (s7_scheme * sc, s7_pointer pt, bool eol_case); /* function to read a string up to \n */ + void (*displayer)(s7_scheme * sc, const char *s, s7_pointer pt); + void (*close_port)(s7_scheme * sc, s7_pointer p); /* close-in|output-port */ +} port_functions_t; + +typedef struct { + bool needs_free, is_closed; + port_type_t ptype; + FILE *file; + char *filename; + block_t *filename_block; + uint32_t line_number, file_number; + s7_int filename_length; + block_t *block; + s7_pointer orig_str; /* GC protection for string port string */ + const port_functions_t *pf; + s7_pointer(*input_function) (s7_scheme * sc, s7_read_t read_choice, + s7_pointer port); + void (*output_function)(s7_scheme * sc, uint8_t c, s7_pointer port); +} port_t; + +typedef enum { o_d_v, o_d_vd, o_d_vdd, o_d_vid, o_d_id, o_d_7pi, o_d_7pii, + o_d_7piid, o_d_7piii, o_d_7piiid, + o_d_ip, o_d_pd, o_d_7pid, o_d, o_d_d, o_d_dd, o_d_7dd, o_d_ddd, + o_d_dddd, + o_i_i, o_i_7i, o_i_ii, o_i_7ii, o_i_iii, o_i_7pi, o_i_7pii, o_i_7piii, + o_d_p, + o_b_p, o_b_7p, o_b_pp, o_b_7pp, o_b_pp_unchecked, o_b_pi, o_b_ii, + o_b_7ii, o_b_dd, + o_p, o_p_p, o_p_ii, o_p_d, o_p_dd, o_i_7d, o_i_7p, o_d_7d, o_p_pp, + o_p_ppp, o_p_pi, o_p_pi_unchecked, + o_p_ppi, o_p_i, o_p_pii, o_p_pip, o_p_pip_unchecked, o_p_piip, o_b_i, + o_b_d +} opt_func_t; + +typedef struct opt_funcs_t { + opt_func_t typ; + void *func; + struct opt_funcs_t *next; +} opt_funcs_t; + +typedef struct { + const char *name; + int32_t name_length; + uint32_t id; + char *doc; + block_t *block; + opt_funcs_t *opt_data; /* vunion-functions (see below) */ + s7_pointer generic_ff, setter, signature, pars; + s7_pointer(*chooser) (s7_scheme * sc, s7_pointer f, int32_t args, + s7_pointer expr, bool ops); + /* arg_defaults|names call_args only T_C_FUNCTION_STAR -- call args for GC protection */ + union { + s7_pointer *arg_defaults; + s7_pointer bool_setter; + } dam; + union { + s7_pointer *arg_names; + s7_pointer c_sym; + } sam; + union { + s7_pointer call_args; + void (*marker)(s7_pointer p, s7_int len); + } cam; +} c_proc_t; + + +typedef struct { + s7_int type, outer_type; + s7_pointer scheme_name, getter, setter; + void (*mark)(void *val); + void (*free)(void *value); /* this will go away someday (use gc_free) */ + bool (*eql)(void *val1, void *val2); /* this will go away someday (use equal) */ +#if (!DISABLE_DEPRECATED) + char *(*print)(s7_scheme * sc, void *value); +#endif + s7_pointer(*equal) (s7_scheme * sc, s7_pointer args); + s7_pointer(*equivalent) (s7_scheme * sc, s7_pointer args); + s7_pointer(*ref) (s7_scheme * sc, s7_pointer args); + s7_pointer(*set) (s7_scheme * sc, s7_pointer args); + s7_pointer(*length) (s7_scheme * sc, s7_pointer args); + s7_pointer(*reverse) (s7_scheme * sc, s7_pointer args); + s7_pointer(*copy) (s7_scheme * sc, s7_pointer args); + s7_pointer(*fill) (s7_scheme * sc, s7_pointer args); + s7_pointer(*to_list) (s7_scheme * sc, s7_pointer args); + s7_pointer(*to_string) (s7_scheme * sc, s7_pointer args); + s7_pointer(*gc_mark) (s7_scheme * sc, s7_pointer args); + s7_pointer(*gc_free) (s7_scheme * sc, s7_pointer args); +} c_object_t; + + +typedef s7_int(*hash_map_t) (s7_scheme * sc, s7_pointer table, s7_pointer key); /* hash-table object->location mapper */ +typedef hash_entry_t *(*hash_check_t)(s7_scheme * sc, s7_pointer table, s7_pointer key); /* hash-table object equality function */ +static hash_map_t default_hash_map[NUM_TYPES]; + + +typedef s7_int(*s7_i_7pi_t) (s7_scheme * sc, s7_pointer p, s7_int i1); +typedef s7_int(*s7_i_7pii_t) (s7_scheme * sc, s7_pointer p, s7_int i1, + s7_int i2); +typedef s7_int(*s7_i_7piii_t) (s7_scheme * sc, s7_pointer p, s7_int i1, + s7_int i2, s7_int i3); +typedef s7_int(*s7_i_iii_t) (s7_int i1, s7_int i2, s7_int i3); +typedef s7_int(*s7_i_7i_t) (s7_scheme * sc, s7_int i1); +typedef s7_int(*s7_i_7ii_t) (s7_scheme * sc, s7_int i1, s7_int i2); +typedef bool (*s7_b_pp_t)(s7_pointer p1, s7_pointer p2); +typedef bool (*s7_b_7pp_t)(s7_scheme * sc, s7_pointer p1, s7_pointer p2); +typedef bool (*s7_b_7p_t)(s7_scheme * sc, s7_pointer p1); +typedef bool (*s7_b_pi_t)(s7_scheme * sc, s7_pointer p1, s7_int i2); +typedef bool (*s7_b_d_t)(s7_double p1); +typedef bool (*s7_b_i_t)(s7_int p1); +typedef bool (*s7_b_ii_t)(s7_int p1, s7_int p2); +typedef bool (*s7_b_7ii_t)(s7_scheme * sc, s7_int p1, s7_int p2); +typedef bool (*s7_b_dd_t)(s7_double p1, s7_double p2); +typedef s7_pointer(*s7_p_p_t) (s7_scheme * sc, s7_pointer p); +typedef s7_pointer(*s7_p_t) (s7_scheme * sc); +typedef s7_pointer(*s7_p_pp_t) (s7_scheme * sc, s7_pointer p1, + s7_pointer p2); +typedef s7_pointer(*s7_p_ppi_t) (s7_scheme * sc, s7_pointer p1, + s7_pointer p2, s7_int i1); +typedef s7_pointer(*s7_p_ppp_t) (s7_scheme * sc, s7_pointer p1, + s7_pointer p2, s7_pointer p3); +typedef s7_pointer(*s7_p_pi_t) (s7_scheme * sc, s7_pointer p1, s7_int i1); +typedef s7_pointer(*s7_p_pii_t) (s7_scheme * sc, s7_pointer p1, s7_int i1, + s7_int i2); +typedef s7_pointer(*s7_p_pip_t) (s7_scheme * sc, s7_pointer p1, s7_int i1, + s7_pointer p2); +typedef s7_pointer(*s7_p_piip_t) (s7_scheme * sc, s7_pointer p1, s7_int i1, + s7_int i2, s7_pointer p3); +typedef s7_pointer(*s7_p_i_t) (s7_scheme * sc, s7_int i); +typedef s7_pointer(*s7_p_ii_t) (s7_scheme * sc, s7_int i1, s7_int i2); +typedef s7_pointer(*s7_p_dd_t) (s7_scheme * sc, s7_double x1, + s7_double x2); +typedef s7_double(*s7_d_7d_t) (s7_scheme * sc, s7_double p1); +typedef s7_double(*s7_d_7dd_t) (s7_scheme * sc, s7_double p1, + s7_double p2); +typedef s7_double(*s7_d_7pii_t) (s7_scheme * sc, s7_pointer p1, s7_int i1, + s7_int i2); +typedef s7_double(*s7_d_7piid_t) (s7_scheme * sc, s7_pointer p1, s7_int i1, + s7_int i2, s7_double x1); +typedef s7_double(*s7_d_7piii_t) (s7_scheme * sc, s7_pointer p1, s7_int i1, + s7_int i2, s7_int i3); +typedef s7_double(*s7_d_7piiid_t) (s7_scheme * sc, s7_pointer p1, + s7_int i1, s7_int i2, s7_int i3, + s7_double x1); + +typedef struct opt_info opt_info; + +typedef union { + s7_int i; + s7_double x; + s7_pointer p; + void *obj; + opt_info *o1; + s7_function call; + s7_double(*d_f) (void); + s7_double(*d_d_f) (s7_double x); + s7_double(*d_7d_f) (s7_scheme * sc, s7_double x); + s7_double(*d_dd_f) (s7_double x1, s7_double x2); + s7_double(*d_7dd_f) (s7_scheme * sc, s7_double x1, s7_double x2); + s7_double(*d_ddd_f) (s7_double x1, s7_double x2, s7_double x3); + s7_double(*d_dddd_f) (s7_double x1, s7_double x2, s7_double x3, + s7_double x4); + s7_double(*d_v_f) (void *obj); + s7_double(*d_vd_f) (void *obj, s7_double fm); + s7_double(*d_vdd_f) (void *obj, s7_double x1, s7_double x2); + s7_double(*d_vid_f) (void *obj, s7_int i, s7_double fm); + s7_double(*d_id_f) (s7_int i, s7_double fm); + s7_double(*d_7pi_f) (s7_scheme * sc, s7_pointer obj, s7_int i1); + s7_double(*d_7pid_f) (s7_scheme * sc, s7_pointer obj, s7_int i1, + s7_double x); + s7_double(*d_7pii_f) (s7_scheme * sc, s7_pointer obj, s7_int i1, + s7_int i2); + s7_double(*d_7piid_f) (s7_scheme * sc, s7_pointer obj, s7_int i1, + s7_int i2, s7_double x); + s7_double(*d_7piii_f) (s7_scheme * sc, s7_pointer obj, s7_int i1, + s7_int i2, s7_int i3); + s7_double(*d_7piiid_f) (s7_scheme * sc, s7_pointer obj, s7_int i1, + s7_int i2, s7_int i3, s7_double x); + s7_double(*d_ip_f) (s7_int i1, s7_pointer p); + s7_double(*d_pd_f) (s7_pointer obj, s7_double x); + s7_double(*d_p_f) (s7_pointer p); + s7_int(*i_7d_f) (s7_scheme * sc, s7_double i1); + s7_int(*i_7p_f) (s7_scheme * sc, s7_pointer i1); + s7_int(*i_i_f) (s7_int i1); + s7_int(*i_7i_f) (s7_scheme * sc, s7_int i1); + s7_int(*i_ii_f) (s7_int i1, s7_int i2); + s7_int(*i_7ii_f) (s7_scheme * sc, s7_int i1, s7_int i2); + s7_int(*i_iii_f) (s7_int i1, s7_int i2, s7_int i3); + s7_int(*i_7pi_f) (s7_scheme * sc, s7_pointer p, s7_int i1); + s7_int(*i_7pii_f) (s7_scheme * sc, s7_pointer p, s7_int i1, + s7_int i2); + s7_int(*i_7piii_f) (s7_scheme * sc, s7_pointer p, s7_int i1, + s7_int i2, s7_int i3); + bool (*b_i_f)(s7_int p); + bool (*b_d_f)(s7_double p); + bool (*b_p_f)(s7_pointer p); + bool (*b_pp_f)(s7_pointer p1, s7_pointer p2); + bool (*b_7pp_f)(s7_scheme * sc, s7_pointer p1, s7_pointer p2); + bool (*b_7p_f)(s7_scheme * sc, s7_pointer p1); + bool (*b_pi_f)(s7_scheme * sc, s7_pointer p1, s7_int i2); + bool (*b_ii_f)(s7_int i1, s7_int i2); + bool (*b_7ii_f)(s7_scheme * sc, s7_int i1, s7_int i2); + bool (*b_dd_f)(s7_double x1, s7_double x2); + s7_pointer(*p_f) (s7_scheme * sc); + s7_pointer(*p_p_f) (s7_scheme * sc, s7_pointer p); + s7_pointer(*p_pp_f) (s7_scheme * sc, s7_pointer p1, s7_pointer p2); + s7_pointer(*p_ppp_f) (s7_scheme * sc, s7_pointer p, s7_pointer p2, + s7_pointer p3); + s7_pointer(*p_pi_f) (s7_scheme * sc, s7_pointer p1, s7_int i1); + s7_pointer(*p_pii_f) (s7_scheme * sc, s7_pointer p1, s7_int i1, + s7_int i2); + s7_pointer(*p_ppi_f) (s7_scheme * sc, s7_pointer p1, s7_pointer p2, + s7_int i1); + s7_pointer(*p_pip_f) (s7_scheme * sc, s7_pointer p1, s7_int i1, + s7_pointer p2); + s7_pointer(*p_piip_f) (s7_scheme * sc, s7_pointer p1, s7_int i1, + s7_int i2, s7_pointer p3); + s7_pointer(*p_i_f) (s7_scheme * sc, s7_int i); + s7_pointer(*p_ii_f) (s7_scheme * sc, s7_int x1, s7_int x2); + s7_pointer(*p_d_f) (s7_scheme * sc, s7_double x); + s7_pointer(*p_dd_f) (s7_scheme * sc, s7_double x1, s7_double x2); + s7_double(*fd) (opt_info * o); + s7_int(*fi) (opt_info * o); + bool (*fb)(opt_info * o); + s7_pointer(*fp) (opt_info * o); +} vunion; + +#define NUM_VUNIONS 15 +struct opt_info { + vunion v[NUM_VUNIONS]; + s7_scheme *sc; +}; + +#define O_WRAP (NUM_VUNIONS - 1) + +#if WITH_GMP +typedef struct bigint { + mpz_t n; + struct bigint *nxt; +} bigint; +typedef struct bigrat { + mpq_t q; + struct bigrat *nxt; +} bigrat; +typedef struct bigflt { + mpfr_t x; + struct bigflt *nxt; +} bigflt; +typedef struct bigcmp { + mpc_t z; + struct bigcmp *nxt; +} bigcmp; + +typedef struct { + mpfr_t error, ux, x0, x1; + mpz_t i, i0, i1, n; + mpz_t p0, q0, r, r1, p1, q1, old_p1, old_q1; + mpfr_t val, e0, e1, e0p, e1p, old_e0, old_e1, old_e0p; + mpq_t q; +} rat_locals_t; +#endif + + +/* -------------------------------- cell structure -------------------------------- */ + +typedef struct s7_cell { + union { + uint64_t flag; /* type info */ + int64_t signed_flag; + uint8_t type_field; + uint16_t sflag; + struct { + uint32_t unused_low_flag; + uint16_t opt_choice; + uint16_t high_flag; + } opts; + } tf; + union { + + union { /* integers, floats */ + s7_int integer_value; + s7_double real_value; + + struct { /* ratios */ + s7_int numerator; + s7_int denominator; + } fraction_value; + + struct { /* complex numbers */ + s7_double rl; + s7_double im; + } complex_value; + +#if WITH_GMP + bigint *bgi; /* bignums */ + bigrat *bgr; + bigflt *bgf; + bigcmp *bgc; +#endif + } number; + + struct { + s7_int unused1, unused2; /* always int64_t so this is 16 bytes */ + uint8_t name[24]; + } number_name; + + struct { /* ports */ + port_t *port; + uint8_t *data; + s7_int size, point; + block_t *block; + } prt; + + struct { /* characters */ + uint8_t c, up_c; + int32_t length; + bool alpha_c, digit_c, space_c, upper_c, lower_c; + char c_name[12]; + } chr; + + struct { /* c-pointers */ + void *c_pointer; + s7_pointer c_type, info, weak1, weak2; + } cptr; + + struct { /* vectors */ + s7_int length; + union { + s7_pointer *objects; + s7_int *ints; + s7_double *floats; + uint8_t *bytes; + } elements; + block_t *block; + s7_pointer(*vget) (s7_scheme * sc, s7_pointer vec, + s7_int loc); + union { + s7_pointer(*vset) (s7_scheme * sc, s7_pointer vec, + s7_int loc, s7_pointer val); + s7_pointer fset; + } setv; + } vector; + + struct { /* stacks (internal) struct must match vector above for length/objects */ + s7_int length; + s7_pointer *objects; + block_t *block; + int64_t top, flags; + } stk; + + struct { /* hash-tables */ + s7_int mask; + hash_entry_t **elements; + hash_check_t hash_func; + hash_map_t *loc; + block_t *block; + } hasher; + + struct { /* iterators */ + s7_pointer obj, cur; + union { + s7_int loc; + s7_pointer lcur; + } lc; + union { + s7_int len; + s7_pointer slow; + hash_entry_t *hcur; + } lw; + s7_pointer(*next) (s7_scheme * sc, s7_pointer iterator); + } iter; + + struct { + c_proc_t *c_proc; /* C functions, macros */ + s7_function ff; + s7_int required_args, optional_args, all_args; + } fnc; + + struct { /* pairs */ + s7_pointer car, cdr, opt1, opt2, opt3; + } cons; + + struct { /* pairs */ + s7_pointer car, cdr, opt1, opt2; + uint8_t opt_type; + } cons_ext; + + struct { /* special purpose pairs (symbol-table etc) */ + s7_pointer unused_car, unused_cdr; + uint64_t hash; + const char *fstr; + uint64_t location; /* line/file/position, also used in symbol_table as raw_len */ + } sym_cons; + + struct { /* scheme functions */ + s7_pointer args, body, env, setter; /* args can be a symbol, as well as a list, setter can be #f as well as a procedure/closure */ + int32_t arity; + } func; + + struct { /* strings */ + s7_int length; + char *svalue; + uint64_t hash; /* string hash-index */ + block_t *block; + block_t *gensym_block; + } string; + + struct { /* symbols */ + s7_pointer name, global_slot, local_slot; + int64_t id; /* which let last bound the symbol -- for faster symbol lookup */ + uint32_t ctr; /* how many times has symbol been bound */ + uint32_t tag; /* symbol as member of a set (tree-set-memq etc), high 32 bits are in symbol_info (the string block) */ + } sym; + + struct { /* syntax */ + s7_pointer symbol; + opcode_t op; + int32_t min_args, max_args; + const char *documentation; + } syn; + + struct { /* slots (bindings) */ + s7_pointer sym, val, nxt, pending_value, expr; + } slt; + + struct { /* lets (environments) */ + s7_pointer slots, nxt; + int64_t id; /* id of rootlet is -1 */ + union { + struct { + s7_pointer function; /* *function* (code) if this is a funclet */ + uint32_t line, file; /* *function* location if it is known */ + } efnc; + struct { + s7_pointer dox1, dox2; /* do loop variables */ + } dox; + struct { /* (catch #t ...) opts */ + uint64_t op_stack_loc, goto_loc; + } ctall; + struct { + s7_int key; /* s7_int is sc->baffle_ctr type */ + } bafl; + } edat; + } envr; + + struct { /* special stuff like # */ + s7_pointer car, cdr; /* unique_car|cdr, for sc->nil these are sc->unspecified for faster assoc etc */ + int64_t unused_let_id; /* let_id(sc->nil) is -1, so this needs to align with envr.id above, only used by sc->nil, so free elsewhere */ + const char *name; + s7_int len; + } unq; + + struct { /* #<...> */ + char *name; /* not const because the GC frees it */ + s7_int len; + } undef; + + struct { /* # */ + const char *name; + s7_int len; + } eof; + + struct { /* counter (internal) */ + s7_pointer result, list, env, slots; /* env = counter_let (curlet after map/for-each let created) */ + uint64_t cap; /* sc->capture_let_counter for let reuse */ + } ctr; + + struct { /* random-state */ +#if WITH_GMP + gmp_randstate_t state; +#else + uint64_t seed, carry; +#endif + } rng; + + struct { /* additional object types (C) */ + s7_int type; + void *value; /* the value the caller associates with the c_object */ + s7_pointer e; /* the method list, if any (openlet) */ + s7_scheme *sc; + } c_obj; + + struct { /* continuations */ + block_t *block; + s7_pointer stack, op_stack; + s7_pointer *stack_start, *stack_end; + } cwcc; + + struct { /* call-with-exit */ + uint64_t goto_loc, op_stack_loc; + bool active; + s7_pointer name; + } rexit; + + struct { /* catch */ + uint64_t goto_loc, op_stack_loc; + s7_pointer tag; + s7_pointer handler; + } rcatch; /* C++ reserves "catch" I guess */ + + struct { /* dynamic-wind */ + s7_pointer in, out, body; + dwind_t state; + } winder; + } object; + +#if S7_DEBUGGING + int32_t current_alloc_line, previous_alloc_line, uses, + explicit_free_line, gc_line; + int64_t current_alloc_type, previous_alloc_type, debugger_bits; + const char *current_alloc_func, *previous_alloc_func, *gc_func; +#endif +} s7_cell; + + +typedef struct s7_big_cell { + s7_cell cell; + int64_t big_hloc; +} s7_big_cell; +typedef struct s7_big_cell *s7_big_pointer; + +typedef struct heap_block_t { + intptr_t start, end; + int64_t offset; + struct heap_block_t *next; +} heap_block_t; + +typedef struct { + s7_pointer *objs; + int32_t size, top, ref, size2; + bool has_hits; + int32_t *refs; + s7_pointer cycle_port, init_port; + s7_int cycle_loc, init_loc; + bool *defined; +} shared_info_t; + +typedef struct { + s7_int loc, curly_len, ctr; + char *curly_str; + s7_pointer args, orig_str, curly_arg; + s7_pointer port, strport; +} format_data_t; + +typedef struct gc_obj_t { + s7_pointer p; + struct gc_obj_t *nxt; +} gc_obj_t; + +typedef struct { + s7_pointer *list; + s7_int size, loc; +} gc_list_t; + +typedef struct { + int32_t size, top, excl_size, excl_top; + s7_pointer *funcs; + s7_int *data, *excl; +} profile_data_t; + + +/* -------------------------------- s7_scheme struct -------------------------------- */ +struct s7_scheme { + s7_pointer code; + s7_pointer curlet; /* layout of first 4 entries should match stack frame layout */ + s7_pointer args; /* arguments of current function */ + opcode_t cur_op; + s7_pointer value; + s7_pointer cur_code; + token_t tok; + + s7_pointer stack; /* stack is a vector */ + uint32_t stack_size; + s7_pointer *stack_start, *stack_end, *stack_resize_trigger; + + s7_pointer *op_stack, *op_stack_now, *op_stack_end; + uint32_t op_stack_size, max_stack_size; + + s7_cell **heap, **free_heap, **free_heap_top, **free_heap_trigger, + **previous_free_heap_top; + int64_t heap_size, gc_freed, gc_total_freed, max_heap_size, + gc_temps_size; + s7_double gc_resize_heap_fraction, gc_resize_heap_by_4_fraction; + s7_int gc_calls, gc_total_time, gc_start, gc_end; + heap_block_t *heap_blocks; + +#if WITH_HISTORY + s7_pointer eval_history1, eval_history2, error_history, history_sink, + history_pairs, old_cur_code; + bool using_history1; +#endif + +#if WITH_MULTITHREAD_CHECKS + int32_t lock_count; + pthread_mutex_t lock; +#endif + + gc_obj_t *permanent_objects, *permanent_lets; + s7_pointer protected_objects, protected_setters, protected_setter_symbols; /* vectors of gc-protected objects */ + s7_int *gpofl; /* "gc_protected_objects_free_locations" (so we never have to do a linear search for a place to store something) */ + s7_int protected_objects_size, protected_setters_size, + protected_setters_loc; + s7_int gpofl_loc; + + s7_pointer nil; /* empty list */ + s7_pointer T; /* #t */ + s7_pointer F; /* #f */ + s7_pointer undefined; /* # */ + s7_pointer unspecified; /* # */ + s7_pointer no_value; /* the (values) value */ + s7_pointer unused; /* a marker for an unoccupied slot in sc->protected_objects (and other similar stuff) */ + + s7_pointer symbol_table; /* symbol table */ + s7_pointer rootlet, shadow_rootlet; /* rootlet */ + s7_int rootlet_entries; + s7_pointer unlet; /* original bindings of predefined functions */ + + s7_pointer input_port; /* current-input-port */ + s7_pointer *input_port_stack; /* input port stack (load and read internally) */ + uint32_t input_port_stack_size, input_port_stack_loc; + + s7_pointer output_port; /* current-output-port */ + s7_pointer error_port; /* current-error-port */ + s7_pointer owlet; /* owlet */ + s7_pointer error_type, error_data, error_code, error_line, error_file, error_position; /* owlet slots */ + s7_pointer standard_input, standard_output, standard_error; + + s7_pointer sharp_readers; /* the binding pair for the global *#readers* list */ + s7_pointer load_hook; /* *load-hook* hook object */ + s7_pointer autoload_hook; /* *autoload-hook* hook object */ + s7_pointer unbound_variable_hook; /* *unbound-variable-hook* hook object */ + s7_pointer missing_close_paren_hook, rootlet_redefinition_hook; + s7_pointer error_hook, read_error_hook; /* *error-hook* hook object, and *read-error-hook* */ + bool gc_off; /* gc_off: if true, the GC won't run */ + uint32_t gc_stats, gensym_counter, f_class, add_class, multiply_class, + subtract_class, num_eq_class; + int32_t format_column; + uint64_t capture_let_counter; + bool short_print, is_autoloading, in_with_let, object_out_locked, + has_openlets, is_expanding, accept_all_keyword_arguments, + muffle_warnings; + bool got_tc, got_rec, not_tc; + s7_int rec_tc_args, continuation_counter; + int64_t let_number; + s7_double default_rationalize_error, equivalent_float_epsilon, + hash_table_float_epsilon; + s7_int default_hash_table_length, initial_string_port_length, + print_length, objstr_max_len, history_size, true_history_size, + output_port_data_size; + s7_int max_vector_length, max_string_length, max_list_length, + max_vector_dimensions, max_format_length, max_port_data_size, + rec_loc, rec_len; + s7_pointer stacktrace_defaults; + + s7_pointer rec_stack, rec_testp, rec_f1p, rec_f2p, rec_f3p, rec_f4p, + rec_f5p, rec_f6p, rec_f7p, rec_f8p, rec_f9p; + s7_pointer rec_resp, rec_slot1, rec_slot2, rec_slot3, rec_p1, rec_p2; + s7_pointer *rec_els; + s7_function rec_testf, rec_f1f, rec_f2f, rec_f3f, rec_f4f, rec_f5f, + rec_f6f, rec_f7f, rec_f8f, rec_f9f, rec_resf, rec_fn; + s7_int(*rec_fi1) (opt_info * o); + s7_int(*rec_fi2) (opt_info * o); + s7_int(*rec_fi3) (opt_info * o); + s7_int(*rec_fi4) (opt_info * o); + s7_int(*rec_fi5) (opt_info * o); + s7_int(*rec_fi6) (opt_info * o); + bool (*rec_fb1)(opt_info * o); + bool (*rec_fb2)(opt_info * o); + + opt_info *rec_test_o, *rec_result_o, *rec_a1_o, *rec_a2_o, *rec_a3_o, + *rec_a4_o, *rec_a5_o, *rec_a6_o; + s7_i_ii_t rec_i_ii_f; + s7_d_dd_t rec_d_dd_f; + s7_pointer rec_val1, rec_val2; + + int32_t float_format_precision; + vdims_t *wrap_only; + + char *typnam; + int32_t typnam_len, print_width; + s7_pointer *singletons; + block_t *unentry; /* hash-table lookup failure indicator */ + +#define INITIAL_FILE_NAMES_SIZE 8 + s7_pointer *file_names; + int32_t file_names_size, file_names_top; + +#define INITIAL_STRBUF_SIZE 1024 + s7_int strbuf_size; + char *strbuf; + + char *read_line_buf; + s7_int read_line_buf_size; + + s7_pointer u, v, w, x, y, z; /* evaluator local vars */ + s7_pointer temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, + temp9, temp_cell_2; + s7_pointer t1_1, t2_1, t2_2, t3_1, t3_2, t3_3, z2_1, z2_2, t4_1, u1_1, + u2_1, u2_2; + + Jmp_Buf goto_start; + bool longjmp_ok; + int32_t setjmp_loc; + + void (*begin_hook)(s7_scheme * sc, bool *val); + opcode_t begin_op; + + bool debug_or_profile, profiling_gensyms; + s7_int current_line, s7_call_line, safety, debug, profile; + profile_data_t *profile_data; + const char *current_file, *s7_call_file, *s7_call_name; + + shared_info_t *circle_info; + format_data_t **fdats; + int32_t num_fdats, last_error_line; + s7_pointer elist_1, elist_2, elist_3, elist_4, elist_5, plist_1, + plist_2, plist_2_2, plist_3, qlist_2, qlist_3, clist_1, dlist_1; + gc_list_t *strings, *vectors, *input_ports, *output_ports, + *input_string_ports, *continuations, *c_objects, *hash_tables; + gc_list_t *gensyms, *undefineds, *lambdas, *multivectors, *weak_refs, + *weak_hash_iterators, *opt1_funcs; +#if (WITH_GMP) + gc_list_t *big_integers, *big_ratios, *big_reals, *big_complexes, + *big_random_states; + mpz_t mpz_1, mpz_2, mpz_3, mpz_4; + mpq_t mpq_1, mpq_2, mpq_3; + mpfr_t mpfr_1, mpfr_2, mpfr_3; + mpc_t mpc_1, mpc_2; + rat_locals_t *ratloc; + bigint *bigints; + bigrat *bigrats; + bigflt *bigflts; + bigcmp *bigcmps; +#endif + s7_pointer *setters; + s7_int setters_size, setters_loc; + s7_pointer *tree_pointers; + int32_t tree_pointers_size, tree_pointers_top, permanent_cells, + string_wrapper_pos, num_to_str_size; + s7_pointer format_ports; + uint32_t alloc_pointer_k, alloc_function_k, alloc_symbol_k; + s7_cell *alloc_pointer_cells; + c_proc_t *alloc_function_cells; + uint32_t alloc_big_pointer_k; + s7_big_cell *alloc_big_pointer_cells; + s7_pointer *string_wrappers; + uint8_t *alloc_symbol_cells; + char *num_to_str; + + block_t *block_lists[NUM_BLOCK_LISTS]; + size_t alloc_string_k; + char *alloc_string_cells; + + c_object_t **c_object_types; + int32_t c_object_types_size, num_c_object_types; + s7_pointer type_to_typers[NUM_TYPES]; + + uint32_t syms_tag, syms_tag2; + int32_t bignum_precision; + s7_int baffle_ctr; + s7_pointer default_rng; + + s7_pointer sort_body, sort_begin, sort_v1, sort_v2; + opcode_t sort_op; + s7_int sort_body_len; + s7_b_7pp_t sort_f; + opt_info *sort_o; + bool (*sort_fb)(opt_info * o); + +#define INT_TO_STR_SIZE 32 + char int_to_str1[INT_TO_STR_SIZE], int_to_str2[INT_TO_STR_SIZE], + int_to_str3[INT_TO_STR_SIZE], int_to_str4[INT_TO_STR_SIZE], + int_to_str5[INT_TO_STR_SIZE]; + + s7_pointer abs_symbol, acos_symbol, acosh_symbol, add_symbol, + angle_symbol, append_symbol, apply_symbol, apply_values_symbol, + arity_symbol, ash_symbol, asin_symbol, asinh_symbol, assoc_symbol, + assq_symbol, assv_symbol, atan_symbol, atanh_symbol, + autoload_symbol, autoloader_symbol, bacro_symbol, + bacro_star_symbol, bignum_symbol, byte_vector_symbol, + byte_vector_ref_symbol, byte_vector_set_symbol, + byte_vector_to_string_symbol, c_pointer_symbol, + c_pointer_info_symbol, c_pointer_to_list_symbol, + c_pointer_type_symbol, c_pointer_weak1_symbol, + c_pointer_weak2_symbol, c_pointer_with_type, caaaar_symbol, + caaadr_symbol, caaar_symbol, caadar_symbol, caaddr_symbol, + caadr_symbol, caar_symbol, cadaar_symbol, cadadr_symbol, + cadar_symbol, caddar_symbol, cadddr_symbol, caddr_symbol, + cadr_symbol, call_cc_symbol, call_with_current_continuation_symbol, + call_with_exit_symbol, call_with_input_file_symbol, + call_with_input_string_symbol, call_with_output_file_symbol, + call_with_output_string_symbol, car_symbol, catch_symbol, + cdaaar_symbol, cdaadr_symbol, cdaar_symbol, cdadar_symbol, + cdaddr_symbol, cdadr_symbol, cdar_symbol, cddaar_symbol, + cddadr_symbol, cddar_symbol, cdddar_symbol, cddddr_symbol, + cdddr_symbol, cddr_symbol, cdr_symbol, ceiling_symbol, + char_downcase_symbol, char_eq_symbol, char_geq_symbol, + char_gt_symbol, char_leq_symbol, char_lt_symbol, + char_position_symbol, char_to_integer_symbol, char_upcase_symbol, + cload_directory_symbol, close_input_port_symbol, + close_output_port_symbol, complex_symbol, cons_symbol, copy_symbol, + cos_symbol, cosh_symbol, coverlet_symbol, curlet_symbol, + current_error_port_symbol, current_input_port_symbol, + current_output_port_symbol, cutlet_symbol, cyclic_sequences_symbol, + denominator_symbol, dilambda_symbol, display_symbol, divide_symbol, + documentation_symbol, dynamic_wind_symbol, dynamic_unwind_symbol, + num_eq_symbol, error_symbol, eval_string_symbol, eval_symbol, + exact_to_inexact_symbol, exit_symbol, exp_symbol, expt_symbol, + features_symbol, file__symbol, fill_symbol, + float_vector_ref_symbol, float_vector_set_symbol, + float_vector_symbol, floor_symbol, flush_output_port_symbol, + for_each_symbol, format_symbol, funclet_symbol, _function__symbol, + gc_symbol, gcd_symbol, gensym_symbol, geq_symbol, + get_output_string_symbol, gt_symbol, hash_table_entries_symbol, + hash_table_ref_symbol, hash_table_set_symbol, hash_table_symbol, + help_symbol, imag_part_symbol, immutable_symbol, + inexact_to_exact_symbol, inlet_symbol, int_vector_ref_symbol, + int_vector_set_symbol, int_vector_symbol, + integer_decode_float_symbol, integer_to_char_symbol, + is_aritable_symbol, is_bignum_symbol, is_boolean_symbol, + is_byte_symbol, is_byte_vector_symbol, is_c_object_symbol, + c_object_type_symbol, is_c_pointer_symbol, + is_char_alphabetic_symbol, is_char_lower_case_symbol, + is_char_numeric_symbol, is_char_symbol, is_char_upper_case_symbol, + is_char_whitespace_symbol, is_complex_symbol, is_constant_symbol, + is_continuation_symbol, is_defined_symbol, is_dilambda_symbol, + is_eof_object_symbol, is_eq_symbol, is_equal_symbol, is_eqv_symbol, + is_even_symbol, is_exact_symbol, is_float_vector_symbol, + is_funclet_symbol, is_gensym_symbol, is_goto_symbol, + is_hash_table_symbol, is_immutable_symbol, is_inexact_symbol, + is_infinite_symbol, is_input_port_symbol, is_int_vector_symbol, + is_integer_symbol, is_iterator_symbol, is_keyword_symbol, + is_let_symbol, is_list_symbol, is_macro_symbol, + is_equivalent_symbol, is_nan_symbol, is_negative_symbol, + is_null_symbol, is_number_symbol, is_odd_symbol, is_openlet_symbol, + is_output_port_symbol, is_pair_symbol, is_port_closed_symbol, + is_positive_symbol, is_procedure_symbol, is_proper_list_symbol, + is_provided_symbol, is_random_state_symbol, is_rational_symbol, + is_real_symbol, is_sequence_symbol, is_string_symbol, + is_subvector_symbol, is_symbol_symbol, is_syntax_symbol, + is_vector_symbol, is_weak_hash_table_symbol, is_zero_symbol, + is_float_symbol, is_integer_or_real_at_end_symbol, + is_integer_or_any_at_end_symbol, is_unspecified_symbol, + is_undefined_symbol, iterate_symbol, iterator_is_at_end_symbol, + iterator_sequence_symbol, keyword_to_symbol_symbol, lcm_symbol, + length_symbol, leq_symbol, let_ref_fallback_symbol, let_ref_symbol, + let_set_fallback_symbol, let_set_symbol, let_temporarily_symbol, + libraries_symbol, list_ref_symbol, list_set_symbol, list_symbol, + list_tail_symbol, list_values_symbol, load_path_symbol, + load_symbol, log_symbol, logand_symbol, logbit_symbol, + logior_symbol, lognot_symbol, logxor_symbol, lt_symbol, + macro_symbol, macro_star_symbol, magnitude_symbol, + make_byte_vector_symbol, make_float_vector_symbol, + make_hash_table_symbol, make_weak_hash_table_symbol, + make_int_vector_symbol, make_iterator_symbol, + string_to_keyword_symbol, make_list_symbol, make_string_symbol, + make_vector_symbol, map_symbol, max_symbol, member_symbol, + memq_symbol, memv_symbol, min_symbol, modulo_symbol, + multiply_symbol, name_symbol, newline_symbol, not_symbol, + number_to_string_symbol, numerator_symbol, object_to_string_symbol, + object_to_let_symbol, open_input_file_symbol, + open_input_function_symbol, open_input_string_symbol, + open_output_file_symbol, open_output_function_symbol, + open_output_string_symbol, openlet_symbol, outlet_symbol, + owlet_symbol, pair_filename_symbol, pair_line_number_symbol, + peek_char_symbol, pi_symbol, port_filename_symbol, + port_line_number_symbol, port_file_symbol, port_position_symbol, + procedure_source_symbol, provide_symbol, quotient_symbol, + random_state_symbol, random_state_to_list_symbol, random_symbol, + rationalize_symbol, read_byte_symbol, read_char_symbol, + read_line_symbol, read_string_symbol, read_symbol, + real_part_symbol, remainder_symbol, require_symbol, reverse_symbol, + reverseb_symbol, rootlet_symbol, round_symbol, setter_symbol, + set_car_symbol, set_cdr_symbol, set_current_error_port_symbol, + set_current_input_port_symbol, set_current_output_port_symbol, + signature_symbol, sin_symbol, sinh_symbol, sort_symbol, + sqrt_symbol, stacktrace_symbol, string_append_symbol, + string_copy_symbol, string_downcase_symbol, string_eq_symbol, + string_fill_symbol, string_geq_symbol, string_gt_symbol, + string_leq_symbol, string_lt_symbol, string_position_symbol, + string_ref_symbol, string_set_symbol, string_symbol, + string_to_number_symbol, string_to_symbol_symbol, + string_upcase_symbol, sublet_symbol, substring_symbol, + subtract_symbol, subvector_symbol, subvector_position_symbol, + subvector_vector_symbol, symbol_symbol, + symbol_to_dynamic_value_symbol, symbol_to_keyword_symbol, + symbol_to_string_symbol, symbol_to_value_symbol, tan_symbol, + tanh_symbol, throw_symbol, string_to_byte_vector_symbol, + tree_count_symbol, tree_leaves_symbol, tree_memq_symbol, + tree_set_memq_symbol, tree_is_cyclic_symbol, truncate_symbol, + type_of_symbol, unlet_symbol, values_symbol, varlet_symbol, + vector_append_symbol, vector_dimension_symbol, + vector_dimensions_symbol, vector_fill_symbol, vector_rank_symbol, + vector_ref_symbol, vector_set_symbol, vector_symbol, + weak_hash_table_symbol, with_input_from_file_symbol, + with_input_from_string_symbol, with_output_to_file_symbol, + with_output_to_string_symbol, write_byte_symbol, write_char_symbol, + write_string_symbol, write_symbol, local_documentation_symbol, + local_signature_symbol, local_setter_symbol, local_iterator_symbol; + s7_pointer hash_code_symbol, dummy_equal_hash_table; +#if (!WITH_PURE_S7) + s7_pointer is_char_ready_symbol, char_ci_leq_symbol, char_ci_lt_symbol, + char_ci_eq_symbol, char_ci_geq_symbol, char_ci_gt_symbol, + let_to_list_symbol, integer_length_symbol, string_ci_leq_symbol, + string_ci_lt_symbol, string_ci_eq_symbol, string_ci_geq_symbol, + string_ci_gt_symbol, string_to_list_symbol, vector_to_list_symbol, + string_length_symbol, list_to_string_symbol, list_to_vector_symbol, + vector_length_symbol; +#endif + + /* syntax symbols et al */ + s7_pointer else_symbol, lambda_symbol, lambda_star_symbol, let_symbol, + quote_symbol, quasiquote_symbol, unquote_symbol, + macroexpand_symbol, define_expansion_symbol, + define_expansion_star_symbol, with_let_symbol, if_symbol, + autoload_error_symbol, when_symbol, unless_symbol, begin_symbol, + cond_symbol, case_symbol, and_symbol, or_symbol, do_symbol, + define_symbol, define_star_symbol, define_constant_symbol, + with_baffle_symbol, define_macro_symbol, define_macro_star_symbol, + define_bacro_symbol, define_bacro_star_symbol, letrec_symbol, + letrec_star_symbol, let_star_symbol, key_rest_symbol, + key_allow_other_keys_symbol, key_readable_symbol, + key_display_symbol, key_write_symbol, value_symbol, type_symbol, + baffled_symbol, set_symbol, body_symbol, class_name_symbol, + feed_to_symbol, format_error_symbol, immutable_error_symbol, + wrong_number_of_args_symbol, read_error_symbol, + string_read_error_symbol, syntax_error_symbol, + division_by_zero_symbol, bad_result_symbol, no_catch_symbol, + io_error_symbol, invalid_escape_function_symbol, + wrong_type_arg_symbol, out_of_range_symbol, out_of_memory_symbol, + missing_method_symbol, unbound_variable_symbol, key_if_symbol, + symbol_table_symbol, profile_in_symbol, trace_in_symbol; + + /* signatures of sequences used as applicable objects: ("hi" 1) */ + s7_pointer string_signature, vector_signature, float_vector_signature, + int_vector_signature, byte_vector_signature, c_object_signature, + let_signature, hash_table_signature, pair_signature; + /* common signatures */ + s7_pointer pcl_bc, pcl_bs, pcl_bt, pcl_c, pcl_e, pcl_f, pcl_i, pcl_n, + pcl_r, pcl_s, pcl_v, pl_bc, pl_bn, pl_bt, pl_p, pl_sf, pl_tl, + pl_nn; + + /* optimizer s7_functions */ + s7_pointer add_2, add_3, add_1x, add_x1, subtract_1, subtract_2, + subtract_3, subtract_x1, subtract_2f, subtract_f2, simple_char_eq, + char_equal_2, char_greater_2, char_less_2, char_position_csi, + string_equal_2, substring_uncopied, display_2, display_f, + string_greater_2, string_less_2, symbol_to_string_uncopied, + get_output_string_uncopied, string_equal_2c, string_c1, + string_append_2, vector_ref_2, vector_ref_3, vector_set_3, + vector_set_4, read_char_1, dynamic_wind_unchecked, append_2, + fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, iv_ref_2, iv_ref_3, + iv_set_3, bv_ref_2, bv_ref_3, bv_set_3, vector_2, vector_3, list_0, + list_1, list_2, list_3, list_4, list_set_i, hash_table_ref_2, + hash_table_2, list_ref_at_0, list_ref_at_1, list_ref_at_2, + format_f, format_no_column, format_just_control_string, + format_as_objstr, values_uncopied, memq_2, memq_3, memq_4, + memq_any, tree_set_memq_syms, simple_inlet, profile_out, + lint_let_ref, lint_let_set, geq_2, add_i_random, + is_defined_in_rootlet; + + s7_pointer multiply_2, invert_1, invert_x, divide_2, divide_by_2, + max_2, min_2, max_3, min_3, num_eq_2, num_eq_xi, num_eq_ix, + less_xi, less_xf, less_x0, less_2, greater_xi, greater_xf, + greater_2, leq_xi, leq_2, leq_ixx, geq_xi, geq_xf, random_i, + random_f, random_1, mul_2_ff, mul_2_ii, mul_2_if, mul_2_fi, + mul_2_xi, mul_2_ix, mul_2_fx, mul_2_xf, add_2_ff, add_2_ii, + add_2_if, add_2_fi, add_2_xi, add_2_ix, add_2_fx, add_2_xf; + s7_pointer seed_symbol, carry_symbol; + + /* object->let symbols */ + s7_pointer active_symbol, goto_symbol, data_symbol, weak_symbol, + dimensions_symbol, info_symbol, c_type_symbol, source_symbol, + c_object_ref_symbol, at_end_symbol, sequence_symbol, + position_symbol, entries_symbol, locked_symbol, function_symbol, + open_symbol, alias_symbol, port_type_symbol, file_symbol, + file_info_symbol, line_symbol, c_object_let_symbol, class_symbol, + c_object_length_symbol, c_object_set_symbol, current_value_symbol, + c_object_copy_symbol, c_object_fill_symbol, + c_object_reverse_symbol, c_object_to_list_symbol, + c_object_to_string_symbol, closed_symbol, mutable_symbol, + size_symbol, original_vector_symbol, pointer_symbol; + +#if WITH_SYSTEM_EXTRAS + s7_pointer is_directory_symbol, file_exists_symbol, delete_file_symbol, + getenv_symbol, system_symbol, directory_to_list_symbol, + file_mtime_symbol; +#endif + s7_pointer open_input_function_choices[S7_NUM_READ_CHOICES]; + s7_pointer closed_input_function, closed_output_function; + s7_pointer vector_set_function, string_set_function, list_set_function, + hash_table_set_function, let_set_function, c_object_set_function, + last_function; + + s7_pointer wrong_type_arg_info, out_of_range_info, + simple_wrong_type_arg_info, simple_out_of_range_info; + s7_pointer integer_wrapper1, integer_wrapper2, integer_wrapper3; + s7_pointer real_wrapper1, real_wrapper2, real_wrapper3, real_wrapper4; + +#define NUM_SAFE_PRELISTS 8 +#define NUM_SAFE_LISTS 64 /* 36 is the biggest normally (lint.scm), 49 in s7test, 57 in snd-test */ + s7_pointer safe_lists[NUM_SAFE_LISTS]; + int32_t current_safe_list; + + s7_pointer autoload_table, s7_let, s7_let_symbol; + const char ***autoload_names; + s7_int *autoload_names_sizes; + bool **autoloaded_already; + s7_int autoload_names_loc, autoload_names_top; + int32_t format_depth; + bool undefined_identifier_warnings, undefined_constant_warnings, + stop_at_error; + + opt_funcs_t *alloc_opt_func_cells; + int32_t alloc_opt_func_k; + + int32_t pc; +#define OPTS_SIZE 256 /* pqw-vox needs 178 */ + opt_info *opts[OPTS_SIZE + 1]; /* this form is a lot faster than opt_info**! */ + +#define INITIAL_SAVED_POINTERS_SIZE 256 /* s7test: 838, thash: 55377, trec: 81 */ + void **saved_pointers; + s7_int saved_pointers_loc, saved_pointers_size; + + s7_pointer prepackaged_type_names[NUM_TYPES]; + +#if S7_DEBUGGING + int *tc_rec_calls; + int last_gc_line; +#endif +}; + +#if S7_DEBUGGING +static void gdb_break(void) +{ +}; +#endif +static s7_scheme *cur_sc = NULL; /* intended for gdb (see gdbinit), but also used if S7_DEBUGGING unfortunately */ + +#define opt_sc(o) o->sc +#define opt_set_sc(o, sc) o->sc = sc + + +/* -------------------------------- mallocate -------------------------------- */ + +static void add_saved_pointer(s7_scheme * sc, void *p) +{ + if (sc->saved_pointers_loc == sc->saved_pointers_size) { + sc->saved_pointers_size *= 2; + sc->saved_pointers = + (void **) realloc(sc->saved_pointers, + sc->saved_pointers_size * sizeof(void *)); + } + sc->saved_pointers[sc->saved_pointers_loc++] = p; +} + +#if POINTER_32 +static void *Malloc(size_t bytes) +{ + void *p; + p = malloc(bytes); + if (!p) + s7_error(cur_sc, cur_sc->out_of_memory_symbol, cur_sc->nil); + return (p); +} + +static void *Calloc(size_t nmemb, size_t size) +{ + void *p; + p = calloc(nmemb, size); + if (!p) + s7_error(cur_sc, cur_sc->out_of_memory_symbol, cur_sc->nil); + return (p); +} + +static void *Realloc(void *ptr, size_t size) +{ + void *p; + p = realloc(ptr, size); + if (!p) + s7_error(cur_sc, cur_sc->out_of_memory_symbol, cur_sc->nil); + return (p); +} +#else +#define Malloc malloc +#define Calloc calloc +#define Realloc realloc +#endif + +static const int32_t intlen_bits[256] = + { 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 5, 5, 5, 5, + 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, + 6, 6, 6, 6, 6, 6, 6, 6, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, + 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, + 8, 8, 8, 8, 8, 8, 8, 8, + 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, + 8, 8, 8, 8, 8, 8, 8, 8, + 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, + 8, 8, 8, 8, 8, 8, 8, 8, + 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, + 8, 8, 8, 8, 8, 8, 8, 8 +}; + +static void memclr(void *s, size_t n) +{ + uint8_t *s2; +#if S7_ALIGNED + s2 = (uint8_t *) s; +#else +#if (defined(__x86_64__) || defined(__i386__)) + if (n >= 8) { + int64_t *s1 = (int64_t *) s; + size_t n8 = n >> 3; + do { + *s1++ = 0; + } while (--n8 > 0); + n &= 7; + s2 = (uint8_t *) s1; + } else + s2 = (uint8_t *) s; +#else + s2 = (uint8_t *) s; +#endif +#endif + while (n > 0) { + *s2++ = 0; + n--; + } +} + +#define LOOP_4(Code) do {Code; Code; Code; Code;} while (0) +#define LOOP_8(Code) do {Code; Code; Code; Code; Code; Code; Code; Code;} while (0) +#define STEP_8(Var) (((Var) & 0x7) == 0) +#define STEP_64(Var) (((Var) & 0x3f) == 0) + +#if POINTER_32 +#define memclr64 memclr +#else +static Vectorized void memclr64(void *p, size_t bytes) +{ + size_t i, n = bytes >> 3; + int64_t *vals = (int64_t *) p; + for (i = 0; i < n;) + LOOP_8(vals[i++] = 0); +} +#endif + +static void init_block_lists(s7_scheme * sc) +{ + int32_t i; + for (i = 0; i < NUM_BLOCK_LISTS; i++) + sc->block_lists[i] = NULL; +} + +static inline void liberate(s7_scheme * sc, block_t * p) +{ + if (block_index(p) != TOP_BLOCK_LIST) { + block_next(p) = (struct block_t *) sc->block_lists[block_index(p)]; + sc->block_lists[block_index(p)] = p; + } else { + if (block_data(p)) { + free(block_data(p)); + block_data(p) = NULL; + } + block_next(p) = (struct block_t *) sc->block_lists[BLOCK_LIST]; + sc->block_lists[BLOCK_LIST] = p; + } +} + +static inline void liberate_block(s7_scheme * sc, block_t * p) +{ + block_next(p) = (struct block_t *) sc->block_lists[BLOCK_LIST]; /* BLOCK_LIST=0 */ + sc->block_lists[BLOCK_LIST] = p; +} + +static void fill_block_list(s7_scheme * sc) +{ + int32_t i; + block_t *b; +#define BLOCK_MALLOC_SIZE 256 + b = (block_t *) Malloc(BLOCK_MALLOC_SIZE * sizeof(block_t)); /* batch alloc means blocks in this batch can't be freed, only returned to the list */ + add_saved_pointer(sc, b); + sc->block_lists[BLOCK_LIST] = b; + for (i = 0; i < BLOCK_MALLOC_SIZE - 1; b++, i++) + block_next(b) = (block_t *) (b + 1); + block_next(b) = NULL; +} + +static inline block_t *mallocate_block(s7_scheme * sc) +{ + block_t *p; + if (!sc->block_lists[BLOCK_LIST]) + fill_block_list(sc); /* this is much faster than allocating blocks as needed */ + p = sc->block_lists[BLOCK_LIST]; + sc->block_lists[BLOCK_LIST] = (block_t *) (block_next(p)); + block_set_index(p, BLOCK_LIST); + return (p); +} + +static inline char *permalloc(s7_scheme * sc, size_t len) +{ +#define ALLOC_STRING_SIZE (65536 * 8) /* going up to 16 made no difference in timings */ +#define ALLOC_MAX_STRING (512 * 8) /* was 256 -- sets max size of block space lost at the end, but smaller = more direct malloc calls */ + char *result; + size_t next_k; + + len = (len + 7) & (~7); /* 8-byte aligned -- more than half the time, len is already 8-byte aligned */ + next_k = sc->alloc_string_k + len; + if (next_k > ALLOC_STRING_SIZE) { + if (len >= ALLOC_MAX_STRING) { + result = (char *) Malloc(len); + add_saved_pointer(sc, result); + return (result); + } + sc->alloc_string_cells = (char *) Malloc(ALLOC_STRING_SIZE); /* get a new block */ + add_saved_pointer(sc, sc->alloc_string_cells); + sc->alloc_string_k = 0; + next_k = len; + } + result = &(sc->alloc_string_cells[sc->alloc_string_k]); + sc->alloc_string_k = next_k; + return (result); +} + +static Inline block_t *mallocate(s7_scheme * sc, size_t bytes) +{ + block_t *p; + if (bytes > 0) { + int32_t index; + if (bytes <= 8) /* presetting a version of intlen_bits with 3's gave only a small speed-up */ + index = 3; + else { + if (bytes <= 256) + index = intlen_bits[bytes - 1]; + else + index = (bytes <= 65536) ? (8 + intlen_bits[(bytes - 1) >> 8]) : TOP_BLOCK_LIST; /* expansion to (1 << 17) made no difference */ + } + p = sc->block_lists[index]; + if (p) + sc->block_lists[index] = (block_t *) block_next(p); + else { + if (index < (TOP_BLOCK_LIST - 1)) { + p = sc->block_lists[index + 1]; + if (p) { + /* we are "borrowing" a block from the next larger bin -- this saves space but costs a bit of time. + * in a tauto run repeating every call 1000 times, the old form ends up at 129M and 31.1 secs, + * whereas the borrowing form ends at 116M and 31.5 secs, but most of my tests show a slight + * speed-up, probably because grabbing a block here is faster than making a new one. + * Worst case is tlet: 8 slower in callgrind. + */ + sc->block_lists[index + 1] = (block_t *) block_next(p); + block_set_size(p, bytes); + return (p); + } + } + p = mallocate_block(sc); + block_data(p) = + (index < TOP_BLOCK_LIST) ? (void *) permalloc(sc, + (size_t) (1 + << + index)) + : Malloc(bytes); + block_set_index(p, index); + }} else + p = mallocate_block(sc); + block_set_size(p, bytes); + return (p); +} + +static block_t *callocate(s7_scheme * sc, size_t bytes) +{ + block_t *p; + p = mallocate(sc, bytes); + if ((block_data(p)) && (block_index(p) != BLOCK_LIST)) { + if ((bytes & (~0x3f)) > 0) + memclr64((void *) block_data(p), bytes & (~0x3f)); + if ((bytes & 0x3f) > 0) + memclr((void *) ((uint8_t *) block_data(p) + + (bytes & (~0x3f))), bytes & 0x3f); + } + return (p); +} + +static block_t *reallocate(s7_scheme * sc, block_t * op, size_t bytes) +{ + block_t *np; + np = mallocate(sc, bytes); + if (block_data(op)) /* presumably block_data(np) is not null */ + memcpy((uint8_t *) (block_data(np)), (uint8_t *) (block_data(op)), + block_size(op)); + liberate(sc, op); + return (np); +} + +/* we can't export mallocate et al without also exporting block_t or accessors for it + * that is, the block_t* pointer returned can't be used as if it were the void* pointer returned by malloc + */ + + +/* -------------------------------------------------------------------------------- */ + +typedef enum { P_DISPLAY, P_WRITE, P_READABLE, P_KEY } use_write_t; + +static s7_pointer too_many_arguments_string, not_enough_arguments_string, + missing_method_string, cant_bind_immutable_string, a_boolean_string, + a_byte_vector_string, a_format_port_string, a_let_string, + a_list_string, a_non_constant_symbol_string, + a_non_negative_integer_string, a_normal_procedure_string, + a_normal_real_string, a_number_string, a_procedure_string, + a_procedure_or_a_macro_string, a_proper_list_string, + a_random_state_object_string, a_rational_string, a_sequence_string, + a_symbol_string, a_thunk_string, a_valid_radix_string, + an_association_list_string, an_eq_func_string, + an_input_file_port_string, an_input_port_string, + an_input_string_port_string, an_open_port_string, + an_output_file_port_string, an_output_port_string, + an_output_string_port_string, an_unsigned_byte_string, + caaar_a_list_string, caadr_a_list_string, caar_a_list_string, + cadar_a_list_string, caddr_a_list_string, cadr_a_list_string, + car_a_list_string, cdaar_a_list_string, cdadr_a_list_string, + cdar_a_list_string, cddar_a_list_string, cdddr_a_list_string, + cddr_a_list_string, cdr_a_list_string, immutable_error_string, + its_infinite_string, its_nan_string, its_negative_string, + its_too_large_string, its_too_small_string, parameter_set_twice_string, + result_is_too_large_string, something_applicable_string, + too_many_indices_string, value_is_missing_string, no_setter_string, + intermediate_too_large_string, format_string_1, format_string_2, + format_string_3, format_string_4; + +static bool t_number_p[NUM_TYPES], t_small_real_p[NUM_TYPES], + t_rational_p[NUM_TYPES], t_real_p[NUM_TYPES], + t_big_number_p[NUM_TYPES]; +static bool t_simple_p[NUM_TYPES], t_structure_p[NUM_TYPES]; +static bool t_any_macro_p[NUM_TYPES], t_any_closure_p[NUM_TYPES], + t_has_closure_let[NUM_TYPES]; +static bool t_mappable_p[NUM_TYPES], t_sequence_p[NUM_TYPES], + t_vector_p[NUM_TYPES]; +static bool t_procedure_p[NUM_TYPES], t_applicable_p[NUM_TYPES]; +#if S7_DEBUGGING +static bool t_freeze_p[NUM_TYPES]; /* free_cell sanity check */ +#endif + +static void init_types(void) +{ + int32_t i; + for (i = 0; i < NUM_TYPES; i++) { + t_number_p[i] = false; + t_small_real_p[i] = false; + t_real_p[i] = false; + t_rational_p[i] = false; + t_simple_p[i] = false; + t_structure_p[i] = false; + t_any_macro_p[i] = false; + t_any_closure_p[i] = false; + t_has_closure_let[i] = false; + t_sequence_p[i] = false; + t_mappable_p[i] = false; + t_vector_p[i] = false; + t_applicable_p[i] = false; + t_procedure_p[i] = false; +#if S7_DEBUGGING + t_freeze_p[i] = false; +#endif + } + t_number_p[T_INTEGER] = true; + t_number_p[T_RATIO] = true; + t_number_p[T_REAL] = true; + t_number_p[T_COMPLEX] = true; + t_number_p[T_BIG_INTEGER] = true; + t_number_p[T_BIG_RATIO] = true; + t_number_p[T_BIG_REAL] = true; + t_number_p[T_BIG_COMPLEX] = true; + + t_rational_p[T_INTEGER] = true; + t_rational_p[T_RATIO] = true; + t_rational_p[T_BIG_INTEGER] = true; + t_rational_p[T_BIG_RATIO] = true; + + t_small_real_p[T_INTEGER] = true; + t_small_real_p[T_RATIO] = true; + t_small_real_p[T_REAL] = true; + + t_real_p[T_INTEGER] = true; + t_real_p[T_RATIO] = true; + t_real_p[T_REAL] = true; + t_real_p[T_BIG_INTEGER] = true; + t_real_p[T_BIG_RATIO] = true; + t_real_p[T_BIG_REAL] = true; + + t_big_number_p[T_BIG_INTEGER] = true; + t_big_number_p[T_BIG_RATIO] = true; + t_big_number_p[T_BIG_REAL] = true; + t_big_number_p[T_BIG_COMPLEX] = true; + + t_structure_p[T_PAIR] = true; + t_structure_p[T_VECTOR] = true; + t_structure_p[T_HASH_TABLE] = true; + t_structure_p[T_SLOT] = true; + t_structure_p[T_LET] = true; + t_structure_p[T_ITERATOR] = true; + t_structure_p[T_C_POINTER] = true; + t_structure_p[T_C_OBJECT] = true; + + t_sequence_p[T_NIL] = true; + t_sequence_p[T_PAIR] = true; + t_sequence_p[T_STRING] = true; + t_sequence_p[T_VECTOR] = true; + t_sequence_p[T_INT_VECTOR] = true; + t_sequence_p[T_FLOAT_VECTOR] = true; + t_sequence_p[T_BYTE_VECTOR] = true; + t_sequence_p[T_HASH_TABLE] = true; + t_sequence_p[T_LET] = true; + t_sequence_p[T_C_OBJECT] = true; + + t_mappable_p[T_PAIR] = true; + t_mappable_p[T_STRING] = true; + t_mappable_p[T_VECTOR] = true; + t_mappable_p[T_INT_VECTOR] = true; + t_mappable_p[T_FLOAT_VECTOR] = true; + t_mappable_p[T_BYTE_VECTOR] = true; + t_mappable_p[T_HASH_TABLE] = true; + t_mappable_p[T_LET] = true; + t_mappable_p[T_C_OBJECT] = true; + t_mappable_p[T_ITERATOR] = true; + t_mappable_p[T_C_MACRO] = true; + t_mappable_p[T_MACRO] = true; + t_mappable_p[T_BACRO] = true; + t_mappable_p[T_MACRO_STAR] = true; + t_mappable_p[T_BACRO_STAR] = true; + t_mappable_p[T_CLOSURE] = true; + t_mappable_p[T_CLOSURE_STAR] = true; + + t_vector_p[T_VECTOR] = true; + t_vector_p[T_INT_VECTOR] = true; + t_vector_p[T_FLOAT_VECTOR] = true; + t_vector_p[T_BYTE_VECTOR] = true; + + t_applicable_p[T_PAIR] = true; + t_applicable_p[T_STRING] = true; + t_applicable_p[T_VECTOR] = true; + t_applicable_p[T_INT_VECTOR] = true; + t_applicable_p[T_FLOAT_VECTOR] = true; + t_applicable_p[T_BYTE_VECTOR] = true; + t_applicable_p[T_HASH_TABLE] = true; + t_applicable_p[T_ITERATOR] = true; + t_applicable_p[T_LET] = true; + t_applicable_p[T_C_OBJECT] = true; + t_applicable_p[T_C_MACRO] = true; + t_applicable_p[T_MACRO] = true; + t_applicable_p[T_BACRO] = true; + t_applicable_p[T_MACRO_STAR] = true; + t_applicable_p[T_BACRO_STAR] = true; + t_applicable_p[T_SYNTAX] = true; + t_applicable_p[T_C_FUNCTION] = true; + t_applicable_p[T_C_FUNCTION_STAR] = true; + t_applicable_p[T_C_ANY_ARGS_FUNCTION] = true; + t_applicable_p[T_C_OPT_ARGS_FUNCTION] = true; + t_applicable_p[T_C_RST_ARGS_FUNCTION] = true; + t_applicable_p[T_CLOSURE] = true; + t_applicable_p[T_CLOSURE_STAR] = true; + t_applicable_p[T_GOTO] = true; + t_applicable_p[T_CONTINUATION] = true; + + /* t_procedure_p[T_C_OBJECT] = true; */ + t_procedure_p[T_C_FUNCTION] = true; + t_procedure_p[T_C_FUNCTION_STAR] = true; + t_procedure_p[T_C_ANY_ARGS_FUNCTION] = true; + t_procedure_p[T_C_OPT_ARGS_FUNCTION] = true; + t_procedure_p[T_C_RST_ARGS_FUNCTION] = true; + t_procedure_p[T_CLOSURE] = true; + t_procedure_p[T_CLOSURE_STAR] = true; + t_procedure_p[T_GOTO] = true; + t_procedure_p[T_CONTINUATION] = true; + + t_any_macro_p[T_C_MACRO] = true; + t_any_macro_p[T_MACRO] = true; + t_any_macro_p[T_BACRO] = true; + t_any_macro_p[T_MACRO_STAR] = true; + t_any_macro_p[T_BACRO_STAR] = true; + + t_any_closure_p[T_CLOSURE] = true; + t_any_closure_p[T_CLOSURE_STAR] = true; + + t_has_closure_let[T_MACRO] = true; + t_has_closure_let[T_BACRO] = true; + t_has_closure_let[T_MACRO_STAR] = true; + t_has_closure_let[T_BACRO_STAR] = true; + t_has_closure_let[T_CLOSURE] = true; + t_has_closure_let[T_CLOSURE_STAR] = true; + + t_simple_p[T_NIL] = true; + /* t_simple_p[T_UNDEFINED] = true; *//* only # itself will work with eq? */ + t_simple_p[T_EOF] = true; + t_simple_p[T_BOOLEAN] = true; + t_simple_p[T_CHARACTER] = true; + t_simple_p[T_SYMBOL] = true; + t_simple_p[T_SYNTAX] = true; + t_simple_p[T_C_MACRO] = true; + t_simple_p[T_C_FUNCTION] = true; + t_simple_p[T_C_FUNCTION_STAR] = true; + t_simple_p[T_C_ANY_ARGS_FUNCTION] = true; + t_simple_p[T_C_OPT_ARGS_FUNCTION] = true; + t_simple_p[T_C_RST_ARGS_FUNCTION] = true; + /* not completely sure about the next ones */ + t_simple_p[T_LET] = true; + t_simple_p[T_INPUT_PORT] = true; + t_simple_p[T_OUTPUT_PORT] = true; + +#if S7_DEBUGGING + t_freeze_p[T_STRING] = true; + t_freeze_p[T_BYTE_VECTOR] = true; + t_freeze_p[T_VECTOR] = true; + t_freeze_p[T_FLOAT_VECTOR] = true; + t_freeze_p[T_INT_VECTOR] = true; + t_freeze_p[T_UNDEFINED] = true; + t_freeze_p[T_C_OBJECT] = true; + t_freeze_p[T_HASH_TABLE] = true; + t_freeze_p[T_C_FUNCTION] = true; + t_freeze_p[T_CONTINUATION] = true; + t_freeze_p[T_INPUT_PORT] = true; + t_freeze_p[T_OUTPUT_PORT] = true; +#endif +} + +#if WITH_HISTORY +#define current_code(Sc) car(Sc->cur_code) +#define set_current_code(Sc, Code) do {Sc->cur_code = cdr(Sc->cur_code); set_car(Sc->cur_code, T_Pos(Code));} while (0) +#define replace_current_code(Sc, Code) set_car(Sc->cur_code, T_Pos(Code)) +#define mark_current_code(Sc) do {int32_t i; s7_pointer p; for (p = Sc->cur_code, i = 0; i < Sc->history_size; i++, p = cdr(p)) gc_mark(car(p));} while (0) +#else +#define current_code(Sc) Sc->cur_code +#define set_current_code(Sc, Code) Sc->cur_code = T_Pos(Code) +#define replace_current_code(Sc, Code) Sc->cur_code = T_Pos(Code) +#define mark_current_code(Sc) gc_mark(Sc->cur_code) +#endif + +#define full_type(p) ((p)->tf.flag) +#define typesflag(p) ((p)->tf.sflag) +#define TYPE_MASK 0xff + +#if S7_DEBUGGING +static bool printing_gc_info = false; +static void print_gc_info(s7_scheme * sc, s7_pointer obj, int32_t line); +static s7_pointer check_ref(s7_pointer p, uint8_t expected_type, + const char *func, int32_t line, + const char *func1, const char *func2); +static s7_pointer check_ref7(s7_pointer p, const char *func, int32_t line); +static s7_pointer check_ref11(s7_pointer p, const char *func, + int32_t line); +static s7_pointer check_ref16(s7_pointer p, const char *func, + int32_t line); +static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line); +static s7_pointer check_let_ref(s7_pointer p, uint64_t role, + const char *func, int32_t line); + +#define unchecked_type(p) ((p)->tf.type_field) +#if WITH_GCC +#define type(p) ({uint8_t _t_; _t_ = (p)->tf.type_field; if ((!printing_gc_info) && ((_t_ == T_FREE) || (_t_ >= NUM_TYPES))) print_gc_info(cur_sc, p, __LINE__); _t_;}) +#else +#define type(p) (p)->tf.type_field +#endif +#define set_full_type(p, f) set_type_1(p, f, __func__, __LINE__) + /* these check most s7_cell field references (and many type bits) for consistency */ +#define T_Any(P) check_cell(sc, P, __func__, __LINE__) /* any cell */ +#define T_App(P) check_ref11(P, __func__, __LINE__) /* applicable or #f */ +#define T_Arg(P) check_ref10(P, __func__, __LINE__) /* closure arg (list, symbol) */ +#define T_BVc(P) check_ref(P, T_BYTE_VECTOR, __func__, __LINE__, "sweep", NULL) +#define T_Bgf(P) check_ref(P, T_BIG_RATIO, __func__, __LINE__, "sweep", NULL) +#define T_Bgi(P) check_ref(P, T_BIG_INTEGER, __func__, __LINE__, "sweep", NULL) +#define T_Bgr(P) check_ref(P, T_BIG_REAL, __func__, __LINE__, "sweep", NULL) +#define T_Bgz(P) check_ref(P, T_BIG_COMPLEX, __func__, __LINE__, "sweep", NULL) +#define T_CMac(P) check_ref(P, T_C_MACRO, __func__, __LINE__, NULL, NULL) +#define T_Cat(P) check_ref(P, T_CATCH, __func__, __LINE__, NULL, NULL) +#define T_Chr(P) check_ref(P, T_CHARACTER, __func__, __LINE__, NULL, NULL) +#define T_Clo(P) check_ref5(P, __func__, __LINE__) /* has closure let */ +#define T_Cmp(P) check_ref(P, T_COMPLEX, __func__, __LINE__, NULL, NULL) +#define T_Con(P) check_ref(P, T_CONTINUATION, __func__, __LINE__, "sweep", "process_continuation") +#define T_Ctr(P) check_ref(P, T_COUNTER, __func__, __LINE__, NULL, NULL) +#define T_Dyn(P) check_ref(P, T_DYNAMIC_WIND, __func__, __LINE__, NULL, NULL) +#define T_Eof(P) check_ref(P, T_EOF, __func__, __LINE__, "sweep", NULL) +#define T_Fnc(P) check_ref6(P, __func__, __LINE__) /* any c_function|c_macro */ +#define T_Frc(P) check_ref2(P, T_RATIO, T_INTEGER, __func__, __LINE__, NULL, NULL) +#define T_Fst(P) check_ref(P, T_C_FUNCTION_STAR, __func__, __LINE__, NULL, NULL) +#define T_Fvc(P) check_ref(P, T_FLOAT_VECTOR, __func__, __LINE__, "sweep", NULL) +#define T_Got(P) check_ref(P, T_GOTO, __func__, __LINE__, NULL, NULL) +#define T_Hsh(P) check_ref(P, T_HASH_TABLE, __func__, __LINE__, "sweep", "free_hash_table") +#define T_Int(P) check_ref(P, T_INTEGER, __func__, __LINE__, NULL, NULL) +#define T_Itr(P) check_ref(P, T_ITERATOR, __func__, __LINE__, "sweep", "process_iterator") +#define T_Ivc(P) check_ref(P, T_INT_VECTOR, __func__, __LINE__, "sweep", NULL) +#define T_Let(P) check_ref(P, T_LET, __func__, __LINE__, NULL, NULL) +#define T_Lid(P) check_ref16(P, __func__, __LINE__) /* let/nil */ +#define T_Lst(P) check_ref2(P, T_PAIR, T_NIL, __func__, __LINE__, "gc", NULL) +#define T_Mac(P) check_ref17(P, __func__, __LINE__) /* and non-C macro */ +#define T_Met(P) check_ref9(P, __func__, __LINE__) /* anything that might contain a method */ +#define T_Nmv(P) check_ref15(P, __func__, __LINE__) /* not multiple-value, not free */ +#define T_Num(P) check_ref7(P, __func__, __LINE__) /* any number (not bignums) */ +#define T_Nvc(P) check_ref(P, T_VECTOR, __func__, __LINE__, "sweep", NULL) +#define T_Obj(P) check_ref(P, T_C_OBJECT, __func__, __LINE__, "sweep", "s7_c_object_value") +#define T_Pair(P) check_ref(P, T_PAIR, __func__, __LINE__, NULL, NULL) +#define T_Pcs(P) check_ref2(P, T_PAIR, T_CLOSURE_STAR, __func__, __LINE__, NULL, NULL) +#define T_Pos(P) check_nref(P, __func__, __LINE__) /* not free */ +#define T_Prc(P) check_ref14(P, __func__, __LINE__) /* any procedure or #f (setters) */ +#define T_Prt(P) check_ref3(P, __func__, __LINE__) /* input|output_port */ +#define T_Ptr(P) check_ref(P, T_C_POINTER, __func__, __LINE__, NULL, NULL) +#define T_Ran(P) check_ref(P, T_RANDOM_STATE, __func__, __LINE__, NULL, NULL) +#define T_Rel(P) check_ref(P, T_REAL, __func__, __LINE__, NULL, NULL) +#define T_SVec(P) check_ref13(P, __func__, __LINE__) /* subvector */ +#define T_Seq(P) check_ref8(P, __func__, __LINE__) /* any sequence or structure */ +#define T_Sld(P) check_ref2(P, T_SLOT, T_UNDEFINED,__func__, __LINE__, NULL, NULL) +#define T_Sln(P) check_ref12(P, __func__, __LINE__) /* slot or nil */ +#define T_Slt(P) check_ref(P, T_SLOT, __func__, __LINE__, NULL, NULL) +#define T_Stk(P) check_ref(P, T_STACK, __func__, __LINE__, NULL, NULL) +#define T_Str(P) check_ref(P, T_STRING, __func__, __LINE__, "sweep", NULL) +#define T_Sym(P) check_ref(P, T_SYMBOL, __func__, __LINE__, "sweep", "remove_gensym_from_symbol_table") +#define T_Syn(P) check_ref(P, T_SYNTAX, __func__, __LINE__, NULL, NULL) +#define T_Undf(P) check_ref(P, T_UNDEFINED, __func__, __LINE__, "sweep", NULL) +#define T_Vec(P) check_ref4(P, __func__, __LINE__) /* any vector */ +#else + /* if not debugging, all those checks go away */ +#define T_Any(P) P +#define T_App(P) P +#define T_Arg(P) P +#define T_BVc(P) P +#define T_Bgf(P) P +#define T_Bgi(P) P +#define T_Bgr(P) P +#define T_Bgz(P) P +#define T_CMac(P) P +#define T_Cat(P) P +#define T_Chr(P) P +#define T_Clo(P) P +#define T_Cmp(P) P +#define T_Con(P) P +#define T_Ctr(P) P +#define T_Dyn(P) P +#define T_Eof(P) P +#define T_Fnc(P) P +#define T_Frc(P) P +#define T_Fst(P) P +#define T_Fvc(P) P +#define T_Got(P) P +#define T_Hsh(P) P +#define T_Int(P) P +#define T_Itr(P) P +#define T_Ivc(P) P +#define T_Let(P) P +#define T_Lid(P) P +#define T_Lst(P) P +#define T_Mac(P) P +#define T_Met(P) P +#define T_Nmv(P) P +#define T_Num(P) P +#define T_Nvc(P) P +#define T_Obj(P) P +#define T_Pair(P) P +#define T_Pcs(P) P +#define T_Pos(P) P +#define T_Prc(P) P +#define T_Prt(P) P +#define T_Ptr(P) P +#define T_Ran(P) P +#define T_Rel(P) P +#define T_SVec(P) P +#define T_Seq(P) P +#define T_Sld(P) P +#define T_Sln(P) P +#define T_Slt(P) P +#define T_Stk(P) P +#define T_Str(P) P +#define T_Sym(P) P +#define T_Syn(P) P +#define T_Undf(P) P +#define T_Vec(P) P + +#define unchecked_type(p) ((p)->tf.type_field) +#define type(p) ((p)->tf.type_field) +#define set_full_type(p, f) full_type(p) = f +#endif +#define signed_type(p) (p)->tf.signed_flag + +#define is_number(P) t_number_p[type(P)] +#define is_small_real(P) t_small_real_p[type(P)] +#define is_real(P) t_real_p[type(P)] +#define is_rational(P) t_rational_p[type(P)] +#define is_big_number(p) t_big_number_p[type(p)] +#define is_t_integer(p) (type(p) == T_INTEGER) +#define is_t_ratio(p) (type(p) == T_RATIO) +#define is_t_real(p) (type(p) == T_REAL) +#define is_t_complex(p) (type(p) == T_COMPLEX) +#define is_t_big_integer(p) (type(p) == T_BIG_INTEGER) +#define is_t_big_ratio(p) (type(p) == T_BIG_RATIO) +#define is_t_big_real(p) (type(p) == T_BIG_REAL) +#define is_t_big_complex(p) (type(p) == T_BIG_COMPLEX) + +#define is_free(p) (type(p) == T_FREE) +#define is_free_and_clear(p) (full_type(p) == T_FREE) +#define is_simple(P) t_simple_p[type(P)] /* eq? */ +#define has_structure(P) ((t_structure_p[type(P)]) && ((!is_normal_vector(P)) || (!has_simple_elements(P)))) + +#define is_any_macro(P) t_any_macro_p[type(P)] +#define is_any_closure(P) t_any_closure_p[type(P)] +#define is_any_procedure(P) (type(P) >= T_CLOSURE) +#define has_closure_let(P) t_has_closure_let[type(P)] + +#define is_simple_sequence(P) (t_sequence_p[type(P)]) +#define is_sequence(P) ((t_sequence_p[type(P)]) || (has_methods(P))) +#define is_mutable_sequence(P) (((t_sequence_p[type(P)]) || (has_methods(P))) && (!is_immutable(P))) +#define is_mappable(P) (t_mappable_p[type(P)]) +#define is_applicable(P) (t_applicable_p[type(P)]) +/* this misses #() which is not applicable to anything, and "", and inapplicable c-objects like random-state */ +#define is_procedure(p) ((t_procedure_p[type(p)]) || ((is_c_object(p)) && (is_safe_procedure(p)))) +#define is_t_procedure(p) (t_procedure_p[type(p)]) + +/* the layout of these bits does matter in several cases -- don't shadow SYNTACTIC_PAIR and OPTIMIZED_PAIR */ +#define TYPE_BITS 8 + +#define set_type_bit(p, b) full_type(p) |= (b) +#define clear_type_bit(p, b) full_type(p) &= (~(b)) +#define has_type_bit(p, b) ((full_type(p) & (b)) != 0) + +#define set_type0_bit(p, b) typesflag(p) |= (b) +#define clear_type0_bit(p, b) typesflag(p) &= (~(b)) +#define has_type0_bit(p, b) ((typesflag(p) & (b)) != 0) + +#define set_type1_bit(p, b) (p)->tf.opts.high_flag |= (b) +#define clear_type1_bit(p, b) (p)->tf.opts.high_flag &= (~(b)) +#define has_type1_bit(p, b) (((p)->tf.opts.high_flag & (b)) != 0) + +#define T_SYNTACTIC (1 << (TYPE_BITS + 1)) +#define is_symbol_and_syntactic(p) (typesflag(T_Pos(p)) == (uint16_t)(T_SYMBOL | T_SYNTACTIC)) +#define is_syntactic_symbol(p) has_type0_bit(T_Sym(p), T_SYNTACTIC) +#define is_syntactic_pair(p) has_type0_bit(T_Pair(p), T_SYNTACTIC) +#define clear_syntactic(p) clear_type0_bit(T_Pair(p), T_SYNTACTIC) +#define set_syntactic_pair(p) full_type(T_Pair(p)) = (T_PAIR | T_SYNTACTIC | (full_type(p) & (0xffffffffffff0000 & ~T_OPTIMIZED))) /* used only in pair_set_syntax_op */ +/* this marks symbols that represent syntax objects, it should be in the second byte */ + +#define T_SIMPLE_ARG_DEFAULTS (1 << (TYPE_BITS + 2)) +#define lambda_has_simple_defaults(p) has_type_bit(T_Pair(closure_body(p)), T_SIMPLE_ARG_DEFAULTS) +#define lambda_set_simple_defaults(p) set_type_bit(T_Pair(p), T_SIMPLE_ARG_DEFAULTS) +/* are all lambda* default values simple? This is set on closure_body, so it doesn't mess up closure_is_ok_1 */ + +#define T_LIST_IN_USE T_SIMPLE_ARG_DEFAULTS +#define list_is_in_use(p) has_type0_bit(T_Pair(p), T_LIST_IN_USE) +#define set_list_in_use(p) set_type_bit(T_Pair(p), T_LIST_IN_USE) +#define clear_list_in_use(p) do {clear_type_bit(T_Pair(p), T_LIST_IN_USE); sc->current_safe_list = 0;} while (0) +/* since the safe lists are not in the heap, if the list_in_use bit is off, the list won't ne GC-protected even if + * it is gc_marked explicitly. This happens, for example, in copy_proper_list where we try to protect the original list + * by sc->u = lst; then in the GC, gc_mark(sc->u); but the safe_list probably is already marked, so its contents are not protected. + */ +/* if (!is_immutable(p)) free_vlist(sc, p) seems plausible here, but it got no hits in s7test and other cases */ + +#define T_ONE_FORM T_SIMPLE_ARG_DEFAULTS +#define set_closure_has_one_form(p) set_type_bit(T_Clo(p), T_ONE_FORM) +#define T_MULTIFORM (1 << (TYPE_BITS + 0)) +#define set_closure_has_multiform(p) set_type_bit(T_Clo(p), T_MULTIFORM) +#define T_ONE_FORM_FX_ARG (T_ONE_FORM | T_MULTIFORM) +#define set_closure_one_form_fx_arg(p) set_type_bit(T_Clo(p), T_ONE_FORM_FX_ARG) +/* can't use T_HAS_FX here because closure_is_ok wants to examine typesflag */ + +#define T_OPTIMIZED (1 << (TYPE_BITS + 3)) +#define set_optimized(p) set_type0_bit(T_Pair(p), T_OPTIMIZED) +#define clear_optimized(p) clear_type0_bit(T_Pair(p), T_OPTIMIZED | T_SYNTACTIC | T_HAS_FX | T_HAS_FN) +#define OPTIMIZED_PAIR (uint16_t)(T_PAIR | T_OPTIMIZED) +#define is_optimized(p) (typesflag(T_Pos(p)) == OPTIMIZED_PAIR) +/* optimizer flag for an expression that has optimization info, it should be in the second byte */ + +#define T_SCOPE_SAFE T_OPTIMIZED +#define is_scope_safe(p) has_type_bit(T_Fnc(p), T_SCOPE_SAFE) +#define set_scope_safe(p) set_type_bit(T_Fnc(p), T_SCOPE_SAFE) + +#define T_SAFE_CLOSURE (1 << (TYPE_BITS + 4)) +#define is_safe_closure(p) has_type0_bit(T_Clo(p), T_SAFE_CLOSURE) +#define set_safe_closure(p) set_type0_bit(T_Clo(p), T_SAFE_CLOSURE) +#define is_safe_closure_body(p) has_type0_bit(T_Pair(p), T_SAFE_CLOSURE) +#define set_safe_closure_body(p) set_type0_bit(T_Pair(p), T_SAFE_CLOSURE) +#define clear_safe_closure_body(p) clear_type0_bit(T_Pair(p), T_SAFE_CLOSURE) + +/* optimizer flag for a closure body that is completely simple (every expression is safe) + * set_safe_closure happens only in define_funchcecked, clear only in procedure_source, bits only here + * this has to be separate from T_SAFE_PROCEDURE, and should be in the second byte (closure_is_ok_1 checks typesflag). + * define -> optimize_lambda sets safe -> define_funchecked -> make_funclet for the let + * similarly, named let -> optimize_lambda, then let creates the let if safe + * thereafter, optimizer uses OP_SAFE_CLOSURE* which calls update_let* + */ + +#define T_DONT_EVAL_ARGS (1 << (TYPE_BITS + 5)) +#define dont_eval_args(p) has_type0_bit(T_Pos(p), T_DONT_EVAL_ARGS) +/* this marks things that don't evaluate their arguments */ + +#define T_EXPANSION (1 << (TYPE_BITS + 6)) +#define is_expansion(p) has_type0_bit(T_Any(p), T_EXPANSION) +#define clear_expansion(p) clear_type0_bit(T_Sym(p), T_EXPANSION) +/* this marks the symbol and its run-time macro value, distinguishing it from an ordinary macro */ + +#define T_MULTIPLE_VALUE (1 << (TYPE_BITS + 7)) +#define is_multiple_value(p) has_type0_bit(T_Pos(p), T_MULTIPLE_VALUE) +#if S7_DEBUGGING +#define set_multiple_value(p) do {if (!in_heap(p)) {fprintf(stderr, "%s[%d]: mv\n", __func__, __LINE__); abort();} set_type0_bit(T_Pair(p), T_MULTIPLE_VALUE);} while (0) +#else +#define set_multiple_value(p) set_type0_bit(T_Pair(p), T_MULTIPLE_VALUE) +#endif +#define clear_multiple_value(p) clear_type0_bit(T_Pair(p), T_MULTIPLE_VALUE) +#define multiple_value(p) p +/* this bit marks a list (from "values") that is waiting for a chance to be spliced into its caller's argument list */ + +#define T_MATCHED T_MULTIPLE_VALUE +#define is_matched_pair(p) has_type0_bit(T_Pair(p), T_MATCHED) +#define clear_match_pair(p) clear_type0_bit(T_Pair(p), T_MATCHED) +#define set_match_pair(p) set_type0_bit(T_Pair(p), T_MATCHED) +#define set_match_symbol(p) set_type0_bit(T_Sym(p), T_MATCHED) +#define is_matched_symbol(p) has_type0_bit(T_Sym(p), T_MATCHED) +#define clear_match_symbol(p) clear_type0_bit(T_Sym(p), T_MATCHED) + +#define T_GLOBAL (1 << (TYPE_BITS + 8)) +#define T_LOCAL (1 << (TYPE_BITS + 12)) +#define is_global(p) has_type_bit(T_Sym(p), T_GLOBAL) +#define set_global(p) do {if ((full_type(T_Sym(p)) & T_LOCAL) == 0) full_type(p) |= T_GLOBAL;} while (0) +/* T_LOCAL marks a symbol that has been used locally */ +/* T_GLOBAL marks something defined (bound) at the top-level, and never defined locally */ + +#define REPORT_ROOTLET_REDEF 0 +#if REPORT_ROOTLET_REDEF + /* to find who is stomping on our symbols: */ +static void set_local_1(s7_scheme * sc, s7_pointer symbol, + const char *func, int32_t line); +#define set_local(Symbol) set_local_1(sc, Symbol, __func__, __LINE__) +#else +#define set_local(p) full_type(T_Sym(p)) = ((full_type(p) | T_LOCAL) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC)) +#endif + +#define T_HIGH_C T_LOCAL +#define has_high_c(p) has_type_bit(T_Pair(p), T_HIGH_C) +#define set_has_high_c(p) set_type_bit(T_Pair(p), T_HIGH_C) + +#define T_TC T_LOCAL +#define has_tc(p) has_type_bit(T_Pair(p), T_TC) +#define set_has_tc(p) set_type_bit(T_Pair(p), T_TC) + +#define T_UNSAFE_DO T_GLOBAL +#define is_unsafe_do(p) has_type_bit(T_Pair(p), T_UNSAFE_DO) +#define set_unsafe_do(p) set_type_bit(T_Pair(p), T_UNSAFE_DO) +/* marks do-loops that resist optimization */ + +#define T_DOX_SLOT1 T_GLOBAL +#define has_dox_slot1(p) has_type_bit(T_Let(p), T_DOX_SLOT1) +#define set_has_dox_slot1(p) set_type_bit(T_Let(p), T_DOX_SLOT1) +/* marks a let that includes the dox_slot1 */ + +#define T_COLLECTED (1 << (TYPE_BITS + 9)) +#define is_collected(p) has_type_bit(T_Seq(p), T_COLLECTED) +#define is_collected_unchecked(p) has_type_bit(p, T_COLLECTED) +#define set_collected(p) set_type_bit(T_Seq(p), T_COLLECTED) +/* #define clear_collected(p) clear_type_bit(T_Seq(p), T_COLLECTED) */ +/* this is a transient flag used by the printer to catch cycles. It affects only objects that have structure. + * We can't use a low bit (bit 7 for example), because collect_shared_info inspects the object's type. + */ + +#define T_LOCATION (1 << (TYPE_BITS + 10)) +#define has_location(p) has_type_bit(T_Pair(p), T_LOCATION) +#define set_has_location(p) set_type_bit(T_Pair(p), T_LOCATION) +/* pair in question has line/file/position info added during read, or the environment has function placement info + * this bit should not be in the first byte -- SYNTACTIC_PAIR ignores it. + */ + +#define T_LOADER_PORT T_LOCATION +#define is_loader_port(p) has_type_bit(T_Prt(p), T_LOADER_PORT) +#define set_loader_port(p) set_type_bit(T_Prt(p), T_LOADER_PORT) +#define clear_loader_port(p) clear_type_bit(T_Prt(p), T_LOADER_PORT) +/* to block random load-time reads from screwing up the load process, this bit marks a port used by the loader */ + +#define T_HAS_SETTER T_LOCATION +#define symbol_has_setter(p) has_type_bit(T_Sym(p), T_HAS_SETTER) +#define symbol_set_has_setter(p) set_type_bit(T_Sym(p), T_HAS_SETTER) +#define slot_has_setter(p) has_type_bit(T_Slt(p), T_HAS_SETTER) +#define slot_set_has_setter(p) set_type_bit(T_Slt(p), T_HAS_SETTER) +/* marks a slot that has a setter or symbol that might have a setter */ + +#define T_WITH_LET_LET T_LOCATION +#define is_with_let_let(p) has_type_bit(T_Let(p), T_WITH_LET_LET) +#define set_with_let_let(p) set_type_bit(T_Let(p), T_WITH_LET_LET) +/* marks a let that is the argument to with-let */ + +#define T_SIMPLE_DEFAULTS T_LOCATION +#define c_func_has_simple_defaults(p) has_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS) +#define c_func_set_simple_defaults(p) set_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS) +#define c_func_clear_simple_defaults(p) clear_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS) +/* flag c_func_star arg defaults that need GC protection */ + +#define T_NO_SETTER T_LOCATION +#define closure_no_setter(p) has_type_bit(T_Clo(p), T_NO_SETTER) +#define closure_set_no_setter(p) set_type_bit(T_Clo(p), T_NO_SETTER) + +#define T_SHARED (1 << (TYPE_BITS + 11)) +#define is_shared(p) has_type_bit(T_Seq(p), T_SHARED) +#define set_shared(p) set_type_bit(T_Seq(p), T_SHARED) +#define is_collected_or_shared(p) has_type_bit(p, T_COLLECTED | T_SHARED) +#define clear_collected_and_shared(p) clear_type_bit(p, T_COLLECTED | T_SHARED) /* this can clear free cells = calloc */ +/* T_LOCAL is bit 12 */ + +#define T_SAFE_PROCEDURE (1 << (TYPE_BITS + 13)) +#define is_safe_procedure(p) has_type_bit(T_App(p), T_SAFE_PROCEDURE) /* was T_Pos 19-Apr-21 */ +#define is_safe_or_scope_safe_procedure(p) ((full_type(T_Fnc(p)) & (T_SCOPE_SAFE | T_SAFE_PROCEDURE)) != 0) +/* applicable objects that do not return or modify their arg list directly (no :rest arg in particular), + * and that can't call themselves either directly or via s7_call, and that don't mess with the stack. + */ + +#define T_CHECKED (1 << (TYPE_BITS + 14)) +#define set_checked(p) set_type_bit(T_Pair(p), T_CHECKED) +#define is_checked(p) has_type_bit(T_Pair(p), T_CHECKED) +#define clear_checked(p) clear_type_bit(T_Pair(p), T_CHECKED) +#define set_checked_slot(p) set_type_bit(T_Slt(p), T_CHECKED) +#define is_checked_slot(p) has_type_bit(T_Slt(p), T_CHECKED) +#define clear_checked_slot(p) clear_type_bit(T_Slt(p), T_CHECKED) + +#define T_ALL_INTEGER T_CHECKED +#define is_all_integer(p) has_type_bit(T_Sym(p), T_ALL_INTEGER) +#define set_all_integer(p) set_type_bit(T_Sym(p), T_ALL_INTEGER) + +#define T_UNSAFE (1 << (TYPE_BITS + 15)) +#define set_unsafe(p) set_type_bit(T_Pair(p), T_UNSAFE) +#define set_unsafely_optimized(p) full_type(T_Pair(p)) = (full_type(p) | T_UNSAFE | T_OPTIMIZED) +#define is_unsafe(p) has_type_bit(T_Pair(p), T_UNSAFE) +#define clear_unsafe(p) clear_type_bit(T_Pair(p), T_UNSAFE) +#define is_safely_optimized(p) ((full_type(T_Pair(p)) & (T_OPTIMIZED | T_UNSAFE)) == T_OPTIMIZED) /* was T_Pos 30-Jan-21 */ +/* optimizer flag saying "this expression is not completely self-contained. It might involve the stack, etc" */ + +#define T_CLEAN_SYMBOL T_UNSAFE +#define is_clean_symbol(p) has_type_bit(T_Sym(p), T_CLEAN_SYMBOL) +#define set_clean_symbol(p) set_type_bit(T_Sym(p), T_CLEAN_SYMBOL) +/* set if we know the symbol name can be printed without quotes (slashification) */ + +#define T_HAS_STEPPER T_UNSAFE +#define has_stepper(p) has_type_bit(T_Slt(p), T_HAS_STEPPER) +#define set_has_stepper(p) set_type_bit(T_Slt(p), T_HAS_STEPPER) + +#define T_DOX_SLOT2 T_UNSAFE +#define has_dox_slot2(p) has_type_bit(T_Let(p), T_DOX_SLOT2) +#define set_has_dox_slot2(p) set_type_bit(T_Let(p), T_DOX_SLOT2) +/* marks a let that includes the dox_slot2 */ + +#define T_IMMUTABLE (1 << (TYPE_BITS + 16)) +#define is_immutable(p) has_type_bit(T_Pos(p), T_IMMUTABLE) +#define set_immutable(p) set_type_bit(T_Pos(p), T_IMMUTABLE) +#define set_immutable_let(p) set_type_bit(T_Lid(p), T_IMMUTABLE) +#define is_immutable_port(p) has_type_bit(T_Prt(p), T_IMMUTABLE) +#define is_immutable_symbol(p) has_type_bit(T_Sym(p), T_IMMUTABLE) +#define is_immutable_slot(p) has_type_bit(T_Slt(p), T_IMMUTABLE) +#define is_immutable_pair(p) has_type_bit(T_Pair(p), T_IMMUTABLE) +#define is_immutable_vector(p) has_type_bit(T_Vec(p), T_IMMUTABLE) +#define is_immutable_string(p) has_type_bit(T_Str(p), T_IMMUTABLE) +/* T_IMMUTABLE is compatible with T_MUTABLE -- the latter is an internal bit for locally mutable numbers */ + +#define T_SETTER (1 << (TYPE_BITS + 17)) +#define set_is_setter(p) set_type_bit(T_Sym(p), T_SETTER) +#define is_setter(p) has_type_bit(T_Sym(p), T_SETTER) +/* optimizer flag for a procedure that sets some variable (set-car! for example). */ + +#define T_ALLOW_OTHER_KEYS T_SETTER +#define set_allow_other_keys(p) set_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS) +#define allows_other_keys(p) has_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS) +#define c_function_set_allow_other_keys(p) set_type_bit(T_Fst(p), T_ALLOW_OTHER_KEYS) +#define c_function_allows_other_keys(p) has_type_bit(T_Fst(p), T_ALLOW_OTHER_KEYS) +/* marks arglist (or c_function*) that allows keyword args other than those in the parameter list; + * we can't allow (define* (f :allow-other-keys)...) because there's only one nil, and besides, it does say "other". + */ + +#define T_LET_REMOVED T_SETTER +#define let_set_removed(p) set_type_bit(T_Let(p), T_LET_REMOVED) +#define let_removed(p) has_type_bit(T_Let(p), T_LET_REMOVED) +/* mark lets that have been removed from the heap or checked for that possibility */ + +#define T_HAS_EXPRESSION T_SETTER +#define slot_set_has_expression(p) set_type_bit(T_Slt(p), T_HAS_EXPRESSION) +#define slot_has_expression(p) has_type_bit(T_Slt(p), T_HAS_EXPRESSION) + +#define T_MUTABLE (1 << (TYPE_BITS + 18)) +#define is_mutable_number(p) has_type_bit(T_Num(p), T_MUTABLE) +#define is_mutable_integer(p) has_type_bit(T_Int(p), T_MUTABLE) +#define clear_mutable_number(p) clear_type_bit(T_Num(p), T_MUTABLE) +#define clear_mutable_integer(p) clear_type_bit(T_Int(p), T_MUTABLE) +/* used for mutable numbers, can occur with T_IMMUTABLE (outside view vs inside) */ + +#define T_HAS_KEYWORD T_MUTABLE +#define has_keyword(p) has_type_bit(T_Sym(p), T_HAS_KEYWORD) +#define set_has_keyword(p) set_type_bit(T_Sym(p), T_HAS_KEYWORD) + +#define T_MARK_SEQ T_MUTABLE +#define is_mark_seq(p) has_type_bit(T_Itr(p), T_MARK_SEQ) +#define set_mark_seq(p) set_type_bit(T_Itr(p), T_MARK_SEQ) +/* used in iterators for GC mark of sequence */ + +#define T_STEP_END T_MUTABLE +#define is_step_end(p) has_type_bit(T_Slt(p), T_STEP_END) +#define step_end_fits(Slot, Len) ((is_step_end(Slot)) && (denominator(slot_value(Slot)) <= Len)) +#define set_step_end(p) set_type_bit(T_Slt(p), T_STEP_END) +/* marks a slot that holds a do-loop's step-or-end variable, numerator=current, denominator=end */ + +#define T_NO_CELL_OPT T_MUTABLE +#define set_no_cell_opt(p) set_type_bit(T_Pair(p), T_NO_CELL_OPT) +#define no_cell_opt(p) has_type_bit(T_Pair(p), T_NO_CELL_OPT) + +#define T_NO_INT_OPT T_SETTER +#define set_no_int_opt(p) set_type_bit(T_Pair(p), T_NO_INT_OPT) +#define no_int_opt(p) has_type_bit(T_Pair(p), T_NO_INT_OPT) + +#define T_NO_FLOAT_OPT T_UNSAFE +#define set_no_float_opt(p) set_type_bit(T_Pair(p), T_NO_FLOAT_OPT) +#define no_float_opt(p) has_type_bit(T_Pair(p), T_NO_FLOAT_OPT) + +#define T_NO_BOOL_OPT T_SAFE_STEPPER +#define set_no_bool_opt(p) set_type_bit(T_Pair(p), T_NO_BOOL_OPT) +#define no_bool_opt(p) has_type_bit(T_Pair(p), T_NO_BOOL_OPT) + +#define T_INTEGER_KEYS T_SETTER +#define set_has_integer_keys(p) set_type_bit(T_Pair(p), T_INTEGER_KEYS) +#define has_integer_keys(p) has_type_bit(T_Pair(p), T_INTEGER_KEYS) + +#define T_SAFE_STEPPER (1 << (TYPE_BITS + 19)) +#define is_safe_stepper(p) has_type_bit(T_Slt(p), T_SAFE_STEPPER) +#define set_safe_stepper(p) set_type_bit(T_Slt(p), T_SAFE_STEPPER) +#define clear_safe_stepper(p) clear_type_bit(T_Slt(p), T_SAFE_STEPPER) +#define is_safe_stepper_expr(p) has_type_bit(T_Pair(p), T_SAFE_STEPPER) +#define set_safe_stepper_expr(p) set_type_bit(T_Pair(p), T_SAFE_STEPPER) + +#define T_NUMBER_NAME T_SAFE_STEPPER +#define has_number_name(p) has_type_bit(T_Num(p), T_NUMBER_NAME) +#define set_has_number_name(p) set_type_bit(T_Num(p), T_NUMBER_NAME) +/* marks numbers that have a saved version of their string representation; this only matters in teq.scm, maybe tread.scm */ + +#define T_MAYBE_SAFE T_SAFE_STEPPER +#define is_maybe_safe(p) has_type_bit(T_Fnc(p), T_MAYBE_SAFE) +#define set_maybe_safe(p) set_type_bit(T_Fnc(p), T_MAYBE_SAFE) + +#define T_PAIR_MACRO T_SAFE_STEPPER +#define has_pair_macro(p) has_type_bit(T_Mac(p), T_PAIR_MACRO) +#define set_has_pair_macro(p) set_type_bit(T_Mac(p), T_PAIR_MACRO) + +#define T_HAS_LET_SET_FALLBACK T_SAFE_STEPPER +#define T_HAS_LET_REF_FALLBACK T_MUTABLE +#define has_let_ref_fallback(p) ((full_type(T_Lid(p)) & (T_HAS_LET_REF_FALLBACK | T_HAS_METHODS)) == (T_HAS_LET_REF_FALLBACK | T_HAS_METHODS)) +#define has_let_set_fallback(p) ((full_type(T_Lid(p)) & (T_HAS_LET_SET_FALLBACK | T_HAS_METHODS)) == (T_HAS_LET_SET_FALLBACK | T_HAS_METHODS)) +#define set_has_let_ref_fallback(p) set_type_bit(T_Let(p), T_HAS_LET_REF_FALLBACK) +#define set_has_let_set_fallback(p) set_type_bit(T_Let(p), T_HAS_LET_SET_FALLBACK) +#define has_let_fallback(p) has_type_bit(T_Lid(p), (T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK)) +#define set_all_methods(p, e) full_type(T_Let(p)) |= (full_type(e) & (T_HAS_METHODS | T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK)) + +#define T_WEAK_HASH T_SAFE_STEPPER +#define set_weak_hash_table(p) set_type_bit(T_Hsh(p), T_WEAK_HASH) +#define is_weak_hash_table(p) has_type_bit(T_Hsh(p), T_WEAK_HASH) + +#define T_ALL_FLOAT T_SAFE_STEPPER +#define is_all_float(p) has_type_bit(T_Sym(p), T_ALL_FLOAT) +#define set_all_float(p) set_type_bit(T_Sym(p), T_ALL_FLOAT) +#define set_all_integer_and_float(p) set_type_bit(T_Sym(p), (T_ALL_INTEGER | T_ALL_FLOAT)) + +#define T_COPY_ARGS (1 << (TYPE_BITS + 20)) +#define needs_copied_args(p) has_type_bit(T_Pos(p), T_COPY_ARGS) /* set via explicit T_COPY_ARGS, on T_Pos see s7_apply_function */ +#define set_needs_copied_args(p) set_type_bit(T_Pair(p), T_COPY_ARGS) +#define clear_needs_copied_args(p) clear_type_bit(T_Pair(p), T_COPY_ARGS) +/* this marks something that might mess with its argument list, it should not be in the second byte */ + +#define T_GENSYM (1 << (TYPE_BITS + 21)) +#define is_gensym(p) has_type_bit(T_Sym(p), T_GENSYM) +/* symbol is from gensym (GC-able etc) */ + +#define T_FUNCLET T_GENSYM +#define is_funclet(p) has_type_bit(T_Let(p), T_FUNCLET) +#define set_funclet(p) set_type_bit(T_Let(p), T_FUNCLET) +/* this marks a funclet */ + +#define T_HASH_CHOSEN T_GENSYM +#define hash_chosen(p) has_type_bit(T_Hsh(p), T_HASH_CHOSEN) +#define hash_set_chosen(p) set_type_bit(T_Hsh(p), T_HASH_CHOSEN) +#define hash_clear_chosen(p) clear_type_bit(T_Hsh(p), T_HASH_CHOSEN) + +#define T_DOCUMENTED T_GENSYM +#define is_documented(p) has_type_bit(T_Str(p), T_DOCUMENTED) +#define set_documented(p) set_type_bit(T_Str(p), T_DOCUMENTED) +/* this marks a symbol that has documentation (bit is set on name cell) */ + +#define T_FX_TREED T_GENSYM +#define is_fx_treed(p) has_type_bit(T_Pair(p), T_FX_TREED) +#define set_fx_treed(p) set_type_bit(T_Pair(p), T_FX_TREED) + +#define T_SUBVECTOR T_GENSYM +#define is_subvector(p) has_type_bit(T_Vec(p), T_SUBVECTOR) + +#define T_HAS_PENDING_VALUE T_GENSYM +#define slot_set_has_pending_value(p) set_type_bit(T_Slt(p), T_HAS_PENDING_VALUE) +#define slot_has_pending_value(p) has_type_bit(T_Slt(p), T_HAS_PENDING_VALUE) +#define slot_clear_has_pending_value(p) clear_type_bit(T_Slt(p), T_HAS_PENDING_VALUE) + +#define T_HAS_METHODS (1 << (TYPE_BITS + 22)) +#define has_methods(p) has_type_bit(T_Pos(p), T_HAS_METHODS) +#define has_active_methods(sc, p) ((has_type_bit(T_Pos(p), T_HAS_METHODS)) && (sc->has_openlets)) /* g_char # */ +#define set_has_methods(p) set_type_bit(T_Met(p), T_HAS_METHODS) +#define clear_has_methods(p) clear_type_bit(T_Met(p), T_HAS_METHODS) +/* this marks an environment or closure that is "open" for generic functions etc, don't reuse this bit */ + +#define T_ITER_OK (1LL << (TYPE_BITS + 23)) +#define iter_ok(p) has_type_bit(T_Itr(p), T_ITER_OK) /* was T_Pos 15-Apr-21 */ +#define clear_iter_ok(p) clear_type_bit(T_Itr(p), T_ITER_OK) + +#define T_STEP_END_OK T_ITER_OK +#define step_end_ok(p) has_type_bit(T_Pair(p), T_STEP_END_OK) +#define set_step_end_ok(p) set_type_bit(T_Pair(p), T_STEP_END_OK) + +#define T_IMPLICIT_SET_OK T_ITER_OK +#define implicit_set_ok(p) has_type_bit(T_Pair(p), T_IMPLICIT_SET_OK) +#define set_implicit_set_ok(p) set_type_bit(T_Pair(p), T_IMPLICIT_SET_OK) + +#define T_IN_ROOTLET T_ITER_OK +#define in_rootlet(p) has_type_bit(T_Slt(p), T_IN_ROOTLET) +#define set_in_rootlet(p) set_type_bit(T_Slt(p), T_IN_ROOTLET) + +#define T_BOOL_FUNCTION T_ITER_OK +#define is_bool_function(p) has_type_bit(T_Prc(p), T_BOOL_FUNCTION) +#define set_is_bool_function(p) set_type_bit(T_Fnc(p), T_BOOL_FUNCTION) + +/* it's faster here to use the high_flag bits rather than typeflag bits */ +#define BIT_ROOM 16 +#define T_FULL_SYMCONS (1LL << (TYPE_BITS + BIT_ROOM + 24)) +#define T_SYMCONS (1 << 0) +#define is_possibly_constant(p) has_type1_bit(T_Sym(p), T_SYMCONS) +#define set_possibly_constant(p) set_type1_bit(T_Sym(p), T_SYMCONS) +#define is_probably_constant(p) has_type_bit(T_Sym(p), (T_FULL_SYMCONS | T_IMMUTABLE)) + +#define T_HAS_LET_ARG T_SYMCONS +#define has_let_arg(p) has_type1_bit(T_Prc(p), T_HAS_LET_ARG) +#define set_has_let_arg(p) set_type1_bit(T_Prc(p), T_HAS_LET_ARG) +/* p is a setter procedure, "let arg" refers to the setter's optional third (let) argument */ + +#define T_HASH_VALUE_TYPE T_SYMCONS +#define has_hash_value_type(p) has_type1_bit(T_Hsh(p), T_HASH_VALUE_TYPE) +#define set_has_hash_value_type(p) set_type1_bit(T_Hsh(p), T_HASH_VALUE_TYPE) + +#define T_INT_OPTABLE T_SYMCONS +#define is_int_optable(p) has_type1_bit(T_Pair(p), T_INT_OPTABLE) +#define set_is_int_optable(p) set_type1_bit(T_Pair(p), T_INT_OPTABLE) + +/* symbol free here */ +#define T_FULL_HAS_LET_FILE (1LL << (TYPE_BITS + BIT_ROOM + 25)) +#define T_HAS_LET_FILE (1 << 1) +#define has_let_file(p) has_type1_bit(T_Let(p), T_HAS_LET_FILE) +#define set_has_let_file(p) set_type1_bit(T_Let(p), T_HAS_LET_FILE) +#define clear_has_let_file(p) clear_type1_bit(T_Let(p), T_HAS_LET_FILE) + +#define T_TYPED_VECTOR T_HAS_LET_FILE +#define is_typed_vector(p) has_type1_bit(T_Vec(p), T_TYPED_VECTOR) +#define set_typed_vector(p) set_type1_bit(T_Vec(p), T_TYPED_VECTOR) + +#define T_TYPED_HASH_TABLE T_HAS_LET_FILE +#define is_typed_hash_table(p) has_type1_bit(T_Hsh(p), T_TYPED_HASH_TABLE) +#define set_typed_hash_table(p) set_type1_bit(T_Hsh(p), T_TYPED_HASH_TABLE) + +#define T_BOOL_SETTER T_HAS_LET_FILE +#define c_function_has_bool_setter(p) has_type1_bit(T_Fnc(p), T_BOOL_SETTER) +#define c_function_set_has_bool_setter(p) set_type1_bit(T_Fnc(p), T_BOOL_SETTER) + +#define T_REST_SLOT T_HAS_LET_FILE +#define is_rest_slot(p) has_type1_bit(T_Slt(p), T_REST_SLOT) +#define set_is_rest_slot(p) set_type1_bit(T_Slt(p), T_REST_SLOT) + +#define T_NO_DEFAULTS T_HAS_LET_FILE +#define T_FULL_NO_DEFAULTS T_FULL_HAS_LET_FILE +#define has_no_defaults(p) has_type1_bit(T_Pcs(p), T_NO_DEFAULTS) +#define set_has_no_defaults(p) set_type1_bit(T_Pcs(p), T_NO_DEFAULTS) +/* pair=closure* body, transferred to closure* */ + +#define T_FULL_DEFINER (1LL << (TYPE_BITS + BIT_ROOM + 26)) +#define T_DEFINER (1 << 2) +#define is_definer(p) has_type1_bit(T_Sym(p), T_DEFINER) +#define set_is_definer(p) set_type1_bit(T_Sym(p), T_DEFINER) +#define is_func_definer(p) has_type1_bit(T_Fnc(p), T_DEFINER) +#define set_func_is_definer(p) do {set_type1_bit(T_Fnc(initial_value(p)), T_DEFINER); set_type1_bit(T_Sym(p), T_DEFINER);} while (0) +#define is_syntax_definer(p) has_type1_bit(T_Syn(p), T_DEFINER) +#define set_syntax_is_definer(p) do {set_type1_bit(T_Syn(initial_value(p)), T_DEFINER); set_type1_bit(T_Sym(p), T_DEFINER);} while (0) +/* this marks "definers" like define and define-macro */ + +#define T_MACLET T_DEFINER +#define is_maclet(p) has_type1_bit(T_Let(p), T_MACLET) +#define set_maclet(p) set_type1_bit(T_Let(p), T_MACLET) +/* this marks a maclet */ + +#define T_HAS_FX T_DEFINER +#define set_has_fx(p) set_type1_bit(T_Pair(p), T_HAS_FX) +#define has_fx(p) has_type1_bit(T_Pair(p), T_HAS_FX) +#define clear_has_fx(p) clear_type1_bit(T_Pair(p), T_HAS_FX) + +#define T_SLOT_DEFAULTS T_DEFINER +#define slot_defaults(p) has_type1_bit(T_Slt(p), T_SLOT_DEFAULTS) +#define set_slot_defaults(p) set_type1_bit(T_Slt(p), T_SLOT_DEFAULTS) + +#define T_WEAK_HASH_ITERATOR T_DEFINER +#define is_weak_hash_iterator(p) has_type1_bit(T_Itr(p), T_WEAK_HASH_ITERATOR) +#define set_weak_hash_iterator(p) set_type1_bit(T_Itr(p), T_WEAK_HASH_ITERATOR) +#define clear_weak_hash_iterator(p) clear_type1_bit(T_Itr(p), T_WEAK_HASH_ITERATOR) + +#define T_HASH_KEY_TYPE T_DEFINER +#define has_hash_key_type(p) has_type1_bit(T_Hsh(p), T_HASH_KEY_TYPE) +#define set_has_hash_key_type(p) set_type1_bit(T_Hsh(p), T_HASH_KEY_TYPE) + +#define T_FULL_BINDER (1LL << (TYPE_BITS + BIT_ROOM + 27)) +#define T_BINDER (1 << 3) +#define set_syntax_is_binder(p) do {set_type1_bit(T_Syn(initial_value(p)), T_BINDER); set_type1_bit(T_Sym(p), T_BINDER);} while (0) +#define is_definer_or_binder(p) has_type1_bit(T_Sym(p), T_DEFINER | T_BINDER) +/* this marks "binders" like let */ + +#define T_SEMISAFE T_BINDER +#define is_semisafe(p) has_type1_bit(T_Fnc(p), T_SEMISAFE) +#define set_is_semisafe(p) set_type1_bit(T_Fnc(p), T_SEMISAFE) + +/* #define T_TREE_COLLECTED T_FULL_BINDER */ +#define T_SHORT_TREE_COLLECTED T_BINDER +#define tree_is_collected(p) has_type1_bit(T_Pair(p), T_SHORT_TREE_COLLECTED) +#define tree_set_collected(p) set_type1_bit(T_Pair(p), T_SHORT_TREE_COLLECTED) +#define tree_clear_collected(p) clear_type1_bit(T_Pair(p), T_SHORT_TREE_COLLECTED) + +#define T_SIMPLE_VALUES T_BINDER +#define has_simple_values(p) has_type1_bit(T_Hsh(p), T_SIMPLE_VALUES) +#define set_has_simple_values(p) set_type1_bit(T_Hsh(p), T_SIMPLE_VALUES) + +#define T_VERY_SAFE_CLOSURE (1LL << (TYPE_BITS + BIT_ROOM + 28)) +#define T_SHORT_VERY_SAFE_CLOSURE (1 << 4) +#define is_very_safe_closure(p) has_type1_bit(T_Clo(p), T_SHORT_VERY_SAFE_CLOSURE) +#define set_very_safe_closure(p) set_type1_bit(T_Clo(p), T_SHORT_VERY_SAFE_CLOSURE) +#define closure_bits(p) (full_type(T_Pair(p)) & (T_SAFE_CLOSURE | T_VERY_SAFE_CLOSURE | T_FULL_NO_DEFAULTS)) +#define is_very_safe_closure_body(p) has_type1_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE) +#define set_very_safe_closure_body(p) set_type1_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE) + +#define T_BAFFLE_LET T_SHORT_VERY_SAFE_CLOSURE +#define is_baffle_let(p) has_type1_bit(T_Let(p), T_BAFFLE_LET) +#define set_baffle_let(p) set_type1_bit(T_Let(p), T_BAFFLE_LET) + +#define T_CYCLIC (1LL << (TYPE_BITS + BIT_ROOM + 29)) +#define T_SHORT_CYCLIC (1 << 5) +#define is_cyclic(p) has_type1_bit(T_Seq(p), T_SHORT_CYCLIC) +#define set_cyclic(p) set_type1_bit(T_Seq(p), T_SHORT_CYCLIC) + +#define T_CYCLIC_SET (1LL << (TYPE_BITS + BIT_ROOM + 30)) +#define T_SHORT_CYCLIC_SET (1 << 6) +#define is_cyclic_set(p) has_type1_bit(T_Seq(p), T_SHORT_CYCLIC_SET) /* was T_Pos 30-Jan-21 */ +#define set_cyclic_set(p) set_type1_bit(T_Seq(p), T_SHORT_CYCLIC_SET) +#define clear_cyclic_bits(p) clear_type_bit(p, T_COLLECTED | T_SHARED | T_CYCLIC | T_CYCLIC_SET) + +#define T_KEYWORD (1LL << (TYPE_BITS + BIT_ROOM + 31)) +#define T_SHORT_KEYWORD (1 << 7) +#define is_keyword(p) has_type1_bit(T_Pos(p), T_SHORT_KEYWORD) +/* this bit distinguishes a symbol from a symbol that is also a keyword */ + +#define T_FULL_SIMPLE_ELEMENTS (1LL << (TYPE_BITS + BIT_ROOM + 32)) +#define T_SIMPLE_ELEMENTS (1 << 8) +#define has_simple_elements(p) has_type1_bit(T_Nvc(p), T_SIMPLE_ELEMENTS) +#define set_has_simple_elements(p) set_type1_bit(T_Nvc(p), T_SIMPLE_ELEMENTS) +#define c_function_has_simple_elements(p) has_type1_bit(T_Fnc(p), T_SIMPLE_ELEMENTS) +#define c_function_set_has_simple_elements(p) set_type1_bit(T_Fnc(p), T_SIMPLE_ELEMENTS) +/* c_func case here refers to boolean? et al -- structure element type declaration that ensures a simple object */ + +#define T_SIMPLE_KEYS T_SIMPLE_ELEMENTS +#define has_simple_keys(p) has_type1_bit(T_Hsh(p), T_SIMPLE_KEYS) +#define set_has_simple_keys(p) set_type1_bit(T_Hsh(p), T_SIMPLE_KEYS) + +#define T_SAFE_SETTER T_SIMPLE_ELEMENTS +#define is_safe_setter(p) has_type1_bit(T_Sym(p), T_SAFE_SETTER) +#define set_is_safe_setter(p) set_type1_bit(T_Sym(p), T_SAFE_SETTER) + +#define T_FLOAT_OPTABLE T_SIMPLE_ELEMENTS +#define is_float_optable(p) has_type1_bit(T_Pair(p), T_FLOAT_OPTABLE) +#define set_is_float_optable(p) set_type1_bit(T_Pair(p), T_FLOAT_OPTABLE) + +#define T_FULL_CASE_KEY (1LL << (TYPE_BITS + BIT_ROOM + 33)) +#define T_CASE_KEY (1 << 9) +#define is_case_key(p) has_type1_bit(T_Pos(p), T_CASE_KEY) +#define set_case_key(p) set_type1_bit(T_Sym(p), T_CASE_KEY) + +#define T_OPT1_FUNC_LISTED T_CASE_KEY +#define opt1_func_listed(p) has_type1_bit(T_Pair(p), T_OPT1_FUNC_LISTED) +#define set_opt1_func_listed(p) set_type1_bit(T_Pair(p), T_OPT1_FUNC_LISTED) + +#define T_FULL_HAS_GX (1LL << (TYPE_BITS + BIT_ROOM + 34)) +#define T_HAS_GX (1 << 10) +#define has_gx(p) has_type1_bit(T_Pair(p), T_HAS_GX) +#define set_has_gx(p) set_type1_bit(T_Pair(p), T_HAS_GX) + +#define T_FULL_UNKNOPT (1LL << (TYPE_BITS + BIT_ROOM + 35)) +#define T_UNKNOPT (1 << 11) +#define is_unknopt(p) has_type1_bit(T_Pair(p), T_UNKNOPT) +#define set_is_unknopt(p) set_type1_bit(T_Pair(p), T_UNKNOPT) + +#define T_MAC_OK T_UNKNOPT +#define mac_is_ok(p) has_type1_bit(T_Pair(p), T_MAC_OK) +#define set_mac_is_ok(p) set_type1_bit(T_Pair(p), T_MAC_OK) +/* marks a macro (via (macro...)) that has been checked -- easier (and slower) than making 4 or 5 more ops, op_macro_unchecked and so on */ + +#define T_FULL_SAFETY_CHECKED (1LL << (TYPE_BITS + BIT_ROOM + 36)) +#define T_SAFETY_CHECKED (1 << 12) +#define is_safety_checked(p) has_type1_bit(T_Pair(p), T_SAFETY_CHECKED) +#define set_safety_checked(p) set_type1_bit(T_Pair(p), T_SAFETY_CHECKED) + +#define T_FULL_HAS_FN (1LL << (TYPE_BITS + BIT_ROOM + 37)) +#define T_HAS_FN (1 << 13) +#define set_has_fn(p) set_type1_bit(T_Pair(p), T_HAS_FN) +#define has_fn(p) has_type1_bit(T_Pair(p), T_HAS_FN) + +#define UNUSED_BITS 0 + +#define T_GC_MARK 0x8000000000000000 +#define is_marked(p) has_type_bit(p, T_GC_MARK) +#define set_mark(p) set_type_bit(T_Pos(p), T_GC_MARK) +#define clear_mark(p) clear_type_bit(p, T_GC_MARK) +/* using the sign bit, bit 23 (or 55) == 31 (or 63) for this makes a big difference in the GC */ + +#define T_UNHEAP 0x4000000000000000 +#define T_SHORT_UNHEAP (1 << 14) +#define in_heap(p) (((T_Pos(p))->tf.opts.high_flag & T_SHORT_UNHEAP) == 0) +#define unheap(sc, p) set_type1_bit(T_Pos(p), T_SHORT_UNHEAP) + +#define is_eof(p) ((T_Pos(p)) == eof_object) +#define is_true(Sc, p) ((T_Pos(p)) != Sc->F) +#define is_false(Sc, p) ((T_Pos(p)) == Sc->F) + +#ifdef _MSC_VER +static s7_pointer make_boolean(s7_scheme * sc, bool val) +{ + if (val) + return (sc->T); + return (sc->F); +} +#else +#define make_boolean(sc, Val) ((Val) ? sc->T : sc->F) +#endif + +#define is_pair(p) (type(p) == T_PAIR) +#define is_mutable_pair(p) ((full_type(T_Pos(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_PAIR) +#define is_null(p) ((T_Pos(p)) == sc->nil) +#define is_not_null(p) ((T_Pos(p)) != sc->nil) +#define is_list(p) ((is_pair(p)) || (type(p) == T_NIL)) +#define is_quoted_pair(p) ((is_pair(p)) && (car(p) == sc->quote_symbol)) +#define is_unquoted_pair(p) ((is_pair(p)) && (car(p) != sc->quote_symbol)) +#define is_quoted_symbol(p) ((is_pair(p)) && (car(p) == sc->quote_symbol) && (is_symbol(cadr(p)))) + + +/* pair line/file/position */ +#define PAIR_LINE_BITS 24 +#define PAIR_FILE_BITS 12 +#define PAIR_POSITION_BITS 28 +#define PAIR_LINE_OFFSET 0 +#define PAIR_FILE_OFFSET PAIR_LINE_BITS +#define PAIR_POSITION_OFFSET (PAIR_LINE_BITS + PAIR_FILE_BITS) +#define PAIR_LINE_MASK ((1 << PAIR_LINE_BITS) - 1) +#define PAIR_FILE_MASK ((1 << PAIR_FILE_BITS) - 1) +#define PAIR_POSITION_MASK ((1 << PAIR_POSITION_BITS) - 1) + +#define port_location(Pt) (((port_line_number(Pt) & PAIR_LINE_MASK) << PAIR_LINE_OFFSET) | \ + ((port_file_number(Pt) & PAIR_FILE_MASK) << PAIR_FILE_OFFSET) | \ + ((port_position(Pt) & PAIR_POSITION_MASK) << PAIR_POSITION_OFFSET)) +#define location_to_line(Loc) ((Loc >> PAIR_LINE_OFFSET) & PAIR_LINE_MASK) +#define location_to_file(Loc) ((Loc >> PAIR_FILE_OFFSET) & PAIR_FILE_MASK) +#define location_to_position(Loc) ((Loc >> PAIR_POSITION_OFFSET) & PAIR_POSITION_MASK) + +#define pair_line_number(p) location_to_line(pair_location(p)) +#define pair_file_number(p) location_to_file(pair_location(p)) +#define pair_position(p) location_to_position(pair_location(p)) + +#if (!S7_DEBUGGING) +#define pair_location(p) (p)->object.sym_cons.location +#define pair_set_location(p, X) (p)->object.sym_cons.location = X +#define pair_raw_hash(p) (p)->object.sym_cons.hash +#define pair_set_raw_hash(p, X) (p)->object.sym_cons.hash = X +#define pair_raw_len(p) (p)->object.sym_cons.location +#define pair_set_raw_len(p, X) (p)->object.sym_cons.location = X +#define pair_raw_name(p) (p)->object.sym_cons.fstr +#define pair_set_raw_name(p, X) (p)->object.sym_cons.fstr = X +/* opt1 == raw_hash, opt2 == raw_name, opt3 == line|ctr + len, but hash/name/len only apply to the symbol table so there's no collision */ + +#define opt1(p, r) ((p)->object.cons.opt1) +#define set_opt1(p, x, r) (p)->object.cons.opt1 = x +#define opt2(p, r) ((p)->object.cons.opt2) +#define set_opt2(p, x, r) (p)->object.cons.opt2 = (s7_pointer)(x) +#define opt3(p, r) ((p)->object.cons.opt3) +#define set_opt3(p, x, r) do {(p)->object.cons.opt3 = x; clear_type_bit(p, T_LOCATION);} while (0) + +#else + +/* the 3 opt fields hold most of the varigated optimizer info, so they are used in many conflicting ways. + * the bits and funcs here try to track each such use, and report any cross-talk or collisions. + * all of this machinery vanishes if debugging is turned off. + */ +#define OPT1_SET (1 << 0) +#define OPT2_SET (1 << 1) +#define OPT3_SET (1 << 2) + +#define OPT1_FAST (1 << 3) /* fast list in member/assoc circular list check */ +#define OPT1_CFUNC (1 << 4) /* c-function */ +#define OPT1_CLAUSE (1 << 5) /* case clause */ +#define OPT1_LAMBDA (1 << 6) /* lambda(*) */ +#define OPT1_SYM (1 << 7) /* symbol */ +#define OPT1_PAIR (1 << 8) /* pair */ +#define OPT1_CON (1 << 9) /* constant from eval's point of view */ /* 10 was opt1_goto, unused */ +#define OPT1_ANY (1 << 11) /* anything -- deliberate unchecked case */ +#define OPT1_HASH (1 << 12) +#define OPT1_MASK (OPT1_FAST | OPT1_CFUNC | OPT1_CLAUSE | OPT1_LAMBDA | OPT1_SYM | OPT1_PAIR | OPT1_CON | OPT1_ANY | OPT1_HASH) + +#define opt1_is_set(p) (((T_Pair(p))->debugger_bits & OPT1_SET) != 0) +#define set_opt1_is_set(p) (T_Pair(p))->debugger_bits |= OPT1_SET +#define opt1_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT1_MASK) == Role) +#define set_opt1_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT1_MASK)) +#define opt1(p, Role) opt1_1(sc, T_Pair(p), Role, __func__, __LINE__) +#define set_opt1(p, x, Role) set_opt1_1(T_Pair(p), x, Role) + +#define OPT2_KEY (1 << 13) /* case key */ +#define OPT2_SLOW (1 << 14) /* slow list in member/assoc circular list check */ +#define OPT2_SYM (1 << 15) /* symbol */ +#define OPT2_PAIR (1 << 16) /* pair */ +#define OPT2_CON (1 << 17) /* constant as above */ +#define OPT2_FX (1 << 18) /* fx (fx_*) func (sc, form) */ +#define OPT2_FN (1 << 19) /* fn (s7_function) func (sc, arglist) */ +#define OPT2_LAMBDA (1 << 20) /* lambda form */ +#define OPT2_NAME (1 << 21) +#define OPT2_DIRECT (1LL << 32) +#define OPT2_INT (1LL << 33) +#define OPT2_MASK (OPT2_KEY | OPT2_SLOW | OPT2_SYM | OPT2_PAIR | OPT2_CON | OPT2_FX | OPT2_FN | OPT2_LAMBDA | OPT2_DIRECT | OPT2_NAME | OPT2_INT) + +#define opt2_is_set(p) (((T_Pair(p))->debugger_bits & OPT2_SET) != 0) +#define set_opt2_is_set(p) (T_Pair(p))->debugger_bits |= OPT2_SET +#define opt2_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT2_MASK) == Role) +#define set_opt2_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT2_MASK)) +#define opt2(p, Role) opt2_1(sc, T_Pair(p), Role, __func__, __LINE__) +#define set_opt2(p, x, Role) set_opt2_1(sc, T_Pair(p), (s7_pointer)(x), Role, __func__, __LINE__) + +#define OPT3_ARGLEN (1 << 22) /* arglist length */ +#define OPT3_SYM (1 << 23) /* expression symbol access */ +#define OPT3_AND (1 << 24) /* and second clause */ +#define OPT3_DIRECT (1 << 25) /* direct call info */ +#define OPT3_ANY (1 << 26) +#define OPT3_LET (1 << 27) /* let or #f */ +#define OPT3_CON (1 << 28) +#define OPT3_LOCATION (1 << 29) +#define OPT3_LEN (1 << 30) +#define OPT3_BYTE (1LL << 31) +#define OPT3_INT (1LL << 34) +#define OPT3_MASK (OPT3_ARGLEN | OPT3_SYM | OPT3_AND | OPT3_ANY | OPT3_LET | OPT3_BYTE | OPT3_LOCATION | OPT3_LEN | OPT3_DIRECT | OPT3_CON | OPT3_INT) + +#define opt3_is_set(p) (((T_Pair(p))->debugger_bits & OPT3_SET) != 0) +#define set_opt3_is_set(p) (T_Pair(p))->debugger_bits |= OPT3_SET +#define opt3_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT3_MASK) == Role) +#define set_opt3_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT3_MASK)) +#define opt3(p, Role) opt3_1(sc, T_Pair(p), Role, __func__, __LINE__) +#define set_opt3(p, x, Role) set_opt3_1(T_Pair(p), x, Role) + +#define pair_location(p) opt3_location_1(sc, T_Pair(p), __func__, __LINE__) +#define pair_set_location(p, X) set_opt3_location_1(T_Pair(p), X) +#define pair_raw_hash(p) opt1_hash_1(sc, T_Pair(p), __func__, __LINE__) +#define pair_set_raw_hash(p, X) set_opt1_hash_1(T_Pair(p), X) +#define pair_raw_len(p) opt3_len_1(sc, T_Pair(p), __func__, __LINE__) +#define pair_set_raw_len(p, X) set_opt3_len_1(T_Pair(p), X) +#define pair_raw_name(p) opt2_name_1(sc, T_Pair(p), __func__, __LINE__) +#define pair_set_raw_name(p, X) set_opt2_name_1(T_Pair(p), X) + +#define L_HIT (1LL << 40) /* "L_SET" is taken */ +#define L_FUNC (1LL << 41) +#define L_DOX (1LL << 42) +#define L_CATCH (1LL << 43) +#define L_MASK (L_FUNC | L_DOX | L_CATCH) +#endif + +#define opt1_fast(P) T_Lst(opt1(P, OPT1_FAST)) +#define set_opt1_fast(P, X) set_opt1(P, T_Pair(X), OPT1_FAST) +#define opt1_cfunc(P) T_Pos(opt1(P, OPT1_CFUNC)) +#define set_opt1_cfunc(P, X) set_opt1(P, T_Fnc(X), OPT1_CFUNC) +#define opt1_lambda_unchecked(P) opt1(P, OPT1_LAMBDA) /* can be free/null? from s7_call? */ +#define opt1_lambda(P) T_Clo(opt1(P, OPT1_LAMBDA)) +#define set_opt1_lambda(P, X) set_opt1(P, T_Clo(X), OPT1_LAMBDA) +#define set_opt1_lambda_add(P, X) do {set_opt1(P, T_Clo(X), OPT1_LAMBDA); add_opt1_func(sc, P);} while (0) +#define opt1_clause(P) T_Pos(opt1(P, OPT1_CLAUSE)) +#define set_opt1_clause(P, X) set_opt1(P, T_Pos(X), OPT1_CLAUSE) +#define opt1_sym(P) T_Sym(opt1(P, OPT1_SYM)) +#define set_opt1_sym(P, X) set_opt1(P, T_Sym(X), OPT1_SYM) +#define opt1_pair(P) T_Lst(opt1(P, OPT1_PAIR)) +#define set_opt1_pair(P, X) set_opt1(P, T_Lst(X), OPT1_PAIR) +#define opt1_con(P) T_Pos(opt1(P, OPT1_CON)) +#define set_opt1_con(P, X) set_opt1(P, T_Pos(X), OPT1_CON) +#define opt1_any(P) opt1(P, OPT1_ANY) /* can be free in closure_is_ok */ +#define set_opt1_any(P, X) set_opt1(P, X, OPT1_ANY) + +#define opt2_any(P) opt2(P, OPT2_KEY) +#define set_opt2_any(P, X) set_opt2(P, X, OPT2_KEY) +#define opt2_int(P) T_Int(opt2(P, OPT2_INT)) +#define set_opt2_int(P, X) set_opt2(P, T_Int(X), OPT2_INT) +#define opt2_slow(P) T_Lst(opt2(P, OPT2_SLOW)) +#define set_opt2_slow(P, X) set_opt2(P, T_Pair(X), OPT2_SLOW) +#define opt2_sym(P) T_Sym(opt2(P, OPT2_SYM)) +#define set_opt2_sym(P, X) set_opt2(P, T_Sym(X), OPT2_SYM) +#define opt2_pair(P) T_Lst(opt2(P, OPT2_PAIR)) +#define set_opt2_pair(P, X) set_opt2(P, T_Lst(X), OPT2_PAIR) +#define opt2_con(P) T_Pos(opt2(P, OPT2_CON)) +#define set_opt2_con(P, X) set_opt2(P, T_Pos(X), OPT2_CON) +#define opt2_lambda(P) T_Pair(opt2(P, OPT2_LAMBDA)) +#define set_opt2_lambda(P, X) set_opt2(P, T_Pair(X), OPT2_LAMBDA) +#define opt2_direct(P) opt2(P, OPT2_DIRECT) +#define set_opt2_direct(P, X) set_opt2(P, (s7_pointer)(X), OPT2_DIRECT) + +#define opt3_arglen(P) T_Int(opt3(P, OPT3_ARGLEN)) +#define set_opt3_arglen(P, X) set_opt3(P, T_Int(X), OPT3_ARGLEN) +#define opt3_int(P) T_Int(opt3(P, OPT3_INT)) +#define set_opt3_int(P, X) set_opt3(P, T_Int(X), OPT3_INT) +#define opt3_sym(P) T_Sym(opt3(P, OPT3_SYM)) +#define set_opt3_sym(P, X) set_opt3(P, T_Sym(X), OPT3_SYM) +#define opt3_con(P) T_Pos(opt3(P, OPT3_CON)) +#define set_opt3_con(P, X) set_opt3(P, T_Pos(X), OPT3_CON) +#define opt3_pair(P) T_Pair(opt3(P, OPT3_AND)) +#define set_opt3_pair(P, X) set_opt3(P, T_Pair(X), OPT3_AND) +#define opt3_any(P) opt3(P, OPT3_ANY) +#define set_opt3_any(P, X) set_opt3(P, X, OPT3_ANY) +#define opt3_let(P) T_Lid(opt3(P, OPT3_LET)) +#define set_opt3_let(P, X) set_opt3(P, T_Lid(X), OPT3_LET) +#define opt3_direct(P) opt3(P, OPT3_DIRECT) +#define set_opt3_direct(P, X) set_opt3(P, (s7_pointer)(X), OPT3_DIRECT) + +#if S7_DEBUGGING +#define opt3_byte(p) opt3_byte_1(sc, T_Pair(p), OPT3_BYTE, __func__, __LINE__) +#define set_opt3_byte(p, x) set_opt3_byte_1(T_Pair(p), x, OPT3_BYTE, __func__, __LINE__) +#else +#define opt3_byte(P) T_Pair(P)->object.cons_ext.opt_type /* op_if_is_type, opt_type == opt3 in cons_ext */ +#define set_opt3_byte(P, X) do {T_Pair(P)->object.cons_ext.opt_type = X; clear_type_bit(P, T_LOCATION);} while (0) +#endif + +#define pair_macro(P) opt2_sym(P) +#define set_pair_macro(P, Name) set_opt2_sym(P, Name) + +#define fn_proc(f) ((s7_function)(opt2(f, OPT2_FN))) +#define fx_proc(f) ((s7_function)(opt2(f, OPT2_FX))) +#define fn_proc_unchecked(f) ((s7_function)(T_Pair(f)->object.cons.opt2)) +#define fx_proc_unchecked(f) ((s7_function)(T_Pair(f)->object.cons.opt2)) /* unused */ + +#define set_fx(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); set_opt2(f, X, OPT2_FX); if (X) set_has_fx(f); else clear_has_fx(f);} while (0) +#define set_fx_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FX); set_has_fx(f);} while (0) +#define set_fn(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); set_opt2(f, X, OPT2_FN); if (X) set_has_fn(f); else clear_has_fx(f);} while (0) +#define set_fn_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FN); set_has_fn(f);} while (0) + +#if WITH_GCC +#define fx_call(Sc, F) ({s7_pointer _P_; _P_ = F; fx_proc(_P_)(Sc, car(_P_));}) +#define fc_call(Sc, F) ({s7_pointer _P_; _P_ = F; fn_proc(_P_)(Sc, cdr(_P_));}) +#define fn_call(Sc, F) ({s7_pointer _P_; _P_ = F; fn_proc(_P_)(Sc, cdr(_P_));}) +#else +#define fx_call(Sc, F) fx_proc(F)(Sc, car(F)) +#define fc_call(Sc, F) fn_proc(F)(Sc, cdr(F)) +#define fn_call(Sc, F) fn_proc(F)(Sc, cdr(F)) +#endif +/* fx_call can affect the stack and sc->value */ + +#define car(p) (T_Pair(p))->object.cons.car +#define set_car(p, Val) car(p) = T_Pos(Val) +#define cdr(p) (T_Pair(p))->object.cons.cdr +#define set_cdr(p, Val) cdr(p) = T_Pos(Val) +#define unchecked_car(p) (T_Pos(p))->object.cons.car +#define unchecked_cdr(p) (T_Pos(p))->object.cons.cdr + +#define caar(p) car(car(p)) +#define cadr(p) car(cdr(p)) +#define set_cadr(p, Val) car(cdr(p)) = T_Pos(Val) +#define cdar(p) cdr(car(p)) +#define set_cdar(p, Val) cdr(car(p)) = T_Pos(Val) +#define cddr(p) cdr(cdr(p)) + +#define caaar(p) car(car(car(p))) +#define cadar(p) car(cdr(car(p))) +#define cdadr(p) cdr(car(cdr(p))) +#define caddr(p) car(cdr(cdr(p))) +#define set_caddr(p, Val) car(cdr(cdr(p))) = T_Pos(Val) +#define caadr(p) car(car(cdr(p))) +#define cdaar(p) cdr(car(car(p))) +#define cdddr(p) cdr(cdr(cdr(p))) +#define set_cdddr(p, Val) cdr(cdr(cdr(p))) = T_Pos(Val) +#define cddar(p) cdr(cdr(car(p))) + +#define caaadr(p) car(car(car(cdr(p)))) +#define caadar(p) car(car(cdr(car(p)))) +#define cadaar(p) car(cdr(car(car(p)))) +#define cadddr(p) car(cdr(cdr(cdr(p)))) +#define caaddr(p) car(car(cdr(cdr(p)))) +#define cddddr(p) cdr(cdr(cdr(cdr(p)))) +#define caddar(p) car(cdr(cdr(car(p)))) +#define cdadar(p) cdr(car(cdr(car(p)))) +#define cdaddr(p) cdr(car(cdr(cdr(p)))) +#define caaaar(p) car(car(car(car(p)))) +#define cadadr(p) car(cdr(car(cdr(p)))) +#define cdaadr(p) cdr(car(car(cdr(p)))) +#define cdaaar(p) cdr(car(car(car(p)))) +#define cdddar(p) cdr(cdr(cdr(car(p)))) +#define cddadr(p) cdr(cdr(car(cdr(p)))) +#define cddaar(p) cdr(cdr(car(car(p)))) + +#define cadaddr(p) cadr(caddr(p)) +#define caddadr(p) caddr(cadr(p)) +#define caddaddr(p) caddr(caddr(p)) + +#if WITH_GCC + /* slightly tricky because cons can be called recursively */ +#define cons(Sc, A, B) ({s7_pointer _X_, _A_, _B_; _A_ = A; _B_ = B; new_cell(Sc, _X_, T_PAIR | T_SAFE_PROCEDURE); set_car(_X_, _A_); set_cdr(_X_, _B_); _X_;}) +#else +#define cons(Sc, A, B) s7_cons(Sc, A, B) +#endif + +#define list_1(Sc, A) cons(Sc, A, Sc->nil) +#define list_1_unchecked(Sc, A) cons_unchecked(Sc, A, Sc->nil) +#define list_2(Sc, A, B) cons_unchecked(Sc, A, cons(Sc, B, Sc->nil)) +#define list_2_unchecked(Sc, A, B) cons_unchecked(Sc, A, cons_unchecked(Sc, B, Sc->nil)) +#define list_3(Sc, A, B, C) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons(Sc, C, Sc->nil))) +#define list_4(Sc, A, B, C, D) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons_unchecked(Sc, C, cons(Sc, D, Sc->nil)))) + +#define is_string(p) (type(p) == T_STRING) +#define is_mutable_string(p) ((full_type(T_Pos(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_STRING) +#define string_value(p) (T_Str(p))->object.string.svalue +#define string_length(p) (T_Str(p))->object.string.length +#define string_hash(p) (T_Str(p))->object.string.hash +#define string_block(p) (T_Str(p))->object.string.block +#define unchecked_string_block(p) p->object.string.block + +#define character(p) (T_Chr(p))->object.chr.c +#define is_character(p) (type(p) == T_CHARACTER) +#define upper_character(p) (T_Chr(p))->object.chr.up_c +#define is_char_alphabetic(p) (T_Chr(p))->object.chr.alpha_c +#define is_char_numeric(p) (T_Chr(p))->object.chr.digit_c +#define is_char_whitespace(p) (T_Chr(p))->object.chr.space_c +#define is_char_uppercase(p) (T_Chr(p))->object.chr.upper_c +#define is_char_lowercase(p) (T_Chr(p))->object.chr.lower_c +#define character_name(p) (T_Chr(p))->object.chr.c_name +#define character_name_length(p) (T_Chr(p))->object.chr.length + +#define optimize_op(P) (T_Pos(P))->tf.opts.opt_choice +#define set_optimize_op(P, Op) (T_Pos(P))->tf.opts.opt_choice = Op +#define OP_HOP_MASK 0xfffe +#define optimize_op_match(P, Q) ((is_optimized(P)) && ((optimize_op(P) & OP_HOP_MASK) == (Q))) +#define op_no_hop(P) (optimize_op(P) & OP_HOP_MASK) +#define op_has_hop(P) ((optimize_op(P) & 1) != 0) +#define clear_optimize_op(P) set_optimize_op(P, OP_UNOPT) +#define set_safe_optimize_op(P, Q) do {set_optimized(P); set_optimize_op(P, Q);} while (0) +#define set_unsafe_optimize_op(P, Q) do {set_unsafely_optimized(P); set_optimize_op(P, Q);} while (0) + +#define is_symbol(p) (type(p) == T_SYMBOL) +#define is_normal_symbol(p) ((is_symbol(p)) && (!is_keyword(p))) +#define is_safe_symbol(p) ((is_symbol(p)) && (is_slot(lookup_slot_from(p, sc->curlet)))) +#define symbol_name_cell(p) T_Str((T_Sym(p))->object.sym.name) +#define symbol_set_name_cell(p, S) (T_Sym(p))->object.sym.name = T_Str(S) +#define symbol_name(p) string_value(symbol_name_cell(p)) +#define symbol_name_length(p) string_length(symbol_name_cell(p)) +#define gensym_block(p) symbol_name_cell(p)->object.string.gensym_block +#define pointer_map(p) (s7_int)((intptr_t)(p) >> 8) +#define symbol_id(p) (T_Sym(p))->object.sym.id +#define symbol_set_id_unchecked(p, X) (T_Sym(p))->object.sym.id = X +#if S7_DEBUGGING +static void symbol_set_id(s7_pointer p, s7_int id) +{ + if (id < symbol_id(p)) { + fprintf(stderr, "id mismatch: sym: %s %" ld64 ", let: %" ld64 "\n", + symbol_name(p), symbol_id(p), id); + abort(); + } + (T_Sym(p))->object.sym.id = id; +} +#else +#define symbol_set_id(p, X) (T_Sym(p))->object.sym.id = X +#endif +/* we need 64-bits here, since we don't want this thing to wrap around, and lets are created at a great rate + * callgrind says this is faster than an uint32_t! + */ +#define symbol_info(p) (symbol_name_cell(p))->object.string.block +#define symbol_type(p) (block_size(symbol_info(p)) & 0xff) /* boolean function bool type */ +#define symbol_set_type(p, Type) block_size(symbol_info(p)) = ((block_size(symbol_info(p)) & ~0xff) | (Type & 0xff)) +#define symbol_clear_type(p) block_size(symbol_info(p)) = 0 +#define symbol_s7_let(p) ((uint8_t)((block_size(symbol_info(p)) >> 8) & 0xff)) /* *s7* field id */ +#define symbol_set_s7_let(p, Field) block_size(symbol_info(p)) = ((block_size(symbol_info(p)) & ~0xff00) | ((Field & 0xff) << 8)) +#define initial_slot(p) T_Sld(symbol_info(p)->ex.ex_ptr) +#define set_initial_slot(p, Val) symbol_info(p)->ex.ex_ptr = T_Sld(Val) +#define global_slot(p) T_Sld((T_Sym(p))->object.sym.global_slot) +#define set_global_slot(p, Val) (T_Sym(p))->object.sym.global_slot = T_Sld(Val) +#define local_slot(p) T_Sln((T_Sym(p))->object.sym.local_slot) +#define set_local_slot(p, Val) (T_Sym(p))->object.sym.local_slot = T_Slt(Val) + +#define initial_value(p) slot_value(initial_slot(T_Sym(p))) +#define local_value(p) slot_value(local_slot(T_Sym(p))) +#define unchecked_local_value(p) local_slot(p)->object.slt.val +#define global_value(p) slot_value(global_slot(T_Sym(p))) + +#define keyword_symbol(p) symbol_info(p)->nx.ksym /* keyword only, so does not collide with documentation */ +#define keyword_set_symbol(p, Val) symbol_info(p)->nx.ksym = T_Sym(Val) +#define symbol_help(p) symbol_info(p)->nx.documentation +#define symbol_set_help(p, Doc) symbol_info(p)->nx.documentation = Doc +#define symbol_tag(p) (T_Sym(p))->object.sym.tag +#define symbol_set_tag(p, Val) (T_Sym(p))->object.sym.tag = Val +#define symbol_ctr(p) (T_Sym(p))->object.sym.ctr /* needs to be in the symbol object (not symbol_info) for speed */ +#define symbol_clear_ctr(p) (T_Sym(p))->object.sym.ctr = 0 +#define symbol_increment_ctr(p) (T_Sym(p))->object.sym.ctr++ +#define symbol_tag2(p) symbol_info(p)->ln.tag +#define symbol_set_tag2(p, Val) symbol_info(p)->ln.tag = Val +#define symbol_has_help(p) (is_documented(symbol_name_cell(p))) +#define symbol_set_has_help(p) set_documented(symbol_name_cell(p)) + +#define symbol_position(p) symbol_info(p)->dx.pos /* this only needs 32 of the available 64 bits */ +#define symbol_set_position(p, Pos) symbol_info(p)->dx.pos = Pos +#define PD_POSITION_UNSET -1 + +#define symbol_set_local_slot_unchecked(Symbol, Id, Slot) \ + do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id); symbol_increment_ctr(Symbol);} while (0) +#define symbol_set_local_slot_unchecked_and_unincremented(Symbol, Id, Slot) \ + do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id);} while (0) +#define symbol_set_local_slot(Symbol, Id, Slot) \ + do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id); symbol_increment_ctr(Symbol);} while (0) +#define symbol_set_local_slot_unincremented(Symbol, Id, Slot) \ + do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id);} while (0) +/* set slot before id in case Slot is an expression that tries to find the current Symbol slot (using its old Id obviously) */ + +#define is_slot(p) (type(p) == T_SLOT) +#define slot_symbol(p) T_Sym((T_Slt(p))->object.slt.sym) +#define slot_set_symbol(p, Sym) (T_Slt(p))->object.slt.sym = T_Sym(Sym) +#define slot_value(p) T_Nmv((T_Slt(p))->object.slt.val) +#define slot_set_value(p, Val) (T_Slt(p))->object.slt.val = T_Nmv(Val) +#define slot_set_symbol_and_value(Slot, Symbol, Value) do {slot_set_symbol(Slot, Symbol); slot_set_value(Slot, Value);} while (0) +#define slot_set_value_with_hook(Slot, Value) \ + do {if (hook_has_functions(sc->rootlet_redefinition_hook)) slot_set_value_with_hook_1(sc, Slot, T_Nmv(Value)); else slot_set_value(Slot, T_Nmv(Value));} while (0) +#define next_slot(p) T_Sln((T_Slt(p))->object.slt.nxt) +#define slot_set_next(p, Val) (T_Slt(p))->object.slt.nxt = T_Sln(Val) +#define slot_set_pending_value(p, Val) do {(T_Slt(p))->object.slt.pending_value = T_Nmv(Val); slot_set_has_pending_value(p);} while (0) +#define slot_simply_set_pending_value(p, Val) (T_Slt(p))->object.slt.pending_value = T_Nmv(Val) +#if S7_DEBUGGING +static s7_pointer slot_pending_value(s7_pointer p) +{ + if (slot_has_pending_value(p)) + return (p->object.slt.pending_value); + fprintf(stderr, "slot: no pending value\n"); + abort(); +} + +static s7_pointer slot_expression(s7_pointer p) +{ + if (slot_has_expression(p)) + return (p->object.slt.expr); + fprintf(stderr, "slot: no expression\n"); + abort(); +} +#else +#define slot_pending_value(p) (T_Slt(p))->object.slt.pending_value +#define slot_expression(p) (T_Slt(p))->object.slt.expr +#endif +#define slot_set_expression(p, Val) do {(T_Slt(p))->object.slt.expr = T_Pos(Val); slot_set_has_expression(p);} while (0) +#define slot_just_set_expression(p, Val) (T_Slt(p))->object.slt.expr = T_Pos(Val) +#define slot_setter(p) T_Prc(T_Slt(p)->object.slt.expr) +#define slot_set_setter_1(p, Val) (T_Slt(p))->object.slt.expr = T_Prc(Val) +#if S7_DEBUGGING +#define tis_slot(p) ((p) && (T_Slt(p))) +#else +#define tis_slot(p) (p) /* used for loop through let slots which end in nil, not for general slot recognition */ +#endif +#define slot_end(sc) NULL +#define is_slot_end(p) (!(p)) + +#define is_syntax(p) (type(p) == T_SYNTAX) +#define syntax_symbol(p) T_Sym((T_Syn(p))->object.syn.symbol) +#define syntax_set_symbol(p, Sym) (T_Syn(p))->object.syn.symbol = T_Sym(Sym) +#define syntax_opcode(p) (T_Syn(p))->object.syn.op +#define syntax_min_args(p) (T_Syn(p))->object.syn.min_args +#define syntax_max_args(p) (T_Syn(p))->object.syn.max_args +#define syntax_documentation(p) (T_Syn(p))->object.syn.documentation +#define pair_set_syntax_op(p, X) do {set_optimize_op(p, X); set_syntactic_pair(p);} while (0) +#define symbol_syntax_op_checked(p) ((is_syntactic_pair(p)) ? optimize_op(p) : symbol_syntax_op(car(p))) +#define symbol_syntax_op(p) syntax_opcode(global_value(p)) + +#define INITIAL_ROOTLET_SIZE 512 +#define let_id(p) (T_Lid(p))->object.envr.id +#define let_set_id(p, Id) (T_Lid(p))->object.envr.id = Id +#define is_let(p) (type(p) == T_LET) +#define is_let_unchecked(p) (unchecked_type(p) == T_LET) +#define let_slots(p) T_Sln((T_Let(p))->object.envr.slots) +#define let_outlet(p) T_Lid((T_Let(p))->object.envr.nxt) +#define let_set_outlet(p, ol) (T_Let(p))->object.envr.nxt = T_Lid(ol) +#if S7_DEBUGGING +#define let_set_slots(p, Slot) do {if ((!in_heap(p)) && (Slot) && (in_heap(Slot))) fprintf(stderr, "let+slot mismatch\n"); T_Let(p)->object.envr.slots = T_Sln(Slot);} while (0) +#define C_Let(p, role) check_let_ref(p, role, __func__, __LINE__) +#define S_Let(p, role) check_let_set(p, role, __func__, __LINE__) +#else +#define let_set_slots(p, Slot) (T_Let(p))->object.envr.slots = T_Sln(Slot) +#define C_Let(p, role) p +#define S_Let(p, role) p +#endif +#define funclet_function(p) T_Sym((C_Let(p, L_FUNC))->object.envr.edat.efnc.function) +#define funclet_set_function(p, F) (S_Let(p, L_FUNC))->object.envr.edat.efnc.function = T_Sym(F) +#define set_curlet(Sc, P) Sc->curlet = T_Lid(P) + +#define let_baffle_key(p) (T_Let(p))->object.envr.edat.bafl.key +#define set_let_baffle_key(p, K) (T_Let(p))->object.envr.edat.bafl.key = K + +#define let_line(p) (C_Let(p, L_FUNC))->object.envr.edat.efnc.line +#define let_set_line(p, L) (S_Let(p, L_FUNC))->object.envr.edat.efnc.line = L +#define let_file(p) (C_Let(p, L_FUNC))->object.envr.edat.efnc.file +#define let_set_file(p, F) (S_Let(p, L_FUNC))->object.envr.edat.efnc.file = F + +#define let_dox_slot1(p) T_Slt((C_Let(p, L_DOX))->object.envr.edat.dox.dox1) +#define let_set_dox_slot1(p, S) do {(S_Let(p, L_DOX))->object.envr.edat.dox.dox1 = T_Slt(S); set_has_dox_slot1(p);} while (0) +#define let_dox_slot2(p) T_Sld((C_Let(p, L_DOX))->object.envr.edat.dox.dox2) +#define let_set_dox_slot2(p, S) do {(S_Let(p, L_DOX))->object.envr.edat.dox.dox2 = T_Slt(S); set_has_dox_slot2(p);} while (0) +#define let_dox_slot2_unchecked(p) T_Sld(C_Let(p, L_DOX)->object.envr.edat.dox.dox2) +#define let_set_dox_slot2_unchecked(p, S) do {S_Let(p, L_DOX)->object.envr.edat.dox.dox2 = T_Sld(S); set_has_dox_slot2(p);} while (0) +#define let_dox1_value(p) slot_value(let_dox_slot1(p)) +#define let_dox2_value(p) slot_value(let_dox_slot2(p)) + +#define unique_name(p) (p)->object.unq.name /* not T_Uniq(p) here -- see make_unique */ +#define unique_name_length(p) (p)->object.unq.len +#define is_unspecified(p) (type(p) == T_UNSPECIFIED) +#define unique_car(p) (p)->object.unq.car +#define unique_cdr(p) (p)->object.unq.cdr + +#define is_undefined(p) (type(p) == T_UNDEFINED) +#define undefined_name(p) (T_Undf(p))->object.undef.name +#define undefined_name_length(p) (T_Undf(p))->object.undef.len +#define undefined_set_name_length(p, L) (T_Undf(p))->object.undef.len = L +#define eof_name(p) (T_Eof(p))->object.eof.name +#define eof_name_length(p) (T_Eof(p))->object.eof.len + +#define is_any_vector(p) t_vector_p[type(p)] +#define is_normal_vector(p) (type(p) == T_VECTOR) +#define vector_length(p) (p)->object.vector.length +#define unchecked_vector_elements(p) (p)->object.vector.elements.objects +#define unchecked_vector_element(p, i) ((p)->object.vector.elements.objects[i]) +#define vector_element(p, i) ((T_Vec(p))->object.vector.elements.objects[i]) +#define vector_elements(p) (T_Vec(p))->object.vector.elements.objects +#define vector_getter(p) (T_Vec(p))->object.vector.vget +#define vector_setter(p) (T_Vec(p))->object.vector.setv.vset +#define vector_block(p) (T_Vec(p))->object.vector.block +#define unchecked_vector_block(p) p->object.vector.block + +#define typed_vector_typer(p) T_Prc((T_Vec(p))->object.vector.setv.fset) +#define typed_vector_set_typer(p, Fnc) (T_Vec(p))->object.vector.setv.fset = T_Prc(Fnc) +#define typed_vector_gc_mark(p) ((is_c_function(typed_vector_typer(p))) ? c_function_marker(typed_vector_typer(p)) : mark_typed_vector_1) +#define typed_vector_typer_call(sc, p, Args) \ + ((is_c_function(typed_vector_typer(p))) ? c_function_call(typed_vector_typer(p))(sc, Args) : s7_apply_function(sc, typed_vector_typer(p), Args)) + +#define is_int_vector(p) (type(p) == T_INT_VECTOR) +#define int_vector(p, i) ((T_Ivc(p))->object.vector.elements.ints[i]) +#define int_vector_ints(p) (T_Ivc(p))->object.vector.elements.ints + +#define is_float_vector(p) (type(p) == T_FLOAT_VECTOR) +#define float_vector(p, i) ((T_Fvc(p))->object.vector.elements.floats[i]) +#define float_vector_floats(p) (T_Fvc(p))->object.vector.elements.floats + +#define is_byte_vector(p) (type(p) == T_BYTE_VECTOR) +#define byte_vector_length(p) (T_BVc(p))->object.vector.length +#define byte_vector_bytes(p) (T_BVc(p))->object.vector.elements.bytes +#define byte_vector(p, i) ((T_BVc(p))->object.vector.elements.bytes[i]) +#define is_string_or_byte_vector(p) ((type(p) == T_STRING) || (type(p) == T_BYTE_VECTOR)) + +#define vector_dimension_info(p) ((vdims_t *)(T_Vec(p))->object.vector.block->ex.ex_info) +#define vector_set_dimension_info(p, d) (T_Vec(p))->object.vector.block->ex.ex_info = (void *)d +#define vector_ndims(p) vdims_rank(vector_dimension_info(p)) +#define vector_dimension(p, i) vdims_dims(vector_dimension_info(p))[i] +#define vector_dimensions(p) vdims_dims(vector_dimension_info(p)) +#define vector_offset(p, i) vdims_offsets(vector_dimension_info(p))[i] +#define vector_offsets(p) vdims_offsets(vector_dimension_info(p)) +#define vector_rank(p) ((vector_dimension_info(p)) ? vector_ndims(p) : 1) +#define vector_has_dimension_info(p) (vector_dimension_info(p)) + +#define subvector_vector(p) T_Vec(((vector_dimension_info(T_SVec(p))) ? vdims_original(vector_dimension_info(p)) : (p)->object.vector.block->nx.ksym)) +#define subvector_set_vector(p, vect) (T_SVec(p))->object.vector.block->nx.ksym = T_Vec(vect) + +#define rootlet_element(p, i) unchecked_vector_element(p, i) +#define rootlet_elements(p) unchecked_vector_elements(p) +#define rootlet_block(p) unchecked_vector_block(p) + +#define stack_element(p, i) unchecked_vector_element(T_Stk(p), i) +#define stack_elements(p) unchecked_vector_elements(T_Stk(p)) +#define stack_block(p) unchecked_vector_block(T_Stk(p)) +#define current_stack_top(Sc) ((Sc)->stack_end - (Sc)->stack_start) +#define temp_stack_top(p) (T_Stk(p))->object.stk.top +/* #define stack_flags(p) (T_Stk(p))->object.stk.flags */ +#define stack_clear_flags(p) (T_Stk(p))->object.stk.flags = 0 +#define stack_has_pairs(p) (((T_Stk(p))->object.stk.flags & 1) != 0) +#define stack_set_has_pairs(p) (T_Stk(p))->object.stk.flags |= 1 +#define stack_has_counters(p) (((T_Stk(p))->object.stk.flags & 2) != 0) +#define stack_set_has_counters(p) (T_Stk(p))->object.stk.flags |= 2 + +#define is_hash_table(p) (type(p) == T_HASH_TABLE) +#define is_mutable_hash_table(p) ((full_type(T_Pos(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_HASH_TABLE) +#define hash_table_mask(p) (T_Hsh(p))->object.hasher.mask +#define hash_table_block(p) (T_Hsh(p))->object.hasher.block +#define unchecked_hash_table_block(p) p->object.hasher.block +#define hash_table_set_block(p, b) (T_Hsh(p))->object.hasher.block = b +#define hash_table_element(p, i) (T_Hsh(p))->object.hasher.elements[i] +#define hash_table_elements(p) (T_Hsh(p))->object.hasher.elements /* block data (dx) */ +#define hash_table_entries(p) hash_table_block(p)->nx.nx_int +#define hash_table_checker(p) (T_Hsh(p))->object.hasher.hash_func +#define hash_table_mapper(p) (T_Hsh(p))->object.hasher.loc +#define hash_table_checker_locked(p) (hash_table_mapper(p) != default_hash_map) +#define hash_table_procedures(p) T_Lst(hash_table_block(p)->ex.ex_ptr) +#define hash_table_set_procedures(p, Lst) hash_table_block(p)->ex.ex_ptr = T_Lst(Lst) +#define hash_table_procedures_checker(p) car(hash_table_procedures(p)) +#define hash_table_procedures_mapper(p) cdr(hash_table_procedures(p)) +#define hash_table_set_procedures_mapper(p, f) set_cdr(hash_table_procedures(p), f) +#define hash_table_key_typer(p) T_Prc(opt1_any(hash_table_procedures(p))) +#define hash_table_set_key_typer(p, Fnc) set_opt1_any(p, T_Prc(Fnc)) +#define hash_table_value_typer(p) T_Prc(opt2_any(hash_table_procedures(p))) +#define hash_table_set_value_typer(p, Fnc) set_opt2_any(p, T_Prc(Fnc)) +#define weak_hash_iters(p) hash_table_block(p)->ln.tag + +#if S7_DEBUGGING +#define T_Itr_Pos(p) titr_pos(sc, T_Itr(p), __func__, __LINE__) +#define T_Itr_Len(p) titr_len(sc, T_Itr(p), __func__, __LINE__) +#define T_Itr_Hash(p) titr_hash(sc, T_Itr(p), __func__, __LINE__) +#define T_Itr_Let(p) titr_let(sc, T_Itr(p), __func__, __LINE__) +#define T_Itr_Pair(p) titr_pair(sc, T_Itr(p), __func__, __LINE__) +#else +#define T_Itr_Pos(p) p +#define T_Itr_Len(p) p +#define T_Itr_Hash(p) p +#define T_Itr_Let(p) p +#define T_Itr_Pair(p) p +#endif + +#define is_iterator(p) (type(p) == T_ITERATOR) +#define iterator_sequence(p) (T_Itr(p))->object.iter.obj +#define iterator_position(p) (T_Itr_Pos(p))->object.iter.lc.loc +#define iterator_length(p) (T_Itr_Len(p))->object.iter.lw.len +#define iterator_next(p) (T_Itr(p))->object.iter.next +#define iterator_is_at_end(p) (!iter_ok(p)) /* ((full_type(T_Itr(p)) & T_ITER_OK) == 0) */ +#define iterator_slow(p) T_Lst((T_Itr_Pair(p))->object.iter.lw.slow) +#define iterator_set_slow(p, Val) (T_Itr_Pair(p))->object.iter.lw.slow = T_Lst(Val) +#define iterator_hash_current(p) (T_Itr_Hash(p))->object.iter.lw.hcur +#define iterator_current(p) (T_Itr(p))->object.iter.cur +#define iterator_current_slot(p) T_Sln((T_Itr_Let(p))->object.iter.lc.lcur) +#define iterator_set_current_slot(p, Val) (T_Itr_Let(p))->object.iter.lc.lcur = T_Sln(Val) +#define iterator_let_cons(p) (T_Itr_Let(p))->object.iter.cur + +#define ITERATOR_END eof_object +#define ITERATOR_END_NAME "#" + +#define is_input_port(p) (type(p) == T_INPUT_PORT) +#define is_output_port(p) (type(p) == T_OUTPUT_PORT) +#define port_port(p) (T_Prt(p))->object.prt.port +#define is_string_port(p) (port_type(p) == STRING_PORT) +#define is_file_port(p) (port_type(p) == FILE_PORT) +#define is_function_port(p) (port_type(p) == FUNCTION_PORT) +#define port_filename_block(p) port_port(p)->filename_block +#define port_filename(p) port_port(p)->filename +#define port_filename_length(p) port_port(p)->filename_length +#define port_file(p) port_port(p)->file +#define port_data_block(p) port_port(p)->block +#define unchecked_port_data_block(p) p->object.prt.port->block +#define port_line_number(p) port_port(p)->line_number +#define port_file_number(p) port_port(p)->file_number +#define port_data(p) (T_Prt(p))->object.prt.data +#define port_data_size(p) (T_Prt(p))->object.prt.size +#define port_position(p) (T_Prt(p))->object.prt.point +#define port_block(p) (T_Prt(p))->object.prt.block +#define port_type(p) port_port(p)->ptype +#define port_is_closed(p) port_port(p)->is_closed +#define port_set_closed(p, Val) port_port(p)->is_closed = Val /* this can't be a type bit because sweep checks it after the type has been cleared */ +#define port_needs_free(p) port_port(p)->needs_free +#define port_next(p) port_block(p)->nx.next +#define port_original_input_string(p) port_port(p)->orig_str +#define port_output_function(p) port_port(p)->output_function /* these two are for function ports */ +#define port_output_scheme_function(p) port_port(p)->orig_str +#define port_input_function(p) port_port(p)->input_function +#define port_input_scheme_function(p) port_port(p)->orig_str + +#define current_input_port(Sc) Sc->input_port +#define set_current_input_port(Sc, P) Sc->input_port = P +#define current_output_port(Sc) Sc->output_port +#define set_current_output_port(Sc, P) Sc->output_port = P + +#define port_read_character(p) port_port(p)->pf->read_character +#define port_read_line(p) port_port(p)->pf->read_line +#define port_display(p) port_port(p)->pf->displayer +#define port_write_character(p) port_port(p)->pf->write_character +#define port_write_string(p) port_port(p)->pf->write_string +#define port_read_semicolon(p) port_port(p)->pf->read_semicolon +#define port_read_white_space(p) port_port(p)->pf->read_white_space +#define port_read_name(p) port_port(p)->pf->read_name +#define port_read_sharp(p) port_port(p)->pf->read_sharp +#define port_close(p) port_port(p)->pf->close_port + +#define is_c_function(f) (type(f) >= T_C_FUNCTION) +#define is_c_function_star(f) (type(f) == T_C_FUNCTION_STAR) +#define is_any_c_function(f) (type(f) >= T_C_FUNCTION_STAR) +#define c_function_data(f) (T_Fnc(f))->object.fnc.c_proc +#define c_function_call(f) (T_Fnc(f))->object.fnc.ff +#define c_function_required_args(f) (T_Fnc(f))->object.fnc.required_args +#define c_function_optional_args(f) (T_Fnc(f))->object.fnc.optional_args +#define c_function_all_args(f) (T_Fnc(f))->object.fnc.all_args +#define c_function_name(f) c_function_data(f)->name +#define c_function_name_length(f) c_function_data(f)->name_length +#define c_function_documentation(f) c_function_data(f)->doc +#define c_function_signature(f) c_function_data(f)->signature +#define c_function_setter(f) T_Prc(c_function_data(f)->setter) +#define c_function_set_setter(f, Val) c_function_data(f)->setter = T_Prc(Val) +#define c_function_block(f) (f)->object.fnc.c_proc->block /* no type checking here */ +#define c_function_class(f) c_function_data(f)->id +#define c_function_chooser(f) c_function_data(f)->chooser +#define c_function_base(f) T_Fnc(c_function_data(f)->generic_ff) +#define c_function_set_base(f, Val) c_function_data(f)->generic_ff = T_Fnc(Val) +#define c_function_marker(f) c_function_data(f)->cam.marker /* the mark function for the vector (mark_vector_1 etc) */ +#define c_function_set_marker(f, Val) c_function_data(f)->cam.marker = Val +#define c_function_symbol(f) c_function_data(f)->sam.c_sym + +#define c_function_bool_setter(f) c_function_data(f)->dam.bool_setter +#define c_function_set_bool_setter(f, Val) c_function_data(f)->dam.bool_setter = Val + +#define c_function_arg_defaults(f) c_function_data(T_Fst(f))->dam.arg_defaults +#define c_function_call_args(f) c_function_data(T_Fst(f))->cam.call_args +#define c_function_arg_names(f) c_function_data(T_Fst(f))->sam.arg_names + +#define set_c_function(X, f) do {set_opt1_cfunc(X, f); set_fn_direct(X, c_function_call(f));} while (0) +#define c_function_opt_data(f) c_function_data(f)->opt_data + +#define is_c_macro(p) (type(p) == T_C_MACRO) +#define c_macro_data(f) (T_CMac(f))->object.fnc.c_proc +#define c_macro_call(f) (T_CMac(f))->object.fnc.ff +#define c_macro_name(f) c_macro_data(f)->name +#define c_macro_name_length(f) c_macro_data(f)->name_length +#define c_macro_required_args(f) (T_CMac(f))->object.fnc.required_args +#define c_macro_all_args(f) (T_CMac(f))->object.fnc.all_args +#define c_macro_setter(f) T_Prc(c_macro_data(f)->setter) +#define c_macro_set_setter(f, Val) c_macro_data(f)->setter = T_Prc(Val) + +#define is_random_state(p) (type(p) == T_RANDOM_STATE) +#define random_gmp_state(p) (p)->object.rng.state /* sweep sees free cell in big_random_state gc_list and needs to call gmprandclear on its value */ +#define random_seed(p) (T_Ran(p))->object.rng.seed +#define random_carry(p) (T_Ran(p))->object.rng.carry + +#define continuation_block(p) (T_Con(p))->object.cwcc.block +#define continuation_stack(p) T_Stk(T_Con(p)->object.cwcc.stack) +#define continuation_set_stack(p, Val) (T_Con(p))->object.cwcc.stack = T_Stk(Val) +#define continuation_stack_end(p) (T_Con(p))->object.cwcc.stack_end +#define continuation_stack_start(p) (T_Con(p))->object.cwcc.stack_start +#define continuation_stack_top(p) (continuation_stack_end(p) - continuation_stack_start(p)) +#define continuation_op_stack(p) (T_Con(p))->object.cwcc.op_stack +#define continuation_stack_size(p) continuation_block(p)->nx.ix.i1 +#define continuation_op_loc(p) continuation_block(p)->nx.ix.i2 +#define continuation_op_size(p) continuation_block(p)->ln.tag +#define continuation_key(p) continuation_block(p)->ex.ckey +/* this can overflow int32_t -- baffle_key is s7_int, so ckey should be also */ +#define continuation_name(p) continuation_block(p)->dx.d_ptr + +#define call_exit_goto_loc(p) (T_Got(p))->object.rexit.goto_loc +#define call_exit_op_loc(p) (T_Got(p))->object.rexit.op_stack_loc +#define call_exit_active(p) (T_Got(p))->object.rexit.active +#define call_exit_name(p) (T_Got(p))->object.rexit.name + +#define is_continuation(p) (type(p) == T_CONTINUATION) +#define is_goto(p) (type(p) == T_GOTO) +#define is_macro(p) (type(p) == T_MACRO) +#define is_macro_star(p) (type(p) == T_MACRO_STAR) +#define is_bacro_star(p) (type(p) == T_BACRO_STAR) +#define is_either_macro(p) ((is_macro(p)) || (is_macro_star(p))) +#define is_either_bacro(p) ((type(p) == T_BACRO) || (type(p) == T_BACRO_STAR)) + +#define is_closure(p) (type(p) == T_CLOSURE) +#define is_closure_star(p) (type(p) == T_CLOSURE_STAR) +#define closure_args(p) T_Arg((T_Clo(p))->object.func.args) +#define closure_set_args(p, Val) (T_Clo(p))->object.func.args = T_Arg(Val) +#define closure_body(p) (T_Pair((T_Clo(p))->object.func.body)) +#define closure_set_body(p, Val) (T_Clo(p))->object.func.body = T_Pair(Val) +#define closure_let(p) T_Lid((T_Clo(p))->object.func.env) +#define closure_set_let(p, L) (T_Clo(p))->object.func.env = T_Lid(L) +#define closure_arity(p) (T_Clo(p))->object.func.arity +#define closure_set_arity(p, A) (T_Clo(p))->object.func.arity = A + +#define closure_setter(p) (T_Prc((T_Clo(p))->object.func.setter)) +#define closure_set_setter(p, Val) (T_Clo(p))->object.func.setter = T_Prc(Val) +#define closure_map_list(p) (T_Pair((T_Clo(p))->object.func.setter)) +#define closure_set_map_list(p, Val) (T_Clo(p))->object.func.setter = T_Pair(Val) +#define closure_setter_or_map_list(p) (T_Clo(p)->object.func.setter) +/* closure_map_list refers to a cyclic list detector in map; since in this case map makes a new closure for its own use, + * closure_map_list doesn't collide with closure_setter. + */ + +#define CLOSURE_ARITY_NOT_SET 0x40000000 +#define MAX_ARITY 0x20000000 +#define closure_arity_unknown(p) (closure_arity(p) == CLOSURE_ARITY_NOT_SET) +#define is_thunk(Sc, Fnc) ((type(Fnc) >= T_GOTO) && (s7_is_aritable(Sc, Fnc, 0))) + +#define hook_has_functions(p) (is_pair(s7_hook_functions(sc, T_Clo(p)))) + +#define catch_tag(p) (T_Cat(p))->object.rcatch.tag +#define catch_goto_loc(p) (T_Cat(p))->object.rcatch.goto_loc +#define catch_op_loc(p) (T_Cat(p))->object.rcatch.op_stack_loc +#define catch_handler(p) T_Pos((T_Cat(p))->object.rcatch.handler) +#define catch_set_handler(p, val) (T_Cat(p))->object.rcatch.handler = T_Pos(val) + +#define catch_all_goto_loc(p) (C_Let(p, L_CATCH))->object.envr.edat.ctall.goto_loc +#define catch_all_set_goto_loc(p, L) (S_Let(p, L_CATCH))->object.envr.edat.ctall.goto_loc = L +#define catch_all_op_loc(p) (C_Let(p, L_CATCH))->object.envr.edat.ctall.op_stack_loc +#define catch_all_set_op_loc(p, L) (S_Let(p, L_CATCH))->object.envr.edat.ctall.op_stack_loc = L + +#define dynamic_wind_state(p) (T_Dyn(p))->object.winder.state +#define dynamic_wind_in(p) (T_Dyn(p))->object.winder.in +#define dynamic_wind_out(p) (T_Dyn(p))->object.winder.out +#define dynamic_wind_body(p) (T_Dyn(p))->object.winder.body + +#define is_c_object(p) (type(p) == T_C_OBJECT) +#define c_object_value(p) (T_Obj(p))->object.c_obj.value +#define c_object_type(p) (T_Obj(p))->object.c_obj.type +#define c_object_let(p) T_Lid((T_Obj(p))->object.c_obj.e) +#define c_object_set_let(p, L) (T_Obj(p))->object.c_obj.e = T_Lid(L) +#define c_object_s7(p) (T_Obj(p))->object.c_obj.sc + +#define c_object_info(Sc, p) Sc->c_object_types[c_object_type(T_Obj(p))] +#define c_object_free(Sc, p) c_object_info(Sc, p)->free +#define c_object_mark(Sc, p) c_object_info(Sc, p)->mark +#define c_object_gc_mark(Sc, p) c_object_info(Sc, p)->gc_mark +#define c_object_gc_free(Sc, p) c_object_info(Sc, p)->gc_free +#define c_object_ref(Sc, p) c_object_info(Sc, p)->ref +#define c_object_getf(Sc, p) c_object_info(Sc, p)->getter +#define c_object_set(Sc, p) c_object_info(Sc, p)->set +#define c_object_setf(Sc, p) c_object_info(Sc, p)->setter +#if (!DISABLE_DEPRECATED) +#define c_object_print(Sc, p) c_object_info(Sc, p)->print +#endif +#define c_object_len(Sc, p) c_object_info(Sc, p)->length +#define c_object_eql(Sc, p) c_object_info(Sc, p)->eql +#define c_object_equal(Sc, p) c_object_info(Sc, p)->equal +#define c_object_equivalent(Sc, p) c_object_info(Sc, p)->equivalent +#define c_object_fill(Sc, p) c_object_info(Sc, p)->fill +#define c_object_copy(Sc, p) c_object_info(Sc, p)->copy +#define c_object_reverse(Sc, p) c_object_info(Sc, p)->reverse +#define c_object_to_list(Sc, p) c_object_info(Sc, p)->to_list +#define c_object_to_string(Sc, p) c_object_info(Sc, p)->to_string +#define c_object_scheme_name(Sc, p) T_Str(c_object_info(Sc, p)->scheme_name) + +#define c_pointer(p) (T_Ptr(p))->object.cptr.c_pointer +#define c_pointer_type(p) (T_Ptr(p))->object.cptr.c_type +#define c_pointer_info(p) (T_Ptr(p))->object.cptr.info +#define c_pointer_weak1(p) (T_Ptr(p))->object.cptr.weak1 +#define c_pointer_weak2(p) (T_Ptr(p))->object.cptr.weak2 +#define c_pointer_set_weak1(p, q) (T_Ptr(p))->object.cptr.weak1 = T_Pos(q) +#define c_pointer_set_weak2(p, q) (T_Ptr(p))->object.cptr.weak2 = T_Pos(q) +#define is_c_pointer(p) (type(p) == T_C_POINTER) + +#define is_counter(p) (type(p) == T_COUNTER) +#define counter_result(p) (T_Ctr(p))->object.ctr.result +#define counter_set_result(p, Val) (T_Ctr(p))->object.ctr.result = T_Pos(Val) +#define counter_list(p) (T_Ctr(p))->object.ctr.list +#define counter_set_list(p, Val) (T_Ctr(p))->object.ctr.list = T_Pos(Val) +#define counter_capture(p) (T_Ctr(p))->object.ctr.cap +#define counter_set_capture(p, Val) (T_Ctr(p))->object.ctr.cap = Val +#define counter_let(p) T_Lid((T_Ctr(p))->object.ctr.env) +#define counter_set_let(p, L) (T_Ctr(p))->object.ctr.env = T_Lid(L) +#define counter_slots(p) T_Sln(T_Ctr(p)->object.ctr.slots) +#define counter_set_slots(p, Val) (T_Ctr(p))->object.ctr.slots = T_Sln(Val) + +#if __cplusplus && HAVE_COMPLEX_NUMBERS +using namespace std; /* the code has to work in C as well as C++, so we can't scatter std:: all over the place */ +typedef complex s7_complex; +static s7_double Real(complex x) +{ + return (real(x)); +} /* protect the C++ name */ + +static s7_double Imag(complex x) +{ + return (imag(x)); +} +#endif + +#define integer(p) (T_Int(p))->object.number.integer_value +#define set_integer(p, x) integer(p) = x +#define real(p) (T_Rel(p))->object.number.real_value +#define set_real(p, x) real(p) = x +#define numerator(p) (T_Frc(p))->object.number.fraction_value.numerator +#define denominator(p) (T_Frc(p))->object.number.fraction_value.denominator +#define fraction(p) (((long_double)numerator(p)) / ((long_double)denominator(p))) +#define inverted_fraction(p) (((long_double)denominator(p)) / ((long_double)numerator(p))) +#define real_part(p) (T_Cmp(p))->object.number.complex_value.rl +#define set_real_part(p, x) real_part(p) = x +#define imag_part(p) (T_Cmp(p))->object.number.complex_value.im +#define set_imag_part(p, x) imag_part(p) = x +#if HAVE_COMPLEX_NUMBERS +#define to_c_complex(p) CMPLX(real_part(p), imag_part(p)) +#endif + +#if WITH_GMP +#define big_integer(p) ((T_Bgi(p))->object.number.bgi->n) +#define big_integer_nxt(p) (p)->object.number.bgi->nxt +#define big_integer_bgi(p) (p)->object.number.bgi +#define big_ratio(p) ((T_Bgf(p))->object.number.bgr->q) +#define big_ratio_nxt(p) (p)->object.number.bgr->nxt +#define big_ratio_bgr(p) (p)->object.number.bgr +#define big_real(p) ((T_Bgr(p))->object.number.bgf->x) +#define big_real_nxt(p) (p)->object.number.bgf->nxt +#define big_real_bgf(p) (p)->object.number.bgf +#define big_complex(p) ((T_Bgz(p))->object.number.bgc->z) +#define big_complex_nxt(p) (p)->object.number.bgc->nxt +#define big_complex_bgc(p) (p)->object.number.bgc +#endif + +#if S7_DEBUGGING +static void set_type_1(s7_pointer p, uint64_t f, const char *func, + int line) +{ + p->previous_alloc_line = p->current_alloc_line; + p->previous_alloc_func = p->current_alloc_func; + p->previous_alloc_type = p->current_alloc_type; + p->current_alloc_line = line; + p->current_alloc_func = func; + p->current_alloc_type = f; + p->explicit_free_line = 0; + p->uses++; + if (((f) & TYPE_MASK) == T_FREE) + fprintf(stderr, "%d: set free, %p type to %" PRIx64 "\n", __LINE__, + p, (int64_t) (f)); + else if (((f) & TYPE_MASK) >= NUM_TYPES) + fprintf(stderr, "%d: set invalid type, %p type to %" PRIx64 "\n", + __LINE__, p, (int64_t) (f)); + else { + if (((full_type(p) & T_IMMUTABLE) != 0) + && ((full_type(p) != (uint64_t) (f)))) { + fprintf(stderr, + "%s[%d]: set immutable %p type %d to %" ld64 "\n", + __func__, __LINE__, p, unchecked_type(p), + (int64_t) (f)); + abort(); + } + if (((full_type(p) & T_UNHEAP) != 0) && (((f) & T_UNHEAP) == 0)) + fprintf(stderr, "%s[%d]: clearing unheap in set type!\n", + __func__, __LINE__); + } + full_type(p) = f; +} +#endif + +#define number_name(p) (char *)((T_Num(p))->object.number_name.name + 1) +#define number_name_length(p) (T_Num(p))->object.number_name.name[0] + +static void set_number_name(s7_pointer p, const char *name, int32_t len) +{ + /* if no number name: teq +110 tread +30 tform +90 */ + if ((len >= 0) && (len < NUMBER_NAME_SIZE) && (!is_mutable_number(p))) { + set_has_number_name(p); + number_name_length(p) = (uint8_t) len; + memcpy((void *) number_name(p), (void *) name, len); + (number_name(p))[len] = 0; + } +} + +static s7_int s7_int_min = 0; +static int32_t s7_int_digits_by_radix[17]; + +#define S7_INT_BITS 63 + +#define S7_INT64_MAX 9223372036854775807LL +#define S7_INT64_MIN (int64_t)(-S7_INT64_MAX - 1LL) + +#define S7_INT32_MAX 2147483647LL +#define S7_INT32_MIN (-S7_INT32_MAX - 1LL) + +static void init_int_limits(void) +{ + int32_t i; +#if WITH_GMP +#define S7_LOG_INT64_MAX 36.736800 +#else + /* actually not safe = (log (- (expt 2 63) 1)) and (log (- (expt 2 31) 1)) (using 63 and 31 bits) */ +#define S7_LOG_INT64_MAX 43.668274 +#endif + + s7_int_min = S7_INT64_MIN; /* see comment in s7_make_ratio -- we're trying to hack around a gcc bug (9.2.1 Ubuntu) */ + s7_int_digits_by_radix[0] = 0; + s7_int_digits_by_radix[1] = 0; + for (i = 2; i < 17; i++) + s7_int_digits_by_radix[i] = + (int32_t) (floor(S7_LOG_INT64_MAX / log((double) i))); +} + +static s7_pointer make_permanent_integer_unchecked(s7_int i) +{ + s7_pointer p; + p = (s7_pointer) Calloc(1, sizeof(s7_cell)); + set_type_bit(p, T_IMMUTABLE | T_INTEGER | T_UNHEAP); + integer(p) = i; + return (p); +} + +#define NUM_CHARS 256 + +#ifndef NUM_SMALL_INTS +#define NUM_SMALL_INTS 8192 + /* 65536: tshoot -6, tvect -50, dup -26, trclo -27, tmap -48, tsort -14, tlet -16, trec -58, thash -40 */ +#else +#if (NUM_SMALL_INTS < NUM_CHARS) /* g_char_to_integer assumes this is at least NUM_CHARS */ +#error num_small_ints is less than num_chars which will not work +#endif +#endif + +static s7_pointer *small_ints = NULL; +#define small_int(Val) small_ints[Val] +#define is_small_int(n) ((n & ~(NUM_SMALL_INTS - 1)) == 0) /* ((n >= 0) && (n < NUM_SMALL_INTS)) is slower */ + +static s7_pointer real_zero, real_NaN, complex_NaN, real_pi, real_one, + arity_not_set, max_arity, real_infinity, real_minus_infinity; +static s7_pointer int_zero, int_one, int_two, int_three, minus_one, + minus_two, mostfix, leastfix; + +static void init_small_ints(void) +{ + const char *ones[10] = + { "0", "1", "2", "3", "4", "5", "6", "7", "8", "9" }; + s7_cell *cells; + int32_t i; + small_ints = + (s7_pointer *) malloc(NUM_SMALL_INTS * sizeof(s7_pointer)); + cells = (s7_cell *) calloc((NUM_SMALL_INTS), sizeof(s7_cell)); + for (i = 0; i < NUM_SMALL_INTS; i++) { + s7_pointer p; + small_ints[i] = &cells[i]; + p = small_ints[i]; + set_type_bit(p, T_IMMUTABLE | T_INTEGER | T_UNHEAP); + integer(p) = i; + } + for (i = 0; i < 10; i++) + set_number_name(small_ints[i], ones[i], 1); + + /* setup a few other numbers while we're here */ +#define EXTRA_NUMBERS 11 + cells = (s7_cell *) calloc(EXTRA_NUMBERS, sizeof(s7_cell)); + +#define init_real(Ptr, Num, Name, Name_Len) do {set_full_type(Ptr, T_REAL | T_IMMUTABLE | T_UNHEAP); set_real(Ptr, Num); set_number_name(Ptr, Name, Name_Len);} while (0) +#define init_real_no_name(Ptr, Num) do {set_full_type(Ptr, T_REAL | T_IMMUTABLE | T_UNHEAP); set_real(Ptr, Num);} while (0) +#define init_complex(Ptr, Real, Imag, Name, Name_Len) \ + do {set_full_type(Ptr, T_COMPLEX | T_IMMUTABLE | T_UNHEAP); set_real_part(Ptr, Real); set_imag_part(Ptr, Imag); set_number_name(Ptr, Name, Name_Len);} while (0) + + real_zero = &cells[0]; + init_real(real_zero, 0.0, "0.0", 3); + real_one = &cells[1]; + init_real(real_one, 1.0, "1.0", 3); + real_NaN = &cells[2]; + init_real(real_NaN, NAN, "+nan.0", 6); + complex_NaN = &cells[10]; + init_complex(complex_NaN, NAN, NAN, "+nan.0+nan.0i", 13); + real_infinity = &cells[3]; + init_real(real_infinity, INFINITY, "+inf.0", 6); + real_minus_infinity = &cells[4]; + init_real(real_minus_infinity, -INFINITY, "-inf.0", 6); + real_pi = &cells[5]; + init_real_no_name(real_pi, 3.1415926535897932384626433832795029L); + +#define init_integer(Ptr, Num, Name, Name_Len) do {set_full_type(Ptr, T_INTEGER | T_IMMUTABLE | T_UNHEAP); set_integer(Ptr, Num); set_number_name(Ptr, Name, Name_Len);} while (0) +#define init_integer_no_name(Ptr, Num) do {set_full_type(Ptr, T_INTEGER | T_IMMUTABLE | T_UNHEAP); set_integer(Ptr, Num);} while (0) + + arity_not_set = &cells[6]; + init_integer_no_name(arity_not_set, CLOSURE_ARITY_NOT_SET); + max_arity = &cells[7]; + init_integer_no_name(max_arity, MAX_ARITY); + minus_one = &cells[8]; + init_integer(minus_one, -1, "-1", 2); + minus_two = &cells[9]; + init_integer(minus_two, -2, "-2", 2); + int_zero = small_ints[0]; + int_one = small_ints[1]; + int_two = small_ints[2]; + int_three = small_ints[3]; + + mostfix = make_permanent_integer_unchecked(S7_INT64_MAX); + leastfix = make_permanent_integer_unchecked(s7_int_min); + set_number_name(mostfix, "9223372036854775807", 19); + set_number_name(leastfix, "-9223372036854775808", 20); +} + +/* -------------------------------------------------------------------------------- */ +#if (defined(__FreeBSD__)) || ((defined(__linux__)) && (__GLIBC__ >= 2) && (__GLIBC_MINOR__ > 17)) || (defined(__OpenBSD__)) || (defined(__NetBSD__)) +static inline s7_int my_clock(void) +{ + struct timespec ts; + clock_gettime(CLOCK_MONOTONIC, &ts); + /* coarse: 0.057u 0.007s, monotonic: 0.083u 0.007s, clock(): 0.624u 0.372s -- coarse since Linux 2.6.32, glibc > 2.17 + * FreeBSD has CLOCK_MONOTONIC_FAST in place of COARSE, OpenBSD and netBSD have neither + * clock_getres places 1 in tv_nsec in linux, so I assume I divide billion/tv_nsec + * MacOSX has clock_get_time, and after Sierra 10.12 has clock_gettime + * apparently we include /usr/include/AvailabilityMacros.h, then #if MAC_OS_X_VERSION_MIN_REQUIRED >= MAC_OS_X_VERSION_10_12 + * Windows has QueryPerformanceCounter or something + * maybe just check for POSIX compatibility? + */ + return (ts.tv_sec * 1000000000 + ts.tv_nsec); /* accumulated into s7_int so this should be ok: s7.h gives it 64 bits */ +} + +static s7_int ticks_per_second(void) +{ + struct timespec ts; + clock_getres(CLOCK_MONOTONIC, &ts); + return ((ts.tv_nsec == 0) ? 1000000000 : (1000000000 / ts.tv_nsec)); +} +#else +#define my_clock clock +#define ticks_per_second() CLOCKS_PER_SEC +#endif + +#ifndef GC_TRIGGER_SIZE +#define GC_TRIGGER_SIZE 64 +#endif + +#if S7_DEBUGGING +static void try_to_call_gc_1(s7_scheme * sc, const char *func, int line); +#define try_to_call_gc(Sc) try_to_call_gc_1(Sc, __func__, __LINE__) +#else +static void try_to_call_gc(s7_scheme * sc); +#endif + +#define GC_STATS 1 +#define HEAP_STATS 2 +#define STACK_STATS 4 +#define PROTECTED_OBJECTS_STATS 8 + +#define show_gc_stats(Sc) ((Sc->gc_stats & GC_STATS) != 0) +#define show_stack_stats(Sc) ((Sc->gc_stats & STACK_STATS) != 0) +#define show_heap_stats(Sc) ((Sc->gc_stats & HEAP_STATS) != 0) +#define show_protected_objects_stats(Sc) ((Sc->gc_stats & PROTECTED_OBJECTS_STATS) != 0) + + +/* new_cell has to include the new cell's type. In the free list, it is 0 (T_FREE). If we remove it here, + * but then hit some error before setting the type, the GC sweep thinks it is a free cell already and + * does not return it to the free list: a memory leak. + */ +#if (!S7_DEBUGGING) +#define new_cell(Sc, Obj, Type) \ + do { \ + if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \ + Obj = (*(--(Sc->free_heap_top))); \ + set_full_type(Obj, Type); \ + } while (0) + +#define new_cell_no_check(Sc, Obj, Type) do {Obj = (*(--(Sc->free_heap_top))); set_full_type(Obj, Type);} while (0) + /* since sc->free_heap_trigger is GC_TRIGGER_SIZE above the free heap base, we don't need + * to check it repeatedly after the first such check. + */ +#else + +#define new_cell(Sc, Obj, Type) \ + do { \ + if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \ + Obj = (*(--(Sc->free_heap_top))); \ + Obj->debugger_bits = 0; Obj->gc_func = NULL; \ + set_full_type(Obj, Type); \ + } while (0) + +#define new_cell_no_check(Sc, Obj, Type) \ + do { \ + Obj = (*(--(Sc->free_heap_top))); \ + if (Sc->free_heap_top < Sc->free_heap) {fprintf(stderr, "free heap exhausted\n"); abort();}\ + Obj->debugger_bits = 0; Obj->gc_func = NULL; \ + set_full_type(Obj, Type); \ + } while (0) +#endif + +/* #define gc_if_at_trigger(Sc) if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc) */ + +#if WITH_GCC +#define make_integer(Sc, N) ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell(Sc, _I_, T_INTEGER); integer(_I_) = _N_; _I_;}) ); }) +#define make_real(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;}) +#define make_real_unchecked(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell_no_check(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;}) + +#define make_complex_not_0i(Sc, R, I) ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, I); _C_;}) +#define make_complex(Sc, R, I) \ + ({ s7_double _im_; _im_ = (I); ((_im_ == 0.0) ? make_real(Sc, R) : \ + ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, _im_); _C_;}) ); }) + +#define real_to_double(Sc, X, Caller) ({ s7_pointer _x_; _x_ = (X); ((type(_x_) == T_REAL) ? real(_x_) : s7_number_to_real_with_caller(Sc, _x_, Caller)); }) +#define rational_to_double(Sc, X) ({ s7_pointer _x_; _x_ = (X); ((type(_x_) == T_INTEGER) ? (s7_double)integer(_x_) : fraction(_x_)); }) + +#else + +#define make_integer(Sc, N) s7_make_integer(Sc, N) +#define make_real(Sc, X) s7_make_real(Sc, X) +#define make_real_unchecked(Sc, X) s7_make_real(Sc, X) +#define make_complex(Sc, R, I) s7_make_complex(Sc, R, I) +#define make_complex_not_0i(Sc, R, I) s7_make_complex(Sc, R, I) +#define real_to_double(Sc, X, Caller) s7_number_to_real_with_caller(Sc, X, Caller) +#define rational_to_double(Sc, X) s7_number_to_real(Sc, X) +#endif + +static inline s7_pointer wrap_integer1(s7_scheme * sc, s7_int x) +{ + if (is_small_int(x)) + return (small_int(x)); + integer(sc->integer_wrapper1) = x; + return (sc->integer_wrapper1); +} + +static inline s7_pointer wrap_integer2(s7_scheme * sc, s7_int x) +{ + if (is_small_int(x)) + return (small_int(x)); + integer(sc->integer_wrapper2) = x; + return (sc->integer_wrapper2); +} + +static inline s7_pointer wrap_integer3(s7_scheme * sc, s7_int x) +{ + if (is_small_int(x)) + return (small_int(x)); + integer(sc->integer_wrapper3) = x; + return (sc->integer_wrapper3); +} + +static inline s7_pointer wrap_real1(s7_scheme * sc, s7_double x) +{ + real(sc->real_wrapper1) = x; + return (sc->real_wrapper1); +} + +static inline s7_pointer wrap_real2(s7_scheme * sc, s7_double x) +{ + real(sc->real_wrapper2) = x; + return (sc->real_wrapper2); +} + + +/* -------------------------------------------------------------------------------- + * local versions of some standard C library functions + * timing tests involving these are very hard to interpret, local_memset is faster using int64_t than int32_t + */ + +static void local_memset(void *s, uint8_t val, size_t n) +{ + uint8_t *s2; +#if S7_ALIGNED + s2 = (uint8_t *) s; +#else +#if (defined(__x86_64__) || defined(__i386__)) + if (n >= 8) { + int64_t ival; + int64_t *s1 = (int64_t *) s; + size_t n8 = n >> 3; + ival = val | (val << 8) | (val << 16) | (((uint64_t) val) << 24); /* uint64_t casts make gcc/clang/fsanitize happy */ + ival = (((uint64_t) ival) << 32) | ival; + do { + *s1++ = ival; + } while (--n8 > 0); + n &= 7; + s2 = (uint8_t *) s1; + } else + s2 = (uint8_t *) s; +#else + s2 = (uint8_t *) s; +#endif +#endif + while (n > 0) { + *s2++ = val; + n--; + } +} + +static inline s7_int safe_strlen(const char *str) +{ + /* this is safer than strlen, and slightly faster */ + const char *tmp = str; + if ((!tmp) || (!(*tmp))) + return (0); + for (; *tmp; ++tmp); + return (tmp - str); +} + +static char *copy_string_with_length(const char *str, s7_int len) +{ + char *newstr; +#if S7_DEBUGGING + if ((len <= 0) || (!str)) + fprintf(stderr, "%s[%d]: len: %" ld64 ", str: %s\n", __func__, + __LINE__, len, str); +#endif + if (len > (1LL << 48)) + return (NULL); /* squelch an idiotic warning */ + newstr = (char *) Malloc(len + 1); + if (len != 0) + memcpy((void *) newstr, (void *) str, len); + newstr[len] = '\0'; + return (newstr); +} + +static char *copy_string(const char *str) +{ + return (copy_string_with_length(str, safe_strlen(str))); +} + +static bool local_strcmp(const char *s1, const char *s2) +{ + while (true) { + if (*s1 != *s2++) + return (false); + if (*s1++ == 0) + return (true); + } + return (true); +} + +#define c_strings_are_equal(Str1, Str2) (local_strcmp(Str1, Str2)) +/* scheme strings can have embedded nulls. */ + +static bool safe_strcmp(const char *s1, const char *s2) +{ + if ((!s1) || (!s2)) + return (s1 == s2); + return (local_strcmp(s1, s2)); +} + +static bool local_strncmp(const char *s1, const char *s2, size_t n) +{ +#if ((!S7_ALIGNED) && (defined(__x86_64__) || defined(__i386__))) /* unaligned accesses are safe on i386 hardware, sez everyone */ + if (n >= 8) { + size_t n8 = n >> 3; + int64_t *is1 = (int64_t *) s1, *is2 = (int64_t *) s2; + do { + if (*is1++ != *is2++) + return (false); + } while (--n8 > 0); + s1 = (const char *) is1; + s2 = (const char *) is2; + n &= 7; + } +#endif + while (n > 0) { + if (*s1++ != *s2++) + return (false); + n--; + } + return (true); +} + +#define strings_are_equal_with_length(Str1, Str2, Len) (local_strncmp(Str1, Str2, Len)) + +static Sentinel size_t catstrs(char *dst, size_t len, ...) +{ /* NULL-terminated arg list */ + const char *s, *dend; + char *d = dst; + va_list ap; + dend = (const char *) (dst + len - 1); /* -1 for null at end? */ + while ((*d) && (d < dend)) + d++; /* stop at NULL or end-of-buffer */ + va_start(ap, len); + for (s = va_arg(ap, const char *); s != NULL; + s = va_arg(ap, const char *)) + while ((*s) && (d < dend)) { + *d++ = *s++; + } + *d = '\0'; + va_end(ap); + return (d - dst); +} + +static Sentinel size_t catstrs_direct(char *dst, const char *s1, ...) +{ /* NULL-terminated arg list, dst is destination only (assumed empty), all args known to fit in dst */ + const char *s; + char *d = dst; + va_list ap; + va_start(ap, s1); + for (s = s1; s != NULL; s = va_arg(ap, const char *)) + while (*s) { + *d++ = *s++; + } + *d = '\0'; + va_end(ap); + return (d - dst); +} + +static char *pos_int_to_str(s7_scheme * sc, s7_int num, s7_int * len, + char endc) +{ + char *p, *op; + p = (char *) (sc->int_to_str3 + INT_TO_STR_SIZE - 1); + op = p; + *p-- = '\0'; + if (endc != '\0') + *p-- = endc; + do { + *p-- = "0123456789"[num % 10]; + num /= 10; + } while (num); + (*len) = op - p; /* this includes the trailing #\null */ + return ((char *) (p + 1)); +} + +static char *pos_int_to_str_direct(s7_scheme * sc, s7_int num) +{ + char *p; + p = (char *) (sc->int_to_str4 + INT_TO_STR_SIZE - 1); + *p-- = '\0'; + do { + *p-- = "0123456789"[num % 10]; + num /= 10; + } while (num); + return ((char *) (p + 1)); +} + +static char *pos_int_to_str_direct_1(s7_scheme * sc, s7_int num) +{ + char *p; + p = (char *) (sc->int_to_str5 + INT_TO_STR_SIZE - 1); + *p-- = '\0'; + do { + *p-- = "0123456789"[num % 10]; + num /= 10; + } while (num); + return ((char *) (p + 1)); +} + +#if S7_DEBUGGING && WITH_GCC +static s7_pointer lookup_1(s7_scheme * sc, s7_pointer symbol); +#define lookup(Sc, Sym) check_null_sym(Sc, lookup_1(Sc, Sym), Sym, __LINE__, __func__) +static s7_pointer check_null_sym(s7_scheme * sc, s7_pointer p, + s7_pointer sym, int32_t line, + const char *func); +#define lookup_unexamined(Sc, Sym) lookup_1(Sc, Sym) +#else +static inline s7_pointer lookup(s7_scheme * sc, s7_pointer symbol); +#define lookup_unexamined(Sc, Sym) lookup(Sc, Sym) +#endif + +#if WITH_GCC +#if S7_DEBUGGING +#define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup_1(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));}) +#else +#define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));}) +#endif +#else +#define lookup_checked(Sc, Sym) lookup(Sc, Sym) +#endif + +static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e); +static s7_pointer object_to_truncated_string(s7_scheme * sc, s7_pointer p, + s7_int len); +static s7_pointer wrap_string(s7_scheme * sc, const char *str, s7_int len); +static s7_pointer cons_unchecked(s7_scheme * sc, s7_pointer a, + s7_pointer b); +static s7_pointer unbound_variable(s7_scheme * sc, s7_pointer sym); +static s7_pointer find_method_with_let(s7_scheme * sc, s7_pointer let, + s7_pointer symbol); +static const char *type_name(s7_scheme * sc, s7_pointer arg, + article_t article); + +static s7_pointer simple_wrong_type_arg_error_prepackaged(s7_scheme * sc, + s7_pointer + caller, + s7_pointer arg, + s7_pointer + typnam, + s7_pointer + descr); +static s7_pointer wrong_type_arg_error_prepackaged(s7_scheme * sc, + s7_pointer caller, + s7_pointer arg_n, + s7_pointer arg, + s7_pointer typnam, + s7_pointer descr); +static s7_pointer out_of_range_error_prepackaged(s7_scheme * sc, + s7_pointer caller, + s7_pointer arg_n, + s7_pointer arg, + s7_pointer descr); +static s7_pointer simple_out_of_range_error_prepackaged(s7_scheme * sc, + s7_pointer caller, + s7_pointer arg, + s7_pointer descr); + +/* putting off the type description until s7_error via the sc->unused marker below makes it possible + * for gcc to speed up the functions that call these as tail-calls. 1-2% overall speedup! + */ +#define simple_wrong_type_argument(Sc, Caller, Arg, Desired_Type) \ + simple_wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), Arg, Sc->unused, Sc->prepackaged_type_names[Desired_Type]) + +#define wrong_type_argument(Sc, Caller, Num, Arg, Desired_Type) \ + wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), make_integer(Sc, Num), Arg, Sc->unused, Sc->prepackaged_type_names[Desired_Type]) + +#define simple_wrong_type_argument_with_type(Sc, Caller, Arg, Type) \ + simple_wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), Arg, Sc->unused, Type) + +#define wrong_type_argument_with_type(Sc, Caller, Num, Arg, Type) \ + wrong_type_arg_error_prepackaged(Sc, symbol_name_cell(Caller), make_integer(Sc, Num), Arg, Sc->unused, Type) + +#define simple_out_of_range(Sc, Caller, Arg, Description) simple_out_of_range_error_prepackaged(Sc, symbol_name_cell(Caller), Arg, Description) +#define out_of_range(Sc, Caller, Arg_Num, Arg, Description) out_of_range_error_prepackaged(Sc, symbol_name_cell(Caller), Arg_Num, Arg, Description) + + +/* ---------------- evaluator ops ---------------- */ + +/* C=constant, S=symbol, A=fx-callable, Q=quote, N=any number of next >= 1, FX=list of A's, P=parlous?, O=one form, M=multiform */ +enum { OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_protect used below as boundary marker */ + + OP_SAFE_C_NC, HOP_SAFE_C_NC, OP_SAFE_C_S, HOP_SAFE_C_S, + OP_SAFE_C_SS, HOP_SAFE_C_SS, OP_SAFE_C_SC, HOP_SAFE_C_SC, OP_SAFE_C_CS, + HOP_SAFE_C_CS, OP_SAFE_C_CQ, HOP_SAFE_C_CQ, + OP_SAFE_C_SSS, HOP_SAFE_C_SSS, OP_SAFE_C_SCS, HOP_SAFE_C_SCS, + OP_SAFE_C_SSC, HOP_SAFE_C_SSC, OP_SAFE_C_CSS, HOP_SAFE_C_CSS, + OP_SAFE_C_SCC, HOP_SAFE_C_SCC, OP_SAFE_C_CSC, HOP_SAFE_C_CSC, + OP_SAFE_C_CCS, HOP_SAFE_C_CCS, + OP_SAFE_C_NS, HOP_SAFE_C_NS, OP_SAFE_C_opNCq, HOP_SAFE_C_opNCq, + OP_SAFE_C_opSq, HOP_SAFE_C_opSq, + OP_SAFE_C_opSSq, HOP_SAFE_C_opSSq, OP_SAFE_C_opSCq, HOP_SAFE_C_opSCq, + OP_SAFE_C_opCSq, HOP_SAFE_C_opCSq, OP_SAFE_C_S_opSq, HOP_SAFE_C_S_opSq, + OP_SAFE_C_C_opSCq, HOP_SAFE_C_C_opSCq, OP_SAFE_C_S_opSCq, + HOP_SAFE_C_S_opSCq, OP_SAFE_C_S_opCSq, HOP_SAFE_C_S_opCSq, + OP_SAFE_C_opSq_S, HOP_SAFE_C_opSq_S, OP_SAFE_C_opSq_C, + HOP_SAFE_C_opSq_C, + OP_SAFE_C_opSq_opSq, HOP_SAFE_C_opSq_opSq, OP_SAFE_C_S_opSSq, + HOP_SAFE_C_S_opSSq, OP_SAFE_C_C_opSq, HOP_SAFE_C_C_opSq, + OP_SAFE_C_opCSq_C, HOP_SAFE_C_opCSq_C, OP_SAFE_C_opSSq_C, + HOP_SAFE_C_opSSq_C, OP_SAFE_C_C_opSSq, HOP_SAFE_C_C_opSSq, + OP_SAFE_C_opSSq_opSSq, HOP_SAFE_C_opSSq_opSSq, OP_SAFE_C_opSSq_opSq, + HOP_SAFE_C_opSSq_opSq, OP_SAFE_C_opSq_opSSq, HOP_SAFE_C_opSq_opSSq, + OP_SAFE_C_opSSq_S, HOP_SAFE_C_opSSq_S, OP_SAFE_C_opCSq_S, + HOP_SAFE_C_opCSq_S, OP_SAFE_C_opSCq_C, HOP_SAFE_C_opSCq_C, + OP_SAFE_C_op_opSSqq_S, HOP_SAFE_C_op_opSSqq_S, OP_SAFE_C_op_opSqq, + HOP_SAFE_C_op_opSqq, + OP_SAFE_C_op_S_opSqq, HOP_SAFE_C_op_S_opSqq, OP_SAFE_C_op_opSq_Sq, + HOP_SAFE_C_op_opSq_Sq, OP_SAFE_C_opSq_CS, HOP_SAFE_C_opSq_CS, + + OP_SAFE_C_A, HOP_SAFE_C_A, OP_SAFE_C_AA, HOP_SAFE_C_AA, OP_SAFE_C_SA, + HOP_SAFE_C_SA, OP_SAFE_C_AS, HOP_SAFE_C_AS, + OP_SAFE_C_CA, HOP_SAFE_C_CA, OP_SAFE_C_AC, HOP_SAFE_C_AC, + OP_SAFE_C_AAA, HOP_SAFE_C_AAA, OP_SAFE_C_4A, HOP_SAFE_C_4A, + OP_SAFE_C_NA, HOP_SAFE_C_NA, OP_SAFE_C_ALL_CA, HOP_SAFE_C_ALL_CA, + OP_SAFE_C_SSA, HOP_SAFE_C_SSA, OP_SAFE_C_SAS, HOP_SAFE_C_SAS, + OP_SAFE_C_SAA, HOP_SAFE_C_SAA, + OP_SAFE_C_CSA, HOP_SAFE_C_CSA, OP_SAFE_C_SCA, HOP_SAFE_C_SCA, + OP_SAFE_C_ASS, HOP_SAFE_C_ASS, + OP_SAFE_C_CAC, HOP_SAFE_C_CAC, OP_SAFE_C_AGG, HOP_SAFE_C_AGG, + OP_SAFE_C_opAq, HOP_SAFE_C_opAq, OP_SAFE_C_opAAq, HOP_SAFE_C_opAAq, + OP_SAFE_C_opAAAq, HOP_SAFE_C_opAAAq, + OP_SAFE_C_S_opAq, HOP_SAFE_C_S_opAq, OP_SAFE_C_opAq_S, + HOP_SAFE_C_opAq_S, + OP_SAFE_C_S_opAAq, HOP_SAFE_C_S_opAAq, OP_SAFE_C_S_opAAAq, + HOP_SAFE_C_S_opAAAq, + OP_SAFE_C_STAR, HOP_SAFE_C_STAR, OP_SAFE_C_STAR_A, HOP_SAFE_C_STAR_A, + OP_SAFE_C_STAR_AA, HOP_SAFE_C_STAR_AA, OP_SAFE_C_STAR_NA, + HOP_SAFE_C_STAR_NA, + OP_SAFE_C_P, HOP_SAFE_C_P, + + OP_THUNK, HOP_THUNK, OP_THUNK_ANY, HOP_THUNK_ANY, OP_SAFE_THUNK, + HOP_SAFE_THUNK, OP_SAFE_THUNK_A, HOP_SAFE_THUNK_A, + + OP_CLOSURE_S, HOP_CLOSURE_S, OP_CLOSURE_S_O, HOP_CLOSURE_S_O, + OP_CLOSURE_A, HOP_CLOSURE_A, OP_CLOSURE_A_O, HOP_CLOSURE_A_O, + OP_CLOSURE_P, HOP_CLOSURE_P, + OP_CLOSURE_AP, HOP_CLOSURE_AP, OP_CLOSURE_PA, HOP_CLOSURE_PA, + OP_CLOSURE_PP, HOP_CLOSURE_PP, + OP_CLOSURE_FA, HOP_CLOSURE_FA, OP_CLOSURE_SS, HOP_CLOSURE_SS, + OP_CLOSURE_SS_O, HOP_CLOSURE_SS_O, + OP_CLOSURE_SC, HOP_CLOSURE_SC, OP_CLOSURE_SC_O, HOP_CLOSURE_SC_O, + OP_CLOSURE_3S, HOP_CLOSURE_3S, OP_CLOSURE_4S, HOP_CLOSURE_4S, + OP_CLOSURE_AA, HOP_CLOSURE_AA, OP_CLOSURE_AA_O, HOP_CLOSURE_AA_O, + OP_CLOSURE_3A, HOP_CLOSURE_3A, OP_CLOSURE_4A, HOP_CLOSURE_4A, + OP_CLOSURE_NA, HOP_CLOSURE_NA, OP_CLOSURE_ASS, HOP_CLOSURE_ASS, + OP_CLOSURE_SAS, HOP_CLOSURE_SAS, OP_CLOSURE_AAS, HOP_CLOSURE_AAS, + OP_CLOSURE_SAA, HOP_CLOSURE_SAA, OP_CLOSURE_ASA, HOP_CLOSURE_ASA, + OP_CLOSURE_NS, HOP_CLOSURE_NS, + + OP_SAFE_CLOSURE_S, HOP_SAFE_CLOSURE_S, OP_SAFE_CLOSURE_S_O, + HOP_SAFE_CLOSURE_S_O, + OP_SAFE_CLOSURE_S_A, HOP_SAFE_CLOSURE_S_A, OP_SAFE_CLOSURE_S_TO_S, + HOP_SAFE_CLOSURE_S_TO_S, OP_SAFE_CLOSURE_S_TO_SC, + HOP_SAFE_CLOSURE_S_TO_SC, + OP_SAFE_CLOSURE_P, HOP_SAFE_CLOSURE_P, OP_SAFE_CLOSURE_P_A, + HOP_SAFE_CLOSURE_P_A, + OP_SAFE_CLOSURE_AP, HOP_SAFE_CLOSURE_AP, OP_SAFE_CLOSURE_PA, + HOP_SAFE_CLOSURE_PA, OP_SAFE_CLOSURE_PP, HOP_SAFE_CLOSURE_PP, + OP_SAFE_CLOSURE_A, HOP_SAFE_CLOSURE_A, OP_SAFE_CLOSURE_A_O, + HOP_SAFE_CLOSURE_A_O, OP_SAFE_CLOSURE_A_A, HOP_SAFE_CLOSURE_A_A, + OP_SAFE_CLOSURE_A_TO_SC, HOP_SAFE_CLOSURE_A_TO_SC, + OP_SAFE_CLOSURE_SS, HOP_SAFE_CLOSURE_SS, OP_SAFE_CLOSURE_SS_O, + HOP_SAFE_CLOSURE_SS_O, OP_SAFE_CLOSURE_SS_A, HOP_SAFE_CLOSURE_SS_A, + OP_SAFE_CLOSURE_SC, HOP_SAFE_CLOSURE_SC, OP_SAFE_CLOSURE_SC_O, + HOP_SAFE_CLOSURE_SC_O, + OP_SAFE_CLOSURE_AA, HOP_SAFE_CLOSURE_AA, OP_SAFE_CLOSURE_AA_O, + HOP_SAFE_CLOSURE_AA_O, OP_SAFE_CLOSURE_AA_A, HOP_SAFE_CLOSURE_AA_A, + OP_SAFE_CLOSURE_SAA, HOP_SAFE_CLOSURE_SAA, OP_SAFE_CLOSURE_SSA, + HOP_SAFE_CLOSURE_SSA, + OP_SAFE_CLOSURE_AGG, HOP_SAFE_CLOSURE_AGG, OP_SAFE_CLOSURE_3A, + HOP_SAFE_CLOSURE_3A, OP_SAFE_CLOSURE_NA, HOP_SAFE_CLOSURE_NA, + OP_SAFE_CLOSURE_3S, HOP_SAFE_CLOSURE_3S, OP_SAFE_CLOSURE_NS, + HOP_SAFE_CLOSURE_NS, + OP_SAFE_CLOSURE_3S_A, HOP_SAFE_CLOSURE_3S_A, + + OP_ANY_CLOSURE_3P, HOP_ANY_CLOSURE_3P, OP_ANY_CLOSURE_4P, + HOP_ANY_CLOSURE_4P, OP_ANY_CLOSURE_NA, HOP_ANY_CLOSURE_NA, + OP_ANY_CLOSURE_NP, HOP_ANY_CLOSURE_NP, + + OP_CLOSURE_STAR_A, HOP_CLOSURE_STAR_A, OP_CLOSURE_STAR_NA, + HOP_CLOSURE_STAR_NA, + OP_SAFE_CLOSURE_STAR_A, HOP_SAFE_CLOSURE_STAR_A, + OP_SAFE_CLOSURE_STAR_AA, HOP_SAFE_CLOSURE_STAR_AA, + OP_SAFE_CLOSURE_STAR_AA_O, HOP_SAFE_CLOSURE_STAR_AA_O, + OP_SAFE_CLOSURE_STAR_A1, HOP_SAFE_CLOSURE_STAR_A1, + OP_SAFE_CLOSURE_STAR_KA, HOP_SAFE_CLOSURE_STAR_KA, OP_CLOSURE_STAR_KA, + HOP_CLOSURE_STAR_KA, OP_SAFE_CLOSURE_STAR_3A, + HOP_SAFE_CLOSURE_STAR_3A, + OP_SAFE_CLOSURE_STAR_NA, HOP_SAFE_CLOSURE_STAR_NA, + OP_SAFE_CLOSURE_STAR_NA_0, HOP_SAFE_CLOSURE_STAR_NA_0, + OP_SAFE_CLOSURE_STAR_NA_1, HOP_SAFE_CLOSURE_STAR_NA_1, + OP_SAFE_CLOSURE_STAR_NA_2, HOP_SAFE_CLOSURE_STAR_NA_2, + + OP_CALL_WITH_EXIT, HOP_CALL_WITH_EXIT, OP_CALL_WITH_EXIT_O, + HOP_CALL_WITH_EXIT_O, + OP_C_CATCH, HOP_C_CATCH, OP_C_CATCH_ALL, HOP_C_CATCH_ALL, + OP_C_CATCH_ALL_O, HOP_C_CATCH_ALL_O, OP_C_CATCH_ALL_A, + HOP_C_CATCH_ALL_A, + OP_C_S_opSq, HOP_C_S_opSq, OP_C_SS, HOP_C_SS, OP_C_S, HOP_C_S, + OP_READ_S, HOP_READ_S, OP_C_P, HOP_C_P, OP_C_AP, HOP_C_AP, + OP_C_A, HOP_C_A, OP_C_AA, HOP_C_AA, OP_C, HOP_C, OP_C_NA, HOP_C_NA, + + OP_CL_S, HOP_CL_S, OP_CL_SS, HOP_CL_SS, OP_CL_A, HOP_CL_A, OP_CL_AA, + HOP_CL_AA, OP_CL_NA, HOP_CL_NA, + OP_CL_FA, HOP_CL_FA, OP_CL_SAS, HOP_CL_SAS, OP_CL_S_opSq, + HOP_CL_S_opSq, + + OP_SAFE_C_PP, HOP_SAFE_C_PP, OP_SAFE_C_FF, HOP_SAFE_C_FF, + OP_SAFE_C_opSq_P, HOP_SAFE_C_opSq_P, + OP_SAFE_C_SP, HOP_SAFE_C_SP, OP_SAFE_C_CP, HOP_SAFE_C_CP, + OP_SAFE_C_AP, HOP_SAFE_C_AP, OP_SAFE_C_PA, HOP_SAFE_C_PA, + OP_SAFE_C_PS, HOP_SAFE_C_PS, OP_SAFE_C_PC, HOP_SAFE_C_PC, + OP_SAFE_C_SSP, HOP_SAFE_C_SSP, OP_ANY_C_NP, HOP_ANY_C_NP, + OP_SAFE_C_3P, HOP_SAFE_C_3P, + /* end of h_opts */ + + OP_APPLY_SS, OP_APPLY_SA, OP_APPLY_SL, + OP_MACRO_D, OP_MACRO_STAR_D, + OP_WITH_IO, OP_WITH_IO_1, OP_WITH_OUTPUT_TO_STRING, OP_WITH_IO_C, + OP_CALL_WITH_OUTPUT_STRING, + OP_S, OP_S_S, OP_S_C, OP_S_A, OP_S_AA, OP_A_A, OP_A_AA, OP_P_S, + OP_P_S_1, OP_MAP_FOR_EACH_FA, OP_MAP_FOR_EACH_FAA, + OP_IMPLICIT_GOTO, OP_IMPLICIT_GOTO_A, OP_IMPLICIT_CONTINUATION_A, + OP_IMPLICIT_ITERATE, + OP_IMPLICIT_VECTOR_REF_A, OP_IMPLICIT_VECTOR_REF_AA, + OP_IMPLICIT_VECTOR_SET_3, OP_IMPLICIT_VECTOR_SET_4, + OP_IMPLICIT_STRING_REF_A, OP_IMPLICIT_C_OBJECT_REF_A, + OP_IMPLICIT_PAIR_REF_A, OP_IMPLICIT_PAIR_REF_AA, + OP_IMPLICIT_HASH_TABLE_REF_A, OP_IMPLICIT_LET_REF_C, + OP_IMPLICIT_LET_REF_A, OP_IMPLICIT_S7_LET_REF_S, + OP_IMPLICIT_S7_LET_SET_SA, + OP_UNKNOWN, OP_UNKNOWN_NS, OP_UNKNOWN_NA, OP_UNKNOWN_G, OP_UNKNOWN_GG, + OP_UNKNOWN_A, OP_UNKNOWN_AA, OP_UNKNOWN_NP, + + OP_SYM, OP_GLOBAL_SYM, OP_CON, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, + HOP_SSA_DIRECT, HOP_HASH_TABLE_INCREMENT, OP_CLEAR_OPTS, + + OP_READ_INTERNAL, OP_EVAL, + OP_EVAL_ARGS, OP_EVAL_ARGS1, OP_EVAL_ARGS2, OP_EVAL_ARGS3, + OP_EVAL_ARGS4, OP_EVAL_ARGS5, + OP_APPLY, OP_EVAL_MACRO, OP_LAMBDA, OP_QUOTE, OP_QUOTE_UNCHECKED, + OP_MACROEXPAND, OP_CALL_CC, + OP_DEFINE, OP_DEFINE1, OP_BEGIN, OP_BEGIN_HOOK, OP_BEGIN_NO_HOOK, + OP_BEGIN_UNCHECKED, OP_BEGIN_2_UNCHECKED, OP_BEGIN_NA, OP_BEGIN_AA, + OP_IF, OP_IF1, OP_WHEN, OP_UNLESS, OP_SET, OP_SET1, OP_SET2, + OP_LET, OP_LET1, OP_LET_STAR, OP_LET_STAR1, OP_LET_STAR2, + OP_LETREC, OP_LETREC1, OP_LETREC_STAR, OP_LETREC_STAR1, + OP_LET_TEMPORARILY, OP_LET_TEMP_UNCHECKED, OP_LET_TEMP_INIT1, + OP_LET_TEMP_INIT2, OP_LET_TEMP_DONE, OP_LET_TEMP_DONE1, + OP_LET_TEMP_S7, OP_LET_TEMP_FX, OP_LET_TEMP_FX_1, OP_LET_TEMP_SETTER, + OP_LET_TEMP_UNWIND, OP_LET_TEMP_S7_UNWIND, + OP_LET_TEMP_SETTER_UNWIND, + OP_LET_TEMP_A_A, + OP_COND, OP_COND1, OP_FEED_TO_1, OP_COND_SIMPLE, OP_COND1_SIMPLE, + OP_COND_SIMPLE_O, OP_COND1_SIMPLE_O, + OP_AND, OP_OR, + OP_DEFINE_MACRO, OP_DEFINE_MACRO_STAR, OP_DEFINE_EXPANSION, + OP_DEFINE_EXPANSION_STAR, OP_MACRO, OP_MACRO_STAR, + OP_CASE, + OP_READ_LIST, OP_READ_NEXT, OP_READ_DOT, OP_READ_QUOTE, + OP_READ_QUASIQUOTE, OP_READ_UNQUOTE, OP_READ_APPLY_VALUES, + OP_READ_VECTOR, OP_READ_BYTE_VECTOR, OP_READ_INT_VECTOR, + OP_READ_FLOAT_VECTOR, OP_READ_DONE, + OP_LOAD_RETURN_IF_EOF, OP_LOAD_CLOSE_AND_POP_IF_EOF, OP_EVAL_DONE, + OP_SPLICE_VALUES, OP_NO_VALUES, OP_FLUSH_VALUES, + OP_CATCH, OP_DYNAMIC_WIND, OP_DYNAMIC_UNWIND, + OP_DYNAMIC_UNWIND_PROFILE, OP_PROFILE_IN, + OP_DEFINE_CONSTANT, OP_DEFINE_CONSTANT1, + OP_DO, OP_DO_END, OP_DO_END1, OP_DO_STEP, OP_DO_STEP2, OP_DO_INIT, + OP_DEFINE_STAR, OP_LAMBDA_STAR, OP_LAMBDA_STAR_DEFAULT, OP_ERROR_QUIT, + OP_UNWIND_INPUT, OP_UNWIND_OUTPUT, + OP_ERROR_HOOK_QUIT, + OP_WITH_LET, OP_WITH_LET1, OP_WITH_LET_UNCHECKED, OP_WITH_LET_S, + OP_WITH_UNLET_S, + OP_WITH_BAFFLE, OP_WITH_BAFFLE_UNCHECKED, OP_EXPANSION, + OP_FOR_EACH, OP_FOR_EACH_1, OP_FOR_EACH_2, OP_FOR_EACH_3, + OP_MAP, OP_MAP_1, OP_MAP_2, OP_MAP_GATHER, OP_MAP_GATHER_1, + OP_MAP_GATHER_2, OP_MAP_GATHER_3, + OP_BARRIER, OP_DEACTIVATE_GOTO, + OP_DEFINE_BACRO, OP_DEFINE_BACRO_STAR, OP_BACRO, OP_BACRO_STAR, + OP_GET_OUTPUT_STRING, + OP_SORT, OP_SORT1, OP_SORT2, OP_SORT3, OP_SORT_PAIR_END, + OP_SORT_VECTOR_END, OP_SORT_STRING_END, + OP_EVAL_STRING, + OP_MEMBER_IF, OP_ASSOC_IF, OP_MEMBER_IF1, OP_ASSOC_IF1, + OP_LAMBDA_UNCHECKED, OP_LET_UNCHECKED, OP_CATCH_1, OP_CATCH_2, + OP_CATCH_ALL, + + OP_SET_UNCHECKED, OP_SET_SYMBOL_C, OP_SET_SYMBOL_S, OP_SET_SYMBOL_P, + OP_SET_SYMBOL_A, + OP_SET_NORMAL, OP_SET_PAIR, OP_SET_DILAMBDA, OP_SET_DILAMBDA_P, + OP_SET_DILAMBDA_P_1, OP_SET_DILAMBDA_SA_A, + OP_SET_PAIR_A, OP_SET_PAIR_P, OP_SET_PAIR_ZA, + OP_SET_PAIR_P_1, OP_SET_FROM_SETTER, OP_SET_FROM_LET_TEMP, OP_SET_PWS, + OP_SET_LET_S, OP_SET_LET_FX, OP_SET_SAFE, + OP_INCREMENT_BY_1, OP_DECREMENT_BY_1, OP_SET_CONS, + OP_INCREMENT_SS, OP_INCREMENT_SP, OP_INCREMENT_SA, OP_INCREMENT_SAA, + + OP_LETREC_UNCHECKED, OP_LETREC_STAR_UNCHECKED, OP_COND_UNCHECKED, + OP_LAMBDA_STAR_UNCHECKED, OP_DO_UNCHECKED, OP_DEFINE_UNCHECKED, + OP_DEFINE_STAR_UNCHECKED, OP_DEFINE_FUNCHECKED, + OP_DEFINE_CONSTANT_UNCHECKED, + OP_DEFINE_WITH_SETTER, + + OP_LET_NO_VARS, OP_NAMED_LET, OP_NAMED_LET_NO_VARS, OP_NAMED_LET_A, + OP_NAMED_LET_AA, OP_NAMED_LET_FX, OP_NAMED_LET_STAR, + OP_LET_FX_OLD, OP_LET_FX_NEW, OP_LET_2A_OLD, OP_LET_2A_NEW, + OP_LET_3A_OLD, OP_LET_3A_NEW, + OP_LET_opSSq_OLD, OP_LET_opSSq_NEW, OP_LET_opSSq_E_OLD, + OP_LET_opSSq_E_NEW, OP_LET_opaSSq_OLD, OP_LET_opaSSq_NEW, + OP_LET_opaSSq_E_OLD, OP_LET_opaSSq_E_NEW, + OP_LET_ONE_OLD, OP_LET_ONE_NEW, OP_LET_ONE_P_OLD, OP_LET_ONE_P_NEW, + OP_LET_ONE_OLD_1, OP_LET_ONE_NEW_1, OP_LET_ONE_P_OLD_1, + OP_LET_ONE_P_NEW_1, + OP_LET_A_OLD, OP_LET_A_NEW, OP_LET_A_P_OLD, OP_LET_A_P_NEW, + OP_LET_A_A_OLD, OP_LET_A_A_NEW, OP_LET_A_FX_OLD, OP_LET_A_FX_NEW, + OP_LET_A_OLD_2, OP_LET_A_NEW_2, + OP_LET_STAR_FX, OP_LET_STAR_FX_A, + + OP_CASE_A_E_S, OP_CASE_A_I_S, OP_CASE_A_G_S, OP_CASE_A_E_G, + OP_CASE_A_G_G, OP_CASE_A_S_S, OP_CASE_A_S_G, + OP_CASE_S_E_S, OP_CASE_S_I_S, OP_CASE_S_G_S, OP_CASE_S_E_G, + OP_CASE_S_G_G, OP_CASE_S_S_S, OP_CASE_S_S_G, + OP_CASE_P_E_S, OP_CASE_P_I_S, OP_CASE_P_G_S, OP_CASE_P_E_G, + OP_CASE_P_G_G, OP_CASE_P_S_S, OP_CASE_P_S_G, + OP_CASE_E_S, OP_CASE_I_S, OP_CASE_G_S, OP_CASE_E_G, OP_CASE_G_G, + OP_CASE_S_S, OP_CASE_S_G, + + OP_IF_UNCHECKED, OP_AND_P, OP_AND_P1, OP_AND_AP, OP_AND_PAIR_P, + OP_AND_SAFE_P1, OP_AND_SAFE_P2, OP_AND_SAFE_P3, OP_AND_SAFE_P_REST, + OP_AND_2A, OP_AND_3A, OP_AND_N, OP_AND_S_2, + OP_OR_P, OP_OR_P1, OP_OR_AP, OP_OR_2A, OP_OR_3A, OP_OR_N, OP_OR_S_2, + OP_OR_S_TYPE_2, + OP_WHEN_S, OP_WHEN_A, OP_WHEN_P, OP_WHEN_AND_AP, OP_WHEN_AND_2A, + OP_WHEN_AND_3A, OP_UNLESS_S, OP_UNLESS_A, OP_UNLESS_P, + + OP_IF_A_C_C, OP_IF_A_A, OP_IF_A_A_A, OP_IF_S_A_A, OP_IF_AND2_S_A, + OP_IF_NOT_A_A, OP_IF_NOT_A_A_A, + OP_IF_B_A, OP_IF_B_P, OP_IF_B_R, OP_IF_B_A_P, OP_IF_B_P_A, OP_IF_B_P_P, + OP_IF_B_N_N, + OP_IF_A_A_P, OP_IF_A_P_A, OP_IF_S_P_A, OP_IF_IS_TYPE_S_P_A, + OP_IF_IS_TYPE_S_A_A, + OP_IF_S_P, OP_IF_S_P_P, OP_IF_S_R, OP_IF_S_N, OP_IF_S_N_N, + OP_IF_opSq_P, OP_IF_opSq_P_P, OP_IF_opSq_R, OP_IF_opSq_N, + OP_IF_opSq_N_N, + OP_IF_IS_TYPE_S_P, OP_IF_IS_TYPE_S_P_P, OP_IF_IS_TYPE_S_R, + OP_IF_IS_TYPE_S_N, OP_IF_IS_TYPE_S_N_N, + OP_IF_A_P, OP_IF_A_P_P, OP_IF_A_R, OP_IF_A_N, OP_IF_A_N_N, + OP_IF_AND2_P, OP_IF_AND2_P_P, OP_IF_AND2_R, OP_IF_AND2_N, + OP_IF_AND2_N_N, + OP_IF_AND3_P, OP_IF_AND3_P_P, OP_IF_AND3_R, OP_IF_AND3_N, OP_IF_AND3_N_N, /* or3 got few hits */ + OP_IF_P_P, OP_IF_P_P_P, OP_IF_P_R, OP_IF_P_N, OP_IF_P_N_N, + OP_IF_ANDP_P, OP_IF_ANDP_P_P, OP_IF_ANDP_R, OP_IF_ANDP_N, + OP_IF_ANDP_N_N, + OP_IF_ORP_P, OP_IF_ORP_P_P, OP_IF_ORP_R, OP_IF_ORP_N, OP_IF_ORP_N_N, + OP_IF_OR2_P, OP_IF_OR2_P_P, OP_IF_OR2_R, OP_IF_OR2_N, OP_IF_OR2_N_N, + OP_IF_PP, OP_IF_PPP, OP_IF_PR, OP_IF_PRR, OP_WHEN_PP, OP_UNLESS_PP, + + OP_COND_FX_FX, OP_COND_FX_NP, OP_COND_FX_NP_1, OP_COND_FX_2E, + OP_COND_FX_3E, OP_COND_FX_NP_O, + OP_COND_FEED, OP_COND_FEED_1, + + OP_SIMPLE_DO, OP_SIMPLE_DO_STEP, OP_SAFE_DOTIMES, OP_SAFE_DOTIMES_STEP, + OP_SAFE_DOTIMES_STEP_O, + OP_SAFE_DO, OP_SAFE_DO_STEP, OP_DOX, OP_DOX_STEP, OP_DOX_STEP_O, + OP_DOX_NO_BODY, OP_DOX_PENDING_NO_BODY, OP_DOX_INIT, + OP_DOTIMES_P, OP_DOTIMES_STEP_O, + OP_DO_NO_VARS, OP_DO_NO_VARS_NO_OPT, OP_DO_NO_VARS_NO_OPT_1, + OP_DO_NO_BODY_FX_VARS, OP_DO_NO_BODY_FX_VARS_STEP, + OP_DO_NO_BODY_FX_VARS_STEP_1, + + OP_SAFE_C_P_1, OP_SAFE_C_PP_1, OP_SAFE_C_PP_3_MV, OP_SAFE_C_PP_5, + OP_SAFE_C_PP_6_MV, + OP_SAFE_C_3P_1, OP_SAFE_C_3P_2, OP_SAFE_C_3P_3, OP_SAFE_C_3P_1_MV, + OP_SAFE_C_3P_2_MV, OP_SAFE_C_3P_3_MV, + OP_SAFE_C_SP_1, OP_SAFE_C_SP_MV, OP_SAFE_CONS_SP_1, OP_SAFE_LIST_SP_1, + OP_SAFE_ADD_SP_1, OP_SAFE_MULTIPLY_SP_1, + OP_SAFE_C_PS_1, OP_SAFE_C_PC_1, OP_SAFE_C_PS_MV, OP_SAFE_C_PC_MV, + OP_EVAL_MACRO_MV, OP_MACROEXPAND_1, OP_APPLY_LAMBDA, + OP_INCREMENT_SP_1, OP_INCREMENT_SP_MV, OP_ANY_C_NP_1, OP_ANY_C_NP_MV_1, + OP_SAFE_C_SSP_1, OP_SAFE_C_SSP_MV_1, + OP_C_P_1, OP_C_P_MV, OP_C_AP_1, OP_C_AP_MV, OP_ANY_C_NP_2, + OP_SAFE_C_PA_1, OP_SAFE_C_PA_MV, + OP_SET_WITH_LET_1, OP_SET_WITH_LET_2, + + OP_CLOSURE_AP_1, OP_CLOSURE_PA_1, OP_CLOSURE_PP_1, OP_CLOSURE_P_1, + OP_SAFE_CLOSURE_P_1, OP_SAFE_CLOSURE_P_A_1, OP_SAFE_CLOSURE_AP_1, + OP_SAFE_CLOSURE_PA_1, OP_SAFE_CLOSURE_PP_1, + OP_ANY_CLOSURE_3P_1, OP_ANY_CLOSURE_3P_2, OP_ANY_CLOSURE_3P_3, + OP_ANY_CLOSURE_NP_1, OP_ANY_CLOSURE_NP_MV_1, + OP_ANY_CLOSURE_4P_1, OP_ANY_CLOSURE_4P_2, OP_ANY_CLOSURE_4P_3, + OP_ANY_CLOSURE_4P_4, OP_ANY_CLOSURE_NP_2, + + OP_TC_AND_A_OR_A_LA, OP_TC_OR_A_AND_A_LA, OP_TC_AND_A_OR_A_LAA, + OP_TC_OR_A_AND_A_LAA, OP_TC_OR_A_A_AND_A_A_LA, + OP_TC_OR_A_AND_A_A_L3A, OP_TC_AND_A_OR_A_A_LA, OP_TC_OR_A_AND_A_A_LA, + OP_TC_WHEN_LAA, OP_TC_LET_WHEN_LAA, OP_TC_LET_UNLESS_LAA, + OP_TC_COND_A_Z_A_Z_LAA, OP_TC_COND_A_Z_A_LAA_Z, + OP_TC_COND_A_Z_A_LAA_LAA, OP_TC_LET_COND, + OP_TC_IF_A_Z_LA, OP_TC_IF_A_Z_LAA, OP_TC_IF_A_Z_L3A, OP_TC_IF_A_L3A_Z, + OP_TC_IF_A_LA_Z, OP_TC_IF_A_LAA_Z, + OP_TC_IF_A_Z_IF_A_Z_LA, OP_TC_IF_A_Z_IF_A_LA_Z, + OP_TC_IF_A_Z_IF_A_Z_LAA, OP_TC_IF_A_Z_IF_A_LAA_Z, + OP_TC_IF_A_Z_IF_A_L3A_L3A, + OP_TC_COND_A_Z_A_Z_LA, OP_TC_COND_A_Z_A_LA_Z, OP_TC_COND_A_Z_LA, + OP_TC_COND_A_LA_Z, OP_TC_COND_A_Z_LAA, OP_TC_COND_A_LAA_Z, + OP_TC_LET_IF_A_Z_LA, OP_TC_LET_IF_A_Z_LAA, OP_TC_IF_A_Z_LET_IF_A_Z_LAA, + OP_TC_CASE_LA, OP_TC_AND_A_IF_A_Z_LA, OP_TC_AND_A_IF_A_LA_Z, + + OP_RECUR_IF_A_A_opA_LAq, OP_RECUR_IF_A_opA_LAq_A, + OP_RECUR_IF_A_A_opLA_Aq, OP_RECUR_IF_A_opLA_Aq_A, + OP_RECUR_IF_A_A_opLA_LAq, OP_RECUR_IF_A_opLA_LAq_A, + OP_RECUR_IF_A_A_opA_LA_LAq, OP_RECUR_IF_A_opA_LA_LAq_A, + OP_RECUR_IF_A_A_opLA_LA_LAq, OP_RECUR_IF_A_A_IF_A_A_opLA_LAq, + OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq, + OP_RECUR_IF_A_A_opA_LAAq, OP_RECUR_IF_A_opA_LAAq_A, + OP_RECUR_IF_A_A_opA_L3Aq, + OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq, OP_RECUR_IF_A_A_AND_A_LAA_LAA, + OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq, /* same as cond case below */ + OP_RECUR_COND_A_A_opA_LAq, OP_RECUR_COND_A_A_opA_LAAq, + OP_RECUR_COND_A_A_A_A_opLA_LAq, OP_RECUR_COND_A_A_A_A_opLAA_LAAq, + OP_RECUR_COND_A_A_A_A_opA_LAAq, + OP_RECUR_COND_A_A_A_LAA_LopA_LAAq, OP_RECUR_COND_A_A_A_LAA_opA_LAAq, + OP_RECUR_AND_A_OR_A_LAA_LAA, + + NUM_OPS +}; + +#define is_tc_op(Op) ((Op >= OP_TC_AND_A_OR_A_LA) && (Op <= OP_TC_CASE_LA)) + +typedef enum { E_C_P, E_C_PP, E_C_CP, E_C_SP, E_C_PC, + E_C_PS +} combine_op_t; + +static const char *op_names[NUM_OPS] = { + "unopt", "gc_protect", + + "safe_c_nc", "h_safe_c_nc", "safe_c_s", "h_safe_c_s", + "safe_c_ss", "h_safe_c_ss", "safe_c_sc", "h_safe_c_sc", "safe_c_cs", + "h_safe_c_cs", "safe_c_cq", "h_safe_c_cq", + "safe_c_sss", "h_safe_c_sss", "safe_c_scs", "h_safe_c_scs", + "safe_c_ssc", "h_safe_c_ssc", "safe_c_css", "h_safe_c_css", + "safe_c_scc", "h_safe_c_scc", "safe_c_csc", "h_safe_c_csc", + "safe_c_ccs", "h_safe_c_ccs", + "safe_c_ns", "h_safe_c_ns", "safe_c_opncq", "h_safe_c_opncq", + "safe_c_opsq", "h_safe_c_opsq", + "safe_c_opssq", "h_safe_c_opssq", "safe_c_opscq", "h_safe_c_opscq", + "safe_c_opcsq", "h_safe_c_opcsq", "safe_c_s_opsq", "h_safe_c_s_opsq", + "safe_c_c_opscq", "h_safe_c_c_opscq", "safe_c_s_opscq", + "h_safe_c_s_opscq", "safe_c_s_opcsq", "h_safe_c_s_opcsq", + "safe_c_opsq_s", "h_safe_c_opsq_s", "safe_c_opsq_c", "h_safe_c_opsq_c", + "safe_c_opsq_opsq", "h_safe_c_opsq_opsq", "safe_c_s_opssq", + "h_safe_c_s_opssq", "safe_c_c_opsq", "h_safe_c_c_opsq", + "safe_c_opcsq_c", "h_safe_c_opcsq_c", "safe_c_opssq_c", + "h_safe_c_opssq_c", "safe_c_c_opssq", "h_safe_c_c_opssq", + "safe_c_opssq_opssq", "h_safe_c_opssq_opssq", "safe_c_opssq_opsq", + "h_safe_c_opssq_opsq", "safe_c_opsq_opssq", "h_safe_c_opsq_opssq", + "safe_c_opssq_s", "h_safe_c_opssq_s", "safe_c_opcsq_s", + "h_safe_c_opcsq_s", "safe_c_opscq_c", "h_safe_c_opscq_c", + "safe_c_op_opssqq_s", "h_safe_c_op_opssqq_s", "safe_c_op_opsqq", + "h_safe_c_op_opsqq", + "safe_c_op_s_opsqq", "h_safe_c_op_s_opsqq", "safe_c_op_opsq_sq", + "h_safe_c_op_opsq_sq", "safe_c_opsq_cs", "h_safe_c_opsq_cs", + + "safe_c_a", "h_safe_c_a", "safe_c_aa", "h_safe_c_aa", "safe_c_sa", + "h_safe_c_sa", "safe_c_as", "h_safe_c_as", + "safe_c_ca", "h_safe_c_ca", "safe_c_ac", "h_safe_c_ac", "safe_c_aaa", + "h_safe_c_aaa", "safe_c_4a", "h_safe_c_4a", + "safe_c_na", "h_safe_c_na", "safe_c_all_ca", "h_safe_c_all_ca", + "safe_c_ssa", "h_safe_c_ssa", "safe_c_sas", "h_safe_c_sas", + "safe_c_saa", "h_safe_c_saa", + "safe_c_csa", "h_safe_c_csa", "safe_c_sca", "h_safe_c_sca", + "safe_c_ass", "h_safe_c_ass", + "safe_c_cac", "h_safe_c_cac", "safe_c_agg", "h_safe_c_agg", + "safe_c_opaq", "h_safe_c_opaq", "safe_c_opaaq", "h_safe_c_opaaq", + "safe_c_opaaaq", "h_safe_c_opaaaq", + "safe_c_s_opaq", "h_safe_c_s_opaq", "safe_c_opaq_s", "h_safe_c_opaq_s", + "safe_c_s_opaaq", "h_safe_c_s_opaaq", "safe_c_s_opaaaq", + "h_safe_c_s_opaaaq", + "safe_c_function*", "h_safe_c_function*", "safe_c_function*_a", + "h_safe_c_function*_a", + "safe_c_function*_aa", "h_safe_c_function*_aa", "safe_c_function*_fx", + "h_safe_c_function*_fx", + "safe_c_p", "h_safe_c_p", + + "thunk", "h_thunk", "thunk_any", "h_thunk_any", "safe_thunk", + "h_safe_thunk", "safe_thunk_a", "h_safe_thunk_a", + + "closure_s", "h_closure_s", "closure_s_o", "h_closure_s_o", + "closure_a", "h_closure_a", "closure_a_o", "h_closure_a_o", + "closure_p", "h_closure_p", + "closure_ap", "h_closure_ap", "closure_pa", "h_closure_pa", + "closure_pp", "h_closure_pp", + "closure_fa", "h_closure_fa", "closure_ss", "h_closure_ss", + "closure_ss_o", "h_closure_ss_o", + "closure_sc", "h_closure_sc", "closure_sc_o", "h_closure_sc_o", + "closure_3s", "h_closure_3s", "closure_4s", "h_closure_4s", + "closure_aa", "h_closure_aa", "closure_aa_o", "h_closure_aa_o", + "closure_3a", "h_closure_3a", "closure_4a", "h_closure_4a", + "closure_na", "h_closure_na", "closure_ass", "h_closure_ass", + "closure_sas", "h_closure_sas ", "closure_aas", "h_closure_aas", + "closure_saa", "h_closure_saa", "closure_asa", "h_closure_asa", + "closure_ns", "h_closure_ns", + + "safe_closure_s", "h_safe_closure_s", "safe_closure_s_o", + "h_safe_closure_s_o", + "safe_closure_s_a", "h_safe_closure_s_a", "safe_closure_s_to_s", + "h_safe_closure_s_to_s", "safe_closure_s_to_sc", + "h_safe_closure_s_to_sc", + "safe_closure_p", "h_safe_closure_p", "safe_closure_p_a", + "h_safe_closure_p_a", + "safe_closure_ap", "h_safe_closure_ap", "safe_closure_pa", + "h_safe_closure_pa", "safe_closure_pp", "h_safe_closure_pp", + "safe_closure_a", "h_safe_closure_a", "safe_closure_a_o", + "h_safe_closure_a_o", "safe_closure_a_a", "h_safe_closure_a_a", + "safe_closure_a_to_sc", "h_safe_closure_a_to_sc", + "safe_closure_ss", "h_safe_closure_ss", "safe_closure_ss_o", + "h_safe_closure_ss_o", "safe_closure_ss_a", "h_safe_closure_ss_a", + "safe_closure_sc", "h_safe_closure_sc", "safe_closure_sc_o", + "h_safe_closure_sc_o", + "safe_closure_aa", "h_safe_closure_aa", "safe_closure_aa_o", + "h_safe_closure_aa_o", "safe_closure_aa_a", "h_safe_closure_aa_a", + "safe_closure_saa", "h_safe_closure_saa", "safe_closure_ssa", + "h_safe_closure_ssa", + "safe_closure_agg", "h_safe_closure_agg", "safe_closure_3a", + "h_safe_closure_3a", "safe_closure_na", "h_safe_closure_na", + "safe_closure_3s", "h_safe_closure_3s", "safe_closure_ns", + "h_safe_closure_ns", + "safe_closure_3s_a", "h_safe_closure_3s_a", + + "any_closure_3p", "h_any_closure_3p", "any_closure_4p", + "h_any_closure_4p", "any_closure_na", "h_any_closure_na", + "any_closure_np", "h_any_closure_np", + + "closure*_a", "h_closure*_a", "closure*_fx", "h_closure*_fx", + "safe_closure*_a", "h_safe_closure*_a", "safe_closure*_aa", + "h_safe_closure*_aa", + "safe_closure*_aa_o", "h_safe_closure*_aa_o", "safe_closure*_a1", + "h_safe_closure*_a1", + "safe_closure*_ka", "h_safe_closure*_ka", "closure*_ka", + "h_closure*_ka", "safe_closure*_3a", "h_safe_closure*_3a", + "safe_closure*_fx", "h_safe_closure*_fx", "safe_closure*_fx_0", + "h_safe_closure*_fx_0", + "safe_closure*_fx_1", "h_safe_closure*_fx_1", "safe_closure*_fx_2", + "h_safe_closure*_fx_2", + + "call_with_exit", "h_call_with_exit", "call_with_exit_o", + "h_call_with_exit_o", + "c_catch", "h_c_catch", "c_catch_all", "h_c_catch_all", + "c_catch_all_o", "h_c_catch_all_o", "c_catch_all_a", + "h_c_catch_all_a", + "c_s_opsq", "h_c_s_opsq", "c_ss", "h_c_ss", "c_s", "h_c_s", "read_s", + "h_read_s", "c_p", "h_c_p", "c_ap", "h_c_ap", + "c_a", "h_c_a", "c_aa", "h_c_aa", "c", "h_c", "c_fx", "h_c_fx", + + "cl_s", "h_cl_s", "cl_ss", "h_cl_ss", "cl_a", "h_cl_a", "cl_aa", + "h_cl_aa", + "cl_na", "h_cl_na", "cl_fa", "h_cl_fa", "cl_sas", "h_cl_sas", + "cl_s_opsq", "h_cl_s_opsq", + + "safe_c_pp", "h_safe_c_pp", "safe_c_ff", "h_safe_c_ff", + "safe_c_opsq_p", "h_safe_c_opsq_p", + "safe_c_sp", "h_safe_c_sp", "safe_c_cp", "h_safe_c_cp", + "safe_c_ap", "h_safe_c_ap", "safe_c_pa", "h_safe_c_pa", + "safe_c_ps", "h_safe_c_ps", "safe_c_pc", "h_safe_c_pc", + "safe_c_ssp", "h_safe_c_ssp", "any_c_np", "h_any_c_np", + "safe_c_3p", "h_safe_c_3p", + + "apply_ss", "apply_sa", "apply_sl", + "macro_d", "macro*_d", + "with_input_from_string", "with_input_from_string_1", + "with_output_to_string", "with_input_from_string_c", + "call_with_output_string", + "s", "s_s", "s_c", "s_a", "s_aa", "a_a", "a_aa", "p_s", "p_s_1", + "map_for_each_fa", "map_for_each_faa", + "implicit_goto", "implicit_goto_a", "implicit_continuation_a", + "implicit_iterate", + "implicit_vector_ref_a", "implicit_vector_ref_aa", + "implicit_vector_set_3", "implicit_vector_set_4", + "implicit_string_ref_a", "implicit_c_object_ref_a", + "implicit_pair_ref_a", "implicit_pair_ref_aa", + "implicit_hash_table_ref_a", "implicit_let_ref_c", + "implicit_let_ref_a", "implicit_*s7*_ref_s", + "implicit_*s7*_set_sa", + "unknown_thunk", "unknown_ns", "unknown_na", "unknown_g", "unknown_gg", + "unknown_a", "unknown_aa", "unknown_np", + + "symbol", "global-symbol", "constant", "pair_sym", "pair_pair", + "pair_any", + "h_ssa_direct", "h_hash_table_increment", "clear_opts", + + "read_internal", "eval", + "eval_args", "eval_args1", "eval_args2", "eval_args3", "eval_args4", + "eval_args5", + "apply", "eval_macro", "lambda", "quote", "quote_unchecked", + "macroexpand", "call/cc", + "define", "define1", "begin", "begin_hook", "begin_no_hook", + "begin_unchecked", "begin_2_unchecked", "begin_na", "begin_aa", + "if", "if1", "when", "unless", "set", "set1", "set2", + "let", "let1", "let*", "let*1", "let*2", + "letrec", "letrec1", "letrec*", "letrec*1", + "let_temporarily", "let_temp_unchecked", "let_temp_init1", + "let_temp_init2", "let_temp_done", "let_temp_done1", + "let_temp_s7", "let_temp_fx", "let_temp_fx_1", "let_temp_setter", + "let_temp_unwind", "let_temp_s7_unwind", "let_temp_setter_unwind", + "let_temp_a_a", + "cond", "cond1", "feed_to_1", "cond_simple", "cond1_simple", + "cond_simple_o", "cond1_simple_o", + "and", "or", + "define_macro", "define_macro*", "define_expansion", + "define_expansion*", "macro", "macro*", + "case", "read_list", "read_next", "read_dot", "read_quote", + "read_quasiquote", "read_unquote", "read_apply_values", + "read_vector", "read_byte_vector", "read_int_vector", + "read_float_vector", "read_done", + "load_return_if_eof", "load_close_and_pop_if_eof", "eval_done", + "splice_values", "no_values", "flush_values", + "catch", "dynamic_wind", "dynamic_unwind", "dynamic_unwind_profile", + "profile_in", + "define_constant", "define_constant1", + "do", "do_end", "do_end1", "do_step", "do_step2", "do_init", + "define*", "lambda*", "lambda*_default", "error_quit", "unwind_input", + "unwind_output", + "error_hook_quit", + "with_let", "with_let1", "with_let_unchecked", "with_let_s", + "with_unlet_s", + "with_baffle", "with_baffle_unchecked", "expansion", + "for_each", "for_each_1", "for_each_2", "for_each_3", + "map", "map_1", "map_2", "map_gather", "map_gather_1", "map_gather_2", + "map_gather_3", + "barrier", "deactivate_goto", + "define_bacro", "define_bacro*", "bacro", "bacro*", + "get_output_string", + "sort", "sort1", "sort2", "sort3", "sort_pair_end", "sort_vector_end", + "sort_string_end", + "eval_string", + "member_if", "assoc_if", "member_if1", "assoc_if1", + "lambda_unchecked", "let_unchecked", "catch_1", "catch_2", "catch_all", + "set_unchecked", "set_symbol_c", "set_symbol_s", "set_symbol_p", + "set_symbol_a", + "set_normal", "set_pair", "set_dilambda", "set_dilambda_p", + "set_dilambda_p_1", "set_dilambda_sa_a", + "set_pair_a", "set_pair_p", "set_pair_za", + "set_pair_p_1", "set_from_setter", "set_from_let_temp", "set_pws", + "set_let_s", "set_let_fx", "set_safe", + "increment_1", "decrement_1", "set_cons", + "increment_ss", "increment_sp", "increment_sa", "increment_saa", + "letrec_unchecked", "letrec*_unchecked", "cond_unchecked", + "lambda*_unchecked", "do_unchecked", "define_unchecked", + "define*_unchecked", "define_funchecked", + "define_constant_unchecked", + "define_with_setter", + + "let_no_vars", "named_let", "named_let_no_vars", "named_let_a", + "named_let_aa", "named_let_fx", "named_let*", + "let_fx_old", "let_fx_new", "let_2a_old", "let_2a_new", "let_3a_old", + "let_3a_new", + "let_opssq_old", "let_opssq_new", "let_opssq_e_old", "let_opssq_e_new", + "let_opassq_old", "let_opassq_new", "let_opassq_e_old", + "let_opassq_e_new", + "let_one_old", "let_one_new", "let_one_p_old", "let_one_p_new", + "let_one_old_1", "let_one_new_1", "let_one_p_old_1", "let_one_p_new_1", + "let_a_old", "let_a_new", "let_a_p_old", "let_a_p_new", + "let_a_a_old", "let_a_a_new", "let_a_fx_old", "let_a_fx_new", + "let_a_old_2", "let_a_new_2", + "let*_fx", "let*_fx_a", + + "case_a_e_s", "case_a_i_s", "case_a_g_s", "case_a_e_g", "case_a_g_g", + "case_a_s_s", "case_a_s_g", + "case_s_e_s", "case_s_i_s", "case_s_g_s", "case_s_e_g", "case_s_g_g", + "case_s_s_s", "case_s_s_g", + "case_p_e_s", "case_p_i_s", "case_p_g_s", "case_p_e_g", "case_p_g_g", + "case_p_s_s", "case_p_s_g", + "case_e_s", "case_i_s", "case_g_s", "case_e_g", "case_g_g", "case_s_s", + "case_s_g", + + "if_unchecked", "and_p", "and_p1", "and_ap", "and_pair_p", + "and_safe_p1", "op_and_safe_p2", "and_safe_p3", "and_safe_p_rest", + "and_2a", "and_3a", "and_n", "and_s_2", + "or_p", "or_p1", "or_ap", "or_2a", "or_3a", "or_n", "or_s_2", + "or_s_type_2", + "when_s", "when_a", "when_p", "when_and_ap", "when_and_2a", + "when_and_3a", "unless_s", "unless_a", "unless_p", + + "if_a_c_c", "if_a_a", "if_a_a_a", "if_s_a_a", "if_and2_s_a", + "if_not_a_a", "if_not_a_a_a", + "if_b_a", "if_b_p", "if_b_r", "if_b_a_p", "if_b_p_a", "if_b_p_p", + "if_b_n_n", + "if_a_a_p", "if_a_p_a", "if_s_p_a", "if_is_type_s_p_a", + "if_is_type_s_a_a", + "if_s_p", "if_s_p_p", "if_s_r", "if_s_n", "if_s_n_n", + "if_opsq_p", "if_opsq_p_p", "if_opsq_r", "if_opsq_n", "if_opsq_n_n", + "if_is_type_s_p", "if_is_type_s_p_p", "if_is_type_s_r", + "if_is_type_s_n", "if_is_type_s_n_n", + "if_a_p", "if_a_p_p", "if_a_r", "if_a_n", "if_a_n_n", + "if_and2_p", "if_and2_p_p", "if_and2_r", "if_and2_n", "if_and2_n_n", + "if_and3_p", "if_and3_p_p", "if_and3_r", "if_and3_n", "if_and3_n_n", + "if_p_p", "if_p_p_p", "if_p_r", "if_p_n", "if_p_n_n", + "if_andp_p", "if_andp_p_p", "if_andp_r", "if_andp_n", "if_andp_n_n", + "if_orp_p", "if_orp_p_p", "if_orp_r", "if_orp_n", "if_orp_n_n", + "if_or2_p", "if_or2_p_p", "if_or2_r", "if_or2_n", "if_or2_n_n", + "if_pp", "if_ppp", "if_pr", "if_prr", "when_pp", "unless_pp", + + "cond_fx_fx", "cond_fx_np", "cond_fx_np_1", "cond_fx_2e", "cond_fx_3e", + "cond_fx_np_o", + "cond_feed", "cond_feed_1", + + "simple_do", "simple_do_step", "safe_dotimes", "safe_dotimes_step", + "safe_dotimes_step_o", + "safe_do", "safe_do_step", "dox", "dox_step", "dox_step_o", + "dox_no_body", "dox_pending_no_body", "dox_init", + "dotimes_p", "dotimes_step_o", + "do_no_vars", "do_no_vars_no_opt", "do_no_vars_no_opt_1", + "do_no_body_fx_vars", "do_no_body_fx_vars_step", + "do_no_body_fx_vars_step_1", + + "safe_c_p_1", "safe_c_pp_1", "safe_c_pp_3_mv", "safe_c_pp_5", + "safe_c_pp_6_mv", + "safe_c_3p_1", "safe_c_3p_2", "safe_c_3p_3", "safe_c_3p_1_mv", + "safe_c_3p_2_mv", "safe_c_3p_3_mv", + "safe_c_sp_1", "safe_c_sp_mv", "safe_cons_sp_1", "safe_list_sp_1", + "safe_add_sp_1", "safe_multiply_sp_1", + "safe_c_ps_1", "safe_c_pc_1", "safe_c_ps_mv", "safe_c_pc_mv", + "eval_macro_mv", "macroexpand_1", "apply_lambda", + "increment_sp_1", "increment_sp_mv", "any_c_np_1", "any_c_np_mv_1", + "safe_c_ssp_1", "safe_c_ssp_mv_1", + "c_p_1", "c_p_mv", "c_ap_1", "c_ap_mv", "any_c_np_2", "safe_c_pa_1", + "safe_c_pa_mv", + "set_with_let_1", "set_with_let_2", + + "closure_ap_1", "closure_pa_1", "closure_pp_1", "closure_p_1", + "safe_closure_p_1", "safe_closure_p_a_1", "safe_closure_ap_1", + "safe_closure_pa_1", "safe_closure_pp_1", + "any_closure_3p_1", "any_closure_3p_2", "any_closure_3p_3", + "any_closure_np_1", "any_closure_np_mv_1", + "any_closure_4p_1", "any_closure_4p_2", "any_closure_4p_3", + "any_closure_4p_4", "any_closure_np_2", + + "tc_and_a_or_a_la", "tc_or_a_and_a_la", "tc_and_a_or_a_laa", + "tc_or_a_and_a_laa", "tc_or_a_a_and_a_a_la", + "tc_or_a_and_a_a_l3a", "tc_and_a_or_a_a_la", "tc_or_a_and_a_a_la", + "tc_when_laa", "tc_let_when_laa", "tc_let_unless_laa", + "tc_cond_a_z_a_z_laa", "tc_cond_a_z_a_laa_z", "tc_cond_a_z_a_laa_laa", + "tc_let_cond", + "tc_if_a_z_la", "tc_if_a_z_laa", "tc_if_a_z_l3a", "tc_if_a_l3a_z", + "tc_if_a_la_z", "tc_if_a_laa_z", + "tc_if_a_z_if_a_z_la", "tc_if_a_z_if_a_la_z", "tc_if_a_z_if_a_z_laa", + "tc_if_a_z_if_a_laa_z", "tc_if_a_z_if_a_l3a_l3a", + "tc_cond_a_z_a_z_la", "tc_cond_a_z_a_la_z", "tc_cond_a_z_la", + "tc_cond_a_la_z", "tc_cond_a_z_laa", "tc_cond_a_laa_z", + "tc_let_if_a_z_la", "tc_let_if_a_z_laa", "if_a_z_let_if_a_z_laa", + "tc_case_la", "tc_and_a_if_a_z_la", "tc_and_a_if_a_la_z", + + "recur_if_a_a_opa_laq", "recur_if_a_opa_laq_a", "recur_if_a_a_opla_aq", + "recur_if_a_opla_aq_a", + "recur_if_a_a_opla_laq", "recur_if_a_opla_laq_a", + "recur_if_a_a_opa_la_laq", "recur_if_a_opa_la_laq_a", + "recur_if_a_a_opla_la_laq", "recur_if_a_a_if_a_a_opla_laq", + "recur_if_a_a_if_a_a_oplaa_laaq", + "recur_if_a_a_opa_laaq", "recur_if_a_opa_laaq_a", + "recur_if_a_a_opa_l3aq", + "recur_if_a_a_lopl3a_l3a_l3aq", "recur_if_a_a_and_a_laa_laa", + "recur_if_a_a_if_a_laa_opa_laaq", + "recur_cond_a_a_op_a_laq", "recur_cond_a_a_op_a_laaq", + "recur_cond_a_a_a_a_opla_laq", "recur_cond_a_a_a_a_oplaa_laaq", + "recur_cond_a_a_a_a_opa_laaq", + "recur_cond_a_a_a_laa_lopa_laaq", "recur_cond_a_a_a_laa_opa_laaq", + "recur_and_a_or_a_laa_laa", +}; + +#define is_safe_c_op(op) ((op >= OP_SAFE_C_NC) && (op < OP_THUNK)) +#define is_unknown_op(op) ((op >= OP_UNKNOWN) && (op <= OP_UNKNOWN_NP)) +#define is_h_safe_c_d(P) (optimize_op(P) == HOP_SAFE_C_NC) +#define is_safe_c_s(P) ((optimize_op(P) == OP_SAFE_C_S) || (optimize_op(P) == HOP_SAFE_C_S)) +#define is_h_safe_c_s(P) (optimize_op(P) == HOP_SAFE_C_S) +#define FIRST_UNHOPPABLE_OP OP_APPLY_SS + +static bool is_h_optimized(s7_pointer p) +{ + return ((is_optimized(p)) && (op_has_hop(p)) && (optimize_op(p) < FIRST_UNHOPPABLE_OP) && /* was OP_S? */ + (optimize_op(p) > OP_GC_PROTECT)); +} + + +/* -------------------------------- internal debugging apparatus -------------------------------- */ + +static int64_t heap_location(s7_scheme * sc, s7_pointer p) +{ + heap_block_t *hp; + for (hp = sc->heap_blocks; hp; hp = hp->next) + if (((intptr_t) p >= hp->start) && ((intptr_t) p < hp->end)) + return (hp->offset + + (((intptr_t) p - hp->start) / sizeof(s7_cell))); + return (((s7_big_pointer) p)->big_hloc); +} + +#if TRAP_SEGFAULT +#include +static Jmp_Buf senv; /* global here is not a problem -- it is used only to protect s7_is_valid */ +static volatile sig_atomic_t can_jump = 0; +static void segv(int32_t ignored) +{ + if (can_jump) + LongJmp(senv, 1); +} +#endif + +bool s7_is_valid(s7_scheme * sc, s7_pointer arg) +{ + bool result = false; + if (!arg) + return (false); +#if TRAP_SEGFAULT + if (SetJmp(senv, 1) == 0) { + void (*old_segv)(int32_t sig); + can_jump = 1; + old_segv = signal(SIGSEGV, segv); +#endif + if ((unchecked_type(arg) > T_FREE) && + (unchecked_type(arg) < NUM_TYPES)) { + if (!in_heap(arg)) + result = true; + else { + int64_t loc; + loc = heap_location(sc, arg); + if ((loc >= 0) && (loc < sc->heap_size)) + result = (sc->heap[loc] == arg); + } + } +#if TRAP_SEGFAULT + signal(SIGSEGV, old_segv); + } else + result = false; + can_jump = 0; +#endif + return (result); +} + +void s7_show_let(s7_scheme * sc) +{ /* debugging convenience */ + s7_pointer olet; + for (olet = sc->curlet; is_let(T_Lid(olet)); olet = let_outlet(olet)) { + if (olet == sc->owlet) + fprintf(stderr, "(owlet): "); + else if (is_funclet(olet)) + fprintf(stderr, "(%s funclet): ", + display(funclet_function(olet))); + else if (olet == sc->shadow_rootlet) + fprintf(stderr, "(shadow rootlet): "); + fprintf(stderr, "%s\n", display(olet)); + } +} + +#define safe_print(Code) \ + do { \ + bool old_open, old_stop; \ + old_open = sc->has_openlets; \ + old_stop = sc->stop_at_error; \ + sc->has_openlets = false; \ + sc->stop_at_error = false; \ + Code; \ + sc->stop_at_error = old_stop; \ + sc->has_openlets = old_open; \ + } while (0) + +void s7_show_history(s7_scheme * sc) +{ +#if WITH_HISTORY + if (sc->cur_code == sc->history_sink) + fprintf(stderr, "history diabled\n"); + else { + int32_t i, size = sc->history_size; + s7_pointer p; + fprintf(stderr, "history:\n"); + for (i = 0, p = cdr(sc->cur_code); i < size; i++, p = cdr(p)) /* stepper "i" is not redundant */ + safe_print(fprintf(stderr, "%d: %s\n", i, display_80(car(p)))); + fprintf(stderr, "\n"); + } +#else + fprintf(stderr, "%s\n", display(sc->cur_code)); +#endif +} + +#define stack_code(Stack, Loc) stack_element(Stack, Loc - 3) +#define stack_let(Stack, Loc) stack_element(Stack, Loc - 2) +#define stack_args(Stack, Loc) stack_element(Stack, Loc - 1) +#define stack_op(Stack, Loc) ((opcode_t)(stack_element(Stack, Loc))) + +void s7_show_stack(s7_scheme * sc) +{ + int64_t i; + fprintf(stderr, "stack:\n"); + for (i = current_stack_top(sc) - 1; i >= 3; i -= 4) + fprintf(stderr, " %s\n", op_names[stack_op(sc->stack, i)]); +} + + +static char *describe_type_bits(s7_scheme * sc, s7_pointer obj) +{ /* used outside S7_DEBUGGING in display_any (fallback for display_functions) */ + uint64_t full_typ = full_type(obj); + uint8_t typ = unchecked_type(obj); + char *buf; + char str[900]; + + str[0] = '\0'; + catstrs(str, 900, /* if debugging, all of these bits are being watched, so we need to access them directly */ + /* bit 8 (the first 8 bits (after the 8 type bits) are easy...) */ + ((full_typ & T_MULTIFORM) != + 0) ? ((is_any_closure(obj)) ? (((full_typ & T_ONE_FORM) != 0) + ? " closure-one-form-has-fx" : + " closure-multiform") : " ?0?") + : "", + /* bit 9 */ + ((full_typ & T_SYNTACTIC) != + 0) ? (((is_pair(obj)) || (is_syntax(obj)) + || (is_normal_symbol(obj))) ? " syntactic" : " ?1?") : + "", + /* bit 10 */ + ((full_typ & T_SIMPLE_ARG_DEFAULTS) != + 0) ? ((is_pair(obj)) ? " simple-args|in-use" + : ((is_any_closure(obj)) ? " closure-one-form" : + " ?2?")) : "", + /* bit 11 */ + ((full_typ & T_OPTIMIZED) != + 0) ? ((is_c_function(obj)) ? " scope-safe" : ((is_pair(obj)) ? + " optimized" : + " ?3?")) : "", + /* bit 12 */ + ((full_typ & T_SAFE_CLOSURE) != 0) ? (((has_closure_let(obj)) + || (is_pair(obj))) ? + " safe-closure" : " ?4?") + : "", + /* bit 13 */ + ((full_typ & T_DONT_EVAL_ARGS) != 0) ? (((is_any_macro(obj)) + || (is_syntax(obj))) ? + " dont-eval-args" : + " ?5?") : "", + /* bit 14 */ + ((full_typ & T_EXPANSION) != 0) ? (((is_normal_symbol(obj)) + || (is_either_macro(obj))) + ? " expansion" : " ?6?") : + "", + /* bit 15 */ + ((full_typ & T_MULTIPLE_VALUE) != + 0) ? ((is_symbol(obj)) ? " matched" : ((is_pair(obj)) ? + " values|matched" : + " ?7?")) : "", + /* bit 16 */ + ((full_typ & T_GLOBAL) != 0) ? ((is_pair(obj)) ? " unsafe-do" : + (((is_symbol(obj)) + || (is_syntax(obj))) ? + " global" : ((is_let(obj)) ? + " dox_slot1" : + " ?8?"))) : "", + /* bit 17 */ + ((full_typ & T_COLLECTED) != 0) ? " collected" : "", + /* bit 18 */ + ((full_typ & T_LOCATION) != + 0) ? ((is_pair(obj)) ? " line-number" : ((is_input_port(obj)) + ? " loader-port" + : ((is_let(obj)) ? + " with-let" + : ((is_any_procedure(obj)) ? " simple-defaults" : (((is_normal_symbol(obj)) || (is_slot(obj))) ? " has-setter" : " ?10?"))))) : "", + /* bit 19 */ + ((full_typ & T_SHARED) != + 0) ? ((is_sequence(obj)) ? " shared" : " ?11?") : "", + /* bit 20 */ + ((full_typ & T_LOCAL) != + 0) ? ((is_normal_symbol(obj)) ? " local" : ((is_pair(obj)) ? + " high-c" : + " ?12?")) : "", + /* bit 21 */ + ((full_typ & T_SAFE_PROCEDURE) != + 0) ? ((is_applicable(obj)) ? " safe-procedure" : " ?13?") : + "", + /* bit 22 */ + ((full_typ & T_CHECKED) != 0) ? (((is_pair(obj)) + || (is_slot(obj))) ? + " checked" : ((is_symbol(obj)) + ? " all-integer" + : " ?14?")) : + "", + /* bit 23 */ + ((full_typ & T_UNSAFE) != + 0) ? ((is_symbol(obj)) ? " clean-symbol" : ((is_slot(obj)) ? + " has-stepper" + : ((is_pair(obj)) + ? + " unsafely-opt|no-float-opt" + : ((is_let + (obj)) ? + " dox-slot2" + : + " ?15?")))) + : "", + /* bit 24 */ + ((full_typ & T_IMMUTABLE) != 0) ? " immutable" : "", + /* bit 25 */ + ((full_typ & T_SETTER) != + 0) ? ((is_normal_symbol(obj)) ? " setter" : ((is_pair(obj)) ? + " allow-other-keys|no-int-opt" + : ((is_slot(obj)) + ? + " has-expression" + : ((is_c_function_star(obj)) ? " allow-other-keys" : " ?17?")))) : "", + /* bit 26 */ + ((full_typ & T_MUTABLE) != + 0) ? ((is_number(obj)) ? " mutable" : ((is_symbol(obj)) ? + " has-keyword" + : ((is_let(obj)) ? + " let-ref-fallback" + : ((is_iterator + (obj)) ? + " mark-sequence" + : ((is_slot(obj)) + ? " step-end" + : ((is_let + (obj)) ? + " ref-fallback" + : ((is_pair + (obj)) + ? + " no-opt" + : + " ?18?"))))))) + : "", + /* bit 27 */ + ((full_typ & T_SAFE_STEPPER) != + 0) ? ((is_let(obj)) ? " set-fallback" : ((is_slot(obj)) ? + " safe-stepper" + : ((is_c_function + (obj)) ? + " maybe-safe" + : ((is_number + (obj)) ? + " print-name" + : ((is_pair + (obj)) ? + " direct-opt" + : ((is_hash_table(obj)) ? " weak-hash" : ((is_any_macro(obj)) ? " pair-macro-set" : ((is_symbol(obj)) ? " all-float" : " ?19?")))))))) : "", + /* bit 28, for c_function case see sc->apply */ + ((full_typ & T_COPY_ARGS) != + 0) ? (((is_pair(obj)) || (is_any_macro(obj)) + || (is_syntax(obj)) || (is_any_closure(obj)) + || (is_c_function(obj))) ? " copy-args" : " ?20?") : + "", + /* bit 29 */ + ((full_typ & T_GENSYM) != 0) ? ((is_let(obj)) ? " funclet" : + ((is_normal_symbol(obj)) ? + " gensym" : ((is_string(obj)) + ? + " documented-symbol" + : ((is_hash_table + (obj)) ? + " hash-chosen" + : ((is_pair + (obj)) ? + " fx-treed" + : ((is_any_vector(obj)) ? " subvector" : ((is_slot(obj)) ? " has-pending-value" : ((is_any_closure(obj)) ? " unknopt" : " ?21?")))))))) : "", + /* bit 30 */ + ((full_typ & T_HAS_METHODS) != + 0) ? (((is_let(obj)) || (is_c_object(obj)) + || (is_any_closure(obj)) || (is_any_macro(obj)) + || (is_c_pointer(obj))) ? " has-methods" : " ?22?") : + "", + /* bit 31 */ + ((full_typ & T_ITER_OK) != + 0) ? ((is_iterator(obj)) ? " iter-ok" : ((is_pair(obj)) ? + " step-end-ok/set-implicit-ok" + : ((is_slot(obj)) ? + " in-rootlet" + : ((is_c_function + (obj)) ? + " bool-function" + : " ?23?")))) : + "", + /* bit 24+24 */ + ((full_typ & T_FULL_SYMCONS) != + 0) ? ((is_symbol(obj)) ? " possibly-constant" + : ((is_procedure(obj)) ? " has-let-arg" + : ((is_hash_table(obj)) ? " has-value-type" + : ((is_pair(obj)) ? " int-optable" : " ?24?")))) : + "", + /* bit 25+24 */ + ((full_typ & T_FULL_HAS_LET_FILE) != + 0) ? ((is_let(obj)) ? " has-let-file" : ((is_any_vector(obj)) + ? " typed-vector" + : ((is_hash_table + (obj)) ? + " typed-hash-table" + : ((is_c_function + (obj)) ? + " has-bool-setter" + : ((is_slot + (obj)) ? + " rest-slot" + : (((is_pair + (obj)) + || + (is_closure_star + (obj))) + ? + " no-defaults" + : + " ?25?")))))) + : "", + /* bit 26+24 */ + ((full_typ & T_FULL_DEFINER) != + 0) ? ((is_normal_symbol(obj)) ? " definer" : ((is_pair(obj)) ? + " has-fx" + : ((is_slot + (obj)) ? + " slot-defaults" + : ((is_iterator(obj)) ? " weak-hash-iterator" : ((is_hash_table(obj)) ? " has-key-type" : ((is_let(obj)) ? " maclet" : ((is_c_function(obj)) ? " func-definer" : ((is_syntax(obj)) ? " syntax-definer" : " ?26?")))))))) : "", + /* bit 27+24 */ + ((full_typ & T_FULL_BINDER) != + 0) ? ((is_pair(obj)) ? " tree-collected" + : ((is_hash_table(obj)) ? " simple-values" + : ((is_normal_symbol(obj)) ? " binder" + : ((is_c_function(obj)) ? " safe-args" : + " ?27?")))) : "", + /* bit 28+24 */ + ((full_typ & T_VERY_SAFE_CLOSURE) != 0) ? (((is_pair(obj)) + || + (is_any_closure + (obj))) ? + " very-safe-closure" + : ((is_let(obj)) ? + " baffle-let" : + " ?28?")) : "", + /* bit 29+24 */ + ((full_typ & T_CYCLIC) != + 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) + || (is_any_closure(obj))) ? " cyclic" : " ?29?") : "", + /* bit 30+24 */ + ((full_typ & T_CYCLIC_SET) != + 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) + || (is_any_closure(obj))) ? " cyclic-set" : " ?30?") : + "", + /* bit 31+24 */ + ((full_typ & T_KEYWORD) != + 0) ? ((is_symbol(obj)) ? " keyword" : " ?31?") : "", + /* bit 32+24 */ + ((full_typ & T_FULL_SIMPLE_ELEMENTS) != + 0) ? ((is_normal_vector(obj)) ? " simple-elements" + : ((is_hash_table(obj)) ? " simple-keys" + : ((is_normal_symbol(obj)) ? " safe-setter" + : ((is_pair(obj)) ? " float-optable" + : ((typ >= + T_C_MACRO) ? " function-simple-elements" : + " 32?"))))) : "", + /* bit 33+24 */ + ((full_typ & T_FULL_CASE_KEY) != + 0) ? ((is_symbol(obj)) ? " case-key" : ((is_pair(obj)) ? + " opt1-func-listed" : + " ?33?")) : "", + /* bit 34+24 */ + ((full_typ & T_FULL_HAS_GX) != + 0) ? ((is_pair(obj)) ? " has-gx" : " ?34?") : "", + /* bit 35+24 */ + ((full_typ & T_FULL_UNKNOPT) != + 0) ? ((is_pair(obj)) ? " unknopt" : " ?35?") : "", + /* bit 36+24 */ + ((full_typ & T_FULL_SAFETY_CHECKED) != + 0) ? ((is_pair(obj)) ? " safety-checked" : " ?36?") : "", + /* bit 37+24 */ + ((full_typ & T_FULL_HAS_FN) != + 0) ? ((is_pair(obj)) ? " has-fn" : " ?37") : "", + /* bit 62 */ + ((full_typ & T_UNHEAP) != 0) ? " unheap" : "", + /* bit 63 */ + ((full_typ & T_GC_MARK) != 0) ? " gc-marked" : "", + ((full_typ & UNUSED_BITS) != 0) ? " unused bits set?" : "", + ((is_symbol(obj)) + && (((uint8_t) (symbol_type(obj) & 0xff) >= NUM_TYPES) + || ((symbol_type(obj) & ~0xffff) != + 0))) ? " bad-symbol-type" : "", NULL); + + buf = (char *) Malloc(1024); + snprintf(buf, 1024, + "type: %s? (%d), opt_op: %d, flags: #x%" PRIx64 "%s", + type_name(sc, obj, NO_ARTICLE), + typ, optimize_op(obj), full_typ, str); + return (buf); +} + +/* snprintf returns the number of bytes that would have been written: (display (c-pointer 123123123 (symbol (make-string 130 #\a)))) */ +#define clamp_length(NLen, Len) (((NLen) < (Len)) ? (NLen) : (Len)) + +#if S7_DEBUGGING +static bool has_odd_bits(s7_pointer obj) +{ + uint64_t full_typ = full_type(obj); + if ((full_typ & UNUSED_BITS) != 0) + return (true); + if (((full_typ & T_MULTIFORM) != 0) && (!is_any_closure(obj))) + return (true); + if (((full_typ & T_KEYWORD) != 0) + && ((!is_symbol(obj)) || (!is_global(obj)) || (is_gensym(obj)))) + return (true); + if (((full_typ & T_SYNTACTIC) != 0) && (!is_syntax(obj)) + && (!is_pair(obj)) && (!is_normal_symbol(obj))) + return (true); + if (((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) && (!is_pair(obj)) + && (!is_any_closure(obj))) + return (true); + if (((full_typ & T_OPTIMIZED) != 0) && (!is_c_function(obj)) + && (!is_pair(obj))) + return (true); + if (((full_typ & T_SAFE_CLOSURE) != 0) && (!is_any_closure(obj)) + && (!is_pair(obj))) + return (true); + if (((full_typ & T_SAFE_PROCEDURE) != 0) && (!is_applicable(obj))) + return (true); + if (((full_typ & T_EXPANSION) != 0) && (!is_normal_symbol(obj)) + && (!is_either_macro(obj))) + return (true); + if (((full_typ & T_MULTIPLE_VALUE) != 0) && (!is_symbol(obj)) + && (!is_pair(obj))) + return (true); + if (((full_typ & T_GLOBAL) != 0) && (!is_pair(obj)) + && (!is_symbol(obj)) && (!is_let(obj)) && (!is_syntax(obj))) + return (true); + if (((full_typ & T_ITER_OK) != 0) && (!is_iterator(obj)) + && (!is_pair(obj)) && (!is_slot(obj)) && (!is_c_function(obj))) + return (true); + if (((full_typ & T_LOCAL) != 0) && (!is_normal_symbol(obj)) + && (!is_pair(obj))) + return (true); + if (((full_typ & T_UNSAFE) != 0) && (!is_symbol(obj)) + && (!is_slot(obj)) && (!is_let(obj)) && (!is_pair(obj))) + return (true); + if (((full_typ & T_VERY_SAFE_CLOSURE) != 0) && (!is_pair(obj)) + && (!is_any_closure(obj)) && (!is_let(obj))) + return (true); + if (((full_typ & T_FULL_CASE_KEY) != 0) && (!is_symbol(obj)) + && (!is_pair(obj))) + return (true); + if (((full_typ & T_FULL_UNKNOPT) != 0) && (!is_pair(obj))) + return (true); + if (((full_typ & T_FULL_SAFETY_CHECKED) != 0) && (!is_pair(obj))) + return (true); + if (((full_typ & T_FULL_HAS_GX) != 0) && (!is_pair(obj)) + && (!is_any_closure(obj))) + return (true); + if (((full_typ & T_DONT_EVAL_ARGS) != 0) && (!is_any_macro(obj)) + && (!is_syntax(obj))) + return (true); + if (((full_typ & T_CHECKED) != 0) && (!is_slot(obj)) && (!is_pair(obj)) + && (!is_symbol(obj))) + return (true); + if (((full_typ & T_SHARED) != 0) && (!t_sequence_p[type(obj)]) + && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) + return (true); + if (((full_typ & T_COPY_ARGS) != 0) && + (!is_pair(obj)) && (!is_any_macro(obj)) && (!is_any_closure(obj)) + && (!is_c_function(obj)) && (!is_syntax(obj))) + return (true); + if (((full_typ & T_FULL_SYMCONS) != 0) && + (!is_symbol(obj)) && (!is_procedure(obj)) && (!is_let(obj)) + && (!is_hash_table(obj)) && (!is_pair(obj))) + return (true); + if (((full_typ & T_FULL_BINDER) != 0) && + ((!is_pair(obj)) && (!is_hash_table(obj)) + && (!is_normal_symbol(obj)) && (!is_c_function(obj)) + && (!is_syntax(obj)))) + return (true); + if (((full_typ & T_FULL_DEFINER) != 0) && + (!is_normal_symbol(obj)) && (!is_c_function(obj)) + && (!is_pair(obj)) && (!is_slot(obj)) && (!is_iterator(obj)) + && (!is_hash_table(obj)) && (!is_let(obj)) && (!is_syntax(obj))) + return (true); + if (((full_typ & T_FULL_HAS_LET_FILE) != 0) && + (!is_let(obj)) && (!is_any_vector(obj)) && (!is_hash_table(obj)) + && (!is_c_function(obj)) && (!is_slot(obj)) && (!is_pair(obj)) + && (!is_closure_star(obj))) + return (true); + if (((full_typ & T_SAFE_STEPPER) != 0) && + (!is_let(obj)) && (!is_slot(obj)) && (!is_c_function(obj)) + && (!is_number(obj)) && (!is_pair(obj)) && (!is_hash_table(obj)) + && (!is_any_macro(obj)) && (!is_symbol(obj))) + return (true); + if (((full_typ & T_SETTER) != 0) && + (!is_slot(obj)) && (!is_normal_symbol(obj)) && (!is_pair(obj)) + && (!is_let(obj)) && (!is_c_function_star(obj))) + return (true); + if (((full_typ & T_LOCATION) != 0) && + (!is_pair(obj)) && (!is_input_port(obj)) && (!is_let(obj)) + && (!is_any_procedure(obj)) && (!is_symbol(obj)) + && (!is_slot(obj))) + return (true); + if (((full_typ & T_MUTABLE) != 0) && + (!is_number(obj)) && (!is_symbol(obj)) && (!is_let(obj)) + && (!is_iterator(obj)) && (!is_slot(obj)) && (!is_let(obj)) + && (!is_pair(obj))) + return (true); + if (((full_typ & T_GENSYM) != 0) && (!is_slot(obj)) + && (!is_any_closure(obj)) && (!is_let(obj)) && (!is_symbol(obj)) + && (!is_string(obj)) && (!is_hash_table(obj)) && (!is_pair(obj)) + && (!is_any_vector(obj))) + return (true); + if (((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) && + ((!is_normal_vector(obj)) && (!is_hash_table(obj)) + && (!is_normal_symbol(obj)) && (!is_pair(obj)) + && (unchecked_type(obj) < T_C_MACRO))) + return (true); + if (((full_typ & T_CYCLIC) != 0) && (!is_simple_sequence(obj)) + && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) + return (true); + if (((full_typ & T_CYCLIC_SET) != 0) && (!is_simple_sequence(obj)) + && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) + return (true); + if (((full_typ & T_FULL_HAS_FN) != 0) && (!is_pair(obj))) + return (true); + + if (is_symbol(obj)) { + if ((uint8_t) (symbol_type(obj) & 0xff) >= NUM_TYPES) + return (true); + if ((symbol_type(obj) & ~0xffff) != 0) + return (true); + } + if ((signed_type(obj) == 0) && ((full_typ & T_GC_MARK) != 0)) + return (true); + return (false); +} + +static const char *check_name(s7_scheme * sc, int32_t typ) +{ + if ((typ >= 0) && (typ < NUM_TYPES)) { + s7_pointer p; + p = sc->prepackaged_type_names[typ]; + if (is_string(p)) + return (string_value(p)); + } + return ("unknown type!"); +} + +#if REPORT_ROOTLET_REDEF +static void set_local_1(s7_scheme * sc, s7_pointer symbol, + const char *func, int32_t line) +{ + if (is_global(symbol)) { + fprintf(stderr, "%s[%d]: %s%s%s in %s\n", + func, line, + BOLD_TEXT, s7_object_to_c_string(sc, symbol), UNBOLD_TEXT, + display_80(sc->cur_code)); + /* gdb_break(); */ + } + full_type(symbol) = + (full_type(symbol) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC)); +} +#endif + +static char *safe_object_to_string(s7_pointer p) +{ + char *buf; + buf = (char *) Malloc(128); + snprintf(buf, 128, "type: %d", unchecked_type(p)); + return (buf); +} + +static void complain(const char *complaint, s7_pointer p, const char *func, + int line, uint8_t typ) +{ + fprintf(stderr, complaint, BOLD_TEXT, func, line, + check_name(cur_sc, typ), safe_object_to_string(p), + UNBOLD_TEXT); + if (cur_sc->stop_at_error) + abort(); +} + +static char *show_debugger_bits(s7_pointer obj); + +static s7_pointer check_ref(s7_pointer p, uint8_t expected_type, + const char *func, int32_t line, + const char *func1, const char *func2) +{ + if (!p) + fprintf(stderr, "%s[%d]: null pointer passed to check_ref\n", func, + line); + else { + uint8_t typ = unchecked_type(p); + if (typ != expected_type) { + if ((!func1) || (typ != T_FREE)) { + fprintf(stderr, "%s%s[%d]: not %s, but %s (%s)%s\n", + BOLD_TEXT, + func, line, check_name(cur_sc, expected_type), + check_name(cur_sc, typ), safe_object_to_string(p), + UNBOLD_TEXT); + if (cur_sc->stop_at_error) + abort(); + } else + if ((strcmp(func, func1) != 0) && + ((!func2) || (strcmp(func, func2) != 0))) { + fprintf(stderr, "%s%s[%d]: free cell, not %s%s\n", + BOLD_TEXT, func, line, check_name(cur_sc, + expected_type), + UNBOLD_TEXT); + if (cur_sc->stop_at_error) + abort(); + } + } + } + return (p); +} + +static s7_pointer check_let_ref(s7_pointer p, uint64_t role, + const char *func, int32_t line) +{ + check_ref(p, T_LET, func, line, NULL, NULL); + if ((p->debugger_bits & L_HIT) == 0) + fprintf(stderr, "%s[%d]: let not set\n", func, line); + if ((p->debugger_bits & L_MASK) != role) + fprintf(stderr, "%s[%d]: let bad role\n", func, line); + return (p); +} + +static s7_pointer check_let_set(s7_pointer p, uint64_t role, + const char *func, int32_t line) +{ + check_ref(p, T_LET, func, line, NULL, NULL); + p->debugger_bits &= (~L_MASK); + p->debugger_bits |= (L_HIT | role); + return (p); +} + +static s7_pointer check_ref2(s7_pointer p, uint8_t expected_type, + int32_t other_type, const char *func, + int32_t line, const char *func1, + const char *func2) +{ + if (!p) + fprintf(stderr, "%s[%d]: null pointer passed to check_ref2\n", + func, line); + else { + uint8_t typ = unchecked_type(p); + if ((typ != expected_type) && (typ != other_type)) + return (check_ref(p, expected_type, func, line, func1, func2)); + } + return (p); +} + +static s7_pointer check_ref3(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = unchecked_type(p); + if ((typ != T_INPUT_PORT) && (typ != T_OUTPUT_PORT) && (typ != T_FREE)) + complain("%s%s[%d]: not a port, but %s (%s)%s\n", p, func, line, + typ); + return (p); +} + +static s7_pointer check_ref4(s7_pointer p, const char *func, int32_t line) +{ + if ((strcmp(func, "sweep") != 0) && + (strcmp(func, "process_multivector") != 0)) { + uint8_t typ = unchecked_type(p); + if (!t_vector_p[typ]) + complain("%s%s[%d]: not a vector, but %s (%s)%s\n", p, func, + line, typ); + } + return (p); +} + +static s7_pointer check_ref5(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = unchecked_type(p); + if (!t_has_closure_let[typ]) + complain("%s%s[%d]: not a closure, but %s (%s)%s\n", p, func, line, + typ); + return (p); +} + +static s7_pointer check_ref6(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = unchecked_type(p); + if (typ < T_C_MACRO) + complain("%s%s[%d]: not a c function, but %s (%s)%s\n", p, func, + line, typ); + return (p); +} + +static s7_pointer check_ref7(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = unchecked_type(p); + if ((typ < T_INTEGER) || (typ > T_COMPLEX)) + complain("%s%s[%d]: not a number, but %s (%s)%s\n", p, func, line, + typ); + return (p); +} + +static s7_pointer check_ref8(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = unchecked_type(p); + if ((!t_sequence_p[typ]) && (!t_structure_p[typ]) && (!is_any_closure(p))) /* closure as iterator -- see s7test */ + complain("%s%s[%d]: not a sequence or structure, but %s (%s)%s\n", + p, func, line, typ); + return (p); +} + +static s7_pointer check_ref9(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = unchecked_type(p); + if ((typ != T_LET) && (typ != T_C_OBJECT) && (!is_any_closure(p)) + && (!is_any_macro(p)) && (typ != T_C_POINTER)) + complain("%s%s[%d]: not a possible method holder, but %s (%s)%s\n", + p, func, line, typ); + return (p); +} + +static s7_pointer check_ref10(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = unchecked_type(p); + if ((typ != T_PAIR) && (typ != T_NIL) && (typ != T_SYMBOL)) + complain("%s%s[%d]: arglist is %s (%s)%s?\n", p, func, line, typ); + return (p); +} + +static s7_pointer check_ref11(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = unchecked_type(p); + if ((!t_applicable_p[typ]) && (p != cur_sc->F)) + complain("%s%s[%d]: applicable object is %s (%s)%s?\n", p, func, + line, typ); + return (p); +} + +static s7_pointer check_ref12(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ; + if (is_slot_end(p)) + return (p); + typ = unchecked_type(p); + if ((typ != T_SLOT) && (typ != T_NIL)) /* unset slots are nil */ + complain("%s%s[%d]: slot is %s (%s)%s?\n", p, func, line, typ); + return (p); +} + +static s7_pointer check_ref13(s7_pointer p, const char *func, int32_t line) +{ + if (!is_any_vector(p)) + complain("%s%s[%d]: subvector is %s (%s)%s?\n", p, func, line, + unchecked_type(p)); + if (!is_subvector(p)) + complain + ("%s%s[%d]: subvector is %s (%s), but not a subvector?%s\n", p, + func, line, unchecked_type(p)); + return (p); +} + +static s7_pointer check_ref14(s7_pointer p, const char *func, int32_t line) +{ + if ((!is_any_procedure(p)) && (!s7_is_boolean(p))) + complain("%s%s[%d]: procedure setter is %s (%s)%s?\n", p, func, + line, unchecked_type(p)); + return (p); +} + +static s7_pointer check_ref15(s7_pointer p, const char *func, int32_t line) +{ /* called in mark_let so s7_scheme* for cur_sc is difficult */ + uint8_t typ; + check_nref(p, func, line); + typ = unchecked_type(p); + if ((is_multiple_value(p)) && (!safe_strcmp(func, "mark_slot"))) /* match == multiple-values which causes false error messages */ + complain("%s%s[%d]: slot value is a multiple-value, %s (%s)%s?\n", + p, func, line, typ); + if (has_odd_bits(p)) { + char *s; + fprintf(stderr, "odd bits: %s\n", s = + describe_type_bits(cur_sc, p)); + free(s); + } + return (p); +} + +static s7_pointer check_ref16(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ; + check_nref(p, func, line); + typ = unchecked_type(p); + if ((typ != T_LET) && (typ != T_NIL)) + complain("%s%s[%d]: not a let or nil, but %s (%s)%s\n", p, func, + line, typ); + return (p); +} + +static s7_pointer check_ref17(s7_pointer p, const char *func, int32_t line) +{ + if ((!is_any_macro(p)) || (is_c_macro(p))) + complain("%s%s[%d]: macro is %s (%s)%s?\n", p, func, line, + unchecked_type(p)); + return (p); +} + +static s7_pointer check_cell(s7_scheme * sc, s7_pointer p, + const char *func, int32_t line) +{ + if (!p) { + fprintf(stderr, "%s%s[%d]: null pointer!%s\n", BOLD_TEXT, func, + line, UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } else if (unchecked_type(p) >= NUM_TYPES) { + fprintf(stderr, + "%s%s[%d]: attempt to use messed up cell (type: %d)%s\n", + BOLD_TEXT, func, line, unchecked_type(p), UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + return (p); +} + +static void print_gc_info(s7_scheme * sc, s7_pointer obj, int32_t line) +{ + if (!obj) + fprintf(stderr, "[%d]: obj is %p\n", line, obj); + else if (unchecked_type(obj) != T_FREE) + fprintf(stderr, "[%d]: %p type is %d?\n", line, obj, + unchecked_type(obj)); + else { + s7_int free_type; + char *bits; + char fline[128]; + free_type = full_type(obj); + full_type(obj) = obj->current_alloc_type; + printing_gc_info = true; + bits = describe_type_bits(sc, obj); /* this func called in type macro */ + printing_gc_info = false; + full_type(obj) = free_type; + if (obj->explicit_free_line > 0) + snprintf(fline, 128, ", freed at %d, ", + obj->explicit_free_line); + fprintf(stderr, + "%s%p is free (line %d, alloc type: %s %" ld64 " #x%" + PRIx64 + " (%s)), current: %s[%d], previous: %s[%d], %sgc: %s[%d]%s\n", + BOLD_TEXT, obj, line, + s7_type_names[obj->current_alloc_type & 0xff], + obj->current_alloc_type, obj->current_alloc_type, bits, + obj->current_alloc_func, obj->current_alloc_line, + obj->previous_alloc_func, obj->previous_alloc_line, + (obj->explicit_free_line > 0) ? fline : "", obj->gc_func, + obj->gc_line, UNBOLD_TEXT); + free(bits); + } + if (sc->stop_at_error) + abort(); +} + +static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line) +{ + check_cell(cur_sc, p, func, line); + if (unchecked_type(p) == T_FREE) { + fprintf(stderr, "%s%s[%d]: attempt to use free cell%s\n", + BOLD_TEXT, func, line, UNBOLD_TEXT); + print_gc_info(cur_sc, p, line); + } + return (p); +} + +static const char *opt1_role_name(uint64_t role) +{ + if (role == OPT1_FAST) + return ("opt1_fast"); + if (role == OPT1_CFUNC) + return ("opt1_cfunc"); + if (role == OPT1_LAMBDA) + return ("opt_lambda"); + if (role == OPT1_CLAUSE) + return ("opt1_clause"); + if (role == OPT1_SYM) + return ("opt1_sym"); + if (role == OPT1_PAIR) + return ("opt1_pair"); + if (role == OPT1_CON) + return ("opt1_con"); + if (role == OPT1_ANY) + return ("opt1_any"); + return ((role == OPT1_HASH) ? "opt1_hash" : "opt1_unknown"); +} + +static const char *opt2_role_name(uint64_t role) +{ + if (role == OPT2_FX) + return ("opt2_fx"); + if (role == OPT2_FN) + return ("opt2_fn"); + if (role == OPT2_KEY) + return ("opt2_any"); + if (role == OPT2_SLOW) + return ("opt2_slow"); + if (role == OPT2_SYM) + return ("opt2_sym"); + if (role == OPT2_PAIR) + return ("opt2_pair"); + if (role == OPT2_CON) + return ("opt2_con"); + if (role == OPT2_LAMBDA) + return ("opt2_lambda"); + if (role == OPT2_DIRECT) + return ("opt2_direct"); + if (role == OPT2_INT) + return ("opt2_int"); + return ((role == OPT2_NAME) ? "opt2_raw_name" : "opt2_unknown"); +} + +static const char *opt3_role_name(uint64_t role) +{ + if (role == OPT3_ARGLEN) + return ("opt3_arglen"); + if (role == OPT3_SYM) + return ("opt3_sym"); + if (role == OPT3_CON) + return ("opt3_con"); + if (role == OPT3_AND) + return ("opt3_pair"); + if (role == OPT3_ANY) + return ("opt3_any"); + if (role == OPT3_LET) + return ("opt3_let"); + if (role == OPT3_BYTE) + return ("opt3_byte"); + if (role == OPT3_DIRECT) + return ("direct_opt3"); + if (role == OPT3_LEN) + return ("opt3_len"); + if (role == OPT3_INT) + return ("opt3_int"); + return ((role == OPT3_LOCATION) ? "opt3_location" : "opt3_unknown"); +} + +static char *show_debugger_bits(s7_pointer p) +{ + char *bits_str; + int64_t bits = p->debugger_bits; + bits_str = (char *) Malloc(512); + snprintf(bits_str, 512, + " %s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s", + ((bits & OPT1_SET) != 0) ? " opt1_set" : "", + ((bits & OPT1_FAST) != 0) ? " opt1_fast" : "", + ((bits & OPT1_CFUNC) != 0) ? " opt1_cfunc" : "", + ((bits & OPT1_CLAUSE) != 0) ? " opt1_clause" : "", + ((bits & OPT1_LAMBDA) != 0) ? " opt_lambda" : "", + ((bits & OPT1_SYM) != 0) ? " opt1_sym" : "", + ((bits & OPT1_PAIR) != 0) ? " opt1_pair" : "", + ((bits & OPT1_CON) != 0) ? " opt1_con" : "", + ((bits & OPT1_ANY) != 0) ? " opt1_any" : "", + ((bits & OPT1_HASH) != 0) ? " opt1_raw_hash" : "", + ((bits & OPT2_SET) != 0) ? " opt2_set" : "", + ((bits & OPT2_KEY) != 0) ? " opt2_any" : "", + ((bits & OPT2_SLOW) != 0) ? " opt2_slow" : "", + ((bits & OPT2_SYM) != 0) ? " opt2_sym" : "", + ((bits & OPT2_PAIR) != 0) ? " opt2_pair" : "", + ((bits & OPT2_CON) != 0) ? " opt2_con" : "", + ((bits & OPT2_FX) != 0) ? " opt2_fx" : "", + ((bits & OPT2_FN) != 0) ? " opt2_fn" : "", + ((bits & OPT2_LAMBDA) != 0) ? " opt2_lambda" : "", + ((bits & OPT2_DIRECT) != 0) ? " opt2_direct" : "", + ((bits & OPT2_NAME) != 0) ? " opt2_raw_name" : "", + ((bits & OPT2_INT) != 0) ? " opt2_int" : "", + ((bits & OPT3_SET) != 0) ? " opt3_set" : "", + ((bits & OPT3_ARGLEN) != 0) ? " opt3_arglen" : "", + ((bits & OPT3_SYM) != 0) ? " opt3_sym" : "", + ((bits & OPT3_CON) != 0) ? " opt3_con" : "", + ((bits & OPT3_AND) != 0) ? " opt3_pair " : "", + ((bits & OPT3_ANY) != 0) ? " opt3_any " : "", + ((bits & OPT3_LET) != 0) ? " opt3_let " : "", + ((bits & OPT3_BYTE) != 0) ? " opt3_byte " : "", + ((bits & OPT3_DIRECT) != 0) ? " opt3_direct" : "", + ((bits & OPT3_LOCATION) != 0) ? " opt3_location" : "", + ((bits & OPT3_LEN) != 0) ? " opt3_len" : "", + ((bits & OPT3_INT) != 0) ? " opt3_int" : "", + ((bits & L_HIT) != 0) ? " let_set" : "", + ((bits & L_FUNC) != 0) ? " let_func" : "", + ((bits & L_DOX) != 0) ? " let_dox" : "", + ((bits & L_CATCH) != 0) ? " let_catch" : ""); + return (bits_str); +} + +static void show_opt1_bits(s7_pointer p, const char *func, int32_t line, + uint64_t role) +{ + char *bits; + bits = show_debugger_bits(p); + fprintf(stderr, + "%s%s[%d]%s: opt1: %p->%p wants %s, debugger bits are %" PRIx64 + "%s but expects %lx", BOLD_TEXT, func, line, UNBOLD_TEXT, p, + p->object.cons.opt1, opt1_role_name(role), p->debugger_bits, + bits, role); + free(bits); +} + +static s7_pointer opt1_1(s7_scheme * sc, s7_pointer p, uint64_t role, + const char *func, int32_t line) +{ + if ((!opt1_is_set(p)) || + ((!opt1_role_matches(p, role)) && (role != OPT1_ANY))) { + show_opt1_bits(p, func, line, role); + if (sc->stop_at_error) + abort(); + } + return (p->object.cons.opt1); +} + +static void base_opt1(s7_pointer p, uint64_t role) +{ + set_opt1_role(p, role); + set_opt1_is_set(p); +} + +static s7_pointer set_opt1_1(s7_pointer p, s7_pointer x, uint64_t role) +{ + /* if ((opt1_role_matches(p, OPT1_LAMBDA)) && (role != OPT1_LAMBDA)) fprintf(stderr, "reset opt1_lambda to %s\n", opt1_role_name(role)); */ + p->object.cons.opt1 = x; + base_opt1(p, role); + return (x); +} + +static uint64_t opt1_hash_1(s7_scheme * sc, s7_pointer p, const char *func, + int32_t line) +{ + if ((!opt1_is_set(p)) || (!opt1_role_matches(p, OPT1_HASH))) { + show_opt1_bits(p, func, line, (uint64_t) OPT1_HASH); + if (sc->stop_at_error) + abort(); + } + return (p->object.sym_cons.hash); +} + +static void set_opt1_hash_1(s7_pointer p, uint64_t x) +{ + p->object.sym_cons.hash = x; + base_opt1(p, OPT1_HASH); +} + +static void show_opt2_bits(s7_pointer p, const char *func, int32_t line, + uint64_t role) +{ + char *bits; + bits = show_debugger_bits(p); + fprintf(stderr, + "%s%s[%d]%s: opt2: %p->%p wants %s, debugger bits are %" PRIx64 + "%s but expects %lx %s", BOLD_TEXT, func, line, UNBOLD_TEXT, p, + p->object.cons.opt2, opt2_role_name(role), p->debugger_bits, + bits, role, opt2_role_name(role)); + free(bits); +} + +static bool f_call_func_mismatch(const char *func) +{ + return ((!safe_strcmp(func, "check_and")) && /* these reflect set_fx|unchecked where the destination checks for null fx_proc */ + (!safe_strcmp(func, "check_or")) && + (!safe_strcmp(func, "eval")) && + (!safe_strcmp(func, "set_any_c_np")) && + (!safe_strcmp(func, "set_any_closure_np")) && + (!safe_strcmp(func, "optimize_func_two_args")) && + (!safe_strcmp(func, "optimize_func_many_args")) && + (!safe_strcmp(func, "optimize_func_three_args")) && + (!safe_strcmp(func, "fx_c_ff")) && + (!safe_strcmp(func, "op_map_for_each_fa")) && + (!safe_strcmp(func, "op_map_for_each_faa"))); +} + +static s7_pointer opt2_1(s7_scheme * sc, s7_pointer p, uint64_t role, + const char *func, int32_t line) +{ + if (!p) { + fprintf(stderr, "%s%s[%d]: opt2 null!\n%s", BOLD_TEXT, func, line, + UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + if ((!opt2_is_set(p)) || (!opt2_role_matches(p, role))) { + show_opt2_bits(p, func, line, role); + if (sc->stop_at_error) + abort(); + } + return (p->object.cons.opt2); +} + +static void base_opt2(s7_pointer p, uint64_t role) +{ + set_opt2_role(p, role); + set_opt2_is_set(p); +} + +static void set_opt2_1(s7_scheme * sc, s7_pointer p, s7_pointer x, + uint64_t role, const char *func, int32_t line) +{ + if ((role == OPT2_FX) && (x == NULL) && (f_call_func_mismatch(func))) + fprintf(stderr, "%s[%d]: set fx_proc for %s to null (%s%s%s)\n", + func, line, + string_value(object_to_truncated_string(sc, p, 80)), + ((is_h_optimized(car(p))) + && (is_safe_c_op(optimize_op(car(p))))) ? BOLD_TEXT : "", + op_names[optimize_op(car(p))], ((is_h_optimized(car(p))) + && + (is_safe_c_op + (optimize_op(car(p))))) ? + UNBOLD_TEXT : ""); + if ((role != OPT2_FX) && (role != OPT2_DIRECT) && (has_fx(p))) /* sometimes opt2_direct just specializes fx */ + fprintf(stderr, "%s[%d]: overwrite has_fx: %s %s\n", func, line, + opt2_role_name(role), display_80(p)); + p->object.cons.opt2 = x; + base_opt2(p, role); +} + +static const char *opt2_name_1(s7_scheme * sc, s7_pointer p, + const char *func, int32_t line) +{ + if ((!opt2_is_set(p)) || (!opt2_role_matches(p, OPT2_NAME))) { + show_opt2_bits(p, func, line, (uint64_t) OPT2_NAME); + if (sc->stop_at_error) + abort(); + } + return (p->object.sym_cons.fstr); +} + +static void set_opt2_name_1(s7_pointer p, const char *str) +{ + p->object.sym_cons.fstr = str; + base_opt2(p, OPT2_NAME); +} + +static void show_opt3_bits(s7_pointer p, const char *func, int32_t line, + uint64_t role) +{ + char *bits; + bits = show_debugger_bits(p); + fprintf(stderr, "%s%s[%d]%s: opt3: %s %" PRIx64 "%s", BOLD_TEXT, func, + line, UNBOLD_TEXT, opt3_role_name(role), p->debugger_bits, + bits); + free(bits); +} + +static void check_opt3_bits(s7_scheme * sc, s7_pointer p, uint64_t role, + const char *func, int32_t line) +{ + if ((!opt3_is_set(p)) || (!opt3_role_matches(p, role))) { + show_opt3_bits(p, func, line, role); + if (sc->stop_at_error) + abort(); + } +} + +static s7_pointer opt3_1(s7_scheme * sc, s7_pointer p, uint64_t role, + const char *func, int32_t line) +{ + check_opt3_bits(sc, p, role, func, line); + return (p->object.cons.opt3); +} + +static void base_opt3(s7_pointer p, uint64_t role) +{ + set_opt3_role(p, role); + set_opt3_is_set(p); +} + +static void set_opt3_1(s7_pointer p, s7_pointer x, uint64_t role) +{ + clear_type_bit(p, T_LOCATION); + p->object.cons.opt3 = x; + base_opt3(p, role); +} + +static uint8_t opt3_byte_1(s7_scheme * sc, s7_pointer p, uint64_t role, + const char *func, int32_t line) +{ + check_opt3_bits(sc, p, role, func, line); + return (p->object.cons_ext.opt_type); +} + +static void set_opt3_byte_1(s7_pointer p, uint8_t x, uint64_t role, + const char *func, int32_t line) +{ + clear_type_bit(p, T_LOCATION); + p->object.cons_ext.opt_type = x; + base_opt3(p, role); +} + +static uint64_t opt3_location_1(s7_scheme * sc, s7_pointer p, + const char *func, int32_t line) +{ + if ((!opt3_is_set(p)) || + ((p->debugger_bits & OPT3_LOCATION) == 0) || (!has_location(p))) { + show_opt3_bits(p, func, line, (uint64_t) OPT3_LOCATION); + if (sc->stop_at_error) + abort(); + } + return (p->object.sym_cons.location); +} + +static void set_opt3_location_1(s7_pointer p, uint64_t x) +{ + p->object.sym_cons.location = x; + (p)->debugger_bits = (OPT3_LOCATION | (p->debugger_bits & ~OPT3_LEN)); /* turn on line, cancel len */ + set_opt3_is_set(p); +} + +static uint64_t opt3_len_1(s7_scheme * sc, s7_pointer p, const char *func, + int32_t line) +{ + if ((!opt3_is_set(p)) || + ((p->debugger_bits & OPT3_LEN) == 0) || (has_location(p))) { + show_opt3_bits(p, func, line, (uint64_t) OPT3_LEN); + if (sc->stop_at_error) + abort(); + } + return (p->object.sym_cons.location); +} + +static void set_opt3_len_1(s7_pointer p, uint64_t x) +{ + clear_type_bit(p, T_LOCATION); + p->object.sym_cons.location = x; + (p)->debugger_bits = + (OPT3_LEN | (p->debugger_bits & ~(OPT3_LOCATION))); + set_opt3_is_set(p); +} + +static void print_debugging_state(s7_scheme * sc, s7_pointer obj, + s7_pointer port) +{ + /* show current state, current allocated state, and previous allocated state */ + char *current_bits, *allocated_bits, *previous_bits, *str; + int64_t save_full_type; + s7_int len, nlen; + const char *excl_name; + block_t *b; + + excl_name = (is_free(obj)) ? "free cell!" : "unknown object!"; + current_bits = describe_type_bits(sc, obj); + save_full_type = full_type(obj); + full_type(obj) = obj->current_alloc_type; + allocated_bits = describe_type_bits(sc, obj); + full_type(obj) = obj->previous_alloc_type; + previous_bits = describe_type_bits(sc, obj); + full_type(obj) = save_full_type; + + len = safe_strlen(excl_name) + + safe_strlen(current_bits) + safe_strlen(allocated_bits) + + safe_strlen(previous_bits) + + safe_strlen(obj->previous_alloc_func) + + safe_strlen(obj->current_alloc_func) + 512; + + b = mallocate(sc, len); + str = (char *) block_data(b); + nlen = snprintf(str, len, + "\n<%s %s,\n current: %s[%d] %s,\n previous: %s[%d] %s\n %d uses>", + excl_name, current_bits, + obj->current_alloc_func, obj->current_alloc_line, + allocated_bits, obj->previous_alloc_func, + obj->previous_alloc_line, previous_bits, obj->uses); + free(current_bits); + free(allocated_bits); + free(previous_bits); + if (is_null(port)) + fprintf(stderr, "%p: %s\n", obj, str); + else + port_write_string(port) (sc, str, clamp_length(nlen, len), port); + liberate(sc, b); +} + +static s7_pointer symbol_to_local_slot(s7_scheme * sc, s7_pointer symbol, + s7_pointer e); +static s7_pointer check_null_sym(s7_scheme * sc, s7_pointer p, + s7_pointer sym, int32_t line, + const char *func) +{ + if (!p) { + s7_pointer slot; + char *s; + fprintf(stderr, "%s%s[%d]: %s unbound%s\n", BOLD_TEXT, func, line, + symbol_name(sym), UNBOLD_TEXT); + fprintf(stderr, + " symbol_id: %" ld64 ", let_id: %" ld64 ", bits: %s", + symbol_id(sym), let_id(sc->curlet), s = + describe_type_bits(sc, sym)); + free(s); + slot = symbol_to_local_slot(sc, sym, sc->curlet); + if (is_slot(slot)) + fprintf(stderr, ", slot: %s", display(slot)); + fprintf(stderr, "\n"); + if (sc->stop_at_error) + abort(); + } + return (p); +} +#endif /* S7_DEBUGGING */ +/* -------------------------------- end internal debugging apparatus -------------------------------- */ + + +static s7_pointer set_elist_1(s7_scheme * sc, s7_pointer x1) +{ + set_car(sc->elist_1, x1); + return (sc->elist_1); +} + +static s7_pointer set_elist_2(s7_scheme * sc, s7_pointer x1, s7_pointer x2) +{ + set_car(sc->elist_2, x1); + set_cadr(sc->elist_2, x2); + return (sc->elist_2); +} + +static s7_pointer set_elist_3(s7_scheme * sc, s7_pointer x1, s7_pointer x2, + s7_pointer x3) +{ + s7_pointer p; + p = sc->elist_3; + set_car(p, x1); + p = cdr(p); + set_car(p, x2); + p = cdr(p); + set_car(p, x3); + return (sc->elist_3); +} + +static s7_pointer set_elist_4(s7_scheme * sc, s7_pointer x1, s7_pointer x2, + s7_pointer x3, s7_pointer x4) +{ + s7_pointer p; + p = sc->elist_4; + set_car(p, x1); + p = cdr(p); + set_car(p, x2); + p = cdr(p); + set_car(p, x3); + p = cdr(p); + set_car(p, x4); + return (sc->elist_4); +} + +static s7_pointer set_elist_5(s7_scheme * sc, s7_pointer x1, s7_pointer x2, + s7_pointer x3, s7_pointer x4, s7_pointer x5) +{ + s7_pointer p; + p = sc->elist_5; + set_car(p, x1); + p = cdr(p); + set_car(p, x2); + p = cdr(p); + set_car(p, x3); + p = cdr(p); + set_car(p, x4); + p = cdr(p); + set_car(p, x5); + return (sc->elist_5); +} + +static s7_pointer set_wlist_3(s7_pointer lst, s7_pointer x1, s7_pointer x2, + s7_pointer x3) +{ + s7_pointer p; + p = lst; + set_car(p, x1); + p = cdr(p); + set_car(p, x2); + p = cdr(p); + set_car(p, x3); + return (lst); +} + +static s7_pointer set_wlist_4(s7_pointer lst, s7_pointer x1, s7_pointer x2, + s7_pointer x3, s7_pointer x4) +{ + s7_pointer p; + p = lst; + set_car(p, x1); + p = cdr(p); + set_car(p, x2); + p = cdr(p); + set_car(p, x3); + p = cdr(p); + set_car(p, x4); + return (lst); +} + +static s7_pointer set_plist_1(s7_scheme * sc, s7_pointer x1) +{ + set_car(sc->plist_1, x1); + return (sc->plist_1); +} + +static s7_pointer set_plist_2(s7_scheme * sc, s7_pointer x1, s7_pointer x2) +{ + set_car(sc->plist_2, x1); + set_car(sc->plist_2_2, x2); + return (sc->plist_2); +} + +static s7_pointer set_plist_3(s7_scheme * sc, s7_pointer x1, s7_pointer x2, + s7_pointer x3) +{ + return (set_wlist_3(sc->plist_3, x1, x2, x3)); +} + +static s7_pointer set_qlist_2(s7_scheme * sc, s7_pointer x1, s7_pointer x2) +{ + set_car(sc->qlist_2, x1); + set_cadr(sc->qlist_2, x2); + return (sc->qlist_2); +} + +static s7_pointer set_qlist_3(s7_scheme * sc, s7_pointer x1, s7_pointer x2, + s7_pointer x3) +{ + set_car(sc->qlist_3, x1); + set_cadr(sc->qlist_3, x2); + set_caddr(sc->qlist_3, x3); + return (sc->qlist_3); +} + +static s7_pointer set_clist_1(s7_scheme * sc, s7_pointer x1) +{ /* for c_object length method etc, a "weak" list */ + set_car(sc->clist_1, x1); + return (sc->clist_1); +} + +static s7_pointer set_dlist_1(s7_scheme * sc, s7_pointer x1) +{ /* another like clist: temp usage, "weak" (not gc_marked), but permanent list */ + set_car(sc->dlist_1, x1); + return (sc->dlist_1); +} + +static s7_pointer set_ulist_1(s7_scheme * sc, s7_pointer x1, s7_pointer x2) +{ + set_car(sc->u1_1, x1); + set_cdr(sc->u1_1, x2); + return (sc->u1_1); +} + +static s7_pointer set_ulist_2(s7_scheme * sc, s7_pointer x1, s7_pointer x2, + s7_pointer x3) +{ + set_car(sc->u2_1, x1); + set_car(sc->u2_2, x2); + set_cdr(sc->u2_2, x3); + return (sc->u2_1); +} + +static int32_t position_of(s7_pointer p, s7_pointer args) +{ + int32_t i; + for (i = 1; p != args; i++, args = cdr(args)); + return (i); +} + +#define call_method(Sc, Obj, Method, Args) s7_apply_function(Sc, Method, Args) + +s7_pointer s7_method(s7_scheme * sc, s7_pointer obj, s7_pointer method) +{ + if (has_active_methods(sc, obj)) + return (find_method_with_let(sc, obj, method)); + return (sc->undefined); +} + +/* if a method is shadowing a built-in like abs, it should expect the same args as abs and behave the same -- no multiple values etc. */ +#define check_method(Sc, Obj, Method, Args) \ + { \ + s7_pointer func; \ + if ((has_active_methods(Sc, Obj)) && \ + ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \ + return(call_method(Sc, Obj, func, Args)); \ + } + +static s7_pointer apply_boolean_method(s7_scheme * sc, s7_pointer obj, + s7_pointer method) +{ + s7_pointer func; + func = find_method_with_let(sc, obj, method); + if (func == sc->undefined) + return (sc->F); + return (call_method(sc, obj, func, set_plist_1(sc, obj))); +} + +static s7_pointer missing_method_error(s7_scheme * sc, s7_pointer method, + s7_pointer obj) +{ + return (s7_error + (sc, sc->missing_method_symbol, + set_elist_3(sc, missing_method_string, method, obj))); +} + +#define check_boolean_method(Sc, Checker, Method, Args) \ + { \ + s7_pointer p = car(Args); \ + if (Checker(p)) return(Sc->T); \ + if (!has_active_methods(Sc, p)) return(Sc->F); \ + return(apply_boolean_method(Sc, p, Method)); \ + } + +static s7_pointer find_and_apply_method(s7_scheme * sc, s7_pointer obj, + s7_pointer sym, s7_pointer args) +{ + s7_pointer func; + func = find_method_with_let(sc, obj, sym); + if (func != sc->undefined) + return (call_method(sc, obj, func, args)); + return (missing_method_error(sc, sym, obj)); +} + +static s7_pointer method_or_bust(s7_scheme * sc, s7_pointer obj, + s7_pointer method, s7_pointer args, + uint8_t typ, int32_t num) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method(sc, obj, method, args)); + return (wrong_type_argument(sc, method, num, obj, typ)); +} + +static s7_pointer method_or_bust_p(s7_scheme * sc, s7_pointer obj, + s7_pointer method, uint8_t typ) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method + (sc, obj, method, set_plist_1(sc, obj))); + return (wrong_type_argument(sc, method, 1, obj, typ)); +} + +static s7_pointer method_or_bust_pp(s7_scheme * sc, s7_pointer obj, + s7_pointer method, s7_pointer x1, + s7_pointer x2, uint8_t typ, + int32_t num) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method + (sc, obj, method, set_plist_2(sc, x1, x2))); + return (wrong_type_argument(sc, method, num, obj, typ)); +} + +static s7_pointer method_or_bust_ppp(s7_scheme * sc, s7_pointer obj, + s7_pointer method, s7_pointer x1, + s7_pointer x2, s7_pointer x3, + uint8_t typ, int32_t num) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method + (sc, obj, method, set_plist_3(sc, x1, x2, x3))); + return (wrong_type_argument(sc, method, num, obj, typ)); +} + +static s7_pointer immutable_object_error(s7_scheme * sc, s7_pointer info) +{ + return (s7_error(sc, sc->immutable_error_symbol, info)); +} + +static s7_pointer mutable_method_or_bust(s7_scheme * sc, s7_pointer obj, + s7_pointer method, + s7_pointer args, uint8_t typ, + int32_t num) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method(sc, obj, method, args)); + if (type(obj) != typ) + return (wrong_type_argument(sc, method, num, obj, typ)); + if (is_immutable(obj)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, method, obj))); + return (wrong_type_argument(sc, method, num, obj, typ)); +} + +static s7_pointer mutable_method_or_bust_ppp(s7_scheme * sc, + s7_pointer obj, + s7_pointer method, + s7_pointer x1, s7_pointer x2, + s7_pointer x3, uint8_t typ, + int32_t num) +{ + return (mutable_method_or_bust + (sc, obj, method, set_plist_3(sc, x1, x2, x3), typ, num)); +} + +static s7_pointer method_or_bust_one_arg(s7_scheme * sc, s7_pointer obj, + s7_pointer method, + s7_pointer args, uint8_t typ) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method(sc, obj, method, args)); + return (simple_wrong_type_argument(sc, method, obj, typ)); +} + +static s7_pointer method_or_bust_one_arg_p(s7_scheme * sc, s7_pointer obj, + s7_pointer method, uint8_t typ) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method + (sc, obj, method, set_plist_1(sc, obj))); + return (simple_wrong_type_argument(sc, method, obj, typ)); +} + +static s7_pointer method_or_bust_with_type(s7_scheme * sc, s7_pointer obj, + s7_pointer method, + s7_pointer args, s7_pointer typ, + int32_t num) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method(sc, obj, method, args)); + return (wrong_type_argument_with_type(sc, method, num, obj, typ)); +} + +static s7_pointer method_or_bust_with_type_pp(s7_scheme * sc, + s7_pointer obj, + s7_pointer method, + s7_pointer x1, s7_pointer x2, + s7_pointer typ, int32_t num) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method + (sc, obj, method, set_plist_2(sc, x1, x2))); + return (wrong_type_argument_with_type(sc, method, num, obj, typ)); +} + +static s7_pointer method_or_bust_with_type_pi(s7_scheme * sc, + s7_pointer obj, + s7_pointer method, + s7_pointer x1, s7_int x2, + s7_pointer typ) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method + (sc, obj, method, + set_plist_2(sc, x1, make_integer(sc, x2)))); + return (wrong_type_argument_with_type(sc, method, 1, obj, typ)); +} + +static s7_pointer method_or_bust_with_type_pf(s7_scheme * sc, + s7_pointer obj, + s7_pointer method, + s7_pointer x1, s7_double x2, + s7_pointer typ) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method + (sc, obj, method, set_plist_2(sc, x1, make_real(sc, x2)))); + return (wrong_type_argument_with_type(sc, method, 1, obj, typ)); +} + +static s7_pointer method_or_bust_with_type_one_arg(s7_scheme * sc, + s7_pointer obj, + s7_pointer method, + s7_pointer args, + s7_pointer typ) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method(sc, obj, method, args)); + return (simple_wrong_type_argument_with_type(sc, method, obj, typ)); +} + +static s7_pointer method_or_bust_with_type_one_arg_p(s7_scheme * sc, + s7_pointer obj, + s7_pointer method, + s7_pointer typ) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method + (sc, obj, method, set_plist_1(sc, obj))); + return (simple_wrong_type_argument_with_type(sc, method, obj, typ)); +} + +#define eval_error_any(Sc, ErrType, ErrMsg, Len, Obj) \ + s7_error(Sc, ErrType, set_elist_2(Sc, wrap_string(Sc, ErrMsg, Len), Obj)) + +#define eval_error(Sc, ErrMsg, Len, Obj) \ + eval_error_any(Sc, Sc->syntax_error_symbol, ErrMsg, Len, Obj) + +#define eval_error_with_caller(Sc, ErrMsg, Len, Caller, Obj) \ + s7_error(Sc, Sc->syntax_error_symbol, set_elist_3(Sc, wrap_string(Sc, ErrMsg, Len), Caller, Obj)) + +#define eval_error_with_caller2(Sc, ErrMsg, Len, Caller, Name, Obj) \ + s7_error(Sc, Sc->syntax_error_symbol, set_elist_4(Sc, wrap_string(Sc, ErrMsg, Len), Caller, Name, Obj)) + + +/* -------------------------------- constants -------------------------------- */ + +/* #f and #t */ +s7_pointer s7_f(s7_scheme * sc) +{ + return (sc->F); +} + +s7_pointer s7_t(s7_scheme * sc) +{ + return (sc->T); +} + + +/* () */ +s7_pointer s7_nil(s7_scheme * sc) +{ + return (sc->nil); +} + +bool s7_is_null(s7_scheme * sc, s7_pointer p) +{ + return (is_null(p)); +} + +static bool is_null_b_p(s7_pointer p) +{ + return (type(p) == T_NIL); +} /* faster than b_7p because opt_b_p is faster */ + +static s7_pointer g_is_null(s7_scheme * sc, s7_pointer args) +{ +#define H_is_null "(null? obj) returns #t if obj is the empty list" +#define Q_is_null sc->pl_bt + check_boolean_method(sc, is_null, sc->is_null_symbol, args); +} + + +/* # and # */ +s7_pointer s7_undefined(s7_scheme * sc) +{ + return (sc->undefined); +} + +s7_pointer s7_unspecified(s7_scheme * sc) +{ + return (sc->unspecified); +} + +bool s7_is_unspecified(s7_scheme * sc, s7_pointer val) +{ + return (is_unspecified(val)); +} + +static s7_pointer g_is_undefined(s7_scheme * sc, s7_pointer args) +{ +#define H_is_undefined "(undefined? val) returns #t if val is # or its reader equivalent" +#define Q_is_undefined sc->pl_bt + check_boolean_method(sc, is_undefined, sc->is_undefined_symbol, args); +} + +static s7_pointer g_is_unspecified(s7_scheme * sc, s7_pointer args) +{ +#define H_is_unspecified "(unspecified? val) returns #t if val is #" +#define Q_is_unspecified sc->pl_bt + check_boolean_method(sc, is_unspecified, sc->is_unspecified_symbol, + args); +} + + +/* -------------------------------- eof-object? -------------------------------- */ +s7_pointer eof_object = NULL; /* # is an entry in the chars array, so it's not a part of sc */ + +s7_pointer s7_eof_object(s7_scheme * sc) +{ + return (eof_object); +} + +static s7_pointer g_is_eof_object(s7_scheme * sc, s7_pointer args) +{ +#define H_is_eof_object "(eof-object? val) returns #t if val is the end-of-file object" +#define Q_is_eof_object sc->pl_bt + check_boolean_method(sc, is_eof, sc->is_eof_object_symbol, args); +} + +static bool is_eof_object_b_p(s7_pointer p) +{ + return (p == eof_object); +} + + +/* -------------------------------- not -------------------------------- */ +static bool not_b_7p(s7_scheme * sc, s7_pointer p) +{ + return (p == sc->F); +} + +bool s7_boolean(s7_scheme * sc, s7_pointer x) +{ + return (x != sc->F); +} + +s7_pointer s7_make_boolean(s7_scheme * sc, bool x) +{ + return (make_boolean(sc, x)); +} + +static s7_pointer g_not(s7_scheme * sc, s7_pointer args) +{ +#define H_not "(not obj) returns #t if obj is #f, otherwise #t: (not ()) -> #f" +#define Q_not sc->pl_bt + return ((car(args) == sc->F) ? sc->T : sc->F); +} + + +/* -------------------------------- boolean? -------------------------------- */ +bool s7_is_boolean(s7_pointer x) +{ + return (type(x) == T_BOOLEAN); +} + +static s7_pointer g_is_boolean(s7_scheme * sc, s7_pointer args) +{ +#define H_is_boolean "(boolean? obj) returns #t if obj is #f or #t: (boolean? ()) -> #f" +#define Q_is_boolean sc->pl_bt + check_boolean_method(sc, s7_is_boolean, sc->is_boolean_symbol, args); +} + + +/* -------------------------------- constant? -------------------------------- */ +static inline bool is_constant_symbol(s7_scheme * sc, s7_pointer sym) +{ + if (is_immutable_symbol(sym)) /* for keywords */ + return (true); + if (is_possibly_constant(sym)) { + s7_pointer slot; + slot = lookup_slot_from(sym, sc->curlet); + return ((is_slot(slot)) && (is_immutable_slot(slot))); + } + return (false); +} + +#define is_constant(sc, p) ((type(p) != T_SYMBOL) || (is_constant_symbol(sc, p))) + +static s7_pointer g_is_constant(s7_scheme * sc, s7_pointer args) +{ +#define H_is_constant "(constant? obj) returns #t if obj either evaluates to itself, or is a symbol whose binding is constant" +#define Q_is_constant sc->pl_bt + return (make_boolean(sc, is_constant(sc, car(args)))); +} + +static bool is_constant_b_7p(s7_scheme * sc, s7_pointer p) +{ + return (is_constant(sc, p)); +} + +static s7_pointer is_constant_p_p(s7_scheme * sc, s7_pointer p) +{ + return (make_boolean(sc, is_constant(sc, p))); +} + + +/* -------------------------------- immutable? -------------------------------- */ +bool s7_is_immutable(s7_pointer p) +{ + return (is_immutable(p)); +} + +static s7_pointer g_is_immutable(s7_scheme * sc, s7_pointer args) +{ +#define H_is_immutable "(immutable? sequence) returns #t if the sequence is immutable" +#define Q_is_immutable sc->pl_bt + s7_pointer p = car(args); +#if 0 /* strikes me as confusing, constant above refers to local define-constant, the symbol itself is always immutable */ + if (is_symbol(p)) { + s7_pointer slot; + slot = lookup_slot_from(p, sc->curlet); + if ((is_slot(slot)) && (is_immutable_slot(slot))) + return (sc->T); + } +#endif + if (is_number(p)) + return (sc->T); /* should these be marked immutable? should we use (type != SYMBOL) as above? */ + return (make_boolean(sc, is_immutable(p))); +} + + +/* -------------------------------- immutable! -------------------------------- */ +s7_pointer s7_immutable(s7_pointer p) +{ + set_immutable(p); + return (p); +} + +static s7_pointer g_immutable(s7_scheme * sc, s7_pointer args) +{ +#define H_immutable "(immutable! sequence) declares that the sequence's entries can't be changed. The sequence is returned." +#define Q_immutable s7_make_signature(sc, 2, sc->T, sc->T) + s7_pointer p = car(args); + if (is_symbol(p)) { + s7_pointer slot; + slot = lookup_slot_from(p, sc->curlet); + if (is_slot(slot)) { + set_immutable(slot); + return (p); /* symbol is not set immutable ? */ + } + } + set_immutable(p); + return (p); +} + +/* there's no way to make a slot setter (as setter) immutable (t_multiform as bit) */ + + +/* -------------------------------- GC -------------------------------- */ + +/* in most code, pairs, lets, and slots dominate the heap -- each about 25% to 40% of the + * total cell allocations. In snd-test, reals are 50%. slots need not be in the heap, + * but moving them out to their own free list was actually slower because we need (in that + * case) to manage them in the sweep process by tracking lets. + */ + +#if S7_DEBUGGING +static s7_int gc_protect_2(s7_scheme * sc, s7_pointer x, int32_t line) +{ + s7_int loc; + loc = s7_gc_protect(sc, x); + if (loc > 8192) { + fprintf(stderr, "infinite loop or memory leak at line %d %s?\n", + line, + string_value(s7_object_to_string + (sc, current_code(sc), false))); + abort(); + } + return (loc); +} + +#define gc_protect_1(Sc, X) gc_protect_2(Sc, X, __LINE__) +#else +#define gc_protect_1(Sc, X) s7_gc_protect(Sc, X) +#endif + +static void resize_gc_protect(s7_scheme * sc) +{ + s7_int i, size = sc->protected_objects_size, new_size; + block_t *ob, *nb; + new_size = 2 * size; + ob = vector_block(sc->protected_objects); + nb = reallocate(sc, ob, new_size * sizeof(s7_pointer)); + block_info(nb) = NULL; + vector_block(sc->protected_objects) = nb; + vector_elements(sc->protected_objects) = (s7_pointer *) block_data(nb); + vector_length(sc->protected_objects) = new_size; + sc->protected_objects_size = new_size; + sc->gpofl = (s7_int *) Realloc(sc->gpofl, new_size * sizeof(s7_int)); + for (i = size; i < new_size; i++) { + vector_element(sc->protected_objects, i) = sc->unused; + sc->gpofl[++sc->gpofl_loc] = i; + } +} + +s7_int s7_gc_protect(s7_scheme * sc, s7_pointer x) +{ + s7_int loc; + if (sc->gpofl_loc < 0) + resize_gc_protect(sc); + loc = sc->gpofl[sc->gpofl_loc--]; + vector_element(sc->protected_objects, loc) = x; + return (loc); +} + +void s7_gc_unprotect_at(s7_scheme * sc, s7_int loc) +{ + if (loc < sc->protected_objects_size) { + if (vector_element(sc->protected_objects, loc) != sc->unused) + sc->gpofl[++sc->gpofl_loc] = loc; +#if S7_DEBUGGING + else + fprintf(stderr, + "redundant gc_unprotect_at location %" ld64 "\n", loc); +#endif + vector_element(sc->protected_objects, loc) = sc->unused; + } +} + +s7_pointer s7_gc_protected_at(s7_scheme * sc, s7_int loc) +{ + s7_pointer obj = sc->unspecified; + if (loc < sc->protected_objects_size) + obj = vector_element(sc->protected_objects, loc); + if (obj == sc->unused) + return (sc->unspecified); + return (obj); +} + +#define gc_protected_at(Sc, Loc) vector_element(Sc->protected_objects, Loc) + +s7_pointer s7_gc_protect_via_location(s7_scheme * sc, s7_pointer x, + s7_int loc) +{ + vector_element(sc->protected_objects, loc) = x; + return (x); +} + +s7_pointer s7_gc_unprotect_via_location(s7_scheme * sc, s7_int loc) +{ + vector_element(sc->protected_objects, loc) = sc->F; + return (sc->F); +} + + +static void (*mark_function[NUM_TYPES])(s7_pointer p); + +void s7_mark(s7_pointer p) +{ + if (!is_marked(p)) + (*mark_function[unchecked_type(p)]) (p); +} + +static inline void gc_mark(s7_pointer p) +{ + if (!is_marked(p)) + (*mark_function[unchecked_type(p)]) (p); +} + +static inline void mark_slot(s7_pointer p) +{ + set_mark(T_Slt(p)); + gc_mark(slot_value(p)); + if (slot_has_setter(p)) + gc_mark(slot_setter(p)); + if (slot_has_pending_value(p)) + gc_mark(slot_pending_value(p)); + set_mark(slot_symbol(p)); +} + +static void mark_noop(s7_pointer p) +{ +} + +static void close_output_port(s7_scheme * sc, s7_pointer p); +static void remove_gensym_from_symbol_table(s7_scheme * sc, + s7_pointer sym); +static void cull_weak_hash_table(s7_scheme * sc, s7_pointer table); + +static void process_iterator(s7_scheme * sc, s7_pointer s1) +{ + if (is_weak_hash_iterator(s1)) { + s7_pointer h; + clear_weak_hash_iterator(s1); + h = iterator_sequence(s1); + if (unchecked_type(h) == T_HASH_TABLE) { + if ((S7_DEBUGGING) && (weak_hash_iters(h) == 0)) + fprintf(stderr, "in gc weak has iters wrapping under!\n"); + weak_hash_iters(h)--; + } + } +} + +static void process_multivector(s7_scheme * sc, s7_pointer s1) +{ + vdims_t *info; + info = vector_dimension_info(s1); /* a multidimensional empty vector can have dimension info, wrapped vectors always have dimension info */ + if ((info) && (info != sc->wrap_only)) { + if (vector_elements_should_be_freed(info)) { /* a kludge for foreign code convenience */ + free(vector_elements(s1)); + vector_elements_should_be_freed(info) = false; + } + liberate(sc, info); + vector_set_dimension_info(s1, NULL); + } + liberate(sc, vector_block(s1)); +} + +static void process_input_string_port(s7_scheme * sc, s7_pointer s1) +{ +#if S7_DEBUGGING + /* this set of ports is a subset of the ports that respond true to is_string_port -- + * the latter include file ports fully read into local memory; see read_file which uses add_input_port, not add_input_string_port + */ + if (port_filename(s1)) + fprintf(stderr, "string input port has a filename: %s\n", + port_filename(s1)); + if (port_needs_free(s1)) + fprintf(stderr, "string input port needs data release\n"); +#endif + liberate(sc, port_block(s1)); +} + +static void free_port_data(s7_scheme * sc, s7_pointer s1) +{ + if (port_data(s1)) { + liberate(sc, port_data_block(s1)); + port_data_block(s1) = NULL; + port_data(s1) = NULL; + port_data_size(s1) = 0; + } + port_needs_free(s1) = false; +} + +static void close_input_function(s7_scheme * sc, s7_pointer p); + +static void process_input_port(s7_scheme * sc, s7_pointer s1) +{ + if (!port_is_closed(s1)) { + if (is_file_port(s1)) { + if (port_file(s1)) { + fclose(port_file(s1)); + port_file(s1) = NULL; + } + } else if (is_function_port(s1)) + close_input_function(sc, s1); + } + if (port_needs_free(s1)) + free_port_data(sc, s1); + + if (port_filename(s1)) { + liberate(sc, port_filename_block(s1)); + port_filename(s1) = NULL; + } + liberate(sc, port_block(s1)); +} + +static void process_output_port(s7_scheme * sc, s7_pointer s1) +{ + close_output_port(sc, s1); /* needed for free filename, etc */ + liberate(sc, port_block(s1)); + if (port_needs_free(s1)) { + if (port_data_block(s1)) { + liberate(sc, port_data_block(s1)); + port_data_block(s1) = NULL; + } + port_needs_free(s1) = false; + } +} + +static void process_continuation(s7_scheme * sc, s7_pointer s1) +{ + continuation_op_stack(s1) = NULL; + liberate_block(sc, continuation_block(s1)); +} + + +#if WITH_GMP +#if ((__GNU_MP_VERSION < 6) || ((__GNU_MP_VERSION == 6) && (__GNU_MP_VERSION_MINOR == 0))) +static int mpq_cmp_z(const mpq_t op1, const mpz_t op2) +{ + mpq_t z1; + int result; + mpq_init(z1); + mpq_set_z(z1, op2); + result = mpq_cmp(op1, z1); + mpq_clear(z1); + return (result); +} +#endif + +static s7_int big_integer_to_s7_int(s7_scheme * sc, mpz_t n); +static s7_int s7_integer_checked(s7_scheme * sc, s7_pointer p) +{ /* "checked" = gmp range check */ + if (is_t_integer(p)) + return (integer(p)); + if (is_t_big_integer(p)) + return (big_integer_to_s7_int(sc, big_integer(p))); + return (0); +} + +static void free_big_integer(s7_scheme * sc, s7_pointer p) +{ + big_integer_nxt(p) = sc->bigints; + sc->bigints = big_integer_bgi(p); + big_integer_bgi(p) = NULL; +} + +static void free_big_ratio(s7_scheme * sc, s7_pointer p) +{ + big_ratio_nxt(p) = sc->bigrats; + sc->bigrats = big_ratio_bgr(p); + big_ratio_bgr(p) = NULL; +} + +static void free_big_real(s7_scheme * sc, s7_pointer p) +{ + big_real_nxt(p) = sc->bigflts; + sc->bigflts = big_real_bgf(p); + big_real_bgf(p) = NULL; +} + +static void free_big_complex(s7_scheme * sc, s7_pointer p) +{ + big_complex_nxt(p) = sc->bigcmps; + sc->bigcmps = big_complex_bgc(p); + big_complex_bgc(p) = NULL; +} +#else +#define s7_integer_checked(Sc, P) integer(P) +#endif + + +static void free_hash_table(s7_scheme * sc, s7_pointer table); + +static void sweep(s7_scheme * sc) +{ + s7_int i, j; + s7_pointer s1; + gc_list_t *gp; + +#define process_gc_list(Code) \ + if (gp->loc > 0) \ + { \ + for (i = 0, j = 0; i < gp->loc; i++) \ + { \ + s1 = gp->list[i]; \ + if (is_free_and_clear(s1)) \ + { \ + Code; \ + } \ + else gp->list[j++] = s1; \ + } \ + gp->loc = j; \ + } \ + + gp = sc->strings; + process_gc_list(liberate(sc, string_block(s1))) + gp = sc->gensyms; + process_gc_list(remove_gensym_from_symbol_table(sc, s1); + liberate(sc, gensym_block(s1))) + if (gp->loc == 0) + mark_function[T_SYMBOL] = mark_noop; + + gp = sc->undefineds; + process_gc_list(free(undefined_name(s1))) + gp = sc->c_objects; + process_gc_list((c_object_gc_free(sc, s1)) + ? (void) (*(c_object_gc_free(sc, s1))) (sc, s1) + : (void) (*(c_object_free(sc, s1))) (c_object_value + (s1))) + gp = sc->lambdas; + process_gc_list(liberate(sc, c_function_block(s1))) + gp = sc->vectors; + process_gc_list(liberate(sc, vector_block(s1))) + gp = sc->multivectors; + process_gc_list(process_multivector(sc, s1)); + + gp = sc->hash_tables; + if (gp->loc > 0) { + for (i = 0, j = 0; i < gp->loc; i++) { + s1 = gp->list[i]; + if (is_free_and_clear(s1)) + free_hash_table(sc, s1); + else { + if ((is_weak_hash_table(s1)) && (weak_hash_iters(s1) == 0)) + cull_weak_hash_table(sc, s1); + gp->list[j++] = s1; + } + } + gp->loc = j; + } + + gp = sc->weak_hash_iterators; + process_gc_list(process_iterator(sc, s1)); + + gp = sc->opt1_funcs; + if (gp->loc > 0) { + for (i = 0, j = 0; i < gp->loc; i++) { + s1 = gp->list[i]; + if (!is_free_and_clear(s1)) + gp->list[j++] = s1; + } + gp->loc = j; + } + + gp = sc->input_ports; + process_gc_list(process_input_port(sc, s1)); + + gp = sc->input_string_ports; + process_gc_list(process_input_string_port(sc, s1)); + + gp = sc->output_ports; + process_gc_list(process_output_port(sc, s1)); + + gp = sc->continuations; + process_gc_list(process_continuation(sc, s1)); + + gp = sc->weak_refs; + if (gp->loc > 0) { + for (i = 0, j = 0; i < gp->loc; i++) { + s1 = gp->list[i]; + if (!is_free_and_clear(s1)) { + if (is_free_and_clear(c_pointer_weak1(s1))) + c_pointer_weak1(s1) = sc->F; + if (is_free_and_clear(c_pointer_weak2(s1))) + c_pointer_weak2(s1) = sc->F; + if ((c_pointer_weak1(s1) != sc->F) || + (c_pointer_weak2(s1) != sc->F)) + gp->list[j++] = s1; + } + } + gp->loc = j; + } + +#if WITH_GMP + gp = sc->big_integers; + process_gc_list(free_big_integer(sc, s1)) + gp = sc->big_ratios; + process_gc_list(free_big_ratio(sc, s1)) + gp = sc->big_reals; + process_gc_list(free_big_real(sc, s1)) + gp = sc->big_complexes; + process_gc_list(free_big_complex(sc, s1)) + gp = sc->big_random_states; + process_gc_list(gmp_randclear(random_gmp_state(s1))) +#endif +} + +static inline void add_to_gc_list(gc_list_t * gp, s7_pointer p) +{ + if (gp->loc == gp->size) { + gp->size *= 2; + gp->list = + (s7_pointer *) realloc(gp->list, + gp->size * sizeof(s7_pointer)); + } + gp->list[gp->loc++] = p; +} + +static gc_list_t *make_gc_list(void) +{ + gc_list_t *gp; +#define INIT_GC_CACHE_SIZE 4 + gp = (gc_list_t *) malloc(sizeof(gc_list_t)); + gp->size = INIT_GC_CACHE_SIZE; + gp->loc = 0; + gp->list = (s7_pointer *) malloc(gp->size * sizeof(s7_pointer)); + return (gp); +} + +static void just_mark(s7_pointer p) +{ + set_mark(p); +} + +static void add_gensym(s7_scheme * sc, s7_pointer p) +{ + add_to_gc_list(sc->gensyms, p); + mark_function[T_SYMBOL] = just_mark; +} + +#define add_c_object(sc, p) add_to_gc_list(sc->c_objects, p) +#define add_hash_table(sc, p) add_to_gc_list(sc->hash_tables, p) +#define add_string(sc, p) add_to_gc_list(sc->strings, p) +#define add_input_port(sc, p) add_to_gc_list(sc->input_ports, p) +#define add_input_string_port(sc, p) add_to_gc_list(sc->input_string_ports, p) +#define add_output_port(sc, p) add_to_gc_list(sc->output_ports, p) +#define add_continuation(sc, p) add_to_gc_list(sc->continuations, p) +#define add_undefined(sc, p) add_to_gc_list(sc->undefineds, p) +#define add_vector(sc, p) add_to_gc_list(sc->vectors, p) +#define add_multivector(sc, p) add_to_gc_list(sc->multivectors, p) +#define add_lambda(sc, p) add_to_gc_list(sc->lambdas, p) +#define add_weak_ref(sc, p) add_to_gc_list(sc->weak_refs, p) +#define add_weak_hash_iterator(sc, p) add_to_gc_list(sc->weak_hash_iterators, p) +#define add_opt1_func(sc, p) do {if (!opt1_func_listed(p)) add_to_gc_list(sc->opt1_funcs, p); set_opt1_func_listed(p);} while (0) + +#if WITH_GMP +#define add_big_integer(sc, p) add_to_gc_list(sc->big_integers, p) +#define add_big_ratio(sc, p) add_to_gc_list(sc->big_ratios, p) +#define add_big_real(sc, p) add_to_gc_list(sc->big_reals, p) +#define add_big_complex(sc, p) add_to_gc_list(sc->big_complexes, p) +#define add_big_random_state(sc, p) add_to_gc_list(sc->big_random_states, p) +#endif + +static void init_gc_caches(s7_scheme * sc) +{ + sc->strings = make_gc_list(); + sc->gensyms = make_gc_list(); + sc->undefineds = make_gc_list(); + sc->vectors = make_gc_list(); + sc->multivectors = make_gc_list(); + sc->hash_tables = make_gc_list(); + sc->input_ports = make_gc_list(); + sc->input_string_ports = make_gc_list(); + sc->output_ports = make_gc_list(); + sc->continuations = make_gc_list(); + sc->c_objects = make_gc_list(); + sc->lambdas = make_gc_list(); + sc->weak_refs = make_gc_list(); + sc->weak_hash_iterators = make_gc_list(); + sc->opt1_funcs = make_gc_list(); +#if WITH_GMP + sc->big_integers = make_gc_list(); + sc->big_ratios = make_gc_list(); + sc->big_reals = make_gc_list(); + sc->big_complexes = make_gc_list(); + sc->big_random_states = make_gc_list(); + sc->ratloc = NULL; +#endif + /* slightly unrelated... */ + sc->setters_size = 4; + sc->setters_loc = 0; + sc->setters = + (s7_pointer *) malloc(sc->setters_size * sizeof(s7_pointer)); +} + +static s7_pointer permanent_cons(s7_scheme * sc, s7_pointer a, + s7_pointer b, uint64_t type); + +static void add_setter(s7_scheme * sc, s7_pointer p, s7_pointer setter) +{ + /* setters GC-protected. The c_function_setter field can't be used because the built-in functions + * are often removed from the heap and never thereafter marked. Only closures and macros are protected here. + */ + s7_int i; + for (i = 0; i < sc->setters_loc; i++) { + s7_pointer x; + x = sc->setters[i]; + if (car(x) == p) { + set_cdr(x, setter); + return; + } + } + if (sc->setters_loc == sc->setters_size) { + sc->setters_size *= 2; + sc->setters = + (s7_pointer *) Realloc(sc->setters, + sc->setters_size * sizeof(s7_pointer)); + } + sc->setters[sc->setters_loc++] = + permanent_cons(sc, p, setter, T_PAIR | T_IMMUTABLE); +} + +static void mark_symbol_vector(s7_pointer p, s7_int len) +{ + set_mark(p); + if (mark_function[T_SYMBOL] != mark_noop) { /* else no gensyms */ + s7_int i; + s7_pointer *e = vector_elements(p); + for (i = 0; i < len; i++) + if (is_gensym(e[i])) + set_mark(e[i]); + } +} + +static void mark_simple_vector(s7_pointer p, s7_int len) +{ + s7_int i; + s7_pointer *e = vector_elements(p); + set_mark(p); + for (i = 0; i < len; i++) + set_mark(e[i]); +} + +static void just_mark_vector(s7_pointer p, s7_int len) +{ + set_mark(p); +} + +static void mark_vector_1(s7_pointer p, s7_int top) +{ + s7_pointer *tp = (s7_pointer *) (vector_elements(p)), *tend, *tend4; + set_mark(p); + if (!tp) + return; + tend = (s7_pointer *) (tp + top); + tend4 = (s7_pointer *) (tend - 8); + while (tp <= tend4) + LOOP_8(gc_mark(*tp++)); + while (tp < tend) + gc_mark(*tp++); +} + +static void mark_typed_vector_1(s7_pointer p, s7_int top) +{ /* for typed vectors with closure setters */ + gc_mark(typed_vector_typer(p)); + mark_vector_1(p, top); +} + +static void mark_let(s7_pointer let) +{ + s7_pointer x; + for (x = let; is_let(x) && (!is_marked(x)); x = let_outlet(x)) { /* let can be sc->nil, e.g. closure_let */ + s7_pointer y; + set_mark(x); + if (has_dox_slot1(x)) + mark_slot(let_dox_slot1(x)); + if ((has_dox_slot2(x)) && (is_slot(let_dox_slot2(x)))) + mark_slot(let_dox_slot2(x)); + for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + if (!is_marked(y)) /* slot value might be the enclosing let */ + mark_slot(y); + } +} + +#if WITH_HISTORY +static void gc_owlet_mark(s7_pointer tp) +{ + /* gc_mark but if tp is a pair ignore the marked bit on unheaped entries */ + if (is_pair(tp)) { + s7_pointer p = tp; + do { + set_mark(p); + gc_mark(car(p)); /* does this need to be gc_owlet_mark? I can't find a case */ + p = cdr(p); + } while ((is_pair(p)) && (p != tp) && ((!in_heap(p)) || (!is_marked(p)))); /* ((full_type(p) & (TYPE_MASK | T_GC_MARK)) == T_PAIR) is much slower */ + gc_mark(p); + } else if (!is_marked(tp)) + (*mark_function[unchecked_type(tp)]) (tp); +} +#endif + +static void mark_owlet(s7_scheme * sc) +{ +#if WITH_HISTORY + { + s7_pointer p1, p2, p3; + int32_t i; + for (i = 1, p1 = sc->eval_history1, p2 = sc->eval_history2, p3 = + sc->history_pairs;; i++, p2 = cdr(p2), p3 = cdr(p3)) { + set_mark(p1); /* pointless? they're permanent */ + set_mark(p2); + set_mark(p3); + gc_owlet_mark(car(p1)); + gc_owlet_mark(car(p2)); + gc_owlet_mark(car(p3)); + p1 = cdr(p1); + if (p1 == sc->eval_history1) + break; /* these are circular lists */ + } + } +#endif + /* sc->error_type and friends are slots in owlet */ + mark_slot(sc->error_type); + slot_set_value(sc->error_data, sc->F); /* or maybe mark_tree(slot_value(sc->error_data)) ? */ + mark_slot(sc->error_data); + mark_slot(sc->error_code); + mark_slot(sc->error_line); + mark_slot(sc->error_file); + mark_slot(sc->error_position); +#if WITH_HISTORY + mark_slot(sc->error_history); +#endif + set_mark(sc->owlet); + mark_let(let_outlet(sc->owlet)); +} + +static void mark_c_pointer(s7_pointer p) +{ + set_mark(p); + gc_mark(c_pointer_type(p)); + gc_mark(c_pointer_info(p)); +} + +static void mark_c_proc_star(s7_pointer p) +{ + set_mark(p); + if ((!c_func_has_simple_defaults(p)) && (c_function_call_args(p))) { /* NULL if not a safe function */ + s7_pointer arg; + for (arg = c_function_call_args(p); is_pair(arg); arg = cdr(arg)) + gc_mark(car(arg)); + } +} + +static void mark_pair(s7_pointer p) +{ + do { + set_mark(p); + gc_mark(car(p)); /* expanding this to avoid recursion is slower */ + p = cdr(p); + } while ((is_pair(p)) && (!is_marked(p))); /* ((full_type(p) & (TYPE_MASK | T_GC_MARK)) == T_PAIR) is much slower */ + gc_mark(p); +} + +static void mark_counter(s7_pointer p) +{ + set_mark(p); + gc_mark(counter_result(p)); + gc_mark(counter_list(p)); + gc_mark(counter_let(p)); +} + +static void mark_closure(s7_pointer p) +{ + set_mark(p); + gc_mark(closure_args(p)); + gc_mark(closure_body(p)); + mark_let(closure_let(p)); + gc_mark(closure_setter_or_map_list(p)); +} + +static void mark_stack_1(s7_pointer p, s7_int top) +{ + s7_pointer *tp = (s7_pointer *) (stack_elements(p)), *tend; + set_mark(p); + if (!tp) + return; + tend = (s7_pointer *) (tp + top); + while (tp < tend) { + gc_mark(*tp++); + gc_mark(*tp++); + gc_mark(*tp++); + tp++; + } +} + +static void mark_stack(s7_pointer p) +{ + /* we can have a bare stack waiting for a continuation to hold it if the new_cell for the continuation triggers the GC! But we need a top-of-stack?? */ + mark_stack_1(p, temp_stack_top(p)); +} + +static void mark_continuation(s7_pointer p) +{ + set_mark(p); + if (!is_marked(continuation_stack(p))) /* can these be cyclic? */ + mark_stack_1(continuation_stack(p), continuation_stack_top(p)); + gc_mark(continuation_op_stack(p)); +} + +static void mark_vector(s7_pointer p) +{ + if (is_typed_vector(p)) + typed_vector_gc_mark(p) (p, vector_length(p)); + else + mark_vector_1(p, vector_length(p)); +} + +static void mark_vector_possibly_shared(s7_pointer p) +{ + /* If a subvector (an inner dimension) of a vector is the only remaining reference + * to the main vector, we want to make sure the main vector is not GC'd until + * the subvector is also GC-able. The subvector field either points to the + * parent vector, or it is sc->F, so we need to check for a vector parent if + * the current is multidimensional (this will include 1-dim slices). We need + * to keep the parent case separate (i.e. sc->F means the current is the original) + * so that we only free once (or remove_from_heap once). + * + * If we have a subvector of a subvector, and the middle and original are not otherwise + * in use, we mark the middle one, but (since it itself is not in use anywhere else) + * we don't mark the original! So we need to follow the share-vector chain marking every one. + * + * To remove a cell from the heap, we need its current heap location so that we can replace it. + * The heap is allocated as needed in monolithic blocks of (say) 1/2M s7_cells. When a cell + * is replaced, the new cell (at heap[x] say) is no longer from the original block. Since the + * GC clears all type bits when it frees a cell, we can't use a type bit to distinguish the + * replacements from the originals, but we need that info because in the base case, we use + * the distance of the cell from the base cell to get "x", its location. In the replacement + * case, we add the location at the end of the s7_cell (s7_big_cell). We track the current + * heap blocks via the sc->heap_blocks list. To get the location of "p" above, we run through + * that list looking for a block it fits in. If none is found, we assume it is an s7_big_cell + * and use the saved location. + */ + if (is_subvector(p)) + mark_vector_possibly_shared(subvector_vector(p)); + + /* mark_vector_1 does not check the marked bit, so if subvector below is in a cycle involving + * the calling vector, we get infinite recursion unless we check the mark bit here. + */ + if (!is_marked(p)) + mark_vector_1(p, vector_length(p)); +} + +static void mark_int_or_float_vector(s7_pointer p) +{ + set_mark(p); +} + +static void mark_int_or_float_vector_possibly_shared(s7_pointer p) +{ + if (is_subvector(p)) + mark_int_or_float_vector_possibly_shared(subvector_vector(p)); + set_mark(p); +} + +static void mark_c_object(s7_pointer p) +{ + set_mark(p); + if (c_object_gc_mark(c_object_s7(p), p)) + (*(c_object_gc_mark(c_object_s7(p), p))) (c_object_s7(p), p); + else + (*(c_object_mark(c_object_s7(p), p))) (c_object_value(p)); +} + +static void mark_catch(s7_pointer p) +{ + set_mark(p); + gc_mark(catch_tag(p)); + gc_mark(catch_handler(p)); +} + +static void mark_dynamic_wind(s7_pointer p) +{ + set_mark(p); + gc_mark(dynamic_wind_in(p)); + gc_mark(dynamic_wind_out(p)); + gc_mark(dynamic_wind_body(p)); +} + +/* if is_typed_hash_table then if c_function_marker(key|value_typer) is just_mark_vector, we can ignore that field, + * if it's mark_simple_vector, we just set_mark (key|value), else we gc_mark (none of this is implemented yet) + */ +static void mark_hash_table(s7_pointer p) +{ + set_mark(p); + gc_mark(hash_table_procedures(p)); + if (hash_table_entries(p) > 0) { + s7_int len = hash_table_mask(p) + 1; + hash_entry_t **entries = hash_table_elements(p), **last; + last = (hash_entry_t **) (entries + len); + + if ((is_weak_hash_table(p)) && (weak_hash_iters(p) == 0)) + while (entries < last) { + hash_entry_t *xp; + for (xp = *entries++; xp; xp = hash_entry_next(xp)) + gc_mark(hash_entry_value(xp)); + for (xp = *entries++; xp; xp = hash_entry_next(xp)) + gc_mark(hash_entry_value(xp)); + } else + while (entries < last) { /* counting entries here was slightly faster */ + hash_entry_t *xp; + for (xp = *entries++; xp; xp = hash_entry_next(xp)) { + gc_mark(hash_entry_key(xp)); + gc_mark(hash_entry_value(xp)); + } + for (xp = *entries++; xp; xp = hash_entry_next(xp)) { + gc_mark(hash_entry_key(xp)); + gc_mark(hash_entry_value(xp)); + } + } + } +} + +static void mark_iterator(s7_pointer p) +{ + set_mark(p); + gc_mark(iterator_sequence(p)); + if (is_mark_seq(p)) + gc_mark(iterator_current(p)); +} + +static void mark_input_port(s7_pointer p) +{ + set_mark(p); + gc_mark(port_input_scheme_function(p)); /* this is also a string port's string */ +} + +static void mark_output_port(s7_pointer p) +{ + set_mark(p); + if (is_function_port(p)) + gc_mark(port_output_scheme_function(p)); +} + +#define clear_type(p) full_type(p) = T_FREE + +static void init_mark_functions(void) +{ + mark_function[T_FREE] = mark_noop; + mark_function[T_UNDEFINED] = just_mark; + mark_function[T_EOF] = mark_noop; + mark_function[T_UNSPECIFIED] = mark_noop; + mark_function[T_NIL] = mark_noop; + mark_function[T_UNUSED] = mark_noop; + mark_function[T_BOOLEAN] = mark_noop; + mark_function[T_SYNTAX] = mark_noop; + mark_function[T_CHARACTER] = mark_noop; + mark_function[T_SYMBOL] = mark_noop; /* this changes to just_mark when gensyms are in the heap */ + mark_function[T_STRING] = just_mark; + mark_function[T_INTEGER] = just_mark; + mark_function[T_RATIO] = just_mark; + mark_function[T_REAL] = just_mark; + mark_function[T_COMPLEX] = just_mark; + mark_function[T_BIG_INTEGER] = just_mark; + mark_function[T_BIG_RATIO] = just_mark; + mark_function[T_BIG_REAL] = just_mark; + mark_function[T_BIG_COMPLEX] = just_mark; + mark_function[T_RANDOM_STATE] = just_mark; + mark_function[T_GOTO] = just_mark; + mark_function[T_OUTPUT_PORT] = just_mark; /* changed to mark_output_port if output function ports are active */ + mark_function[T_C_MACRO] = just_mark; + mark_function[T_C_POINTER] = mark_c_pointer; + mark_function[T_C_FUNCTION] = just_mark; + mark_function[T_C_FUNCTION_STAR] = just_mark; /* changes to mark_c_proc_star if defaults involve an expression */ + mark_function[T_C_ANY_ARGS_FUNCTION] = just_mark; + mark_function[T_C_OPT_ARGS_FUNCTION] = just_mark; + mark_function[T_C_RST_ARGS_FUNCTION] = just_mark; + mark_function[T_PAIR] = mark_pair; + mark_function[T_CLOSURE] = mark_closure; + mark_function[T_CLOSURE_STAR] = mark_closure; + mark_function[T_CONTINUATION] = mark_continuation; + mark_function[T_INPUT_PORT] = mark_input_port; + mark_function[T_VECTOR] = mark_vector; /* this changes if subvector created (similarly below) */ + mark_function[T_INT_VECTOR] = mark_int_or_float_vector; + mark_function[T_FLOAT_VECTOR] = mark_int_or_float_vector; + mark_function[T_BYTE_VECTOR] = just_mark; + mark_function[T_MACRO] = mark_closure; + mark_function[T_BACRO] = mark_closure; + mark_function[T_MACRO_STAR] = mark_closure; + mark_function[T_BACRO_STAR] = mark_closure; + mark_function[T_C_OBJECT] = mark_c_object; + mark_function[T_CATCH] = mark_catch; + mark_function[T_DYNAMIC_WIND] = mark_dynamic_wind; + mark_function[T_HASH_TABLE] = mark_hash_table; + mark_function[T_ITERATOR] = mark_iterator; + mark_function[T_LET] = mark_let; + mark_function[T_STACK] = mark_stack; + mark_function[T_COUNTER] = mark_counter; + mark_function[T_SLOT] = mark_slot; +} + +static void mark_op_stack(s7_scheme * sc) +{ + s7_pointer *p = sc->op_stack, *tp = sc->op_stack_now; + while (p < tp) + gc_mark(*p++); +} + +static void mark_input_port_stack(s7_scheme * sc) +{ + s7_pointer *p, *tp; + tp = (s7_pointer *) (sc->input_port_stack + sc->input_port_stack_loc); + for (p = sc->input_port_stack; p < tp; p++) + gc_mark(*p); +} + +static void mark_rootlet(s7_scheme * sc) +{ + s7_pointer ge = sc->rootlet; + s7_pointer *tmp, *top; + tmp = rootlet_elements(ge); + top = (s7_pointer *) (tmp + sc->rootlet_entries); + set_mark(ge); + while (tmp < top) + gc_mark(slot_value(*tmp++)); + /* slot_setter is handled below with an explicit list -- more code than its worth probably */ + /* we're not marking slot_symbol above which makes me worry that a top-level gensym won't be protected + * (apply define (gensym) '(32)), then try to get the GC to clobber {gensym}-0, + * but I can't get it to break, so they must be protected somehow; apparently they are + * removed from the heap! At least: (define-macro (defit) (let ((n (gensym))) `(define (,n) (format #t "fun")))) (defit) + * removes the function from the heap (protecting the gensym). + */ +} + +/* arrays for permanent_objects are not needed yet: init: cells: 0, lets: 0, s7test: cells: 4, lets: 10, snd-test: cells: 14, lets: 1147 */ + +/* mark_closure calls mark_let on closure_let(func) which marks slot values. + * if we move rootlet to end, unmarked closures at that point could mark let/slot but not slot value? + * or save safe-closure lets to handle all at end? or a gc_list of safe closure lets and only mark let if not safe? + */ + +static void mark_permanent_objects(s7_scheme * sc) +{ + gc_obj_t *g; + for (g = sc->permanent_objects; g; g = (gc_obj_t *) (g->nxt)) + gc_mark(g->p); + /* permanent_objects also has lets (removed from heap) -- should they be handled like permanent_lets? + * if unmarked should either be removed from the list and perhaps placed on a free list? + * if outlet is free can the let potentially be in use? + * there are many more permanent_lets(slots) than permanent objects + */ +} + +/* do we mark funclet slot values from the function as root? Maybe treat them like permanent_lets here? */ + +static void unmark_permanent_objects(s7_scheme * sc) +{ + gc_obj_t *g; + for (g = sc->permanent_objects; g; g = (gc_obj_t *) (g->nxt)) + clear_mark(g->p); + for (g = sc->permanent_lets; g; g = (gc_obj_t *) (g->nxt)) /* there are lets and slots in this list */ + clear_mark(g->p); +} + +#if (!MS_WINDOWS) +#include +#include +#endif + +#if S7_DEBUGGING +static bool has_odd_bits(s7_pointer obj); +#endif +static char *describe_type_bits(s7_scheme * sc, s7_pointer obj); +static s7_pointer make_symbol(s7_scheme * sc, const char *name); +static void s7_warn(s7_scheme * sc, s7_int len, const char *ctrl, ...); + +#if S7_DEBUGGING +#define call_gc(Sc) gc(Sc, __func__, __LINE__) +static int64_t gc(s7_scheme * sc, const char *func, int line) +#else +#define call_gc(Sc) gc(Sc) +static int64_t gc(s7_scheme * sc) +#endif +{ + s7_cell **old_free_heap_top; + s7_int i; + s7_pointer p; + + sc->gc_start = my_clock(); + sc->gc_calls++; +#if S7_DEBUGGING + sc->last_gc_line = line; +#endif + sc->continuation_counter = 0; + + mark_rootlet(sc); + mark_owlet(sc); + + gc_mark(sc->code); + if (sc->args) + gc_mark(sc->args); + gc_mark(sc->curlet); /* not mark_let because op_any_closure_3p uses sc->curlet as a temp!! */ + mark_current_code(sc); /* probably redundant if with_history */ + + mark_stack_1(sc->stack, current_stack_top(sc)); + gc_mark(sc->u); + gc_mark(sc->v); + gc_mark(sc->w); + gc_mark(sc->x); + gc_mark(sc->y); + gc_mark(sc->z); + gc_mark(sc->value); + + gc_mark(sc->temp1); + gc_mark(sc->temp2); + gc_mark(sc->temp3); + gc_mark(sc->temp4); + gc_mark(sc->temp5); + gc_mark(sc->temp6); + gc_mark(sc->temp7); + gc_mark(sc->temp8); + gc_mark(sc->temp9); + + set_mark(current_input_port(sc)); + mark_input_port_stack(sc); + set_mark(current_output_port(sc)); + set_mark(sc->error_port); + gc_mark(sc->stacktrace_defaults); + gc_mark(sc->autoload_table); + gc_mark(sc->default_rng); + + /* permanent lists that might escape and therefore need GC protection */ + mark_pair(sc->temp_cell_2); + gc_mark(car(sc->t1_1)); + gc_mark(car(sc->t2_1)); + gc_mark(car(sc->t2_2)); + gc_mark(car(sc->t3_1)); + gc_mark(car(sc->t3_2)); + gc_mark(car(sc->t3_3)); + gc_mark(car(sc->t4_1)); + gc_mark(car(sc->plist_1)); + /* gc_mark(car(sc->clist_1)); *//* unnecessary, I think */ + gc_mark(car(sc->plist_2)); + gc_mark(cadr(sc->plist_2)); + gc_mark(car(sc->qlist_2)); + gc_mark(cadr(sc->qlist_2)); + gc_mark(car(sc->qlist_3)); + gc_mark(cadr(sc->qlist_3)); + gc_mark(caddr(sc->qlist_3)); + gc_mark(car(sc->u1_1)); + gc_mark(car(sc->u2_1)); + + gc_mark(sc->rec_p1); + gc_mark(sc->rec_p2); + + for (p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p)) + gc_mark(car(p)); + for (p = sc->simple_wrong_type_arg_info; is_pair(p); p = cdr(p)) + gc_mark(car(p)); + for (p = sc->out_of_range_info; is_pair(p); p = cdr(p)) + gc_mark(car(p)); + for (p = sc->simple_out_of_range_info; is_pair(p); p = cdr(p)) + gc_mark(car(p)); + gc_mark(car(sc->elist_1)); + gc_mark(car(sc->elist_2)); + gc_mark(cadr(sc->elist_2)); + for (p = sc->plist_3; is_pair(p); p = cdr(p)) + gc_mark(car(p)); + for (p = sc->elist_3; is_pair(p); p = cdr(p)) + gc_mark(car(p)); + for (p = sc->elist_4; is_pair(p); p = cdr(p)) + gc_mark(car(p)); + for (p = sc->elist_5; is_pair(p); p = cdr(p)) + gc_mark(car(p)); + + for (i = 1; i < NUM_SAFE_LISTS; i++) + if ((is_pair(sc->safe_lists[i])) && + (list_is_in_use(sc->safe_lists[i]))) + for (p = sc->safe_lists[i]; is_pair(p); p = cdr(p)) + gc_mark(car(p)); + + for (i = 0; i < sc->setters_loc; i++) + gc_mark(cdr(sc->setters[i])); + + for (i = 0; i < sc->num_fdats; i++) + if (sc->fdats[i]) + gc_mark(sc->fdats[i]->curly_arg); + + if (sc->rec_stack) { + just_mark(sc->rec_stack); + for (i = 0; i < sc->rec_loc; i++) + gc_mark(sc->rec_els[i]); + } + mark_vector(sc->protected_objects); + mark_vector(sc->protected_setters); + set_mark(sc->protected_setter_symbols); + + /* now protect recent allocations using the free_heap cells above the current free_heap_top (if any). + * cells above sc->free_heap_top might be malloc'd garbage (after heap reallocation), so we keep track of + * where the last actually freed cells were after the previous GC call. We're trying to + * GC protect the previous GC_TEMPS_SIZE allocated pointers so that the caller doesn't have + * to gc-protect every temporary cell. + * There's one remaining possible problem. s7_remove_from_heap frees cells outside + * the GC and might push free_heap_top beyond its previous_free_heap_top, then + * an immediate explicit gc call might not see those temp cells. + */ + { + s7_pointer *tmps, *tmps_top; + tmps = sc->free_heap_top; + tmps_top = tmps + sc->gc_temps_size; + if (tmps_top > sc->previous_free_heap_top) + tmps_top = sc->previous_free_heap_top; + while (tmps < tmps_top) + gc_mark(*tmps++); + } + mark_op_stack(sc); + mark_permanent_objects(sc); + + if (sc->profiling_gensyms) { + profile_data_t *pd = sc->profile_data; + for (i = 0; i < pd->top; i++) + if (is_gensym(pd->funcs[i])) + set_mark(pd->funcs[i]); + } + + { + gc_list_t *gp = sc->opt1_funcs; + for (i = 0; i < gp->loc; i++) { + s7_pointer s1; + s1 = T_Pair(gp->list[i]); + if ((is_marked(s1)) && (!is_marked(opt1_any(s1)))) /* opt1_lambda, but op_unknown* can change to opt1_cfunc etc */ + gc_mark(opt1_any(s1)); /* not set_mark -- need to protect let/body/args as well */ + } + } + + /* free up all unmarked objects */ + old_free_heap_top = sc->free_heap_top; + { + s7_pointer *fp = sc->free_heap_top, *tp = sc->heap, *heap_top; + heap_top = (s7_pointer *) (sc->heap + sc->heap_size); + +#if S7_DEBUGGING +#define gc_object(Tp) \ + p = (*Tp++); \ + if (signed_type(p) > 0) \ + { \ + p->debugger_bits = 0; p->gc_func = func; p->gc_line = line; \ + /* if (unchecked_type(p) == T_PAIR) {p->object.cons.opt1 = NULL; p->object.cons.opt2 = NULL; p->object.cons.opt3 = NULL;} */\ + if (has_odd_bits(p)) {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(sc, p)); free(s);} \ + signed_type(p) = 0; \ + (*fp++) = p; \ + } \ + else if (signed_type(p) < 0) clear_mark(p); +#else +#define gc_object(Tp) p = (*Tp++); if (signed_type(p) > 0) {signed_type(p) = 0; (*fp++) = p;} else if (signed_type(p) < 0) clear_mark(p); + /* this appears to be about 10% faster than the previous form + * if the sign bit is on, but no other bits, this version will take no action (it thinks the cell is on the free list), but + * it means we've marked a free cell as in-use: since types are set as soon as removed from the free list, this has to be a bug + * (this case is caught by has_odd_bits). If ignored, the type will be set, and later the bit cleared, so no problem? + * An alternate form that simply calls clear_mark (no check for < 0) appears to be the same speed even in cases with lots + * of long-lived objects. + */ +#endif + while (tp < heap_top) { /* != here or ^ makes no difference, and going to 64 (from 32) doesn't matter */ + LOOP_8(gc_object(tp)); + LOOP_8(gc_object(tp)); + LOOP_8(gc_object(tp)); + LOOP_8(gc_object(tp)); + } + /* I tried using pthreads here, since there is no need for a lock in this loop, but the *fp++ part needs to + * be local to each thread, then merged at the end. In my timing tests, the current version was faster. + * If NUM_THREADS=2, and all thread variables are local, surely there's no "false sharing"? + */ + sc->free_heap_top = fp; + sweep(sc); + } + + unmark_permanent_objects(sc); + sc->gc_freed = (int64_t) (sc->free_heap_top - old_free_heap_top); + sc->gc_total_freed += sc->gc_freed; + sc->gc_end = my_clock(); + sc->gc_total_time += (sc->gc_end - sc->gc_start); + + if (sc->gc_stats != 0) { + if (show_gc_stats(sc)) { +#if (!MS_WINDOWS) + s7_warn(sc, 256, + "gc freed %" ld64 "/%" ld64 " (free: %" p64 + "), time: %f\n", sc->gc_freed, sc->heap_size, + (intptr_t) (sc->free_heap_top - sc->free_heap), + (double) (sc->gc_end - + sc->gc_start) / ticks_per_second()); +#else + s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 "\n", + sc->gc_freed, sc->heap_size); +#endif + } + if (show_protected_objects_stats(sc)) { + s7_int len, num; + len = vector_length(sc->protected_objects); /* allocated at startup */ + for (i = 0, num = 0; i < len; i++) + if (vector_element(sc->protected_objects, i) != sc->unused) + num++; + s7_warn(sc, 256, + "gc-protected-objects: %" ld64 " in use of %" ld64 + "\n", num, len); + } + } + sc->previous_free_heap_top = sc->free_heap_top; + return (sc->gc_freed); +} + +#define GC_RESIZE_HEAP_BY_4_FRACTION 0.67 +/* .5+.1: test -3?, dup +86, tmap +45, tsort -3, thash +305. .85+.7: dup -5 */ + +static void resize_heap_to(s7_scheme * sc, int64_t size) +{ + int64_t old_size = sc->heap_size, old_free, k; + s7_cell *cells; + s7_pointer p; + s7_cell **cp; + heap_block_t *hp; + + old_free = sc->free_heap_top - sc->free_heap; + if (size == 0) { + /* (sc->heap_size < 2048000) *//* 8192000 here improves various gc benchmarks only slightly */ + /* maybe the choice of 4 should depend on how much space was freed rather than the current heap_size? */ + if (old_free < old_size * sc->gc_resize_heap_by_4_fraction) + sc->heap_size *= 4; /* *8 if < 1M (or whatever) doesn't make much difference */ + else + sc->heap_size *= 2; + } else if (size > sc->heap_size) + while (sc->heap_size < size) + sc->heap_size *= 2; + else + return; + /* do not call new_cell here! */ + + if (((2 * sc->heap_size * sizeof(s7_cell *)) + + ((sc->heap_size - old_size) * sizeof(s7_cell))) >= SIZE_MAX) { + s7_warn(sc, 256, + "heap size requested, %" ld64 " => %" ld64 + " bytes, is greater than size_t: %" ld64 "\n", + sc->heap_size, + (2 * sc->heap_size * sizeof(s7_cell *)) + + ((sc->heap_size - old_size) * sizeof(s7_cell)), SIZE_MAX); + sc->heap_size = old_size + 64000; + } + + cp = (s7_cell **) realloc(sc->heap, sc->heap_size * sizeof(s7_cell *)); + if (cp) + sc->heap = cp; + else { + s7_warn(sc, 256, + "heap reallocation failed! tried to get %" ld64 + " bytes (will retry with a smaller amount)\n", + (int64_t) (sc->heap_size * sizeof(s7_cell *))); + sc->heap_size = old_size + 64000; + sc->heap = + (s7_cell **) Realloc(sc->heap, + sc->heap_size * sizeof(s7_cell *)); + } + sc->free_heap = + (s7_cell **) Realloc(sc->free_heap, + sc->heap_size * sizeof(s7_cell *)); + sc->free_heap_trigger = (s7_cell **) (sc->free_heap + GC_TRIGGER_SIZE); + sc->free_heap_top = sc->free_heap + old_free; /* incremented below, added old_free 21-Aug-12?!? */ + + cells = (s7_cell *) Calloc(sc->heap_size - old_size, sizeof(s7_cell)); + add_saved_pointer(sc, (void *) cells); + for (p = cells, k = old_size; k < sc->heap_size;) { + LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); + LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); + LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); + LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); + } + hp = (heap_block_t *) Malloc(sizeof(heap_block_t)); + hp->start = (intptr_t) cells; + hp->end = + (intptr_t) cells + ((sc->heap_size - old_size) * sizeof(s7_cell)); + hp->offset = old_size; + hp->next = sc->heap_blocks; + sc->heap_blocks = hp; + sc->previous_free_heap_top = sc->free_heap_top; + + if (show_heap_stats(sc)) { + char *str; + str = + string_value(object_to_truncated_string + (sc, current_code(sc), 80)); + if (size != 0) + s7_warn(sc, 512, + "heap grows to %" ld64 " (old free/size: %" ld64 "/%" + ld64 ", requested %" ld64 ") from %s\n", sc->heap_size, + old_free, old_size, size, str); + else + s7_warn(sc, 512, + "heap grows to %" ld64 " (old free/size: %" ld64 "/%" + ld64 ") from %s\n", sc->heap_size, old_free, old_size, + str); + } + if (sc->heap_size >= sc->max_heap_size) + s7_error(sc, make_symbol(sc, "heap-too-big"), + set_elist_3(sc, + wrap_string(sc, + "heap has grown past (*s7* 'max-heap-size): ~S > ~S", + 50), wrap_integer1(sc, + sc->max_heap_size), + wrap_integer2(sc, sc->heap_size))); +} + +#define resize_heap(Sc) resize_heap_to(Sc, 0) + +#ifndef GC_RESIZE_HEAP_FRACTION +#define GC_RESIZE_HEAP_FRACTION 0.8 +/* 1/2 is ok, 3/4 speeds up some GC benchmarks, 7/8 is a bit faster, 95/100 comes to a halt (giant heap) + * in my tests, only tvect.scm ends up larger if 3/4 used + */ +#endif + +#if S7_DEBUGGING +static void try_to_call_gc_1(s7_scheme * sc, const char *func, int line) +#else +static void try_to_call_gc(s7_scheme * sc) +#endif +{ + /* called only from new_cell */ + if (sc->gc_off) /* we can't just return here! Someone needs a new cell, and once the heap free list is exhausted, segfault */ + resize_heap(sc); + else { +#if (!S7_DEBUGGING) + int64_t freed_heap; + freed_heap = gc(sc); + if (freed_heap < (sc->heap_size * sc->gc_resize_heap_fraction)) + resize_heap(sc); +#else + gc(sc, func, line); + if ((int64_t) (sc->free_heap_top - sc->free_heap) < + (sc->heap_size * sc->gc_resize_heap_fraction)) + resize_heap(sc); +#endif + } +} + + /* originally I tried to mark each temporary value until I was done with it, but + * that way madness lies... By delaying GC of _every_ %$^#%@ pointer, I can dispense + * with hundreds of individual protections. So the free_heap's last GC_TEMPS_SIZE + * allocated pointers are protected during the mark sweep. + */ + +static s7_pointer g_gc(s7_scheme * sc, s7_pointer args) +{ +#define H_gc "(gc (on #t)) runs the garbage collector. If 'on' is supplied, it turns the GC on or off. \ +Evaluation produces a surprising amount of garbage, so don't leave the GC off for very long!" +#define Q_gc s7_make_signature(sc, 2, sc->T, sc->is_boolean_symbol) + + /* g_gc can't be called in a situation where these lists matter (I think...) */ + set_elist_1(sc, sc->nil); + set_plist_1(sc, sc->nil); + set_elist_2(sc, sc->nil, sc->nil); + set_plist_2(sc, sc->nil, sc->nil); + /* set_clist_1(sc, sc->nil); *//* not gc_marked */ + set_qlist_2(sc, sc->nil, sc->nil); + set_qlist_3(sc, sc->nil, sc->nil, sc->nil); + set_elist_3(sc, sc->nil, sc->nil, sc->nil); + set_plist_3(sc, sc->nil, sc->nil, sc->nil); + set_elist_4(sc, sc->nil, sc->nil, sc->nil, sc->nil); + set_elist_5(sc, sc->nil, sc->nil, sc->nil, sc->nil, sc->nil); + + if (is_not_null(args)) { + if (!s7_is_boolean(car(args))) + return (method_or_bust_one_arg + (sc, car(args), sc->gc_symbol, args, T_BOOLEAN)); + sc->gc_off = (car(args) == sc->F); + if (sc->gc_off) + return (sc->F); + } + call_gc(sc); + return (sc->unspecified); +} + +s7_pointer s7_gc_on(s7_scheme * sc, bool on) +{ + sc->gc_off = !on; + return (s7_make_boolean(sc, on)); +} + +#if S7_DEBUGGING +static void check_free_heap_size_1(s7_scheme * sc, s7_int size, + const char *func, int line) +#define check_free_heap_size(Sc, Size) check_free_heap_size_1(Sc, Size, __func__, __LINE__) +#else +static void check_free_heap_size(s7_scheme * sc, s7_int size) +#endif +{ + s7_int free_cells; + free_cells = sc->free_heap_top - sc->free_heap; + if (free_cells < size) { +#if S7_DEBUGGING + gc(sc, func, line); +#else + gc(sc); +#endif + while ((sc->free_heap_top - sc->free_heap) < size) + resize_heap(sc); + } +} + +#define ALLOC_POINTER_SIZE 256 +static s7_cell *alloc_pointer(s7_scheme * sc) +{ + if (sc->alloc_pointer_k == ALLOC_POINTER_SIZE) { /* if either no current block or the block is used up, make a new block */ + sc->permanent_cells += ALLOC_POINTER_SIZE; + sc->alloc_pointer_cells = + (s7_cell *) Calloc(ALLOC_POINTER_SIZE, sizeof(s7_cell)); + add_saved_pointer(sc, sc->alloc_pointer_cells); + sc->alloc_pointer_k = 0; + } + return (&(sc->alloc_pointer_cells[sc->alloc_pointer_k++])); +} + +#define ALLOC_BIG_POINTER_SIZE 256 +static s7_big_cell *alloc_big_pointer(s7_scheme * sc, int64_t loc) +{ + s7_big_pointer p; + if (sc->alloc_big_pointer_k == ALLOC_BIG_POINTER_SIZE) { + sc->permanent_cells += ALLOC_BIG_POINTER_SIZE; + sc->alloc_big_pointer_cells = + (s7_big_cell *) Calloc(ALLOC_BIG_POINTER_SIZE, + sizeof(s7_big_cell)); + add_saved_pointer(sc, sc->alloc_big_pointer_cells); + sc->alloc_big_pointer_k = 0; + } + p = (&(sc->alloc_big_pointer_cells[sc->alloc_big_pointer_k++])); + p->big_hloc = loc; + /* needed if this new pointer is itself petrified later -- it's not from one of the heap blocks, + * but it's in the heap, and we'll need to know where it is in the heap to replace it + */ + return (p); +} + +static void add_permanent_object(s7_scheme * sc, s7_pointer obj) +{ /* called by remove_from_heap */ + gc_obj_t *g; + g = (gc_obj_t *) Malloc(sizeof(gc_obj_t)); + g->p = obj; + g->nxt = sc->permanent_objects; + sc->permanent_objects = g; +} + +static void add_permanent_let_or_slot(s7_scheme * sc, s7_pointer obj) +{ + gc_obj_t *g; + g = (gc_obj_t *) Malloc(sizeof(gc_obj_t)); + g->p = obj; + g->nxt = sc->permanent_lets; + sc->permanent_lets = g; +} + +#if S7_DEBUGGING +static const char *type_name_from_type(int32_t typ, article_t article); + +#define free_cell(Sc, P) free_cell_1(Sc, P, __LINE__) +static void free_cell_1(s7_scheme * sc, s7_pointer p, int32_t line) +#else +static void free_cell(s7_scheme * sc, s7_pointer p) +#endif +{ +#if S7_DEBUGGING + /* anything that needs gc_list attention should not be freed here */ + uint8_t typ = unchecked_type(p); + if ((t_freeze_p[typ]) || ((typ == T_SYMBOL) && (is_gensym(p)))) + fprintf(stderr, "free_cell of %s?\n", + type_name_from_type(typ, NO_ARTICLE)); + p->debugger_bits = 0; + p->explicit_free_line = line; +#endif + clear_type(p); + (*(sc->free_heap_top++)) = p; +} + +static inline s7_pointer petrify(s7_scheme * sc, s7_pointer x) +{ + s7_pointer p; + int64_t loc; + loc = heap_location(sc, x); + p = (s7_pointer) alloc_big_pointer(sc, loc); + sc->heap[loc] = p; + free_cell(sc, p); + unheap(sc, x); /* set_immutable(x); *//* if there are GC troubles, this might catch them? */ + return (x); +} + +static inline void s7_remove_from_heap(s7_scheme * sc, s7_pointer x) +{ + /* global functions are very rarely redefined, so we can remove the function body from the heap when it is defined */ + if (!in_heap(x)) + return; + if (is_pair(x)) { + s7_pointer p = x; + do { + petrify(sc, p); + s7_remove_from_heap(sc, car(p)); + p = cdr(p); + } while (is_pair(p) && (in_heap(p))); + if (in_heap(p)) + petrify(sc, p); + return; + } + + switch (type(x)) { + case T_LET: + if (is_funclet(x)) + set_immutable(x); + case T_HASH_TABLE: + case T_VECTOR: + /* not int|float_vector or string because none of their elements are GC-able (so unheap below is ok) + * but hash-table and let seem like they need protection? And let does happen via define-class. + */ + add_permanent_object(sc, x); + return; + + case T_SYMBOL: + if (is_gensym(x)) { + s7_int i; + gc_list_t *gp; + int64_t loc; + loc = heap_location(sc, x); + sc->heap[loc] = (s7_pointer) alloc_big_pointer(sc, loc); + free_cell(sc, sc->heap[loc]); + unheap(sc, x); + + gp = sc->gensyms; + for (i = 0; i < gp->loc; i++) /* sc->gensyms reaches size 512 during s7test, but this search is called 3 times and costs nothing */ + if (gp->list[i] == x) { + s7_int j; + for (j = i + 1; i < gp->loc - 1; i++, j++) + gp->list[i] = gp->list[j]; + gp->list[i] = NULL; + gp->loc--; + if (gp->loc == 0) + mark_function[T_SYMBOL] = mark_noop; + break; + } + } + return; + + case T_CLOSURE: + case T_CLOSURE_STAR: + case T_MACRO: + case T_MACRO_STAR: + case T_BACRO: + case T_BACRO_STAR: + /* these need to be GC-protected! */ + add_permanent_object(sc, x); + return; + + default: + break; + } + + petrify(sc, x); +} + + +/* -------------------------------- stacks -------------------------------- */ + +#define OP_STACK_INITIAL_SIZE 64 + +#if S7_DEBUGGING +static void push_op_stack(s7_scheme * sc, s7_pointer op) +{ + (*sc->op_stack_now++) = T_Pos(op); + if (sc->op_stack_now > (sc->op_stack + sc->op_stack_size)) { + fprintf(stderr, "%sop_stack overflow%s\n", BOLD_TEXT, UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } +} + +static s7_pointer pop_op_stack(s7_scheme * sc) +{ + s7_pointer op; + op = (*(--(sc->op_stack_now))); + if (sc->op_stack_now < sc->op_stack) { + fprintf(stderr, "%sop_stack underflow%s\n", BOLD_TEXT, + UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + return (T_Pos(op)); +} +#else +#define push_op_stack(Sc, Op) (*Sc->op_stack_now++) = Op +#define pop_op_stack(Sc) (*(--(Sc->op_stack_now))) +#endif + +static void initialize_op_stack(s7_scheme * sc) +{ + int32_t i; + sc->op_stack = + (s7_pointer *) malloc(OP_STACK_INITIAL_SIZE * sizeof(s7_pointer)); + sc->op_stack_size = OP_STACK_INITIAL_SIZE; + sc->op_stack_now = sc->op_stack; + sc->op_stack_end = (s7_pointer *) (sc->op_stack + sc->op_stack_size); + for (i = 0; i < OP_STACK_INITIAL_SIZE; i++) + sc->op_stack[i] = sc->nil; +} + +static void resize_op_stack(s7_scheme * sc) +{ + int32_t i, loc, new_size; + loc = (int32_t) (sc->op_stack_now - sc->op_stack); + new_size = sc->op_stack_size * 2; + sc->op_stack = + (s7_pointer *) Realloc((void *) (sc->op_stack), + new_size * sizeof(s7_pointer)); + for (i = sc->op_stack_size; i < new_size; i++) + sc->op_stack[i] = sc->nil; + sc->op_stack_size = (uint32_t) new_size; + sc->op_stack_now = (s7_pointer *) (sc->op_stack + loc); + sc->op_stack_end = (s7_pointer *) (sc->op_stack + sc->op_stack_size); +} + +#if S7_DEBUGGING +#define pop_stack(Sc) pop_stack_1(Sc, __func__, __LINE__) +static void pop_stack_1(s7_scheme * sc, const char *func, int line) +{ + sc->stack_end -= 4; + if (sc->stack_end < sc->stack_start) { + fprintf(stderr, "%s%s[%d]: stack underflow%s\n", BOLD_TEXT, func, + line, UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + /* here and in push_stack, both code and args might be non-free only because they've been retyped + * inline (as in named let) -- they actually don't make sense in these cases, but are ignored, + * and are carried around as GC protection in other cases. + */ + sc->code = T_Pos(sc->stack_end[0]); + sc->curlet = T_Pos(sc->stack_end[1]); /* not T_Lid, see op_any_closure_3p_end et al (stack used to pass args, not curlet) */ + sc->args = sc->stack_end[2]; + sc->cur_op = (opcode_t) (sc->stack_end[3]); + if (sc->cur_op >= NUM_OPS) { + fprintf(stderr, + "%s%s[%d]: pop_stack invalid opcode: %" p64 " %s\n", + BOLD_TEXT, func, line, sc->cur_op, UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + if ((sc->cur_op != OP_GC_PROTECT) && (!is_let(sc->stack_end[1])) && (!is_null(sc->stack_end[1])) && (sc->cur_op != OP_ANY_CLOSURE_3P_3)) /* used as third GC protection field */ + fprintf(stderr, "%s[%d]: curlet not a let: %s\n", func, line, + op_names[sc->cur_op]); +} + +#define pop_stack_no_op(Sc) pop_stack_no_op_1(Sc, __func__, __LINE__) +static void pop_stack_no_op_1(s7_scheme * sc, const char *func, int line) +{ + sc->stack_end -= 4; + if (sc->stack_end < sc->stack_start) { + fprintf(stderr, "%s%s[%d]: stack underflow%s\n", BOLD_TEXT, func, + line, UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + sc->code = T_Pos(sc->stack_end[0]); + if ((sc->cur_op != OP_GC_PROTECT) && (!is_let(sc->stack_end[1])) + && (!is_null(sc->stack_end[1]))) + fprintf(stderr, "%s[%d]: curlet not a let\n", func, line); + sc->curlet = T_Pos(sc->stack_end[1]); /* not T_Lid: gc_protect can set this directly (not through push_stack) to anything */ + sc->args = sc->stack_end[2]; +} + +#define push_stack(Sc, Op, Args, Code) \ + do {s7_pointer *_end_; _end_ = Sc->stack_end; push_stack_1(Sc, Op, Args, Code, _end_, __func__, __LINE__);} while (0) + +static void push_stack_1(s7_scheme * sc, opcode_t op, s7_pointer args, + s7_pointer code, s7_pointer * end, + const char *func, int line) +{ + if (sc->stack_end >= sc->stack_start + sc->stack_size) { + fprintf(stderr, "%s%s[%d]: stack overflow%s\n", BOLD_TEXT, func, + line, UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + if (sc->stack_end >= sc->stack_resize_trigger) + fprintf(stderr, "%s%s[%d]: stack resize skipped%s\n", BOLD_TEXT, + func, line, UNBOLD_TEXT); + if (sc->stack_end != end) + fprintf(stderr, "%s[%d]: stack changed in push_stack\n", func, + line); + if (op >= NUM_OPS) { + fprintf(stderr, + "%s%s[%d]: push_stack invalid opcode: %" p64 " %s\n", + BOLD_TEXT, func, line, sc->cur_op, UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + if (code) + sc->stack_end[0] = T_Pos(code); + sc->stack_end[1] = T_Lid(sc->curlet); + if ((args) && (unchecked_type(args) != T_FREE)) + sc->stack_end[2] = T_Pos(args); + sc->stack_end[3] = (s7_pointer) op; + sc->stack_end += 4; +} + +#define push_stack_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused) +#define push_stack_no_let_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused) +#define push_stack_no_args(Sc, Op, Code) push_stack(Sc, Op, Sc->unused, Code) +#define push_stack_no_let(Sc, Op, Args, Code) push_stack(Sc, Op, Args, Code) +#define push_stack_op(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->unused) +#define push_stack_op_let(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->unused) +#define push_stack_direct(Sc, Op) push_stack(Sc, Op, Sc->args, Sc->code) +#define push_stack_no_args_direct(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->code) +/* in the non-debugging case, the sc->unused's here are not set, so we can (later) pop free cells */ + +#else + +#define pop_stack(Sc) do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 4 * sizeof(s7_pointer));} while (0) +#define pop_stack_no_op(Sc) {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 3 * sizeof(s7_pointer));} while (0) + +#define push_stack(Sc, Op, Args, Code) \ + do { \ + Sc->stack_end[0] = Code; \ + Sc->stack_end[1] = Sc->curlet; \ + Sc->stack_end[2] = Args; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ + Sc->stack_end += 4; \ + } while (0) + +#define push_stack_direct(Sc, Op) \ + do { \ + memcpy((void *)(Sc->stack_end), (void *)Sc, 3 * sizeof(s7_pointer)); \ + Sc->stack_end[3] = (s7_pointer)(Op); \ + Sc->stack_end += 4; \ + } while (0) + +#define push_stack_no_code(Sc, Op, Args) \ + do { \ + Sc->stack_end[1] = Sc->curlet; \ + Sc->stack_end[2] = Args; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ + Sc->stack_end += 4; \ + } while (0) + +#define push_stack_no_let_no_code(Sc, Op, Args) \ + do { \ + Sc->stack_end[2] = Args; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ + Sc->stack_end += 4; \ + } while (0) + +#define push_stack_no_args(Sc, Op, Code) \ + do { \ + Sc->stack_end[0] = Code; \ + Sc->stack_end[1] = Sc->curlet; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ + Sc->stack_end += 4; \ + } while (0) + +#define push_stack_no_args_direct(Sc, Op) \ + do { \ + memcpy((void *)(Sc->stack_end), (void *)Sc, 2 * sizeof(s7_pointer)); \ + Sc->stack_end[3] = (s7_pointer)(Op); \ + Sc->stack_end += 4; \ + } while (0) + +#define push_stack_no_let(Sc, Op, Args, Code) \ + do { \ + Sc->stack_end[0] = Code; \ + Sc->stack_end[2] = Args; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ + Sc->stack_end += 4; \ + } while (0) + +#define push_stack_op(Sc, Op) \ + do { \ + Sc->stack_end[3] = (s7_pointer)(Op); \ + Sc->stack_end += 4; \ + } while (0) + +#define push_stack_op_let(Sc, Op) \ + do { \ + Sc->stack_end[1] = Sc->curlet; \ + Sc->stack_end[3] = (s7_pointer)(Op); \ + Sc->stack_end += 4; \ + } while (0) +#endif +/* since we don't GC mark the stack past the stack_top, push_stack_no_args and friends can cause pop_stack to set + * sc->code and sc->args to currently free objects. + */ + +#if S7_DEBUGGING +#define unstack(Sc) unstack_1(Sc, __func__, __LINE__) +static void unstack_1(s7_scheme * sc, const char *func, int line) +{ + sc->stack_end -= 4; + if (((opcode_t) sc->stack_end[3]) != OP_GC_PROTECT) { + fprintf(stderr, "%s%s[%d]: popped %s?%s\n", BOLD_TEXT, func, line, + op_names[(opcode_t) sc->stack_end[3]], UNBOLD_TEXT); + fprintf(stderr, " code: %s, args: %s\n", display(sc->code), + display(sc->args)); + fprintf(stderr, " cur_code: %s, estr: %s\n", + display(current_code(sc)), + display(s7_name_to_value(sc, "estr"))); + if (sc->stop_at_error) + abort(); + } +} + +#define unstack_with(Sc, Op) unstack_2(Sc, Op, __func__, __LINE__) +static void unstack_2(s7_scheme * sc, opcode_t op, const char *func, + int line) +{ + sc->stack_end -= 4; + if (((opcode_t) sc->stack_end[3]) != op) { + fprintf(stderr, "%s%s[%d]: popped %s?%s\n", BOLD_TEXT, func, line, + op_names[(opcode_t) sc->stack_end[3]], UNBOLD_TEXT); + fprintf(stderr, " code: %s, args: %s\n", display(sc->code), + display(sc->args)); + fprintf(stderr, " cur_code: %s, estr: %s\n", + display(current_code(sc)), + display(s7_name_to_value(sc, "estr"))); + if (sc->stop_at_error) + abort(); + } +} +#else +#define unstack(sc) sc->stack_end -= 4 +#define unstack_with(sc, op) sc->stack_end -= 4 +#endif + +#define main_stack_op(Sc) ((opcode_t)(Sc->stack_end[-1])) +/* #define main_stack_args(Sc) (Sc->stack_end[-2]), #define main_stack_let(Sc) (Sc->stack_end[-3]), #define main_stack_code(Sc) (Sc->stack_end[-4]) */ +/* beware of main_stack_code! If a function has a tail-call, the main_stack_code that form sees + * if main_stack_op==op-begin1 can change from call to call -- the begin actually refers + * to the caller, which is dependent on where the current function was called, so we can't hard-wire + * any optimizations based on that sequence. + */ + +static void stack_reset(s7_scheme * sc) +{ + sc->stack_end = sc->stack_start; + push_stack_op(sc, OP_EVAL_DONE); +} + +static void resize_stack(s7_scheme * sc) +{ + uint64_t loc; + uint32_t new_size; + block_t *ob, *nb; + + loc = current_stack_top(sc); + new_size = sc->stack_size * 2; + + /* how can we trap infinite recursion? Is a warning in order here? I think I'll add 'max-stack-size */ + if (new_size > sc->max_stack_size) + s7_error(sc, make_symbol(sc, "stack-too-big"), + set_elist_1(sc, + wrap_string(sc, + "stack has grown past (*s7* 'max-stack-size)", + 43))); + + ob = stack_block(sc->stack); + nb = reallocate(sc, ob, new_size * sizeof(s7_pointer)); + block_info(nb) = NULL; + stack_block(sc->stack) = nb; + stack_elements(sc->stack) = (s7_pointer *) block_data(nb); + if (!stack_elements(sc->stack)) + s7_error(sc, make_symbol(sc, "stack-too-big"), + set_elist_1(sc, + wrap_string(sc, "no room to expand stack?", + 24))); + { + s7_pointer *orig = stack_elements(sc->stack); + s7_int i = sc->stack_size, left; + left = new_size - i - 8; + while (i <= left) + LOOP_8(orig[i++] = sc->nil); + for (; i < new_size; i++) + orig[i] = sc->nil; + } + vector_length(sc->stack) = new_size; + sc->stack_size = new_size; + sc->stack_start = stack_elements(sc->stack); + sc->stack_end = (s7_pointer *) (sc->stack_start + loc); + /* sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + sc->stack_size / 2); */ + sc->stack_resize_trigger = + (s7_pointer *) (sc->stack_start + + (new_size - STACK_RESIZE_TRIGGER)); + + if (show_stack_stats(sc)) + s7_warn(sc, 128, "stack grows to %u\n", new_size); +} + +#define check_stack_size(Sc) do {if (Sc->stack_end >= Sc->stack_resize_trigger) resize_stack(Sc);} while (0) + +s7_pointer s7_gc_protect_via_stack(s7_scheme * sc, s7_pointer x) +{ + push_stack_no_let_no_code(sc, OP_GC_PROTECT, x); + return (x); +} + +s7_pointer s7_gc_unprotect_via_stack(s7_scheme * sc, s7_pointer x) +{ + unstack(sc); + return (x); +} + +#define stack_protected1(Sc) Sc->stack_end[-2] +#define stack_protected2(Sc) Sc->stack_end[-4] +#define stack_protected3(Sc) Sc->stack_end[-3] + +static inline void gc_protect_via_stack(s7_scheme * sc, s7_pointer val) +{ + sc->stack_end[2] = val; + sc->stack_end[3] = (s7_pointer) OP_GC_PROTECT; + sc->stack_end += 4; +} + +#define gc_protect_2_via_stack(Sc, X, Y) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); stack_protected2(Sc) = Y;} while (0) +/* often X and Y are fx_calls, so push X, then set Y */ + + +/* -------------------------------- symbols -------------------------------- */ + +static inline uint64_t raw_string_hash(const uint8_t * key, s7_int len) +{ + if (len <= 8) { + uint64_t xs[1] = { 0 }; + memcpy((void *) xs, (void *) key, len); + return (xs[0]); + } else { + uint64_t xs[2] = { 0, 0 }; + memcpy((void *) xs, (void *) key, (len > 16) ? 16 : len); /* compiler complaint here is bogus */ + return (xs[0] + xs[1]); + } +} + +static uint8_t *alloc_symbol(s7_scheme * sc) +{ +#define SYMBOL_SIZE (3 * sizeof(s7_cell) + sizeof(block_t)) +#define ALLOC_SYMBOL_SIZE (64 * SYMBOL_SIZE) + uint8_t *result; + + if (sc->alloc_symbol_k == ALLOC_SYMBOL_SIZE) { + sc->alloc_symbol_cells = (uint8_t *) Malloc(ALLOC_SYMBOL_SIZE); + add_saved_pointer(sc, sc->alloc_symbol_cells); + sc->alloc_symbol_k = 0; + } + result = &(sc->alloc_symbol_cells[sc->alloc_symbol_k]); + sc->alloc_symbol_k += SYMBOL_SIZE; + return (result); +} + +static s7_pointer make_permanent_slot(s7_scheme * sc, s7_pointer symbol, + s7_pointer value); +static inline s7_pointer make_symbol_with_length(s7_scheme * sc, + const char *name, + s7_int len); + +static inline s7_pointer new_symbol(s7_scheme * sc, const char *name, + s7_int len, uint64_t hash, + uint32_t location) +{ + /* name might not be null-terminated, these are permanent symbols even in s7_gensym; g_gensym handles everything separately */ + s7_pointer x, str, p; + uint8_t *base, *val; + + base = alloc_symbol(sc); + x = (s7_pointer) base; + str = (s7_pointer) (base + sizeof(s7_cell)); + p = (s7_pointer) (base + 2 * sizeof(s7_cell)); + val = (uint8_t *) permalloc(sc, len + 1); + memcpy((void *) val, (void *) name, len); + val[len] = '\0'; + + full_type(str) = T_STRING | T_IMMUTABLE | T_UNHEAP; /* avoid debugging confusion involving set_type (also below) */ + string_length(str) = len; + string_value(str) = (char *) val; + string_hash(str) = hash; + + full_type(x) = T_SYMBOL | T_UNHEAP; + symbol_set_name_cell(x, str); + set_global_slot(x, sc->undefined); /* was sc->nil */ + symbol_info(x) = (block_t *) (base + 3 * sizeof(s7_cell)); + set_initial_slot(x, sc->undefined); + symbol_set_local_slot_unchecked_and_unincremented(x, 0LL, sc->nil); + symbol_set_tag(x, 0); + symbol_set_tag2(x, 0); + symbol_clear_ctr(x); /* alloc_symbol uses malloc */ + symbol_clear_type(x); + symbol_set_position(x, PD_POSITION_UNSET); + + if ((len > 1) && /* not 0, otherwise : is a keyword */ + ((name[0] == ':') || (name[len - 1] == ':'))) { /* see s7test under keyword? for troubles if both colons are present */ + s7_pointer slot, ksym; + set_type_bit(x, T_IMMUTABLE | T_KEYWORD | T_GLOBAL); + set_optimize_op(str, OP_CON); + ksym = + make_symbol_with_length(sc, + (name[0] == + ':') ? (char *) (name + 1) : name, + len - 1); + keyword_set_symbol(x, ksym); + set_has_keyword(ksym); + /* the keyword symbol needs to be permanent (not a gensym) else we have to laboriously gc-protect it */ + if ((is_gensym(ksym)) && (in_heap(ksym))) + s7_remove_from_heap(sc, ksym); + slot = make_permanent_slot(sc, x, x); + set_global_slot(x, slot); + set_local_slot(x, slot); + } + + full_type(p) = T_PAIR | T_IMMUTABLE | T_UNHEAP; /* add x to the symbol table */ + set_car(p, x); + set_cdr(p, vector_element(sc->symbol_table, location)); + vector_element(sc->symbol_table, location) = p; + pair_set_raw_hash(p, hash); + pair_set_raw_len(p, (uint64_t) len); /* symbol name length, so it ought to fit! */ + pair_set_raw_name(p, string_value(str)); + return (x); +} + +static inline s7_pointer make_symbol_with_length(s7_scheme * sc, + const char *name, + s7_int len) +{ + s7_pointer x; + uint64_t hash; + uint32_t location; + + hash = raw_string_hash((const uint8_t *) name, len); + location = hash % SYMBOL_TABLE_SIZE; + + if (len <= 8) { + for (x = vector_element(sc->symbol_table, location); is_pair(x); + x = cdr(x)) + if ((hash == pair_raw_hash(x)) + && ((uint64_t) len == pair_raw_len(x))) + return (car(x)); + } else + for (x = vector_element(sc->symbol_table, location); is_pair(x); + x = cdr(x)) + if ((hash == pair_raw_hash(x)) && ((uint64_t) len == pair_raw_len(x)) && (strings_are_equal_with_length(name, pair_raw_name(x), len))) /* length here because name might not be null-terminated */ + return (car(x)); + return (new_symbol(sc, name, len, hash, location)); +} + +static s7_pointer make_symbol(s7_scheme * sc, const char *name) +{ + return (make_symbol_with_length(sc, name, safe_strlen(name))); +} + +s7_pointer s7_make_symbol(s7_scheme * sc, const char *name) +{ + return ((name) ? make_symbol_with_length(sc, name, safe_strlen(name)) : + sc->F); +} + +static s7_pointer symbol_table_find_by_name(s7_scheme * sc, + const char *name, + uint64_t hash, + uint32_t location, s7_int len) +{ + s7_pointer x; + for (x = vector_element(sc->symbol_table, location); is_not_null(x); + x = cdr(x)) + if ((hash == pair_raw_hash(x)) + && + (strings_are_equal_with_length(name, pair_raw_name(x), len))) + return (car(x)); + return (sc->nil); +} + +s7_pointer s7_symbol_table_find_name(s7_scheme * sc, const char *name) +{ + uint64_t hash; + uint32_t location; + s7_pointer result; + s7_int len; + + hash = raw_string_hash((const uint8_t *) name, len = + safe_strlen(name)); + location = hash % SYMBOL_TABLE_SIZE; + result = symbol_table_find_by_name(sc, name, hash, location, len); + if (is_null(result)) + return (NULL); + return (result); +} + + +/* -------------------------------- symbol-table -------------------------------- */ +static inline s7_pointer make_simple_vector(s7_scheme * sc, s7_int len); + +static s7_pointer g_symbol_table(s7_scheme * sc, s7_pointer args) +{ +#define H_symbol_table "(symbol-table) returns a vector containing the current symbol-table symbols" +#define Q_symbol_table s7_make_signature(sc, 1, sc->is_vector_symbol) + + s7_pointer lst, x; + s7_pointer *els, *entries = vector_elements(sc->symbol_table); + int32_t i, j, syms = 0; + + /* this can't be optimized by returning the actual symbol-table (a vector of lists), because + * gensyms can cause the table's lists and symbols to change at any time. This wreaks havoc + * on traversals like for-each. So, symbol-table returns a snap-shot of the table contents + * at the time it is called. + * (define (for-each-symbol func num) (for-each (lambda (sym) (if (> num 0) (for-each-symbol func (- num 1)) (func sym))) (symbol-table))) + * (for-each-symbol (lambda (sym) (gensym) 1)) + */ + for (i = 0; i < SYMBOL_TABLE_SIZE; i++) + for (x = entries[i]; is_not_null(x); x = cdr(x)) + syms++; + sc->w = make_simple_vector(sc, syms); + els = vector_elements(sc->w); + + for (i = 0, j = 0; i < SYMBOL_TABLE_SIZE; i++) + for (x = entries[i]; is_not_null(x); x = cdr(x)) + els[j++] = car(x); + + lst = sc->w; + sc->w = sc->nil; + return (lst); +} + +bool s7_for_each_symbol_name(s7_scheme * sc, + bool (*symbol_func)(const char *symbol_name, + void *data), void *data) +{ + /* this includes the special constants # and so on for simplicity -- are there any others? */ + int32_t i; + s7_pointer x; + + for (i = 0; i < SYMBOL_TABLE_SIZE; i++) + for (x = vector_element(sc->symbol_table, i); is_not_null(x); + x = cdr(x)) + if (symbol_func(symbol_name(car(x)), data)) + return (true); + + return ((symbol_func("#t", data)) || + (symbol_func("#f", data)) || + (symbol_func("#", data)) || + (symbol_func("#", data)) || + (symbol_func("#", data)) || + (symbol_func("#true", data)) || (symbol_func("#false", data))); +} + +bool s7_for_each_symbol(s7_scheme * sc, + bool (*symbol_func)(const char *symbol_name, + void *data), void *data) +{ + int32_t i; + s7_pointer x; + for (i = 0; i < SYMBOL_TABLE_SIZE; i++) + for (x = vector_element(sc->symbol_table, i); is_not_null(x); + x = cdr(x)) + if (symbol_func(symbol_name(car(x)), data)) + return (true); + return (false); +} + +/* -------------------------------- gensym -------------------------------- */ +static void remove_gensym_from_symbol_table(s7_scheme * sc, s7_pointer sym) +{ + /* sym is a free cell at this point (we're called after the GC), but the name_cell is still intact */ + s7_pointer x, name = symbol_name_cell(sym); + uint32_t location; + + location = string_hash(name) % SYMBOL_TABLE_SIZE; + x = vector_element(sc->symbol_table, location); + + if (car(x) == sym) + vector_element(sc->symbol_table, location) = cdr(x); + else { + s7_pointer y; + for (y = x, x = cdr(x); is_pair(x); y = x, x = cdr(x)) + if (car(x) == sym) { + set_cdr(y, cdr(x)); + return; + } + if (S7_DEBUGGING) + fprintf(stderr, "could not remove %s?\n", string_value(name)); + } +} + +s7_pointer s7_gensym(s7_scheme * sc, const char *prefix) +{ + block_t *b; + char *name; + uint32_t location; + s7_int len; + uint64_t hash; + s7_pointer x; + + len = safe_strlen(prefix) + 32; + b = mallocate(sc, len); + name = (char *) block_data(b); + /* there's no point in heroic efforts here to avoid name collisions -- the user can screw up no matter what we do */ + name[0] = '\0'; + len = + catstrs(name, len, "{", (prefix) ? prefix : "", "}-", + pos_int_to_str_direct(sc, sc->gensym_counter++), + (char *) NULL); + hash = raw_string_hash((const uint8_t *) name, len); + location = hash % SYMBOL_TABLE_SIZE; + x = new_symbol(sc, name, len, hash, location); /* not T_GENSYM -- might be called from outside */ + liberate(sc, b); + return (x); +} + +static bool is_gensym_b_p(s7_pointer g) +{ + return ((is_symbol(g)) && (is_gensym(g))); +} + +static s7_pointer g_is_gensym(s7_scheme * sc, s7_pointer args) +{ +#define H_is_gensym "(gensym? sym) returns #t if sym is a gensym" +#define Q_is_gensym sc->pl_bt + check_boolean_method(sc, is_gensym_b_p, sc->is_gensym_symbol, args); +} + +static s7_pointer g_gensym(s7_scheme * sc, s7_pointer args) +{ +#define H_gensym "(gensym (prefix \"gensym\")) returns a new, unused symbol" +#define Q_gensym s7_make_signature(sc, 2, sc->is_gensym_symbol, sc->is_string_symbol) + + const char *prefix; + char *name, *p, *base; + s7_int len, plen, nlen; + uint32_t location; + uint64_t hash; + s7_pointer x, str, stc; + block_t *b, *ib; + + /* get symbol name */ + if (is_not_null(args)) { + s7_pointer gname; + gname = car(args); + if (!is_string(gname)) + return (method_or_bust_one_arg + (sc, gname, sc->gensym_symbol, args, T_STRING)); + prefix = string_value(gname); + plen = safe_strlen(prefix); + } else { + prefix = "gensym"; + plen = 6; + } + len = plen + 32; /* why 32 -- we need room for the gensym_counter integer, but (length "9223372036854775807") = 19 */ + + b = mallocate(sc, len + sizeof(block_t) + 2 * sizeof(s7_cell)); + /* only 16 of block_t size is actually needed here because only the ln.tag (symbol_tag2) field is used in the embedded block_t */ + base = (char *) block_data(b); + str = (s7_cell *) base; + stc = (s7_cell *) (base + sizeof(s7_cell)); + ib = (block_t *) (base + 2 * sizeof(s7_cell)); + name = (char *) (base + sizeof(block_t) + 2 * sizeof(s7_cell)); + + name[0] = '{'; + if (plen > 0) + memcpy((void *) (name + 1), prefix, plen); + name[plen + 1] = '}'; + name[plen + 2] = '-'; /* {gensym}-nnn */ + + p = pos_int_to_str(sc, sc->gensym_counter++, &len, '\0'); + memcpy((void *) (name + plen + 3), (void *) p, len); + nlen = len + plen + 2; + if ((S7_DEBUGGING) && ((s7_int) strlen(name) != nlen)) + fprintf(stderr, "%s[%d]: %s len: %" ld64 " != %" ld64 "\n", + __func__, __LINE__, name, nlen, (s7_int) strlen(name)); + hash = raw_string_hash((const uint8_t *) name, nlen); + location = hash % SYMBOL_TABLE_SIZE; + + if ((WITH_WARNINGS) && + (!is_null + (symbol_table_find_by_name(sc, name, hash, location, nlen)))) + s7_warn(sc, nlen + 32, "%s is already in use!", name); + + /* make-string for symbol name */ + if (S7_DEBUGGING) + full_type(str) = 0; /* here and below, this is needed to avoid set_type check errors (mallocate above) */ + set_full_type(str, T_STRING | T_IMMUTABLE | T_UNHEAP); + string_length(str) = nlen; + string_value(str) = name; + string_hash(str) = hash; + + /* allocate the symbol in the heap so GC'd when inaccessible */ + new_cell(sc, x, T_SYMBOL | T_GENSYM); + symbol_set_name_cell(x, str); + symbol_info(x) = ib; + set_global_slot(x, sc->undefined); /* set_initial_slot(x, sc->undefined); */ + symbol_set_local_slot_unchecked(x, 0LL, sc->nil); + symbol_clear_ctr(x); + symbol_set_tag(x, 0); + symbol_set_tag2(x, 0); + symbol_clear_type(x); + symbol_set_position(x, PD_POSITION_UNSET); + gensym_block(x) = b; + + /* place new symbol in symbol-table */ + if (S7_DEBUGGING) + full_type(stc) = 0; + set_full_type(stc, T_PAIR | T_IMMUTABLE | T_UNHEAP); + set_car(stc, x); + set_cdr(stc, vector_element(sc->symbol_table, location)); + vector_element(sc->symbol_table, location) = stc; + pair_set_raw_hash(stc, hash); + pair_set_raw_len(stc, (uint64_t) string_length(str)); + pair_set_raw_name(stc, string_value(str)); + + add_gensym(sc, x); + return (x); +} + + +/* -------------------------------- syntax? -------------------------------- */ +bool s7_is_syntax(s7_pointer p) +{ + return (is_syntax(p)); +} + +static s7_pointer g_is_syntax(s7_scheme * sc, s7_pointer args) +{ +#define H_is_syntax "(syntax? obj) returns #t if obj is a syntactic value (e.g. lambda)" +#define Q_is_syntax sc->pl_bt + check_boolean_method(sc, is_syntax, sc->is_syntax_symbol, args); +} + + +/* -------------------------------- symbol? -------------------------------- */ +bool s7_is_symbol(s7_pointer p) +{ + return (is_symbol(p)); +} + +static s7_pointer g_is_symbol(s7_scheme * sc, s7_pointer args) +{ +#define H_is_symbol "(symbol? obj) returns #t if obj is a symbol" +#define Q_is_symbol sc->pl_bt + check_boolean_method(sc, is_symbol, sc->is_symbol_symbol, args); +} + +const char *s7_symbol_name(s7_pointer p) +{ + return (symbol_name(p)); +} + +s7_pointer s7_name_to_value(s7_scheme * sc, const char *name) +{ + return (s7_symbol_value(sc, make_symbol(sc, name))); +} + +/* should this also handle non-symbols such as "+nan.0"? */ + + +/* -------------------------------- symbol->string -------------------------------- */ +static Inline s7_pointer inline_make_string_with_length(s7_scheme * sc, + const char *str, + s7_int len) +{ + s7_pointer x; + new_cell(sc, x, T_STRING | T_SAFE_PROCEDURE); + string_block(x) = mallocate(sc, len + 1); + string_value(x) = (char *) block_data(string_block(x)); + if (len > 0) + memcpy((void *) string_value(x), (void *) str, len); + string_value(x)[len] = 0; + string_length(x) = len; + string_hash(x) = 0; + add_string(sc, x); + return (x); +} + +static inline s7_pointer make_string_with_length(s7_scheme * sc, + const char *str, + s7_int len) +{ + return (inline_make_string_with_length(sc, str, len)); +} + +static s7_pointer g_symbol_to_string(s7_scheme * sc, s7_pointer args) +{ +#define H_symbol_to_string "(symbol->string sym) returns the symbol sym converted to a string" +#define Q_symbol_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_symbol_symbol) + + s7_pointer sym = car(args); + if (!is_symbol(sym)) + return (method_or_bust_one_arg + (sc, sym, sc->symbol_to_string_symbol, args, T_SYMBOL)); + /* s7_make_string uses strlen which stops at an embedded null */ + return (inline_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); /* return a copy */ +} + +static s7_pointer g_symbol_to_string_uncopied(s7_scheme * sc, + s7_pointer args) +{ + s7_pointer sym = car(args); + if (!is_symbol(sym)) + return (method_or_bust_one_arg + (sc, sym, sc->symbol_to_string_symbol, args, T_SYMBOL)); + if (is_gensym(sym)) + return (make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); /* return a copy of gensym name (which will be freed) */ + return (symbol_name_cell(sym)); +} + +static s7_pointer symbol_to_string_p_p(s7_scheme * sc, s7_pointer sym) +{ + if (!is_symbol(sym)) + return (method_or_bust_one_arg + (sc, sym, sc->symbol_to_string_symbol, + set_plist_1(sc, sym), T_SYMBOL)); + return (inline_make_string_with_length + (sc, symbol_name(sym), symbol_name_length(sym))); +} + +static s7_pointer symbol_to_string_uncopied_p(s7_scheme * sc, + s7_pointer sym) +{ + if (!is_symbol(sym)) + return (method_or_bust_one_arg + (sc, sym, sc->symbol_to_string_symbol, + set_plist_1(sc, sym), T_SYMBOL)); + if (is_gensym(sym)) + return (make_string_with_length + (sc, symbol_name(sym), symbol_name_length(sym))); + return (symbol_name_cell(sym)); +} + + +/* -------------------------------- string->symbol -------------------------------- */ +static inline s7_pointer g_string_to_symbol_1(s7_scheme * sc, + s7_pointer str, + s7_pointer caller) +{ + if (!is_string(str)) + return (method_or_bust_one_arg_p(sc, str, caller, T_STRING)); + if (string_length(str) > 0) + return (make_symbol_with_length + (sc, string_value(str), string_length(str))); + return (simple_wrong_type_argument_with_type + (sc, caller, str, wrap_string(sc, "a non-null string", 17))); +} + +static s7_pointer g_string_to_symbol(s7_scheme * sc, s7_pointer args) +{ +#define H_string_to_symbol "(string->symbol str) returns the string str converted to a symbol" +#define Q_string_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_string_symbol) + return (g_string_to_symbol_1 + (sc, car(args), sc->string_to_symbol_symbol)); +} + +static s7_pointer string_to_symbol_p_p(s7_scheme * sc, s7_pointer p) +{ + return (g_string_to_symbol_1(sc, p, sc->string_to_symbol_symbol)); +} + + +/* -------------------------------- symbol -------------------------------- */ +static s7_pointer g_string_append_1(s7_scheme * sc, s7_pointer args, + s7_pointer caller); + +static s7_pointer g_symbol(s7_scheme * sc, s7_pointer args) +{ +#define H_symbol "(symbol str ...) returns its string arguments concatenated and converted to a symbol" +#define Q_symbol s7_make_circular_signature(sc, 1, 2, sc->is_symbol_symbol, sc->is_string_symbol) + + s7_int len = 0, cur_len; + s7_pointer p, sym; + block_t *b; + char *name; + + for (p = args; is_pair(p); p = cdr(p)) + if (is_string(car(p))) + len += string_length(car(p)); + else + break; + + if (is_pair(p)) { + if (is_null(cdr(args))) + return (g_string_to_symbol_1 + (sc, car(args), sc->symbol_symbol)); + return (g_string_to_symbol_1 + (sc, g_string_append_1(sc, args, sc->symbol_symbol), + sc->symbol_symbol)); + } + if (len == 0) + return (simple_wrong_type_argument_with_type + (sc, sc->symbol_symbol, car(args), + wrap_string(sc, "a non-null string", 17))); + + b = mallocate(sc, len + 1); + name = (char *) block_data(b); + /* can't use catstrs_direct here because it stops at embedded null */ + cur_len = 0; + for (p = args; is_pair(p); p = cdr(p)) { + s7_pointer str = car(p); + if (string_length(str) > 0) { + memcpy((void *) (name + cur_len), (void *) string_value(str), + string_length(str)); + cur_len += string_length(str); + } + } + name[len] = '\0'; + sym = make_symbol_with_length(sc, name, len); + liberate(sc, b); + return (sym); +} + +static s7_pointer symbol_p_pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + char buf[256]; + s7_int len; + if ((!is_string(p1)) || (!is_string(p2))) + return (g_symbol(sc, set_plist_2(sc, p1, p2))); + len = string_length(p1) + string_length(p2); + if ((len == 0) || (len >= 256)) + return (g_symbol(sc, set_plist_2(sc, p1, p2))); + memcpy((void *) buf, (void *) string_value(p1), string_length(p1)); + memcpy((void *) (buf + string_length(p1)), (void *) string_value(p2), + string_length(p2)); + return (make_symbol_with_length(sc, buf, len)); +} + + +/* -------- symbol sets -------- */ +static inline s7_pointer add_symbol_to_list(s7_scheme * sc, s7_pointer sym) +{ + symbol_set_tag(sym, sc->syms_tag); + symbol_set_tag2(sym, sc->syms_tag2); + return (sym); +} + +static inline void clear_symbol_list(s7_scheme * sc) +{ + sc->syms_tag++; + if (sc->syms_tag == 0) { + sc->syms_tag = 1; /* we're assuming (in let_equal) that this tag is not 0 */ + sc->syms_tag2++; + } +} + +#define symbol_is_in_list(Sc, Sym) ((symbol_tag(Sym) == Sc->syms_tag) && (symbol_tag2(Sym) == Sc->syms_tag2)) + + +/* -------------------------------- lets/slots -------------------------------- */ + +static Inline s7_pointer make_let(s7_scheme * sc, s7_pointer old_let) +{ + s7_pointer x; + new_cell(sc, x, T_LET | T_SAFE_PROCEDURE); + let_set_id(x, ++sc->let_number); + let_set_slots(x, slot_end(sc)); + let_set_outlet(x, old_let); + return (x); +} + +static inline s7_pointer make_let_slowly(s7_scheme * sc, + s7_pointer old_let) +{ + s7_pointer x; + new_cell(sc, x, T_LET | T_SAFE_PROCEDURE); + let_set_id(x, ++sc->let_number); + let_set_slots(x, slot_end(sc)); + let_set_outlet(x, old_let); + return (x); +} + +static inline s7_pointer make_simple_let(s7_scheme * sc) +{ /* called only in op_let_fx */ + s7_pointer let; + new_cell(sc, let, T_LET | T_SAFE_PROCEDURE); + let_set_id(let, sc->let_number + 1); + let_set_slots(let, slot_end(sc)); + let_set_outlet(let, sc->curlet); + return (let); +} + +static Inline s7_pointer make_let_with_slot(s7_scheme * sc, + s7_pointer old_let, + s7_pointer symbol, + s7_pointer value) +{ + s7_pointer new_let, slot; + new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE); + let_set_id(new_let, ++sc->let_number); + let_set_outlet(new_let, old_let); + new_cell_no_check(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + symbol_set_local_slot(symbol, sc->let_number, slot); + slot_set_next(slot, slot_end(sc)); + let_set_slots(new_let, slot); + return (new_let); +} + +static Inline s7_pointer make_let_with_two_slots(s7_scheme * sc, + s7_pointer old_let, + s7_pointer symbol1, + s7_pointer value1, + s7_pointer symbol2, + s7_pointer value2) +{ + /* we leave value1/value2 computation order to the C compiler here -- in the old macro, it was explicitly value1 then value2 + * this means any let in old scheme code that actually depends on the order may break -- it should be let*. + */ + s7_pointer new_let, slot1, slot2; + new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE); + let_set_id(new_let, ++sc->let_number); + let_set_outlet(new_let, old_let); + + new_cell_no_check(sc, slot1, T_SLOT); + slot_set_symbol_and_value(slot1, symbol1, value1); + symbol_set_local_slot(symbol1, sc->let_number, slot1); + let_set_slots(new_let, slot1); + + new_cell_no_check(sc, slot2, T_SLOT); + slot_set_symbol_and_value(slot2, symbol2, value2); + symbol_set_local_slot(symbol2, sc->let_number, slot2); + slot_set_next(slot2, slot_end(sc)); + slot_set_next(slot1, slot2); + return (new_let); +} + +/* in all these functions, symbol_set_local_slot should follow slot_set_value so that we can evaluate the slot's value in its old state. */ +static inline void add_slot_unchecked(s7_scheme * sc, s7_pointer let, + s7_pointer symbol, s7_pointer value, + uint64_t id) +{ + s7_pointer slot; + new_cell_no_check(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + slot_set_next(slot, let_slots(let)); + let_set_slots(let, slot); + set_local(symbol); + symbol_set_local_slot(symbol, id, slot); +} + +#define add_slot(Sc, Let, Symbol, Value) add_slot_unchecked(Sc, Let, Symbol, Value, let_id(Let)) + +static inline s7_pointer add_slot_checked(s7_scheme * sc, s7_pointer let, + s7_pointer symbol, + s7_pointer value) +{ + s7_pointer slot; + new_cell(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + symbol_set_local_slot(symbol, let_id(let), slot); + slot_set_next(slot, let_slots(let)); + let_set_slots(let, slot); + return (slot); +} + +static inline s7_pointer add_slot_checked_with_id(s7_scheme * sc, + s7_pointer let, + s7_pointer symbol, + s7_pointer value) +{ + s7_pointer slot; + new_cell(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + set_local(symbol); + if (let_id(let) >= symbol_id(symbol)) + symbol_set_local_slot(symbol, let_id(let), slot); + slot_set_next(slot, let_slots(let)); + let_set_slots(let, slot); + return (slot); +} + +static s7_pointer add_slot_unchecked_with_id(s7_scheme * sc, + s7_pointer let, + s7_pointer symbol, + s7_pointer value) +{ + s7_pointer slot; + new_cell_no_check(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + set_local(symbol); + if (let_id(let) >= symbol_id(symbol)) + symbol_set_local_slot(symbol, let_id(let), slot); + slot_set_next(slot, let_slots(let)); + let_set_slots(let, slot); + return (slot); +} + +static Inline s7_pointer add_slot_at_end(s7_scheme * sc, uint64_t id, + s7_pointer last_slot, + s7_pointer symbol, + s7_pointer value) +{ + s7_pointer slot; + new_cell_no_check(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + slot_set_next(slot, slot_end(sc)); + symbol_set_local_slot(symbol, id, slot); + slot_set_next(last_slot, slot); + return (slot); +} + +static inline void make_let_with_three_slots(s7_scheme * sc, + s7_pointer func, + s7_pointer val1, + s7_pointer val2, + s7_pointer val3) +{ + s7_pointer last_slot, cargs = closure_args(func); + sc->curlet = + make_let_with_two_slots(sc, closure_let(func), car(cargs), val1, + cadr(cargs), val2); + last_slot = next_slot(let_slots(sc->curlet)); + add_slot_at_end(sc, let_id(sc->curlet), last_slot, caddr(cargs), val3); +} + +static inline void make_let_with_four_slots(s7_scheme * sc, + s7_pointer func, + s7_pointer val1, + s7_pointer val2, + s7_pointer val3, + s7_pointer val4) +{ + s7_pointer last_slot, cargs = closure_args(func); + sc->curlet = + make_let_with_two_slots(sc, closure_let(func), car(cargs), val1, + cadr(cargs), val2); + cargs = cddr(cargs); + last_slot = next_slot(let_slots(sc->curlet)); + last_slot = + add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(cargs), + val3); + add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadr(cargs), val4); +} + +static s7_pointer reuse_as_let(s7_scheme * sc, s7_pointer let, + s7_pointer next_let) +{ + /* we're reusing let here as a let -- it was probably a pair */ +#if S7_DEBUGGING + let->debugger_bits = 0; + if (!in_heap(let)) + fprintf(stderr, "reusing an unheaped let?\n"); +#endif + set_full_type(let, T_LET | T_SAFE_PROCEDURE); + let_set_slots(let, slot_end(sc)); + let_set_outlet(let, next_let); + let_set_id(let, ++sc->let_number); + return (let); +} + +static s7_pointer reuse_as_slot(s7_scheme * sc, s7_pointer slot, + s7_pointer symbol, s7_pointer value) +{ +#if S7_DEBUGGING + slot->debugger_bits = 0; + if (!in_heap(slot)) + fprintf(stderr, "reusing a permanent cell?\n"); + if (is_multiple_value(value)) { + fprintf(stderr, "%s%s[%d]: multiple-value %s %s%s\n", BOLD_TEXT, + __func__, __LINE__, display(value), display(sc->code), + UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } +#endif + set_full_type(slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + return (slot); +} + +#define update_slot(Slot, Val, Id) do {s7_pointer sym; slot_set_value(Slot, Val); sym = slot_symbol(Slot); symbol_set_local_slot_unincremented(sym, Id, Slot);} while (0) + +static s7_pointer update_let_with_slot(s7_scheme * sc, s7_pointer let, + s7_pointer val) +{ + s7_pointer slot = let_slots(let); + uint64_t id; + id = ++sc->let_number; + let_set_id(let, id); + update_slot(slot, val, id); + return (let); +} + +static s7_pointer update_let_with_two_slots(s7_scheme * sc, s7_pointer let, + s7_pointer val1, + s7_pointer val2) +{ + s7_pointer slot = let_slots(let); + uint64_t id; + id = ++sc->let_number; + let_set_id(let, id); + update_slot(slot, val1, id); + slot = next_slot(slot); + update_slot(slot, val2, id); + return (let); +} + +static s7_pointer update_let_with_three_slots(s7_scheme * sc, + s7_pointer let, + s7_pointer val1, + s7_pointer val2, + s7_pointer val3) +{ + s7_pointer slot = let_slots(let); + uint64_t id; + id = ++sc->let_number; + let_set_id(let, id); + update_slot(slot, val1, id); + slot = next_slot(slot); + update_slot(slot, val2, id); + slot = next_slot(slot); + update_slot(slot, val3, id); + return (let); +} + +static s7_pointer update_let_with_four_slots(s7_scheme * sc, + s7_pointer let, + s7_pointer val1, + s7_pointer val2, + s7_pointer val3, + s7_pointer val4) +{ + s7_pointer slot = let_slots(let); + uint64_t id; + id = ++sc->let_number; + let_set_id(let, id); + update_slot(slot, val1, id); + slot = next_slot(slot); + update_slot(slot, val2, id); + slot = next_slot(slot); + update_slot(slot, val3, id); + slot = next_slot(slot); + update_slot(slot, val4, id); + return (let); +} + +static s7_pointer make_permanent_slot(s7_scheme * sc, s7_pointer symbol, + s7_pointer value) +{ + s7_pointer slot; + slot = alloc_pointer(sc); + set_full_type(slot, T_SLOT | T_UNHEAP); + slot_set_symbol_and_value(slot, symbol, value); + return (slot); +} + +static s7_pointer make_permanent_let(s7_scheme * sc, s7_pointer vars) +{ + s7_pointer let, var, slot; + let = alloc_pointer(sc); + + set_full_type(let, T_LET | T_SAFE_PROCEDURE | T_UNHEAP); + let_set_id(let, ++sc->let_number); + let_set_outlet(let, sc->curlet); + slot = make_permanent_slot(sc, caar(vars), sc->F); + add_permanent_let_or_slot(sc, slot); + symbol_set_local_slot(caar(vars), sc->let_number, slot); + let_set_slots(let, slot); + for (var = cdr(vars); is_pair(var); var = cdr(var)) { + s7_pointer last_slot; + last_slot = slot; + slot = make_permanent_slot(sc, caar(var), sc->F); + add_permanent_let_or_slot(sc, slot); + symbol_set_local_slot(caar(var), sc->let_number, slot); + slot_set_next(last_slot, slot); + } + slot_set_next(slot, slot_end(sc)); + add_permanent_let_or_slot(sc, let); /* need to mark outlet and maybe slot values */ + return (let); +} + +static s7_pointer find_let(s7_scheme * sc, s7_pointer obj) +{ + if (is_let(obj)) + return (obj); + switch (type(obj)) { + case T_MACRO: + case T_MACRO_STAR: + case T_BACRO: + case T_BACRO_STAR: + case T_CLOSURE: + case T_CLOSURE_STAR: + return (closure_let(obj)); + + case T_C_OBJECT: + return (c_object_let(obj)); + + case T_C_POINTER: + if ((is_let(c_pointer_info(obj))) && + (c_pointer_info(obj) != sc->rootlet)) + return (c_pointer_info(obj)); + } + return (sc->nil); +} + +static s7_pointer call_setter(s7_scheme * sc, s7_pointer slot, + s7_pointer old_value); + +static inline s7_pointer checked_slot_set_value(s7_scheme * sc, + s7_pointer y, + s7_pointer value) +{ + if (slot_has_setter(y)) + slot_set_value(y, call_setter(sc, y, value)); + else { + if (is_immutable_slot(y)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->let_set_symbol, slot_symbol(y)))); + slot_set_value(y, value); + } + return (slot_value(y)); +} + +static s7_pointer let_fill(s7_scheme * sc, s7_pointer args) +{ + s7_pointer e = car(args), val, p; + if ((e == sc->rootlet) || (e == sc->s7_let)) + eval_error(sc, "attempt to fill! ~S?", 20, e); + if (e == sc->owlet) /* (owlet) copies sc->owlet, so this probably can't happen */ + return (out_of_range + (sc, sc->fill_symbol, int_one, e, + wrap_string(sc, "can't fill! owlet", 17))); + if (is_funclet(e)) + return (out_of_range + (sc, sc->fill_symbol, int_one, e, + wrap_string(sc, "can't fill! a funclet", 21))); + val = cadr(args); + for (p = let_slots(e); tis_slot(p); p = next_slot(p)) + checked_slot_set_value(sc, p, val); + return (val); +} + +static s7_pointer find_method(s7_scheme * sc, s7_pointer let, + s7_pointer symbol) +{ + s7_pointer slot; + if (symbol_id(symbol) == 0) /* this means the symbol has never been used locally, so how can it be a method? */ + return (sc->undefined); + slot = lookup_slot_from(symbol, let); + if (slot != global_slot(symbol)) + return (slot_value(slot)); + return (sc->undefined); +} + +static s7_pointer find_method_with_let(s7_scheme * sc, s7_pointer let, + s7_pointer symbol) +{ + return (find_method(sc, find_let(sc, let), symbol)); +} + +static s7_int s7_let_length(void); + +static s7_int let_length(s7_scheme * sc, s7_pointer e) +{ + /* used by length, applicable_length, copy, and some length optimizations */ + s7_int i; + s7_pointer p; + + if (e == sc->rootlet) + return (sc->rootlet_entries); + if (e == sc->s7_let) + return (s7_let_length()); + + if (has_active_methods(sc, e)) { + s7_pointer length_func; + length_func = find_method(sc, e, sc->length_symbol); + if (length_func != sc->undefined) { + p = call_method(sc, e, length_func, set_plist_1(sc, e)); + return ((s7_is_integer(p)) ? s7_integer_checked(sc, p) : -1); /* ?? */ + } + } + for (i = 0, p = let_slots(e); tis_slot(p); i++, p = next_slot(p)); + return (i); +} + + +static void slot_set_setter(s7_pointer p, s7_pointer val) +{ + if ((type(val) == T_C_FUNCTION) && (c_function_has_bool_setter(val))) + slot_set_setter_1(p, c_function_bool_setter(val)); + else + slot_set_setter_1(p, val); +} + +static void slot_set_value_with_hook_1(s7_scheme * sc, s7_pointer slot, + s7_pointer value) +{ + /* (set! (hook-functions *rootlet-redefinition-hook*) (list (lambda (hook) (format *stderr* "~A ~A~%" (hook 'symbol) (hook 'value))))) */ + s7_pointer symbol = slot_symbol(slot); + if ((global_slot(symbol) == slot) && (value != slot_value(slot))) + s7_call(sc, sc->rootlet_redefinition_hook, + set_elist_2(sc, symbol, value)); + slot_set_value(slot, value); +} + +static void remove_function_from_heap(s7_scheme * sc, s7_pointer value); + +static void remove_let_from_heap(s7_scheme * sc, s7_pointer lt) +{ + s7_pointer p; + for (p = let_slots(lt); tis_slot(p); p = next_slot(p)) { + s7_pointer val = slot_value(p); + if ((has_closure_let(val)) && (in_heap(closure_args(val)))) + remove_function_from_heap(sc, val); + } + let_set_removed(lt); +} + +static void add_slot_to_rootlet(s7_scheme * sc, s7_pointer slot) +{ + s7_pointer ge; + ge = sc->rootlet; + rootlet_element(ge, sc->rootlet_entries++) = slot; + set_in_rootlet(slot); + if (sc->rootlet_entries >= vector_length(ge)) { + s7_int i, len; + block_t *ob, *nb; + vector_length(ge) *= 2; + len = vector_length(ge); + ob = rootlet_block(ge); + nb = reallocate(sc, ob, len * sizeof(s7_pointer)); + block_info(nb) = NULL; + rootlet_block(ge) = nb; + rootlet_elements(ge) = (s7_pointer *) block_data(nb); + for (i = sc->rootlet_entries; i < len; i++) + rootlet_element(ge, i) = sc->nil; + } +} + +static void remove_function_from_heap(s7_scheme * sc, s7_pointer value) +{ + s7_pointer lt; + s7_remove_from_heap(sc, closure_args(value)); + s7_remove_from_heap(sc, closure_body(value)); + /* remove closure if it's local to current func (meaning (define f (let ...) (lambda ...)) removes the enclosing let) */ + lt = closure_let(value); /* closure_let and all its outlets can't be rootlet */ + if ((is_let(lt)) && (!let_removed(lt)) && (lt != sc->shadow_rootlet)) { + lt = let_outlet(lt); + if ((is_let(lt)) && (!let_removed(lt)) + && (lt != sc->shadow_rootlet)) { + remove_let_from_heap(sc, lt); + lt = let_outlet(lt); + if ((is_let(lt)) && (!let_removed(lt)) + && (lt != sc->shadow_rootlet)) + remove_let_from_heap(sc, lt); + } + } +} + +s7_pointer s7_make_slot(s7_scheme * sc, s7_pointer let, s7_pointer symbol, + s7_pointer value) +{ + if ((!is_let(let)) || (let == sc->rootlet)) { + s7_pointer slot; + if (is_immutable(sc->rootlet)) + return (immutable_object_error + (sc, + set_elist_2(sc, + wrap_string(sc, + "can't define '~S; rootlet is immutable", + 38), symbol))); + if ((sc->safety == NO_SAFETY) && (has_closure_let(value))) + remove_function_from_heap(sc, value); + + /* first look for existing slot -- this is not always checked before calling s7_make_slot */ + if (is_slot(global_slot(symbol))) { + slot = global_slot(symbol); + symbol_increment_ctr(symbol); + slot_set_value_with_hook(slot, value); + return (slot); + } + + slot = make_permanent_slot(sc, symbol, value); + add_slot_to_rootlet(sc, slot); + set_global_slot(symbol, slot); + + if (symbol_id(symbol) == 0) { /* never defined locally? */ + if ((!is_gensym(symbol)) && (initial_slot(symbol) == sc->undefined) && (!in_heap(value)) && /* else initial_slot value can be GC'd if symbol set! (initial != global, initial unprotected) */ + ((!sc->unlet) || /* init_unlet creates sc->unlet, after that initial_slot is for c_functions?? */ + (is_c_function(value)))) + set_initial_slot(symbol, + make_permanent_slot(sc, symbol, value)); + set_local_slot(symbol, slot); + set_global(symbol); + } + symbol_increment_ctr(symbol); + if (is_gensym(symbol)) + s7_remove_from_heap(sc, symbol); + return (slot); + } + return (add_slot_checked_with_id(sc, let, symbol, value)); + /* there are about as many lets as local variables -- this strikes me as surprising, but it holds up across a lot of code. */ +} + +static s7_pointer make_slot(s7_scheme * sc, s7_pointer variable, + s7_pointer value) +{ + s7_pointer y; + new_cell(sc, y, T_SLOT); + slot_set_symbol_and_value(y, variable, value); + return (y); +} + + +/* -------------------------------- let? -------------------------------- */ +bool s7_is_let(s7_pointer e) +{ + return (is_let(e)); +} + +static s7_pointer g_is_let(s7_scheme * sc, s7_pointer args) +{ +#define H_is_let "(let? obj) returns #t if obj is a let." +#define Q_is_let sc->pl_bt + check_boolean_method(sc, is_let, sc->is_let_symbol, args); +} + + +/* -------------------------------- funclet? -------------------------------- */ +static s7_pointer g_is_funclet(s7_scheme * sc, s7_pointer args) +{ +#define H_is_funclet "(funclet? obj) returns #t if obj is a funclet (a function's environment)." +#define Q_is_funclet sc->pl_bt + + s7_pointer lt = car(args); + if ((is_let(lt)) && ((is_funclet(lt)) || (is_maclet(lt)))) + return (sc->T); + if (!has_active_methods(sc, lt)) + return (sc->F); + return (apply_boolean_method(sc, lt, sc->is_funclet_symbol)); +} + + +/* -------------------------------- unlet -------------------------------- */ +static s7_pointer default_vector_setter(s7_scheme * sc, s7_pointer vec, + s7_int loc, s7_pointer val); +static s7_pointer default_vector_getter(s7_scheme * sc, s7_pointer vec, + s7_int loc); + +#define UNLET_ENTRIES 512 /* 397 if not --disable-deprecated etc */ + +static void init_unlet(s7_scheme * sc) +{ + int32_t i, k = 0; + s7_pointer x; + s7_pointer *inits, *els; + block_t *block; + + sc->unlet = (s7_pointer) Calloc(1, sizeof(s7_cell)); + set_full_type(sc->unlet, T_VECTOR | T_UNHEAP); + vector_length(sc->unlet) = UNLET_ENTRIES; + block = mallocate(sc, UNLET_ENTRIES * sizeof(s7_pointer)); + vector_block(sc->unlet) = block; + vector_elements(sc->unlet) = (s7_pointer *) block_data(block); + vector_set_dimension_info(sc->unlet, NULL); + vector_getter(sc->unlet) = default_vector_getter; + vector_setter(sc->unlet) = default_vector_setter; + inits = vector_elements(sc->unlet); + s7_vector_fill(sc, sc->unlet, sc->nil); + els = vector_elements(sc->symbol_table); + + inits[k++] = initial_slot(sc->else_symbol); + for (i = 0; i < SYMBOL_TABLE_SIZE; i++) + for (x = els[i]; is_not_null(x); x = cdr(x)) { + s7_pointer sym = car(x); + if ((!is_gensym(sym)) && (is_slot(initial_slot(sym)))) { + s7_pointer val = initial_value(sym); + if ((is_c_function(val)) || (is_syntax(val))) /* we assume the initial_slot value needs no GC protection */ + inits[k++] = initial_slot(sym); + + /* non-c_functions that are not set! (and therefore initial_slot GC) protected by default: + * make-hook hook-functions + * if these initial_slot values are added to unlet, they need explicit GC protection. + */ + if ((S7_DEBUGGING) && (k >= UNLET_ENTRIES)) + fprintf(stderr, "unlet overflow\n"); + } + } +} + +static s7_pointer g_unlet(s7_scheme * sc, s7_pointer args) +{ + /* add sc->unlet bindings to the current environment */ +#define H_unlet "(unlet) returns a let that establishes the original bindings of all the predefined functions" +#define Q_unlet s7_make_signature(sc, 1, sc->is_let_symbol) + + /* slightly confusing: + * ((unlet) 'abs) -> # + * (defined? 'abs (unlet)) -> #t + * this is because unlet sets up a local environment of unshadowed symbols, and s7_let_ref only looks at the local env chain + * (that is, if env is not the global env, then the global env is not searched). + */ + int32_t i; + s7_pointer *inits; + s7_pointer x; + + sc->w = make_let_slowly(sc, sc->curlet); + inits = vector_elements(sc->unlet); + for (i = 0; (i < UNLET_ENTRIES) && (is_slot(inits[i])); i++) { + s7_pointer sym; + x = slot_value(inits[i]); + sym = slot_symbol(inits[i]); + if ((x != global_value(sym)) || /* it has been changed globally */ + ((!is_global(sym)) && /* it might be shadowed locally */ + (s7_symbol_local_value(sc, sym, sc->curlet) != + global_value(sym)))) + add_slot_checked_with_id(sc, sc->w, sym, x); + } + /* if (set! + -) then + needs to be overridden, but the local bit isn't set, so we have to check the actual values in the non-local case. + * (define (f x) (with-let (unlet) (+ x 1))) + */ + x = sc->w; + sc->w = sc->nil; + return (x); +} + + +/* -------------------------------- openlet? -------------------------------- */ +bool s7_is_openlet(s7_pointer e) +{ + return (has_methods(e)); +} + +static s7_pointer g_is_openlet(s7_scheme * sc, s7_pointer args) +{ +#define H_is_openlet "(openlet? obj) returns #t is 'obj' has methods." +#define Q_is_openlet sc->pl_bt + + s7_pointer e = car(args); /* if e is not a let, should this raise an error? -- no, easier to use this way in cond */ + check_method(sc, e, sc->is_openlet_symbol, args); + return (make_boolean(sc, has_methods(e))); +} + + +/* -------------------------------- openlet -------------------------------- */ +s7_pointer s7_openlet(s7_scheme * sc, s7_pointer e) +{ + set_has_methods(e); + return (e); +} + +static s7_pointer g_openlet(s7_scheme * sc, s7_pointer args) +{ +#define H_openlet "(openlet e) tells the built-in generic functions that the let 'e might have an over-riding method." +#define Q_openlet sc->pcl_e + + s7_pointer e = car(args), elet, func; + if ((e == sc->rootlet) || (e == sc->nil)) + s7_error(sc, sc->out_of_range_symbol, + set_elist_1(sc, + wrap_string(sc, "can't openlet rootlet", + 21))); + elet = find_let(sc, e); /* returns nil if no let found, so has to follow error check above */ + if (!is_let(elet)) + return (simple_wrong_type_argument_with_type + (sc, sc->openlet_symbol, e, a_let_string)); + + if ((has_active_methods(sc, e)) && + ((func = + find_method(sc, elet, sc->openlet_symbol)) != sc->undefined)) + return (call_method(sc, e, func, args)); + + set_has_methods(e); + return (e); +} + +/* -------------------------------- coverlet -------------------------------- */ +static s7_pointer g_coverlet(s7_scheme * sc, s7_pointer args) +{ +#define H_coverlet "(coverlet e) undoes an earlier openlet." +#define Q_coverlet sc->pcl_e + + s7_pointer e = car(args); + sc->temp3 = e; + check_method(sc, e, sc->coverlet_symbol, set_plist_1(sc, e)); + sc->temp3 = sc->nil; + if ((e == sc->rootlet) || (e == sc->s7_let)) + s7_error(sc, sc->out_of_range_symbol, + set_elist_2(sc, wrap_string(sc, "can't coverlet ~S", 17), + e)); + + if ((is_let(e)) || + (has_closure_let(e)) || + ((is_c_object(e)) && (c_object_let(e) != sc->nil)) || + ((is_c_pointer(e)) && (is_let(c_pointer_info(e))))) { + clear_has_methods(e); + return (e); + } + return (simple_wrong_type_argument_with_type + (sc, sc->coverlet_symbol, e, a_let_string)); +} + + +/* -------------------------------- varlet -------------------------------- */ +static void append_let(s7_scheme * sc, s7_pointer new_e, s7_pointer old_e) +{ + s7_pointer x; + + if ((old_e == sc->rootlet) || (new_e == sc->s7_let)) + return; + + if (new_e == sc->rootlet) + for (x = let_slots(old_e); tis_slot(x); x = next_slot(x)) { + s7_pointer sym = slot_symbol(x), val = slot_value(x); + if (is_slot(global_slot(sym))) + slot_set_value(global_slot(sym), val); + else + s7_make_slot(sc, new_e, sym, val); + } else if (old_e == sc->s7_let) { + s7_pointer iter, carrier; + s7_int gc_loc; + iter = s7_make_iterator(sc, sc->s7_let); + gc_loc = s7_gc_protect(sc, iter); + carrier = cons_unchecked(sc, sc->F, sc->F); + iterator_current(iter) = carrier; + set_mark_seq(iter); /* so carrier is GC protected by mark_iterator */ + while (true) { + s7_pointer y; + y = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) + break; + add_slot_checked_with_id(sc, new_e, car(y), cdr(y)); + } + s7_gc_unprotect_at(sc, gc_loc); + } else + for (x = let_slots(old_e); tis_slot(x); x = next_slot(x)) + add_slot_checked_with_id(sc, new_e, slot_symbol(x), slot_value(x)); /* not add_slot here because we might run off the free heap end */ +} + +static s7_pointer check_c_object_let(s7_scheme * sc, s7_pointer old_e, + s7_pointer caller) +{ + if (is_c_object(old_e)) + old_e = c_object_let(old_e); + if (!is_let(old_e)) + return (simple_wrong_type_argument_with_type + (sc, caller, old_e, a_let_string)); + return (old_e); +} + +s7_pointer s7_varlet(s7_scheme * sc, s7_pointer let, s7_pointer symbol, + s7_pointer value) +{ + if (!is_let(let)) + return (wrong_type_argument_with_type + (sc, sc->varlet_symbol, 1, let, a_let_string)); + + if (!is_symbol(symbol)) + return (wrong_type_argument_with_type + (sc, sc->varlet_symbol, 2, symbol, a_symbol_string)); + + if ((is_slot(global_slot(symbol))) && + (is_syntax(global_value(symbol)))) + return (wrong_type_argument_with_type + (sc, sc->varlet_symbol, 2, symbol, + wrap_string(sc, "a non-syntactic name", 20))); + + if (let == sc->rootlet) { + if (is_slot(global_slot(symbol))) + slot_set_value(global_slot(symbol), value); + else + s7_make_slot(sc, let, symbol, value); + } else + add_slot_checked_with_id(sc, let, symbol, value); + return (value); +} + +static s7_pointer g_varlet(s7_scheme * sc, s7_pointer args) +{ +#define H_varlet "(varlet let ...) adds its arguments (a let, a cons: symbol . value, or two arguments, the symbol and its value) \ +to the let let, and returns let. (varlet (curlet) 'a 1) adds 'a to the current environment with the value 1." +#define Q_varlet s7_make_circular_signature(sc, 2, 4, sc->is_let_symbol, \ + s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), \ + s7_make_signature(sc, 3, sc->is_pair_symbol, sc->is_symbol_symbol, sc->is_let_symbol), \ + sc->T) + /* varlet = with-let + define */ + s7_pointer x, e = car(args), val; + + if (is_null(e)) + e = sc->rootlet; + else { + check_method(sc, e, sc->varlet_symbol, args); + if (!is_let(e)) + return (wrong_type_argument_with_type + (sc, sc->varlet_symbol, 1, e, a_let_string)); + if ((is_immutable(e)) || (e == sc->s7_let)) + return (s7_error + (sc, sc->immutable_error_symbol, + set_elist_3(sc, + wrap_string(sc, + "can't (varlet ~{~S~^ ~}), ~S is immutable", + 41), args, e))); + } + for (x = cdr(args); is_pair(x); x = cdr(x)) { + s7_pointer sym, p = car(x); + switch (type(p)) { + case T_SYMBOL: + sym = (is_keyword(p)) ? keyword_symbol(p) : p; + if (!is_pair(cdr(x))) + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, value_is_missing_string, + sc->varlet_symbol, car(x))); + if (is_constant_symbol(sc, sym)) + return (wrong_type_argument_with_type + (sc, sc->varlet_symbol, position_of(x, args), sym, + a_non_constant_symbol_string)); + x = cdr(x); + val = car(x); + break; + + case T_PAIR: + sym = car(p); + if (!is_symbol(sym)) + return (wrong_type_argument_with_type + (sc, sc->varlet_symbol, position_of(x, args), p, + a_symbol_string)); + if (is_constant_symbol(sc, sym)) + return (wrong_type_argument_with_type + (sc, sc->varlet_symbol, position_of(x, args), sym, + a_non_constant_symbol_string)); + val = cdr(p); + break; + + case T_LET: + append_let(sc, e, + check_c_object_let(sc, p, sc->varlet_symbol)); + continue; + + default: + return (wrong_type_argument_with_type + (sc, sc->varlet_symbol, position_of(x, args), p, + a_symbol_string)); + } + + if (e == sc->rootlet) { + if (is_slot(global_slot(sym))) { + if (is_syntax(global_value(sym))) + return (wrong_type_argument_with_type + (sc, sc->varlet_symbol, position_of(x, args), + p, wrap_string(sc, "a non-syntactic keyword", + 23))); + /* without this check we can end up turning our code into gibberish: + * (set! quote 1) -> ;can't set! quote + * (varlet (rootlet) '(quote . 1)), :quote -> 1 + * or worse set quote to a function of one arg that tries to quote something -- infinite loop + */ + slot_set_value_with_hook(global_slot(sym), val); + } else + s7_make_slot(sc, e, sym, val); + } else { + if ((has_let_fallback(e)) && + ((sym == sc->let_ref_fallback_symbol) + || (sym == sc->let_set_fallback_symbol))) + return (s7_error + (sc, sc->out_of_range_symbol, + set_elist_2(sc, + wrap_string(sc, + "varlet can't shadow ~S", + 22), sym))); + + add_slot_checked_with_id(sc, e, sym, val); + } + } + /* this used to check for sym already defined, and set its value, but that greatly slows down + * the most common use (adding a slot), and makes it hard to shadow explicitly. Don't use + * varlet as a substitute for set!/let-set!. + */ + return (e); +} + + +/* -------------------------------- cutlet -------------------------------- */ +static s7_pointer g_cutlet(s7_scheme * sc, s7_pointer args) +{ +#define H_cutlet "(cutlet e symbol ...) removes symbols from the let e." +#define Q_cutlet s7_make_circular_signature(sc, 2, 3, sc->is_let_symbol, sc->is_let_symbol, sc->is_symbol_symbol) + + s7_pointer e = car(args), syms; + s7_int the_un_id; + if (is_null(e)) + e = sc->rootlet; + else { + check_method(sc, e, sc->cutlet_symbol, args); + if (!is_let(e)) + return (wrong_type_argument_with_type + (sc, sc->cutlet_symbol, 1, e, a_let_string)); + if ((is_immutable(e)) || (e == sc->s7_let)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->cutlet_symbol, e))); + } + /* besides removing the slot we have to make sure the symbol_id does not match else + * let-ref and others will use the old slot! What's the un-id? Perhaps the next one? + * (let ((b 1)) (let ((b 2)) (cutlet (curlet) 'b)) b) + */ + the_un_id = ++sc->let_number; + + for (syms = cdr(args); is_pair(syms); syms = cdr(syms)) { + s7_pointer sym = car(syms), slot; + + if (!is_symbol(sym)) + return (wrong_type_argument_with_type + (sc, sc->cutlet_symbol, position_of(syms, args), sym, + a_symbol_string)); + + if (is_keyword(sym)) + sym = keyword_symbol(sym); + + if (e == sc->rootlet) { + if (is_slot(global_slot(sym))) { + symbol_set_id(sym, the_un_id); + slot_set_value(global_slot(sym), sc->undefined); + } + } else { + if ((has_let_fallback(e)) && + ((sym == sc->let_ref_fallback_symbol) + || (sym == sc->let_set_fallback_symbol))) + return (s7_error + (sc, sc->out_of_range_symbol, + set_elist_2(sc, + wrap_string(sc, + "cutlet can't remove ~S", + 22), sym))); + + slot = let_slots(e); + if (tis_slot(slot)) { + if (slot_symbol(slot) == sym) { + let_set_slots(e, next_slot(let_slots(e))); + symbol_set_id(sym, the_un_id); + } else { + s7_pointer last_slot = slot; + for (slot = next_slot(let_slots(e)); tis_slot(slot); + last_slot = slot, slot = next_slot(slot)) + if (slot_symbol(slot) == sym) { + symbol_set_id(sym, the_un_id); + slot_set_next(last_slot, next_slot(slot)); + break; + } + } + } + } + } + return (e); +} + + +/* -------------------------------- sublet -------------------------------- */ +static s7_pointer sublet_1(s7_scheme * sc, s7_pointer e, + s7_pointer bindings, s7_pointer caller) +{ + s7_pointer new_e; + new_e = + (e == sc->rootlet) ? make_let_slowly(sc, + sc->nil) : make_let_slowly(sc, + e); + set_all_methods(new_e, e); + + if (!is_null(bindings)) { + s7_pointer x; + sc->temp3 = new_e; + for (x = bindings; is_pair(x); x = cdr(x)) { + s7_pointer p = car(x), sym, val; + + switch (type(p)) { + /* should this insist on one style of field arg? i.e. (cons sym val) throughout, or :sym val etc? */ + case T_SYMBOL: + sym = (is_keyword(p)) ? keyword_symbol(p) : p; + if (!is_pair(cdr(x))) + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, value_is_missing_string, + caller, car(x))); + x = cdr(x); + val = car(x); + break; + + case T_PAIR: + sym = car(p); + if (!is_symbol(sym)) + return (wrong_type_argument_with_type + (sc, caller, 1 + position_of(x, bindings), p, + a_symbol_string)); + if (is_keyword(sym)) + sym = keyword_symbol(sym); + val = cdr(p); + break; + + case T_LET: + append_let(sc, new_e, check_c_object_let(sc, p, caller)); + continue; + + default: + return (wrong_type_argument_with_type + (sc, caller, 1 + position_of(x, bindings), p, + a_symbol_string)); + } + + if (is_constant_symbol(sc, sym)) + return (wrong_type_argument_with_type + (sc, caller, 1 + position_of(x, bindings), sym, + a_non_constant_symbol_string)); + if ((is_slot(global_slot(sym))) + && (is_syntax(global_value(sym)))) + return (wrong_type_argument_with_type + (sc, caller, 2, sym, + wrap_string(sc, "a non-syntactic name", 20))); + + /* here we know new_e is a let and is not rootlet */ + add_slot_checked_with_id(sc, new_e, sym, val); /* add_slot without let_id check or is it set_local will not work here */ + if (sym == sc->let_ref_fallback_symbol) + set_has_let_ref_fallback(new_e); + else if (sym == sc->let_set_fallback_symbol) + set_has_let_set_fallback(new_e); + } + sc->temp3 = sc->nil; + } + return (new_e); +} + +s7_pointer s7_sublet(s7_scheme * sc, s7_pointer e, s7_pointer bindings) +{ + return (sublet_1(sc, e, bindings, sc->sublet_symbol)); +} + +static s7_pointer g_sublet(s7_scheme * sc, s7_pointer args) +{ +#define H_sublet "(sublet let ...) adds its arguments (each a let or a cons: '(symbol . value)) to let, and returns the new let." +#define Q_sublet Q_varlet + + s7_pointer e = car(args); + if (is_null(e)) + e = sc->rootlet; + else { + check_method(sc, e, sc->sublet_symbol, args); + if (!is_let(e)) + return (wrong_type_argument_with_type + (sc, sc->sublet_symbol, 1, e, a_let_string)); + } + return (sublet_1(sc, e, cdr(args), sc->sublet_symbol)); +} + + +/* -------------------------------- inlet -------------------------------- */ +s7_pointer s7_inlet(s7_scheme * sc, s7_pointer args) +{ +#define H_inlet "(inlet ...) adds its arguments, each a let, a cons: '(symbol . value), or a keyword/value pair, to a new let, and returns the \ +new let. (inlet :a 1 :b 2) or (inlet '(a . 1) '(b . 2))" +#define Q_inlet s7_make_circular_signature(sc, 1, 2, sc->is_let_symbol, sc->T) + return (sublet_1(sc, sc->rootlet, args, sc->inlet_symbol)); +} + +#define g_inlet s7_inlet + +static s7_pointer g_simple_inlet(s7_scheme * sc, s7_pointer args) +{ + /* here all args are paired with normal symbol/value, no fallbacks, no immutable symbols etc */ + s7_pointer new_e, x; + int64_t id; + new_e = make_let_slowly(sc, sc->nil); + sc->temp3 = new_e; + id = let_id(new_e); + for (x = args; is_pair(x); x = cddr(x)) { + s7_pointer symbol = car(x); + if (is_keyword(symbol)) /* (inlet ':allow-other-keys 3) */ + symbol = keyword_symbol(symbol); + if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */ + return (wrong_type_argument_with_type + (sc, sc->inlet_symbol, 1, symbol, + a_non_constant_symbol_string)); + add_slot_unchecked(sc, new_e, symbol, cadr(x), id); + } + sc->temp3 = sc->nil; + return (new_e); +} + +static s7_pointer inlet_p_pp(s7_scheme * sc, s7_pointer symbol, + s7_pointer value) +{ + s7_pointer x; + + if (!is_symbol(symbol)) + return (sublet_1 + (sc, sc->nil, set_plist_2(sc, symbol, value), + sc->inlet_symbol)); + if (is_keyword(symbol)) + symbol = keyword_symbol(symbol); + if (is_constant_symbol(sc, symbol)) + return (wrong_type_argument_with_type + (sc, sc->inlet_symbol, 1, symbol, + a_non_constant_symbol_string)); + if ((is_global(symbol)) && (is_syntax(global_value(symbol)))) + return (wrong_type_argument_with_type + (sc, sc->inlet_symbol, 1, symbol, + wrap_string(sc, "a non-syntactic name", 20))); + + new_cell(sc, x, T_LET | T_SAFE_PROCEDURE); + sc->temp3 = x; + let_set_id(x, ++sc->let_number); + let_set_outlet(x, sc->nil); + let_set_slots(x, slot_end(sc)); + add_slot_unchecked(sc, x, symbol, value, let_id(x)); + sc->temp3 = sc->nil; + return (x); +} + +static s7_pointer g_local_inlet(s7_scheme * sc, s7_int num_args, ...) +{ + va_list ap; + s7_int i; + s7_pointer new_e; + int64_t id; + + new_e = make_let_slowly(sc, sc->nil); + sc->temp3 = new_e; + id = let_id(new_e); + + va_start(ap, num_args); + for (i = 0; i < num_args; i += 2) { + s7_pointer symbol, value; + symbol = va_arg(ap, s7_pointer); + value = va_arg(ap, s7_pointer); + if (is_keyword(symbol)) /* (inlet ':allow-other-keys 3) */ + symbol = keyword_symbol(symbol); + add_slot_unchecked(sc, new_e, symbol, value, id); + } + va_end(ap); + + sc->temp3 = sc->nil; + return (new_e); +} + +static bool is_proper_quote(s7_scheme * sc, s7_pointer p) +{ + return ((is_quoted_pair(p)) && + (is_pair(cdr(p))) && + (is_null(cddr(p))) && (is_global(sc->quote_symbol))); +} + +static s7_pointer inlet_chooser(s7_scheme * sc, s7_pointer f, int32_t args, + s7_pointer expr, bool ops) +{ + if (!ops) + return (f); + if ((args > 0) && ((args % 2) == 0)) { + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cddr(p)) + if (!is_keyword(car(p))) { + s7_pointer sym; + if (!is_proper_quote(sc, car(p))) /* 'abs etc, but tricky: ':abs */ + return (f); + sym = cadar(p); + if ((!is_symbol(sym)) || (is_possibly_constant(sym)) || /* define-constant etc */ + (is_syntactic_symbol(sym)) || /* (inlet 'if 3) */ + ((is_slot(global_slot(sym))) && + (is_syntax(global_value(sym)))) || + (sym == sc->let_ref_fallback_symbol) || + (sym == sc->let_set_fallback_symbol)) + return (f); + } + return (sc->simple_inlet); + } + return (f); +} + + +/* -------------------------------- let->list -------------------------------- */ +static s7_pointer proper_list_reverse_in_place(s7_scheme * sc, + s7_pointer list); + +s7_pointer s7_let_to_list(s7_scheme * sc, s7_pointer let) +{ + s7_pointer x; + sc->temp3 = sc->w; + sc->w = sc->nil; + if (let == sc->rootlet) { + s7_int i, lim2 = sc->rootlet_entries; + s7_pointer *entries = rootlet_elements(let); + + if (lim2 & 1) + lim2--; + for (i = 0; i < lim2;) { + sc->w = + cons_unchecked(sc, + cons(sc, slot_symbol(entries[i]), + slot_value(entries[i])), sc->w); + i++; + sc->w = + cons_unchecked(sc, + cons_unchecked(sc, slot_symbol(entries[i]), + slot_value(entries[i])), + sc->w); + i++; + } + if (lim2 < sc->rootlet_entries) + sc->w = + cons_unchecked(sc, + cons(sc, slot_symbol(entries[i]), + slot_value(entries[i])), sc->w); + } else { + s7_pointer iter, func; + s7_int gc_loc = -1; + /* need to check make-iterator method before dropping into let->list */ + + if ((has_active_methods(sc, let)) && + ((func = + find_method(sc, let, + sc->make_iterator_symbol)) != sc->undefined)) + iter = call_method(sc, let, func, set_plist_1(sc, let)); + else if (let == sc->s7_let) { /* (let->list *s7*) via s7_let_make_iterator */ + iter = s7_make_iterator(sc, let); + gc_loc = s7_gc_protect(sc, iter); + } else + iter = sc->nil; + + if (is_null(iter)) + for (x = let_slots(let); tis_slot(x); x = next_slot(x)) + sc->w = + cons_unchecked(sc, + cons(sc, slot_symbol(x), slot_value(x)), + sc->w); + else { + /* (begin (load "mockery.scm") (let ((lt ((*mock-pair* 'mock-pair) 1 2 3))) (format *stderr* "~{~A ~}" lt))) */ + while (true) { + x = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) + break; + sc->w = cons(sc, x, sc->w); + } + sc->w = proper_list_reverse_in_place(sc, sc->w); + } + if (gc_loc != -1) + s7_gc_unprotect_at(sc, gc_loc); + } + x = sc->w; + sc->w = sc->temp3; + sc->temp3 = sc->nil; + return (x); +} + +#if (!WITH_PURE_S7) +static s7_pointer g_let_to_list(s7_scheme * sc, s7_pointer args) +{ +#define H_let_to_list "(let->list let) returns let's bindings as a list of cons's: '(symbol . value)." +#define Q_let_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_let_symbol) + + s7_pointer let = car(args); + check_method(sc, let, sc->let_to_list_symbol, args); + if (!is_let(let)) { + if (is_c_object(let)) + let = c_object_let(let); + else if (is_c_pointer(let)) + let = c_pointer_info(let); + if (!is_let(let)) + return (simple_wrong_type_argument_with_type + (sc, sc->let_to_list_symbol, let, a_let_string)); + } + return (s7_let_to_list(sc, let)); +} +#endif + + +/* -------------------------------- let-ref -------------------------------- */ + +static s7_pointer call_let_ref_fallback(s7_scheme * sc, s7_pointer let, + s7_pointer symbol) +{ + s7_pointer p; + push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code); + p = s7_apply_function(sc, + find_method(sc, let, + sc->let_ref_fallback_symbol), + set_qlist_2(sc, let, symbol)); + unstack(sc); + sc->code = T_Pos(sc->stack_end[0]); + sc->value = T_Pos(sc->stack_end[2]); + return (p); +} + +static s7_pointer call_let_set_fallback(s7_scheme * sc, s7_pointer let, + s7_pointer symbol, + s7_pointer value) +{ + s7_pointer p; + push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code); + p = s7_apply_function(sc, + find_method(sc, let, + sc->let_set_fallback_symbol), + set_qlist_3(sc, let, symbol, value)); + unstack(sc); + sc->code = T_Pos(sc->stack_end[0]); + sc->value = T_Pos(sc->stack_end[2]); + return (p); +} + +inline s7_pointer s7_let_ref(s7_scheme * sc, s7_pointer let, + s7_pointer symbol) +{ + s7_pointer x, y; + /* (let ((a 1)) ((curlet) 'a)) or ((rootlet) 'abs) */ + if (!is_let(let)) + return (wrong_type_argument_with_type + (sc, sc->let_ref_symbol, 1, let, a_let_string)); + + if (!is_symbol(symbol)) { +#if S7_DEBUGGING + if ((let != sc->rootlet) && (has_let_ref_fallback(let))) +#else + if (has_let_ref_fallback(let)) +#endif + return (call_let_ref_fallback(sc, let, symbol)); + return (wrong_type_argument_with_type + (sc, sc->let_ref_symbol, 2, symbol, a_symbol_string)); + } + + if (!is_global(sc->let_ref_symbol)) + check_method(sc, let, sc->let_ref_symbol, + set_plist_2(sc, let, symbol)); + /* a let-ref method is almost impossible to write without creating an infinite loop: + * any reference to the let will probably call let-ref somewhere, calling us again, and looping. + * This is not a problem in c-objects and funclets because c-object-ref and funclet-ref don't exist. + * After much wasted debugging, I decided to make let-ref and let-set! immutable. + */ + + if (is_keyword(symbol)) + symbol = keyword_symbol(symbol); + + if (let == sc->rootlet) { + y = global_slot(symbol); + return ((is_slot(y)) ? slot_value(y) : sc->undefined); + } + + if (let_id(let) == symbol_id(symbol)) + return (local_value(symbol)); /* this obviously has to follow the rootlet check */ + + for (x = let; is_let(x); x = let_outlet(x)) + for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == symbol) + return (slot_value(y)); + + if (has_methods(let)) { /* this is not a redundant check -- if has_methods, don't check global slot */ + /* If a let is a mock-hash-table (for example), implicit + * indexing of the hash-table collides with the same thing for the let (field names + * versus keys), and we can't just try again here because that makes it too easy to + * get into infinite recursion. So, 'let-ref-fallback... + */ + if (has_let_ref_fallback(let)) + return (call_let_ref_fallback(sc, let, symbol)); + } else { + y = global_slot(symbol); /* (let () ((curlet) 'pi)) */ + if (is_slot(y)) + return (slot_value(y)); + } + return (sc->undefined); +} + +static s7_pointer g_let_ref(s7_scheme * sc, s7_pointer args) +{ +#define H_let_ref "(let-ref let sym) returns the value of the symbol sym in the let" +#define Q_let_ref s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol) + return (s7_let_ref(sc, car(args), cadr(args))); +} + +static s7_pointer slot_in_let(s7_scheme * sc, s7_pointer e, s7_pointer sym) +{ + s7_pointer y; + for (y = let_slots(e); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == sym) + return (y); + return (sc->undefined); +} + +static s7_pointer lint_let_ref_p_pp(s7_scheme * sc, s7_pointer lt, + s7_pointer sym) +{ + s7_pointer x, y; + for (x = lt; is_let(x); x = let_outlet(x)) + for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == sym) + return (slot_value(y)); + + if (has_methods(lt)) { + if (has_let_ref_fallback(lt)) + return (call_let_ref_fallback(sc, lt, sym)); + } else { + y = global_slot(sym); + if (is_slot(y)) + return (slot_value(y)); + } + return (sc->undefined); +} + +static inline s7_pointer g_lint_let_ref(s7_scheme * sc, s7_pointer args) +{ + s7_pointer lt = car(args), y, sym; + if (!is_let(lt)) + return (wrong_type_argument_with_type + (sc, sc->let_ref_symbol, 1, lt, a_let_string)); + sym = cadr(args); + for (y = let_slots(lt); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == sym) + return (slot_value(y)); + return (lint_let_ref_p_pp(sc, let_outlet(lt), sym)); +} + +static s7_pointer let_ref_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if ((!ops) || (!is_global(sc->let_ref_symbol))) + return (f); + if (optimize_op(expr) == HOP_SAFE_C_opSq_C) { + s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if ((car(arg1) == sc->cdr_symbol) && + (is_quoted_symbol(arg2)) && + (!is_possibly_constant(cadr(arg2)))) { + set_opt3_sym(cdr(expr), cadr(arg2)); + return (sc->lint_let_ref); + } + } + return (f); +} + +static bool op_implicit_let_ref_c(s7_scheme * sc) +{ + s7_pointer s; + s = lookup_checked(sc, car(sc->code)); + if (!is_let(s)) { + sc->last_function = s; + return (false); + } + sc->value = s7_let_ref(sc, T_Pos(s), opt3_con(sc->code)); + return (true); +} + +static bool op_implicit_let_ref_a(s7_scheme * sc) +{ + s7_pointer s; + s = lookup_checked(sc, car(sc->code)); + if (!is_let(s)) { + sc->last_function = s; + return (false); + } + sc->value = s7_let_ref(sc, s, fx_call(sc, cdr(sc->code))); + return (true); +} + + +/* -------------------------------- let-set! -------------------------------- */ +static s7_pointer let_set_1(s7_scheme * sc, s7_pointer let, + s7_pointer symbol, s7_pointer value) +{ + s7_pointer x, y; + + if (is_keyword(symbol)) + symbol = keyword_symbol(symbol); + symbol_increment_ctr(symbol); + + if (let == sc->rootlet) { + if (is_constant_symbol(sc, symbol)) /* (let-set! (rootlet) 'pi #f) */ + return (wrong_type_argument_with_type + (sc, sc->let_set_symbol, 2, symbol, + a_non_constant_symbol_string)); + + y = global_slot(symbol); + if (!is_slot(y)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, + wrap_string(sc, + "let-set!: ~A is not defined in ~A", + 33), symbol, let))); + if (is_syntax(slot_value(y))) + return (wrong_type_argument_with_type + (sc, sc->let_set_symbol, 2, symbol, + wrap_string(sc, "a non-syntactic keyword", 23))); + + if (slot_has_setter(y)) + slot_set_value(y, call_setter(sc, y, value)); + else + slot_set_value(y, value); + return (slot_value(y)); + } + + if (let_id(let) == symbol_id(symbol)) { + y = local_slot(symbol); + if (is_slot(y)) + return (checked_slot_set_value(sc, y, value)); + } + + for (x = let; is_let(x); x = let_outlet(x)) + for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == symbol) + return (checked_slot_set_value(sc, y, value)); + + if ((has_methods(let)) && (has_let_set_fallback(let))) + return (call_let_set_fallback(sc, let, symbol, value)); + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, + wrap_string(sc, + "let-set!: ~A is not defined in ~A", + 33), symbol, let))); + /* not sure about this -- what's the most useful choice? */ +} + +s7_pointer s7_let_set(s7_scheme * sc, s7_pointer let, s7_pointer symbol, + s7_pointer value) +{ + if (!is_let(let)) + return (wrong_type_argument_with_type + (sc, sc->let_set_symbol, 1, let, a_let_string)); + if (!is_symbol(symbol)) { + if (has_let_set_fallback(let)) + return (call_let_set_fallback(sc, let, symbol, value)); + return (wrong_type_argument_with_type + (sc, sc->let_set_symbol, 2, symbol, a_symbol_string)); + } + if (!is_global(sc->let_set_symbol)) + check_method(sc, let, sc->let_set_symbol, + set_plist_3(sc, let, symbol, value)); + return (let_set_1(sc, let, symbol, value)); +} + +static s7_pointer g_let_set(s7_scheme * sc, s7_pointer args) +{ + /* (let ((a 1)) (set! ((curlet) 'a) 32) a) */ +#define H_let_set "(let-set! let sym val) sets the symbol sym's value in the let to val" +#define Q_let_set s7_make_signature(sc, 4, sc->T, sc->is_let_symbol, sc->is_symbol_symbol, sc->T) + return (s7_let_set(sc, car(args), cadr(args), caddr(args))); +} + +static s7_pointer let_set_p_ppp_2(s7_scheme * sc, s7_pointer p1, + s7_pointer p2, s7_pointer p3) +{ + if (!is_symbol(p2)) + return (wrong_type_argument_with_type + (sc, sc->let_set_symbol, 2, p2, a_symbol_string)); + return (let_set_1(sc, p1, p2, p3)); +} + +static s7_pointer g_lint_let_set(s7_scheme * sc, s7_pointer args) +{ + s7_pointer y, lt = car(args), sym, val; + + if (!is_let(lt)) + return (wrong_type_argument_with_type + (sc, sc->let_set_symbol, 1, lt, a_let_string)); + sym = cadr(args); + val = caddr(args); + + if (lt != sc->rootlet) { + s7_pointer x; + for (x = lt; is_let(x); x = let_outlet(x)) + for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == sym) { + if (slot_has_setter(y)) + slot_set_value(y, call_setter(sc, y, val)); + else + slot_set_value(y, val); + return (slot_value(y)); + } + if ((has_methods(lt)) && (has_let_set_fallback(lt))) + return (call_let_set_fallback(sc, lt, sym, val)); + } + y = global_slot(sym); + if (!is_slot(y)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, + wrap_string(sc, + "let-set!: ~A is not defined in ~A", + 33), sym, lt))); + if (slot_has_setter(y)) + slot_set_value(y, call_setter(sc, y, val)); + else + slot_set_value(y, val); + return (slot_value(y)); +} + +static s7_pointer let_set_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if ((!ops) || (!is_global(sc->let_set_symbol))) + return (f); + if (optimize_op(expr) == HOP_SAFE_C_opSq_CS) { + s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 = + cadddr(expr); + if ((car(arg1) == sc->cdr_symbol) + && (car(arg2) == sc->quote_symbol) && (is_symbol(cadr(arg2))) + && (!is_possibly_constant(cadr(arg2))) + && (!is_possibly_constant(arg3))) + return (sc->lint_let_set); + } + return (f); +} + + +static s7_pointer reverse_slots(s7_scheme * sc, s7_pointer list) +{ + s7_pointer p = list, result = slot_end(sc), q; + while (tis_slot(p)) { + q = next_slot(p); + slot_set_next(p, result); + result = p; + p = q; + } + return (result); +} + +static s7_pointer let_copy(s7_scheme * sc, s7_pointer let) +{ + if (is_let(let)) { + s7_pointer new_e; + + if (let == sc->rootlet) /* (copy (rootlet)) or (copy (funclet abs)) etc */ + return (sc->rootlet); + + /* we can't make copy handle lets-as-objects specially because the make-object function in define-class uses copy to make a new object! + * So if it is present, we get it here, and then there's almost surely trouble. + */ + new_e = make_let_slowly(sc, let_outlet(let)); + set_all_methods(new_e, let); + sc->temp3 = new_e; + if (tis_slot(let_slots(let))) { + s7_int id = let_id(new_e); + s7_pointer x, y = NULL; + + for (x = let_slots(let); tis_slot(x); x = next_slot(x)) { + s7_pointer z; + new_cell(sc, z, T_SLOT); + slot_set_symbol_and_value(z, slot_symbol(x), + slot_value(x)); + if (symbol_id(slot_symbol(z)) != id) /* keep shadowing intact */ + symbol_set_local_slot(slot_symbol(x), id, z); + if (slot_has_setter(x)) { + slot_set_setter(z, slot_setter(x)); + slot_set_has_setter(z); + } + if (y) + slot_set_next(y, z); + else + let_set_slots(new_e, z); + slot_set_next(z, slot_end(sc)); /* in case GC runs during this loop */ + y = z; + } + } + /* We can't do a (normal) loop here then reverse the slots later because the symbol's local_slot has to + * match the unshadowed slot, not the last in the list: + * (let ((e1 (inlet 'a 1 'a 2))) (let ((e2 (copy e1))) (list (equal? e1 e2) (equal? (e1 'a) (e2 'a))))) + */ + sc->temp3 = sc->nil; + return (new_e); + } + return (sc->nil); +} + + +/* -------------------------------- rootlet -------------------------------- */ +static s7_pointer g_rootlet(s7_scheme * sc, s7_pointer ignore) +{ +#define H_rootlet "(rootlet) returns the current top-level definitions (symbol bindings)." +#define Q_rootlet s7_make_signature(sc, 1, sc->is_let_symbol) + return (sc->rootlet); +} + +/* as with the symbol-table, this function can lead to disaster -- user could + * clobber the let etc. But we want it to be editable and augmentable, + * so I guess I'll leave it alone. (See curlet|funclet as well). + */ + +s7_pointer s7_rootlet(s7_scheme * sc) +{ + return (sc->rootlet); +} + +/* shadow_rootlet is a convenience for foreign function writers -- the C code can act as if it were loading everything into rootlet, + * but when actually loaded, everything can be shunted into a separate namespace (*motif* for example). + */ +s7_pointer s7_shadow_rootlet(s7_scheme * sc) +{ + return (sc->shadow_rootlet); +} + +s7_pointer s7_set_shadow_rootlet(s7_scheme * sc, s7_pointer let) +{ + s7_pointer old_let = sc->shadow_rootlet; + sc->shadow_rootlet = let; + return (old_let); /* like s7_set_curlet below */ +} + + +/* -------------------------------- curlet -------------------------------- */ +static s7_pointer g_curlet(s7_scheme * sc, s7_pointer args) +{ +#define H_curlet "(curlet) returns the current definitions (symbol bindings)" +#define Q_curlet s7_make_signature(sc, 1, sc->is_let_symbol) + + sc->capture_let_counter++; + return ((is_let(sc->curlet)) ? sc->curlet : sc->rootlet); +} + +s7_pointer s7_curlet(s7_scheme * sc) +{ + sc->capture_let_counter++; + return (sc->curlet); +} + +static void update_symbol_ids(s7_scheme * sc, s7_pointer e) +{ + s7_pointer p; + for (p = let_slots(e); tis_slot(p); p = next_slot(p)) { + s7_pointer sym = slot_symbol(p); + if (symbol_id(sym) != sc->let_number) + symbol_set_local_slot_unincremented(sym, sc->let_number, p); + } +} + +s7_pointer s7_set_curlet(s7_scheme * sc, s7_pointer e) +{ + s7_pointer old_e = sc->curlet; + set_curlet(sc, e); + if ((is_let(e)) && (let_id(e) > 0)) { /* might be () [id=-1] or rootlet [id=0?] etc */ + let_set_id(e, ++sc->let_number); + update_symbol_ids(sc, e); + } + return (old_e); +} + + +/* -------------------------------- outlet -------------------------------- */ +s7_pointer s7_outlet(s7_scheme * sc, s7_pointer let) +{ + if ((let == sc->rootlet) || (is_null(let_outlet(let)))) + return (sc->rootlet); + return (let_outlet(let)); +} + +s7_pointer outlet_p_p(s7_scheme * sc, s7_pointer let) +{ + if (!is_let(let)) + return (s7_wrong_type_arg_error(sc, "outlet", 1, let, "a let")); /* not a method call here! */ + if ((let == sc->rootlet) || (is_null(let_outlet(let)))) + return (sc->rootlet); + return (let_outlet(let)); +} + +static s7_pointer g_outlet(s7_scheme * sc, s7_pointer args) +{ +#define H_outlet "(outlet let) is the environment that contains let." +#define Q_outlet s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_let_symbol) + return (outlet_p_p(sc, car(args))); +} + + +static s7_pointer g_set_outlet(s7_scheme * sc, s7_pointer args) +{ + /* (let ((a 1)) (let ((b 2)) (set! (outlet (curlet)) (rootlet)) ((curlet) 'a))) */ + s7_pointer let = car(args), new_outer; + + if (!is_let(let)) + return (s7_wrong_type_arg_error + (sc, "set! outlet", 1, let, "a let")); + if ((is_immutable(let)) || (let == sc->s7_let)) + return (s7_wrong_type_arg_error + (sc, "set! outlet", 1, let, "a mutable let")); + + new_outer = cadr(args); + if (!is_let(new_outer)) + return (s7_wrong_type_arg_error + (sc, "set! outlet", 2, new_outer, "a let")); + + if (let != sc->rootlet) { + /* here it's possible to get cyclic let chains; maybe do this check only if safety>0 */ + s7_pointer lt; + for (lt = new_outer; (is_let(lt)) && (lt != sc->rootlet); + lt = let_outlet(lt)) + if (let == lt) + s7_error(sc, s7_make_symbol(sc, "cyclic-let"), + set_elist_2(sc, + wrap_string(sc, + "set! (outlet ~A) creates a cyclic let chain", + 43), let)); + let_set_outlet(let, (new_outer == sc->rootlet) ? sc->nil : new_outer); /* outlet rootlet->() so that slot search can use is_let(outlet) I think */ + } + return (new_outer); +} + +/* -------------------------------- symbol lookup -------------------------------- */ + +static inline s7_pointer lookup_from(s7_scheme * sc, + const s7_pointer symbol, s7_pointer e) +{ +#if S7_DEBUGGING + if ((!is_let(e)) && (!is_null(e))) { + fprintf(stderr, "%s[%d]: e is not a let\n", __func__, __LINE__); + if (sc != cur_sc) + fprintf(stderr, "sc != cur_sc\n"); + /* how to show calling code? last stack op is sc->stack_end[3] */ + } +#endif + if (let_id(e) == symbol_id(symbol)) + return (local_value(symbol)); + if (symbol_id(symbol) < let_id(e)) { + do { + e = let_outlet(e); + } while (symbol_id(symbol) < let_id(e)); + if (let_id(e) == symbol_id(symbol)) + return (local_value(symbol)); + } + for (; is_let(e); e = let_outlet(e)) { + s7_pointer y; + for (y = let_slots(e); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == symbol) + return (slot_value(y)); + } + if (is_slot(global_slot(symbol))) + return (global_value(symbol)); +#if WITH_GCC + return (NULL); /* much faster than various alternatives */ +#else + return (unbound_variable(sc, symbol)); +#endif +} + +static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e) +{ + if (let_id(e) == symbol_id(symbol)) + return (local_slot(symbol)); + if (symbol_id(symbol) < let_id(e)) { + do { + e = let_outlet(e); + } while (symbol_id(symbol) < let_id(e)); + if (let_id(e) == symbol_id(symbol)) + return (local_slot(symbol)); + } + for (; is_let(e); e = let_outlet(e)) { + s7_pointer y; + for (y = let_slots(e); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == symbol) + return (y); + } + return (global_slot(symbol)); +} + +#if WITH_GCC && S7_DEBUGGING +static s7_pointer lookup_1(s7_scheme * sc, const s7_pointer symbol) +#else +static inline s7_pointer lookup(s7_scheme * sc, const s7_pointer symbol) /* lookup_checked includes the unbound_variable call */ +#endif +{ + return (lookup_from(sc, symbol, sc->curlet)); +} + +s7_pointer s7_slot(s7_scheme * sc, s7_pointer symbol) +{ + return (lookup_slot_from(symbol, sc->curlet)); +} + +s7_pointer s7_slot_value(s7_pointer slot) +{ + return (slot_value(slot)); +} + +s7_pointer s7_slot_set_value(s7_scheme * sc, s7_pointer slot, + s7_pointer value) +{ + slot_set_value(slot, value); + return (value); +} + +void s7_slot_set_real_value(s7_scheme * sc, s7_pointer slot, + s7_double value) +{ + set_real(slot_value(slot), value); +} + +static s7_pointer symbol_to_local_slot(s7_scheme * sc, s7_pointer symbol, + s7_pointer e) +{ + if (!is_let(e)) + return (global_slot(symbol)); + + if (symbol_id(symbol) != 0) { + s7_pointer y; + for (y = let_slots(e); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == symbol) + return (y); + } + return (sc->undefined); +} + +s7_pointer s7_symbol_value(s7_scheme * sc, s7_pointer sym) +{ + s7_pointer x; + x = lookup_slot_from(sym, sc->curlet); + return ((is_slot(x)) ? slot_value(x) : sc->undefined); +} + +s7_pointer s7_symbol_local_value(s7_scheme * sc, s7_pointer sym, + s7_pointer let) +{ + /* restrict the search to local let outward */ + if ((let == sc->rootlet) || (is_global(sym))) + return ((is_slot(global_slot(sym))) ? global_value(sym) : + sc->undefined); + + if (!is_let(let)) + return (s7_symbol_value(sc, sym)); + + if (let_id(let) == symbol_id(sym)) + return (local_value(sym)); + if (symbol_id(sym) < let_id(let)) { + do { + let = let_outlet(let); + } while (symbol_id(sym) < let_id(let)); + if (let_id(let) == symbol_id(sym)) + return (local_value(sym)); + } + for (; is_let(let); let = let_outlet(let)) { + s7_pointer y; + for (y = let_slots(let); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == sym) + return (slot_value(y)); + } + /* need to check rootlet before giving up */ + if (is_slot(global_slot(sym))) + return (global_value(sym)); + + /* (let ((e (curlet))) (let ((a 1)) (symbol->value 'a e))) -> # not 1 */ + return (sc->undefined); /* 29-Nov-17 */ +} + + +/* -------------------------------- symbol->value -------------------------------- */ +#define lookup_global(Sc, Sym) ((is_global(Sym)) ? global_value(Sym) : lookup_checked(Sc, Sym)) + +static s7_pointer g_s7_let_ref_fallback(s7_scheme * sc, s7_pointer args); +static s7_pointer g_s7_let_set_fallback(s7_scheme * sc, s7_pointer args); + +static s7_pointer g_symbol_to_value(s7_scheme * sc, s7_pointer args) +{ +#define H_symbol_to_value "(symbol->value sym (let (curlet))) returns the binding of (the value associated with) the \ +symbol sym in the given let: (let ((x 32)) (symbol->value 'x)) -> 32" +#define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->is_let_symbol) + /* (symbol->value 'x e) => (e 'x)? */ + + s7_pointer sym = car(args); + if (!is_symbol(sym)) + return (method_or_bust + (sc, sym, sc->symbol_to_value_symbol, args, T_SYMBOL, 1)); + + if (is_not_null(cdr(args))) { + s7_pointer local_let = cadr(args); + if (local_let == sc->unlet_symbol) + return ((is_slot(initial_slot(sym))) ? initial_value(sym) : + sc->undefined); + + if (!is_let(local_let)) + return (method_or_bust_with_type + (sc, local_let, sc->symbol_to_value_symbol, args, + a_let_string, 2)); + + if (local_let == sc->s7_let) + return (g_s7_let_ref_fallback + (sc, set_qlist_2(sc, local_let, sym))); + + return (s7_symbol_local_value(sc, sym, local_let)); + } + if (is_global(sym)) + return (global_value(sym)); + return (s7_symbol_value(sc, sym)); +} + +s7_pointer s7_symbol_set_value(s7_scheme * sc, s7_pointer sym, + s7_pointer val) +{ + s7_pointer x; /* if immutable should this return an error? */ + x = lookup_slot_from(sym, sc->curlet); + if (is_slot(x)) + slot_set_value(x, val); /* with_hook? */ + return (val); +} + + +/* -------------------------------- symbol->dynamic-value -------------------------------- */ +static s7_pointer find_dynamic_value(s7_scheme * sc, s7_pointer x, + s7_pointer sym, int64_t * id) +{ + for (; symbol_id(sym) < let_id(x); x = let_outlet(x)); + if (let_id(x) == symbol_id(sym)) { + (*id) = let_id(x); + return (local_value(sym)); + } + for (; (is_let(x)) && (let_id(x) > (*id)); x = let_outlet(x)) { + s7_pointer y; + for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == sym) { + (*id) = let_id(x); + return (slot_value(y)); + } + } + return (sc->unused); +} + +static s7_pointer g_symbol_to_dynamic_value(s7_scheme * sc, + s7_pointer args) +{ +#define H_symbol_to_dynamic_value "(symbol->dynamic-value sym) returns the dynamic binding of the symbol sym" +#define Q_symbol_to_dynamic_value s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol) + + s7_pointer sym = car(args), val; + int64_t i, top_id; + + if (!is_symbol(sym)) + return (method_or_bust + (sc, sym, sc->symbol_to_dynamic_value_symbol, args, + T_SYMBOL, 1)); + + if (is_global(sym)) + return (global_value(sym)); + + if (let_id(sc->curlet) == symbol_id(sym)) + return (local_value(sym)); + + top_id = -1; + val = find_dynamic_value(sc, sc->curlet, sym, &top_id); + if (top_id == symbol_id(sym)) + return (val); + + for (i = current_stack_top(sc) - 1; i > 0; i -= 4) + if (is_let_unchecked(stack_let(sc->stack, i))) { /* OP_GC_PROTECT let slot can be anything (even free) */ + s7_pointer cur_val; + cur_val = + find_dynamic_value(sc, stack_let(sc->stack, i), sym, + &top_id); + if (cur_val != sc->unused) + val = cur_val; + if (top_id == symbol_id(sym)) + return (val); + } + return ((val == sc->unused) ? s7_symbol_value(sc, sym) : val); +} + + +typedef bool (safe_sym_t) (s7_scheme * sc, s7_pointer sym, s7_pointer e); + +static bool direct_memq(s7_pointer symbol, s7_pointer symbols) +{ + s7_pointer x; + for (x = symbols; is_pair(x); x = cdr(x)) + if (car(x) == symbol) + return (true); + return (false); +} + +static bool direct_assq(s7_pointer symbol, s7_pointer symbols) +{ /* used only below in do_symbol_is_safe */ + s7_pointer x; + for (x = symbols; is_pair(x); x = cdr(x)) + if (caar(x) == symbol) + return (true); + return (false); +} + +static bool do_symbol_is_safe(s7_scheme * sc, s7_pointer sym, s7_pointer e) +{ + return ((is_slot(global_slot(sym))) || + (direct_assq(sym, e)) || + (is_slot(lookup_slot_from(sym, sc->curlet)))); +} + +static bool let_symbol_is_safe(s7_scheme * sc, s7_pointer sym, + s7_pointer e) +{ + if (is_slot(global_slot(sym))) + return (true); + if (is_null(e)) + e = sc->rootlet; + return ((!is_with_let_let(e)) && + (is_slot(lookup_slot_from(sym, sc->curlet)))); +} + +static bool let_symbol_is_safe_or_listed(s7_scheme * sc, s7_pointer sym, + s7_pointer e) +{ + return ((symbol_is_in_list(sc, sym)) || + (let_symbol_is_safe(sc, sym, e))); +} + +static bool let_star_symbol_is_safe(s7_scheme * sc, s7_pointer sym, + s7_pointer e) +{ + return ((symbol_is_in_list(sc, sym)) || + (is_slot(global_slot(sym))) || + ((is_let(e)) && (!is_with_let_let(e)) + && (is_slot(lookup_slot_from(sym, sc->curlet))))); +} + +static bool pair_symbol_is_safe(s7_scheme * sc, s7_pointer sym, + s7_pointer e) +{ + return ((is_slot(global_slot(sym))) || (direct_memq(sym, e))); +} + +static inline s7_pointer collect_variables(s7_scheme * sc, s7_pointer lst, + s7_pointer e) +{ + /* collect local variable names from let/do (pre-error-check) */ + s7_pointer p; + sc->w = e; + for (p = lst; is_pair(p); p = cdr(p)) + sc->w = cons(sc, add_symbol_to_list(sc, caar(p)), sc->w); + return (sc->w); +} + +static s7_pointer collect_parameters(s7_scheme * sc, s7_pointer lst, + s7_pointer e) +{ + /* collect local variable names from lambda arglists (pre-error-check) */ + s7_pointer p; + s7_int the_un_id; + the_un_id = ++sc->let_number; + if (is_symbol(lst)) { + symbol_set_id(lst, the_un_id); + return (cons(sc, add_symbol_to_list(sc, lst), e)); + } + sc->w = e; + for (p = lst; is_pair(p); p = cdr(p)) { + s7_pointer car_p = car(p); + if (is_pair(car_p)) + car_p = car(car_p); + if (is_normal_symbol(car_p)) { + symbol_set_id(car_p, the_un_id); + sc->w = cons(sc, add_symbol_to_list(sc, car_p), sc->w); + } + } + if (is_symbol(p)) { /* rest arg */ + symbol_set_id(p, the_un_id); + sc->w = cons(sc, add_symbol_to_list(sc, p), sc->w); + } + return (sc->w); +} + +typedef enum { OPT_F, OPT_T, OPT_OOPS } opt_t; +static opt_t optimize(s7_scheme * sc, s7_pointer code, int32_t hop, + s7_pointer e); + +static void clear_all_optimizations(s7_scheme * sc, s7_pointer p) +{ + /* I believe that we would not have been optimized to begin with if the tree were circular, + * and this tree is supposed to be a function call + args -- a circular list here is a bug. + */ + if (is_pair(p)) { + if ((is_optimized(p)) && (((optimize_op(p) >= FIRST_UNHOPPABLE_OP) || /* avoid clearing hop ops, fx_function and op_unknown* need to be cleared */ + (!op_has_hop(p))))) { + clear_optimized(p); /* includes T_SYNTACTIC */ + clear_optimize_op(p); + } + clear_all_optimizations(sc, cdr(p)); + clear_all_optimizations(sc, car(p)); + } +} + +static s7_pointer add_trace(s7_scheme * sc, s7_pointer code) +{ + if ((is_pair(car(code))) && (caar(code) == sc->trace_in_symbol)) + return (code); + return (cons_unchecked + (sc, + list_2(sc, sc->trace_in_symbol, + list_1(sc, sc->curlet_symbol)), code)); +} + +static s7_pointer add_profile(s7_scheme * sc, s7_pointer code) +{ + s7_pointer p; + if ((is_pair(car(code))) && (caar(code) == sc->profile_in_symbol)) + return (code); + p = cons_unchecked(sc, + list_2(sc, sc->profile_in_symbol, + list_1(sc, sc->curlet_symbol)), code); + set_unsafe_optimize_op(car(p), OP_PROFILE_IN); + return (p); +} + +static bool tree_has_definers(s7_scheme * sc, s7_pointer tree) +{ + s7_pointer p; + for (p = tree; is_pair(p); p = cdr(p)) + if (tree_has_definers(sc, car(p))) + return (true); + return ((is_symbol(tree)) && (is_definer(tree))); +} + +static s7_pointer make_macro(s7_scheme * sc, opcode_t op, bool named) +{ + s7_pointer mac, body, mac_name = NULL; + uint64_t typ; + switch (op) { + case OP_DEFINE_MACRO: + case OP_MACRO: + typ = T_MACRO; + break; + case OP_DEFINE_MACRO_STAR: + case OP_MACRO_STAR: + typ = T_MACRO_STAR; + break; + case OP_DEFINE_BACRO: + case OP_BACRO: + typ = T_BACRO; + break; + case OP_DEFINE_BACRO_STAR: + case OP_BACRO_STAR: + typ = T_BACRO_STAR; + break; + case OP_DEFINE_EXPANSION: + typ = T_MACRO | ((is_let(sc->curlet)) ? 0 : T_EXPANSION); + break; /* local expansions are just normal macros */ + case OP_DEFINE_EXPANSION_STAR: + typ = T_MACRO_STAR | ((is_let(sc->curlet)) ? 0 : T_EXPANSION); + break; + default: + if (S7_DEBUGGING) + fprintf(stderr, "%s[%d]: got %s\n", __func__, __LINE__, + op_names[op]); + typ = T_MACRO; + break; + } + new_cell(sc, mac, typ | T_DONT_EVAL_ARGS); + sc->temp6 = mac; + closure_set_args(mac, (named) ? cdar(sc->code) : car(sc->code)); + body = cdr(sc->code); + closure_set_body(mac, body); + closure_set_setter(mac, sc->F); + closure_set_let(mac, sc->curlet); + closure_set_arity(mac, CLOSURE_ARITY_NOT_SET); + sc->capture_let_counter++; + + if (named) { + s7_pointer cx; + mac_name = caar(sc->code); + + if (((op == OP_DEFINE_EXPANSION) + || (op == OP_DEFINE_EXPANSION_STAR)) && (!is_let(sc->curlet))) + set_full_type(mac_name, + T_EXPANSION | T_SYMBOL | (full_type(mac_name) & + T_UNHEAP)); + + /* symbol? macro name has already been checked, find name in let, and define it */ + cx = symbol_to_local_slot(sc, mac_name, sc->curlet); /* returns global_slot(symbol) if sc->curlet == nil */ + if (is_slot(cx)) { + if ((S7_DEBUGGING) && (sc->curlet == sc->rootlet)) + fprintf(stderr, "%s[%d]: curlet==rootlet!\n", __func__, + __LINE__); + if ((sc->curlet == sc->nil) && (!in_rootlet(cx))) { +#if S7_DEBUGGING + s7_pointer *tmp, *top; + tmp = rootlet_elements(sc->rootlet); + top = (s7_pointer *) (tmp + sc->rootlet_entries); + while (tmp < top) + if (cx == *tmp++) + break; + fprintf(stderr, "add %s%s\n", display(cx), + (tmp < top) ? ", already in rootlet!" : ""); +#endif + add_slot_to_rootlet(sc, cx); + } + slot_set_value_with_hook(cx, mac); + } else + s7_make_slot(sc, sc->curlet, mac_name, mac); /* was current but we've checked immutable already */ + if (tree_has_definers(sc, body)) + set_is_definer(mac_name); /* (list-values 'define ...) aux-13 */ + } + + /* TODO: we want to ignore arguments here, not (define xyzzy (macro...)) */ + if ((!is_either_bacro(mac)) && + (optimize + (sc, body, 1, + collect_parameters(sc, closure_args(mac), sc->nil)) == OPT_OOPS)) + clear_all_optimizations(sc, body); + + sc->temp6 = sc->nil; + if (sc->debug > 1) { /* no profile here */ + gc_protect_via_stack(sc, mac); /* GC protect func during add_trace */ + closure_set_body(mac, add_trace(sc, body)); + unstack(sc); + } + if (named) { + set_pair_macro(closure_body(mac), mac_name); + set_has_pair_macro(mac); + if (has_location(car(sc->code))) { + pair_set_location(closure_body(mac), + pair_location(car(sc->code))); + set_has_location(closure_body(mac)); + } + } + /* passed to maclet in apply_macro et al, copied in copy_closure */ + return (mac); +} + +static s7_pointer make_closure_unchecked(s7_scheme * sc, s7_pointer args, + s7_pointer code, uint64_t type, + int32_t arity) +{ + s7_pointer x; + new_cell_no_check(sc, x, (type | closure_bits(code))); + closure_set_args(x, args); + closure_set_let(x, sc->curlet); + closure_set_setter(x, sc->F); + closure_set_arity(x, arity); + closure_set_body(x, code); + if (is_pair(cdr(code))) + set_closure_has_multiform(x); + else + set_closure_has_one_form(x); + sc->capture_let_counter++; + return (x); +} + +static Inline s7_pointer inline_make_closure(s7_scheme * sc, + s7_pointer args, + s7_pointer code, + uint64_t type, int32_t arity) +{ + /* this is called (almost?) every time a lambda form is evaluated, or during letrec, etc */ + s7_pointer x; + new_cell(sc, x, (type | closure_bits(code))); + closure_set_args(x, args); + closure_set_let(x, sc->curlet); + closure_set_setter(x, sc->F); + closure_set_arity(x, arity); + closure_set_body(x, code); /* in case add_trace triggers GC, new func (x) needs some legit body for mark_closure */ + if (sc->debug_or_profile) { + gc_protect_via_stack(sc, x); /* GC protect func during add_trace */ + closure_set_body(x, + (sc->debug > 1) ? add_trace(sc, + code) : + add_profile(sc, code)); + set_closure_has_multiform(x); + unstack(sc); + } else if (is_pair(cdr(code))) + set_closure_has_multiform(x); + else + set_closure_has_one_form(x); + sc->capture_let_counter++; + return (x); +} + +static s7_pointer make_closure(s7_scheme * sc, s7_pointer args, + s7_pointer code, uint64_t type, + int32_t arity) +{ + return (inline_make_closure(sc, args, code, type, arity)); +} + +static int32_t closure_length(s7_scheme * sc, s7_pointer e) +{ + /* we can't use let_length(sc, closure_let(e)) because the closure_let(closure) + * changes. So the open bit is not always on. Besides, the fallbacks need to be for closures, not lets. + */ + s7_pointer length_func; + length_func = find_method(sc, closure_let(e), sc->length_symbol); + if (length_func != sc->undefined) + return ((int32_t) + s7_integer_checked(sc, + call_method(sc, e, length_func, + set_plist_1(sc, e)))); + + /* there are cases where this should raise a wrong-type-arg error, but for now... */ + return (-1); +} + +static s7_pointer cons_unchecked_with_type(s7_scheme * sc, s7_pointer p, + s7_pointer a, s7_pointer b); + +static s7_pointer copy_tree_with_type(s7_scheme * sc, s7_pointer tree) +{ + /* if sc->safety > NO_SAFETY, '(1 2) is set immutable by the reader, but eval (in that safety case) calls + * copy_body on the incoming tree, so we have to preserve T_IMMUTABLE in that case. + * if tree is something like (+ 1 (car '#1=(2 . #1#))), we have to see the quoted list and not copy it. + * Before getting here, we have checked that there is room for the entire tree (in copy_body), or 8192 cells (in list_values) in the free heap. + */ +#if WITH_GCC +#define COPY_TREE_WITH_TYPE(P) ({s7_pointer _p; _p = P; \ + cons_unchecked_with_type(sc, _p, (is_unquoted_pair(car(_p))) ? copy_tree_with_type(sc, car(_p)) : car(_p), \ + (is_unquoted_pair(cdr(_p))) ? copy_tree_with_type(sc, cdr(_p)) : cdr(_p));}) +#else +#define COPY_TREE_WITH_TYPE(P) copy_tree_with_type(sc, P) +#endif + return (cons_unchecked_with_type(sc, tree, + (is_unquoted_pair(car(tree))) ? + COPY_TREE_WITH_TYPE(car(tree)) : + car(tree), + (is_unquoted_pair(cdr(tree))) ? + COPY_TREE_WITH_TYPE(cdr(tree)) : + cdr(tree))); +} + +static s7_pointer copy_tree(s7_scheme * sc, s7_pointer tree) +{ +#if WITH_GCC +#define COPY_TREE(P) ({s7_pointer _p; _p = P; \ + cons_unchecked(sc, (is_unquoted_pair(car(_p))) ? copy_tree(sc, car(_p)) : car(_p), \ + (is_pair(cdr(_p))) ? copy_tree(sc, cdr(_p)) : cdr(_p));}) +#else +#define COPY_TREE(P) copy_tree(sc, P) +#endif + return (cons_unchecked(sc, + (is_unquoted_pair(car(tree))) ? + COPY_TREE(car(tree)) : car(tree), + (is_pair(cdr(tree))) ? COPY_TREE(cdr(tree)) : + cdr(tree))); +} + + +/* -------------------------------- tree-cyclic? -------------------------------- */ +#define TREE_NOT_CYCLIC 0 +#define TREE_CYCLIC 1 +#define TREE_HAS_PAIRS 2 + +static int tree_is_cyclic_or_has_pairs(s7_scheme * sc, s7_pointer tree) +{ + s7_pointer fast = tree, slow = tree; /* we assume tree is a pair */ + bool has_pairs = false; + while (true) { + if (tree_is_collected(fast)) + return (TREE_CYCLIC); + if ((!has_pairs) && (is_unquoted_pair(car(fast)))) + has_pairs = true; + fast = cdr(fast); + if (!is_pair(fast)) { + if (!has_pairs) + return (TREE_NOT_CYCLIC); + break; + } + if (tree_is_collected(fast)) + return (TREE_CYCLIC); + if ((!has_pairs) && (is_unquoted_pair(car(fast)))) + has_pairs = true; + fast = cdr(fast); + if (!is_pair(fast)) { + if (!has_pairs) + return (TREE_NOT_CYCLIC); + break; + } + slow = cdr(slow); + if (fast == slow) + return (TREE_CYCLIC); + } + return (TREE_HAS_PAIRS); +} + +/* we can't use shared_info here because tree_is_cyclic may be called in the midst of output that depends on sc->circle_info */ + +static bool tree_is_cyclic_1(s7_scheme * sc, s7_pointer tree) +{ + s7_pointer p; + for (p = tree; is_pair(p); p = cdr(p)) { + tree_set_collected(p); + if (sc->tree_pointers_top == sc->tree_pointers_size) { + if (sc->tree_pointers_size == 0) { + sc->tree_pointers_size = 8; + sc->tree_pointers = + (s7_pointer *) Malloc(sc->tree_pointers_size * + sizeof(s7_pointer)); + } else { + sc->tree_pointers_size *= 2; + sc->tree_pointers = + (s7_pointer *) Realloc(sc->tree_pointers, + sc->tree_pointers_size * + sizeof(s7_pointer)); + } + } + sc->tree_pointers[sc->tree_pointers_top++] = p; + if (is_unquoted_pair(car(p))) { + int32_t i, old_top = sc->tree_pointers_top, result; + result = tree_is_cyclic_or_has_pairs(sc, car(p)); + if ((result == TREE_CYCLIC) || (tree_is_cyclic_1(sc, car(p)))) + return (true); + for (i = old_top; i < sc->tree_pointers_top; i++) + tree_clear_collected(sc->tree_pointers[i]); + sc->tree_pointers_top = old_top; + } + } + return (false); +} + +static bool tree_is_cyclic(s7_scheme * sc, s7_pointer tree) +{ + int32_t i, result; + if (!is_pair(tree)) + return (false); + result = tree_is_cyclic_or_has_pairs(sc, tree); + if (result == TREE_NOT_CYCLIC) + return (false); + if (result == TREE_CYCLIC) + return (true); + result = tree_is_cyclic_1(sc, tree); + for (i = 0; i < sc->tree_pointers_top; i++) + tree_clear_collected(sc->tree_pointers[i]); + sc->tree_pointers_top = 0; + return (result); +} + +static s7_pointer g_tree_is_cyclic(s7_scheme * sc, s7_pointer args) +{ +#define H_tree_is_cyclic "(tree-cyclic? tree) returns #t if the tree has a cycle." +#define Q_tree_is_cyclic sc->pl_bt + return (make_boolean(sc, tree_is_cyclic(sc, car(args)))); +} + +static inline s7_int tree_len(s7_scheme * sc, s7_pointer p); + +static s7_pointer copy_body(s7_scheme * sc, s7_pointer p) +{ + sc->w = p; + if (tree_is_cyclic(sc, p)) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, "copy: tree is cyclic: ~S", + 24), p)); + check_free_heap_size(sc, tree_len(sc, p) * 2); + return ((sc->safety > NO_SAFETY) ? copy_tree_with_type(sc, + p) : + copy_tree(sc, p)); +} + +static s7_pointer copy_closure(s7_scheme * sc, s7_pointer fnc) +{ + /* copy the source tree annotating (for eventual optimization), return a thing of the same type as fnc */ + s7_pointer x, body; + + body = copy_body(sc, closure_body(fnc)); + if ((is_any_macro(fnc)) && (has_pair_macro(fnc))) { + set_pair_macro(body, pair_macro(closure_body(fnc))); + set_has_pair_macro(fnc); + } + new_cell(sc, x, full_type(fnc) & (~T_COLLECTED)); /* I'm paranoid about that is_collected bit */ + closure_set_args(x, closure_args(fnc)); + closure_set_body(x, body); + closure_set_setter(x, closure_setter(fnc)); + closure_set_arity(x, closure_arity(fnc)); + closure_set_let(x, closure_let(fnc)); + return (x); +} + + +/* -------------------------------- defined? -------------------------------- */ +static s7_pointer g_is_defined(s7_scheme * sc, s7_pointer args) +{ +#define H_is_defined "(defined? symbol (let (curlet)) ignore-globals) returns #t if symbol has a binding (a value) in the environment let. Only let is searched if ignore-globals is not #f." +#define Q_is_defined s7_make_signature(sc, 4, sc->is_boolean_symbol, sc->is_symbol_symbol, sc->is_let_symbol, sc->is_boolean_symbol) + + /* if the symbol has a global slot and e is unset or rootlet, this returns #t */ + s7_pointer sym = car(args); + if (!is_symbol(sym)) + return (method_or_bust + (sc, sym, sc->is_defined_symbol, args, T_SYMBOL, 1)); + + if (is_pair(cdr(args))) { + s7_pointer e = cadr(args), b, x; + + if (!is_let(e)) + return (wrong_type_argument_with_type + (sc, sc->is_defined_symbol, 2, e, a_let_string)); + if (e == sc->s7_let) + return (make_boolean(sc, symbol_s7_let(sym) != 0)); + + if (is_pair(cddr(args))) { + b = caddr(args); + if (!s7_is_boolean(b)) + return (method_or_bust_with_type + (sc, b, sc->is_defined_symbol, args, + a_boolean_string, 3)); + } else + b = sc->F; + + if (e == sc->rootlet) { /* we checked (let? e) above */ + if (b == sc->F) + return (make_boolean(sc, is_slot(global_slot(sym)))); /* new_symbol and gensym initialize global_slot to # */ + return (sc->F); + } + + x = symbol_to_local_slot(sc, sym, e); + if (is_slot(x)) + return (sc->T); + return ((b == sc->T) ? sc->F : make_boolean(sc, + is_slot(global_slot + (sym)))); + } + return ((is_global(sym)) ? sc->T : make_boolean(sc, + is_slot + (lookup_slot_from + (sym, sc->curlet)))); +} + +static s7_pointer g_is_defined_in_rootlet(s7_scheme * sc, s7_pointer args) +{ + /* here we know arg2=(rootlet), and no arg3, arg1 is a symbol that needs to be looked-up */ + s7_pointer sym; + sym = lookup(sc, car(args)); + if (!is_symbol(sym)) + return (method_or_bust + (sc, sym, sc->is_defined_symbol, args, T_SYMBOL, 1)); + return (make_boolean(sc, is_slot(global_slot(sym)))); +} + +static s7_pointer is_defined_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + if (!ops) + return (f); + if ((args == 2) && (is_symbol(cadr(expr)))) { + s7_pointer e = caddr(expr); + if ((is_pair(e)) && (is_null(cdr(e))) + && (car(e) == sc->rootlet_symbol)) { + set_safe_optimize_op(expr, HOP_SAFE_C_NC); + return (sc->is_defined_in_rootlet); + } + } + return (f); +} + +bool s7_is_defined(s7_scheme * sc, const char *name) +{ + s7_pointer x; + x = s7_symbol_table_find_name(sc, name); + if (!x) + return (false); + x = lookup_slot_from(x, sc->curlet); + return (is_slot(x)); +} + +static bool is_defined_b_7p(s7_scheme * sc, s7_pointer p) +{ + if (!is_symbol(p)) + return (method_or_bust + (sc, p, sc->is_defined_symbol, set_plist_1(sc, p), + T_SYMBOL, 1) != sc->F); + return (is_slot(lookup_slot_from(p, sc->curlet))); +} + +static bool is_defined_b_7pp(s7_scheme * sc, s7_pointer p, s7_pointer e) +{ + return (g_is_defined(sc, set_plist_2(sc, p, e)) != sc->F); +} + + +void s7_define(s7_scheme * sc, s7_pointer let, s7_pointer symbol, + s7_pointer value) +{ + s7_pointer x; + if ((let == sc->nil) || (let == sc->rootlet)) + let = sc->shadow_rootlet; + x = symbol_to_local_slot(sc, symbol, let); + if (is_slot(x)) + slot_set_value_with_hook(x, value); + else { + s7_make_slot(sc, let, symbol, value); /* I think this means C code can override "constant" defs */ + /* if let is sc->nil or rootlet, s7_make_slot makes a permanent_slot */ + if ((let == sc->shadow_rootlet) && (!is_slot(global_slot(symbol)))) { + set_global(symbol); /* is_global => global_slot is usable -- is this a good idea? */ + set_global_slot(symbol, local_slot(symbol)); + } + } +} + +s7_pointer s7_define_variable(s7_scheme * sc, const char *name, + s7_pointer value) +{ + s7_pointer sym; + sym = make_symbol(sc, name); + s7_define(sc, sc->nil, sym, value); + return (sym); +} + +s7_pointer s7_define_variable_with_documentation(s7_scheme * sc, + const char *name, + s7_pointer value, + const char *help) +{ + s7_pointer sym; + sym = s7_define_variable(sc, name, value); + symbol_set_has_help(sym); + symbol_set_help(sym, copy_string(help)); + add_saved_pointer(sc, symbol_help(sym)); + return (sym); +} + +s7_pointer s7_define_constant_with_environment(s7_scheme * sc, + s7_pointer envir, + const char *name, + s7_pointer value) +{ + s7_pointer sym; + sym = make_symbol(sc, name); + s7_define(sc, envir, sym, value); + set_immutable(sym); + set_possibly_constant(sym); + set_immutable(global_slot(sym)); + set_immutable(local_slot(sym)); + return (sym); +} + +s7_pointer s7_define_constant(s7_scheme * sc, const char *name, + s7_pointer value) +{ + return (s7_define_constant_with_environment(sc, sc->nil, name, value)); +} + +/* (define (func a) (let ((cvar (+ a 1))) cvar)) (define-constant cvar 23) (func 1) -> ;can't bind an immutable object: cvar + * (let ((aaa 1)) (define-constant aaa 32) (set! aaa 3)) -> set!: can't alter immutable object: aaa + */ + +s7_pointer s7_define_constant_with_documentation(s7_scheme * sc, + const char *name, + s7_pointer value, + const char *help) +{ + s7_pointer sym; + sym = s7_define_constant(sc, name, value); + symbol_set_has_help(sym); + symbol_set_help(sym, copy_string(help)); + add_saved_pointer(sc, symbol_help(sym)); + return (value); /* inconsistent with variable above, but consistent with define_function? */ +} + + +/* -------------------------------- keyword? -------------------------------- */ +bool s7_is_keyword(s7_pointer obj) +{ + return (is_keyword(obj)); +} + +static s7_pointer g_is_keyword(s7_scheme * sc, s7_pointer args) +{ +#define H_is_keyword "(keyword? obj) returns #t if obj is a keyword, (keyword? :rest) -> #t" +#define Q_is_keyword sc->pl_bt + check_boolean_method(sc, is_keyword, sc->is_keyword_symbol, args); +} + + +/* -------------------------------- string->keyword -------------------------------- */ +s7_pointer s7_make_keyword(s7_scheme * sc, const char *key) +{ + s7_pointer sym; + block_t *b; + char *name; + size_t slen; + slen = (size_t) safe_strlen(key); + b = mallocate(sc, slen + 2); + name = (char *) block_data(b); + name[0] = ':'; + memcpy((void *) (name + 1), (void *) key, slen); + name[slen + 1] = '\0'; + sym = make_symbol_with_length(sc, name, slen + 1); /* keyword slot etc taken care of here (in new_symbol actually) */ + liberate(sc, b); + return (sym); +} + +static s7_pointer g_string_to_keyword(s7_scheme * sc, s7_pointer args) +{ +#define H_string_to_keyword "(string->keyword str) prepends ':' to str and defines that as a keyword" +#define Q_string_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_string_symbol) + + s7_pointer str = car(args); + if (!is_string(str)) + return (method_or_bust_one_arg + (sc, str, sc->string_to_keyword_symbol, args, T_STRING)); + if ((string_length(str) == 0) || (string_value(str)[0] == '\0')) + return (s7_error + (sc, sc->out_of_range_symbol, + set_elist_2(sc, + wrap_string(sc, + "string->keyword wants a non-null string: ~S", + 43), str))); + return (s7_make_keyword(sc, string_value(str))); +} + + +/* -------------------------------- keyword->symbol -------------------------------- */ +static s7_pointer g_keyword_to_symbol(s7_scheme * sc, s7_pointer args) +{ +#define H_keyword_to_symbol "(keyword->symbol key) returns a symbol with the same name as key but no prepended colon" +#define Q_keyword_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_keyword_symbol) + + s7_pointer sym = car(args); + if (!is_keyword(sym)) + return (method_or_bust_with_type_one_arg + (sc, sym, sc->keyword_to_symbol_symbol, args, + wrap_string(sc, "a keyword", 9))); + return (keyword_symbol(sym)); +} + +s7_pointer s7_keyword_to_symbol(s7_scheme * sc, s7_pointer key) +{ + return (keyword_symbol(key)); +} + + +/* -------------------------------- symbol->keyword -------------------------------- */ +#define symbol_to_keyword(Sc, Sym) s7_make_keyword(Sc, symbol_name(Sym)) + +static s7_pointer g_symbol_to_keyword(s7_scheme * sc, s7_pointer args) +{ +#define H_symbol_to_keyword "(symbol->keyword sym) returns a keyword with the same name as sym, but with a colon prepended" +#define Q_symbol_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_symbol_symbol) + + if (!is_symbol(car(args))) + return (method_or_bust_one_arg + (sc, car(args), sc->symbol_to_keyword_symbol, args, + T_SYMBOL)); + return (symbol_to_keyword(sc, car(args))); +} + + +/* -------------------------------- c-pointer? -------------------------------- */ +bool s7_is_c_pointer(s7_pointer arg) +{ + return (is_c_pointer(arg)); +} + +bool s7_is_c_pointer_of_type(s7_pointer arg, s7_pointer type) +{ + return ((is_c_pointer(arg)) && (c_pointer_type(arg) == type)); +} + +static s7_pointer g_is_c_pointer(s7_scheme * sc, s7_pointer args) +{ +#define H_is_c_pointer "(c-pointer? obj type) returns #t if obj is a C pointer being held in s7. If type is given, the c_pointer's type is also checked." +#define Q_is_c_pointer s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T) + + s7_pointer p = car(args); + if (is_c_pointer(p)) + return ((is_pair(cdr(args))) ? + make_boolean(sc, c_pointer_type(p) == cadr(args)) : sc->T); + if (!has_active_methods(sc, p)) + return (sc->F); + return (apply_boolean_method(sc, p, sc->is_c_pointer_symbol)); +} + + +/* -------------------------------- c-pointer -------------------------------- */ +void *s7_c_pointer(s7_pointer p) +{ + return (c_pointer(p)); +} + +void *s7_c_pointer_with_type(s7_scheme * sc, s7_pointer p, + s7_pointer expected_type, const char *caller, + s7_int argnum) +{ + if (!is_c_pointer(p)) + return (wrong_type_arg_error_prepackaged + (sc, wrap_string(sc, caller, strlen(caller)), + make_integer(sc, argnum), p, sc->unused, + sc->prepackaged_type_names[T_C_POINTER])); + if ((c_pointer(p) != NULL) && (c_pointer_type(p) != expected_type)) + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_5(sc, + wrap_string(sc, + "~S argument ~D got a pointer of type ~S, but expected ~S", + 56), wrap_string(sc, + caller, + strlen + (caller)), + make_integer(sc, argnum), + c_pointer_type(p), expected_type))); + return (c_pointer(p)); +} + +s7_pointer s7_make_c_pointer_with_type(s7_scheme * sc, void *ptr, + s7_pointer type, s7_pointer info) +{ + s7_pointer x; + new_cell(sc, x, T_C_POINTER); + c_pointer(x) = ptr; + c_pointer_type(x) = type; + c_pointer_info(x) = info; + c_pointer_weak1(x) = sc->F; + c_pointer_weak2(x) = sc->F; + return (x); +} + +s7_pointer s7_make_c_pointer(s7_scheme * sc, void *ptr) +{ + return (s7_make_c_pointer_with_type(sc, ptr, sc->F, sc->F)); +} + +static s7_pointer g_c_pointer(s7_scheme * sc, s7_pointer args) +{ +#define H_c_pointer "(c-pointer int type info weak1 weak2) returns a c-pointer object. The type and info args are optional, defaulting to #f." +#define Q_c_pointer s7_make_circular_signature(sc, 2, 3, sc->is_c_pointer_symbol, sc->is_integer_symbol, sc->T) + + s7_pointer arg = car(args), type = sc->F, info = sc->F, weak1 = + sc->F, weak2 = sc->F, cp; + intptr_t p; + + if (!s7_is_integer(arg)) + return (method_or_bust + (sc, arg, sc->c_pointer_symbol, args, T_INTEGER, 1)); + p = (intptr_t) s7_integer_checked(sc, arg); /* (c-pointer (bignum "1234")) */ + args = cdr(args); + if (is_pair(args)) { + type = car(args); + args = cdr(args); + if (is_pair(args)) { + info = car(args); + args = cdr(args); + if (is_pair(args)) { + weak1 = car(args); + args = cdr(args); + if (is_pair(args)) + weak2 = car(args); + } + } + } + cp = s7_make_c_pointer_with_type(sc, (void *) p, type, info); + c_pointer_set_weak1(cp, weak1); + c_pointer_set_weak2(cp, weak2); + if ((weak1 != sc->F) || (weak2 != sc->F)) + add_weak_ref(sc, cp); + return (cp); +} + + +/* -------------------------------- c-pointer-info -------------------------------- */ +static s7_pointer c_pointer_info_p_p(s7_scheme * sc, s7_pointer p) +{ + if (!is_c_pointer(p)) + return (method_or_bust_p + (sc, p, sc->c_pointer_info_symbol, T_C_POINTER)); + return (c_pointer_info(p)); +} + +static s7_pointer g_c_pointer_info(s7_scheme * sc, s7_pointer args) +{ +#define H_c_pointer_info "(c-pointer-info obj) returns the c-pointer info field" +#define Q_c_pointer_info s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol) + return (c_pointer_info_p_p(sc, car(args))); +} + + +/* -------------------------------- c-pointer-type -------------------------------- */ +s7_pointer s7_c_pointer_type(s7_pointer p) +{ + return ((is_c_pointer(p)) ? c_pointer_type(p) : NULL); +} + +static s7_pointer c_pointer_type_p_p(s7_scheme * sc, s7_pointer p) +{ + return ((is_c_pointer(p)) ? c_pointer_type(p) : + method_or_bust_p(sc, p, sc->c_pointer_type_symbol, + T_C_POINTER)); +} + +static s7_pointer g_c_pointer_type(s7_scheme * sc, s7_pointer args) +{ +#define H_c_pointer_type "(c-pointer-type obj) returns the c-pointer type field" +#define Q_c_pointer_type s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol) + return (c_pointer_type_p_p(sc, car(args))); +} + + +/* -------------------------------- c-pointer-weak1/2 -------------------------------- */ +static s7_pointer c_pointer_weak1_p_p(s7_scheme * sc, s7_pointer p) +{ + return ((is_c_pointer(p)) ? c_pointer_weak1(p) : + method_or_bust_p(sc, p, sc->c_pointer_weak1_symbol, + T_C_POINTER)); +} + +static s7_pointer g_c_pointer_weak1(s7_scheme * sc, s7_pointer args) +{ +#define H_c_pointer_weak1 "(c-pointer-weak1 obj) returns the c-pointer weak1 field" +#define Q_c_pointer_weak1 s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol) + return (c_pointer_weak1_p_p(sc, car(args))); +} + +static s7_pointer c_pointer_weak2_p_p(s7_scheme * sc, s7_pointer p) +{ + return ((is_c_pointer(p)) ? c_pointer_weak2(p) : + method_or_bust_p(sc, p, sc->c_pointer_weak2_symbol, + T_C_POINTER)); +} + +static s7_pointer g_c_pointer_weak2(s7_scheme * sc, s7_pointer args) +{ +#define H_c_pointer_weak2 "(c-pointer-weak2 obj) returns the c-pointer weak2 field" +#define Q_c_pointer_weak2 s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol) + return (c_pointer_weak2_p_p(sc, car(args))); +} + + +/* -------------------------------- c-pointer->list -------------------------------- */ +static s7_pointer g_c_pointer_to_list(s7_scheme * sc, s7_pointer args) +{ +#define H_c_pointer_to_list "(c-pointer->list obj) returns the c-pointer data as (list pointer-as-int type info)" +#define Q_c_pointer_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_c_pointer_symbol) + + s7_pointer p = car(args); + if (!is_c_pointer(p)) + return (method_or_bust + (sc, p, sc->c_pointer_to_list_symbol, args, T_C_POINTER, + 1)); + return (list_3 + (sc, make_integer(sc, (s7_int) ((intptr_t) c_pointer(p))), + c_pointer_type(p), c_pointer_info(p))); +} + + +/* -------------------------------- continuations and gotos -------------------------------- */ + +enum { NO_JUMP, CALL_WITH_EXIT_JUMP, THROW_JUMP, CATCH_JUMP, ERROR_JUMP, + ERROR_QUIT_JUMP +}; +enum { NO_SET_JUMP, READ_SET_JUMP, LOAD_SET_JUMP, DYNAMIC_WIND_SET_JUMP, + S7_CALL_SET_JUMP, EVAL_SET_JUMP +}; + + +/* ----------------------- continuation? -------------------------------- */ +static s7_pointer g_is_continuation(s7_scheme * sc, s7_pointer args) +{ +#define H_is_continuation "(continuation? obj) returns #t if obj is a continuation" +#define Q_is_continuation sc->pl_bt + check_boolean_method(sc, is_continuation, sc->is_continuation_symbol, + args); + /* is this the right thing? It returns #f for call-with-exit ("goto") because + * that form of continuation can't continue (via a jump back to its context). + */ +} + +static bool is_continuation_b_p(s7_pointer p) +{ + return (is_continuation(p)); +} + +#if S7_DEBUGGING +static s7_pointer check_wrap_return(s7_pointer lst) +{ + s7_pointer fast, slow; + for (fast = lst, slow = lst; is_pair(fast); + slow = cdr(slow), fast = cdr(fast)) { + if (is_matched_pair(fast)) + fprintf(stderr, "matched_pair not cleared\n"); + fast = cdr(fast); + if (!is_pair(fast)) + return (lst); + if (fast == slow) + return (lst); + if (is_matched_pair(fast)) + fprintf(stderr, "matched_pair not cleared\n"); + } + return (lst); +} +#endif + +static s7_pointer copy_any_list(s7_scheme * sc, s7_pointer a) +{ + s7_pointer slow, fast, p; +#if S7_DEBUGGING +#define wrap_return(W) do {fast = W; W = sc->nil; return(check_wrap_return(fast));} while (0) +#else +#define wrap_return(W) do {fast = W; W = sc->nil; return(fast);} while (0) +#endif + sc->w = list_1(sc, car(a)); + p = sc->w; + + slow = cdr(a); + fast = slow; + while (true) { + if (!is_pair(fast)) { + if (is_null(fast)) + wrap_return(sc->w); + set_cdr(p, fast); + wrap_return(sc->w); + } + + set_cdr(p, list_1(sc, car(fast))); + p = cdr(p); + + fast = cdr(fast); + if (!is_pair(fast)) { + if (is_null(fast)) + wrap_return(sc->w); + set_cdr(p, fast); + wrap_return(sc->w); + } + /* if unrolled further, it's a lot slower? */ + set_cdr(p, list_1_unchecked(sc, car(fast))); + p = cdr(p); + + fast = cdr(fast); + slow = cdr(slow); + if (fast == slow) { + /* try to preserve the original cyclic structure */ + s7_pointer p1, f1, p2, f2; + set_match_pair(a); + for (p1 = sc->w, f1 = a; !(is_matched_pair(cdr(f1))); + f1 = cdr(f1), p1 = cdr(p1)) + set_match_pair(f1); + for (p2 = sc->w, f2 = a; cdr(f1) != f2; + f2 = cdr(f2), p2 = cdr(p2)) + clear_match_pair(f2); + for (f1 = f2; is_pair(f1); f1 = cdr(f1), f2 = cdr(f2)) { + clear_match_pair(f1); + f1 = cdr(f1); + clear_match_pair(f1); + if (f1 == f2) + break; + } + clear_match_pair(a); + if (is_null(p1)) + set_cdr(p2, p2); + else + set_cdr(p1, p2); + wrap_return(sc->w); + } + } + wrap_return(sc->w); +} + +static s7_pointer copy_counter(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer nobj; + new_cell(sc, nobj, T_COUNTER); + counter_set_result(nobj, counter_result(obj)); + counter_set_list(nobj, counter_list(obj)); + counter_set_capture(nobj, counter_capture(obj)); + counter_set_let(nobj, counter_let(obj)); + counter_set_slots(nobj, counter_slots(obj)); + return (nobj); +} + +static void copy_stack_list_set_immutable(s7_scheme * sc, s7_pointer pold, + s7_pointer pnew) +{ + s7_pointer p1, p2, slow = pold; + for (p1 = pold, p2 = pnew; is_pair(p2); p1 = cdr(p1), p2 = cdr(p2)) { + if (is_immutable(p1)) + set_immutable(p2); + if (is_pair(cdr(p1))) { + p1 = cdr(p1); + p2 = cdr(p2); + if (is_immutable(p1)) + set_immutable(p2); + if (p1 == slow) + break; + slow = cdr(slow); + } + } +} + +static s7_pointer copy_stack(s7_scheme * sc, s7_pointer new_v, + s7_pointer old_v, int64_t top) +{ + int64_t i; + bool has_pairs = false; + s7_pointer *nv = stack_elements(new_v), *ov = stack_elements(old_v); + memcpy((void *) nv, (void *) ov, top * sizeof(s7_pointer)); + stack_clear_flags(new_v); + + s7_gc_on(sc, false); + if (stack_has_counters(old_v)) { + for (i = 2; i < top; i += 4) { + s7_pointer p = ov[i]; /* args */ + /* if op_gc_protect, any ov[i] (except op) can be a list, but it isn't the arglist, so it seems to be safe */ + if (is_pair(p)) { /* args need not be a list (it can be a port or #f, etc) */ + has_pairs = true; + if (is_null(cdr(p))) + nv[i] = cons_unchecked(sc, car(p), sc->nil); /* GC is off -- could uncheck list_2 et al also */ + else if ((is_pair(cdr(p))) && (is_null(cddr(p)))) + nv[i] = list_2_unchecked(sc, car(p), cadr(p)); + else + nv[i] = copy_any_list(sc, p); /* args (copy is needed -- see s7test.scm) */ + /* if op=eval_args4 for example, this has to be a proper list, and in many cases it doesn't need to be copied */ + copy_stack_list_set_immutable(sc, p, nv[i]); + } + /* lst can be dotted or circular here. The circular list only happens in a case like: + * (dynamic-wind (lambda () (eq? (let ((lst (cons 1 2))) (set-cdr! lst lst) lst) (call/cc (lambda (k) k)))) (lambda () #f) (lambda () #f)) + * proper_list_reverse_in_place(sc->args) is one reason we need to copy, another reuse_as_let + */ + else if (is_counter(p)) { /* these can only occur in this context (not in a list etc) */ + stack_set_has_counters(new_v); + nv[i] = copy_counter(sc, p); + } + } + } else + for (i = 2; i < top; i += 4) + if (is_pair(ov[i])) { + s7_pointer p = ov[i]; + has_pairs = true; + if (is_null(cdr(p))) + nv[i] = cons_unchecked(sc, car(p), sc->nil); + else if ((is_pair(cdr(p))) && (is_null(cddr(p)))) + nv[i] = list_2_unchecked(sc, car(p), cadr(p)); + else + nv[i] = copy_any_list(sc, p); /* args (copy is needed -- see s7test.scm) */ + copy_stack_list_set_immutable(sc, p, nv[i]); + } + if (has_pairs) + stack_set_has_pairs(new_v); + s7_gc_on(sc, true); + return (new_v); +} + +static s7_pointer copy_op_stack(s7_scheme * sc) +{ + s7_pointer nv; + int32_t len; + len = (int32_t) (sc->op_stack_now - sc->op_stack); + nv = make_simple_vector(sc, len); /* not sc->op_stack_size */ + if (len > 0) { + int32_t i; + s7_pointer *src, *dst; + src = sc->op_stack; + dst = (s7_pointer *) vector_elements(nv); + for (i = len; i > 0; i--) + *dst++ = *src++; + } + return (nv); +} + +/* -------------------------------- with-baffle -------------------------------- */ +/* (with-baffle . body) calls body guaranteeing that there can be no jumps into the + * middle of it from outside -- no outer evaluation of a continuation can jump across this + * barrier: The flip-side of call-with-exit. + */ + +static bool find_baffle(s7_scheme * sc, s7_int key) +{ + /* search backwards through sc->curlet for baffle_let with (continuation_)key as its baffle_key value */ + if (sc->baffle_ctr > 0) { + s7_pointer x; + for (x = sc->curlet; is_let(x); x = let_outlet(x)) + if ((is_baffle_let(x)) && (let_baffle_key(x) == key)) + return (true); + } + return (false); +} + +#define NOT_BAFFLED -1 + +static s7_int find_any_baffle(s7_scheme * sc) +{ + /* search backwards through sc->curlet for any sc->baffle_symbol -- called by s7_make_continuation to set continuation_key */ + if (sc->baffle_ctr > 0) { + s7_pointer x; + for (x = sc->curlet; is_let(x); x = let_outlet(x)) + if (is_baffle_let(x)) + return (let_baffle_key(x)); + } + return (NOT_BAFFLED); +} + +static void check_with_baffle(s7_scheme * sc) +{ + if (!s7_is_proper_list(sc, sc->code)) + eval_error(sc, "with-baffle: unexpected dot? ~A", 31, sc->code); + pair_set_syntax_op(sc->code, OP_WITH_BAFFLE_UNCHECKED); +} + +static bool op_with_baffle_unchecked(s7_scheme * sc) +{ + sc->code = cdr(sc->code); + if (is_null(sc->code)) { + sc->value = sc->nil; + return (true); + } + sc->curlet = make_let(sc, sc->curlet); + set_baffle_let(sc->curlet); + set_let_baffle_key(sc->curlet, sc->baffle_ctr++); + return (false); +} + + +/* -------------------------------- call/cc -------------------------------- */ +static void make_room_for_cc_stack(s7_scheme * sc) +{ + if ((int64_t) (sc->free_heap_top - sc->free_heap) < (int64_t) (sc->heap_size / 8)) { /* we probably never need this much space -- very often we don't need any */ + int64_t freed_heap; + freed_heap = call_gc(sc); + if (freed_heap < (int64_t) (sc->heap_size / 8)) + resize_heap(sc); + } +} + +s7_pointer s7_make_continuation(s7_scheme * sc) +{ + s7_pointer x, stack; + int64_t loc; + block_t *block; + + sc->continuation_counter++; + make_room_for_cc_stack(sc); + if (sc->continuation_counter > 2000) + call_gc(sc); /* gc time up, but run time down -- try big cache */ + + loc = current_stack_top(sc); + stack = make_simple_vector(sc, loc); + set_full_type(stack, T_STACK); + temp_stack_top(stack) = loc; + sc->temp8 = stack; + copy_stack(sc, stack, sc->stack, loc); + + new_cell(sc, x, T_CONTINUATION); + block = mallocate_block(sc); + continuation_block(x) = block; + continuation_set_stack(x, stack); + continuation_stack_size(x) = vector_length(continuation_stack(x)); + continuation_stack_start(x) = stack_elements(continuation_stack(x)); + continuation_stack_end(x) = + (s7_pointer *) (continuation_stack_start(x) + loc); + continuation_op_stack(x) = copy_op_stack(sc); + continuation_op_loc(x) = (int32_t) (sc->op_stack_now - sc->op_stack); + continuation_op_size(x) = sc->op_stack_size; + continuation_key(x) = find_any_baffle(sc); + continuation_name(x) = sc->F; + sc->temp8 = sc->nil; + + add_continuation(sc, x); + return (x); +} + +static void let_temp_done(s7_scheme * sc, s7_pointer args, s7_pointer code, + s7_pointer let); +static void let_temp_unwind(s7_scheme * sc, s7_pointer slot, + s7_pointer new_value); +static s7_pointer dynamic_unwind(s7_scheme * sc, s7_pointer func, + s7_pointer e); +static s7_pointer eval(s7_scheme * sc, opcode_t first_op); + +static bool check_for_dynamic_winds(s7_scheme * sc, s7_pointer c) +{ + /* called only from call_with_current_continuation. + * if call/cc jumps into a dynamic-wind, the init/finish funcs are wrapped in with-baffle + * so they'll complain. Otherwise we're supposed to re-run the init func before diving + * into the body. Similarly for let-temporarily. If a call/cc jumps out of a dynamic-wind + * body-func, we're supposed to call the finish-func. The continuation is called at + * current_stack_top(sc); the continuation form is at continuation_stack_top(c). + */ + int64_t i, top1, top2; + opcode_t op; + /* check sc->stack for dynamic-winds we're jumping out of + * we need to check from the current stack top down to where the continuation stack matches the current stack?? + * this was (i > 0), but that goes too far back; perhaps s7 should save the position of the call/cc invocation. + * also the two stacks can be different sizes (either can be larger) + */ + top1 = current_stack_top(sc); + top2 = continuation_stack_top(c); + for (i = top1 - 1; (i > 0) && ((i >= top2) + || (stack_code(sc->stack, i) != + stack_code(continuation_stack(c), + i))); i -= 4) { + op = stack_op(sc->stack, i); + switch (op) { + case OP_DYNAMIC_WIND: + case OP_LET_TEMP_DONE: + { + s7_pointer x; + int64_t j, s_base = 0; + x = stack_code(sc->stack, i); + for (j = 3; j < top2; j += 4) + if (((stack_op(continuation_stack(c), j) == + OP_DYNAMIC_WIND) + || (stack_op(continuation_stack(c), j) == + OP_LET_TEMP_DONE)) + && (x == stack_code(continuation_stack(c), j))) { + s_base = i; + break; + } + if (s_base == 0) { + if (op == OP_DYNAMIC_WIND) { + if (dynamic_wind_state(x) == DWIND_BODY) { + dynamic_wind_state(x) = DWIND_FINISH; + if (dynamic_wind_out(x) != sc->F) { + push_stack_direct(sc, OP_EVAL_DONE); + sc->args = sc->nil; + sc->code = dynamic_wind_out(x); + eval(sc, OP_APPLY); + } + } + } else + let_temp_done(sc, stack_args(sc->stack, i), + stack_code(sc->stack, i), + stack_let(sc->stack, i)); + } + } + break; + + case OP_DYNAMIC_UNWIND: + case OP_DYNAMIC_UNWIND_PROFILE: + stack_element(sc->stack, i) = (s7_pointer) OP_GC_PROTECT; + break; + + case OP_LET_TEMP_UNWIND: + let_temp_unwind(sc, stack_code(sc->stack, i), + stack_args(sc->stack, i)); + break; + + case OP_LET_TEMP_S7_UNWIND: + g_s7_let_set_fallback(sc, + set_plist_3(sc, sc->s7_let, + stack_code(sc->stack, i), + stack_args(sc->stack, i))); + break; + + case OP_BARRIER: + if (i > top2) /* otherwise it's some unproblematic outer eval-string? */ + return (false); /* but what if we've already evaluated a dynamic-wind closer? */ + break; + + case OP_DEACTIVATE_GOTO: /* here we're jumping out of an unrelated call-with-exit block */ + if (i > top2) + call_exit_active(stack_args(sc->stack, i)) = false; + break; + + case OP_UNWIND_INPUT: + if (stack_args(sc->stack, i) != sc->unused) + set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ + break; + + case OP_UNWIND_OUTPUT: + if (stack_args(sc->stack, i) != sc->unused) + set_current_output_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ + break; + + default: + break; + } + } + + /* check continuation-stack for dynamic-winds we're jumping into */ + for (i = current_stack_top(sc) - 1; i < top2; i += 4) { + op = stack_op(continuation_stack(c), i); + if (op == OP_DYNAMIC_WIND) { + s7_pointer x; + x = stack_code(continuation_stack(c), i); + if (dynamic_wind_in(x) != sc->F) { + push_stack_direct(sc, OP_EVAL_DONE); + sc->args = sc->nil; + sc->code = dynamic_wind_in(x); + eval(sc, OP_APPLY); + } + dynamic_wind_state(x) = DWIND_BODY; + } else if (op == OP_DEACTIVATE_GOTO) + call_exit_active(stack_args(continuation_stack(c), i)) = true; + /* not let_temp_done here! */ + /* if op == OP_LET_TEMP_DONE, we're jumping back into a let-temporarily. MIT and Chez scheme say they remember the + * let-temp vars (fluid-let or parameters in their terminology) at the point of the call/cc, and restore them + * on re-entry; that strikes me as incoherently complex -- they've wrapped a hidden dynamic-wind around the + * call/cc to restore all let-temp vars! I think let-temp here should be the same as let -- if you jump back + * in, nothing hidden happens. So, + * (let ((x #f) (cc #f)) (let-temporarily ((x 1)) (set! x 2) (call/cc (lambda (r) (set! cc r))) (display x) (unless (= x 2) (newline) (exit)) (set! x 3) (cc))) + * behaves the same (in this regard) if let-temp is replaced with let. + */ + } + return (true); +} + +static s7_pointer splice_in_values(s7_scheme * sc, s7_pointer args); + +static bool call_with_current_continuation(s7_scheme * sc) +{ + s7_pointer c = sc->code; + + /* check for (baffle ...) blocking the current attempt to continue */ + if ((continuation_key(c) != NOT_BAFFLED) && + (!(find_baffle(sc, continuation_key(c))))) + return (false); + + if (!check_for_dynamic_winds(sc, c)) + return (true); + + /* make_room_for_cc_stack(sc); *//* 28-May-21 */ + + /* we push_stack sc->code before calling an embedded eval above, so sc->code should still be c here, etc */ + if ((stack_has_pairs(continuation_stack(c))) || + (stack_has_counters(continuation_stack(c)))) { + make_room_for_cc_stack(sc); + copy_stack(sc, sc->stack, continuation_stack(c), + continuation_stack_top(c)); + } else { + s7_pointer *nv = stack_elements(sc->stack), *ov = + stack_elements(continuation_stack(c)); + memcpy((void *) nv, (void *) ov, + continuation_stack_top(c) * sizeof(s7_pointer)); + } + /* copy_stack(sc, sc->stack, continuation_stack(c), continuation_stack_top(c)); */ + sc->stack_end = + (s7_pointer *) (sc->stack_start + continuation_stack_top(c)); + + { + int32_t i, top = continuation_op_loc(c); + s7_pointer *src, *dst; + + sc->op_stack_now = (s7_pointer *) (sc->op_stack + top); + sc->op_stack_size = continuation_op_size(c); + sc->op_stack_end = + (s7_pointer *) (sc->op_stack + sc->op_stack_size); + src = (s7_pointer *) vector_elements(continuation_op_stack(c)); + dst = sc->op_stack; + for (i = 0; i < top; i++) + dst[i] = src[i]; + } + if (is_null(sc->args)) + sc->value = sc->nil; + else + sc->value = + (is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc, + sc->args); + return (true); +} + +static s7_pointer g_call_cc(s7_scheme * sc, s7_pointer args) +{ +#define H_call_cc "(call-with-current-continuation (lambda (continuer)...)) is always a mistake!" +#define Q_call_cc s7_make_signature(sc, 2, sc->T, sc->is_procedure_symbol) + + s7_pointer p = car(args); /* this is the procedure passed to call/cc */ + if (!is_t_procedure(p)) { /* this includes continuations */ + check_method(sc, p, sc->call_cc_symbol, args); + check_method(sc, p, sc->call_with_current_continuation_symbol, + args); + return (simple_wrong_type_argument_with_type + (sc, sc->call_cc_symbol, p, a_procedure_string)); + } + if (((!is_closure(p)) || + (closure_arity(p) != 1)) && (!s7_is_aritable(sc, p, 1))) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "call/cc procedure, ~A, should take one argument", + 47), p))); + + sc->w = s7_make_continuation(sc); + if ((is_any_closure(p)) && (is_pair(closure_args(p))) + && (is_symbol(car(closure_args(p))))) + continuation_name(sc->w) = car(closure_args(p)); + push_stack(sc, OP_APPLY, list_1_unchecked(sc, sc->w), p); /* apply function p to continuation sc->w */ + sc->w = sc->nil; + return (sc->nil); +} + +/* we can't naively optimize call/cc to call-with-exit if the continuation is only + * used as a function in the call/cc body because it might (for example) be wrapped + * in a lambda form that is being exported. See b-func in s7test for an example. + */ +static void apply_continuation(s7_scheme * sc) +{ /* sc->code is the continuation */ + if (!call_with_current_continuation(sc)) + s7_error(sc, sc->baffled_symbol, + (is_symbol(continuation_name(sc->code))) ? + set_elist_2(sc, + wrap_string(sc, + "continuation ~S can't jump into with-baffle", + 43), + continuation_name(sc->code)) : set_elist_1(sc, + wrap_string + (sc, + "continuation can't jump into with-baffle", + 40))); +} + +static void op_call_cc(s7_scheme * sc) +{ + sc->w = s7_make_continuation(sc); + continuation_name(sc->w) = caar(opt2_pair(sc->code)); /* caadadr(sc->code) */ + sc->curlet = + make_let_with_slot(sc, sc->curlet, continuation_name(sc->w), + sc->w); + sc->w = sc->nil; + sc->code = cdr(opt2_pair(sc->code)); /* cddadr(sc->code) */ +} + +static bool op_implicit_continuation_a(s7_scheme * sc) +{ + s7_pointer s, code = sc->code; /* dumb-looking code, but it's faster than the pretty version, according to callgrind */ + s = lookup_checked(sc, car(code)); + if (!is_continuation(s)) { + sc->last_function = s; + return (false); + } + sc->code = s; + sc->args = set_plist_1(sc, fx_call(sc, cdr(code))); + apply_continuation(sc); + return (true); +} + + +/* -------------------------------- call-with-exit -------------------------------- */ + +static void pop_input_port(s7_scheme * sc); + +static void call_with_exit(s7_scheme * sc) +{ + int64_t i, new_stack_top, quit = 0; + + if (!call_exit_active(sc->code)) + s7_error(sc, sc->invalid_escape_function_symbol, + set_elist_1(sc, + wrap_string(sc, + "call-with-exit escape procedure called outside its block", + 56))); + + call_exit_active(sc->code) = false; + new_stack_top = call_exit_goto_loc(sc->code); + sc->op_stack_now = + (s7_pointer *) (sc->op_stack + call_exit_op_loc(sc->code)); + + /* look for dynamic-wind in the stack section that we are jumping out of */ + i = current_stack_top(sc) - 1; + do { + switch (stack_op(sc->stack, i)) { /* avoidable if we group these ops at the end and use op< */ + case OP_DYNAMIC_WIND: + { + s7_pointer lx; + lx = stack_code(sc->stack, i); + if (dynamic_wind_state(lx) == DWIND_BODY) { + dynamic_wind_state(lx) = DWIND_FINISH; + if (dynamic_wind_out(lx) != sc->F) { + s7_pointer arg; + /* protect the sc->args value across this call if it is sc->plist_1 -- I can't find a broken case */ + arg = (sc->args == sc->plist_1) ? car(sc->plist_1) : sc->unused; /* might also need GC protection here */ + push_stack_direct(sc, OP_EVAL_DONE); + sc->args = sc->nil; + sc->code = dynamic_wind_out(lx); + eval(sc, OP_APPLY); + if (arg != sc->unused) + set_plist_1(sc, arg); + } + } + } + break; + + case OP_DYNAMIC_UNWIND: + case OP_DYNAMIC_UNWIND_PROFILE: + stack_element(sc->stack, i) = (s7_pointer) OP_GC_PROTECT; + dynamic_unwind(sc, stack_code(sc->stack, i), + stack_args(sc->stack, i)); + break; + + case OP_EVAL_STRING: + s7_close_input_port(sc, current_input_port(sc)); + pop_input_port(sc); + break; + + case OP_BARRIER: /* oops -- we almost certainly went too far */ + goto SET_VALUE; + + case OP_DEACTIVATE_GOTO: /* here we're jumping into an unrelated call-with-exit block */ + call_exit_active(stack_args(sc->stack, i)) = false; + break; + + case OP_LET_TEMP_DONE: + let_temp_done(sc, stack_args(sc->stack, i), + stack_code(sc->stack, i), stack_let(sc->stack, + i)); + break; + + case OP_LET_TEMP_UNWIND: + let_temp_unwind(sc, stack_code(sc->stack, i), + stack_args(sc->stack, i)); + break; + + case OP_LET_TEMP_S7_UNWIND: + g_s7_let_set_fallback(sc, + set_plist_3(sc, sc->s7_let, + stack_code(sc->stack, i), + stack_args(sc->stack, i))); + break; + + /* call/cc does not close files, but I think call-with-exit should */ + case OP_GET_OUTPUT_STRING: + case OP_UNWIND_OUTPUT: + { + s7_pointer x = stack_code(sc->stack, i); /* "code" = port that we opened */ + s7_close_output_port(sc, x); + x = stack_args(sc->stack, i); /* "args" = port that we shadowed, if not # */ + if (x != sc->unused) + set_current_output_port(sc, x); + } + break; + + case OP_UNWIND_INPUT: + s7_close_input_port(sc, stack_code(sc->stack, i)); /* "code" = port that we opened */ + if (stack_args(sc->stack, i) != sc->unused) + set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ + break; + + case OP_EVAL_DONE: /* goto called in a method -- put off the inner eval return(s) until we clean up the stack */ + quit++; + break; + + default: + break; + } + i -= 4; + } while (i > new_stack_top); + + SET_VALUE: + sc->stack_end = (s7_pointer *) (sc->stack_start + new_stack_top); + + /* the return value should have an implicit values call, just as in call/cc */ + if (is_null(sc->args)) + sc->value = sc->nil; + else + sc->value = + (is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc, + sc->args); + + if (quit > 0) { + if (sc->longjmp_ok) { + pop_stack(sc); + LongJmp(sc->goto_start, CALL_WITH_EXIT_JUMP); + } + for (i = 0; i < quit; i++) + push_stack_op_let(sc, OP_EVAL_DONE); + } +} + +static s7_pointer g_is_goto(s7_scheme * sc, s7_pointer args) +{ +#define H_is_goto "(goto? obj) returns #t if obj is a call-with-exit exit function" +#define Q_is_goto sc->pl_bt + return (make_boolean(sc, is_goto(car(args)))); +} + +static inline s7_pointer make_goto(s7_scheme * sc, s7_pointer name) +{ + s7_pointer x; + new_cell(sc, x, T_GOTO); + call_exit_goto_loc(x) = current_stack_top(sc); + call_exit_op_loc(x) = (int32_t) (sc->op_stack_now - sc->op_stack); + call_exit_active(x) = true; + call_exit_name(x) = name; + return (x); +} + +static s7_pointer g_call_with_exit(s7_scheme * sc, s7_pointer args) +{ /* (call-with-exit (lambda (return) ...)) */ +#define H_call_with_exit "(call-with-exit (lambda (exiter) ...)) is call/cc without the ability to jump back into a previous computation." +#define Q_call_with_exit s7_make_signature(sc, 2, sc->values_symbol, sc->is_procedure_symbol) + + s7_pointer p = car(args), x; + if (is_any_closure(p)) { + x = make_goto(sc, + ((is_any_closure(p)) && (is_pair(closure_args(p))) + && (is_symbol(car(closure_args(p))))) ? + car(closure_args(p)) : sc->F); + push_stack(sc, OP_DEACTIVATE_GOTO, x, p); /* this means call-with-exit is not tail-recursive */ + push_stack(sc, OP_APPLY, cons_unchecked(sc, x, sc->nil), p); + return (sc->nil); + } + + if (!is_t_procedure(p)) /* this includes continuations */ + return (method_or_bust_with_type_one_arg + (sc, p, sc->call_with_exit_symbol, args, + a_procedure_string)); + + x = make_goto(sc, ((is_any_closure(p)) && (is_pair(closure_args(p))) + && (is_symbol(car(closure_args(p))))) ? + car(closure_args(p)) : sc->F); + if ((is_any_c_function(p)) && (s7_is_aritable(sc, p, 1))) { + call_exit_active(x) = false; + return ((is_c_function(p)) ? + c_function_call(p) (sc, + set_plist_1(sc, + x)) : + s7_apply_function_star(sc, p, set_plist_1(sc, x))); + } + push_stack(sc, OP_DEACTIVATE_GOTO, x, p); /* this means call-with-exit is not tail-recursive */ + push_stack(sc, OP_APPLY, cons_unchecked(sc, x, sc->nil), p); + return (sc->nil); + /* this is why call-with-exit is declared an unsafe_defun: a safe function returns its value, but an unsafe one + * can await a further evaluation (the call-with-exit body). The sc->nil returned value is ignored. + */ +} + +static inline void op_call_with_exit(s7_scheme * sc) +{ + s7_pointer go, args = opt2_pair(sc->code); + go = make_goto(sc, caar(args)); + push_stack_no_let_no_code(sc, OP_DEACTIVATE_GOTO, go); /* was also pushing code */ + sc->curlet = make_let_with_slot(sc, sc->curlet, caar(args), go); + sc->code = T_Pair(cdr(args)); +} + +static void op_call_with_exit_o(s7_scheme * sc) +{ + op_call_with_exit(sc); + sc->code = car(sc->code); +} + +static bool op_implicit_goto(s7_scheme * sc) +{ + s7_pointer g; + g = lookup_checked(sc, car(sc->code)); + if (!is_goto(g)) { + sc->last_function = g; + return (false); + } + sc->args = sc->nil; + sc->code = g; + call_with_exit(sc); + return (true); +} + +static bool op_implicit_goto_a(s7_scheme * sc) +{ + s7_pointer g; + g = lookup_checked(sc, car(sc->code)); + if (!is_goto(g)) { + sc->last_function = g; + return (false); + } + sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code))); + sc->code = g; + call_with_exit(sc); + return (true); +} + + +/* -------------------------------- numbers -------------------------------- */ + +static block_t *string_to_block(s7_scheme * sc, const char *p, s7_int len) +{ + block_t *b; + char *bp; + b = mallocate(sc, len + 1); + bp = (char *) block_data(b); + memcpy((void *) bp, (void *) p, len); + bp[len] = '\0'; + return (b); +} + +static s7_pointer block_to_string(s7_scheme * sc, block_t * block, + s7_int len) +{ + s7_pointer x; + new_cell(sc, x, T_STRING | T_SAFE_PROCEDURE); + string_block(x) = block; + string_value(x) = (char *) block_data(block); + string_length(x) = len; + string_value(x)[len] = '\0'; + string_hash(x) = 0; + add_string(sc, x); + return (x); +} + +static inline s7_pointer make_simple_ratio(s7_scheme * sc, s7_int num, + s7_int den) +{ + s7_pointer x; + if (den == 1) + return (make_integer(sc, num)); + if (den == -1) + return (make_integer(sc, -num)); + if ((den == S7_INT64_MIN) && ((num & 1) != 0)) + return (make_real(sc, (long_double) num / (long_double) den)); + new_cell(sc, x, T_RATIO); + if (den < 0) { + numerator(x) = -num; + denominator(x) = -den; + } else { + numerator(x) = num; + denominator(x) = den; + } + return (x); +} + +static bool is_zero(s7_scheme * sc, s7_pointer x); +static bool is_positive(s7_scheme * sc, s7_pointer x); +static bool is_negative(s7_scheme * sc, s7_pointer x); +static s7_pointer make_ratio(s7_scheme * sc, s7_int a, s7_int b); + +static bool is_NaN(s7_double x) +{ + return (x != x); +} + +/* callgrind says this is faster than isnan, I think (very confusing data...) */ + +#if defined(__sun) && defined(__SVR4) +static bool is_inf(s7_double x) +{ + return ((x == x) && (is_NaN(x - x))); +} /* there's no isinf in Solaris */ +#else +#if (!MS_WINDOWS) +#if __cplusplus +#define is_inf(x) std::isinf(x) +#else +#define is_inf(x) isinf(x) +#endif +#else +static bool is_inf(s7_double x) +{ + return ((x == x) && (is_NaN(x - x))); +} /* Another possibility: (x * 0) != 0 */ + +#if (_MSC_VER < 1700) + /* in MS C, we need to provide inverse hyperbolic trig funcs and cbrt */ +static double asinh(double x) +{ + return (log(x + sqrt(1.0 + x * x))); +} + +static double acosh(double x) +{ + return (log(x + sqrt(x * x - 1.0))); +} + + /* perhaps less prone to numerical troubles (untested): 2.0 * log(sqrt(0.5 * (x + 1.0)) + sqrt(0.5 * (x - 1.0))) */ +static double atanh(double x) +{ + return (log((1.0 + x) / (1.0 - x)) / 2.0); +} + +static double cbrt(double x) +{ + if (x >= 0.0) + return (pow(x, 1.0 / 3.0)); + return (-pow(-x, 1.0 / 3.0)); +} +#endif +#endif /* windows */ +#endif /* not sun */ + + +#if WITH_GMP +static mp_prec_t mpc_precision = DEFAULT_BIGNUM_PRECISION; +static mp_prec_t mpc_set_default_precision(mp_prec_t prec) +{ + mpc_precision = prec; + return (prec); +} + +#define mpc_init(Z) mpc_init2(Z, mpc_precision) + +static bigint *alloc_bigint(s7_scheme * sc) +{ + bigint *p; + if (sc->bigints) { + p = sc->bigints; + sc->bigints = p->nxt; + } else { + p = (bigint *) malloc(sizeof(bigint)); + /* not permalloc here: gmp must be playing tricky games with realloc or something. permalloc can lead + * to mpz_set_si overwriting adjacent memory (valgrind does not catch this), clobbering at least the + * bigint nxt field. Someday I need to look at the source. + */ + mpz_init(p->n); + } + return (p); +} + +static bigrat *alloc_bigrat(s7_scheme * sc) +{ + bigrat *p; + if (sc->bigrats) { + p = sc->bigrats; + sc->bigrats = p->nxt; + } else { + p = (bigrat *) malloc(sizeof(bigrat)); + mpq_init(p->q); + } + return (p); +} + +static bigflt *alloc_bigflt(s7_scheme * sc) +{ + bigflt *p; + if (sc->bigflts) { + p = sc->bigflts; + sc->bigflts = p->nxt; + mpfr_set_prec(p->x, sc->bignum_precision); + } else { + p = (bigflt *) malloc(sizeof(bigflt)); + mpfr_init2(p->x, sc->bignum_precision); + } + return (p); +} + +static bigcmp *alloc_bigcmp(s7_scheme * sc) +{ + bigcmp *p; + if (sc->bigcmps) { + p = sc->bigcmps; + sc->bigcmps = p->nxt; + mpc_set_prec(p->z, sc->bignum_precision); + } else { + p = (bigcmp *) malloc(sizeof(bigcmp)); + mpc_init(p->z); + } + return (p); +} + +static s7_pointer mpz_to_big_integer(s7_scheme * sc, mpz_t val) +{ + s7_pointer x; + new_cell(sc, x, T_BIG_INTEGER); + big_integer_bgi(x) = alloc_bigint(sc); + mpz_set(big_integer(x), val); + add_big_integer(sc, x); + return (x); +} + +static s7_pointer mpz_to_integer(s7_scheme * sc, mpz_t val) +{ + if (mpz_fits_slong_p(val)) + return (make_integer(sc, mpz_get_si(val))); + return (mpz_to_big_integer(sc, val)); +} + +#if (!WITH_PURE_S7) +static s7_pointer mpz_to_big_real(s7_scheme * sc, mpz_t val) +{ + s7_pointer x; + new_cell(sc, x, T_BIG_REAL); + big_real_bgf(x) = alloc_bigflt(sc); + add_big_real(sc, x); + mpfr_set_z(big_real(x), val, MPFR_RNDN); + return (x); +} +#endif + +static s7_pointer mpq_to_big_ratio(s7_scheme * sc, mpq_t val) +{ + s7_pointer x; + new_cell(sc, x, T_BIG_RATIO); + big_ratio_bgr(x) = alloc_bigrat(sc); + add_big_ratio(sc, x); + mpq_set(big_ratio(x), val); + return (x); +} + +static s7_pointer mpq_to_rational(s7_scheme * sc, mpq_t val) +{ + if (mpz_cmp_ui(mpq_denref(val), 1) == 0) + return (mpz_to_integer(sc, mpq_numref(val))); +#if S7_DEBUGGING + mpq_canonicalize(val); + if (mpz_cmp_ui(mpq_denref(val), 1) == 0) { + fprintf(stderr, "mpq_to_rational: missing canonicalize\n"); + return (mpz_to_integer(sc, mpq_numref(val))); + } +#endif + if ((mpz_fits_slong_p(mpq_numref(val))) + && (mpz_fits_slong_p(mpq_denref(val)))) + return (make_simple_ratio + (sc, mpz_get_si(mpq_numref(val)), + mpz_get_si(mpq_denref(val)))); + return (mpq_to_big_ratio(sc, val)); +} + +static s7_pointer mpq_to_canonicalized_rational(s7_scheme * sc, mpq_t mpq) +{ + mpq_canonicalize(mpq); + return (mpq_to_rational(sc, mpq)); +} + +static s7_pointer mpz_to_rational(s7_scheme * sc, mpz_t n, mpz_t d) +{ /* mpz_3 and mpz_4 */ + if (mpz_cmp_ui(d, 1) == 0) + return (mpz_to_integer(sc, n)); + mpq_set_num(sc->mpq_1, n); + mpq_set_den(sc->mpq_1, d); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); +} + +#if (!WITH_PURE_S7) +static s7_pointer mpq_to_big_real(s7_scheme * sc, mpq_t val) +{ + s7_pointer x; + new_cell(sc, x, T_BIG_REAL); + big_real_bgf(x) = alloc_bigflt(sc); + add_big_real(sc, x); + mpfr_set_q(big_real(x), val, MPFR_RNDN); + return (x); +} +#endif + +static s7_pointer any_rational_to_mpq(s7_scheme * sc, s7_pointer z, + mpq_t bigq) +{ + switch (type(z)) { + case T_INTEGER: + mpq_set_si(bigq, integer(z), 1); + break; + case T_BIG_INTEGER: + mpq_set_z(bigq, big_integer(z)); + break; + case T_RATIO: + mpq_set_si(bigq, numerator(z), denominator(z)); + break; + case T_BIG_RATIO: + mpq_set(bigq, big_ratio(z)); + break; + } + return (z); +} + +static s7_pointer mpfr_to_integer(s7_scheme * sc, mpfr_t val) +{ + mpfr_get_z(sc->mpz_4, val, MPFR_RNDN); + return (mpz_to_integer(sc, sc->mpz_4)); +} + +static s7_pointer mpfr_to_big_real(s7_scheme * sc, mpfr_t val) +{ + s7_pointer x; + new_cell(sc, x, T_BIG_REAL); + add_big_real(sc, x); + big_real_bgf(x) = alloc_bigflt(sc); + mpfr_set(big_real(x), val, MPFR_RNDN); + return (x); +} + +static s7_pointer mpc_to_number(s7_scheme * sc, mpc_t val) +{ + s7_pointer x; + if (mpfr_zero_p(mpc_imagref(val))) + return (mpfr_to_big_real(sc, mpc_realref(val))); + new_cell(sc, x, T_BIG_COMPLEX); + big_complex_bgc(x) = alloc_bigcmp(sc); + add_big_complex(sc, x); + mpc_set(big_complex(x), val, MPC_RNDNN); + return (x); +} + +/* s7.h */ +mpz_t *s7_big_integer(s7_pointer x) +{ + return (&big_integer(x)); +} + +mpq_t *s7_big_ratio(s7_pointer x) +{ + return (&big_ratio(x)); +} + +mpfr_t *s7_big_real(s7_pointer x) +{ + return (&big_real(x)); +} + +mpc_t *s7_big_complex(s7_pointer x) +{ + return (&big_complex(x)); +} + +bool s7_is_big_integer(s7_pointer x) +{ + return (is_t_big_integer(x)); +} + +bool s7_is_big_ratio(s7_pointer x) +{ + return (is_t_big_ratio(x)); +} + +bool s7_is_big_real(s7_pointer x) +{ + return (is_t_big_real(x)); +} + +bool s7_is_big_complex(s7_pointer x) +{ + return (is_t_big_complex(x)); +} + +s7_pointer s7_make_big_integer(s7_scheme * sc, mpz_t * val) +{ + return (mpz_to_integer(sc, *val)); +} + +s7_pointer s7_make_big_ratio(s7_scheme * sc, mpq_t * val) +{ + return (mpq_to_rational(sc, *val)); +} + +s7_pointer s7_make_big_real(s7_scheme * sc, mpfr_t * val) +{ + return (mpfr_to_big_real(sc, *val)); +} + +s7_pointer s7_make_big_complex(s7_scheme * sc, mpc_t * val) +{ + return (mpc_to_number(sc, *val)); +} + +#if (!WITH_PURE_S7) +static s7_pointer big_integer_to_big_real(s7_scheme * sc, s7_pointer x) +{ + return (mpz_to_big_real(sc, big_integer(x))); +} + +static s7_pointer big_ratio_to_big_real(s7_scheme * sc, s7_pointer x) +{ + return (mpq_to_big_real(sc, big_ratio(x))); +} +#endif + +static s7_pointer s7_int_to_big_integer(s7_scheme * sc, s7_int val) +{ + s7_pointer x; + new_cell(sc, x, T_BIG_INTEGER); + big_integer_bgi(x) = alloc_bigint(sc); + mpz_set_si(big_integer(x), val); + add_big_integer(sc, x); + return (x); +} + +static s7_pointer s7_int_to_big_ratio(s7_scheme * sc, s7_int num, + s7_int den) +{ + /* (called only in g_bignum), den here always comes from denominator(x) or some positive constant so it is not negative */ + s7_pointer x; + new_cell(sc, x, T_BIG_RATIO); + big_ratio_bgr(x) = alloc_bigrat(sc); + add_big_ratio(sc, x); + mpq_set_si(big_ratio(x), num, den); + return (x); +} + +static s7_pointer s7_double_to_big_real(s7_scheme * sc, s7_double rl) +{ + s7_pointer x; + new_cell(sc, x, T_BIG_REAL); + big_real_bgf(x) = alloc_bigflt(sc); + add_big_real(sc, x); + mpfr_set_d(big_real(x), rl, MPFR_RNDN); + return (x); +} + +static s7_pointer s7_double_to_big_complex(s7_scheme * sc, s7_double rl, + s7_double im) +{ + s7_pointer x; + new_cell(sc, x, T_BIG_COMPLEX); + add_big_complex(sc, x); + big_complex_bgc(x) = alloc_bigcmp(sc); + mpc_set_d_d(big_complex(x), rl, im, MPC_RNDNN); + return (x); +} + +static s7_pointer big_pi(s7_scheme * sc) +{ + s7_pointer x; + new_cell(sc, x, T_BIG_REAL | T_IMMUTABLE); + big_real_bgf(x) = alloc_bigflt(sc); + add_big_real(sc, x); + mpfr_const_pi(big_real(x), MPFR_RNDN); + return (x); +} + +static bool is_integer_via_method(s7_scheme * sc, s7_pointer p) +{ + if (s7_is_integer(p)) + return (true); + if (has_active_methods(sc, p)) { + s7_pointer f; + f = find_method_with_let(sc, p, sc->is_integer_symbol); + if (f != sc->undefined) + return (is_true + (sc, call_method(sc, p, f, set_plist_1(sc, p)))); + } + return (false); +} + +#if (!WITH_PURE_S7) +static s7_pointer s7_number_to_big_real(s7_scheme * sc, s7_pointer p) +{ + s7_pointer x; + new_cell(sc, x, T_BIG_REAL); + big_real_bgf(x) = alloc_bigflt(sc); + add_big_real(sc, x); + + switch (type(p)) { + case T_INTEGER: + mpfr_set_si(big_real(x), integer(p), MPFR_RNDN); + break; + case T_RATIO: + /* here we can't use fraction(number(p)) even though that uses long_double division because + * there are lots of int64_t ratios that will still look the same. + * We have to do the actual bignum divide by hand. + */ + mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); + mpfr_set_q(big_real(x), sc->mpq_1, MPFR_RNDN); + break; + default: + mpfr_set_d(big_real(x), s7_real(p), MPFR_RNDN); + break; + } + return (x); +} +#endif + +static s7_pointer s7_number_to_big_complex(s7_scheme * sc, s7_pointer p) +{ + s7_pointer x; + new_cell(sc, x, T_BIG_COMPLEX); + big_complex_bgc(x) = alloc_bigcmp(sc); + add_big_complex(sc, x); + + switch (type(p)) { + case T_INTEGER: + mpc_set_si(big_complex(x), integer(p), MPC_RNDNN); + break; + case T_RATIO: + /* can't use fraction here */ + mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); + mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); + mpc_set_fr(big_complex(x), sc->mpfr_1, MPC_RNDNN); + break; + case T_REAL: + mpc_set_d(big_complex(x), s7_real(p), MPC_RNDNN); + break; + default: + mpc_set_d_d(big_complex(x), real_part(p), imag_part(p), MPC_RNDNN); + break; + } + return (x); +} + +static s7_pointer any_real_to_mpfr(s7_scheme * sc, s7_pointer p, + mpfr_t bigx) +{ + switch (type(p)) { + case T_INTEGER: + mpfr_set_si(bigx, integer(p), MPFR_RNDN); + break; + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); + mpfr_set_q(bigx, sc->mpq_1, MPFR_RNDN); + break; + case T_REAL: + mpfr_set_d(bigx, real(p), MPFR_RNDN); + if (is_NaN(real(p))) + return (real_NaN); + if (is_inf(real(p))) + return (real_infinity); + break; + case T_BIG_INTEGER: + mpfr_set_z(bigx, big_integer(p), MPFR_RNDN); + break; + case T_BIG_RATIO: + mpfr_set_q(bigx, big_ratio(p), MPFR_RNDN); + break; + case T_BIG_REAL: + mpfr_set(bigx, big_real(p), MPFR_RNDN); + if (mpfr_nan_p(big_real(p))) + return (real_NaN); + if (mpfr_inf_p(big_real(p))) + return (real_infinity); + break; + } + return (NULL); +} + +#define mpc_zero_p(z) ((mpfr_zero_p(mpc_realref(z))) && (mpfr_zero_p(mpc_imagref(z)))) + +static s7_pointer any_number_to_mpc(s7_scheme * sc, s7_pointer p, + mpc_t bigz) +{ + switch (type(p)) { + case T_INTEGER: + mpc_set_si(bigz, integer(p), MPC_RNDNN); + break; + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); + mpc_set_q(bigz, sc->mpq_1, MPC_RNDNN); + break; + case T_REAL: + if (is_NaN(real(p))) + return (real_NaN); + if (is_inf(real(p))) + return (real_infinity); + mpc_set_d(bigz, real(p), MPC_RNDNN); + break; + case T_COMPLEX: + if (is_NaN(imag_part(p))) + return (complex_NaN); + if (is_NaN(real_part(p))) + return (real_NaN); + mpc_set_d_d(bigz, real_part(p), imag_part(p), MPC_RNDNN); + break; + case T_BIG_INTEGER: + mpc_set_z(bigz, big_integer(p), MPC_RNDNN); + break; + case T_BIG_RATIO: + mpc_set_q(bigz, big_ratio(p), MPC_RNDNN); + break; + case T_BIG_REAL: + mpc_set_fr(bigz, big_real(p), MPC_RNDNN); + if (mpfr_nan_p(big_real(p))) + return (real_NaN); + if (mpfr_inf_p(big_real(p))) + return (real_infinity); + break; + case T_BIG_COMPLEX: + if (mpfr_nan_p(mpc_imagref(big_complex(p)))) + return (complex_NaN); + if (mpfr_nan_p(mpc_realref(big_complex(p)))) + return (real_NaN); + mpc_set(bigz, big_complex(p), MPC_RNDNN); + break; + } + return (NULL); +} + +static s7_pointer make_big_complex(s7_scheme * sc, mpfr_t rl, mpfr_t im) +{ + /* there is no mpc_get_str equivalent, so we need to split up str, use make_big_real to get the 2 halves, then mpc_init, then mpc_set_fr_fr */ + s7_pointer x; + new_cell(sc, x, T_BIG_COMPLEX); + big_complex_bgc(x) = alloc_bigcmp(sc); + add_big_complex(sc, x); + mpc_set_fr_fr(big_complex(x), rl, im, MPC_RNDNN); + return (x); +} + +static block_t *mpfr_to_string(s7_scheme * sc, mpfr_t val, int32_t radix) +{ + char *str; + mp_exp_t expptr; + int32_t ep; + s7_int i, len; + block_t *b, *btmp; + + if (mpfr_zero_p(val)) + return (string_to_block(sc, "0.0", 3)); + + if (mpfr_nan_p(val)) + return (string_to_block(sc, "+nan.0", 6)); + if (mpfr_inf_p(val)) + return ((mpfr_signbit(val) == 0) ? string_to_block(sc, "+inf.0", + 6) : + string_to_block(sc, "-inf.0", 6)); + + b = callocate(sc, sc->bignum_precision + 32); +#if 1 + str = + mpfr_get_str((char *) block_data(b), &expptr, radix, 0, val, + MPFR_RNDN); + ep = (int32_t) expptr; + len = safe_strlen(str); + + /* remove trailing 0's */ + for (i = len - 1; i > 3; i--) + if (str[i] != '0') + break; + if (i < len - 1) + str[i + 1] = '\0'; + + btmp = mallocate(sc, len + 64); + if (str[0] == '-') + snprintf((char *) block_data(btmp), len + 64, "-%c.%s%c%d", str[1], + (char *) (str + 2), (radix <= 10) ? 'E' : '@', ep - 1); + else + snprintf((char *) block_data(btmp), len + 64, "%c.%s%c%d", str[0], + (char *) (str + 1), (radix <= 10) ? 'E' : '@', ep - 1); + + liberate(sc, b); + return (btmp); +#else + /* this is dumb */ + mpfr_snprintf((char *) block_data(b), sc->bignum_precision + 32, "%.*RE", sc->bignum_precision, val); /* default precision is 1!! */ + return (b); +#endif +} + +static block_t *mpc_to_string(s7_scheme * sc, mpc_t val, int32_t radix, + use_write_t use_write) +{ + block_t *rl, *im, *tmp; + s7_int len; + + mpc_real(sc->mpfr_1, val, MPFR_RNDN); + rl = mpfr_to_string(sc, sc->mpfr_1, radix); + mpc_imag(sc->mpfr_2, val, MPFR_RNDN); + im = mpfr_to_string(sc, sc->mpfr_2, radix); + + len = + safe_strlen((char *) block_data(rl)) + + safe_strlen((char *) block_data(im)) + 128; + tmp = mallocate(sc, len); + snprintf((char *) block_data(tmp), len, "%s%s%si", + (char *) block_data(rl), + ((((char *) block_data(im))[0] == '-') + || (((char *) block_data(im))[0] == '+')) ? "" : "+", + (char *) block_data(im)); + + liberate(sc, rl); + liberate(sc, im); + return (tmp); +} + +static block_t *big_number_to_string_with_radix(s7_scheme * sc, + s7_pointer p, + int32_t radix, + s7_int width, + s7_int * nlen, + use_write_t use_write) +{ + block_t *str; + switch (type(p)) { + case T_BIG_INTEGER: + str = callocate(sc, mpz_sizeinbase(big_integer(p), radix) + 64); + mpz_get_str((char *) block_data(str), radix, big_integer(p)); + break; + case T_BIG_RATIO: + mpz_set(sc->mpz_1, mpq_numref(big_ratio(p))); + mpz_set(sc->mpz_2, mpq_denref(big_ratio(p))); + str = + callocate(sc, + mpz_sizeinbase(sc->mpz_1, + radix) + mpz_sizeinbase(sc->mpz_2, + radix) + 64); + mpq_get_str((char *) block_data(str), radix, big_ratio(p)); + break; + case T_BIG_REAL: + str = mpfr_to_string(sc, big_real(p), radix); + break; + default: + str = mpc_to_string(sc, big_complex(p), radix, use_write); + break; + } + if (width > 0) { + s7_int len; + len = safe_strlen((char *) block_data(str)); + if (width > len) { + int32_t spaces; + block_t *tmp; + tmp = (block_t *) mallocate(sc, width + 1); + spaces = width - len; + ((char *) block_data(tmp))[width] = '\0'; + memmove((void *) ((char *) block_data(tmp) + spaces), + (void *) block_data(str), len); + memset((void *) block_data(tmp), (int) ' ', spaces); + (*nlen) = width; + liberate(sc, str); + return (tmp); + } + (*nlen) = len; + } else + (*nlen) = safe_strlen((char *) block_data(str)); + return (str); +} + +static s7_pointer string_to_big_integer(s7_scheme * sc, const char *str, + int32_t radix) +{ + mpz_set_str(sc->mpz_4, + (str[0] == '+') ? (const char *) (str + 1) : str, radix); + return (mpz_to_integer(sc, sc->mpz_4)); +} + +static s7_pointer string_to_big_ratio(s7_scheme * sc, const char *str, + int32_t radix) +{ + s7_pointer x; + mpq_set_str(sc->mpq_1, str, radix); + mpq_canonicalize(sc->mpq_1); + if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) + return (mpz_to_integer(sc, mpq_numref(sc->mpq_1))); + new_cell(sc, x, T_BIG_RATIO); + big_ratio_bgr(x) = alloc_bigrat(sc); + add_big_ratio(sc, x); + mpq_set(big_ratio(x), sc->mpq_1); + return (x); +} + +static s7_pointer string_to_big_real(s7_scheme * sc, const char *str, + int32_t radix) +{ + s7_pointer x; + new_cell(sc, x, T_BIG_REAL); + big_real_bgf(x) = alloc_bigflt(sc); + add_big_real(sc, x); + mpfr_set_str(big_real(x), str, radix, MPFR_RNDN); + return (x); +} + +static s7_int string_to_integer(const char *str, int32_t radix, + bool *overflow); + +static s7_pointer string_to_either_integer(s7_scheme * sc, const char *str, + int32_t radix) +{ + s7_int val; + bool overflow = false; + val = string_to_integer(str, radix, &overflow); + if (!overflow) + return (make_integer(sc, val)); + return (string_to_big_integer(sc, str, radix)); +} + +static s7_pointer string_to_either_ratio(s7_scheme * sc, const char *nstr, + const char *dstr, int32_t radix) +{ + s7_int d; + bool overflow = false; + + /* gmp segfaults if passed a bignum/0 so this needs to check first that + * the denominator is not 0 before letting gmp screw up. Also, if the + * first character is '+', gmp returns 0! + */ + d = string_to_integer(dstr, radix, &overflow); + if (!overflow) { + s7_int n; + if (d == 0) + return (real_NaN); + + n = string_to_integer(nstr, radix, &overflow); + if (!overflow) + return (make_ratio(sc, n, d)); + } + if (nstr[0] == '+') + return (string_to_big_ratio(sc, (const char *) (nstr + 1), radix)); + return (string_to_big_ratio(sc, nstr, radix)); +} + +static s7_double string_to_double_with_radix(const char *ur_str, + int32_t radix, + bool *overflow); +static s7_pointer string_to_either_real(s7_scheme * sc, const char *str, + int32_t radix) +{ + bool overflow = false; + s7_double val; + val = string_to_double_with_radix((char *) str, radix, &overflow); + if (!overflow) + return (make_real(sc, val)); + return (string_to_big_real(sc, str, radix)); +} + +static s7_pointer string_to_either_complex_1(s7_scheme * sc, char *q, + char *slash1, char *ex1, + bool has_dec_point1, + int32_t radix, + s7_double * d_rl) +{ + bool overflow = false; + /* there's a real problem here -- we don't want to promote s7_double .1 to a bignum because + * its low order digits are garbage, causing (rationalize .1 0) to return 3602879701896397/36028797018963968 + * no matter what the bignum-precision. But we can't just fallback on gmp's reader because (for example) + * it reads 1/2+i or 1+0/0i as 1.0. Also format gets screwed up. And string->number signals an error + * where it should return #f. I wonder what to do. + */ + if ((has_dec_point1) || (ex1)) { + (*d_rl) = string_to_double_with_radix(q, radix, &overflow); + if (overflow) + return (string_to_big_real(sc, q, radix)); + } else { + if (slash1) { + s7_int n, d; + + /* q can include the slash and denominator */ + n = string_to_integer(q, radix, &overflow); + if (overflow) + return (string_to_big_ratio(sc, q, radix)); + d = string_to_integer(slash1, radix, &overflow); + if (!overflow) + (*d_rl) = (s7_double) n / (s7_double) d; + else + return (string_to_big_ratio(sc, q, radix)); + } else { + s7_int val; + + val = string_to_integer(q, radix, &overflow); + if (overflow) + return (string_to_big_integer(sc, q, radix)); + (*d_rl) = (s7_double) val; + } + } + if ((*d_rl) == -0.0) + (*d_rl) = 0.0; + return (NULL); +} + +static s7_pointer string_to_either_complex(s7_scheme * sc, char *q, + char *slash1, char *ex1, + bool has_dec_point1, char *plus, + char *slash2, char *ex2, + bool has_dec_point2, + int32_t radix, + int32_t has_plus_or_minus) +{ + /* this can be just about anything involving 2 real/ratio/int portions, +/- in between and 'i' at the end */ + double d_rl = 0.0, d_im = 0.0; + s7_pointer p_rl = NULL, p_im = NULL; + + p_rl = + string_to_either_complex_1(sc, q, slash1, ex1, has_dec_point1, + radix, &d_rl); + p_im = + string_to_either_complex_1(sc, plus, slash2, ex2, has_dec_point2, + radix, &d_im); + + if ((d_im == 0.0) && /* 1.0+0.0000000000000000000000000000i */ + ((!p_im) || (is_zero(sc, p_im)))) + return ((p_rl) ? p_rl : make_real(sc, d_rl)); + + if ((!p_rl) && (!p_im)) + return (s7_make_complex + (sc, d_rl, (has_plus_or_minus == -1) ? (-d_im) : d_im)); + + if (p_rl) + any_real_to_mpfr(sc, p_rl, sc->mpfr_1); + else + mpfr_set_d(sc->mpfr_1, d_rl, MPFR_RNDN); + + if (p_im) + any_real_to_mpfr(sc, p_im, sc->mpfr_2); + else + mpfr_set_d(sc->mpfr_2, d_im, MPFR_RNDN); + + if (has_plus_or_minus == -1) + mpfr_neg(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); + return (make_big_complex(sc, sc->mpfr_1, sc->mpfr_2)); +} + +static bool big_numbers_are_eqv(s7_scheme * sc, s7_pointer a, s7_pointer b) +{ + /* either or both can be big here, but not neither, and types might not match at all */ + switch (type(a)) { + case T_INTEGER: + return ((is_t_big_integer(b)) + && (mpz_cmp_si(big_integer(b), integer(a)) == 0)); + case T_BIG_INTEGER: + if (is_t_big_integer(b)) + return (mpz_cmp(big_integer(a), big_integer(b)) == 0); + return ((is_t_integer(b)) + && (mpz_cmp_si(big_integer(a), integer(b)) == 0)); + case T_RATIO: + if (!is_t_big_ratio(b)) + return (false); + mpq_set_si(sc->mpq_1, numerator(a), denominator(a)); + return (mpq_equal(sc->mpq_1, big_ratio(b))); + case T_BIG_RATIO: + if (is_t_big_ratio(b)) + return (mpq_equal(big_ratio(a), big_ratio(b))); + if (!is_t_ratio(b)) + return (false); + mpq_set_si(sc->mpq_1, numerator(b), denominator(b)); + return (mpq_equal(sc->mpq_1, big_ratio(a))); + case T_REAL: + if (is_NaN(real(a))) + return (false); + return ((is_t_big_real(b)) && (!mpfr_nan_p(big_real(b))) + && (mpfr_cmp_d(big_real(b), real(a)) == 0)); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(a))) + return (false); + if (is_t_big_real(b)) + return ((!mpfr_nan_p(big_real(b))) + && (mpfr_equal_p(big_real(a), big_real(b)))); + return ((is_t_real(b)) && (!is_NaN(real(b))) + && (mpfr_cmp_d(big_real(a), real(b)) == 0)); + case T_COMPLEX: + if ((is_NaN(real_part(a))) || (is_NaN(imag_part(a)))) + return (false); + if (!is_t_big_complex(b)) + return (false); + if ((mpfr_nan_p(mpc_realref(big_complex(b)))) + || (mpfr_nan_p(mpc_imagref(big_complex(b))))) + return (false); + mpc_set_d_d(sc->mpc_1, real_part(a), imag_part(a), MPC_RNDNN); + return (mpc_cmp(sc->mpc_1, big_complex(b)) == 0); + + case T_BIG_COMPLEX: + if ((mpfr_nan_p(mpc_realref(big_complex(a)))) + || (mpfr_nan_p(mpc_imagref(big_complex(a))))) + return (false); + if (is_t_big_complex(b)) { + if ((mpfr_nan_p(mpc_realref(big_complex(b)))) + || (mpfr_nan_p(mpc_imagref(big_complex(b))))) + return (false); + return (mpc_cmp(big_complex(a), big_complex(b)) == 0); + } + if (is_t_complex(b)) { + if ((is_NaN(real_part(b))) || (is_NaN(imag_part(b)))) + return (false); + mpc_set_d_d(sc->mpc_2, real_part(b), imag_part(b), MPC_RNDNN); + return (mpc_cmp(big_complex(a), sc->mpc_1) == 0); + } + } + return (false); +} + +static s7_int big_integer_to_s7_int(s7_scheme * sc, mpz_t n) +{ + if (!mpz_fits_slong_p(n)) + s7_error(sc, sc->out_of_range_symbol, + set_elist_2(sc, + wrap_string(sc, + "big int does not fit in s7_int: ~S", + 34), mpz_to_big_integer(sc, n))); + return (mpz_get_si(n)); +} +#endif + +#ifndef HAVE_OVERFLOW_CHECKS +#if ((defined(__clang__) && (!POINTER_32) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4))) || (defined(__GNUC__) && __GNUC__ >= 5)) +#define HAVE_OVERFLOW_CHECKS 1 +#else +#define HAVE_OVERFLOW_CHECKS 0 +#pragma message("no arithmetic overflow checks in this version of s7") +#endif +#endif + +#if (defined(__clang__) && (!POINTER_32) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4))) +#define subtract_overflow(A, B, C) __builtin_ssubll_overflow((long long)A, (long long)B, (long long *)C) +#define add_overflow(A, B, C) __builtin_saddll_overflow((long long)A, (long long)B, (long long *)C) +#define multiply_overflow(A, B, C) __builtin_smulll_overflow((long long)A, (long long)B, (long long *)C) + /* #define int32_subtract_overflow(A, B, C) __builtin_ssub_overflow(A, B, C) */ +#define int32_add_overflow(A, B, C) __builtin_sadd_overflow(A, B, C) +#define int32_multiply_overflow(A, B, C) __builtin_smul_overflow(A, B, C) +#else +#if (defined(__GNUC__) && __GNUC__ >= 5) +#define subtract_overflow(A, B, C) __builtin_sub_overflow(A, B, C) +#define add_overflow(A, B, C) __builtin_add_overflow(A, B, C) +#define multiply_overflow(A, B, C) __builtin_mul_overflow(A, B, C) + /* #define int32_subtract_overflow(A, B, C) __builtin_sub_overflow(A, B, C) */ +#define int32_add_overflow(A, B, C) __builtin_add_overflow(A, B, C) +#define int32_multiply_overflow(A, B, C) __builtin_mul_overflow(A, B, C) +#endif +#endif + +#if WITH_GCC +#define s7_int_abs(x) ({s7_int _X_; _X_ = x; _X_ >= 0 ? _X_ : -_X_;}) +#else +#define s7_int_abs(x) ((x) >= 0 ? (x) : -(x)) +#endif +/* can't use abs even in gcc -- it doesn't work with int64_ts! */ + +#if (!__NetBSD__) +#define s7_fabsl(X) fabsl(X) +#else +static double s7_fabsl(long_double x) +{ + return ((signbit(x)) ? -x : x); +} +#endif + +/* for g_log, we also need round. this version is from stackoverflow, see also r5rs_round below */ +double s7_round(double number) +{ + return ((number < 0.0) ? ceil(number - 0.5) : floor(number + 0.5)); +} + +#if HAVE_COMPLEX_NUMBERS +#if __cplusplus +#define _Complex_I (complex(0.0, 1.0)) +#define creal(x) Real(x) +#define cimag(x) Imag(x) +#define carg(x) arg(x) +#define cabs(x) abs(x) +#define csqrt(x) sqrt(x) +#define cpow(x, y) pow(x, y) +#define clog(x) log(x) +#define cexp(x) exp(x) +#define csin(x) sin(x) +#define ccos(x) cos(x) +#define ctan(x) tan(x) +#define csinh(x) sinh(x) +#define ccosh(x) cosh(x) +#define ctanh(x) tanh(x) +#define casin(x) asin(x) +#define cacos(x) acos(x) +#define catan(x) atan(x) +#define casinh(x) asinh(x) +#define cacosh(x) acosh(x) +#define catanh(x) atanh(x) +#else +typedef double complex s7_complex; +#endif + + +#if (!HAVE_COMPLEX_TRIG) +#if (__cplusplus) + +static s7_complex ctan(s7_complex z) +{ + return (csin(z) / ccos(z)); +} + +static s7_complex ctanh(s7_complex z) +{ + return (csinh(z) / ccosh(z)); +} + +static s7_complex casin(s7_complex z) +{ + return (-_Complex_I * clog(_Complex_I * z + csqrt(1.0 - z * z))); +} + +static s7_complex cacos(s7_complex z) +{ + return (-_Complex_I * clog(z + _Complex_I * csqrt(1.0 - z * z))); +} + +static s7_complex catan(s7_complex z) +{ + return (_Complex_I * clog((_Complex_I + z) / (_Complex_I - z)) / 2.0); +} + +static s7_complex casinh(s7_complex z) +{ + return (clog(z + csqrt(1.0 + z * z))); +} + +static s7_complex cacosh(s7_complex z) +{ + return (clog(z + csqrt(z * z - 1.0))); +} + +static s7_complex catanh(s7_complex z) +{ + return (clog((1.0 + z) / (1.0 - z)) / 2.0); +} +#else + +#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 12) +static s7_complex clog(s7_complex z) +{ + return (log(fabs(cabs(z))) + carg(z) * _Complex_I); +} + +static s7_complex cpow(s7_complex x, s7_complex y) +{ + s7_double r = cabs(x); + s7_double theta = carg(x); + s7_double yre = creal(y); + s7_double yim = cimag(y); + s7_double nr = exp(yre * log(r) - yim * theta); + s7_double ntheta = yre * theta + yim * log(r); + return (nr * cos(ntheta) + (nr * sin(ntheta)) * _Complex_I); +} +#endif +#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 9) /* untested -- this orignally looked at __FreeBSD_version which apparently no longer exists */ +static s7_complex cexp(s7_complex z) +{ + return (exp(creal(z)) * cos(cimag(z)) + + (exp(creal(z)) * sin(cimag(z))) * _Complex_I); +} +#endif + +#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 10) +static s7_complex csin(s7_complex z) +{ + return (sin(creal(z)) * cosh(cimag(z)) + + (cos(creal(z)) * sinh(cimag(z))) * _Complex_I); +} + +static s7_complex ccos(s7_complex z) +{ + return (cos(creal(z)) * cosh(cimag(z)) + + (-sin(creal(z)) * sinh(cimag(z))) * _Complex_I); +} + +static s7_complex csinh(s7_complex z) +{ + return (sinh(creal(z)) * cos(cimag(z)) + + (cosh(creal(z)) * sin(cimag(z))) * _Complex_I); +} + +static s7_complex ccosh(s7_complex z) +{ + return (cosh(creal(z)) * cos(cimag(z)) + + (sinh(creal(z)) * sin(cimag(z))) * _Complex_I); +} + +static s7_complex ctan(s7_complex z) +{ + return (csin(z) / ccos(z)); +} + +static s7_complex ctanh(s7_complex z) +{ + return (csinh(z) / ccosh(z)); +} + +static s7_complex casin(s7_complex z) +{ + return (-_Complex_I * clog(_Complex_I * z + csqrt(1.0 - z * z))); +} + +static s7_complex cacos(s7_complex z) +{ + return (-_Complex_I * clog(z + _Complex_I * csqrt(1.0 - z * z))); +} + +static s7_complex catan(s7_complex z) +{ + return (_Complex_I * clog((_Complex_I + z) / (_Complex_I - z)) / 2.0); +} + +static s7_complex catanh(s7_complex z) +{ + return (clog((1.0 + z) / (1.0 - z)) / 2.0); +} + +static s7_complex casinh(s7_complex z) +{ + return (clog(z + csqrt(1.0 + z * z))); +} + +static s7_complex cacosh(s7_complex z) +{ + return (clog(z + csqrt(z * z - 1.0))); +} +#endif /* not FreeBSD 10 */ +#endif /* not c++ */ +#endif /* not HAVE_COMPLEX_TRIG */ + +#else /* not HAVE_COMPLEX_NUMBERS */ +typedef double s7_complex; +#define _Complex_I 1 +#define creal(x) x +#define cimag(x) x +#define csin(x) sin(x) +#define casin(x) x +#define ccos(x) cos(x) +#define cacos(x) x +#define ctan(x) x +#define catan(x) x +#define csinh(x) x +#define casinh(x) x +#define ccosh(x) x +#define cacosh(x) x +#define ctanh(x) x +#define catanh(x) x +#define cexp(x) exp(x) +#define cpow(x, y) pow(x, y) +#define clog(x) log(x) +#define csqrt(x) sqrt(x) +#define conj(x) x +#endif + +#ifdef __OpenBSD__ + /* openbsd's builtin versions of these functions are not usable */ +static s7_complex catanh_1(s7_complex z) +{ + return (clog((1.0 + z) / (1.0 - z)) / 2.0); +} + +static s7_complex casinh_1(s7_complex z) +{ + return (clog(z + csqrt(1.0 + z * z))); +} + +static s7_complex cacosh_1(s7_complex z) +{ + return (clog(z + csqrt(z * z - 1.0))); +} +#endif +#ifdef __NetBSD__ +static s7_complex catanh_1(s7_complex z) +{ + return (clog((1.0 + z) / (1.0 - z)) / 2.0); +} + +static s7_complex casinh_1(s7_complex z) +{ + return (clog(z + csqrt(1.0 + z * z))); +} +#endif + + +bool s7_is_number(s7_pointer p) +{ + return (is_number(p)); +} + +bool s7_is_complex(s7_pointer p) +{ + return (is_number(p)); +} + +bool s7_is_real(s7_pointer p) +{ + return (is_real(p)); +} + +bool s7_is_rational(s7_pointer p) +{ + return (is_rational(p)); +} + +bool s7_is_integer(s7_pointer p) +{ +#if WITH_GMP + return ((is_t_integer(p)) || (is_t_big_integer(p))); +#else + return (is_t_integer(p)); +#endif +} + +bool s7_is_ratio(s7_pointer p) +{ +#if WITH_GMP + return ((is_t_ratio(p)) || (is_t_big_ratio(p))); +#else + return (is_t_ratio(p)); +#endif +} + +static s7_int c_gcd(s7_int u, s7_int v) +{ + s7_int a, b; + if ((u == s7_int_min) || (v == s7_int_min)) { + /* can't take abs of these (below) so do it by hand */ + s7_int divisor = 1; + if (u == v) + return (u); + while (((u & 1) == 0) && ((v & 1) == 0)) { + u /= 2; + v /= 2; + divisor *= 2; + } + return (divisor); + } + a = s7_int_abs(u); + b = s7_int_abs(v); + /* there are faster gcd algorithms but does it ever matter? */ + while (b != 0) { + s7_int temp; + temp = a % b; + a = b; + b = temp; + } + /* if (a < 0) return(-a); *//* why this? */ + return (a); +} + +#define RATIONALIZE_LIMIT 1.0e12 + +static bool c_rationalize(s7_double ux, s7_double error, s7_int * numer, + s7_int * denom) +{ + /* from CL code in Canny, Donald, Ressler, "A Rational Rotation Method for Robust Geometric Algorithms" */ + double x0, x1; + s7_int i, i0, i1, p0, q0, p1, q1; + double e0, e1, e0p, e1p; + int32_t tries = 0; + /* don't use long_double: the loop below will hang */ + + /* #e1e19 is a killer -- it's bigger than most-positive-fixnum, but if we ceil(ux) below + * it turns into most-negative-fixnum. 1e19 is trouble in many places. + */ + if (fabs(ux) > RATIONALIZE_LIMIT) { + /* (rationalize most-positive-fixnum) should not return most-negative-fixnum + * but any number > 1e14 here is so inaccurate that rationalize is useless + * for example, + * default: (rationalize (/ (*s7* 'most-positive-fixnum) 31111.0)) -> 1185866354261165/4 + * gmp: (rationalize (/ (*s7* 'most-positive-fixnum) 31111.0)) -> 9223372036854775807/31111 + * can't return false here because that confuses some of the callers! + */ + (*numer) = (s7_int) ux; + (*denom) = 1; + return (true); + } + + if (error < 0.0) + error = -error; + x0 = ux - error; + x1 = ux + error; + i = (s7_int) ceil(x0); + + if (error >= 1.0) { /* aw good grief! */ + if (x0 < 0) + (*numer) = (x1 < 0) ? (s7_int) floor(x1) : 0; + else + (*numer) = i; + (*denom) = 1; + return (true); + } + + if (x1 >= i) { + (*numer) = (i >= 0) ? i : (s7_int) floor(x1); + (*denom) = 1; + return (true); + } + + i0 = (s7_int) floor(x0); + i1 = (s7_int) ceil(x1); + + p0 = i0; + q0 = 1; + p1 = i1; + q1 = 1; + e0 = i1 - x0; + e1 = x0 - i0; + e0p = i1 - x1; + e1p = x1 - i0; + + while (true) { + s7_int old_p1, old_q1; + double old_e0, old_e1, old_e0p, val, r, r1; + val = (double) p0 / (double) q0; + + if (((x0 <= val) && (val <= x1)) || + (e1 == 0) || (e1p == 0) || (tries > 100)) { + if ((q0 == s7_int_min) && (p0 == 1)) { /* (rationalize 1.000000004297917e-12) when error is 1e-12 */ + (*numer) = 0; + (*denom) = 1; + } else { + (*numer) = p0; + (*denom) = q0; +#if S7_DEBUGGING + if (q0 == 0) + fprintf(stderr, "%f %ld/0\n", ux, p0); +#endif + } + return (true); + } + tries++; + + r = (s7_int) floor(e0 / e1); + r1 = (s7_int) ceil(e0p / e1p); + if (r1 < r) + r = r1; + + /* do handles all step vars in parallel */ + old_p1 = p1; + p1 = p0; + old_q1 = q1; + q1 = q0; + old_e0 = e0; + e0 = e1p; + old_e0p = e0p; + e0p = e1; + old_e1 = e1; + + p0 = old_p1 + r * p0; + q0 = old_q1 + r * q0; + e1 = old_e0p - r * e1p; + /* if the error is set too low, we can get e1 = 0 here: (rationalize (/ pi) 1e-17) */ + e1p = old_e0 - r * old_e1; + } + return (false); +} + +s7_pointer s7_rationalize(s7_scheme * sc, s7_double x, s7_double error) +{ + s7_int numer = 0, denom = 1; + if (c_rationalize(x, error, &numer, &denom)) + return (make_ratio(sc, numer, denom)); + return (make_real(sc, x)); +} + +s7_pointer s7_make_integer(s7_scheme * sc, s7_int n) +{ + s7_pointer x; + if (is_small_int(n)) + return (small_int(n)); + new_cell(sc, x, T_INTEGER); + integer(x) = n; + return (x); +} + +static s7_pointer make_mutable_integer(s7_scheme * sc, s7_int n) +{ + s7_pointer x; + new_cell(sc, x, T_INTEGER | T_MUTABLE | T_IMMUTABLE); + integer(x) = n; + return (x); +} + +static s7_pointer make_permanent_integer(s7_int i) +{ + if (is_small_int(i)) + return (small_int(i)); + if (i == MAX_ARITY) + return (max_arity); + if (i == CLOSURE_ARITY_NOT_SET) + return (arity_not_set); + if (i == -1) + return (minus_one); + if (i == -2) + return (minus_two); /* a few -3 */ + return (make_permanent_integer_unchecked(i)); +} + +s7_pointer s7_make_real(s7_scheme * sc, s7_double n) +{ + s7_pointer x; + new_cell(sc, x, T_REAL); + set_real(x, n); + return (x); +} + +s7_pointer s7_make_mutable_real(s7_scheme * sc, s7_double n) +{ + s7_pointer x; + new_cell(sc, x, T_REAL | T_MUTABLE | T_IMMUTABLE); + set_real(x, n); + return (x); +} + +s7_pointer s7_make_complex(s7_scheme * sc, s7_double a, s7_double b) +{ + s7_pointer x; + if (b == 0.0) { + new_cell(sc, x, T_REAL); + set_real(x, a); + } else { + new_cell(sc, x, T_COMPLEX); + set_real_part(x, a); + set_imag_part(x, b); + } + return (x); +} + +static s7_complex s7_to_c_complex(s7_pointer p) +{ +#if HAVE_COMPLEX_NUMBERS + return (CMPLX(s7_real_part(p), s7_imag_part(p))); +#else + return (0.0); +#endif +} + +static s7_pointer c_complex_to_s7(s7_scheme * sc, s7_complex z) +{ + return (make_complex(sc, creal(z), cimag(z))); +} + +static s7_pointer division_by_zero_error(s7_scheme * sc, s7_pointer caller, + s7_pointer arg); + +static s7_pointer make_ratio(s7_scheme * sc, s7_int a, s7_int b) +{ + s7_pointer x; + if (b == s7_int_min) { + /* This should not trigger an error during reading -- we might have the + * ratio on a switch with-bignums or whatever, so its mere occurrence is just an annoyance. + */ + if (a & 1) + return (make_real(sc, (long_double) a / (long_double) b)); + a /= 2; + b /= 2; + } + if (b < 0) { + a = -a; + b = -b; + } + if (a == s7_int_min) { /* believe it or not, gcc randomly says a != S7_INT64_MIN here but a == s7_int_min even with explicit types! This has to be a bug */ + while (((a & 1) == 0) && ((b & 1) == 0)) { + a /= 2; + b /= 2; + } + } else { + s7_int b1 = b, divisor; + divisor = s7_int_abs(a); + do { + s7_int temp; + temp = divisor % b1; + divisor = b1; + b1 = temp; + } while (b1 != 0); + if (divisor != 1) { + a /= divisor; + b /= divisor; + } + } + if (b == 1) + return (make_integer(sc, a)); + + new_cell(sc, x, T_RATIO); + numerator(x) = a; + denominator(x) = b; + return (x); +} + +s7_pointer s7_make_ratio(s7_scheme * sc, s7_int a, s7_int b) +{ + if (b == 0) + return (division_by_zero_error + (sc, wrap_string(sc, "make-ratio", 10), + set_elist_2(sc, wrap_integer1(sc, a), int_zero))); + return (make_ratio(sc, a, b)); +} + +#define WITH_OVERFLOW_ERROR true +#define WITHOUT_OVERFLOW_ERROR false + +#define INT64_TO_DOUBLE_LIMIT (1LL << 53) +#define DOUBLE_TO_INT64_LIMIT (1LL << 53) + +#if (!WITH_PURE_S7) + +/* 9007199254740991LL is where a truncated double starts to skip integers (expt 2 53) = ca 1e16 + * (ceiling (+ 1e16 1)) -> 10000000000000000 + * (> 9007199254740993.0 9007199254740992.0) -> #f ; in non-gmp 64-bit doubles + * but we can't fix this except in the gmp case because: + * (integer-decode-float (+ (expt 2.0 62) 100)) -> (4503599627370496 10 1) + * (integer-decode-float (+ (expt 2.0 62) 500)) -> (4503599627370496 10 1) + * (> (+ (expt 2.0 62) 500) (+ (expt 2.0 62) 100)) -> #f ; non-gmp again + * i.e. the bits are identical. We can't even detect when it has happened (without tedious effort), so should + * we just give an error for any floor (or whatever) of an arg>1e16? (sin has a similar problem)? + * I think in the non-gmp case I'll throw an error in these cases because the results are bogus: + * (floor (+ (expt 2.0 62) 512)) -> 4611686018427387904 + * (floor (+ (expt 2.0 62) 513)) -> 4611686018427388928 + * another case at the edge: (round 9007199254740992.51) -> 9007199254740992 + * This spells trouble for normal arithmetic in this range. If no gmp, + * (- (+ (expt 2.0 62) 512) (+ (expt 2.0 62) 513)) = -1024.0 (should be -1.0) + * but we don't currently give an error in this case -- not sure what the right thing is. + */ + +static s7_pointer exact_to_inexact(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: +#if WITH_GMP + if ((integer(x) > INT64_TO_DOUBLE_LIMIT) + || (integer(x) < -INT64_TO_DOUBLE_LIMIT)) + return (s7_number_to_big_real(sc, x)); +#endif + return (make_real(sc, (s7_double) (integer(x)))); + + case T_RATIO: +#if WITH_GMP + if ((numerator(x) > INT64_TO_DOUBLE_LIMIT) || (numerator(x) < -INT64_TO_DOUBLE_LIMIT) || (denominator(x) > INT64_TO_DOUBLE_LIMIT)) /* just a guess */ + return (s7_number_to_big_real(sc, x)); +#endif + return (make_real(sc, (s7_double) (fraction(x)))); + +#if WITH_GMP + case T_BIG_INTEGER: + return (big_integer_to_big_real(sc, x)); + + case T_BIG_RATIO: + return (big_ratio_to_big_real(sc, x)); +#endif + + case T_REAL: + case T_BIG_REAL: + case T_COMPLEX: + case T_BIG_COMPLEX: + return (x); /* apparently (exact->inexact 1+i) is not an error */ + + default: + return (method_or_bust_with_type_one_arg_p + (sc, x, sc->exact_to_inexact_symbol, a_number_string)); + } +} + +#if WITH_GMP +static s7_pointer big_rationalize(s7_scheme * sc, s7_pointer args); +#endif + +static s7_pointer inexact_to_exact(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + case T_BIG_INTEGER: + case T_RATIO: + case T_BIG_RATIO: + return (x); + +#if WITH_GMP + case T_BIG_REAL: + return (big_rationalize(sc, set_plist_1(sc, x))); +#endif + + case T_REAL: + { + s7_int numer = 0, denom = 1; + s7_double val = real(x); + if ((is_inf(val)) || (is_NaN(val))) + return (simple_wrong_type_argument_with_type + (sc, sc->inexact_to_exact_symbol, x, + a_normal_real_string)); + + if ((val > DOUBLE_TO_INT64_LIMIT) + || (val < -(DOUBLE_TO_INT64_LIMIT))) { +#if WITH_GMP + return (big_rationalize(sc, set_plist_1(sc, x))); /* this can handle t_real as well as t_big_real */ +#else + return (simple_out_of_range + (sc, sc->inexact_to_exact_symbol, x, + its_too_large_string)); +#endif + } + /* c_rationalize limit is RATIONALIZE_LIMIT=1e12 currently so this is a tighter limit than DOUBLE_TO_INT64_LIMIT */ + if (c_rationalize + (val, sc->default_rationalize_error, &numer, &denom)) + return (make_ratio(sc, numer, denom)); + } + + default: + return (method_or_bust_one_arg_p + (sc, x, sc->inexact_to_exact_symbol, T_REAL)); + } + return (x); +} +#endif + +/* this is a mess -- it's too late to clean up s7.h (sigh) */ +s7_double s7_number_to_real_with_caller(s7_scheme * sc, s7_pointer x, + const char *caller) +{ + if (is_t_real(x)) + return (real(x)); + switch (type(x)) { + case T_INTEGER: + return ((s7_double) integer(x)); + case T_RATIO: + return (fraction(x)); +#if WITH_GMP + case T_BIG_INTEGER: + return ((s7_double) big_integer_to_s7_int(sc, big_integer(x))); + case T_BIG_RATIO: + return ((s7_double) + ((long_double) + big_integer_to_s7_int(sc, + mpq_numref(big_ratio(x))) / + (long_double) big_integer_to_s7_int(sc, + mpq_denref(big_ratio + (x))))); + case T_BIG_REAL: + return ((s7_double) mpfr_get_d(big_real(x), MPFR_RNDN)); +#endif + } + s7_wrong_type_arg_error(sc, caller, 0, x, "a real number"); + return (0.0); +} + +s7_double s7_number_to_real(s7_scheme * sc, s7_pointer x) +{ + return (s7_number_to_real_with_caller(sc, x, "s7_number_to_real")); +} + +s7_int s7_number_to_integer_with_caller(s7_scheme * sc, s7_pointer x, + const char *caller) +{ + if (is_t_integer(x)) + return (integer(x)); +#if WITH_GMP + if (is_t_big_integer(x)) + return (big_integer_to_s7_int(sc, big_integer(x))); +#endif + s7_wrong_type_arg_error(sc, caller, 0, x, "an integer"); + return (0); +} + +s7_int s7_number_to_integer(s7_scheme * sc, s7_pointer x) +{ + return (s7_number_to_integer_with_caller + (sc, x, "s7_number_to_integer")); +} + +s7_int s7_numerator(s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + return (integer(x)); + case T_RATIO: + return (numerator(x)); +#if WITH_GMP + case T_BIG_INTEGER: + return (mpz_get_si(big_integer(x))); /* big_integer_to_s7_int but no sc -- no error if out of range */ + case T_BIG_RATIO: + return (mpz_get_si(mpq_numref(big_ratio(x)))); +#endif + } + return (0); +} + +s7_int s7_denominator(s7_pointer x) +{ + if (is_t_ratio(x)) + return (denominator(x)); +#if WITH_GMP + if (is_t_big_ratio(x)) + return (mpz_get_si(mpq_denref(big_ratio(x)))); +#endif + return (1); +} + +s7_int s7_integer(s7_pointer p) +{ + if (is_t_integer(p)) + return (integer(p)); +#if WITH_GMP + if (is_t_big_integer(p)) + return (mpz_get_si(big_integer(p))); +#endif + return (0); +} + +s7_double s7_real(s7_pointer x) +{ + if (is_t_real(x)) + return (real(x)); + switch (type(x)) { + case T_RATIO: + return (fraction(x)); + case T_INTEGER: + return ((s7_double) integer(x)); +#if WITH_GMP + case T_BIG_INTEGER: + return ((s7_double) mpz_get_si(big_integer(x))); + case T_BIG_REAL: + return ((s7_double) mpfr_get_d(big_real(x), MPFR_RNDN)); + case T_BIG_RATIO: + { + s7_double result; + mpfr_t bx; + mpfr_init2(bx, DEFAULT_BIGNUM_PRECISION); + mpfr_set_q(bx, big_ratio(x), MPFR_RNDN); + result = mpfr_get_d(bx, MPFR_RNDN); + mpfr_clear(bx); + return (result); + } +#endif + } + return (0.0); +} + +static bool is_one(s7_pointer x) +{ + return (((is_t_integer(x)) && (integer(x) == 1)) || + ((is_t_real(x)) && (real(x) == 1.0))); +} + + +/* -------- optimize exponents -------- */ + +#define MAX_POW 64 +static double **pepow = NULL; /* [17][MAX_POW * 2]; */ + +static void init_pows(void) +{ + int32_t i, j; + pepow = (double **) malloc(17 * sizeof(double *)); + pepow[0] = NULL; + pepow[1] = NULL; + for (i = 2; i < 17; i++) + pepow[i] = (double *) malloc((MAX_POW * 2) * sizeof(double)); + for (i = 2; i < 17; i++) /* radix between 2 and 16 */ + for (j = -MAX_POW; j < MAX_POW; j++) /* saved exponent between 0 and +/- MAX_POW */ + pepow[i][j + MAX_POW] = pow((double) i, (double) j); +} + +static inline double dpow(int32_t x, int32_t y) +{ + if ((y >= MAX_POW) || (y < -MAX_POW)) /* this can happen (once in a blue moon) */ + return (pow((double) x, (double) y)); + return (pepow[x][y + MAX_POW]); +} + + +/* -------------------------------- number->string -------------------------------- */ +#define WITH_DTOA 1 +#if WITH_DTOA +/* fpconv, revised to fit the local coding style + + The MIT License + +Copyright (c) 2013 Andreas Samoljuk + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +*/ + +#define dtoa_npowers 87 +#define dtoa_steppowers 8 +#define dtoa_firstpower -348 /* 10 ^ -348 */ +#define dtoa_expmax -32 +#define dtoa_expmin -60 + +typedef struct dtoa_np { + uint64_t frac; + int exp; +} dtoa_np; + +static const dtoa_np dtoa_powers_ten[] = { + { 18054884314459144840U, -1220 }, { 13451937075301367670U, -1193 }, + { 10022474136428063862U, -1166 }, { 14934650266808366570U, -1140 }, + { 11127181549972568877U, -1113 }, { 16580792590934885855U, -1087 }, + { 12353653155963782858U, -1060 }, { 18408377700990114895U, -1034 }, + { 13715310171984221708U, -1007 }, { 10218702384817765436U, -980 }, + { 15227053142812498563U, -954 }, { 11345038669416679861U, -927 }, + { 16905424996341287883U, -901 }, { 12595523146049147757U, -874 }, + { 9384396036005875287U, -847 }, { 13983839803942852151U, -821 }, + { 10418772551374772303U, -794 }, { 15525180923007089351U, -768 }, + { 11567161174868858868U, -741 }, { 17236413322193710309U, -715 }, + { 12842128665889583758U, -688 }, { 9568131466127621947U, -661 }, + { 14257626930069360058U, -635 }, { 10622759856335341974U, -608 }, + { 15829145694278690180U, -582 }, { 11793632577567316726U, -555 }, + { 17573882009934360870U, -529 }, { 13093562431584567480U, -502 }, + { 9755464219737475723U, -475 }, { 14536774485912137811U, -449 }, + { 10830740992659433045U, -422 }, { 16139061738043178685U, -396 }, + { 12024538023802026127U, -369 }, { 17917957937422433684U, -343 }, + { 13349918974505688015U, -316 }, { 9946464728195732843U, -289 }, + { 14821387422376473014U, -263 }, { 11042794154864902060U, -236 }, + { 16455045573212060422U, -210 }, { 12259964326927110867U, -183 }, + { 18268770466636286478U, -157 }, { 13611294676837538539U, -130 }, + { 10141204801825835212U, -103 }, { 15111572745182864684U, -77 }, + { 11258999068426240000U, -50 }, { 16777216000000000000U, -24 }, + { 12500000000000000000U, 3 }, { 9313225746154785156U, 30 }, + { 13877787807814456755U, 56 }, { 10339757656912845936U, 83 }, + { 15407439555097886824U, 109 }, { 11479437019748901445U, 136 }, + { 17105694144590052135U, 162 }, { 12744735289059618216U, 189 }, + { 9495567745759798747U, 216 }, { 14149498560666738074U, 242 }, + { 10542197943230523224U, 269 }, { 15709099088952724970U, 295 }, + { 11704190886730495818U, 322 }, { 17440603504673385349U, 348 }, + { 12994262207056124023U, 375 }, { 9681479787123295682U, 402 }, + { 14426529090290212157U, 428 }, { 10748601772107342003U, 455 }, + { 16016664761464807395U, 481 }, { 11933345169920330789U, 508 }, + { 17782069995880619868U, 534 }, { 13248674568444952270U, 561 }, + { 9871031767461413346U, 588 }, { 14708983551653345445U, 614 }, + { 10959046745042015199U, 641 }, { 16330252207878254650U, 667 }, + { 12166986024289022870U, 694 }, { 18130221999122236476U, 720 }, + { 13508068024458167312U, 747 }, { 10064294952495520794U, 774 }, + { 14996968138956309548U, 800 }, { 11173611982879273257U, 827 }, + { 16649979327439178909U, 853 }, { 12405201291620119593U, 880 }, + { 9242595204427927429U, 907 }, { 13772540099066387757U, 933 }, + { 10261342003245940623U, 960 }, { 15290591125556738113U, 986 }, + { 11392378155556871081U, 1013 }, { 16975966327722178521U, 1039 }, + { 12648080533535911531U, 1066 } +}; + +static dtoa_np dtoa_find_cachedpow10(int exp, int *k) +{ + int approx, idx; + const double one_log_ten = 0.30102999566398114; + + approx = -(exp + dtoa_npowers) * one_log_ten; + idx = (approx - dtoa_firstpower) / dtoa_steppowers; + while (true) { + int current; + current = exp + dtoa_powers_ten[idx].exp + 64; + if (current < dtoa_expmin) { + idx++; + continue; + } + if (current > dtoa_expmax) { + idx--; + continue; + } + *k = (dtoa_firstpower + idx * dtoa_steppowers); + return (dtoa_powers_ten[idx]); + } +} + +#define dtoa_fracmask 0x000FFFFFFFFFFFFFU +#define dtoa_expmask 0x7FF0000000000000U +#define dtoa_hiddenbit 0x0010000000000000U +#define dtoa_signmask 0x8000000000000000U +#define dtoa_expbias (1023 + 52) +#define dtoa_absv(n) ((n) < 0 ? -(n) : (n)) +#define dtoa_minv(a, b) ((a) < (b) ? (a) : (b)) + +static uint64_t dtoa_tens[] = + { 10000000000000000000U, 1000000000000000000U, 100000000000000000U, + 10000000000000000U, 1000000000000000U, 100000000000000U, + 10000000000000U, 1000000000000U, 100000000000U, + 10000000000U, 1000000000U, 100000000U, + 10000000U, 1000000U, 100000U, + 10000U, 1000U, 100U, + 10U, 1U +}; + +static uint64_t dtoa_get_dbits(double d) +{ + union { + double dbl; + uint64_t i; + } dbl_bits = { d }; + return (dbl_bits.i); +} + +static dtoa_np dtoa_build_np(double d) +{ + uint64_t bits; + dtoa_np fp; + + bits = dtoa_get_dbits(d); + fp.frac = bits & dtoa_fracmask; + fp.exp = (bits & dtoa_expmask) >> 52; + if (fp.exp) { + fp.frac += dtoa_hiddenbit; + fp.exp -= dtoa_expbias; + } else + fp.exp = -dtoa_expbias + 1; + return (fp); +} + +static void dtoa_normalize(dtoa_np * fp) +{ + int shift; + while ((fp->frac & dtoa_hiddenbit) == 0) { + fp->frac <<= 1; + fp->exp--; + } + shift = 64 - 52 - 1; + fp->frac <<= shift; + fp->exp -= shift; +} + +static void dtoa_get_normalized_boundaries(dtoa_np * fp, dtoa_np * lower, + dtoa_np * upper) +{ + int u_shift, l_shift; + upper->frac = (fp->frac << 1) + 1; + upper->exp = fp->exp - 1; + while ((upper->frac & (dtoa_hiddenbit << 1)) == 0) { + upper->frac <<= 1; + upper->exp--; + } + u_shift = 64 - 52 - 2; + upper->frac <<= u_shift; + upper->exp = upper->exp - u_shift; + l_shift = fp->frac == dtoa_hiddenbit ? 2 : 1; + lower->frac = (fp->frac << l_shift) - 1; + lower->exp = fp->exp - l_shift; + lower->frac <<= lower->exp - upper->exp; + lower->exp = upper->exp; +} + +static dtoa_np dtoa_multiply(dtoa_np * a, dtoa_np * b) +{ + dtoa_np fp; + uint64_t ah_bl, al_bh, al_bl, ah_bh, tmp; + const uint64_t lomask = 0x00000000FFFFFFFF; + + ah_bl = (a->frac >> 32) * (b->frac & lomask); + al_bh = (a->frac & lomask) * (b->frac >> 32); + al_bl = (a->frac & lomask) * (b->frac & lomask); + ah_bh = (a->frac >> 32) * (b->frac >> 32); + tmp = (ah_bl & lomask) + (al_bh & lomask) + (al_bl >> 32); + /* round up */ + tmp += 1U << 31; + fp.frac = ah_bh + (ah_bl >> 32) + (al_bh >> 32) + (tmp >> 32); + fp.exp = a->exp + b->exp + 64; + return (fp); +} + +static void dtoa_round_digit(char *digits, int ndigits, uint64_t delta, + uint64_t rem, uint64_t kappa, uint64_t frac) +{ + while ((rem < frac) && (delta - rem >= kappa) && + ((rem + kappa < frac) || (frac - rem > rem + kappa - frac))) { + digits[ndigits - 1]--; + rem += kappa; + } +} + +static int dtoa_generate_digits(dtoa_np * fp, dtoa_np * upper, + dtoa_np * lower, char *digits, int *K) +{ + uint64_t part1, part2, wfrac, delta; + uint64_t *divp, *unit; + int idx, kappa; + dtoa_np one; + + wfrac = upper->frac - fp->frac; + delta = upper->frac - lower->frac; + one.frac = 1ULL << -upper->exp; + one.exp = upper->exp; + part1 = upper->frac >> -one.exp; + part2 = upper->frac & (one.frac - 1); + idx = 0; + kappa = 10; + + /* 1000000000 */ + for (divp = dtoa_tens + 10; kappa > 0; divp++) { + uint64_t tmp, div; + unsigned digit; + div = *divp; + digit = part1 / div; + if (digit || idx) + digits[idx++] = digit + '0'; + part1 -= digit * div; + kappa--; + tmp = (part1 << -one.exp) + part2; + if (tmp <= delta) { + *K += kappa; + dtoa_round_digit(digits, idx, delta, tmp, div << -one.exp, + wfrac); + return (idx); + } + } + + /* 10 */ + unit = dtoa_tens + 18; + while (true) { + unsigned digit; + part2 *= 10; + delta *= 10; + kappa--; + digit = part2 >> -one.exp; + if (digit || idx) + digits[idx++] = digit + '0'; + part2 &= one.frac - 1; + if (part2 < delta) { + *K += kappa; + dtoa_round_digit(digits, idx, delta, part2, one.frac, + wfrac * *unit); + return (idx); + } + unit--; + } +} + +static int dtoa_grisu2(double d, char *digits, int *K) +{ + int k; + dtoa_np cp, w, lower, upper; + w = dtoa_build_np(d); + dtoa_get_normalized_boundaries(&w, &lower, &upper); + dtoa_normalize(&w); + cp = dtoa_find_cachedpow10(upper.exp, &k); + w = dtoa_multiply(&w, &cp); + upper = dtoa_multiply(&upper, &cp); + lower = dtoa_multiply(&lower, &cp); + lower.frac++; + upper.frac--; + *K = -k; + return (dtoa_generate_digits(&w, &upper, &lower, digits, K)); +} + +static int dtoa_emit_digits(char *digits, int ndigits, char *dest, int K, + bool neg) +{ + int exp, idx, cent; + char sign; + exp = dtoa_absv(K + ndigits - 1); + + /* write plain integer */ + if ((K >= 0) && (exp < (ndigits + 7))) { + memcpy(dest, digits, ndigits); + memset(dest + ndigits, '0', K); + dest[ndigits + K] = '.'; + dest[ndigits + K + 1] = '0'; + return (ndigits + K + 2); + } + + /* write decimal w/o scientific notation */ + if ((K < 0) && (K > -7 || exp < 4)) { + int offset; + offset = ndigits - dtoa_absv(K); + /* fp < 1.0 -> write leading zero */ + if (offset <= 0) { + offset = -offset; + dest[0] = '0'; + dest[1] = '.'; + memset(dest + 2, '0', offset); + memcpy(dest + offset + 2, digits, ndigits); + return (ndigits + 2 + offset); + /* fp > 1.0 */ + } else { + memcpy(dest, digits, offset); + dest[offset] = '.'; + memcpy(dest + offset + 1, digits + offset, ndigits - offset); + return (ndigits + 1); + } + } + + /* write decimal w/ scientific notation */ + ndigits = dtoa_minv(ndigits, 18 - neg); + idx = 0; + dest[idx++] = digits[0]; + if (ndigits > 1) { + dest[idx++] = '.'; + memcpy(dest + idx, digits + 1, ndigits - 1); + idx += ndigits - 1; + } + dest[idx++] = 'e'; + sign = K + ndigits - 1 < 0 ? '-' : '+'; + dest[idx++] = sign; + cent = 0; + if (exp > 99) { + cent = exp / 100; + dest[idx++] = cent + '0'; + exp -= cent * 100; + } + if (exp > 9) { + int dec; + dec = exp / 10; + dest[idx++] = dec + '0'; + exp -= dec * 10; + } else if (cent) + dest[idx++] = '0'; + + dest[idx++] = exp % 10 + '0'; + return (idx); +} + +static int dtoa_filter_special(double fp, char *dest, bool neg) +{ + uint64_t bits; + bool nan; + if (fp == 0.0) { + dest[0] = '0'; + dest[1] = '.'; + dest[2] = '0'; + return (3); + } + bits = dtoa_get_dbits(fp); + nan = (bits & dtoa_expmask) == dtoa_expmask; + if (!nan) + return (0); + + if (!neg) { + dest[0] = '+'; + dest++; + } + if (bits & dtoa_fracmask) { + dest[0] = 'n'; + dest[1] = 'a'; + dest[2] = 'n'; + dest[3] = '.'; + dest[4] = '0'; + } else { + dest[0] = 'i'; + dest[1] = 'n'; + dest[2] = 'f'; + dest[3] = '.'; + dest[4] = '0'; + } + return ((neg) ? 5 : 6); +} + +static inline int fpconv_dtoa(double d, char dest[24]) +{ + char digit[18]; + int str_len = 0, spec, K, ndigits; + bool neg = false; + + if (dtoa_get_dbits(d) & dtoa_signmask) { + dest[0] = '-'; + str_len++; + neg = true; + } + spec = dtoa_filter_special(d, dest + str_len, neg); + if (spec) + return (str_len + spec); + K = 0; + ndigits = dtoa_grisu2(d, digit, &K); + str_len += dtoa_emit_digits(digit, ndigits, dest + str_len, K, neg); + return (str_len); +} +#endif + + +/* -------------------------------- number->string -------------------------------- */ +static const char dignum[] = "0123456789abcdef"; + +static size_t integer_to_string_any_base(char *p, s7_int n, int32_t radix) +{ /* called by number_to_string_with_radix */ + s7_int i, len, end; + bool sign; + s7_int pown; + + if ((radix < 2) || (radix > 16)) + return (0); + + if (n == S7_INT64_MIN) { /* can't negate this, so do it by hand */ + static const char *mnfs[17] = { "", "", + "-1000000000000000000000000000000000000000000000000000000000000000", + "-2021110011022210012102010021220101220222", + "-20000000000000000000000000000000", + "-1104332401304422434310311213", + "-1540241003031030222122212", + "-22341010611245052052301", "-1000000000000000000000", + "-67404283172107811828", "-9223372036854775808", + "-1728002635214590698", "-41a792678515120368", + "-10b269549075433c38", "-4340724c6c71dc7a8", + "-160e2ad3246366808", "-8000000000000000" + }; + + len = safe_strlen(mnfs[radix]); + memcpy((void *) p, (void *) mnfs[radix], len); + p[len] = '\0'; + return (len); + } + + sign = (n < 0); + if (sign) + n = -n; + + /* the previous version that counted up to n, rather than dividing down below n, as here, + * could be confused by large ints on 64 bit machines + */ + pown = n; + for (i = 1; i < 100; i++) { + if (pown < radix) + break; + pown /= (s7_int) radix; + } + len = i - 1; + if (sign) + len++; + end = 0; + if (sign) { + p[0] = '-'; + end++; + } + for (i = len; i >= end; i--) { + p[i] = dignum[n % radix]; + n /= radix; + } + p[len + 1] = '\0'; + return (len + 1); +} + +static char *integer_to_string(s7_scheme * sc, s7_int num, s7_int * nlen) +{ /* do not free the returned string */ + char *p, *op; + bool sign; + + if (num == S7_INT64_MIN) { + (*nlen) = 20; + return ((char *) "-9223372036854775808"); + } + p = (char *) (sc->int_to_str1 + INT_TO_STR_SIZE - 1); + op = p; + *p-- = '\0'; + + sign = (num < 0); + if (sign) + num = -num; /* we need a positive index below */ + do { + *p-- = "0123456789"[num % 10]; + num /= 10; + } while (num); + if (sign) { + *p = '-'; + (*nlen) = op - p; + return (p); + } + + (*nlen) = op - p - 1; + return (++p); +} + +static char *integer_to_string_no_length(s7_scheme * sc, s7_int num) +{ /* do not free the returned string */ + char *p; + bool sign; + + if (num == S7_INT64_MIN) + return ((char *) "-9223372036854775808"); + p = (char *) (sc->int_to_str2 + INT_TO_STR_SIZE - 1); + *p-- = '\0'; + sign = (num < 0); + if (sign) + num = -num; + do { + *p-- = "0123456789"[num % 10]; + num /= 10; + } while (num); + if (sign) { + *p = '-'; + return (p); + } + return (++p); +} + +static inline char *floatify(char *str, s7_int * nlen) +{ + if ((!strchr(str, '.')) && (!strchr(str, 'e'))) { /* faster than (strcspn(str, ".e") >= (size_t)(*nlen)) */ + s7_int len = *nlen; + /* snprintf returns "nan" and "inf" but we (stupidly) want "+nan.0" and "+inf.0"; "-nan" and "-inf" will be handled by the normal case */ + if (len == 3) { + if (str[0] == 'n') { + str[0] = '+'; + str[1] = 'n'; + str[2] = 'a'; + str[3] = 'n'; + len = 4; + } + if (str[0] == 'i') { + str[0] = '+'; + str[1] = 'i'; + str[2] = 'n'; + str[3] = 'f'; + len = 4; + } + } + str[len] = '.'; + str[len + 1] = '0'; + str[len + 2] = '\0'; + (*nlen) = len + 2; + } + return (str); +} + +static void insert_spaces(s7_scheme * sc, char *src, s7_int width, + s7_int len) +{ + s7_int spaces; + if (width >= sc->num_to_str_size) { + sc->num_to_str_size = width + 1; + sc->num_to_str = + (char *) Realloc(sc->num_to_str, sc->num_to_str_size); + } + spaces = width - len; + sc->num_to_str[width] = '\0'; + memmove((void *) (sc->num_to_str + spaces), (void *) src, len); + memset((void *) (sc->num_to_str), (int) ' ', spaces); +} + +static char *number_to_string_base_10(s7_scheme * sc, s7_pointer obj, + s7_int width, s7_int precision, + char float_choice, s7_int * nlen, + use_write_t choice) +{ /* don't free result */ + /* called by number_to_string_with_radix g_number_to_string, number_to_string_p_p number_to_port format_number */ + /* the rest of s7 assumes nlen is set to the correct length + * a tricky case: (format #f "~f" 1e308) -- tries to print 308 digits! so 256 as default len is too small. + * but then even worse: (format #f "~F" 1e308+1e308i)! + */ + s7_int len; + len = width + precision; + len = (len > 512) ? (512 + 2 * len) : 1024; + if (len > sc->num_to_str_size) { + sc->num_to_str = + (sc->num_to_str) ? (char *) Realloc(sc->num_to_str, + len) : (char *) + Malloc(len); + sc->num_to_str_size = len; + } + + /* bignums can't happen here */ + if (is_t_integer(obj)) { + char *p; + if (width == 0) { + if (has_number_name(obj)) { + (*nlen) = number_name_length(obj); + return ((char *) number_name(obj)); + } + return (integer_to_string(sc, integer(obj), nlen)); + } + p = integer_to_string(sc, integer(obj), &len); + if (width > len) { + insert_spaces(sc, p, width, len); + (*nlen) = width; + return (sc->num_to_str); + } + (*nlen) = len; + return (p); + } + + if (is_t_real(obj)) { + if (width == 0) { +#if WITH_DTOA + if ((float_choice == 'g') && + (precision == WRITE_REAL_PRECISION)) { + /* (number->string 0.0000001) is sensitive to (*s7* 'float-format-precision) and inconsistent: either 1e-7 or 0.0000001 + * because fpconv_dtoa has some complicated decision about 'g' vs 'f' -- not sure if this is a bug. + */ + len = fpconv_dtoa(real(obj), sc->num_to_str); + sc->num_to_str[len] = '\0'; + (*nlen) = len; + return (sc->num_to_str); + } +#endif + len = snprintf(sc->num_to_str, sc->num_to_str_size - 4, (float_choice == 'g') ? "%.*g" : ((float_choice == 'f') ? "%.*f" : "%.*e"), (int32_t) precision, real(obj)); /* -4 for floatify */ + } else + len = snprintf(sc->num_to_str, sc->num_to_str_size - 4, (float_choice == 'g') ? "%*.*g" : ((float_choice == 'f') ? "%*.*f" : "%*.*e"), (int32_t) width, (int32_t) precision, real(obj)); /* -4 for floatify */ + (*nlen) = len; + floatify(sc->num_to_str, nlen); + return (sc->num_to_str); + } + + if (is_t_complex(obj)) { + char *imag; + sc->num_to_str[0] = '\0'; + real(sc->real_wrapper4) = imag_part(obj); + imag = + copy_string(number_to_string_base_10 + (sc, sc->real_wrapper4, 0, precision, float_choice, + &len, choice)); + + sc->num_to_str[0] = '\0'; + real(sc->real_wrapper3) = real_part(obj); + number_to_string_base_10(sc, sc->real_wrapper3, 0, precision, + float_choice, &len, choice); + + sc->num_to_str[len] = '\0'; + len = + catstrs(sc->num_to_str, sc->num_to_str_size, ((imag[0] == '+') + || (imag[0] == + '-')) ? "" : + "+", imag, "i", (char *) NULL); + free(imag); + + if (width > len) { /* (format #f "~20g" 1+i) */ + insert_spaces(sc, sc->num_to_str, width, len); /* this checks sc->num_to_str_size */ + (*nlen) = width; + } else + (*nlen) = len; + return (sc->num_to_str); + } + + /* ratio */ + len = + catstrs_direct(sc->num_to_str, + integer_to_string_no_length(sc, numerator(obj)), + "/", pos_int_to_str_direct(sc, denominator(obj)), + (const char *) NULL); + if (width > len) { + insert_spaces(sc, sc->num_to_str, width, len); + (*nlen) = width; + } else + (*nlen) = len; + return (sc->num_to_str); +} + +static block_t *number_to_string_with_radix(s7_scheme * sc, s7_pointer obj, + int32_t radix, s7_int width, + s7_int precision, + char float_choice, + s7_int * nlen) +{ + /* called by s7_number_to_string (char*), g_number_to_string (strp), number_to_string_p_pp (strp), format_number (strp basically) */ + /* the rest of s7 assumes nlen is set to the correct length */ + block_t *b; + char *p; + s7_int len, str_len; + +#if WITH_GMP + if (s7_is_bignum(obj)) + return (big_number_to_string_with_radix + (sc, obj, radix, width, nlen, P_WRITE)); + /* this ignores precision because it's way too hard to get the mpfr string to look like + * C's output -- we either have to call mpfr_get_str twice (the first time just to + * find out what the exponent is and how long the string actually is), or we have + * to do messy string manipulations. So (format #f "",3F" pi) ignores the "3" and + * prints the full string. And don't even think about mpfr_snprintf! + */ +#endif + if (radix == 10) { + p = number_to_string_base_10(sc, obj, width, precision, + float_choice, nlen, P_WRITE); + return (string_to_block(sc, p, *nlen)); + } + + switch (type(obj)) { + case T_INTEGER: + { + size_t len1; + b = mallocate(sc, (128 + width)); + p = (char *) block_data(b); + len1 = integer_to_string_any_base(p, integer(obj), radix); + if ((size_t) width > len1) { + size_t start; + start = width - len1; + memmove((void *) (p + start), (void *) p, len1); + memset((void *) p, (int) ' ', start); + p[width] = '\0'; + *nlen = width; + } else + *nlen = len1; + return (b); + } + + case T_RATIO: + { + size_t len1, len2; + str_len = 256 + width; + b = mallocate(sc, str_len); + p = (char *) block_data(b); + len1 = integer_to_string_any_base(p, numerator(obj), radix); + p[len1] = '/'; + len2 = + integer_to_string_any_base((char *) (p + len1 + 1), + denominator(obj), radix); + len = len1 + 1 + len2; + p[len] = '\0'; + } + break; + + case T_REAL: + { + int32_t i; + s7_int int_part, nsize; + s7_double x = real(obj), frac_part, min_frac, base; + bool sign = false; + char n[128], d[256]; + + if (is_NaN(x)) + return (string_to_block(sc, "+nan.0", *nlen = 6)); + if (is_inf(x)) { + if (x < 0.0) + return (string_to_block(sc, "-inf.0", *nlen = 6)); + return (string_to_block(sc, "+inf.0", *nlen = 6)); + } + if (x < 0.0) { + sign = true; + x = -x; + } + if (x > 1.0e18) { /* i.e. close to or greater than most-positive-fixnum (9.22e18), so the code below is unlikely to work, (format #f "~X" 1e19) */ + int32_t ep; + block_t *b1; + len = 0; + ep = (int32_t) floor(log(x) / log((double) radix)); + real(sc->real_wrapper3) = x / pow((double) radix, (double) ep); /* divide it down to one digit, then the fractional part */ + b = number_to_string_with_radix(sc, sc->real_wrapper3, + radix, width, precision, + float_choice, &len); + b1 = mallocate(sc, len + 8); + p = (char *) block_data(b1); + p[0] = '\0'; + (*nlen) = + catstrs(p, len + 8, (sign) ? "-" : "", + (char *) block_data(b), + (radix == 16) ? "@" : "e", + integer_to_string_no_length(sc, ep), + (char *) NULL); + liberate(sc, b); + return (b1); + } + + int_part = (s7_int) floor(x); + frac_part = x - int_part; + nsize = integer_to_string_any_base(n, int_part, radix); + min_frac = dpow(radix, -precision); + + /* doesn't this assume precision < 128/256 and that we can fit in 256 digits (1e308)? */ + for (i = 0, base = radix; + (i < precision) && (frac_part > min_frac); + i++, base *= radix) { + s7_int ipart; + ipart = (s7_int) (frac_part * base); + if (ipart >= radix) /* rounding confusion */ + ipart = radix - 1; + frac_part -= (ipart / base); + /* d[i] = ((const char *)"0123456789abcdef")[ipart]; */ + d[i] = dignum[ipart]; + } + if (i == 0) + d[i++] = '0'; + d[i] = '\0'; + b = mallocate(sc, 256); + p = (char *) block_data(b); + /* much faster than catstrs because we know the string lengths */ + { + char *pt = p; + if (sign) { + pt[0] = '-'; + pt++; + } + memcpy(pt, n, nsize); + pt += nsize; + pt[0] = '.'; + pt++; + memcpy(pt, d, i); + pt[i] = '\0'; + /* len = ((sign) ? 1 : 0) + 1 + nsize + i; */ + len = pt + i - p; + } + str_len = 256; + } + break; + + default: + { + block_t *n, *d; + char *dp, *pt; + s7_int real_len = 0, imag_len = 0; + real(sc->real_wrapper3) = real_part(obj); + n = number_to_string_with_radix(sc, sc->real_wrapper3, radix, 0, precision, float_choice, &real_len); /* include floatify */ + real(sc->real_wrapper4) = imag_part(obj); + d = number_to_string_with_radix(sc, sc->real_wrapper4, radix, + 0, precision, float_choice, + &imag_len); + dp = (char *) block_data(d); + b = mallocate(sc, 512); + p = (char *) block_data(b); + pt = p; + memcpy(pt, (void *) block_data(n), real_len); + pt += real_len; + if ((dp[0] != '+') && (dp[0] != '-')) { + pt[0] = '+'; + pt++; + } + memcpy(pt, dp, imag_len); + pt[imag_len] = 'i'; + pt[imag_len + 1] = '\0'; + len = pt + imag_len + 1 - p; + str_len = 512; + liberate(sc, n); + liberate(sc, d); + } + break; + } + + if (width > len) { + s7_int spaces; + if (width >= str_len) { + str_len = width + 1; + b = reallocate(sc, b, str_len); + p = (char *) block_data(b); + } + spaces = width - len; + p[width] = '\0'; + memmove((void *) (p + spaces), (void *) p, len); + memset((void *) p, (int) ' ', spaces); + (*nlen) = width; + } else + (*nlen) = len; + return (b); +} + +char *s7_number_to_string(s7_scheme * sc, s7_pointer obj, s7_int radix) +{ + s7_int nlen = 0; + block_t *b; + char *str; + b = number_to_string_with_radix(sc, obj, radix, 0, 20, 'g', &nlen); /* (log top 10) so we get all the digits in base 10 (??) */ + str = copy_string_with_length((char *) block_data(b), nlen); + liberate(sc, b); + return (str); +} + +static s7_pointer g_number_to_string(s7_scheme * sc, s7_pointer args) +{ +#define H_number_to_string "(number->string num (radix 10)) converts the number num into a string." +#define Q_number_to_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_number_symbol, sc->is_integer_symbol) + + s7_int nlen = 0, radix; /* ignore cppcheck complaint about radix! */ + char *res; + s7_pointer x = car(args); + + if (!is_number(x)) + return (method_or_bust_with_type + (sc, x, sc->number_to_string_symbol, args, a_number_string, + 1)); + + if (is_pair(cdr(args))) { + s7_pointer y = cadr(args); + if (s7_is_integer(y)) + radix = s7_integer_checked(sc, y); + else + return (method_or_bust + (sc, y, sc->number_to_string_symbol, args, T_INTEGER, + 2)); + if ((radix < 2) || (radix > 16)) + return (out_of_range + (sc, sc->number_to_string_symbol, int_two, y, + a_valid_radix_string)); +#if (WITH_GMP) + if (!s7_is_bignum(x)) +#endif + { + block_t *b; + b = number_to_string_with_radix(sc, x, radix, 0, + sc->float_format_precision, + 'g', &nlen); + return (block_to_string(sc, b, nlen)); + } + } +#if WITH_GMP + else + radix = 10; + if (s7_is_bignum(x)) { + block_t *b; + b = big_number_to_string_with_radix(sc, x, radix, 0, &nlen, + P_WRITE); + return (block_to_string(sc, b, nlen)); + } + res = + number_to_string_base_10(sc, x, 0, sc->float_format_precision, 'g', + &nlen, P_WRITE); +#else + if (is_t_integer(x)) { + if (has_number_name(x)) { + nlen = number_name_length(x); + res = (char *) number_name(x); + } else + res = integer_to_string(sc, integer(x), &nlen); + } else + res = + number_to_string_base_10(sc, x, 0, sc->float_format_precision, + 'g', &nlen, P_WRITE); +#endif + return (inline_make_string_with_length(sc, res, nlen)); +} + +static s7_pointer number_to_string_p_p(s7_scheme * sc, s7_pointer p) +{ +#if WITH_GMP + return (g_number_to_string(sc, set_plist_1(sc, p))); +#else + s7_int nlen = 0; + char *res; + if (!is_number(p)) + return (method_or_bust_with_type_one_arg_p + (sc, p, sc->number_to_string_symbol, a_number_string)); + res = + number_to_string_base_10(sc, p, 0, sc->float_format_precision, 'g', + &nlen, P_WRITE); + return (inline_make_string_with_length(sc, res, nlen)); +#endif +} + +static s7_pointer number_to_string_p_i(s7_scheme * sc, s7_int p) +{ + s7_int nlen = 0; + char *res; + res = integer_to_string(sc, p, &nlen); + return (inline_make_string_with_length(sc, res, nlen)); +} + +/* not number_to_string_p_d! */ + +static s7_pointer number_to_string_p_pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ +#if WITH_GMP + return (g_number_to_string(sc, set_plist_2(sc, p1, p2))); +#else + s7_int nlen = 0, radix; + block_t *b; + + if (!is_number(p1)) + return (wrong_type_argument_with_type + (sc, sc->number_to_string_symbol, 1, p1, a_number_string)); + if (!is_t_integer(p2)) + return (wrong_type_argument + (sc, sc->number_to_string_symbol, 2, p2, T_INTEGER)); + radix = integer(p2); + if ((radix < 2) || (radix > 16)) + return (out_of_range + (sc, sc->number_to_string_symbol, int_two, p2, + a_valid_radix_string)); + + b = number_to_string_with_radix(sc, p1, radix, 0, + sc->float_format_precision, 'g', + &nlen); + return (block_to_string(sc, b, nlen)); +#endif +} + + +/* -------------------------------------------------------------------------------- */ +#define CTABLE_SIZE 256 +static bool *exponent_table, *slashify_table, *char_ok_in_a_name, + *white_space, *number_table, *symbol_slashify_table; +static int32_t *digits; + +static void init_ctables(void) +{ + int32_t i; + + exponent_table = (bool *) calloc(CTABLE_SIZE, sizeof(bool)); + slashify_table = (bool *) calloc(CTABLE_SIZE, sizeof(bool)); + symbol_slashify_table = (bool *) calloc(CTABLE_SIZE, sizeof(bool)); + char_ok_in_a_name = (bool *) calloc(CTABLE_SIZE, sizeof(bool)); + white_space = (bool *) calloc(CTABLE_SIZE + 1, sizeof(bool)); + white_space++; /* leave white_space[-1] false for white_space[EOF] */ + number_table = (bool *) calloc(CTABLE_SIZE, sizeof(bool)); + digits = (int32_t *) calloc(CTABLE_SIZE, sizeof(int32_t)); + + for (i = 0; i < CTABLE_SIZE; i++) { + char_ok_in_a_name[i] = true; + white_space[i] = false; + digits[i] = 256; + number_table[i] = false; + } + + char_ok_in_a_name[0] = false; + char_ok_in_a_name[(uint8_t) '('] = false; /* cast for C++ */ + char_ok_in_a_name[(uint8_t) ')'] = false; + char_ok_in_a_name[(uint8_t) ';'] = false; + char_ok_in_a_name[(uint8_t) '\t'] = false; + char_ok_in_a_name[(uint8_t) '\n'] = false; + char_ok_in_a_name[(uint8_t) '\r'] = false; + char_ok_in_a_name[(uint8_t) ' '] = false; + char_ok_in_a_name[(uint8_t) '"'] = false; + + white_space[(uint8_t) '\t'] = true; + white_space[(uint8_t) '\n'] = true; + white_space[(uint8_t) '\r'] = true; + white_space[(uint8_t) '\f'] = true; + white_space[(uint8_t) '\v'] = true; + white_space[(uint8_t) ' '] = true; + white_space[(uint8_t) '\205'] = true; /* 133 */ + white_space[(uint8_t) '\240'] = true; /* 160 */ + + /* surely only 'e' is needed... */ + exponent_table[(uint8_t) 'e'] = true; + exponent_table[(uint8_t) 'E'] = true; + exponent_table[(uint8_t) '@'] = true; +#if WITH_EXTRA_EXPONENT_MARKERS + exponent_table[(uint8_t) 's'] = true; + exponent_table[(uint8_t) 'S'] = true; + exponent_table[(uint8_t) 'f'] = true; + exponent_table[(uint8_t) 'F'] = true; + exponent_table[(uint8_t) 'd'] = true; + exponent_table[(uint8_t) 'D'] = true; + exponent_table[(uint8_t) 'l'] = true; + exponent_table[(uint8_t) 'L'] = true; +#endif + for (i = 0; i < 32; i++) + slashify_table[i] = true; + for (i = 127; i < 160; i++) + slashify_table[i] = true; + slashify_table[(uint8_t) '\\'] = true; + slashify_table[(uint8_t) '"'] = true; + slashify_table[(uint8_t) '\n'] = false; + + for (i = 0; i < CTABLE_SIZE; i++) + symbol_slashify_table[i] = ((slashify_table[i]) || (!char_ok_in_a_name[i])); /* force use of (symbol ...) for cases like '(ab) as symbol */ + + digits[(uint8_t) '0'] = 0; + digits[(uint8_t) '1'] = 1; + digits[(uint8_t) '2'] = 2; + digits[(uint8_t) '3'] = 3; + digits[(uint8_t) '4'] = 4; + digits[(uint8_t) '5'] = 5; + digits[(uint8_t) '6'] = 6; + digits[(uint8_t) '7'] = 7; + digits[(uint8_t) '8'] = 8; + digits[(uint8_t) '9'] = 9; + digits[(uint8_t) 'a'] = 10; + digits[(uint8_t) 'A'] = 10; + digits[(uint8_t) 'b'] = 11; + digits[(uint8_t) 'B'] = 11; + digits[(uint8_t) 'c'] = 12; + digits[(uint8_t) 'C'] = 12; + digits[(uint8_t) 'd'] = 13; + digits[(uint8_t) 'D'] = 13; + digits[(uint8_t) 'e'] = 14; + digits[(uint8_t) 'E'] = 14; + digits[(uint8_t) 'f'] = 15; + digits[(uint8_t) 'F'] = 15; + + number_table[(uint8_t) '0'] = true; + number_table[(uint8_t) '1'] = true; + number_table[(uint8_t) '2'] = true; + number_table[(uint8_t) '3'] = true; + number_table[(uint8_t) '4'] = true; + number_table[(uint8_t) '5'] = true; + number_table[(uint8_t) '6'] = true; + number_table[(uint8_t) '7'] = true; + number_table[(uint8_t) '8'] = true; + number_table[(uint8_t) '9'] = true; + number_table[(uint8_t) '.'] = true; + number_table[(uint8_t) '+'] = true; + number_table[(uint8_t) '-'] = true; + number_table[(uint8_t) '#'] = true; +} + +#define is_white_space(C) white_space[C] + /* this is much faster than C's isspace, and does not depend on the current locale. + * if c == EOF (-1), it indexes into the empty (0) slot we preallocated below white_space + */ + +/* -------------------------------- *#readers* -------------------------------- */ +static s7_pointer check_sharp_readers(s7_scheme * sc, const char *name) +{ + s7_pointer reader, value = sc->F, args = sc->F; + bool need_loader_port; + + /* *#reader* is assumed to be an alist of (char . proc) + * where each proc takes one argument, the string from just beyond the "#" to the next delimiter. + * The procedure can call read-char to read ahead in the current-input-port. + * If it returns anything other than #f, that is the value of the sharp expression. + * Since #f means "nothing found", it is tricky to handle #F: + * (cons #\F (lambda (str) (and (string=? str "F") (list 'not #t)))) ; or ''#f used in lint.scm + * This search happens after #|, #t, and #f (and #nD for multivectors?). #! has a fallback. Added #_ later) + */ + + need_loader_port = is_loader_port(current_input_port(sc)); + if (need_loader_port) + clear_loader_port(current_input_port(sc)); + + /* normally read* can't read from current_input_port(sc) if it is in use by the loader, but here we are deliberately making that possible. */ + for (reader = slot_value(sc->sharp_readers); is_not_null(reader); + reader = cdr(reader)) + if (name[0] == s7_character(caar(reader))) { + if (args == sc->F) + args = set_plist_1(sc, s7_make_string_wrapper(sc, name)); + /* args is GC protected by s7_apply_function?? (placed on the stack) */ + value = s7_apply_function(sc, cdar(reader), args); /* this is much less error-safe than s7_call */ + if (value != sc->F) + break; + } + if (need_loader_port) + set_loader_port(current_input_port(sc)); + return (value); +} + +static s7_pointer g_sharp_readers_set(s7_scheme * sc, s7_pointer args) +{ + /* new value must be either () or a proper list of conses (char . func) */ + if (is_null(cadr(args))) + return (cadr(args)); + if (is_pair(cadr(args))) { + s7_pointer x; + for (x = cadr(args); is_pair(x); x = cdr(x)) + if ((!is_pair(car(x))) || + (!is_character(caar(x))) || (!is_procedure(cdar(x)))) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "can't set *#readers* to ~S", + 26), cadr(args)))); + if (is_null(x)) + return (cadr(args)); + } + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, "can't set *#readers* to ~S", 26), + cadr(args)))); +} + +static s7_pointer make_undefined(s7_scheme * sc, const char *name) +{ + s7_pointer p; + char *newstr; + s7_int len; + new_cell(sc, p, T_UNDEFINED | T_IMMUTABLE); + len = safe_strlen(name); + newstr = (char *) Malloc(len + 2); + newstr[0] = '#'; + if (len > 0) + memcpy((void *) (newstr + 1), (void *) name, len); + newstr[len + 1] = '\0'; + if (sc->undefined_constant_warnings) + s7_warn(sc, len + 32, "%s is undefined\n", newstr); + undefined_set_name_length(p, len + 1); + undefined_name(p) = newstr; + add_undefined(sc, p); + return (p); +} + +static int32_t inchar(s7_pointer pt) +{ + int32_t c; + if (is_file_port(pt)) + c = fgetc(port_file(pt)); /* not uint8_t! -- could be EOF */ + else { + if (port_data_size(pt) <= port_position(pt)) + return (EOF); + c = (uint8_t) port_data(pt)[port_position(pt)++]; + } + if (c == '\n') + port_line_number(pt)++; + return (c); +} + +static void backchar(char c, s7_pointer pt) +{ + if (c == '\n') + port_line_number(pt)--; + + if (is_file_port(pt)) + ungetc(c, port_file(pt)); + else if (port_position(pt) > 0) + port_position(pt)--; +} + +static void resize_strbuf(s7_scheme * sc, s7_int needed_size) +{ + s7_int i, old_size = sc->strbuf_size; + while (sc->strbuf_size <= needed_size) + sc->strbuf_size *= 2; + sc->strbuf = (char *) Realloc(sc->strbuf, sc->strbuf_size); + for (i = old_size; i < sc->strbuf_size; i++) + sc->strbuf[i] = '\0'; +} + +static s7_pointer *chars; + +static s7_pointer unknown_sharp_constant(s7_scheme * sc, char *name, + s7_pointer pt) +{ + if (hook_has_functions(sc->read_error_hook)) { /* check *read-error-hook* */ + s7_pointer result; + bool old_history_enabled; + old_history_enabled = s7_set_history_enabled(sc, false); + /* see sc->error_hook for a more robust way to handle this */ + result = + s7_call(sc, sc->read_error_hook, + set_plist_2(sc, sc->T, + s7_make_string_wrapper(sc, name))); + s7_set_history_enabled(sc, old_history_enabled); + if (result != sc->unspecified) + return (result); + } + if (pt) { /* #<"..."> which gets here as name="#<" */ + s7_int len; + len = safe_strlen(name); + if ((name[len - 1] != '>') && + (is_input_port(pt)) && (pt != sc->standard_input)) { + if (s7_peek_char(sc, pt) != chars[(uint8_t) '"']) /* if not #<"...">, just return it */ + return (make_undefined(sc, name)); + + if (is_string_port(pt)) { /* probably unnecessary (see below) */ + s7_int added_len, c; + const char *pstart, *p; + char *buf; + s7_pointer res; + c = inchar(pt); + pstart = + (const char *) (port_data(pt) + port_position(pt)); + p = strchr(pstart, (int) '"'); + if (!p) { + backchar(c, pt); + return (make_undefined(sc, name)); + } + p++; + while (char_ok_in_a_name[(uint8_t) (*p)]) { + p++; + } + added_len = (s7_int) (p - pstart); /* p is one past '>' presumably */ + /* we can't use strbuf here -- it might be the source of the "name" argument! */ + buf = (char *) malloc(len + added_len + 2); + memcpy((void *) buf, (void *) name, len); + buf[len] = '"'; /* from inchar */ + memcpy((void *) (buf + len + 1), (void *) pstart, + added_len); + buf[len + added_len + 1] = 0; + port_position(pt) += added_len; + res = make_undefined(sc, (const char *) buf); + free(buf); + return (res); + } + } + } + return (make_undefined(sc, name)); +} + +static s7_pointer make_atom(s7_scheme * sc, char *q, int32_t radix, + bool want_symbol, bool with_error); +#define SYMBOL_OK true +#define NO_SYMBOLS false + +static s7_pointer make_sharp_constant(s7_scheme * sc, char *name, + bool with_error, s7_pointer pt, + bool error_if_bad_number) +{ + /* name is the stuff after the '#', return sc->nil if not a recognized #... entity */ + + /* stupid r7rs special cases */ + if ((name[0] == 't') && + ((name[1] == '\0') || (c_strings_are_equal(name, "true")))) + return (sc->T); + + if ((name[0] == 'f') && + ((name[1] == '\0') || (c_strings_are_equal(name, "false")))) + return (sc->F); + + if (name[0] == '_') { + /* this needs to be unsettable via *#readers*: + * (set! *#readers* (list (cons #\_ (lambda (str) (string->symbol (substring str 1)))))) + * (let ((+ -)) (#_+ 1 2)): -1 + */ + s7_pointer sym; + sym = make_symbol(sc, (char *) (name + 1)); + if ((!is_gensym(sym)) && (is_slot(initial_slot(sym)))) + return (initial_value(sym)); + /* here we should not necessarily raise an error that *_... is undefined. reader-cond, for example, needs to + * read undefined #_ vals that it will eventually discard. + */ + return (make_undefined(sc, name)); /* (define x (with-input-from-string "(#_asdf 1 2)" read)) (type-of (car x)) -> undefined? */ + } + + if (is_not_null(slot_value(sc->sharp_readers))) { + s7_pointer x; + x = check_sharp_readers(sc, name); + if (x != sc->F) + return (x); + } + + if ((name[0] == '\0') || name[1] == '\0') + return (unknown_sharp_constant(sc, name, pt)); /* pt here because #<"..."> comes here as "<" so name[1] is '\0'! */ + + switch (name[0]) { + /* -------- #< ... > -------- */ + case '<': + if (c_strings_are_equal(name, "")) + return (sc->unspecified); + + if (c_strings_are_equal(name, "")) + return (sc->undefined); + + if (c_strings_are_equal(name, "")) + return (eof_object); + + return (unknown_sharp_constant(sc, name, pt)); + + /* -------- #o #x #b -------- */ + case 'o': /* #o (octal) */ + case 'x': /* #x (hex) */ + case 'b': /* #b (binary) */ + { + s7_pointer res; + res = + make_atom(sc, (char *) (name + 1), + (name[0] == + 'o') ? 8 : ((name[0] == 'x') ? 16 : 2), + NO_SYMBOLS, with_error); + if ((error_if_bad_number) && (res == sc->F)) { /* #b32 etc but not if called from string->number */ + char buf[256]; + size_t len; + len = snprintf(buf, 256, "#%s is not a number", name); + s7_error(sc, sc->read_error_symbol, set_elist_1(sc, s7_make_string_with_length(sc, buf, len))); /* can't use wrap_string here (buf is local) */ + } + return (res); + } + + /* -------- #\... -------- */ + case '\\': + if (name[2] == 0) /* the most common case: #\a */ + return (chars[(uint8_t) (name[1])]); + /* not uint32_t here! (uint32_t)255 (as a char) returns -1!! */ + switch (name[1]) { + case 'n': + if ((c_strings_are_equal(name + 1, "null")) || + (c_strings_are_equal(name + 1, "nul"))) + return (chars[0]); + + if (c_strings_are_equal(name + 1, "newline")) + return (chars[(uint8_t) '\n']); + break; + + case 's': + if (c_strings_are_equal(name + 1, "space")) + return (chars[(uint8_t) ' ']); + break; + case 'r': + if (c_strings_are_equal(name + 1, "return")) + return (chars[(uint8_t) '\r']); + break; + case 'l': + if (c_strings_are_equal(name + 1, "linefeed")) + return (chars[(uint8_t) '\n']); + break; + case 't': + if (c_strings_are_equal(name + 1, "tab")) + return (chars[(uint8_t) '\t']); + break; + case 'a': + if (c_strings_are_equal(name + 1, "alarm")) + return (chars[7]); + break; + case 'b': + if (c_strings_are_equal(name + 1, "backspace")) + return (chars[8]); + break; + case 'e': + if (c_strings_are_equal(name + 1, "escape")) + return (chars[0x1b]); + break; + case 'd': + if (c_strings_are_equal(name + 1, "delete")) + return (chars[0x7f]); + break; + + case 'x': + /* #\x is just x, but apparently #\x is int->char? #\x65 -> #\e, and #\xcebb is lambda? */ + { + /* sscanf here misses errors like #\x1.4, but make_atom misses #\x6/3, + * #\x#b0, #\x#e0.0, #\x-0, #\x#e0e100 etc, so we have to do it at an even lower level. + * another problem: #\xbdca2cbec overflows so lval is -593310740 -> segfault unless caught + */ + bool happy = true; + char *tmp = (char *) (name + 2); + int32_t lval = 0; + + while ((*tmp) && (happy) && (lval >= 0) && (lval < 256)) { + int32_t dig; + dig = digits[(int32_t) (*tmp++)]; + if (dig < 16) + lval = dig + (lval * 16); + else + happy = false; + } + if ((happy) && (lval < 256) && (lval >= 0)) + return (chars[lval]); + } + break; + } + } + return (unknown_sharp_constant(sc, name, NULL)); +} + +static s7_int string_to_integer(const char *str, int32_t radix, + bool *overflow) +{ + bool negative = false; + s7_int lval = 0; + int32_t dig; + char *tmp = (char *) str; +#if WITH_GMP + char *tmp1; +#endif + if (str[0] == '+') + tmp++; + else if (str[0] == '-') { + negative = true; + tmp++; + } + while (*tmp == '0') { + tmp++; + }; +#if WITH_GMP + tmp1 = tmp; +#endif + if (radix == 10) { + while (true) { + dig = digits[(uint8_t) (*tmp++)]; + if (dig > 9) + break; +#if HAVE_OVERFLOW_CHECKS + if ((multiply_overflow(lval, (s7_int) 10, &lval)) || + (add_overflow(lval, (s7_int) dig, &lval))) { + if ((radix == 10) && (strncmp(str, "-9223372036854775808", 20) == 0) && (digits[(uint8_t) (*tmp++)] > 9)) /* i.e. next thing is not a digit -- "/" for example */ + return (S7_INT64_MIN); + *overflow = true; + return ((negative) ? S7_INT64_MIN : S7_INT64_MAX); + break; + } +#else + lval = dig + (lval * 10); + dig = digits[(uint8_t) (*tmp++)]; + if (dig > 9) + break; + lval = dig + (lval * 10); +#endif + } + } else + while (true) { + dig = digits[(uint8_t) (*tmp++)]; + if (dig >= radix) + break; +#if HAVE_OVERFLOW_CHECKS && (!WITH_GMP) + { + s7_int oval = 0; + if (multiply_overflow(lval, (s7_int) radix, &oval)) { + /* maybe a bad idea! #xffffffffffffffff -> -1??? this is needed for 64-bit number hacks (see s7test.scm bit-reverse) */ + if ((radix == 16) && + (digits[(uint8_t) (*tmp)] >= radix)) { + lval -= 576460752303423488LL; /* turn off sign bit */ + lval *= radix; + lval += dig; + lval -= 9223372036854775807LL; + return (lval - 1); + } + lval = oval; /* old case */ + if ((lval == S7_INT64_MIN) + && (digits[(uint8_t) (*tmp++)] > 9)) + return (lval); + *overflow = true; + break; + } else + lval = oval; + if (add_overflow(lval, (s7_int) dig, &lval)) { + if (lval == S7_INT64_MIN) + return (lval); + *overflow = true; + break; + } + } +#else + lval = dig + (lval * radix); + dig = digits[(uint8_t) (*tmp++)]; + if (dig >= radix) + break; + lval = dig + (lval * radix); +#endif + } + +#if WITH_GMP + if (!(*overflow)) + (*overflow) = ((lval > S7_INT32_MAX) || + ((tmp - tmp1) > s7_int_digits_by_radix[radix])); + /* this tells the string->number readers to create a bignum. We need to be very conservative here to catch contexts such as (/ 1/524288 19073486328125) */ +#endif + return ((negative) ? -lval : lval); +} + +/* 9223372036854775807 9223372036854775807 + * -9223372036854775808 -9223372036854775808 + * 0000000000000000000000000001.0 1.0 + * 1.0000000000000000000000000000 1.0 + * 1000000000000000000000000000.0e-40 1.0e-12 + * 0.0000000000000000000000000001e40 1.0e12 + * 1.0e00000000000000000001 10.0 + */ + +#if WITH_GMP +static s7_double string_to_double_with_radix(const char *ur_str, + int32_t radix, bool *overflow) +#else +#define string_to_double_with_radix(Str, Rad, Over) string_to_double_with_radix_1(Str, Rad) +static s7_double string_to_double_with_radix_1(const char *ur_str, + int32_t radix) +#endif +{ + /* strtod follows LANG which is not what we want (only "." is decimal point in Scheme). + * To overcome LANG in strtod would require screwing around with setlocale which never works. + * So we use our own code -- according to valgrind, this function is much faster than strtod. + * comma as decimal point causes ambiguities: `(+ ,1 2) etc + */ + + int32_t i, sign = 1, frac_len, int_len, dig, max_len, exponent = 0; + int64_t int_part = 0, frac_part = 0; + char *str = (char *) ur_str; + char *ipart, *fpart; + s7_double dval = 0.0; + + /* there's an ambiguity in number notation here if we allow "1e1" or "1.e1" in base 16 (or 15) -- is e a digit or an exponent marker? + * but 1e+1, for example disambiguates it -- kind of messy! -- the scheme spec says "e" can only occur in base 10. + * '@' can now be used as the exponent marker (26-Mar-12). + * Another slight ambiguity: 1+1/2i is parsed as 1 + 0.5i, not 1+1/(2i), or (1+1)/(2i) or (1+1/2)i etc + */ + + max_len = s7_int_digits_by_radix[radix]; + if (*str == '+') + str++; + else if (*str == '-') { + str++; + sign = -1; + } + while (*str == '0') { + str++; + }; + + ipart = str; + while (digits[(int32_t) (*str)] < radix) + str++; + int_len = str - ipart; + + if (*str == '.') + str++; + fpart = str; + while (digits[(int32_t) (*str)] < radix) + str++; + frac_len = str - fpart; + + if ((*str) && (exponent_table[(uint8_t) (*str)])) { + int32_t exp_negative = false; + str++; + if (*str == '+') + str++; + else if (*str == '-') { + str++; + exp_negative = true; + } + while ((dig = digits[(int32_t) (*str++)]) < 10) { /* exponent itself is always base 10 */ +#if HAVE_OVERFLOW_CHECKS + if ((int32_multiply_overflow(exponent, 10, &exponent)) || + (int32_add_overflow(exponent, dig, &exponent))) { + exponent = 1000000; /* see below */ + break; + } +#else + exponent = dig + (exponent * 10); +#endif + } +#if (!defined(__GNUC__)) || ((__GNUC__ < 5) && (!defined(__clang__))) + if (exponent < 0) /* we overflowed, so make sure we notice it below (need to check for 0.0e... first) (Brian Damgaard) */ + exponent = 1000000; /* see below for examples -- this number needs to be very big but not too big for add */ +#endif + if (exp_negative) + exponent = -exponent; + + /* 2e12341234123123123123213123123123 -> 0.0 + * but exp len is not the decider: 2e00000000000000000000000000000000000000001 -> 20.0 + * first zero: 2e123412341231231231231 + * then: 2e12341234123123123123123123 -> inf + * then: 2e123412341231231231231231231231231231 -> 0.0 + * 2e-123412341231231231231 -> inf + * but: 0e123412341231231231231231231231231231 + */ + } + +#if WITH_GMP + /* 9007199254740995.0 */ + if (int_len + frac_len >= max_len) { + (*overflow) = true; + return (0.0); + } +#endif + str = ipart; + if ((int_len + exponent) > max_len) { + /* 12341234.56789e12 12341234567889999872.0 1.234123456789e+19 + * -1234567890123456789.0 -1234567890123456768.0 -1.2345678901235e+18 + * 12345678901234567890.0 12345678901234567168.0 1.2345678901235e+19 + * 123.456e30 123456000000000012741097792995328.0 1.23456e+32 + * 12345678901234567890.0e12 12345678901234569054409354903552.0 1.2345678901235e+31 + * 1.234567890123456789012e30 1234567890123456849145940148224.0 1.2345678901235e+30 + * 1e20 100000000000000000000.0 1e+20 + * 1234567890123456789.0 1234567890123456768.0 1.2345678901235e+18 + * 123.456e16 1234560000000000000.0 1.23456e+18 + * 98765432101234567890987654321.0e-5 987654321012345728401408.0 9.8765432101235e+23 + * 98765432101234567890987654321.0e-10 9876543210123456512.0 9.8765432101235e+18 + * 0.00000000000000001234e20 1234.0 + * 0.000000000000000000000000001234e30 1234.0 + * 0.0000000000000000000000000000000000001234e40 1234.0 + * 0.000000000012345678909876543210e15 12345.678909877 + * 0e1000 0.0 + */ + + for (i = 0; i < max_len; i++) { + dig = digits[(int32_t) (*str++)]; + if (dig < radix) + int_part = dig + (int_part * radix); + else + break; + } + + /* if the exponent is huge, check for 0 int_part and frac_part before complaining (0e1000 or 0.0e1000) + */ + if ((int_part == 0) && (exponent > max_len)) { + /* if frac_part is also 0, return 0.0 */ + if (frac_len == 0) + return (0.0); + + str = fpart; + while ((dig = digits[(int32_t) (*str++)]) < radix) + frac_part = dig + (frac_part * radix); + if (frac_part == 0) + return (0.0); + +#if WITH_GMP + (*overflow) = true; +#endif + } +#if WITH_GMP + (*overflow) = ((int_part > 0) || (exponent > 20)); /* .1e310 is a tricky case */ +#endif + if (int_part != 0) { /* 0.<310 zeros here>1e310 for example -- + * pow (via dpow) thinks it has to be too big, returns Nan, + * then Nan * 0 -> Nan and the NaN propagates + */ + if (int_len <= max_len) + dval = int_part * dpow(radix, exponent); + else + dval = + int_part * dpow(radix, exponent + int_len - max_len); + } else + dval = 0.0; + + /* shift by exponent, but if int_len > max_len then we assumed (see below) int_len - max_len 0's on the left */ + /* using int_to_int or table lookups here instead of pow did not make any difference in speed */ + + if (int_len < max_len) { + int32_t k; + str = fpart; + + for (k = 0; (frac_len > 0) && (k < exponent); k += max_len) { + int32_t flen; + flen = (frac_len > max_len) ? max_len : frac_len; /* ? */ + frac_len -= max_len; + + frac_part = 0; + for (i = 0; i < flen; i++) + frac_part = + digits[(int32_t) (*str++)] + (frac_part * radix); + + if (frac_part != 0) /* same pow->NaN problem as above can occur here */ + dval += frac_part * dpow(radix, exponent - flen - k); + } + } else + /* some of the fraction is in the integer part before the negative exponent shifts it over */ + if (int_len > max_len) { + int32_t ilen; + /* str should be at the last digit we read */ + ilen = int_len - max_len; /* we read these above */ + if (ilen > max_len) + ilen = max_len; + + for (i = 0; i < ilen; i++) + frac_part = + digits[(int32_t) (*str++)] + (frac_part * radix); + + dval += frac_part * dpow(radix, exponent - ilen); + } + return (sign * dval); + } + + /* int_len + exponent <= max_len */ + + if (int_len <= max_len) { + int32_t int_exponent; + /* a better algorithm (since the inaccuracies are in the radix^exponent portion): + * strip off leading zeros and possible sign, + * strip off digits beyond max_len, then remove any trailing zeros. + * (maybe fiddle with the lowest order digit here for rounding, but I doubt it matters) + * read digits until end of number or max_len reached, ignoring the decimal point + * get exponent and use it and decimal point location to position the current result integer + * this always combines the same integer and the same exponent no matter how the number is expressed. + */ + + int_exponent = exponent; + if (int_len > 0) { + char *iend; + iend = (char *) (str + int_len - 1); + while ((*iend == '0') && (iend != str)) { + iend--; + int_exponent++; + } + + while (str <= iend) + int_part = digits[(int32_t) (*str++)] + (int_part * radix); + } + dval = + (int_exponent == + 0) ? (s7_double) int_part : int_part * dpow(radix, + int_exponent); + } else { + int32_t len, flen; + int64_t frpart = 0; + + /* 98765432101234567890987654321.0e-20 987654321.012346 + * 98765432101234567890987654321.0e-29 0.98765432101235 + * 98765432101234567890987654321.0e-30 0.098765432101235 + * 98765432101234567890987654321.0e-28 9.8765432101235 + */ + + len = int_len + exponent; + for (i = 0; i < len; i++) + int_part = digits[(int32_t) (*str++)] + (int_part * radix); + + flen = -exponent; + if (flen > max_len) + flen = max_len; + + for (i = 0; i < flen; i++) + frpart = digits[(int32_t) (*str++)] + (frpart * radix); + + if (len <= 0) + dval = int_part + frpart * dpow(radix, len - flen); + else + dval = int_part + frpart * dpow(radix, -flen); + } + + if (frac_len > 0) { + str = fpart; + if (frac_len <= max_len) { + /* splitting out base 10 case saves very little here */ + /* this ignores trailing zeros, so that 0.3 equals 0.300 */ + char *fend = (char *) (str + frac_len - 1); + + while ((*fend == '0') && (fend != str)) { + fend--; + frac_len--; + } /* (= .6 0.6000) */ + + if ((frac_len & 1) == 0) { + while (str <= fend) { + frac_part = + digits[(int32_t) (*str++)] + (frac_part * radix); + frac_part = + digits[(int32_t) (*str++)] + (frac_part * radix); + } + } else + while (str <= fend) + frac_part = + digits[(int32_t) (*str++)] + (frac_part * radix); + + dval += frac_part * dpow(radix, exponent - frac_len); + + /* 0.6: frac: 6, exp: 0.10000000000000000555, val: 0.60000000000000008882 + * 0.60: frac: 60, exp: 0.01000000000000000021, val: 0.59999999999999997780 + * 0.6000: frac: 6000, exp: 0.00010000000000000000, val: 0.59999999999999997780 + * (= 0.6 0.60): #f + * (= #i3/5 0.6): #f + * so (string->number (number->string num)) == num only if both num's are the same text (or you get lucky) + * (= 0.6 6e-1): #t ; but not 60e-2 + * to fix the 0.60 case, we need to ignore trailing post-dot zeros. + */ + } else { + if (exponent <= 0) { + for (i = 0; i < max_len; i++) + frac_part = + digits[(int32_t) (*str++)] + (frac_part * radix); + + dval += frac_part * dpow(radix, exponent - max_len); + } else { + /* 1.0123456789876543210e1 10.12345678987654373771 + * 1.0123456789876543210e10 10123456789.87654304504394531250 + * 0.000000010000000000000000e10 100.0 + * 0.000000010000000000000000000000000000000000000e10 100.0 + * 0.000000012222222222222222222222222222222222222e10 122.22222222222222 + * 0.000000012222222222222222222222222222222222222e17 1222222222.222222 + */ + + int_part = 0; + for (i = 0; i < exponent; i++) + int_part = + digits[(int32_t) (*str++)] + (int_part * radix); + + frac_len -= exponent; + if (frac_len > max_len) + frac_len = max_len; + + for (i = 0; i < frac_len; i++) + frac_part = + digits[(int32_t) (*str++)] + (frac_part * radix); + + dval += int_part + frac_part * dpow(radix, -frac_len); + } + } + } +#if WITH_GMP + if ((int_part == 0) && (frac_part == 0)) + return (0.0); + (*overflow) = ((frac_len - exponent) > max_len); +#endif + return (sign * dval); +} + +#if (!WITH_GMP) +static s7_pointer make_undefined_bignum(s7_scheme * sc, char *name) +{ + block_t *b; + char *buf; + s7_int len; + s7_pointer res; + len = safe_strlen(name) + 16; + b = mallocate(sc, len); + buf = (char *) block_data(b); + snprintf(buf, len, "", name); + res = make_undefined(sc, (const char *) buf); /* 123123123123123123123123123123 -> +inf.0 originally, but now # */ + liberate(sc, b); + return (res); +} +#endif + +static s7_pointer nan1_or_bust(s7_scheme * sc, s7_double x, char *p, + char *q, int32_t radix, bool want_symbol) +{ + s7_int len; + len = safe_strlen(p); + if (p[len - 1] == 'i') { /* +nan.0[+/-]...i */ + if (len == 6) /* +nan.0+i */ + return (make_complex_not_0i + (sc, x, (p[4] == '+') ? 1.0 : -1.0)); + if ((len > 5) && (len < 1024)) { /* make compiler happy */ + char *ip; + s7_pointer imag; + ip = copy_string_with_length((const char *) (p + 4), len - 5); + imag = + make_atom(sc, ip, radix, NO_SYMBOLS, + WITHOUT_OVERFLOW_ERROR); + free(ip); + if (is_real(imag)) + return (make_complex(sc, x, real_to_double(sc, imag, __func__))); /* +nan.0+2/3i etc */ + } + } + return ((want_symbol) ? make_symbol(sc, q) : sc->F); +} + +static s7_pointer nan2_or_bust(s7_scheme * sc, s7_double x, char *q, + int32_t radix, bool want_symbol) +{ + s7_int len; + len = safe_strlen(q); + if ((len > 7) && (len < 1024)) { /* make compiler happy */ + char *ip; + s7_pointer rl; + ip = copy_string_with_length((const char *) q, len - 7); + rl = make_atom(sc, ip, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR); + free(ip); + if (is_real(rl)) + return (make_complex(sc, real_to_double(sc, rl, __func__), x)); + } + return ((want_symbol) ? make_symbol(sc, q) : sc->F); +} + +static s7_pointer make_atom(s7_scheme * sc, char *q, int32_t radix, + bool want_symbol, bool with_error) +{ + /* make symbol or number from string, a number starts with + - . or digit, but so does 1+ for example */ +#define IS_DIGIT(Chr, Rad) (digits[(uint8_t)Chr] < Rad) + + char c, *p = q; + bool has_dec_point1 = false; + + c = *p++; + switch (c) { + case '#': + /* from string->number, (string->number #xc) */ + return (make_sharp_constant(sc, p, with_error, NULL, false)); /* make_sharp_constant expects the '#' to be removed */ + + case '+': + case '-': + c = *p++; + if (c == '.') { + has_dec_point1 = true; + c = *p++; + } + if (!c) + return ((want_symbol) ? make_symbol(sc, q) : sc->F); + if (!IS_DIGIT(c, radix)) { + if (has_dec_point1) + return ((want_symbol) ? make_symbol(sc, q) : sc->F); + if (c == 'n') { + if (local_strcmp(p, "an.0")) /* +nan.0 */ + return (real_NaN); + if ((local_strncmp(p, "an.0", 4)) && + ((p[4] == '+') || (p[4] == '-'))) + return (nan1_or_bust + (sc, NAN, p, q, radix, want_symbol)); + } + if (c == 'i') { + if (local_strcmp(p, "nf.0")) /* +inf.0 */ + return ((q[0] == + '+') ? real_infinity : real_minus_infinity); + if ((local_strncmp(p, "nf.0", 4)) + && ((p[4] == '+') || (p[4] == '-'))) + return (nan1_or_bust + (sc, (q[0] == '-') ? -INFINITY : INFINITY, p, + q, radix, want_symbol)); + } + return ((want_symbol) ? make_symbol(sc, q) : sc->F); + } + break; + + case '.': + has_dec_point1 = true; + c = *p++; + + if ((!c) || (!IS_DIGIT(c, radix))) + return ((want_symbol) ? make_symbol(sc, q) : sc->F); + break; + + case 'n': + return ((want_symbol) ? make_symbol(sc, q) : sc->F); + + case 'i': + return ((want_symbol) ? make_symbol(sc, q) : sc->F); + + case '0': /* these two are always digits */ + case '1': + break; + + default: + if (!IS_DIGIT(c, radix)) + return ((want_symbol) ? make_symbol(sc, q) : sc->F); + break; + } + + /* now it's possibly a number -- the first character(s) could be part of a number in the current radix */ + { + char *slash1 = NULL, *slash2 = NULL, *plus = NULL, *ex1 = + NULL, *ex2 = NULL; + bool has_i = false, has_dec_point2 = false; + int32_t has_plus_or_minus = 0, current_radix; +#if (!WITH_GMP) + bool overflow = false; /* for string_to_integer */ +#endif + current_radix = radix; /* current_radix is 10 for the exponent portions, but radix for all the rest */ + + for (; (c = *p) != 0; ++p) { + /* what about embedded null? (string->number (string #\1 (integer->char 0) #\0)) + * currently we stop and return 1, but Guile returns #f. + * this also means we can't use substring_uncopied if (string->number (substring...)) + */ + if (!IS_DIGIT(c, current_radix)) { /* moving this inside the switch statement was much slower */ + current_radix = radix; + + switch (c) { + /* -------- decimal point -------- */ + case '.': + if ((!IS_DIGIT(p[1], current_radix)) && + (!IS_DIGIT(p[-1], current_radix))) + return ((want_symbol) ? make_symbol(sc, q) : + sc->F); + + if (has_plus_or_minus == 0) { + if ((has_dec_point1) || (slash1)) + return ((want_symbol) ? make_symbol(sc, q) : + sc->F); + has_dec_point1 = true; + } else { + if ((has_dec_point2) || (slash2)) + return ((want_symbol) ? make_symbol(sc, q) : + sc->F); + has_dec_point2 = true; + } + continue; + + /* -------- exponent marker -------- */ +#if WITH_EXTRA_EXPONENT_MARKERS + /* 1st 3d-perspective 0.0f 128.0f 3d 1s -- in 2 million lines of public scheme code, not one actual use! */ + case 's': + case 'S': + case 'd': + case 'D': + case 'f': + case 'F': + case 'l': + case 'L': +#endif + case 'e': + case 'E': + if (current_radix > 10) /* see above */ + return ((want_symbol) ? make_symbol(sc, q) : + sc->F); + /* fall through -- if '@' used, radices>10 are ok */ + + case '@': + current_radix = 10; + + if (((ex1) || (slash1)) && (has_plus_or_minus == 0)) /* ee */ + return ((want_symbol) ? make_symbol(sc, q) : + sc->F); + + if (((ex2) || (slash2)) && (has_plus_or_minus != 0)) /* 1+1.0ee */ + return ((want_symbol) ? make_symbol(sc, q) : + sc->F); + + if ((!IS_DIGIT(p[-1], radix)) && /* was current_radix but that's always 10! */ + (p[-1] != '.')) + return ((want_symbol) ? make_symbol(sc, q) : + sc->F); + + if (has_plus_or_minus == 0) { + ex1 = p; + has_dec_point1 = true; /* decimal point illegal from now on */ + } else { + ex2 = p; + has_dec_point2 = true; + } + p++; + if ((*p == '-') || (*p == '+')) + p++; + if (IS_DIGIT(*p, current_radix)) + continue; + break; + + /* -------- internal + or - -------- */ + case '+': + case '-': + if (has_plus_or_minus != 0) /* already have the separator */ + return ((want_symbol) ? make_symbol(sc, q) : + sc->F); + + if (c == '+') + has_plus_or_minus = 1; + else + has_plus_or_minus = -1; + plus = (char *) (p + 1); + /* now check for nan/inf as imaginary part */ + + if ((plus[0] == 'n') && (local_strcmp(plus, "nan.0i"))) + return (nan2_or_bust + (sc, (c == '+') ? NAN : -NAN, q, radix, + want_symbol)); + if ((plus[0] == 'i') && (local_strcmp(plus, "inf.0i"))) + return (nan2_or_bust + (sc, (c == '+') ? INFINITY : -INFINITY, q, + radix, want_symbol)); + continue; + + /* ratio marker */ + case '/': + if ((has_plus_or_minus == 0) && + ((ex1) || (slash1) || (has_dec_point1))) + return ((want_symbol) ? make_symbol(sc, q) : + sc->F); + + if ((has_plus_or_minus != 0) && + ((ex2) || (slash2) || (has_dec_point2))) + return ((want_symbol) ? make_symbol(sc, q) : + sc->F); + + if (has_plus_or_minus == 0) + slash1 = (char *) (p + 1); + else + slash2 = (char *) (p + 1); + + if ((!IS_DIGIT(p[1], current_radix)) || + (!IS_DIGIT(p[-1], current_radix))) + return ((want_symbol) ? make_symbol(sc, q) : + sc->F); + + continue; + + /* -------- i for the imaginary part -------- */ + case 'i': + if ((has_plus_or_minus != 0) && (!has_i)) { + has_i = true; + continue; + } + break; + + default: + break; + } + return ((want_symbol) ? make_symbol(sc, q) : sc->F); + } + } + + if ((has_plus_or_minus != 0) && /* that is, we have an internal + or - */ + (!has_i)) /* but no i for the imaginary part */ + return ((want_symbol) ? make_symbol(sc, q) : sc->F); + + if (has_i) { +#if (!WITH_GMP) + s7_double rl = 0.0, im = 0.0; +#else + char e1 = 0, e2 = 0; +#endif + s7_pointer result; + s7_int len; + char ql1, pl1; + + len = safe_strlen(q); + + if (q[len - 1] != 'i') + return ((want_symbol) ? make_symbol(sc, q) : sc->F); + + /* save original string */ + ql1 = q[len - 1]; + pl1 = (*(plus - 1)); +#if WITH_GMP + if (ex1) { + e1 = *ex1; + (*ex1) = '@'; + } /* for mpfr */ + if (ex2) { + e2 = *ex2; + (*ex2) = '@'; + } +#endif + /* look for cases like 1+i */ + q[len - 1] = ((q[len - 2] == '+') || (q[len - 2] == '-')) ? '1' : '\0'; /* remove 'i' */ + + (*((char *) (plus - 1))) = '\0'; + +#if (!WITH_GMP) + if ((has_dec_point1) || (ex1)) /* (string->number "1100.1+0.11i" 2) -- need to split into 2 honest reals before passing to non-base-10 str->dbl */ + rl = string_to_double_with_radix(q, radix, ignored); + else { /* no decimal point, no exponent, a ratio (1/2+i for example, but 1+2/3i is handled below) */ + if (slash1) { + /* here the overflow could be innocuous if it's in the denominator and the numerator is 0: 0/100000000000000000000000000000000000000 */ + s7_int num, den; + num = string_to_integer(q, radix, &overflow); + if (overflow) + return (make_undefined_bignum(sc, q)); + den = string_to_integer(slash1, radix, &overflow); + if (den == 0) + rl = NAN; /* real_part if complex */ + else { + if (num == 0) { + rl = 0.0; + overflow = false; + } else { + if (overflow) + return (make_undefined_bignum(sc, q)); /* denominator overflow */ + rl = (long_double) num / (long_double) den; /* no gmp, so we do what we can */ + } + } + } else { + rl = (s7_double) string_to_integer(q, radix, + &overflow); + if (overflow) + return (make_undefined_bignum(sc, q)); + } + } + if (rl == -0.0) + rl = 0.0; + + if ((has_dec_point2) || (ex2)) + im = string_to_double_with_radix(plus, radix, ignored); + else { + if (slash2) { /* complex part I think */ + /* same as above: 0-0/100000000000000000000000000000000000000i */ + s7_int num, den; + num = string_to_integer(plus, radix, &overflow); + if (overflow) + return (make_undefined_bignum(sc, q)); + den = string_to_integer(slash2, radix, &overflow); + if (den == 0) + im = NAN; + else { + if (num == 0) { + im = 0.0; + overflow = false; + } else { + if (overflow) + return (make_undefined_bignum(sc, q)); /* denominator overflow */ + im = (long_double) num / (long_double) den; + } + } + } else { + im = (s7_double) string_to_integer(plus, radix, + &overflow); + if (overflow) + return (make_undefined_bignum(sc, q)); + } + } + if ((has_plus_or_minus == -1) && (im != 0.0)) + im = -im; + result = s7_make_complex(sc, rl, im); +#else + result = + string_to_either_complex(sc, q, slash1, ex1, + has_dec_point1, plus, slash2, ex2, + has_dec_point2, radix, + has_plus_or_minus); +#endif + /* restore original string */ + q[len - 1] = ql1; + (*((char *) (plus - 1))) = pl1; +#if WITH_GMP + if (ex1) + (*ex1) = e1; + if (ex2) + (*ex2) = e2; +#endif + return (result); + } + + /* not complex */ + if ((has_dec_point1) || (ex1)) { + s7_pointer result; + + if (slash1) /* not complex, so slash and "." is not a number */ + return ((want_symbol) ? make_symbol(sc, q) : sc->F); + +#if (!WITH_GMP) + result = + make_real(sc, + string_to_double_with_radix(q, radix, ignored)); +#else + { + char old_e = 0; + if (ex1) { + old_e = (*ex1); + (*ex1) = '@'; + } + result = string_to_either_real(sc, q, radix); + if (ex1) + (*ex1) = old_e; + } +#endif + return (result); + } + + /* rational */ + if (slash1) +#if (!WITH_GMP) + { + s7_int n, d; + + n = string_to_integer(q, radix, &overflow); + if (overflow) + return (make_undefined_bignum(sc, q)); + d = string_to_integer(slash1, radix, &overflow); + + if ((n == 0) && (d != 0)) /* 0/100000000000000000000000000000000000000 */ + return (int_zero); + if (d == 0) + return (real_NaN); + if (overflow) + return (make_undefined_bignum(sc, q)); + /* it would be neat to return 1 from 10000000000000000000000000000/10000000000000000000000000000 + * but q is the entire number ('/' included) and slash1 is the stuff after the '/', and every + * big number comes through here, so there's no clean and safe way to check that q == slash1. + */ + return (make_ratio(sc, n, d)); + } +#else + return (string_to_either_ratio(sc, q, slash1, radix)); +#endif + /* integer */ +#if (!WITH_GMP) + { + s7_int x; + x = string_to_integer(q, radix, &overflow); + if (overflow) + return (make_undefined_bignum(sc, q)); + return (make_integer(sc, x)); + } +#else + return (string_to_either_integer(sc, q, radix)); +#endif + } +} + + +/* -------------------------------- string->number -------------------------------- */ + +static s7_pointer string_to_number(s7_scheme * sc, char *str, + int32_t radix) +{ + s7_pointer x; + x = make_atom(sc, str, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR); + return ((is_number(x)) ? x : sc->F); /* only needed because str might start with '#' and not be a number (#t for example) */ +} + +static s7_pointer string_to_number_p_p(s7_scheme * sc, s7_pointer str1) +{ + char *str; + if (!is_string(str1)) + return (wrong_type_argument + (sc, sc->string_to_number_symbol, 1, str1, T_STRING)); + str = (char *) string_value(str1); + return (((!str) || (!(*str))) ? sc->F : string_to_number(sc, str, 10)); +} + +static s7_pointer string_to_number_p_pp(s7_scheme * sc, s7_pointer str1, + s7_pointer radix1) +{ + s7_int radix; + char *str; + if (!is_string(str1)) + return (wrong_type_argument + (sc, sc->string_to_number_symbol, 1, str1, T_STRING)); + + if (!is_t_integer(radix1)) + return (wrong_type_argument + (sc, sc->string_to_number_symbol, 2, radix1, T_INTEGER)); + radix = integer(radix1); + if ((radix < 2) || (radix > 16)) + return (out_of_range + (sc, sc->string_to_number_symbol, int_two, radix1, + a_valid_radix_string)); + + str = (char *) string_value(str1); + if ((!str) || (!(*str))) + return (sc->F); + return (string_to_number(sc, str, radix)); +} + +static s7_pointer g_string_to_number_1(s7_scheme * sc, s7_pointer args, + s7_pointer caller) +{ + s7_int radix; + char *str; + if (!is_string(car(args))) + return (method_or_bust(sc, car(args), caller, args, T_STRING, 1)); + + if (is_pair(cdr(args))) { + s7_pointer rad = cadr(args); + if (!s7_is_integer(rad)) + return (method_or_bust(sc, rad, caller, args, T_INTEGER, 2)); + radix = s7_integer_checked(sc, rad); + if ((radix < 2) || (radix > 16)) + return (out_of_range + (sc, caller, int_two, rad, a_valid_radix_string)); + } else + radix = 10; + str = (char *) string_value(car(args)); + if ((!str) || (!(*str))) + return (sc->F); + return (string_to_number(sc, str, radix)); +} + +static s7_pointer g_string_to_number(s7_scheme * sc, s7_pointer args) +{ +#define H_string_to_number "(string->number str (radix 10)) converts str into a number. \ +If str does not represent a number, string->number returns #f. If 'str' has an embedded radix, \ +the optional 'radix' argument is ignored: (string->number \"#x11\" 2) -> 17 not 3." +#define Q_string_to_number s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_number_symbol, sc->not_symbol), sc->is_string_symbol, sc->is_integer_symbol) + return (g_string_to_number_1(sc, args, sc->string_to_number_symbol)); +} + + +/* -------------------------------- abs -------------------------------- */ +static inline s7_pointer abs_p_p(s7_scheme * sc, s7_pointer x) +{ +#if (!WITH_GMP) + if (is_t_integer(x)) { + if (integer(x) >= 0) + return (x); + if (integer(x) > S7_INT64_MIN) + return (make_integer(sc, -integer(x))); + } + if (is_t_real(x)) { + if (is_NaN(real(x))) /* (abs -nan.0) -> +nan.0, not -nan.0 */ + return (real_NaN); + return ((signbit(real(x))) ? make_real(sc, -real(x)) : x); + } +#endif + switch (type(x)) { + case T_INTEGER: + if (integer(x) >= 0) + return (x); +#if WITH_GMP + if (integer(x) == S7_INT64_MIN) { + x = s7_int_to_big_integer(sc, integer(x)); + mpz_neg(big_integer(x), big_integer(x)); + return (x); + } +#else + if (integer(x) == S7_INT64_MIN) + return (simple_out_of_range + (sc, sc->abs_symbol, set_elist_1(sc, x), + result_is_too_large_string)); +#endif + return (make_integer(sc, -integer(x))); + + case T_RATIO: + if (numerator(x) >= 0) + return (x); +#if WITH_GMP && (!POINTER_32) + if (numerator(x) == S7_INT64_MIN) { + s7_pointer p; + mpz_set_si(sc->mpz_1, S7_INT64_MIN); + mpz_neg(sc->mpz_1, sc->mpz_1); + mpz_set_si(sc->mpz_2, denominator(x)); + new_cell(sc, p, T_BIG_RATIO); + big_ratio_bgr(p) = alloc_bigrat(sc); + add_big_ratio(sc, p); + mpq_set_num(big_ratio(p), sc->mpz_1); + mpq_set_den(big_ratio(p), sc->mpz_2); + return (p); + } +#else + if (numerator(x) == S7_INT64_MIN) + return (make_ratio(sc, S7_INT64_MAX, denominator(x))); +#endif + return (make_simple_ratio(sc, -numerator(x), denominator(x))); + + case T_REAL: + if (is_NaN(real(x))) /* (abs -nan.0) -> +nan.0, not -nan.0 */ + return (real_NaN); + return ((signbit(real(x))) ? make_real(sc, -real(x)) : x); /* (abs -0.0) returns -0.0 -- Shiro Kawai */ +#if WITH_GMP + case T_BIG_INTEGER: + mpz_abs(sc->mpz_1, big_integer(x)); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_abs(sc->mpq_1, big_ratio(x)); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_abs(sc->mpfr_1, big_real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); +#endif + default: + return (method_or_bust_one_arg_p(sc, x, sc->abs_symbol, T_REAL)); + } +} + +static s7_pointer g_abs(s7_scheme * sc, s7_pointer args) +{ +#define H_abs "(abs x) returns the absolute value of the real number x" +#define Q_abs s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol) + return (abs_p_p(sc, car(args))); +} + +static s7_double abs_d_d(s7_double x) +{ + return ((signbit(x)) ? (-x) : x); +} + +static s7_int abs_i_i(s7_int x) +{ + return ((x < 0) ? (-x) : x); +} + + +/* -------------------------------- magnitude -------------------------------- */ +static double my_hypot(double x, double y) +{ + /* according to callgrind, this is much faster than libc's hypot */ + if (x == 0.0) + return (fabs(y)); + if (y == 0.0) + return (fabs(x)); + if (x == y) + return (1.414213562373095 * fabs(x)); + if ((is_NaN(x)) || (is_NaN(y))) + return (NAN); + return (sqrt(x * x + y * y)); +} + +static s7_pointer magnitude_p_p(s7_scheme * sc, s7_pointer x) +{ + if (is_t_complex(x)) + return (make_real(sc, my_hypot(imag_part(x), real_part(x)))); + + switch (type(x)) { + case T_INTEGER: + if (integer(x) == S7_INT64_MIN) + return (mostfix); + /* (magnitude -9223372036854775808) -> -9223372036854775808 + * same thing happens in abs, lcm and gcd: (gcd -9223372036854775808) -> -9223372036854775808 + */ + return ((integer(x) < 0) ? make_integer(sc, -integer(x)) : x); + + case T_RATIO: + return ((numerator(x) < 0) ? make_simple_ratio(sc, -numerator(x), + denominator(x)) : + x); + + case T_REAL: + if (is_NaN(real(x))) /* (magnitude -nan.0) -> +nan.0, not -nan.0 */ + return (real_NaN); + return ((signbit(real(x))) ? make_real(sc, -real(x)) : x); + +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + case T_BIG_REAL: + return (abs_p_p(sc, x)); + + case T_BIG_COMPLEX: + mpc_abs(sc->mpfr_1, big_complex(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); +#endif + + default: + return (method_or_bust_with_type_one_arg_p + (sc, x, sc->magnitude_symbol, a_number_string)); + } +} + +static s7_pointer g_magnitude(s7_scheme * sc, s7_pointer args) +{ +#define H_magnitude "(magnitude z) returns the magnitude of z" +#define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) + return (magnitude_p_p(sc, car(args))); +} + + +/* -------------------------------- rationalize -------------------------------- */ +#if WITH_GMP + +static rat_locals_t *init_rat_locals_t(s7_scheme * sc) +{ + rat_locals_t *r; + r = (rat_locals_t *) malloc(sizeof(rat_locals_t)); + sc->ratloc = r; + mpz_inits(r->i, r->i0, r->i1, r->n, r->p0, r->q0, r->r, r->r1, r->p1, + r->q1, r->old_p1, r->old_q1, NULL); + mpq_init(r->q); + mpfr_inits2(sc->bignum_precision, r->error, r->ux, r->x0, r->x1, + r->val, r->e0, r->e1, r->e0p, r->e1p, r->old_e0, r->old_e1, + r->old_e0p, NULL); + return (r); +} + +static void free_rat_locals(s7_scheme * sc) +{ + rat_locals_t *r; + r = sc->ratloc; + mpz_clears(r->i, r->i0, r->i1, r->n, r->p0, r->q0, r->r, r->r1, r->p1, + r->q1, r->old_p1, r->old_q1, NULL); + mpq_clear(r->q); + mpfr_clears(r->error, r->ux, r->x0, r->x1, r->val, r->e0, r->e1, + r->e0p, r->e1p, r->old_e0, r->old_e1, r->old_e0p, NULL); + free(r); +} + +static s7_pointer big_rationalize(s7_scheme * sc, s7_pointer args) +{ + /* can return be non-rational? */ + /* currently (rationalize 1/0 1e18) -> 0 + * remember to pad with many trailing zeros: + * (rationalize 0.1 0) -> 3602879701896397/36028797018963968 + * (rationalize 0.1000000000000000 0) -> 1/10 + * perhaps gmp number reader used if gmp -- could this be the trailing zeros problem? (why is the non-gmp case ok?) + * also the bignum function is faking it. + * (rationalize (real-part (bignum "0.1+i")) 0) -> 3602879701896397/36028797018963968 + * a confusing case: + * (rationalize 5925563891587147521650777143.74135805596e05) should be 148139097289678688041269428593533951399/250000 + * but that requires more than 128 bits of bignum-precision. + */ + + s7_pointer pp0 = car(args); + rat_locals_t *r; + + if (!sc->ratloc) + r = init_rat_locals_t(sc); + else + r = sc->ratloc; + + switch (type(pp0)) { + case T_INTEGER: + mpfr_set_si(r->ux, integer(pp0), MPFR_RNDN); + break; + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(pp0), denominator(pp0)); + mpfr_set_q(r->ux, sc->mpq_1, MPFR_RNDN); + break; + case T_REAL: + if (is_NaN(real(pp0))) + return (out_of_range + (sc, sc->rationalize_symbol, int_one, pp0, + its_nan_string)); + if (is_inf(real(pp0))) + return (out_of_range + (sc, sc->rationalize_symbol, int_one, pp0, + its_infinite_string)); + mpfr_set_d(r->ux, real(pp0), MPFR_RNDN); + break; + case T_BIG_INTEGER: + mpfr_set_z(r->ux, big_integer(pp0), MPFR_RNDN); + break; + case T_BIG_RATIO: + mpfr_set_q(r->ux, big_ratio(pp0), MPFR_RNDN); + break; + case T_BIG_REAL: + if (mpfr_nan_p(big_real(pp0))) + return (out_of_range + (sc, sc->rationalize_symbol, int_one, pp0, + its_nan_string)); + if (mpfr_inf_p(big_real(pp0))) + return (out_of_range + (sc, sc->rationalize_symbol, int_one, pp0, + its_infinite_string)); + mpfr_set(r->ux, big_real(pp0), MPFR_RNDN); + break; + case T_COMPLEX: + case T_BIG_COMPLEX: + return (wrong_type_argument + (sc, sc->rationalize_symbol, 1, pp0, T_REAL)); + default: + return (method_or_bust + (sc, pp0, sc->rationalize_symbol, args, T_REAL, 1)); + } + + if (is_null(cdr(args))) + mpfr_set_d(r->error, sc->default_rationalize_error, MPFR_RNDN); + else { + s7_pointer pp1 = cadr(args); + + switch (type(pp1)) { + case T_INTEGER: + mpfr_set_si(r->error, integer(pp1), MPFR_RNDN); + break; + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(pp1), denominator(pp1)); + mpfr_set_q(r->error, sc->mpq_1, MPFR_RNDN); + break; + case T_REAL: + if (is_NaN(real(pp1))) + return (out_of_range + (sc, sc->rationalize_symbol, int_two, pp1, + its_nan_string)); + if (is_inf(real(pp1))) + return (int_zero); + mpfr_set_d(r->error, real(pp1), MPFR_RNDN); + break; + case T_BIG_INTEGER: + mpfr_set_z(r->error, big_integer(pp1), MPFR_RNDN); + break; + case T_BIG_RATIO: + mpfr_set_q(r->error, big_ratio(pp1), MPFR_RNDN); + break; + case T_BIG_REAL: + if (mpfr_nan_p(big_real(pp1))) + return (out_of_range + (sc, sc->rationalize_symbol, int_two, pp1, + its_nan_string)); + if (mpfr_inf_p(big_real(pp1))) + return (int_zero); + mpfr_set(r->error, big_real(pp1), MPFR_RNDN); + break; + case T_COMPLEX: + case T_BIG_COMPLEX: + return (wrong_type_argument + (sc, sc->rationalize_symbol, 2, pp1, T_REAL)); + default: + return (method_or_bust + (sc, pp1, sc->rationalize_symbol, args, T_REAL, 2)); + } + mpfr_abs(r->error, r->error, MPFR_RNDN); + } + + mpfr_set(r->x0, r->ux, MPFR_RNDN); /* x0 = ux - error */ + mpfr_sub(r->x0, r->x0, r->error, MPFR_RNDN); + mpfr_set(r->x1, r->ux, MPFR_RNDN); /* x1 = ux + error */ + mpfr_add(r->x1, r->x1, r->error, MPFR_RNDN); + mpfr_get_z(r->i, r->x0, MPFR_RNDU); /* i = ceil(x0) */ + + if (mpfr_cmp_ui(r->error, 1) >= 0) { /* if (error >= 1.0) */ + if (mpfr_cmp_ui(r->x0, 0) < 0) { /* if (x0 < 0) */ + if (mpfr_cmp_ui(r->x1, 0) < 0) /* if (x1 < 0) */ + mpfr_get_z(r->n, r->x1, MPFR_RNDD); /* num = floor(x1) */ + else + mpz_set_ui(r->n, 0); /* else num = 0 */ + } else + mpz_set(r->n, r->i); /* else num = i */ + return (mpz_to_integer(sc, r->n)); + } + + if (mpfr_cmp_z(r->x1, r->i) >= 0) { /* if (x1 >= i) */ + if (mpz_cmp_ui(r->i, 0) >= 0) /* if (i >= 0) */ + mpz_set(r->n, r->i); /* num = i */ + else + mpfr_get_z(r->n, r->x1, MPFR_RNDD); /* else num = floor(x1) */ + return (mpz_to_integer(sc, r->n)); + } + + mpfr_get_z(r->i0, r->x0, MPFR_RNDD); /* i0 = floor(x0) */ + mpfr_get_z(r->i1, r->x1, MPFR_RNDU); /* i1 = ceil(x1) */ + + mpz_set(r->p0, r->i0); /* p0 = i0 */ + mpz_set_ui(r->q0, 1); /* q0 = 1 */ + mpz_set(r->p1, r->i1); /* p1 = i1 */ + mpz_set_ui(r->q1, 1); /* q1 = 1 */ + mpfr_sub_z(r->e0, r->x0, r->i1, MPFR_RNDN); /* e0 = i1 - x0 */ + mpfr_neg(r->e0, r->e0, MPFR_RNDN); + mpfr_sub_z(r->e1, r->x0, r->i0, MPFR_RNDN); /* e1 = x0 - i0 */ + mpfr_sub_z(r->e0p, r->x1, r->i1, MPFR_RNDN); /* e0p = i1 - x1 */ + mpfr_neg(r->e0p, r->e0p, MPFR_RNDN); + mpfr_sub_z(r->e1p, r->x1, r->i0, MPFR_RNDN); /* e1p = x1 - i0 */ + + while (true) { + mpfr_set_z(r->val, r->p0, MPFR_RNDN); + mpfr_div_z(r->val, r->val, r->q0, MPFR_RNDN); /* val = p0/q0 */ + + if (((mpfr_lessequal_p(r->x0, r->val)) && /* if ((x0 <= val) && (val <= x1)) */ + (mpfr_lessequal_p(r->val, r->x1))) || + (mpfr_cmp_ui(r->e1, 0) == 0) || (mpfr_cmp_ui(r->e1p, 0) == 0)) + /* these last 2 are probably not needed -- they protect against running out of bits in the non-gmp case above */ + { + mpq_set_num(r->q, r->p0); /* return(p0/q0) */ + mpq_set_den(r->q, r->q0); + return (mpq_to_rational(sc, r->q)); + } + + mpfr_div(r->val, r->e0, r->e1, MPFR_RNDN); + mpfr_get_z(r->r, r->val, MPFR_RNDD); /* r = floor(e0/e1) */ + mpfr_div(r->val, r->e0p, r->e1p, MPFR_RNDN); + mpfr_get_z(r->r1, r->val, MPFR_RNDU); /* r1 = ceil(e0p/e1p) */ + if (mpz_cmp(r->r1, r->r) < 0) /* if (r1 < r) */ + mpz_set(r->r, r->r1); /* r = r1 */ + + mpz_set(r->old_p1, r->p1); /* old_p1 = p1 */ + mpz_set(r->p1, r->p0); /* p1 = p0 */ + mpz_set(r->old_q1, r->q1); /* old_q1 = q1 */ + mpz_set(r->q1, r->q0); /* q1 = q0 */ + + mpfr_set(r->old_e0, r->e0, MPFR_RNDN); /* old_e0 = e0 */ + mpfr_set(r->e0, r->e1p, MPFR_RNDN); /* e0 = e1p */ + mpfr_set(r->old_e0p, r->e0p, MPFR_RNDN); /* old_e0p = e0p */ + mpfr_set(r->e0p, r->e1, MPFR_RNDN); /* e0p = e1 */ + mpfr_set(r->old_e1, r->e1, MPFR_RNDN); /* old_e1 = e1 */ + + mpz_mul(r->p0, r->p0, r->r); /* p0 = old_p1 + r * p0 */ + mpz_add(r->p0, r->p0, r->old_p1); + + mpz_mul(r->q0, r->q0, r->r); /* q0 = old_q1 + r * q0 */ + mpz_add(r->q0, r->q0, r->old_q1); + + mpfr_mul_z(r->e1, r->e1p, r->r, MPFR_RNDN); /* e1 = old_e0p - r * e1p */ + mpfr_sub(r->e1, r->old_e0p, r->e1, MPFR_RNDN); + + mpfr_mul_z(r->e1p, r->old_e1, r->r, MPFR_RNDN); /* e1p = old_e0 - r * old_e1 */ + mpfr_sub(r->e1p, r->old_e0, r->e1p, MPFR_RNDN); + } +} +#endif + +static s7_pointer g_rationalize(s7_scheme * sc, s7_pointer args) +{ +#define H_rationalize "(rationalize x err) returns the ratio with smallest denominator within err of x" +#define Q_rationalize s7_make_signature(sc, 3, sc->is_rational_symbol, sc->is_real_symbol, sc->is_real_symbol) + /* I can't find a case where this returns a non-rational result */ + + s7_double err; + s7_pointer x = car(args); + +#if WITH_GMP + if (is_big_number(x)) + return (big_rationalize(sc, args)); +#endif + if (!is_real(x)) + return (method_or_bust + (sc, x, sc->rationalize_symbol, args, T_REAL, 1)); + + if (is_null(cdr(args))) + err = sc->default_rationalize_error; + else { + s7_pointer ex = cadr(args); +#if WITH_GMP + if (is_big_number(ex)) + return (big_rationalize(sc, args)); +#endif + if (!is_real(ex)) + return (method_or_bust + (sc, ex, sc->rationalize_symbol, args, T_REAL, 2)); + err = real_to_double(sc, ex, "rationalize"); + if (is_NaN(err)) + return (out_of_range + (sc, sc->rationalize_symbol, int_two, cadr(args), + its_nan_string)); + if (err < 0.0) + err = -err; + } + + switch (type(x)) { + case T_INTEGER: + { + s7_int a, b, pa; + if (err < 1.0) + return (x); + a = integer(x); + if (a < 0) + pa = -a; + else + pa = a; + if (err >= pa) + return (int_zero); + b = (s7_int) err; + pa -= b; + return ((a < 0) ? make_integer(sc, -pa) : make_integer(sc, + pa)); + } + + case T_RATIO: + if (err == 0.0) + return (x); + + case T_REAL: + { + s7_double rat = s7_real(x); /* possible fall through from above */ + s7_int numer = 0, denom = 1; + + if ((is_NaN(rat)) || (is_inf(rat))) + return (out_of_range + (sc, sc->rationalize_symbol, int_one, x, + a_normal_real_string)); + + if (err >= fabs(rat)) + return (int_zero); + +#if WITH_GMP + if (fabs(rat) > RATIONALIZE_LIMIT) + return (big_rationalize + (sc, set_plist_2(sc, x, wrap_real1(sc, err)))); +#else + if (fabs(rat) > RATIONALIZE_LIMIT) + return (out_of_range + (sc, sc->rationalize_symbol, int_one, x, + its_too_large_string)); +#endif + if ((fabs(rat) + fabs(err)) < 1.0e-18) + err = 1.0e-18; + /* (/ 1.0 most-positive-fixnum) is 1.0842021e-19, so if we let err be less than that, + * (rationalize 1e-19 1e-20) hangs, but this only affects the initial ceiling, I believe. + */ + + if (fabs(rat) < fabs(err)) + return (int_zero); + + return ((c_rationalize(rat, err, &numer, &denom)) ? + make_ratio(sc, numer, denom) : sc->F); + } + } + return (sc->F); /* make compiler happy */ +} + +static s7_int rationalize_i_i(s7_int x) +{ + return (x); +} + +static s7_pointer rationalize_p_i(s7_scheme * sc, s7_int x) +{ + return (make_integer(sc, x)); +} + +static s7_pointer rationalize_p_d(s7_scheme * sc, s7_double x) +{ + if ((is_NaN(x)) || (is_inf(x))) + return (out_of_range(sc, sc->rationalize_symbol, int_one, wrap_real1(sc, x), a_normal_real_string)); /* was make_real, also below */ + if (fabs(x) > RATIONALIZE_LIMIT) +#if WITH_GMP + return (big_rationalize(sc, set_plist_1(sc, wrap_real1(sc, x)))); +#else + return (out_of_range + (sc, sc->rationalize_symbol, int_one, wrap_real1(sc, x), + its_too_large_string)); +#endif + return (s7_rationalize(sc, x, sc->default_rationalize_error)); +} + + +/* -------------------------------- angle -------------------------------- */ +static s7_pointer g_angle(s7_scheme * sc, s7_pointer args) +{ +#define H_angle "(angle z) returns the angle of z" +#define Q_angle s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) + + s7_pointer x = car(args); /* (angle inf+infi) -> 0.78539816339745 ? I think this should be -pi < ang <= pi */ + switch (type(x)) { + case T_INTEGER: + return ((integer(x) < 0) ? real_pi : int_zero); + case T_RATIO: + return ((numerator(x) < 0) ? real_pi : int_zero); + case T_COMPLEX: + return (make_real(sc, atan2(imag_part(x), real_part(x)))); + + case T_REAL: + if (is_NaN(real(x))) + return (x); + return ((real(x) < 0.0) ? real_pi : real_zero); +#if WITH_GMP + case T_BIG_INTEGER: + return ((mpz_cmp_ui(big_integer(x), 0) >= + 0) ? int_zero : big_pi(sc)); + case T_BIG_RATIO: + return ((mpq_cmp_ui(big_ratio(x), 0, 1) >= + 0) ? int_zero : big_pi(sc)); + + case T_BIG_REAL: + if (mpfr_nan_p(big_real(x))) + return (x); + return ((mpfr_cmp_d(big_real(x), 0.0) >= + 0) ? real_zero : big_pi(sc)); + + case T_BIG_COMPLEX: + { + s7_pointer z; + new_cell(sc, z, T_BIG_REAL); + big_real_bgf(z) = alloc_bigflt(sc); + add_big_real(sc, z); + mpc_arg(big_real(z), big_complex(x), MPFR_RNDN); + return (z); + } +#endif + default: + return (method_or_bust_with_type_one_arg + (sc, x, sc->angle_symbol, args, a_number_string)); + } +} + + +/* -------------------------------- complex -------------------------------- */ +static s7_pointer g_complex(s7_scheme * sc, s7_pointer args) +{ +#define H_complex "(complex x1 x2) returns a complex number with real-part x1 and imaginary-part x2" +#define Q_complex s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol) + + s7_pointer x = car(args), y = cadr(args); + +#if WITH_GMP + if ((is_big_number(x)) || (is_big_number(y))) { + s7_pointer p0 = x, p1, p = NULL; + + if (!is_real(p0)) + return (method_or_bust + (sc, p0, sc->complex_symbol, args, T_REAL, 1)); + + p1 = y; + if (!is_real(p1)) + return (method_or_bust + (sc, p1, sc->complex_symbol, args, T_REAL, 2)); + + switch (type(p1)) { + case T_INTEGER: + case T_RATIO: + case T_REAL: + { + s7_double iz = s7_real(p1); + if (iz == 0.0) /* imag-part is 0.0 */ + return (p0); + new_cell(sc, p, T_BIG_COMPLEX); + big_complex_bgc(p) = alloc_bigcmp(sc); + mpfr_set_d(mpc_imagref(big_complex(p)), iz, MPFR_RNDN); + } + break; + + case T_BIG_REAL: + if (mpfr_zero_p(big_real(p1))) + return (p0); + new_cell(sc, p, T_BIG_COMPLEX); + big_complex_bgc(p) = alloc_bigcmp(sc); + mpfr_set(mpc_imagref(big_complex(p)), big_real(p1), MPFR_RNDN); + break; + + case T_BIG_RATIO: + new_cell(sc, p, T_BIG_COMPLEX); + big_complex_bgc(p) = alloc_bigcmp(sc); + mpfr_set_q(mpc_imagref(big_complex(p)), big_ratio(p1), + MPFR_RNDN); + break; + + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(p1), 0) == 0) + return (p0); + new_cell(sc, p, T_BIG_COMPLEX); + big_complex_bgc(p) = alloc_bigcmp(sc); + mpfr_set_z(mpc_imagref(big_complex(p)), big_integer(p1), + MPFR_RNDN); + break; + } + + switch (type(p0)) { + case T_INTEGER: + case T_RATIO: + case T_REAL: + mpfr_set_d(mpc_realref(big_complex(p)), s7_real(p0), + MPFR_RNDN); + break; + + case T_BIG_REAL: + mpfr_set(mpc_realref(big_complex(p)), big_real(p0), MPFR_RNDN); + break; + + case T_BIG_RATIO: + mpfr_set_q(mpc_realref(big_complex(p)), big_ratio(p0), + MPFR_RNDN); + break; + + case T_BIG_INTEGER: + mpfr_set_z(mpc_realref(big_complex(p)), big_integer(p0), + MPFR_RNDN); + break; + } + add_big_complex(sc, p); + return (p); + } +#endif + switch (type(y)) { + case T_INTEGER: + switch (type(x)) { + case T_INTEGER: + return ((integer(y) == 0) ? x : s7_make_complex(sc, (s7_double) + integer(x), + (s7_double) + integer(y))); + /* these int->dbl's are problematic: + * (complex 9223372036854775807 9007199254740995): 9223372036854776000.0+9007199254740996.0i + * should we raise an error? + */ + case T_RATIO: + return ((integer(y) == 0) ? x : s7_make_complex(sc, (s7_double) + fraction(x), + (s7_double) + integer(y))); + case T_REAL: + return ((integer(y) == 0) ? x : s7_make_complex(sc, real(x), + (s7_double) + integer(y))); + default: + return (method_or_bust + (sc, x, sc->complex_symbol, args, T_REAL, 1)); + } + + case T_RATIO: + switch (type(x)) { + case T_INTEGER: + return (s7_make_complex(sc, (s7_double) integer(x), (s7_double) fraction(y))); /* can fraction be 0.0? */ + case T_RATIO: + return (s7_make_complex + (sc, (s7_double) fraction(x), + (s7_double) fraction(y))); + case T_REAL: + return (s7_make_complex(sc, real(x), (s7_double) fraction(y))); + default: + return (method_or_bust + (sc, x, sc->complex_symbol, args, T_REAL, 1)); + } + + case T_REAL: + switch (type(x)) { + case T_INTEGER: + return ((real(y) == 0.0) ? x : s7_make_complex(sc, (s7_double) + integer(x), + real(y))); + case T_RATIO: + return ((real(y) == 0.0) ? x : s7_make_complex(sc, (s7_double) + fraction(x), + real(y))); + case T_REAL: + return ((real(y) == 0.0) ? x : s7_make_complex(sc, real(x), + real(y))); + default: + return (method_or_bust + (sc, x, sc->complex_symbol, args, T_REAL, 1)); + } + + default: + return (method_or_bust + (sc, (is_let(x)) ? x : y, sc->complex_symbol, args, T_REAL, + 2)); + } +} + +static s7_pointer complex_p_ii(s7_scheme * sc, s7_int x, s7_int y) +{ + return ((y == 0.0) ? make_integer(sc, x) : make_complex_not_0i(sc, + (s7_double) + x, + (s7_double) + y)); +} + +static s7_pointer complex_p_dd(s7_scheme * sc, s7_double x, s7_double y) +{ + return ((y == 0.0) ? make_real(sc, x) : make_complex_not_0i(sc, x, y)); +} + + +/* -------------------------------- bignum -------------------------------- */ +static s7_pointer g_bignum(s7_scheme * sc, s7_pointer args) +{ +#define H_bignum "(bignum val (radix 10)) returns a multiprecision version of the string 'val'. If the argument is a number \ +bignum returns that number as a bignum" +#define Q_bignum s7_make_signature(sc, 3, sc->is_bignum_symbol, s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_string_symbol), sc->is_integer_symbol) + +#if WITH_GMP + s7_pointer p = car(args); + if (is_number(p)) { + if (!is_null(cdr(args))) + s7_error(sc, make_symbol(sc, "bignum-error"), + set_elist_2(sc, + wrap_string(sc, + "bignum of a number takes only one argument: ~S", + 46), args)); + switch (type(p)) { + case T_INTEGER: + return (s7_int_to_big_integer(sc, integer(p))); + case T_RATIO: + return (s7_int_to_big_ratio(sc, numerator(p), denominator(p))); + case T_REAL: + return (s7_double_to_big_real(sc, real(p))); + case T_COMPLEX: + return (s7_double_to_big_complex + (sc, real_part(p), imag_part(p))); + default: + return (p); + } + } + p = g_string_to_number_1(sc, args, sc->bignum_symbol); + if (is_false(sc, p)) /* (bignum "1/3.0") */ + s7_error(sc, make_symbol(sc, "bignum-error"), + set_elist_2(sc, + wrap_string(sc, + "bignum string argument does not represent a number: ~S", + 54), car(args))); + switch (type(p)) { + case T_INTEGER: + return (s7_int_to_big_integer(sc, integer(p))); + case T_RATIO: + return (s7_int_to_big_ratio(sc, numerator(p), denominator(p))); + case T_COMPLEX: + return (s7_number_to_big_complex(sc, p)); + case T_REAL: + if (is_NaN(real(p))) + return (p); + return (string_to_big_real + (sc, string_value(car(args)), + (is_pair(cdr(args))) ? s7_integer_checked(sc, + cadr(args)) : + 10)); + default: + return (p); + } +#else + return ((is_number(car(args))) ? car(args) : + g_string_to_number_1(sc, args, sc->bignum_symbol)); +#endif +} + + +/* -------------------------------- exp -------------------------------- */ +#if (!HAVE_COMPLEX_NUMBERS) +static s7_pointer no_complex_numbers_string; +#endif + +#define EXP_LIMIT 100.0 + +#if WITH_GMP +static s7_pointer exp_1(s7_scheme * sc, s7_double x) +{ + mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN); + mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); +} + +static s7_pointer exp_2(s7_scheme * sc, s7_double x, s7_double y) +{ + mpc_set_d_d(sc->mpc_1, x, y, MPC_RNDNN); + mpc_exp(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +} +#endif + +static s7_pointer exp_p_p(s7_scheme * sc, s7_pointer x) +{ + double z; + switch (type(x)) { + case T_INTEGER: + if (integer(x) == 0) + return (int_one); /* (exp 0) -> 1 */ + z = (s7_double) integer(x); +#if WITH_GMP + if (fabs(z) > EXP_LIMIT) + return (exp_1(sc, z)); +#endif + return (make_real(sc, exp(z))); + + case T_RATIO: + z = (s7_double) fraction(x); +#if WITH_GMP + if (fabs(z) > EXP_LIMIT) + return (exp_1(sc, z)); +#endif + return (make_real(sc, exp(z))); + + case T_REAL: +#if WITH_GMP + if (fabs(real(x)) > EXP_LIMIT) + return (exp_1(sc, real(x))); +#endif + return (make_real(sc, exp(real(x)))); + + case T_COMPLEX: +#if HAVE_COMPLEX_NUMBERS +#if WITH_GMP + if ((fabs(real_part(x)) > EXP_LIMIT) || + (fabs(imag_part(x)) > EXP_LIMIT)) + return (exp_2(sc, real_part(x), imag_part(x))); +#endif + return (c_complex_to_s7(sc, cexp(to_c_complex(x)))); + /* this is inaccurate for large arguments: + * (exp 0+1e20i) -> -0.66491178990701-0.74692189125949i, not 7.639704044417283004001468027378811228331E-1-6.45251285265780844205811711312523007406E-1i + */ +#else + return (out_of_range + (sc, sc->exp_symbol, int_one, x, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_REAL: + mpfr_exp(sc->mpfr_1, big_real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_COMPLEX: + mpc_exp(sc->mpc_1, big_complex(x), MPC_RNDNN); + if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) + return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg + (sc, x, sc->exp_symbol, set_plist_1(sc, x), + a_number_string)); + } +} + +static s7_pointer g_exp(s7_scheme * sc, s7_pointer args) +{ +#define H_exp "(exp z) returns e^z, (exp 1) is 2.718281828459" +#define Q_exp sc->pl_nn + return (exp_p_p(sc, car(args))); +} + +#if (!WITH_GMP) +static s7_double exp_d_d(s7_double x) +{ + return (exp(x)); +} +#endif + + +/* -------------------------------- log -------------------------------- */ +#if __cplusplus +#define LOG_2 1.4426950408889634074 +#else +#define LOG_2 1.4426950408889634073599246810018921L /* (/ (log 2.0)) */ +#endif +static bool is_nan_b_7p(s7_scheme * sc, s7_pointer x); + +#if WITH_GMP +static s7_pointer big_log(s7_scheme * sc, s7_pointer args) +{ + s7_pointer p0 = car(args), p1 = NULL, res; + + if (!is_number(p0)) + return (method_or_bust_with_type + (sc, p0, sc->log_symbol, args, a_number_string, 1)); + + if (is_pair(cdr(args))) { + p1 = cadr(args); + if (!is_number(p1)) + return (method_or_bust_with_type + (sc, p1, sc->log_symbol, args, a_number_string, 2)); + } + + if (is_real(p0)) { + res = any_real_to_mpfr(sc, p0, sc->mpfr_1); + if (res == real_NaN) + return (res); + if ((is_positive(sc, p0)) && + ((!p1) || ((is_real(p1)) && (is_positive(sc, p1))))) { + if (res) + return (res); + mpfr_log(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + if (p1) { + res = any_real_to_mpfr(sc, p1, sc->mpfr_2); + if (res) + return ((res == real_infinity) ? real_zero : res); + if (mpfr_zero_p(sc->mpfr_2)) + return (out_of_range + (sc, sc->log_symbol, int_two, p1, + wrap_string(sc, "can't be zero", 13))); + mpfr_log(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); + mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + } + if ((mpfr_integer_p(sc->mpfr_1)) + && ((is_rational(p0)) && ((!p1) || (is_rational(p1))))) + return (mpfr_to_integer(sc, sc->mpfr_1)); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } + } + + if (p1) { + res = any_number_to_mpc(sc, p1, sc->mpc_2); + if (res) + return ((res == real_infinity) ? real_zero : complex_NaN); + if (mpc_zero_p(sc->mpc_2)) + return (out_of_range + (sc, sc->log_symbol, int_two, p1, + wrap_string(sc, "can't be zero", 13))); + } + res = any_number_to_mpc(sc, p0, sc->mpc_1); + if (res) { + if ((res == real_infinity) && (p1) && ((is_negative(sc, p0)))) + return (make_complex_not_0i(sc, INFINITY, -NAN)); + return ((res == real_NaN) ? complex_NaN : res); + } + mpc_log(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + if (p1) { + mpc_log(sc->mpc_2, sc->mpc_2, MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + } + if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) + return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return (mpc_to_number(sc, sc->mpc_1)); +} +#endif + +static s7_pointer g_log(s7_scheme * sc, s7_pointer args) +{ +#define H_log "(log z1 (z2 e)) returns log(z1) / log(z2) where z2 (the base) defaults to e: (log 8 2) = 3" +#define Q_log sc->pcl_n + + s7_pointer x = car(args); + if (!is_number(x)) + return (method_or_bust_with_type + (sc, x, sc->log_symbol, args, a_number_string, 1)); + +#if WITH_GMP + if (is_big_number(x)) + return (big_log(sc, args)); +#endif + if (is_pair(cdr(args))) { + s7_pointer y = cadr(args); + if (!(is_number(y))) + return (method_or_bust_with_type + (sc, y, sc->log_symbol, args, a_number_string, 2)); + +#if WITH_GMP + if (is_big_number(y)) + return (big_log(sc, args)); +#endif + if ((is_t_integer(y)) && (integer(y) == 2)) { + /* (define (2^n? x) (and (not (zero? x)) (zero? (logand x (- x 1))))) */ + if (is_t_integer(x)) { + s7_int ix; + ix = integer(x); + if (ix > 0) { + s7_double fx; +#if (__ANDROID__) || (MS_WINDOWS) || (((__GNUC__) && ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ <= 4)))) && (!defined(__clang__))) + /* just a guess -- log2 gets a warning in gcc 4.3.2, but not in 4.4.4 */ + fx = log((double) ix) / log(2.0); +#else + fx = log2((double) ix); +#endif + /* (s7_int)fx rounds (log 8 2) to 2 in FreeBSD! */ +#if (((__GNUC__) && ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 4)))) && (!defined(__clang__))) + return (make_real(sc, fx)); +#else + return (((ix & (ix - 1)) == 0) ? make_integer(sc, + (s7_int) + s7_round + (fx)) : + make_real(sc, fx)); +#endif + } + } + if ((is_real(x)) && (is_positive(sc, x))) + return (make_real(sc, log(s7_real(x)) * LOG_2)); + return (c_complex_to_s7(sc, clog(s7_to_c_complex(x)) * LOG_2)); + } + + if ((is_t_integer(x)) && (integer(x) == 1) && (is_t_integer(y)) && (integer(y) == 1)) /* (log 1 1) -> 0 (this is NaN in the bignum case) */ + return (int_zero); + + /* (log 1 0) must be 0 since everyone says (expt 0 0) is 1 */ + if (is_zero(sc, y)) { + if ((is_t_integer(y)) && (is_t_integer(x)) + && (integer(x) == 1)) + return (y); + return (out_of_range + (sc, sc->log_symbol, int_two, y, + wrap_string(sc, "can't be zero", 13))); + } + + if ((is_t_real(x)) && (is_NaN(real(x)))) + return (real_NaN); + if (is_one(y)) /* this used to raise an error, but the bignum case is simpler if we return inf */ + return ((is_one(x)) ? real_zero : real_infinity); /* but (log 1.0 1.0) -> 0.0, currently (log 1/0 1) is inf? */ + + if ((is_real(x)) && + (is_real(y)) && (is_positive(sc, x)) && (is_positive(sc, y))) { + if ((is_rational(x)) && (is_rational(y))) { + s7_double res; + s7_int ires; + res = + log(rational_to_double(sc, x)) / + log(rational_to_double(sc, y)); + ires = (s7_int) res; + if (res - ires == 0.0) + return (make_integer(sc, ires)); /* (log 8 2) -> 3 or (log 1/8 2) -> -3 */ + /* since x and y are rational here, it seems reasonable to try to rationalize the result, but not go overboard? + * what about (expt 16 3/2) -> 64? also 2 as base is handled above and always returns a float. + */ + if (fabs(res) < RATIONALIZE_LIMIT) { + s7_int num, den; + if ((c_rationalize + (res, sc->default_rationalize_error, &num, &den)) + && (s7_int_abs(num) < 100) + && (s7_int_abs(den) < 100)) + return (make_simple_ratio(sc, num, den)); + } + return (make_real(sc, res)); + } + return (make_real(sc, log(s7_real(x)) / log(s7_real(y)))); + } + if ((is_t_real(x)) && (is_NaN(real(x)))) + return (real_NaN); + if ((is_t_complex(y)) + && ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))))) + return (real_NaN); + return (c_complex_to_s7 + (sc, clog(s7_to_c_complex(x)) / clog(s7_to_c_complex(y)))); + } + + if (!is_real(x)) + return (c_complex_to_s7(sc, clog(s7_to_c_complex(x)))); + if (is_positive(sc, x)) + return (make_real(sc, log(s7_real(x)))); + return (make_complex_not_0i(sc, log(-s7_real(x)), M_PI)); +} + + +/* -------------------------------- sin -------------------------------- */ +#define SIN_LIMIT 1.0e16 +#define SINH_LIMIT 20.0 +/* (- (sinh (bignum 30.0)) (sinh 30.0)): -3.718172657214174140191915872003397016115E-4 + * (- (sinh (bignum 20.0)) (sinh 20.0)): -7.865629467297586346406367346575835463792E-10, slightly worse (e-8) if imag-part + */ + +static s7_pointer sin_p_p(s7_scheme * sc, s7_pointer x) +{ +#if (!WITH_GMP) + if (is_t_real(x)) + return (make_real(sc, sin(real(x)))); /* range check in gmp case */ +#endif + switch (type(x)) { + case T_INTEGER: + if (integer(x) == 0) + return (int_zero); /* (sin 0) -> 0 */ +#if WITH_GMP + if (integer(x) > SIN_LIMIT) { + mpz_set_si(sc->mpz_1, integer(x)); + mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); + mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, sin((s7_double) (integer(x))))); + + case T_RATIO: + return (make_real(sc, sin((s7_double) (fraction(x))))); + + case T_REAL: + { + s7_double y = real(x); +#if WITH_GMP + if (fabs(y) > SIN_LIMIT) { + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, sin(y))); + } + + case T_COMPLEX: +#if WITH_GMP + if ((fabs(real_part(x)) > SIN_LIMIT) + || (fabs(imag_part(x)) > SINH_LIMIT)) { + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_sin(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + } +#endif +#if HAVE_COMPLEX_NUMBERS + return (c_complex_to_s7(sc, csin(to_c_complex(x)))); +#else + return (out_of_range + (sc, sc->sin_symbol, int_one, x, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_REAL: + mpfr_sin(sc->mpfr_1, big_real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_COMPLEX: + mpc_sin(sc->mpc_1, big_complex(x), MPC_RNDNN); + if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) + return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg_p + (sc, x, sc->sin_symbol, a_number_string)); + } + /* sin is inaccurate over about 1e30. There's a way to get true results, but it involves fancy "range reduction" techniques. + * (sin 1e32): 0.5852334864823946 + * but it should be 3.901970254333630491697613212893425767786E-1 + * (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 !! (it's now a range error) + * it should be 5.263007914620499494429139986095833592117E0 + * before comparing imag-part to 0, we need to look for NaN and inf, else: + * (sinh 0+0/0i) -> 0.0 and (sinh (log 0.0)) -> inf.0 + */ +} + +static s7_pointer g_sin(s7_scheme * sc, s7_pointer args) +{ +#define H_sin "(sin z) returns sin(z)" +#define Q_sin sc->pl_nn + return (sin_p_p(sc, car(args))); +} + +#if WITH_GMP +static s7_pointer sin_p_d(s7_scheme * sc, s7_double x) +{ + if (fabs(x) <= SIN_LIMIT) + return (make_real(sc, sin(x))); + mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN); + mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); +} +#else +static s7_pointer sin_p_d(s7_scheme * sc, s7_double x) +{ + return (make_real(sc, sin(x))); +} +#endif + +static s7_double sin_d_d(s7_double x) +{ + return (sin(x)); +} + + +/* -------------------------------- cos -------------------------------- */ +static s7_pointer cos_p_p(s7_scheme * sc, s7_pointer x) +{ +#if (!WITH_GMP) + if (is_t_real(x)) + return (make_real(sc, cos(real(x)))); /* range check in gmp case */ +#endif + switch (type(x)) { + case T_INTEGER: + if (integer(x) == 0) + return (int_one); /* (cos 0) -> 1 */ +#if WITH_GMP + if (integer(x) > SIN_LIMIT) { + mpz_set_si(sc->mpz_1, integer(x)); + mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); + mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, cos((s7_double) (integer(x))))); + + case T_RATIO: + return (make_real(sc, cos((s7_double) (fraction(x))))); + + case T_REAL: /* if with_gmp */ + { + s7_double y = real(x); +#if WITH_GMP + if (fabs(y) > SIN_LIMIT) { + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, cos(y))); + } + + case T_COMPLEX: +#if WITH_GMP + if ((fabs(real_part(x)) > SIN_LIMIT) + || (fabs(imag_part(x)) > SINH_LIMIT)) { + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_cos(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + } +#endif +#if HAVE_COMPLEX_NUMBERS + return (c_complex_to_s7(sc, ccos(to_c_complex(x)))); +#else + return (out_of_range + (sc, sc->cos_symbol, int_one, x, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_REAL: + mpfr_cos(sc->mpfr_1, big_real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_COMPLEX: + mpc_cos(sc->mpc_1, big_complex(x), MPC_RNDNN); + if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) + return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg_p + (sc, x, sc->cos_symbol, a_number_string)); + } +} + +static s7_pointer g_cos(s7_scheme * sc, s7_pointer args) +{ +#define H_cos "(cos z) returns cos(z)" +#define Q_cos sc->pl_nn + return (cos_p_p(sc, car(args))); +} + +#if WITH_GMP +static s7_pointer cos_p_d(s7_scheme * sc, s7_double x) +{ + if (fabs(x) <= SIN_LIMIT) + return (make_real(sc, cos(x))); + mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN); + mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); +} +#else +static s7_pointer cos_p_d(s7_scheme * sc, s7_double x) +{ + return (make_real(sc, cos(x))); +} +#endif + +static s7_double cos_d_d(s7_double x) +{ + return (cos(x)); +} + + +/* -------------------------------- tan -------------------------------- */ +#define TAN_LIMIT 1.0e18 + +static s7_pointer tan_p_p(s7_scheme * sc, s7_pointer x) +{ +#if (!WITH_GMP) + if (is_t_real(x)) + return (make_real(sc, tan(real(x)))); +#endif + switch (type(x)) { + case T_INTEGER: + if (integer(x) == 0) + return (int_zero); /* (tan 0) -> 0 */ +#if WITH_GMP + if (integer(x) > TAN_LIMIT) { + mpz_set_si(sc->mpz_1, integer(x)); + mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); + mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, tan((s7_double) (integer(x))))); + + case T_RATIO: + return (make_real(sc, tan((s7_double) (fraction(x))))); + +#if WITH_GMP + case T_REAL: + if (fabs(real(x)) > TAN_LIMIT) { + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, tan(real(x)))); + + case T_COMPLEX: +#if HAVE_COMPLEX_NUMBERS + if (imag_part(x) > 350.0) + return (make_complex_not_0i(sc, 0.0, 1.0)); + return ((imag_part(x) < -350.0) ? s7_make_complex(sc, 0.0, + -1.0) : + c_complex_to_s7(sc, ctan(to_c_complex(x)))); +#else + return (out_of_range + (sc, sc->tan_symbol, int_one, x, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_REAL: + mpfr_tan(sc->mpfr_1, big_real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_COMPLEX: + if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, 350))) > 0) + return (make_complex_not_0i(sc, 0.0, 1.0)); + if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, -350))) < 0) + return (make_complex_not_0i(sc, 0.0, -1.0)); + mpc_tan(sc->mpc_1, big_complex(x), MPC_RNDNN); + if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) + return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg_p + (sc, x, sc->tan_symbol, a_number_string)); + } +} + +static s7_pointer g_tan(s7_scheme * sc, s7_pointer args) +{ +#define H_tan "(tan z) returns tan(z)" +#define Q_tan sc->pl_nn + return (tan_p_p(sc, car(args))); +} + +static s7_double tan_d_d(s7_double x) +{ + return (tan(x)); +} + + +/* -------------------------------- asin -------------------------------- */ +static s7_pointer c_asin(s7_scheme * sc, s7_double x) +{ + s7_double absx = fabs(x), recip; + s7_complex result; + + if (absx <= 1.0) + return (make_real(sc, asin(x))); + + /* otherwise use maxima code: */ + recip = 1.0 / absx; + result = + (M_PI / 2.0) - + (_Complex_I * + clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip))))); + return ((x < 0.0) ? c_complex_to_s7(sc, -result) : c_complex_to_s7(sc, + result)); +} + +static s7_pointer asin_p_p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_real(p)) + return (c_asin(sc, real(p))); + switch (type(p)) { + case T_INTEGER: + if (integer(p) == 0) + return (int_zero); /* (asin 0) -> 0 */ + /* in netBSD, (asin 2) returns 0.25383842987008+0.25383842987008i according to Peter Bex */ + return (c_asin(sc, (s7_double) integer(p))); + + case T_RATIO: + return (c_asin(sc, fraction(p))); + + case T_COMPLEX: +#if HAVE_COMPLEX_NUMBERS + /* if either real or imag part is very large, use explicit formula, not casin */ + /* this code taken from sbcl's src/code/irrat.lisp; break is around x+70000000i */ + if ((fabs(real_part(p)) > 1.0e7) || (fabs(imag_part(p)) > 1.0e7)) { + s7_complex sq1mz, sq1pz, z; + z = to_c_complex(p); + sq1mz = csqrt(1.0 - z); + sq1pz = csqrt(1.0 + z); + return (s7_make_complex + (sc, atan(real_part(p) / creal(sq1mz * sq1pz)), + asinh(cimag(sq1pz * conj(sq1mz))))); + } + return (c_complex_to_s7(sc, casin(to_c_complex(p)))); +#else + return (out_of_range + (sc, sc->asin_symbol, int_one, p, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN); + goto ASIN_BIG_REAL; + + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN); + goto ASIN_BIG_REAL; + + case T_BIG_REAL: + if (mpfr_inf_p(big_real(p))) { + if (mpfr_cmp_ui(big_real(p), 0) < 0) + return (make_complex_not_0i(sc, NAN, INFINITY)); /* match non-bignum choice */ + return (make_complex_not_0i(sc, NAN, -INFINITY)); + } + mpfr_set(sc->mpfr_1, big_real(p), MPFR_RNDN); + ASIN_BIG_REAL: + mpfr_set_ui(sc->mpfr_2, 1, MPFR_RNDN); + if (mpfr_cmpabs(sc->mpfr_1, sc->mpfr_2) <= 0) { + mpfr_asin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } + mpc_set_fr(sc->mpc_1, sc->mpfr_1, MPC_RNDNN); + mpc_asin(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + + case T_BIG_COMPLEX: + mpc_asin(sc->mpc_1, big_complex(p), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg_p + (sc, p, sc->asin_symbol, a_number_string)); + } +} + +static s7_pointer g_asin(s7_scheme * sc, s7_pointer args) +{ +#define H_asin "(asin z) returns asin(z); (sin (asin x)) = x" +#define Q_asin sc->pl_nn + return (asin_p_p(sc, car(args))); +} + + +/* -------------------------------- acos -------------------------------- */ +static s7_pointer c_acos(s7_scheme * sc, s7_double x) +{ + s7_double absx = fabs(x), recip; + s7_complex result; + + if (absx <= 1.0) + return (make_real(sc, acos(x))); + + /* else follow maxima again: */ + recip = 1.0 / absx; + if (x > 0.0) + result = + _Complex_I * clog(absx * + (1.0 + + (sqrt(1.0 + recip) * csqrt(1.0 - recip)))); + else + result = + M_PI - + _Complex_I * clog(absx * + (1.0 + + (sqrt(1.0 + recip) * csqrt(1.0 - recip)))); + return (c_complex_to_s7(sc, result)); +} + +static s7_pointer acos_p_p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_real(p)) + return (c_acos(sc, real(p))); + switch (type(p)) { + case T_INTEGER: + return ((integer(p) == 1) ? int_zero : c_acos(sc, (s7_double) + integer(p))); + + case T_RATIO: + return (c_acos(sc, fraction(p))); + + case T_COMPLEX: +#if HAVE_COMPLEX_NUMBERS + /* if either real or imag part is very large, use explicit formula, not cacos */ + /* this code taken from sbcl's src/code/irrat.lisp */ + + if ((fabs(real_part(p)) > 1.0e7) || (fabs(imag_part(p)) > 1.0e7)) { + s7_complex sq1mz, sq1pz, z; + z = to_c_complex(p); + sq1mz = csqrt(1.0 - z); + sq1pz = csqrt(1.0 + z); /* creal(sq1pz) can be 0.0 */ + if (creal(sq1pz) == 0.0) /* so the atan arg will be inf, so the real part will be pi/2(?) */ + return (s7_make_complex + (sc, M_PI / 2.0, + asinh(cimag(sq1mz * conj(sq1pz))))); + return (s7_make_complex + (sc, 2.0 * atan(creal(sq1mz) / creal(sq1pz)), + asinh(cimag(sq1mz * conj(sq1pz))))); + } + return (c_complex_to_s7(sc, cacos(s7_to_c_complex(p)))); +#else + return (out_of_range + (sc, sc->acos_symbol, int_one, p, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN); + goto ACOS_BIG_REAL; + + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN); + goto ACOS_BIG_REAL; + + case T_BIG_REAL: + if (mpfr_inf_p(big_real(p))) { + if (mpfr_cmp_ui(big_real(p), 0) < 0) + return (make_complex_not_0i(sc, -NAN, -INFINITY)); /* match non-bignum choice */ + return (make_complex_not_0i(sc, -NAN, INFINITY)); + } + mpfr_set(sc->mpfr_1, big_real(p), MPFR_RNDN); + ACOS_BIG_REAL: + mpfr_set_ui(sc->mpfr_2, 1, MPFR_RNDN); + if (mpfr_cmpabs(sc->mpfr_1, sc->mpfr_2) <= 0) { + mpfr_acos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } + mpc_set_fr(sc->mpc_1, sc->mpfr_1, MPC_RNDNN); + mpc_acos(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + + case T_BIG_COMPLEX: + mpc_acos(sc->mpc_1, big_complex(p), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg_p + (sc, p, sc->acos_symbol, a_number_string)); + } +} + +static s7_pointer g_acos(s7_scheme * sc, s7_pointer args) +{ +#define H_acos "(acos z) returns acos(z); (cos (acos 1)) = 1" +#define Q_acos sc->pl_nn + return (acos_p_p(sc, car(args))); +} + + +/* -------------------------------- atan -------------------------------- */ +static s7_pointer g_atan(s7_scheme * sc, s7_pointer args) +{ +#define H_atan "(atan z) returns atan(z), (atan y x) returns atan(y/x)" +#define Q_atan s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_real_symbol) + /* actually if there are two args, both should be real, but how to express that in the signature? */ + + s7_pointer x = car(args), y; + /* currently (atan inf.0 inf.0) -> 0.78539816339745, and (atan inf.0 -inf.0) -> 2.3561944901923 (etc) */ + + if (!is_pair(cdr(args))) { + switch (type(x)) { + case T_INTEGER: + return ((integer(x) == 0) ? int_zero : make_real(sc, + atan((double) + integer + (x)))); + case T_RATIO: + return (make_real(sc, atan(fraction(x)))); + case T_REAL: + return (make_real(sc, atan(real(x)))); + + case T_COMPLEX: +#if HAVE_COMPLEX_NUMBERS + return (c_complex_to_s7(sc, catan(to_c_complex(x)))); +#else + return (out_of_range + (sc, sc->atan_symbol, int_one, x, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_atan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_atan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_REAL: + mpfr_atan(sc->mpfr_1, big_real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_COMPLEX: + mpc_atan(sc->mpc_1, big_complex(x), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg + (sc, x, sc->atan_symbol, args, a_number_string)); + } + } + + y = cadr(args); + switch (type(x)) { + case T_INTEGER: + case T_RATIO: + case T_REAL: + if (is_small_real(y)) + return (make_real(sc, atan2(s7_real(x), s7_real(y)))); +#if WITH_GMP + if (!is_real(y)) + return (method_or_bust + (sc, y, sc->atan_symbol, args, T_REAL, 2)); + mpfr_set_d(sc->mpfr_1, s7_real(x), MPFR_RNDN); + goto ATAN2_BIG_REAL; + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + goto ATAN2_BIG_REAL; + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + goto ATAN2_BIG_REAL; + case T_BIG_REAL: + mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); + goto ATAN2_BIG_REAL; +#endif + default: + return (method_or_bust(sc, x, sc->atan_symbol, args, T_REAL, 1)); + } +#if WITH_GMP + ATAN2_BIG_REAL: + if (is_small_real(y)) + mpfr_set_d(sc->mpfr_2, s7_real(y), MPFR_RNDN); + else if (is_t_big_real(y)) + mpfr_set(sc->mpfr_2, big_real(y), MPFR_RNDN); + else if (is_t_big_integer(y)) + mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); + else if (is_t_big_ratio(y)) + mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); + else + return (method_or_bust(sc, y, sc->atan_symbol, args, T_REAL, 2)); + mpfr_atan2(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); +#endif +} + +static s7_double atan_d_dd(s7_double x, s7_double y) +{ + return (atan2(x, y)); +} + + +/* -------------------------------- sinh -------------------------------- */ +static s7_pointer g_sinh(s7_scheme * sc, s7_pointer args) +{ +#define H_sinh "(sinh z) returns sinh(z)" +#define Q_sinh sc->pl_nn + + s7_pointer x = car(args); + switch (type(x)) { + case T_INTEGER: + if (integer(x) == 0) + return (int_zero); /* (sinh 0) -> 0 */ + + case T_REAL: + case T_RATIO: + { + s7_double y = s7_real(x); +#if WITH_GMP + if (fabs(y) > SINH_LIMIT) { + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, sinh(y))); + } + + case T_COMPLEX: +#if WITH_GMP + if ((fabs(real_part(x)) > SINH_LIMIT) + || (fabs(imag_part(x)) > SINH_LIMIT)) { + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_sinh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + } +#endif +#if HAVE_COMPLEX_NUMBERS + return (c_complex_to_s7(sc, csinh(to_c_complex(x)))); +#else + return (out_of_range + (sc, sc->sinh_symbol, int_one, x, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_REAL: + mpfr_sinh(sc->mpfr_1, big_real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_COMPLEX: + mpc_sinh(sc->mpc_1, big_complex(x), MPC_RNDNN); + if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) + return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg + (sc, x, sc->sinh_symbol, args, a_number_string)); + } +} + +#if (!WITH_GMP) +static s7_double sinh_d_d(s7_double x) +{ + return (sinh(x)); +} +#endif + + +/* -------------------------------- cosh -------------------------------- */ +static s7_pointer g_cosh(s7_scheme * sc, s7_pointer args) +{ +#define H_cosh "(cosh z) returns cosh(z)" +#define Q_cosh sc->pl_nn + + s7_pointer x = car(args); + switch (type(x)) { + case T_INTEGER: + if (integer(x) == 0) + return (int_one); /* (cosh 0) -> 1 */ + + case T_REAL: + case T_RATIO: + { + s7_double y; + y = s7_real(x); +#if WITH_GMP + if (fabs(y) > SINH_LIMIT) { + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, cosh(y))); + } + + case T_COMPLEX: +#if WITH_GMP + if ((fabs(real_part(x)) > SINH_LIMIT) + || (fabs(imag_part(x)) > SINH_LIMIT)) { + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_cosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + } +#endif +#if HAVE_COMPLEX_NUMBERS + return (c_complex_to_s7(sc, ccosh(to_c_complex(x)))); +#else + return (out_of_range + (sc, sc->cosh_symbol, int_one, x, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_REAL: + mpfr_cosh(sc->mpfr_1, big_real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_COMPLEX: + mpc_cosh(sc->mpc_1, big_complex(x), MPC_RNDNN); + if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) + return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg + (sc, x, sc->cosh_symbol, args, a_number_string)); + } +} + +#if (!WITH_GMP) +static s7_double cosh_d_d(s7_double x) +{ + return (cosh(x)); +} +#endif + + +/* -------------------------------- tanh -------------------------------- */ +#define TANH_LIMIT 350.0 +static s7_pointer g_tanh(s7_scheme * sc, s7_pointer args) +{ +#define H_tanh "(tanh z) returns tanh(z)" +#define Q_tanh sc->pl_nn + + s7_pointer x = car(args); + switch (type(x)) { + case T_INTEGER: + return ((integer(x) == 0) ? int_zero : make_real(sc, + tanh((s7_double) + integer + (x)))); + case T_RATIO: + return (make_real(sc, tanh(fraction(x)))); + case T_REAL: + return (make_real(sc, tanh(real(x)))); + + case T_COMPLEX: +#if HAVE_COMPLEX_NUMBERS + if (real_part(x) > TANH_LIMIT) + return (real_one); /* closer than 0.0 which is what ctanh is about to return! */ + if (real_part(x) < -TANH_LIMIT) + return (make_real(sc, -1.0)); /* closer than ctanh's -0.0 */ + return (c_complex_to_s7(sc, ctanh(to_c_complex(x)))); +#else + return (out_of_range + (sc, sc->tanh_symbol, int_one, x, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + goto BIG_REAL_TANH; + + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + goto BIG_REAL_TANH; + + case T_BIG_REAL: + if (mpfr_nan_p(big_real(x))) + return (real_NaN); + mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); + + BIG_REAL_TANH: + if (mpfr_cmp_d(sc->mpfr_1, TANH_LIMIT) > 0) + return (real_one); + if (mpfr_cmp_d(sc->mpfr_1, -TANH_LIMIT) < 0) + return (make_real(sc, -1.0)); + mpfr_tanh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_COMPLEX: + if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), TANH_LIMIT, 1))) > + 0) + return (real_one); + if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), -TANH_LIMIT, 1))) < + 0) + return (make_real(sc, -1.0)); + + if ((mpfr_nan_p(mpc_imagref(big_complex(x)))) || + (mpfr_inf_p(mpc_imagref(big_complex(x))))) { + if (mpfr_cmp_ui(mpc_realref(big_complex(x)), 0) == 0) + return (make_complex_not_0i(sc, 0.0, NAN)); /* match non-bignum choice */ + return (complex_NaN); + } + + mpc_tanh(sc->mpc_1, big_complex(x), MPC_RNDNN); + if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) + return (mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg + (sc, x, sc->tanh_symbol, args, a_number_string)); + } +} + +static s7_double tanh_d_d(s7_double x) +{ + return (tanh(x)); +} + + +/* -------------------------------- asinh -------------------------------- */ +static s7_pointer g_asinh(s7_scheme * sc, s7_pointer args) +{ +#define H_asinh "(asinh z) returns asinh(z)" +#define Q_asinh sc->pl_nn + + s7_pointer x = car(args); + switch (type(x)) { + case T_INTEGER: + return ((integer(x) == 0) ? int_zero : make_real(sc, + asinh((s7_double) + integer + (x)))); + case T_RATIO: + return (make_real(sc, asinh(fraction(x)))); + case T_REAL: + return (make_real(sc, asinh(real(x)))); + case T_COMPLEX: +#if HAVE_COMPLEX_NUMBERS +#if (defined(__OpenBSD__)) || (defined(__NetBSD__)) + return (c_complex_to_s7(sc, casinh_1(to_c_complex(x)))); +#else + return (c_complex_to_s7(sc, casinh(to_c_complex(x)))); +#endif +#else + return (out_of_range + (sc, sc->asinh_symbol, int_one, x, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_asinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_asinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_asinh(sc->mpfr_1, big_real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_asinh(sc->mpc_1, big_complex(x), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg_p + (sc, x, sc->asinh_symbol, a_number_string)); + } +} + + +/* -------------------------------- acosh -------------------------------- */ +static s7_pointer g_acosh(s7_scheme * sc, s7_pointer args) +{ +#define H_acosh "(acosh z) returns acosh(z)" +#define Q_acosh sc->pl_nn + + s7_pointer x = car(args); + switch (type(x)) { + case T_INTEGER: + if (integer(x) == 1) + return (int_zero); + case T_REAL: + case T_RATIO: + { + double x1 = s7_real(x); + if (x1 >= 1.0) + return (make_real(sc, acosh(x1))); + } + case T_COMPLEX: +#if HAVE_COMPLEX_NUMBERS +#ifdef __OpenBSD__ + return (c_complex_to_s7(sc, cacosh_1(s7_to_c_complex(x)))); +#else + return (c_complex_to_s7(sc, cacosh(s7_to_c_complex(x)))); /* not to_c_complex because x might not be complex */ +#endif +#else + /* since we can fall through to this branch, we need a better error message than "must be a number, not 0.0" */ + return (out_of_range + (sc, sc->acosh_symbol, int_one, x, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); + mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_set_fr(sc->mpc_1, big_real(x), MPC_RNDNN); + mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_acosh(sc->mpc_1, big_complex(x), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg_p + (sc, x, sc->acosh_symbol, a_number_string)); + } +} + + +/* -------------------------------- atanh -------------------------------- */ +static s7_pointer g_atanh(s7_scheme * sc, s7_pointer args) +{ +#define H_atanh "(atanh z) returns atanh(z)" +#define Q_atanh sc->pl_nn + + s7_pointer x = car(args); + switch (type(x)) { + case T_INTEGER: + if (integer(x) == 0) + return (int_zero); /* (atanh 0) -> 0 */ + case T_REAL: + case T_RATIO: + { + double x1 = s7_real(x); + if (fabs(x1) < 1.0) + return (make_real(sc, atanh(x1))); + } + /* if we can't distinguish x from 1.0 even with long_doubles, we'll get inf.0: + * (atanh 9223372036854775/9223372036854776) -> 18.714973875119 + * (atanh 92233720368547758/92233720368547757) -> inf.0 + * (atanh (bignum 92233720368547758/92233720368547757)) -> 1.987812468492420421418925013176932317086E1+1.570796326794896619231321691639751442098E0i + * but the imaginary part is unnecessary + */ + case T_COMPLEX: +#if HAVE_COMPLEX_NUMBERS +#if (defined(__OpenBSD__)) || (defined(__NetBSD__)) + return (c_complex_to_s7(sc, catanh_1(s7_to_c_complex(x)))); +#else + return (c_complex_to_s7(sc, catanh(s7_to_c_complex(x)))); +#endif +#else + return (out_of_range + (sc, sc->atanh_symbol, int_one, x, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_2, big_integer(x), MPFR_RNDN); + goto ATANH_BIG_REAL; + + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_2, big_ratio(x), MPFR_RNDN); + goto ATANH_BIG_REAL; + + case T_BIG_REAL: + mpfr_set(sc->mpfr_2, big_real(x), MPFR_RNDN); + ATANH_BIG_REAL: + mpfr_set_ui(sc->mpfr_1, 1, MPFR_RNDN); + if (mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) < 0) { + mpfr_atanh(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_2)); + } + mpc_set_fr(sc->mpc_1, sc->mpfr_2, MPC_RNDNN); + mpc_atanh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + + case T_BIG_COMPLEX: + mpc_atanh(sc->mpc_1, big_complex(x), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg_p + (sc, x, sc->atanh_symbol, a_number_string)); + } +} + + +/* -------------------------------- sqrt -------------------------------- */ +static s7_pointer sqrt_p_p(s7_scheme * sc, s7_pointer p) +{ + switch (type(p)) { + case T_INTEGER: + { + s7_double sqx; + if (integer(p) >= 0) { + s7_int ix; +#if WITH_GMP + mpz_set_si(sc->mpz_1, integer(p)); + mpz_sqrtrem(sc->mpz_1, sc->mpz_2, sc->mpz_1); + if (mpz_cmp_ui(sc->mpz_2, 0) == 0) + return (make_integer(sc, mpz_get_si(sc->mpz_1))); + mpfr_set_si(sc->mpfr_1, integer(p), MPFR_RNDN); + mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); +#endif + sqx = sqrt((s7_double) integer(p)); + ix = (s7_int) sqx; + return (((ix * ix) == integer(p)) ? make_integer(sc, + ix) : + make_real(sc, sqx)); + /* Mark Weaver notes that (zero? (- (sqrt 9007199136250226) 94906265.0)) -> #t + * but (* 94906265 94906265) -> 9007199136250225 -- oops + * if we use bigfloats, we're ok: + * (* (sqrt 9007199136250226.0) (sqrt 9007199136250226.0)) -> 9.007199136250226000000000000000000000026E15 + * at least we return a real here, not an incorrect integer and (sqrt 9007199136250225) -> 94906265 + */ + } +#if HAVE_COMPLEX_NUMBERS +#if WITH_GMP + mpc_set_si(sc->mpc_1, integer(p), MPC_RNDNN); + mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + sqx = (s7_double) integer(p); /* we're trying to protect against (sqrt -9223372036854775808) where we can't negate the integer argument */ + return (s7_make_complex(sc, 0.0, sqrt((s7_double) (-sqx)))); +#else + return (out_of_range + (sc, sc->sqrt_symbol, int_one, p, + no_complex_numbers_string)); +#endif + } + + case T_RATIO: + if (numerator(p) > 0) { /* else it's complex, so it can't be a ratio */ + s7_int nm = (s7_int) sqrt(numerator(p)); + if (nm * nm == numerator(p)) { + s7_int dn = (s7_int) sqrt(denominator(p)); + if (dn * dn == denominator(p)) + return (make_ratio(sc, nm, dn)); + } + return (make_real(sc, sqrt((s7_double) fraction(p)))); + } +#if HAVE_COMPLEX_NUMBERS + return (s7_make_complex + (sc, 0.0, sqrt((s7_double) (-fraction(p))))); +#else + return (out_of_range + (sc, sc->sqrt_symbol, int_one, p, + no_complex_numbers_string)); +#endif + + case T_REAL: + if (is_NaN(real(p))) + return (real_NaN); + if (real(p) >= 0.0) + return (make_real(sc, sqrt(real(p)))); + return (make_complex_not_0i(sc, 0.0, sqrt(-real(p)))); + + case T_COMPLEX: /* (* inf.0 (sqrt -1)) -> -nan+infi, but (sqrt -inf.0) -> 0+infi */ +#if HAVE_COMPLEX_NUMBERS + return (c_complex_to_s7(sc, csqrt(to_c_complex(p)))); /* sqrt(+inf.0+1.0i) -> +inf.0 */ +#else + return (out_of_range + (sc, sc->sqrt_symbol, int_one, p, + no_complex_numbers_string)); +#endif + +#if WITH_GMP + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(p), 0) >= 0) { + mpz_sqrtrem(sc->mpz_1, sc->mpz_2, big_integer(p)); + if (mpz_cmp_ui(sc->mpz_2, 0) == 0) + return (mpz_to_integer(sc, sc->mpz_1)); + mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN); + mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } + mpc_set_z(sc->mpc_1, big_integer(p), MPC_RNDNN); + mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + + case T_BIG_RATIO: /* if big ratio, check both num and den for squares */ + if (mpq_cmp_ui(big_ratio(p), 0, 1) < 0) { + mpc_set_q(sc->mpc_1, big_ratio(p), MPC_RNDNN); + mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + } + mpz_sqrtrem(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(p))); + if (mpz_cmp_ui(sc->mpz_2, 0) == 0) { + mpz_sqrtrem(sc->mpz_3, sc->mpz_2, mpq_denref(big_ratio(p))); + if (mpz_cmp_ui(sc->mpz_2, 0) == 0) { + mpq_set_num(sc->mpq_1, sc->mpz_1); + mpq_set_den(sc->mpq_1, sc->mpz_3); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + } + } + mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN); + mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_REAL: + if (mpfr_cmp_ui(big_real(p), 0) < 0) { + mpc_set_fr(sc->mpc_1, big_real(p), MPC_RNDNN); + mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + } + mpfr_sqrt(sc->mpfr_1, big_real(p), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_BIG_COMPLEX: + mpc_sqrt(sc->mpc_1, big_complex(p), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg_p + (sc, p, sc->sqrt_symbol, a_number_string)); + } +} + +static s7_pointer g_sqrt(s7_scheme * sc, s7_pointer args) +{ +#define H_sqrt "(sqrt z) returns the square root of z" +#define Q_sqrt sc->pl_nn + return (sqrt_p_p(sc, car(args))); +} + + +/* -------------------------------- expt -------------------------------- */ +static s7_int int_to_int(s7_int x, s7_int n) +{ + /* from GSL */ + s7_int value = 1; + do { + if (n & 1) + value *= x; + n >>= 1; +#if HAVE_OVERFLOW_CHECKS + if (multiply_overflow(x, x, &x)) + break; +#else + x *= x; +#endif + } while (n); + return (value); +} + +static const int64_t nth_roots[63] = { + S7_INT64_MAX, S7_INT64_MAX, 3037000499LL, 2097151, 55108, 6208, 1448, + 511, 234, 127, 78, 52, 38, 28, 22, + 18, 15, 13, 11, 9, 8, 7, 7, 6, 6, 5, 5, 5, 4, 4, 4, 4, 3, 3, 3, 3, 3, + 3, 3, 3, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 +}; + +static bool int_pow_ok(s7_int x, s7_int y) +{ + return ((y < S7_INT_BITS) && (nth_roots[y] >= s7_int_abs(x))); +} + +#if WITH_GMP +static s7_pointer real_part_p_p(s7_scheme * sc, s7_pointer p); +static bool lt_b_pi(s7_scheme * sc, s7_pointer p1, s7_int p2); + +static s7_pointer big_expt(s7_scheme * sc, s7_pointer args) +{ + s7_pointer x = car(args), y, res; + if (!is_number(x)) + return (method_or_bust_with_type + (sc, x, sc->expt_symbol, args, a_number_string, 1)); + + y = cadr(args); + if (!is_number(y)) + return (method_or_bust_with_type + (sc, y, sc->expt_symbol, args, a_number_string, 2)); + + if (is_zero(sc, x)) { + if ((s7_is_integer(x)) && (s7_is_integer(y)) && (is_zero(sc, y))) + return (int_one); + + if (is_real(y)) { + if (is_negative(sc, y)) + return (division_by_zero_error(sc, sc->expt_symbol, args)); + } else if (is_negative(sc, real_part_p_p(sc, y))) /* handle big_complex as well as complex */ + return (division_by_zero_error(sc, sc->expt_symbol, args)); + + if ((is_rational(x)) && (is_rational(y))) + return (int_zero); + return (real_zero); + } + + if (s7_is_integer(y)) { + s7_int yval; + yval = s7_integer_checked(sc, y); + if (yval == 0) + return ((is_rational(x)) ? int_one : real_one); + + if (yval == 1) + return (x); + + if ((!is_big_number(x)) && ((is_one(x)) || (is_zero(sc, x)))) + return (x); + + if ((yval < S7_INT32_MAX) && (yval > S7_INT32_MIN)) { + /* (protect against gmp exception if for example (expt 1/9223372036854775807 -9223372036854775807) */ + if (s7_is_integer(x)) { + if (is_t_big_integer(x)) + mpz_set(sc->mpz_2, big_integer(x)); + else + mpz_set_si(sc->mpz_2, integer(x)); + if (yval >= 0) { + mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t) yval); + return (mpz_to_integer(sc, sc->mpz_2)); + } + mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t) (-yval)); + mpq_set_z(sc->mpq_1, sc->mpz_2); + mpq_inv(sc->mpq_1, sc->mpq_1); + if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) + return (mpz_to_integer(sc, mpq_numref(sc->mpq_1))); + return (mpq_to_big_ratio(sc, sc->mpq_1)); + } + + if (s7_is_ratio(x)) { /* here y is an integer */ + if (is_t_big_ratio(x)) { + mpz_set(sc->mpz_1, mpq_numref(big_ratio(x))); + mpz_set(sc->mpz_2, mpq_denref(big_ratio(x))); + } else { + mpz_set_si(sc->mpz_1, numerator(x)); + mpz_set_si(sc->mpz_2, denominator(x)); + } + if (yval >= 0) { + mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t) yval); + mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t) yval); + mpq_set_num(sc->mpq_1, sc->mpz_1); + mpq_set_den(sc->mpq_1, sc->mpz_2); + } else { + yval = -yval; + mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t) yval); + mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t) yval); + mpq_set_num(sc->mpq_1, sc->mpz_2); + mpq_set_den(sc->mpq_1, sc->mpz_1); + mpq_canonicalize(sc->mpq_1); + } + if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) + return (mpz_to_integer(sc, mpq_numref(sc->mpq_1))); + return (mpq_to_big_ratio(sc, sc->mpq_1)); + } + + if (is_real(x)) { + if (is_t_big_real(x)) + mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); + else + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_pow_si(sc->mpfr_1, sc->mpfr_1, yval, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } + } + } + + if ((is_t_ratio(y)) && /* not s7_is_ratio which accepts bignums */ + (numerator(y) == 1)) { + if (denominator(y) == 2) + return (sqrt_p_p(sc, x)); + + if ((is_real(x)) && (denominator(y) == 3)) { + any_real_to_mpfr(sc, x, sc->mpfr_1); + mpfr_cbrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } + } + + res = any_number_to_mpc(sc, y, sc->mpc_2); + if (res == real_infinity) { + if (is_one(x)) + return (int_one); + if (!is_real(x)) + return ((is_negative(sc, y)) ? real_zero : complex_NaN); + if (is_zero(sc, x)) { + if (is_negative(sc, y)) + return (division_by_zero_error(sc, sc->expt_symbol, args)); + return (real_zero); + } + if (lt_b_pi(sc, x, 0)) { + if (lt_b_pi(sc, x, -1)) + return ((is_positive(sc, y)) ? real_infinity : real_zero); + return ((is_positive(sc, y)) ? real_zero : real_infinity); + } + if (lt_b_pi(sc, x, 1)) + return ((is_positive(sc, y)) ? real_zero : real_infinity); + return ((is_positive(sc, y)) ? real_infinity : real_zero); + } + if (res) + return (complex_NaN); + + if ((is_real(x)) && (is_real(y)) && (is_positive(sc, x))) { + res = any_real_to_mpfr(sc, x, sc->mpfr_1); + if (res) { + if (res == real_infinity) { + if (is_negative(sc, y)) + return (real_zero); + return ((is_zero(sc, y)) ? real_one : real_infinity); + } + return (complex_NaN); + } + mpfr_pow(sc->mpfr_1, sc->mpfr_1, mpc_realref(sc->mpc_2), + MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } + + res = any_number_to_mpc(sc, x, sc->mpc_1); + if (res) { + if ((res == real_infinity) && (is_real(y))) { + if (is_negative(sc, y)) + return (real_zero); + return ((is_zero(sc, y)) ? real_one : real_infinity); + } + return (complex_NaN); + } + if (mpc_cmp_si_si(sc->mpc_1, 0, 0) == 0) + return (int_zero); + if (mpc_cmp_si_si(sc->mpc_1, 1, 0) == 0) + return (int_one); + + mpc_pow(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + + if ((!mpfr_nan_p(mpc_imagref(sc->mpc_1))) && (mpfr_cmp_ui(mpc_imagref(sc->mpc_1), 0) == 0)) { /* (expt -inf.0 1/3) -> +inf.0+nan.0i in mpc */ + if ((is_rational(car(args))) && + (is_rational(cadr(args))) && + (mpfr_integer_p(mpc_realref(sc->mpc_1)) != 0)) { + /* mpfr_integer_p can be confused: (expt 2718/1000 (bignum 617/5)) returns an int32_t if precision=128, float if 512 */ + /* so first make sure we're within (say) 31 bits */ + mpfr_set_ui(sc->mpfr_1, S7_INT32_MAX, MPFR_RNDN); + if (mpfr_cmpabs(mpc_realref(sc->mpc_1), sc->mpfr_1) < 0) { + mpfr_get_z(sc->mpz_1, mpc_realref(sc->mpc_1), MPFR_RNDN); + return (mpz_to_integer(sc, sc->mpz_1)); + } + } + mpfr_set(sc->mpfr_1, mpc_realref(sc->mpc_1), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } + return (mpc_to_number(sc, sc->mpc_1)); +} +#endif + +static s7_pointer g_expt(s7_scheme * sc, s7_pointer args) +{ +#define H_expt "(expt z1 z2) returns z1^z2" +#define Q_expt sc->pcl_n + + s7_pointer n = car(args), pw; + +#if WITH_GMP + return (big_expt(sc, args)); + /* big_expt sometimes chooses a different value: g_expt (expt -1 1/3) is -1, but big_expt (expt -1 (bignum 1/3)) is (complex 1/2 (/ (sqrt 3) 2)) */ +#endif + + if (!is_number(n)) + return (method_or_bust_with_type + (sc, n, sc->expt_symbol, args, a_number_string, 1)); + + pw = cadr(args); + if (!is_number(pw)) + return (method_or_bust_with_type + (sc, pw, sc->expt_symbol, args, a_number_string, 2)); + + if (is_zero(sc, n)) { + if (is_zero(sc, pw)) { + if ((s7_is_integer(n)) && (s7_is_integer(pw))) /* (expt 0 0) -> 1 */ + return (int_one); + return (real_zero); /* (expt 0.0 0) -> 0.0 */ + } + if (is_real(pw)) { + if (is_negative(sc, pw)) /* (expt 0 -1) */ + return (division_by_zero_error(sc, sc->expt_symbol, args)); + /* (Clisp gives divide-by-zero error here, Guile returns inf.0) */ + + if (is_NaN(s7_real(pw))) /* (expt 0 +nan.0) */ + return (pw); + } else { /* (expt 0 a+bi) */ + if (real_part(pw) < 0.0) /* (expt 0 -1+i) */ + return (division_by_zero_error(sc, sc->expt_symbol, args)); + if ((is_NaN(real_part(pw))) || /* (expt 0 0+1/0i) */ + (is_NaN(imag_part(pw)))) + return (real_NaN); + } + if ((s7_is_integer(n)) && (s7_is_integer(pw))) /* pw != 0, (expt 0 2312) */ + return (int_zero); + return (real_zero); /* (expt 0.0 123123) */ + } + + if (is_one(pw)) { + if (s7_is_integer(pw)) /* (expt x 1) */ + return (n); + if (is_rational(n)) /* (expt ratio 1.0) */ + return (make_real(sc, rational_to_double(sc, n))); + return (n); + } + if (is_t_integer(pw)) { + s7_int y = integer(pw); + if (y == 0) { + if (is_rational(n)) /* (expt 3 0) */ + return (int_one); + if ((is_NaN(s7_real_part(n))) || /* (expt 1/0 0) -> NaN */ + (is_NaN(s7_imag_part(n)))) /* (expt (complex 0 1/0) 0) -> NaN */ + return (n); + return (real_one); /* (expt 3.0 0) */ + } + switch (type(n)) { + case T_INTEGER: + { + s7_int x; + x = integer(n); + if (x == 1) /* (expt 1 y) */ + return (n); + + if (x == -1) { + if (y == S7_INT64_MIN) /* (expt -1 most-negative-fixnum) */ + return (int_one); + if (s7_int_abs(y) & 1) /* (expt -1 odd-int) */ + return (n); + return (int_one); /* (expt -1 even-int) */ + } + + if (y == S7_INT64_MIN) /* (expt x most-negative-fixnum) */ + return (int_zero); + if (x == S7_INT64_MIN) /* (expt most-negative-fixnum y) */ + return (make_real(sc, pow((double) x, (double) y))); + + if (int_pow_ok(x, s7_int_abs(y))) { + if (y > 0) + return (make_integer(sc, int_to_int(x, y))); + return (make_ratio(sc, 1, int_to_int(x, -y))); + } + } + break; + + case T_RATIO: + { + s7_int nm = numerator(n), dn = denominator(n); + + if (y == S7_INT64_MIN) { + if (s7_int_abs(nm) > dn) + return (int_zero); /* (expt 4/3 most-negative-fixnum) -> 0? */ + return (real_infinity); /* (expt 3/4 most-negative-fixnum) -> inf? */ + } + + if ((int_pow_ok(nm, s7_int_abs(y))) && + (int_pow_ok(dn, s7_int_abs(y)))) { + if (y > 0) + return (make_ratio + (sc, int_to_int(nm, y), + int_to_int(dn, y))); + return (s7_make_ratio + (sc, int_to_int(dn, -y), int_to_int(nm, -y))); + } + } + break; + /* occasionally int^rat can be int32_t but it happens so infrequently it's probably not worth checking + * one possibly easy case: (expt 1 1/2) -> 1 (-1?) etc + */ + + case T_REAL: + /* (expt -1.0 most-positive-fixnum) should be -1.0 + * (expt -1.0 (+ (expt 2 53) 1)) -> -1.0 + * (expt -1.0 (- 1 (expt 2 54))) -> -1.0 + */ + if (real(n) == -1.0) { + if (y == S7_INT64_MIN) + return (real_one); + return ((s7_int_abs(y) & 1) ? n : real_one); + } + break; + + case T_COMPLEX: +#if HAVE_COMPLEX_NUMBERS + if ((s7_real_part(n) == 0.0) && + ((s7_imag_part(n) == 1.0) || (s7_imag_part(n) == -1.0))) { + bool yp, np; + yp = (y > 0); + np = (s7_imag_part(n) > 0.0); + switch (s7_int_abs(y) % 4) { + case 0: + return (real_one); + case 1: + return (make_complex_not_0i + (sc, 0.0, (yp == np) ? 1.0 : -1.0)); + case 2: + return (make_real(sc, -1.0)); + case 3: + return (make_complex_not_0i + (sc, 0.0, (yp == np) ? -1.0 : 1.0)); + } + } +#else + return (out_of_range + (sc, sc->expt_symbol, int_two, n, + no_complex_numbers_string)); +#endif + break; + } + } + + if ((is_real(n)) && (is_real(pw))) { + s7_double x, y; + + if ((is_t_ratio(pw)) && (numerator(pw) == 1)) { + if (denominator(pw) == 2) + return (sqrt_p_p(sc, n)); + if (denominator(pw) == 3) + return (make_real(sc, cbrt(s7_real(n)))); /* (expt 27 1/3) should be 3, not 3.0... */ + /* but: (expt 512/729 1/3) -> 0.88888888888889, and 4 -> sqrt(sqrt...) etc? */ + } + + x = s7_real(n); + y = s7_real(pw); + + if (is_NaN(x)) + return (n); + if (is_NaN(y)) + return (pw); + if (y == 0.0) + return (real_one); + + /* I think pow(rl, inf) is ok */ + if (x > 0.0) + return (make_real(sc, pow(x, y))); /* tricky cases abound here: (expt -1 1/9223372036854775807) */ + } + + /* (expt 0+i 1e+16) = 0.98156860153485-0.19111012657867i ? + * (expt 0+i 1+1/0i) = 0.0 ?? + */ + return (c_complex_to_s7 + (sc, cpow(s7_to_c_complex(n), s7_to_c_complex(pw)))); +} + + +/* -------------------------------- lcm -------------------------------- */ +#if WITH_GMP +static s7_pointer big_lcm(s7_scheme * sc, s7_int num, s7_int den, + s7_pointer args) +{ + s7_pointer x; + mpz_set_si(sc->mpz_3, num); + mpz_set_si(sc->mpz_4, den); + + for (x = args; is_pair(x); x = cdr(x)) { + s7_pointer rat = car(x); + switch (type(rat)) { + case T_INTEGER: + mpz_set_si(sc->mpz_1, integer(rat)); + mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1); + mpz_set_si(sc->mpz_4, 1); + break; + case T_RATIO: + mpz_set_si(sc->mpz_1, numerator(rat)); + mpz_set_si(sc->mpz_2, denominator(rat)); + mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1); + mpz_gcd(sc->mpz_4, sc->mpz_4, sc->mpz_2); + break; + case T_BIG_INTEGER: + mpz_lcm(sc->mpz_3, sc->mpz_3, big_integer(rat)); + mpz_set_si(sc->mpz_4, 1); + break; + case T_BIG_RATIO: + mpz_lcm(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat))); + mpz_gcd(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat))); + break; + case T_REAL: + case T_BIG_REAL: + case T_COMPLEX: + case T_BIG_COMPLEX: + return (wrong_type_argument_with_type + (sc, sc->lcm_symbol, position_of(x, args), rat, + a_rational_string)); + default: + return (method_or_bust_with_type(sc, rat, sc->lcm_symbol, + set_ulist_1(sc, + mpz_to_rational + (sc, sc->mpz_3, + sc->mpz_4), x), + a_rational_string, + position_of(x, args))); + } + } + return (mpz_to_rational(sc, sc->mpz_3, sc->mpz_4)); +} +#endif + +static s7_pointer g_lcm(s7_scheme * sc, s7_pointer args) +{ + /* (/ (* m n) (gcd m n)), (lcm a b c) -> (lcm a (lcm b c)) */ +#define H_lcm "(lcm ...) returns the least common multiple of its rational arguments" +#define Q_lcm sc->pcl_f + + s7_int n = 1, d = 0; + s7_pointer p; + + if (!is_pair(args)) + return (int_one); + + if (!is_pair(cdr(args))) { + if (!is_rational(car(args))) + return (method_or_bust_with_type + (sc, car(args), sc->lcm_symbol, args, + a_rational_string, 1)); + return (g_abs(sc, args)); + } + + for (p = args; is_pair(p); p = cdr(p)) { + s7_pointer x = car(p); + s7_int b; +#if HAVE_OVERFLOW_CHECKS + s7_int n1; +#endif + switch (type(x)) { + case T_INTEGER: + d = 1; + if (integer(x) == 0) { /* return 0 unless there's a wrong-type-arg (geez what a mess) */ + for (p = cdr(p); is_pair(p); p = cdr(p)) { + s7_pointer x1 = car(p); + if (is_number(x1)) { + if (!is_rational(x1)) + return (wrong_type_argument_with_type + (sc, sc->lcm_symbol, + position_of(p, args), x1, + a_rational_string)); + } else if (has_active_methods(sc, x1)) { + s7_pointer f; + f = find_method_with_let(sc, x1, + sc->is_rational_symbol); + if ((f == sc->undefined) + || + (is_false + (sc, + call_method(sc, x1, f, + set_plist_1(sc, x1))))) + return (wrong_type_argument_with_type + (sc, sc->lcm_symbol, + position_of(p, args), x1, + a_rational_string)); + } else + return (wrong_type_argument_with_type + (sc, sc->lcm_symbol, position_of(p, args), + x1, a_rational_string)); + } + return (int_zero); + } + b = integer(x); + if (b < 0) { + if (b == S7_INT64_MIN) +#if WITH_GMP + return (big_lcm(sc, n, d, p)); +#else + return (simple_out_of_range + (sc, sc->lcm_symbol, args, + its_too_large_string)); +#endif + b = -b; + } +#if HAVE_OVERFLOW_CHECKS + if (multiply_overflow(n / c_gcd(n, b), b, &n1)) +#if WITH_GMP + return (big_lcm(sc, n, d, p)); +#else + return (simple_out_of_range + (sc, sc->lcm_symbol, args, + result_is_too_large_string)); +#endif + n = n1; +#else + n = (n / c_gcd(n, b)) * b; +#endif + break; + + case T_RATIO: + b = numerator(x); + if (b < 0) { + if (b == S7_INT64_MIN) +#if WITH_GMP + return (big_lcm(sc, n, d, p)); +#else + return (simple_out_of_range + (sc, sc->lcm_symbol, args, + its_too_large_string)); +#endif + b = -b; + } +#if HAVE_OVERFLOW_CHECKS + if (multiply_overflow(n / c_gcd(n, b), b, &n1)) /* (lcm 92233720368547758/3 3005/2) */ +#if WITH_GMP + return (big_lcm(sc, n, d, p)); +#else + return (simple_out_of_range + (sc, sc->lcm_symbol, args, + intermediate_too_large_string)); +#endif + n = n1; +#else + n = (n / c_gcd(n, b)) * b; +#endif + if (d == 0) + d = (p == args) ? denominator(x) : 1; + else + d = c_gcd(d, denominator(x)); + break; + +#if WITH_GMP + case T_BIG_INTEGER: + d = 1; + case T_BIG_RATIO: + return (big_lcm(sc, n, d, p)); +#endif + case T_REAL: + case T_BIG_REAL: + case T_COMPLEX: + case T_BIG_COMPLEX: + return (wrong_type_argument_with_type + (sc, sc->lcm_symbol, position_of(p, args), x, + a_rational_string)); + + default: + return (method_or_bust_with_type(sc, x, sc->lcm_symbol, + set_ulist_1(sc, + (d <= + 1) ? + make_integer(sc, + n) : + s7_make_ratio(sc, + n, + d), + p), + a_rational_string, + position_of(p, args))); + } + } + return ((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d)); +} + + +/* -------------------------------- gcd -------------------------------- */ +#if WITH_GMP +static s7_pointer big_gcd(s7_scheme * sc, s7_int num, s7_int den, + s7_pointer args) +{ + s7_pointer x; + + mpz_set_si(sc->mpz_3, num); + mpz_set_si(sc->mpz_4, den); + + for (x = args; is_pair(x); x = cdr(x)) { + s7_pointer rat; + rat = car(x); + switch (type(rat)) { + case T_INTEGER: + mpz_set_si(sc->mpz_1, integer(rat)); + mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1); + break; + case T_RATIO: + mpz_set_si(sc->mpz_1, numerator(rat)); + mpz_set_si(sc->mpz_2, denominator(rat)); + mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1); + mpz_lcm(sc->mpz_4, sc->mpz_4, sc->mpz_2); + break; + case T_BIG_INTEGER: + mpz_gcd(sc->mpz_3, sc->mpz_3, big_integer(rat)); + break; + case T_BIG_RATIO: + mpz_gcd(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat))); + mpz_lcm(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat))); + break; + case T_REAL: + case T_BIG_REAL: + case T_COMPLEX: + case T_BIG_COMPLEX: + return (wrong_type_argument_with_type + (sc, sc->gcd_symbol, position_of(x, args), rat, + a_rational_string)); + default: + return (method_or_bust_with_type(sc, rat, sc->gcd_symbol, + set_ulist_1(sc, + mpz_to_rational + (sc, sc->mpz_3, + sc->mpz_4), x), + a_rational_string, + position_of(x, args))); + } + } + return (mpz_to_rational(sc, sc->mpz_3, sc->mpz_4)); +} +#endif + +static s7_pointer g_gcd(s7_scheme * sc, s7_pointer args) +{ +#define H_gcd "(gcd ...) returns the greatest common divisor of its rational arguments" +#define Q_gcd sc->pcl_f + + s7_int n = 0, d = 1; + s7_pointer p; + + if (!is_pair(args)) /* (gcd) */ + return (int_zero); + + if (!is_pair(cdr(args))) { /* (gcd 3/4) */ + if (!is_rational(car(args))) + return (method_or_bust_with_type + (sc, car(args), sc->gcd_symbol, args, + a_rational_string, 1)); + return (abs_p_p(sc, car(args))); + } + + for (p = args; is_pair(p); p = cdr(p)) { + s7_pointer x = car(p); + switch (type(x)) { + case T_INTEGER: + if (integer(x) == S7_INT64_MIN) +#if WITH_GMP + return (big_gcd(sc, n, d, p)); +#else + return (simple_out_of_range + (sc, sc->lcm_symbol, args, its_too_large_string)); +#endif + n = c_gcd(n, integer(x)); + break; + + case T_RATIO: + { +#if HAVE_OVERFLOW_CHECKS + s7_int dn; +#endif + n = c_gcd(n, numerator(x)); + if (d == 1) + d = denominator(x); + else { + s7_int b = denominator(x); +#if HAVE_OVERFLOW_CHECKS + if (multiply_overflow(d / c_gcd(d, b), b, &dn)) /* (gcd 1/92233720368547758 1/3005) */ +#if WITH_GMP + return (big_gcd(sc, n, d, x)); +#else + return (simple_out_of_range + (sc, sc->gcd_symbol, args, + intermediate_too_large_string)); +#endif + d = dn; +#else + d = (d / c_gcd(d, b)) * b; +#endif + } + } + break; + +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + return (big_gcd(sc, n, d, p)); +#endif + + case T_REAL: + case T_BIG_REAL: + case T_COMPLEX: + case T_BIG_COMPLEX: + return (wrong_type_argument_with_type + (sc, sc->gcd_symbol, position_of(p, args), x, + a_rational_string)); + + default: + return (method_or_bust_with_type(sc, x, sc->gcd_symbol, + set_ulist_1(sc, + (d <= + 1) ? + make_integer(sc, + n) : + s7_make_ratio(sc, + n, + d), + p), + a_rational_string, + position_of(p, args))); + } + } + return ((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d)); +} + + +/* -------------------------------- floor -------------------------------- */ +static s7_pointer floor_p_p(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + return (x); + case T_RATIO: + { + s7_int val = numerator(x) / denominator(x); + /* C "/" truncates? -- C spec says "truncation toward 0" */ + /* we're avoiding "floor" here because the int->double conversion introduces inaccuracies for big numbers + * but it's used by opt_i_d_c (via s7_number_to_real) so floor_i_7d below can return different results: + * (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (floor 3441313796169221281/1720656898084610641)) (newline))) (func)): 1 + * (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (/ (floor 3441313796169221281/1720656898084610641))) (newline))) (func)): 1/2 + */ + return ((numerator(x) < 0) ? make_integer(sc, val - 1) : make_integer(sc, val)); /* not "val" because it might be truncated to 0 */ + } + case T_REAL: + { + s7_double z = real(x); + if (is_NaN(z)) + return (simple_out_of_range + (sc, sc->floor_symbol, x, its_nan_string)); + if (is_inf(z)) + return (simple_out_of_range + (sc, sc->floor_symbol, x, its_infinite_string)); +#if WITH_GMP + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) { + mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); + mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD); + return (mpz_to_integer(sc, sc->mpz_1)); + } +#else + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) + return (simple_out_of_range + (sc, sc->floor_symbol, x, its_too_large_string)); +#endif + return (make_integer(sc, (s7_int) floor(z))); + /* floor here rounds down, whereas a straight int<=real coercion apparently rounds towards 0 */ + } +#if WITH_GMP + case T_BIG_INTEGER: + return (x); + case T_BIG_RATIO: + mpz_fdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), + mpq_denref(big_ratio(x))); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(x))) + return (simple_out_of_range + (sc, sc->floor_symbol, x, its_nan_string)); + if (mpfr_inf_p(big_real(x))) + return (simple_out_of_range + (sc, sc->floor_symbol, x, its_infinite_string)); + mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDD); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_COMPLEX: +#endif + case T_COMPLEX: + return (s7_wrong_type_arg_error + (sc, "floor", 0, x, "a real number")); + default: + return (method_or_bust_one_arg_p(sc, x, sc->floor_symbol, T_REAL)); + } +} + +static s7_pointer g_floor(s7_scheme * sc, s7_pointer args) +{ +#define H_floor "(floor x) returns the integer closest to x toward -inf" +#define Q_floor s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) + return (floor_p_p(sc, car(args))); +} + +static s7_int floor_i_i(s7_int i) +{ + return (i); +} + +#if (!WITH_GMP) +static s7_int floor_i_7d(s7_scheme * sc, s7_double x) +{ + if (is_NaN(x)) + simple_out_of_range(sc, sc->floor_symbol, wrap_real1(sc, x), + its_nan_string); + if (fabs(x) > DOUBLE_TO_INT64_LIMIT) + simple_out_of_range(sc, sc->floor_symbol, wrap_real1(sc, x), + its_too_large_string); + return ((s7_int) floor(x)); +} + +static s7_int floor_i_7p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_integer(p)) + return (integer(p)); + if (is_t_real(p)) + return (floor_i_7d(sc, real(p))); + if (is_t_ratio(p)) { /* for consistency with floor_p_p, don't use floor(fraction(p)) */ + s7_int val; + val = numerator(p) / denominator(p); + return ((numerator(p) < 0) ? val - 1 : val); + } + return (s7_integer_checked + (sc, method_or_bust_p(sc, p, sc->floor_symbol, T_REAL))); +} +#endif + + +/* -------------------------------- ceiling -------------------------------- */ +static s7_pointer ceiling_p_p(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + return (x); + case T_RATIO: + { + s7_int val = numerator(x) / denominator(x); + return ((numerator(x) < 0) ? make_integer(sc, + val) : + make_integer(sc, val + 1)); + } + case T_REAL: + { + s7_double z = real(x); + if (is_NaN(z)) + return (simple_out_of_range + (sc, sc->ceiling_symbol, x, its_nan_string)); + if (is_inf(z)) + return (simple_out_of_range + (sc, sc->ceiling_symbol, x, its_infinite_string)); +#if WITH_GMP + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) { + mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); + mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDU); + return (mpz_to_integer(sc, sc->mpz_1)); + } +#else + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) + return (simple_out_of_range + (sc, sc->ceiling_symbol, x, its_too_large_string)); +#endif + return (make_integer(sc, (s7_int) ceil(real(x)))); + } +#if WITH_GMP + case T_BIG_INTEGER: + return (x); + case T_BIG_RATIO: + mpz_cdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), + mpq_denref(big_ratio(x))); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(x))) + return (simple_out_of_range + (sc, sc->ceiling_symbol, x, its_nan_string)); + if (mpfr_inf_p(big_real(x))) + return (simple_out_of_range + (sc, sc->ceiling_symbol, x, its_infinite_string)); + mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDU); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_COMPLEX: +#endif + case T_COMPLEX: + return (s7_wrong_type_arg_error + (sc, "ceiling", 0, x, "a real number")); + default: + return (method_or_bust_one_arg_p + (sc, x, sc->ceiling_symbol, T_REAL)); + } +} + +static s7_pointer g_ceiling(s7_scheme * sc, s7_pointer args) +{ +#define H_ceiling "(ceiling x) returns the integer closest to x toward inf" +#define Q_ceiling s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) + return (ceiling_p_p(sc, car(args))); +} + +static s7_int ceiling_i_i(s7_int i) +{ + return (i); +} + +#if (!WITH_GMP) +static s7_int ceiling_i_7d(s7_scheme * sc, s7_double x) +{ + if (is_NaN(x)) + simple_out_of_range(sc, sc->ceiling_symbol, wrap_real1(sc, x), + its_nan_string); + if ((is_inf(x)) || (x > DOUBLE_TO_INT64_LIMIT) + || (x < -DOUBLE_TO_INT64_LIMIT)) + simple_out_of_range(sc, sc->ceiling_symbol, wrap_real1(sc, x), + its_too_large_string); + return ((s7_int) ceil(x)); +} + +static s7_int ceiling_i_7p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_integer(p)) + return (integer(p)); + if (is_t_real(p)) + return (ceiling_i_7d(sc, real(p))); + if (is_t_ratio(p)) + return ((s7_int) (ceil(fraction(p)))); + return (s7_integer_checked + (sc, method_or_bust_p(sc, p, sc->ceiling_symbol, T_REAL))); +} +#endif + + +/* -------------------------------- truncate -------------------------------- */ +static s7_pointer truncate_p_p(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + return (x); + case T_RATIO: + return (make_integer(sc, (s7_int) (numerator(x) / denominator(x)))); /* C "/" already truncates (but this divide is not accurate over e13) */ + case T_REAL: + { + s7_double z = real(x); + if (is_NaN(z)) + return (simple_out_of_range + (sc, sc->truncate_symbol, x, its_nan_string)); + if (is_inf(z)) + return (simple_out_of_range + (sc, sc->truncate_symbol, x, its_infinite_string)); +#if WITH_GMP + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) { + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDZ); + return (mpz_to_integer(sc, sc->mpz_1)); + } +#else + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) + return (simple_out_of_range + (sc, sc->truncate_symbol, x, + its_too_large_string)); +#endif + return ((z > 0.0) ? make_integer(sc, + (s7_int) floor(z)) : + make_integer(sc, (s7_int) ceil(z))); + } +#if WITH_GMP + case T_BIG_INTEGER: + return (x); + case T_BIG_RATIO: + mpz_tdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), + mpq_denref(big_ratio(x))); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(x))) + return (simple_out_of_range + (sc, sc->truncate_symbol, x, its_nan_string)); + if (mpfr_inf_p(big_real(x))) + return (simple_out_of_range + (sc, sc->truncate_symbol, x, its_infinite_string)); + mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDZ); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_COMPLEX: +#endif + case T_COMPLEX: + return (s7_wrong_type_arg_error + (sc, "truncate", 0, x, "a real number")); + default: + return (method_or_bust_one_arg_p + (sc, x, sc->truncate_symbol, T_REAL)); + } +} + +static s7_pointer g_truncate(s7_scheme * sc, s7_pointer args) +{ +#define H_truncate "(truncate x) returns the integer closest to x toward 0" +#define Q_truncate s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) + return (truncate_p_p(sc, car(args))); +} + +static s7_int truncate_i_i(s7_int i) +{ + return (i); +} + +#if (!WITH_GMP) +static s7_int truncate_i_7d(s7_scheme * sc, s7_double x) +{ + if (is_NaN(x)) + simple_out_of_range(sc, sc->truncate_symbol, wrap_real1(sc, x), + its_nan_string); + if (is_inf(x)) + simple_out_of_range(sc, sc->truncate_symbol, wrap_real1(sc, x), + its_infinite_string); + if (fabs(x) > DOUBLE_TO_INT64_LIMIT) + simple_out_of_range(sc, sc->truncate_symbol, wrap_real1(sc, x), + its_too_large_string); + return ((x > 0.0) ? (s7_int) floor(x) : (s7_int) ceil(x)); +} +#endif + + +/* -------------------------------- round -------------------------------- */ +static s7_double r5rs_round(s7_double x) +{ + s7_double fl = floor(x), ce = ceil(x), dfl, dce; + dfl = x - fl; + dce = ce - x; + if (dfl > dce) + return (ce); + if (dfl < dce) + return (fl); + return ((fmod(fl, 2.0) == 0.0) ? fl : ce); +} + +static s7_pointer round_p_p(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + return (x); + case T_RATIO: + { + s7_int truncated = numerator(x) / denominator(x), remains = + numerator(x) % denominator(x); + long_double frac; + frac = + s7_fabsl((long_double) remains / + (long_double) denominator(x)); + if ((frac > 0.5) || ((frac == 0.5) && (truncated % 2 != 0))) + return ((numerator(x) < 0) ? make_integer(sc, + truncated - + 1) : + make_integer(sc, truncated + 1)); + return (make_integer(sc, truncated)); + } + case T_REAL: + { + s7_double z = real(x); + if (is_NaN(z)) + return (simple_out_of_range + (sc, sc->round_symbol, x, its_nan_string)); + if (is_inf(z)) + return (simple_out_of_range + (sc, sc->round_symbol, x, its_infinite_string)); +#if WITH_GMP + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) { + mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); + mpfr_rint(sc->mpfr_2, sc->mpfr_1, MPFR_RNDN); /* mpfr_roundeven in mpfr 4.0.0 */ + mpfr_get_z(sc->mpz_3, sc->mpfr_2, MPFR_RNDN); + return (mpz_to_integer(sc, sc->mpz_3)); + } +#else + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) + return (simple_out_of_range + (sc, sc->round_symbol, x, its_too_large_string)); +#endif + return (make_integer(sc, (s7_int) r5rs_round(z))); + } +#if WITH_GMP + case T_BIG_INTEGER: + return (x); + case T_BIG_RATIO: + { + int32_t rnd; + mpz_fdiv_qr(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(x)), + mpq_denref(big_ratio(x))); + mpz_mul_ui(sc->mpz_2, sc->mpz_2, 2); + rnd = mpz_cmpabs(sc->mpz_2, mpq_denref(big_ratio(x))); + mpz_fdiv_q(sc->mpz_2, sc->mpz_2, mpq_denref(big_ratio(x))); + if (rnd > 0) + mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); + else if ((rnd == 0) && (mpz_odd_p(sc->mpz_1))) + mpz_add_ui(sc->mpz_1, sc->mpz_1, 1); + return (mpz_to_integer(sc, sc->mpz_1)); + } + case T_BIG_REAL: + if (mpfr_nan_p(big_real(x))) + return (simple_out_of_range + (sc, sc->round_symbol, x, its_nan_string)); + if (mpfr_inf_p(big_real(x))) + return (simple_out_of_range + (sc, sc->round_symbol, x, its_infinite_string)); + mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); + mpfr_rint(sc->mpfr_2, sc->mpfr_1, MPFR_RNDN); + mpfr_get_z(sc->mpz_3, sc->mpfr_2, MPFR_RNDN); + return (mpz_to_integer(sc, sc->mpz_3)); + case T_BIG_COMPLEX: +#endif + case T_COMPLEX: + return (s7_wrong_type_arg_error + (sc, "round", 0, x, "a real number")); + default: + return (method_or_bust_one_arg_p(sc, x, sc->round_symbol, T_REAL)); + } +} + +static s7_pointer g_round(s7_scheme * sc, s7_pointer args) +{ +#define H_round "(round x) returns the integer closest to x" +#define Q_round s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) + return (round_p_p(sc, car(args))); +} + +static s7_int round_i_i(s7_int i) +{ + return (i); +} + +#if (!WITH_GMP) +static s7_int round_i_7d(s7_scheme * sc, s7_double z) +{ + if (is_NaN(z)) + simple_out_of_range(sc, sc->round_symbol, wrap_real1(sc, z), + its_nan_string); + if ((is_inf(z)) || (z > DOUBLE_TO_INT64_LIMIT) + || (z < -DOUBLE_TO_INT64_LIMIT)) + simple_out_of_range(sc, sc->round_symbol, wrap_real1(sc, z), + its_too_large_string); + return ((s7_int) r5rs_round(z)); +} +#endif + + +/* ---------------------------------------- add ---------------------------------------- */ + +static inline s7_pointer add_if_overflow_to_real_or_big_integer(s7_scheme * + sc, + s7_int x, + s7_int y) +{ +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if (add_overflow(x, y, &val)) +#if WITH_GMP + { + mpz_set_si(sc->mpz_1, x); + mpz_set_si(sc->mpz_2, y); + mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); + return (mpz_to_big_integer(sc, sc->mpz_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, + y); + return (make_real(sc, (long_double) x + (long_double) y)); + } +#endif + return (make_integer(sc, val)); +#else + return (make_integer(sc, x + y)); +#endif +} + +static s7_pointer +integer_ratio_add_if_overflow_to_real_or_rational(s7_scheme * sc, + s7_pointer x, + s7_pointer y) +{ /* x: int, y:ratio */ +#if HAVE_OVERFLOW_CHECKS + s7_int z; + if ((multiply_overflow(integer(x), denominator(y), &z)) || + (add_overflow(z, numerator(y), &z))) +#if WITH_GMP + { + mpz_set_si(sc->mpz_1, integer(x)); + mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(y)); + mpz_set_si(sc->mpz_2, numerator(y)); + mpz_add(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1); + mpz_set_si(mpq_denref(sc->mpq_1), denominator(y)); + return (mpq_to_rational(sc, sc->mpq_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "integer + ratio overflow: (+ %" ld64 " %" ld64 "/%" + ld64 ")\n", integer(x), numerator(y), denominator(y)); + return (make_real(sc, (long_double) integer(x) + fraction(y))); + } +#endif + return (make_ratio(sc, z, denominator(y))); +#else + return (make_ratio + (sc, integer(x) * denominator(y) + numerator(y), + denominator(y))); +#endif +} + +#define parcel_out_fractions(X, Y) do {d1 = denominator(x); n1 = numerator(x); d2 = denominator(y); n2 = numerator(y);} while (0) +/* add_out_x|y here (as in lt_out_x|y) gives a small speed-up, say 3-7 callgrind units, about 2% */ + +static s7_pointer add_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + /* an experiment: try to avoid the switch statement */ + /* this wins in most s7 cases, not so much elsewhere? parallel subtract/multiply code is slower */ + if (is_t_integer(x)) { + if (is_t_integer(y)) + return (add_if_overflow_to_real_or_big_integer + (sc, integer(x), integer(y))); + } else if (is_t_real(x)) { + if (is_t_real(y)) + return (make_real(sc, real(x) + real(y))); + } else if ((is_t_complex(x)) && (is_t_complex(y))) + return (make_complex + (sc, real_part(x) + real_part(y), + imag_part(x) + imag_part(y))); + + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_INTEGER: + return (add_if_overflow_to_real_or_big_integer + (sc, integer(x), integer(y))); + case T_RATIO: + return (integer_ratio_add_if_overflow_to_real_or_rational + (sc, x, y)); + case T_REAL: +#if WITH_GMP + if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) { /* (+ 9223372036854775807 .1), >= needed for (+ 9007199254740992 1.0) */ + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, (long_double) integer(x) + real(y))); + case T_COMPLEX: + return (make_complex_not_0i + (sc, + (long_double) integer(x) + (long_double) real_part(y), + imag_part(y))); +#if WITH_GMP + case T_BIG_INTEGER: + mpz_set_si(sc->mpz_1, integer(x)); + mpz_add(sc->mpz_1, sc->mpz_1, big_integer(y)); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, integer(x), 1); + mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_add_si(sc->mpfr_1, big_real(y), integer(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + return (integer_ratio_add_if_overflow_to_real_or_rational + (sc, y, x)); + case T_RATIO: + { + s7_int d1, d2, n1, n2; + parcel_out_fractions(x, y); + if (d1 == d2) { +#if HAVE_OVERFLOW_CHECKS + s7_int q; + if (add_overflow(n1, n2, &q)) +#if WITH_GMP + { + mpq_set_si(sc->mpq_1, n1, d1); + mpq_set_si(sc->mpq_2, n2, d2); + mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_rational(sc, sc->mpq_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "ratio + ratio overflow: (/ (+ %" ld64 + " %" ld64 ") %" ld64 ")\n", n1, n2, + d1); + return (make_real + (sc, + ((long_double) n1 + + (long_double) n2) / (long_double) d1)); + } +#endif + return (s7_make_ratio(sc, q, d1)); +#else + return (s7_make_ratio(sc, n1 + n2, d1)); +#endif + } + +#if HAVE_OVERFLOW_CHECKS + { + s7_int n1d2, n2d1, d1d2, q; + if ((multiply_overflow(d1, d2, &d1d2)) || + (multiply_overflow(n1, d2, &n1d2)) || + (multiply_overflow(n2, d1, &n2d1)) || + (add_overflow(n1d2, n2d1, &q))) +#if WITH_GMP + { + mpq_set_si(sc->mpq_1, n1, d1); + mpq_set_si(sc->mpq_2, n2, d2); + mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_rational(sc, sc->mpq_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "ratio + ratio overflow: (+ %" ld64 + "/%" ld64 " %" ld64 "/%" ld64 ")\n", + n1, d1, n2, d2); + return (make_real + (sc, + ((long_double) n1 / (long_double) d1) + + ((long_double) n2 / (long_double) d2))); + } +#endif + return (s7_make_ratio(sc, q, d1d2)); + } +#else + return (s7_make_ratio(sc, n1 * d2 + n2 * d1, d1 * d2)); +#endif + } + case T_REAL: + return (make_real(sc, fraction(x) + real(y))); + case T_COMPLEX: + return (make_complex_not_0i + (sc, fraction(x) + real_part(y), imag_part(y))); +#if WITH_GMP + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_set_z(sc->mpq_2, big_integer(y)); + mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpfr_add_q(sc->mpfr_1, big_real(y), sc->mpq_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } + + case T_REAL: + switch (type(y)) { + case T_INTEGER: +#if WITH_GMP + if (s7_int_abs(integer(y)) >= INT64_TO_DOUBLE_LIMIT) { /* (+ .1 9223372036854775807) */ + mpfr_set_si(sc->mpfr_1, integer(y), MPFR_RNDN); + mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, real(x) + (long_double) integer(y))); + case T_RATIO: + return (make_real(sc, real(x) + fraction(y))); + case T_REAL: + return (make_real(sc, real(x) + real(y))); + case T_COMPLEX: + return (make_complex_not_0i + (sc, real(x) + real_part(y), imag_part(y))); +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_add_d(sc->mpfr_1, big_real(y), real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } + + case T_COMPLEX: + switch (type(y)) { + case T_INTEGER: + return (make_complex_not_0i + (sc, real_part(x) + integer(y), imag_part(x))); + case T_RATIO: + return (make_complex_not_0i + (sc, real_part(x) + fraction(y), imag_part(x))); + case T_REAL: + return (make_complex_not_0i + (sc, real_part(x) + real(y), imag_part(x))); + case T_COMPLEX: + return (make_complex + (sc, real_part(x) + real_part(y), + imag_part(x) + imag_part(y))); +#if WITH_GMP + case T_BIG_INTEGER: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } + +#if WITH_GMP + case T_BIG_INTEGER: + switch (type(y)) { + case T_INTEGER: + mpz_set_si(sc->mpz_1, integer(y)); + mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_RATIO: + mpq_set_z(sc->mpq_2, big_integer(x)); + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_add(sc->mpq_1, sc->mpq_2, sc->mpq_1); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpz_add(sc->mpz_1, big_integer(x), big_integer(y)); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_add_z(sc->mpfr_1, big_real(y), big_integer(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } + + case T_BIG_RATIO: + switch (type(y)) { + case T_INTEGER: + mpq_set_si(sc->mpq_1, integer(y), 1); + mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpq_set_z(sc->mpq_1, big_integer(y)); + mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_add(sc->mpq_1, big_ratio(x), big_ratio(y)); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_add_q(sc->mpfr_1, big_real(y), big_ratio(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } + + case T_BIG_REAL: + switch (type(y)) { + case T_INTEGER: + mpfr_add_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpfr_add_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + mpfr_add_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpfr_add_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_add_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_add(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_add_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } + case T_BIG_COMPLEX: + switch (type(y)) { + case T_INTEGER: + mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN); + mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_REAL: + /* if (is_NaN(real(y))) return(real_NaN); */ + mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); + mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); + mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); + mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_add_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_add(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } +#endif + default: + return (method_or_bust_with_type_pp + (sc, x, sc->add_symbol, x, y, a_number_string, 1)); + } +} + +static s7_pointer add_p_ppp(s7_scheme * sc, s7_pointer x, s7_pointer y, + s7_pointer z) +{ +#if HAVE_OVERFLOW_CHECKS && (!WITH_GMP) + if ((is_t_integer(x)) && (is_t_integer(y)) && (is_t_integer(z))) { + s7_int val; + if ((!add_overflow(integer(x), integer(y), &val)) && + (!add_overflow(val, integer(z), &val))) + return (make_integer(sc, val)); + if (WITH_WARNINGS) + s7_warn(sc, 128, + "integer add overflow: (+ %" ld64 " %" ld64 " %" ld64 + ")\n", integer(x), integer(y), integer(z)); + return (make_real + (sc, + (long_double) integer(x) + (long_double) integer(y) + + (long_double) integer(z))); + } +#endif + if ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z))) + return (make_real(sc, real(x) + real(y) + real(z))); + return (add_p_pp(sc, add_p_pp(sc, x, y), z)); +} + +static s7_pointer g_add(s7_scheme * sc, s7_pointer args) +{ +#define H_add "(+ ...) adds its arguments" +#define Q_add sc->pcl_n + + s7_pointer x, p; + if (is_null(args)) + return (int_zero); + x = car(args); + p = cdr(args); + if (is_null(p)) { + if (!is_number(x)) + return (method_or_bust_with_type_one_arg + (sc, x, sc->add_symbol, args, a_number_string)); + return (x); + } + if (is_null(cdr(p))) + return (add_p_pp(sc, x, car(p))); + for (; is_pair(p); p = cdr(p)) + x = add_p_pp(sc, x, car(p)); + return (x); +} + +static s7_pointer g_add_2(s7_scheme * sc, s7_pointer args) +{ + return (add_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_add_3(s7_scheme * sc, s7_pointer args) +{ + s7_pointer p0 = car(args), p1 = cadr(args), p2 = caddr(args); + if ((is_t_integer(p0)) && (is_t_integer(p1)) && (is_t_integer(p2))) { +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if ((!add_overflow(integer(p0), integer(p1), &val)) && + (!add_overflow(val, integer(p2), &val))) + return (make_integer(sc, val)); +#if WITH_GMP + mpz_set_si(sc->mpz_1, integer(p0)); + mpz_set_si(sc->mpz_2, integer(p1)); + mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); + mpz_set_si(sc->mpz_2, integer(p2)); + mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); + return (mpz_to_integer(sc, sc->mpz_1)); +#else + if (WITH_WARNINGS) + s7_warn(sc, 128, + "integer add overflow: (+ %" ld64 " %" ld64 " %" ld64 + ")\n", integer(p0), integer(p1), integer(p2)); + return (make_real + (sc, + (long_double) integer(p0) + (long_double) integer(p1) + + (long_double) integer(p2))); +#endif +#else + return (make_integer(sc, integer(p0) + integer(p1) + integer(p2))); +#endif + } + if ((is_t_real(p0)) && (is_t_real(p1)) && (is_t_real(p2))) + return (make_real(sc, real(p0) + real(p1) + real(p2))); + return (add_p_pp(sc, add_p_pp(sc, p0, p1), p2)); +} + +/* trade-off in add_3: time saved by using add_p_pp, but it conses up a new number cell, so subsequent gc can overwhelm the gains, and add add_p_pp overhead + * need int wrap as output or reuse-if-known-temp, or perhaps free if not permanent + */ + +static s7_pointer g_add_x1_1(s7_scheme * sc, s7_pointer x, int pos) +{ + if (is_t_integer(x)) + return (add_if_overflow_to_real_or_big_integer(sc, integer(x), 1)); + + switch (type(x)) { + case T_RATIO: + return (add_p_pp(sc, x, int_one)); + case T_REAL: + return (make_real(sc, real(x) + 1.0)); + case T_COMPLEX: + return (make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x))); +#if WITH_GMP + case T_BIG_INTEGER: + mpz_set_si(sc->mpz_1, 1); + mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + case T_BIG_REAL: + case T_BIG_COMPLEX: + return (add_p_pp(sc, x, int_one)); +#endif + default: + return (method_or_bust_with_type(sc, x, sc->add_symbol, + (pos == 1) ? set_plist_2(sc, x, + int_one) + : set_plist_2(sc, int_one, x), + a_number_string, pos)); + } + return (x); +} + +#if WITH_GMP +static s7_pointer g_add_x1(s7_scheme * sc, s7_pointer args) +{ + return (g_add_x1_1(sc, car(args), 1)); +} +#else +static s7_pointer g_add_x1(s7_scheme * sc, s7_pointer args) +{ + s7_pointer x = car(args); + if (is_t_integer(x)) + return (make_integer(sc, integer(x) + 1)); + if (is_t_real(x)) + return (make_real(sc, real(x) + 1.0)); + if (is_t_complex(x)) + return (make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x))); + return (add_p_pp(sc, x, int_one)); +} +#endif +static s7_pointer g_add_1x(s7_scheme * sc, s7_pointer args) +{ + return (g_add_x1_1(sc, cadr(args), 2)); +} + +static s7_pointer g_add_xi(s7_scheme * sc, s7_pointer x, s7_int y) +{ + if (is_t_integer(x)) + return (add_if_overflow_to_real_or_big_integer(sc, integer(x), y)); + + switch (type(x)) { + case T_RATIO: + return (add_p_pp(sc, x, wrap_integer1(sc, y))); + case T_REAL: + return (make_real(sc, real(x) + y)); + case T_COMPLEX: + return (make_complex_not_0i(sc, real_part(x) + y, imag_part(x))); +#if WITH_GMP + case T_BIG_INTEGER: + mpz_set_si(sc->mpz_1, y); + mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + case T_BIG_REAL: + case T_BIG_COMPLEX: + return (add_p_pp(sc, x, wrap_integer1(sc, y))); +#endif + default: + return (method_or_bust_with_type_pi + (sc, x, sc->add_symbol, x, y, a_number_string)); + } + return (x); +} + +static s7_pointer g_add_xf(s7_scheme * sc, s7_pointer x, s7_double y) +{ + if (is_t_real(x)) + return (make_real(sc, real(x) + y)); + switch (type(x)) { + case T_INTEGER: + return (make_real(sc, integer(x) + y)); + case T_RATIO: + return (make_real(sc, fraction(x) + y)); + case T_COMPLEX: + return (make_complex_not_0i(sc, real_part(x) + y, imag_part(x))); +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + case T_BIG_REAL: + case T_BIG_COMPLEX: + return (add_p_pp(sc, x, wrap_real2(sc, y))); +#endif + default: + return (method_or_bust_with_type_pf + (sc, x, sc->add_symbol, x, y, a_number_string)); + } + return (x); +} + +static s7_pointer g_add_2_ff(s7_scheme * sc, s7_pointer args) +{ +#if WITH_GMP + if ((is_t_real(car(args))) && (is_t_real(cadr(args)))) + return (make_real(sc, real(car(args)) + real(cadr(args)))); + return (add_p_pp(sc, car(args), cadr(args))); +#else + return (make_real(sc, real(car(args)) + real(cadr(args)))); +#endif +} + +static s7_pointer g_add_2_ii(s7_scheme * sc, s7_pointer args) +{ +#if WITH_GMP + if ((is_t_integer(car(args))) && (is_t_integer(cadr(args)))) +#endif + return (add_if_overflow_to_real_or_big_integer + (sc, integer(car(args)), integer(cadr(args)))); +#if WITH_GMP + return (g_add(sc, args)); /* possibly bigint? */ +#endif +} + +#if WITH_GMP +static s7_pointer add_2_if(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if ((is_t_integer(x)) && (is_t_real(y))) { + if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) { + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } + return (make_real(sc, integer(x) + real(y))); + } + return (add_p_pp(sc, x, y)); +} + +static s7_pointer g_add_2_if(s7_scheme * sc, s7_pointer args) +{ + return (add_2_if(sc, car(args), cadr(args))); +} + +static s7_pointer g_add_2_fi(s7_scheme * sc, s7_pointer args) +{ + return (add_2_if(sc, cadr(args), car(args))); +} + +static s7_pointer g_add_2_xi(s7_scheme * sc, s7_pointer args) +{ + if (is_t_integer(cadr(args))) + return (g_add_xi(sc, car(args), integer(cadr(args)))); + return (g_add(sc, args)); +} + +static s7_pointer g_add_2_ix(s7_scheme * sc, s7_pointer args) +{ + if (is_t_integer(car(args))) + return (g_add_xi(sc, cadr(args), integer(car(args)))); + return (g_add(sc, args)); +} + +static s7_pointer g_add_2_xf(s7_scheme * sc, s7_pointer args) +{ + if (is_t_real(cadr(args))) + return (g_add_xf(sc, car(args), real(cadr(args)))); + return (g_add(sc, args)); +} + +static s7_pointer g_add_2_fx(s7_scheme * sc, s7_pointer args) +{ + if (is_t_real(car(args))) + return (g_add_xf(sc, cadr(args), real(car(args)))); + return (g_add(sc, args)); +} + +#else + +static s7_pointer g_add_2_if(s7_scheme * sc, s7_pointer args) +{ + return (make_real(sc, integer(car(args)) + real(cadr(args)))); +} + +static s7_pointer g_add_2_fi(s7_scheme * sc, s7_pointer args) +{ + return (make_real(sc, real(car(args)) + integer(cadr(args)))); +} + +static s7_pointer g_add_2_xi(s7_scheme * sc, s7_pointer args) +{ + return (g_add_xi(sc, car(args), integer(cadr(args)))); +} + +static s7_pointer g_add_2_ix(s7_scheme * sc, s7_pointer args) +{ + return (g_add_xi(sc, cadr(args), integer(car(args)))); +} + +static s7_pointer g_add_2_xf(s7_scheme * sc, s7_pointer args) +{ + return (g_add_xf(sc, car(args), real(cadr(args)))); +} + +static s7_pointer g_add_2_fx(s7_scheme * sc, s7_pointer args) +{ + return (g_add_xf(sc, cadr(args), real(car(args)))); +} +#endif + +static s7_pointer add_p_dd(s7_scheme * sc, s7_double x1, s7_double x2) +{ + return (make_real(sc, x1 + x2)); +} + +/* add_p_ii and add_d_id unhittable apparently -- this (d_id) is due to the order of d_dd_ok and d_id_ok in float_optimize, + * but d_dd is much more often hit, and the int arg (if constant) is turned into a float in d_dd + */ +static s7_double add_d_d(s7_double x) +{ + return (x); +} + +static s7_double add_d_dd(s7_double x1, s7_double x2) +{ + return (x1 + x2); +} + +static s7_double add_d_ddd(s7_double x1, s7_double x2, s7_double x3) +{ + return (x1 + x2 + x3); +} + +static s7_double add_d_dddd(s7_double x1, s7_double x2, s7_double x3, + s7_double x4) +{ + return (x1 + x2 + x3 + x4); +} + +static s7_int add_i_ii(s7_int i1, s7_int i2) +{ + return (i1 + i2); +} + +static s7_int add_i_iii(s7_int i1, s7_int i2, s7_int i3) +{ + return (i1 + i2 + i3); +} + +static s7_pointer argument_type(s7_scheme * sc, s7_pointer arg1) +{ + if (is_pair(arg1)) { + if (car(arg1) == sc->quote_symbol) + return ((is_pair(cdr(arg1))) ? s7_type_of(sc, cadr(arg1)) : NULL); /* arg1 = (quote) */ + + if ((is_h_optimized(arg1)) && + (is_safe_c_op(optimize_op(arg1))) && + (is_c_function(opt1_cfunc(arg1)))) { + s7_pointer sig; + sig = c_function_signature(opt1_cfunc(arg1)); + if ((sig) && (is_pair(sig)) && (is_symbol(car(sig)))) + return (car(sig)); + } + /* perhaps add closure sig if we can depend on it (immutable func etc) */ + } else if (!is_symbol(arg1)) + return (s7_type_of(sc, arg1)); + return (NULL); +} + +static s7_pointer chooser_check_arg_types(s7_scheme * sc, s7_pointer arg1, + s7_pointer arg2, + s7_pointer fallback, + s7_pointer f_2_ff, + s7_pointer f_2_ii, + s7_pointer f_2_if, + s7_pointer f_2_fi, + s7_pointer f_2_xi, + s7_pointer f_2_ix, + s7_pointer f_2_fx, + s7_pointer f_2_xf) +{ + s7_pointer arg1_type, arg2_type; + arg1_type = argument_type(sc, arg1); + arg2_type = argument_type(sc, arg2); + if ((arg1_type) || (arg2_type)) { + if (arg1_type == sc->is_float_symbol) { + if (arg2_type == sc->is_float_symbol) + return (f_2_ff); + return ((arg2_type == + sc->is_integer_symbol) ? f_2_fi : f_2_fx); + } + if (arg1_type == sc->is_integer_symbol) { + if (arg2_type == sc->is_float_symbol) + return (f_2_if); + return ((arg2_type == + sc->is_integer_symbol) ? f_2_ii : f_2_ix); + } + if (arg2_type == sc->is_float_symbol) + return (f_2_xf); + if (arg2_type == sc->is_integer_symbol) + return (f_2_xi); + } + return (fallback); +} + +static s7_pointer g_random_i(s7_scheme * sc, s7_pointer args); + +static s7_pointer add_chooser(s7_scheme * sc, s7_pointer f, int32_t args, + s7_pointer expr, bool ops) +{ + /* (+ s f) (+ (* s s) s) (+ s s) (+ s (* s s)) */ + if (args == 2) { + if (ops) { + s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if (arg2 == int_one) /* (+ ... 1) */ + return (sc->add_x1); + if ((is_t_integer(arg1)) + && ((is_pair(arg2)) && (is_optimized(arg2)) + && (is_h_safe_c_d(arg2)) + && (fn_proc(arg2) == g_random_i))) { + set_opt3_int(cdr(expr), cadr(arg2)); + set_safe_optimize_op(expr, HOP_SAFE_C_NC); /* op if r op? */ + return (sc->add_i_random); + } + if (arg1 == int_one) + return (sc->add_1x); + return (chooser_check_arg_types(sc, arg1, arg2, sc->add_2, + sc->add_2_ff, sc->add_2_ii, + sc->add_2_if, sc->add_2_fi, + sc->add_2_xi, sc->add_2_ix, + sc->add_2_fx, sc->add_2_xf)); + } + return (sc->add_2); + } + return ((args == 3) ? sc->add_3 : f); +} + +/* ---------------------------------------- subtract ---------------------------------------- */ + +static s7_pointer negate_p_p(s7_scheme * sc, s7_pointer p) +{ /* can't use "negate" because it confuses C++! */ + switch (type(p)) { + case T_INTEGER: + if (integer(p) == S7_INT64_MIN) +#if WITH_GMP + { + mpz_set_si(sc->mpz_1, S7_INT64_MIN); + mpz_neg(sc->mpz_1, sc->mpz_1); + return (mpz_to_big_integer(sc, sc->mpz_1)); + } +#else + return (simple_out_of_range + (sc, sc->subtract_symbol, p, + wrap_string(sc, + "most-negative-fixnum can't be negated", + 37))); +#endif + return (make_integer(sc, -integer(p))); + + case T_RATIO: + return (make_simple_ratio(sc, -numerator(p), denominator(p))); + case T_REAL: + return (make_real(sc, -real(p))); + case T_COMPLEX: + return (make_complex_not_0i(sc, -real_part(p), -imag_part(p))); + +#if WITH_GMP + case T_BIG_INTEGER: + mpz_neg(sc->mpz_1, big_integer(p)); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_neg(sc->mpq_1, big_ratio(p)); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_neg(sc->mpfr_1, big_real(p), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_neg(sc->mpc_1, big_complex(p), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_one_arg_p + (sc, p, sc->subtract_symbol, a_number_string)); + } +} + +static inline s7_pointer +subtract_if_overflow_to_real_or_big_integer(s7_scheme * sc, s7_int x, + s7_int y) +{ +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if (subtract_overflow(x, y, &val)) +#if WITH_GMP + { + mpz_set_si(sc->mpz_1, x); + mpz_set_si(sc->mpz_2, y); + mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_2); + return (mpz_to_big_integer(sc, sc->mpz_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", + x, y); + return (make_real(sc, (long_double) x - (long_double) y)); + } +#endif + return (make_integer(sc, val)); +#else + return (make_integer(sc, x - y)); +#endif +} + +static s7_pointer subtract_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + switch (type(x)) { + case T_INTEGER: + if (integer(x) == 0) + return (negate_p_p(sc, y)); + switch (type(y)) { + case T_INTEGER: + return (subtract_if_overflow_to_real_or_big_integer + (sc, integer(x), integer(y))); + + case T_RATIO: + { +#if HAVE_OVERFLOW_CHECKS + s7_int z; + if ((multiply_overflow(integer(x), denominator(y), &z)) || + (subtract_overflow(z, numerator(y), &z))) +#if WITH_GMP + { + mpz_set_si(sc->mpz_1, integer(x)); + mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(y)); + mpz_set_si(sc->mpz_2, numerator(y)); + mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_1, sc->mpz_2); + mpz_set_si(mpq_denref(sc->mpq_1), denominator(y)); + return (mpq_to_rational(sc, sc->mpq_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "integer - ratio overflow: (- %" ld64 " %" + ld64 "/%" ld64 ")\n", integer(x), + numerator(y), denominator(y)); + return (make_real + (sc, (long_double) integer(x) - fraction(y))); + } +#endif + return (make_ratio(sc, z, denominator(y))); +#else + return (make_ratio + (sc, integer(x) * denominator(y) - numerator(y), + denominator(y))); +#endif + } + case T_REAL: +#if WITH_GMP + if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) { /* (- 9223372036854775807 .1) */ + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, (long_double) integer(x) - real(y))); + case T_COMPLEX: + return (make_complex_not_0i + (sc, (long_double) integer(x) - real_part(y), + -imag_part(y))); +#if WITH_GMP + case T_BIG_INTEGER: + mpz_set_si(sc->mpz_1, integer(x)); + mpz_sub(sc->mpz_1, sc->mpz_1, big_integer(y)); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, integer(x), 1); + mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_si_sub(sc->mpfr_1, integer(x), big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->subtract_symbol, x, y, a_number_string, + 2)); + } + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + { +#if HAVE_OVERFLOW_CHECKS + s7_int z; + if ((multiply_overflow(integer(y), denominator(x), &z)) || + (subtract_overflow(numerator(x), z, &z))) +#if WITH_GMP + { + mpz_set_si(sc->mpz_1, integer(y)); + mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(x)); + mpz_set_si(sc->mpz_2, numerator(x)); + mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1); + mpz_set_si(mpq_denref(sc->mpq_1), denominator(x)); + return (mpq_to_rational(sc, sc->mpq_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "ratio - integer overflow: (- %" ld64 "/%" + ld64 " %" ld64 ")\n", numerator(x), + denominator(x), integer(y)); + return (make_real + (sc, fraction(x) - (long_double) integer(y))); + } +#endif + return (make_ratio(sc, z, denominator(x))); +#else + return (make_ratio + (sc, numerator(x) - (integer(y) * denominator(x)), + denominator(x))); +#endif + } + case T_RATIO: + { + s7_int d1, d2, n1, n2; + parcel_out_fractions(x, y); + if (d1 == d2) { +#if HAVE_OVERFLOW_CHECKS + s7_int q; + if (subtract_overflow(n1, n2, &q)) +#if WITH_GMP + { + mpq_set_si(sc->mpq_1, n1, d1); + mpq_set_si(sc->mpq_2, n2, d2); + mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_rational(sc, sc->mpq_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "ratio - ratio overflow: (- %" ld64 + "/%" ld64 " %" ld64 "/%" ld64 ")\n", + n1, d1, n2, d2); + return (make_real + (sc, + ((long_double) n1 - + (long_double) n2) / (long_double) d1)); + } +#endif + return (s7_make_ratio(sc, q, d1)); +#else + return (make_ratio + (sc, numerator(x) - numerator(y), + denominator(x))); +#endif + } + +#if HAVE_OVERFLOW_CHECKS + { + s7_int n1d2, n2d1, d1d2, q; + if ((multiply_overflow(d1, d2, &d1d2)) || + (multiply_overflow(n1, d2, &n1d2)) || + (multiply_overflow(n2, d1, &n2d1)) || + (subtract_overflow(n1d2, n2d1, &q))) +#if WITH_GMP + { + mpq_set_si(sc->mpq_1, n1, d1); + mpq_set_si(sc->mpq_2, n2, d2); + mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_rational(sc, sc->mpq_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "ratio - ratio overflow: (- %" ld64 + "/%" ld64 " %" ld64 "/%" ld64 ")\n", + n1, d1, n2, d2); + return (make_real + (sc, + ((long_double) n1 / (long_double) d1) - + ((long_double) n2 / (long_double) d2))); + } +#endif + return (s7_make_ratio(sc, q, d1d2)); + } +#else + return (s7_make_ratio(sc, n1 * d2 - n2 * d1, d1 * d2)); +#endif + } + case T_REAL: + return (make_real(sc, fraction(x) - real(y))); + case T_COMPLEX: + return (make_complex_not_0i + (sc, fraction(x) - real_part(y), -imag_part(y))); +#if WITH_GMP + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_set_z(sc->mpq_2, big_integer(y)); + mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); + mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->subtract_symbol, x, y, a_number_string, + 2)); + } + + case T_REAL: + switch (type(y)) { + case T_INTEGER: +#if WITH_GMP + if (s7_int_abs(integer(y)) >= INT64_TO_DOUBLE_LIMIT) { /* (- .1 92233720368547758071) */ + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_sub_si(sc->mpfr_1, sc->mpfr_1, integer(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, real(x) - (long_double) integer(y))); /* long_double saves (- 9007199254740996.0 9007199254740995): 1.0 */ + case T_RATIO: + return (make_real(sc, real(x) - fraction(y))); + case T_REAL: + return (make_real(sc, real(x) - real(y))); + case T_COMPLEX: + return (make_complex_not_0i + (sc, real(x) - real_part(y), -imag_part(y))); +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_sub_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_sub_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_d_sub(sc->mpfr_1, real(x), big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->subtract_symbol, x, y, a_number_string, + 2)); + } + + case T_COMPLEX: + switch (type(y)) { + case T_INTEGER: + return (make_complex_not_0i + (sc, real_part(x) - integer(y), imag_part(x))); + case T_RATIO: + return (make_complex_not_0i + (sc, real_part(x) - fraction(y), imag_part(x))); + case T_REAL: + return (make_complex_not_0i + (sc, real_part(x) - real(y), imag_part(x))); + case T_COMPLEX: + return (make_complex + (sc, real_part(x) - real_part(y), + imag_part(x) - imag_part(y))); +#if WITH_GMP + case T_BIG_INTEGER: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_sub_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->subtract_symbol, x, y, a_number_string, + 2)); + } + +#if WITH_GMP + case T_BIG_INTEGER: + switch (type(y)) { + case T_INTEGER: + mpz_set_si(sc->mpz_1, integer(y)); + mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_RATIO: + mpq_set_z(sc->mpq_2, big_integer(x)); + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_sub(sc->mpq_1, sc->mpq_2, sc->mpq_1); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpz_sub(sc->mpz_1, big_integer(x), big_integer(y)); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->subtract_symbol, x, y, a_number_string, + 2)); + } + + case T_BIG_RATIO: + switch (type(y)) { + case T_INTEGER: + mpq_set_si(sc->mpq_1, integer(y), 1); + mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpq_set_z(sc->mpq_1, big_integer(y)); + mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_sub(sc->mpq_1, big_ratio(x), big_ratio(y)); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->subtract_symbol, x, y, a_number_string, + 2)); + } + + case T_BIG_REAL: + switch (type(y)) { + case T_INTEGER: + mpfr_sub_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpfr_sub_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + mpfr_sub_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_fr_sub(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpfr_sub_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_sub_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_sub(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_fr_sub(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->subtract_symbol, x, y, a_number_string, + 2)); + } + case T_BIG_COMPLEX: + switch (type(y)) { + case T_INTEGER: + mpc_set_si(sc->mpc_2, integer(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_REAL: + /* if (is_NaN(real(y))) return(real_NaN); */ + mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); + mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_sub_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_sub(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->subtract_symbol, x, y, a_number_string, + 2)); + } +#endif + default: + return (method_or_bust_with_type_pp + (sc, x, sc->subtract_symbol, x, y, a_number_string, 1)); + } +} + +static s7_pointer g_subtract(s7_scheme * sc, s7_pointer args) +{ +#define H_subtract "(- x1 ...) subtracts its trailing arguments from the first, or negates the first if only one it is given" +#define Q_subtract sc->pcl_n + + s7_pointer x = car(args), p = cdr(args); + if (is_null(p)) + return (negate_p_p(sc, x)); + return ((is_null(cddr(args))) ? subtract_p_pp(sc, x, cadr(args)) : + subtract_p_pp(sc, x, g_add(sc, cdr(args)))); +} + +static s7_pointer g_subtract_1(s7_scheme * sc, s7_pointer args) +{ + return (negate_p_p(sc, car(args))); +} + +static s7_pointer g_subtract_2(s7_scheme * sc, s7_pointer args) +{ + return (subtract_p_pp(sc, car(args), cadr(args))); +} + +/* static s7_pointer g_subtract_3(s7_scheme *sc, s7_pointer args) {return(subtract_p_pp(sc, subtract_p_pp(sc, car(args), cadr(args)), caddr(args)));} */ +static s7_pointer g_subtract_3(s7_scheme * sc, s7_pointer args) +{ + return (subtract_p_pp + (sc, car(args), add_p_pp(sc, cadr(args), caddr(args)))); +} + +static s7_pointer minus_c1(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + return (subtract_if_overflow_to_real_or_big_integer + (sc, integer(x), 1)); + case T_RATIO: + return (subtract_p_pp(sc, x, int_one)); + case T_REAL: + return (make_real(sc, real(x) - 1.0)); + case T_COMPLEX: + return (make_complex_not_0i(sc, real_part(x) - 1.0, imag_part(x))); +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + case T_BIG_REAL: + case T_BIG_COMPLEX: + return (subtract_p_pp(sc, x, int_one)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, x, sc->subtract_symbol, x, int_one, a_number_string, + 1)); + } + return (x); +} + +static s7_pointer g_subtract_x1(s7_scheme * sc, s7_pointer args) +{ + s7_pointer p = car(args); +#if WITH_GMP + return (subtract_p_pp(sc, p, int_one)); +#endif + return ((is_t_integer(p)) ? make_integer(sc, integer(p) - 1) : + minus_c1(sc, p)); +} + +static s7_pointer g_subtract_2f(s7_scheme * sc, s7_pointer args) +{ /* (- x f) */ + s7_pointer x = car(args); + s7_double n = real(cadr(args)); /* checked below is_t_real */ + if (is_t_real(x)) + return (make_real(sc, real(x) - n)); + switch (type(x)) { + case T_INTEGER: + return (make_real(sc, integer(x) - n)); + case T_RATIO: + return (make_real(sc, fraction(x) - n)); + case T_COMPLEX: + return (make_complex_not_0i(sc, real_part(x) - n, imag_part(x))); +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + case T_BIG_REAL: + case T_BIG_COMPLEX: + return (subtract_p_pp(sc, x, cadr(args))); +#endif + default: + return (method_or_bust_with_type + (sc, x, sc->subtract_symbol, args, a_number_string, 1)); + } + return (x); +} + +static s7_pointer g_subtract_f2(s7_scheme * sc, s7_pointer args) +{ /* (- f x) */ + s7_pointer x = cadr(args); + s7_double n = real(car(args)); /* checked below is_t_real */ + + if (is_t_real(x)) + return (make_real(sc, n - real(x))); + switch (type(x)) { + case T_INTEGER: + return (make_real(sc, n - integer(x))); + case T_RATIO: + return (make_real(sc, n - fraction(x))); + case T_COMPLEX: + return (make_complex_not_0i(sc, n - real_part(x), -imag_part(x))); +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + case T_BIG_REAL: + case T_BIG_COMPLEX: + return (subtract_p_pp(sc, car(args), x)); +#endif + default: + return (method_or_bust_with_type + (sc, x, sc->subtract_symbol, args, a_number_string, 1)); + } + return (x); +} + +static s7_int subtract_i_ii(s7_int i1, s7_int i2) +{ + return (i1 - i2); +} + +static s7_int subtract_i_i(s7_int x) +{ + return (-x); +} + +static s7_int subtract_i_iii(s7_int i1, s7_int i2, s7_int i3) +{ + return (i1 - i2 - i3); +} + +static s7_double subtract_d_d(s7_double x) +{ + return (-x); +} + +static s7_double subtract_d_dd(s7_double x1, s7_double x2) +{ + return (x1 - x2); +} + +static s7_double subtract_d_ddd(s7_double x1, s7_double x2, s7_double x3) +{ + return (x1 - x2 - x3); +} + +static s7_double subtract_d_dddd(s7_double x1, s7_double x2, s7_double x3, + s7_double x4) +{ + return (x1 - x2 - x3 - x4); +} + +static s7_pointer subtract_p_dd(s7_scheme * sc, s7_double x1, s7_double x2) +{ + return (make_real(sc, x1 - x2)); +} + +static s7_pointer subtract_p_ii(s7_scheme * sc, s7_int i1, s7_int i2) +{ + return (make_integer(sc, i1 - i2)); +} + +static s7_pointer g_sub_xi(s7_scheme * sc, s7_pointer x, s7_int y) +{ + if (is_t_integer(x)) + return (subtract_if_overflow_to_real_or_big_integer + (sc, integer(x), y)); + + switch (type(x)) { + case T_RATIO: + return (make_ratio + (sc, numerator(x) - (y * denominator(x)), denominator(x))); + case T_REAL: + return (make_real(sc, real(x) - y)); + case T_COMPLEX: + return (make_complex_not_0i(sc, real_part(x) - y, imag_part(x))); +#if WITH_GMP + case T_BIG_INTEGER: + mpz_set_si(sc->mpz_1, y); + mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + case T_BIG_REAL: + case T_BIG_COMPLEX: + return (subtract_p_pp(sc, x, wrap_integer1(sc, y))); +#endif + default: + return (method_or_bust_with_type_pi + (sc, x, sc->subtract_symbol, x, y, a_number_string)); + } + return (x); +} + +static s7_pointer subtract_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if (args == 1) + return (sc->subtract_1); + if (args == 2) { + if (ops) { + s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if (arg2 == int_one) + return (sc->subtract_x1); + if (is_t_real(arg1)) + return (sc->subtract_f2); + if (is_t_real(arg2)) + return (sc->subtract_2f); + } + return (sc->subtract_2); + } + return ((args == 3) ? sc->subtract_3 : f); +} + + +/* ---------------------------------------- multiply ---------------------------------------- */ + +#define QUOTIENT_FLOAT_LIMIT 1e13 +#define QUOTIENT_INT_LIMIT 10000000000000 +/* fraction(x) is not accurate enough if it involves numbers over e18 even when done with long_doubles */ + +static inline s7_pointer +multiply_if_overflow_to_real_or_big_integer(s7_scheme * sc, s7_int x, + s7_int y) +{ +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if (multiply_overflow(x, y, &val)) +#if WITH_GMP + { + mpz_set_si(sc->mpz_1, x); + mpz_mul_si(sc->mpz_1, sc->mpz_1, y); + return (mpz_to_big_integer(sc, sc->mpz_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", + x, y); + return (make_real(sc, (double) x * (double) y)); + } +#endif + return (make_integer(sc, val)); +#else + return (make_integer(sc, x * y)); +#endif +} + +static s7_pointer +integer_ratio_multiply_if_overflow_to_real_or_ratio(s7_scheme * sc, + s7_int x, s7_pointer y) +{ +#if HAVE_OVERFLOW_CHECKS + s7_int z; + if (multiply_overflow(x, numerator(y), &z)) +#if WITH_GMP + { + mpz_set_si(sc->mpz_1, x); + mpz_mul_si(sc->mpz_1, sc->mpz_1, numerator(y)); + mpq_set_si(sc->mpq_1, 1, denominator(y)); + mpq_set_num(sc->mpq_1, sc->mpz_1); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "integer * ratio overflow: (* %" ld64 " %" ld64 "/%" + ld64 ")\n", x, numerator(y), denominator(y)); + return (make_real(sc, (double) x * fraction(y))); + } +#endif + return (make_ratio(sc, z, denominator(y))); +#else + return (make_ratio(sc, x * numerator(y), denominator(y))); +#endif +} + +static s7_pointer multiply_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_INTEGER: + return (multiply_if_overflow_to_real_or_big_integer + (sc, integer(x), integer(y))); + case T_RATIO: + return (integer_ratio_multiply_if_overflow_to_real_or_ratio + (sc, integer(x), y)); + case T_REAL: +#if WITH_GMP + if (s7_int_abs(integer(x)) > QUOTIENT_INT_LIMIT) { + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); + mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, (long_double) integer(x) * real(y))); + case T_COMPLEX: + return (s7_make_complex + (sc, (long_double) integer(x) * real_part(y), + (long_double) integer(x) * imag_part(y))); +#if WITH_GMP + case T_BIG_INTEGER: + mpz_mul_si(sc->mpz_1, big_integer(y), integer(x)); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, integer(x), 1); + mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_mul_si(sc->mpfr_1, big_real(y), integer(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_mul_si(sc->mpc_1, big_complex(y), integer(x), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); /* x might be 0 */ +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->multiply_symbol, x, y, a_number_string, + 2)); + } + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + return (integer_ratio_multiply_if_overflow_to_real_or_ratio + (sc, integer(y), x)); + case T_RATIO: + { + s7_int d1, d2, n1, n2; + parcel_out_fractions(x, y); +#if HAVE_OVERFLOW_CHECKS + { + s7_int n1n2, d1d2; + if ((multiply_overflow(d1, d2, &d1d2)) || + (multiply_overflow(n1, n2, &n1n2))) +#if WITH_GMP + { + mpq_set_si(sc->mpq_1, n1, d1); + mpq_set_si(sc->mpq_2, n2, d2); + mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_canonicalized_rational + (sc, sc->mpq_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "ratio * ratio overflow: (* %" ld64 + "/%" ld64 " %" ld64 "/%" ld64 ")\n", + n1, d1, n2, d2); + return (make_real(sc, fraction(x) * fraction(y))); + } +#endif + return (s7_make_ratio(sc, n1n2, d1d2)); + } +#else + return (s7_make_ratio(sc, n1 * n2, d1 * d2)); +#endif + } + case T_REAL: +#if WITH_GMP + if (numerator(x) > QUOTIENT_INT_LIMIT) { + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); + mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, fraction(x) * real(y))); + case T_COMPLEX: + return (s7_make_complex + (sc, fraction(x) * real_part(y), + fraction(x) * imag_part(y))); +#if WITH_GMP + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_set_z(sc->mpq_2, big_integer(y)); + mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpfr_mul_q(sc->mpfr_1, big_real(y), sc->mpq_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->multiply_symbol, x, y, a_number_string, + 2)); + } + + case T_REAL: + switch (type(y)) { + case T_INTEGER: +#if WITH_GMP + if (s7_int_abs(integer(y)) > QUOTIENT_INT_LIMIT) { + mpfr_set_si(sc->mpfr_1, integer(y), MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, real(x), MPFR_RNDN); + mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, real(x) * (long_double) integer(y))); + case T_RATIO: +#if WITH_GMP + if (numerator(y) > QUOTIENT_INT_LIMIT) { + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); + mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, fraction(y) * real(x))); + case T_REAL: + return (make_real(sc, real(x) * real(y))); + case T_COMPLEX: + return (make_complex + (sc, real(x) * real_part(y), real(x) * imag_part(y))); +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_mul_d(sc->mpfr_1, big_real(y), real(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); /* x might = 0.0 */ +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->multiply_symbol, x, y, a_number_string, + 2)); + } + + case T_COMPLEX: + switch (type(y)) { + case T_INTEGER: + return (make_complex + (sc, real_part(x) * integer(y), + imag_part(x) * integer(y))); + case T_RATIO: + return (s7_make_complex + (sc, real_part(x) * fraction(y), + imag_part(x) * fraction(y))); + case T_REAL: + return (make_complex + (sc, real_part(x) * real(y), imag_part(x) * real(y))); + case T_COMPLEX: + { + s7_double r1, r2, i1, i2; + r1 = real_part(x); + r2 = real_part(y); + i1 = imag_part(x); + i2 = imag_part(y); + return (make_complex + (sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1)); + } +#if WITH_GMP + case T_BIG_INTEGER: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->multiply_symbol, x, y, a_number_string, + 2)); + } + +#if WITH_GMP + case T_BIG_INTEGER: + switch (type(y)) { + case T_INTEGER: + mpz_mul_si(sc->mpz_1, big_integer(x), integer(y)); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_RATIO: + mpq_set_z(sc->mpq_2, big_integer(x)); + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_mul(sc->mpq_1, sc->mpq_2, sc->mpq_1); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpz_mul(sc->mpz_1, big_integer(x), big_integer(y)); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_mul_z(sc->mpfr_1, big_real(y), big_integer(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->multiply_symbol, x, y, a_number_string, + 2)); + } + + case T_BIG_RATIO: + switch (type(y)) { + case T_INTEGER: + mpq_set_si(sc->mpq_1, integer(y), 1); + mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpq_set_z(sc->mpq_1, big_integer(y)); + mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_mul(sc->mpq_1, big_ratio(x), big_ratio(y)); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_mul_q(sc->mpfr_1, big_real(y), big_ratio(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->multiply_symbol, x, y, a_number_string, + 2)); + } + + case T_BIG_REAL: + switch (type(y)) { + case T_INTEGER: + mpfr_mul_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpfr_mul_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + mpfr_mul_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpfr_mul_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_mul_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_mul(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_mul_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); /* 0.0? */ + default: + return (method_or_bust_with_type_pp + (sc, y, sc->multiply_symbol, x, y, a_number_string, + 2)); + } + case T_BIG_COMPLEX: + switch (type(y)) { + case T_INTEGER: + mpc_mul_si(sc->mpc_1, big_complex(x), integer(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_REAL: + /* if (is_NaN(real(y))) return(real_NaN); */ + mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); + mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); + mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); + mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_mul_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_mul(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->multiply_symbol, x, y, a_number_string, + 2)); + } +#endif + default: + return (method_or_bust_with_type_pp + (sc, x, sc->multiply_symbol, x, y, a_number_string, 1)); + } +} + +static s7_pointer multiply_p_ppp(s7_scheme * sc, s7_pointer x, + s7_pointer y, s7_pointer z) +{ + return (multiply_p_pp(sc, multiply_p_pp(sc, x, y), z)); +} + +static s7_pointer multiply_method_or_bust(s7_scheme * sc, s7_pointer obj, + s7_pointer caller, + s7_pointer args, s7_pointer typ, + int32_t num) +{ + if (has_active_methods(sc, obj)) + return (find_and_apply_method(sc, obj, sc->multiply_symbol, args)); + if (num == 0) + return (simple_wrong_type_argument_with_type + (sc, sc->multiply_symbol, obj, typ)); + return (wrong_type_argument_with_type + (sc, sc->multiply_symbol, num, obj, typ)); +} + +static s7_pointer g_multiply(s7_scheme * sc, s7_pointer args) +{ +#define H_multiply "(* ...) multiplies its arguments" +#define Q_multiply sc->pcl_n + + s7_pointer x, p; + if (is_null(args)) + return (int_one); + x = car(args); + p = cdr(args); + if (is_null(p)) { + if (!is_number(x)) + return (multiply_method_or_bust + (sc, x, sc->multiply_symbol, args, a_number_string, + 0)); + return (x); + } + if (is_null(cdr(p))) + return (multiply_p_pp(sc, x, car(p))); + for (; is_pair(p); p = cdr(p)) + x = multiply_p_pp(sc, x, car(p)); + return (x); +} + +static s7_pointer g_multiply_2(s7_scheme * sc, s7_pointer args) +{ + return (multiply_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_mul_xi(s7_scheme * sc, s7_pointer x, s7_int n) +{ + switch (type(x)) { + case T_INTEGER: + return (multiply_if_overflow_to_real_or_big_integer + (sc, integer(x), n)); + case T_RATIO: + return (integer_ratio_multiply_if_overflow_to_real_or_ratio + (sc, n, x)); + case T_REAL: + return (make_real(sc, real(x) * n)); + case T_COMPLEX: + return (s7_make_complex(sc, real_part(x) * n, imag_part(x) * n)); +#if WITH_GMP + case T_BIG_INTEGER: + mpz_mul_si(sc->mpz_1, big_integer(x), n); + return (mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + case T_BIG_REAL: + case T_BIG_COMPLEX: + return (multiply_p_pp(sc, x, wrap_integer1(sc, n))); +#endif + default: + /* we can get here from mul_2_xi for example so the non-integer argument might not be a symbol */ + return (method_or_bust_with_type_pi + (sc, x, sc->multiply_symbol, x, n, a_number_string)); + } + return (x); +} + +static s7_pointer g_mul_xf(s7_scheme * sc, s7_pointer x, s7_double y) +{ + switch (type(x)) { + case T_INTEGER: + return (make_real(sc, integer(x) * y)); + case T_RATIO: + return (make_real(sc, numerator(x) * y / denominator(x))); + case T_REAL: + return (make_real(sc, real(x) * y)); + case T_COMPLEX: + return (s7_make_complex(sc, real_part(x) * y, imag_part(x) * y)); +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_mul_d(sc->mpfr_1, big_real(x), y, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + mpc_mul_fr(sc->mpc_1, big_complex(x), sc->mpfr_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pf + (sc, x, sc->multiply_symbol, x, y, a_number_string)); + } + return (x); +} + +#if WITH_GMP +static s7_pointer g_mul_2_if(s7_scheme * sc, s7_pointer args) +{ + if ((is_t_integer(car(args))) && (is_t_real(cadr(args)))) + return (make_real(sc, integer(car(args)) * real(cadr(args)))); + return (multiply_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_mul_2_fi(s7_scheme * sc, s7_pointer args) +{ + if ((is_t_integer(cadr(args))) && (is_t_real(car(args)))) + return (make_real(sc, real(car(args)) * integer(cadr(args)))); + return (multiply_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_mul_2_xi(s7_scheme * sc, s7_pointer args) +{ + if (is_t_integer(cadr(args))) + return (g_mul_xi(sc, car(args), integer(cadr(args)))); + return (g_multiply(sc, args)); +} + +static s7_pointer g_mul_2_ix(s7_scheme * sc, s7_pointer args) +{ + if (is_t_integer(car(args))) + return (g_mul_xi(sc, cadr(args), integer(car(args)))); + return (g_multiply(sc, args)); +} + +static s7_pointer g_mul_2_xf(s7_scheme * sc, s7_pointer args) +{ + if (is_t_real(cadr(args))) + return (g_mul_xf(sc, car(args), real(cadr(args)))); + return (g_multiply(sc, args)); +} + +static s7_pointer g_mul_2_fx(s7_scheme * sc, s7_pointer args) +{ + if (is_t_real(car(args))) + return (g_mul_xf(sc, cadr(args), real(car(args)))); + return (g_multiply(sc, args)); +} + +static s7_pointer g_mul_2_ff(s7_scheme * sc, s7_pointer args) +{ + return (multiply_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_mul_2_ii(s7_scheme * sc, s7_pointer args) +{ + return (multiply_p_pp(sc, car(args), cadr(args))); +} +#else +static s7_pointer g_mul_2_if(s7_scheme * sc, s7_pointer args) +{ + return (make_real(sc, integer(car(args)) * real(cadr(args)))); +} + +static s7_pointer g_mul_2_fi(s7_scheme * sc, s7_pointer args) +{ + return (make_real(sc, real(car(args)) * integer(cadr(args)))); +} + +static s7_pointer g_mul_2_xi(s7_scheme * sc, s7_pointer args) +{ + return (g_mul_xi(sc, car(args), integer(cadr(args)))); +} + +static s7_pointer g_mul_2_ix(s7_scheme * sc, s7_pointer args) +{ + return (g_mul_xi(sc, cadr(args), integer(car(args)))); +} + +static s7_pointer g_mul_2_xf(s7_scheme * sc, s7_pointer args) +{ + return (g_mul_xf(sc, car(args), real(cadr(args)))); +} + +static s7_pointer g_mul_2_fx(s7_scheme * sc, s7_pointer args) +{ + return (g_mul_xf(sc, cadr(args), real(car(args)))); +} + +static s7_pointer g_mul_2_ff(s7_scheme * sc, s7_pointer args) +{ + return (make_real(sc, real(car(args)) * real(cadr(args)))); +} + +static s7_pointer g_mul_2_ii(s7_scheme * sc, s7_pointer args) +{ +#if HAVE_OVERFLOW_CHECKS + s7_int val, x = integer(car(args)), y = integer(cadr(args)); + if (multiply_overflow(x, y, &val)) { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", + x, y); + return (make_real(sc, (double) x * (double) y)); + } + return (make_integer(sc, val)); +#else + return (make_integer(sc, integer(car(args)) * integer(cadr(args)))); +#endif +} +#endif + +static s7_int multiply_i_ii(s7_int i1, s7_int i2) +{ +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if (multiply_overflow(i1, i2, &val)) { + if (WITH_WARNINGS) + s7_warn(cur_sc, 64, + "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", + i1, i2); + return (S7_INT64_MAX); /* this is inconsistent with other unopt cases where an overflow -> double result */ + } + /* (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (do ((j 0 (+ j 1))) ((= j 1)) (even? (* (ash 1 43) (ash 1 43)))))) (define (hi) (func)) (hi)) */ + return (val); +#else + return (i1 * i2); +#endif +} + +static s7_int multiply_i_iii(s7_int i1, s7_int i2, s7_int i3) +{ +#if HAVE_OVERFLOW_CHECKS + s7_int val1, val2; + if ((multiply_overflow(i1, i2, &val1)) || + (multiply_overflow(val1, i3, &val2))) { + if (WITH_WARNINGS) + s7_warn(cur_sc, 64, + "integer multiply overflow: (* %" ld64 " %" ld64 " %" + ld64 ")\n", i1, i2, i3); + return (S7_INT64_MAX); + } + return (val2); +#else + return (i1 * i2 * i3); +#endif +} + +static s7_double multiply_d_d(s7_double x) +{ + return (x); +} + +static s7_double multiply_d_dd(s7_double x1, s7_double x2) +{ + return (x1 * x2); +} + +static s7_double multiply_d_ddd(s7_double x1, s7_double x2, s7_double x3) +{ + return (x1 * x2 * x3); +} + +static s7_double multiply_d_dddd(s7_double x1, s7_double x2, s7_double x3, + s7_double x4) +{ + return (x1 * x2 * x3 * x4); +} + +static s7_pointer mul_p_dd(s7_scheme * sc, s7_double x1, s7_double x2) +{ + return (make_real(sc, x1 * x2)); +} + +static s7_pointer multiply_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if (args == 2) { + if (ops) + return (chooser_check_arg_types + (sc, cadr(expr), caddr(expr), sc->multiply_2, + sc->mul_2_ff, sc->mul_2_ii, sc->mul_2_if, + sc->mul_2_fi, sc->mul_2_xi, sc->mul_2_ix, + sc->mul_2_fx, sc->mul_2_xf)); + return (sc->multiply_2); + } + return (f); +} + + +/* ---------------------------------------- divide ---------------------------------------- */ + +static s7_pointer complex_invert(s7_scheme * sc, s7_pointer p) +{ + s7_double den, r2 = real_part(p), i2 = imag_part(p); + den = (r2 * r2 + i2 * i2); + /* here if p is, for example, -inf.0+i, den is +inf.0 so -i2/den is -0.0 (in gcc anyway), so the imag part is 0.0 */ + return (s7_make_complex(sc, r2 / den, -i2 / den)); +} + +static s7_pointer invert_p_p(s7_scheme * sc, s7_pointer p) +{ +#if WITH_GMP + s7_pointer x; +#endif + switch (type(p)) { + case T_INTEGER: +#if WITH_GMP && (!POINTER_32) + if (integer(p) == S7_INT64_MIN) { /* (/ 1 (*s7* 'most-negative-fixnum)) -> -1/9223372036854775808 */ + new_cell(sc, x, T_BIG_RATIO); + big_ratio_bgr(x) = alloc_bigrat(sc); + add_big_ratio(sc, x); + mpz_set_si(sc->mpz_1, S7_INT64_MAX); + mpz_set_si(sc->mpz_2, 1); + mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); + mpq_set_si(big_ratio(x), -1, 1); + mpq_set_den(big_ratio(x), sc->mpz_1); /* geez... */ + return (x); + } +#endif + if (integer(p) == 0) + return (division_by_zero_error(sc, sc->divide_symbol, p)); + return (make_simple_ratio(sc, 1, integer(p))); /* this checks for int */ + case T_RATIO: + return (make_simple_ratio(sc, denominator(p), numerator(p))); + case T_REAL: + if (real(p) == 0.0) + return (division_by_zero_error(sc, sc->divide_symbol, p)); + return (make_real(sc, 1.0 / real(p))); + case T_COMPLEX: + return (complex_invert(sc, p)); + +#if WITH_GMP + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(p), 0) == 0) + return (division_by_zero_error(sc, sc->divide_symbol, p)); + if ((mpz_cmp_ui(big_integer(p), 1) == 0) + || (mpz_cmp_si(big_integer(p), -1) == 0)) + return (p); + new_cell(sc, x, T_BIG_RATIO); + big_ratio_bgr(x) = alloc_bigrat(sc); + add_big_ratio(sc, x); + mpq_set_si(big_ratio(x), 1, 1); + mpq_set_den(big_ratio(x), big_integer(p)); + mpq_canonicalize(big_ratio(x)); + return (x); + + case T_BIG_RATIO: + if (mpz_cmp_ui(mpq_numref(big_ratio(p)), 1) == 0) + return (mpz_to_integer(sc, mpq_denref(big_ratio(p)))); + if (mpz_cmp_si(mpq_numref(big_ratio(p)), -1) == 0) { + mpz_neg(sc->mpz_1, mpq_denref(big_ratio(p))); + return (mpz_to_integer(sc, sc->mpz_1)); + } + new_cell(sc, x, T_BIG_RATIO); + big_ratio_bgr(x) = alloc_bigrat(sc); + add_big_ratio(sc, x); + mpq_inv(big_ratio(x), big_ratio(p)); + mpq_canonicalize(big_ratio(x)); + return (x); + + case T_BIG_REAL: + if (mpfr_zero_p(big_real(p))) + return (division_by_zero_error(sc, sc->divide_symbol, p)); + x = mpfr_to_big_real(sc, big_real(p)); + mpfr_ui_div(big_real(x), 1, big_real(x), MPFR_RNDN); + return (x); + + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(p)))) + || (!mpfr_number_p(mpc_imagref(big_complex(p))))) + return (complex_NaN); + mpc_ui_div(sc->mpc_1, 1, big_complex(p), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); /* x might be 0+0i if real-part is inf? */ +#endif + default: + check_method(sc, p, sc->divide_symbol, set_plist_1(sc, p)); + return (wrong_type_argument_with_type + (sc, sc->divide_symbol, 1, p, a_number_string)); + } +} + +static s7_pointer divide_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + /* splitting out real/real here saves very little */ + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + /* -------- integer x -------- */ + case T_INTEGER: + if (integer(y) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + if (integer(x) == 1) /* mainly to handle (/ 1 -9223372036854775808) correctly! */ + return (invert_p_p(sc, y)); + return (make_ratio(sc, integer(x), integer(y))); + + case T_RATIO: +#if HAVE_OVERFLOW_CHECKS + { + s7_int dn; + if (multiply_overflow(integer(x), denominator(y), &dn)) +#if WITH_GMP + { + mpq_set_si(sc->mpq_1, integer(x), 1); + mpq_set_si(sc->mpq_2, numerator(y), denominator(y)); + mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "integer / ratio overflow: (/ %" ld64 " %" + ld64 "/%" ld64 ")\n", integer(x), + numerator(y), denominator(y)); + return (make_real + (sc, integer(x) * inverted_fraction(y))); + } +#endif + return (s7_make_ratio(sc, dn, numerator(y))); + } +#else + return (s7_make_ratio + (sc, integer(x) * denominator(y), numerator(y))); +#endif + + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + if (is_inf(real(y))) + return (real_zero); + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); +#if WITH_GMP + if ((s7_int_abs(integer(x))) > QUOTIENT_INT_LIMIT) { + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); + mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return (make_real(sc, (s7_double) (integer(x)) / real(y))); + + case T_COMPLEX: + { + s7_double den, r1 = (s7_double) integer(x), r2 = + real_part(y), i2 = imag_part(y); + den = 1.0 / (r2 * r2 + i2 * i2); + /* we could avoid the squaring (see Knuth II p613 16), not a big deal: (/ 1.0e308+1.0e308i 2.0e308+2.0e308i) => nan, (gmp case is ok here) */ + return (s7_make_complex + (sc, r1 * r2 * den, -(r1 * i2 * den))); + } + +#if WITH_GMP + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpq_set_si(sc->mpq_1, integer(x), 1); + mpq_set_den(sc->mpq_1, big_integer(y)); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, integer(x), 1); + mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpfr_si_div(sc->mpfr_1, integer(x), big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) + || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return (complex_NaN); + mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); /* x might be 0? */ +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } + break; + + /* -------- ratio x -------- */ + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + if (integer(y) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); +#if HAVE_OVERFLOW_CHECKS + { + s7_int dn; + if (multiply_overflow(denominator(x), integer(y), &dn)) +#if WITH_GMP + { + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_set_si(sc->mpq_2, integer(y), 1); + mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_rational(sc, sc->mpq_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "ratio / integer overflow: (/ %" ld64 "/%" + ld64 " %" ld64 ")\n", numerator(x), + denominator(x), integer(y)); + return (make_real + (sc, + (long_double) numerator(x) / + ((long_double) denominator(x) * + (long_double) integer(y)))); + } +#endif + return (s7_make_ratio(sc, numerator(x), dn)); + } +#else + return (s7_make_ratio + (sc, numerator(x), denominator(x) * integer(y))); +#endif + + case T_RATIO: + { + s7_int d1, d2, n1, n2; + parcel_out_fractions(x, y); + if (d1 == d2) + return (s7_make_ratio(sc, n1, n2)); +#if HAVE_OVERFLOW_CHECKS + if ((multiply_overflow(n1, d2, &n1)) || + (multiply_overflow(n2, d1, &d1))) { +#if WITH_GMP + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); /* not n1 and d1! they are garbage here */ + mpq_set_si(sc->mpq_2, n2, d2); + mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_rational(sc, sc->mpq_1)); +#else + s7_double r1, r2; + if (WITH_WARNINGS) + s7_warn(sc, 128, + "ratio / ratio overflow: (/ %" ld64 "/%" + ld64 " %" ld64 "/%" ld64 ")\n", + numerator(x), denominator(x), numerator(y), + denominator(y)); + r1 = fraction(x); + r2 = inverted_fraction(y); + return (make_real(sc, r1 * r2)); +#endif + } + return (s7_make_ratio(sc, n1, d1)); +#else + return (s7_make_ratio(sc, n1 * d2, n2 * d1)); +#endif + } + + case T_REAL: + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + return (make_real(sc, fraction(x) / real(y))); + + case T_COMPLEX: + { + s7_double den, rx = fraction(x), r2 = real_part(y), i2 = + imag_part(y); + den = 1.0 / (r2 * r2 + i2 * i2); + return (s7_make_complex(sc, rx * r2 * den, -rx * i2 * den)); /* not unchecked: (/ 3/4 -inf.0+i) */ + } + +#if WITH_GMP + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpq_set_z(sc->mpq_1, big_integer(y)); + mpq_set_si(sc->mpq_2, numerator(x), denominator(x)); + mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); + mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) + || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return (complex_NaN); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } + + /* -------- real x -------- */ + case T_REAL: + switch (type(y)) { + case T_INTEGER: + if (integer(y) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + if (is_NaN(real(x))) + return (real_NaN); /* what is (/ +nan.0 0)? */ + if (is_inf(real(x))) + return ((real(x) > + 0.0) ? ((integer(y) > + 0) ? real_infinity : real_minus_infinity) + : ((integer(y) > + 0) ? real_minus_infinity : real_infinity)); + return (make_real + (sc, + (long_double) real(x) / (long_double) integer(y))); + + case T_RATIO: + if (is_NaN(real(x))) + return (real_NaN); + if (is_inf(real(x))) + return ((real(x) > + 0) ? ((numerator(y) > + 0) ? real_infinity : real_minus_infinity) + : ((numerator(y) > + 0) ? real_minus_infinity : real_infinity)); + return (make_real(sc, real(x) * inverted_fraction(y))); + + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + if (is_NaN(real(x))) + return (real_NaN); + if (is_inf(real(y))) + return ((is_inf(real(x))) ? real_NaN : real_zero); + return (make_real(sc, real(x) / real(y))); + + case T_COMPLEX: + { + s7_double den, r2, i2; + if (is_NaN(real(x))) + return (complex_NaN); + r2 = real_part(y); + i2 = imag_part(y); + if ((is_NaN(r2)) || (is_inf(r2))) + return (complex_NaN); + if ((is_NaN(i2)) || (is_inf(i2))) + return (complex_NaN); + den = 1.0 / (r2 * r2 + i2 * i2); + return (s7_make_complex + (sc, real(x) * r2 * den, -real(x) * i2 * den)); + } + +#if WITH_GMP + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); + mpfr_d_div(sc->mpfr_1, real(x), sc->mpfr_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_div_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpfr_d_div(sc->mpfr_1, real(x), big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + if ((is_NaN(real(x))) + || (!mpfr_number_p(mpc_realref(big_complex(y)))) + || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return (complex_NaN); + mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } + + /* -------- complex x -------- */ + case T_COMPLEX: + switch (type(y)) { + case T_INTEGER: + { + s7_double r1; + if (integer(y) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, + set_elist_2(sc, x, y))); + r1 = (long_double) 1.0 / (long_double) integer(y); + return (s7_make_complex + (sc, real_part(x) * r1, imag_part(x) * r1)); + } + + case T_RATIO: + { + s7_double frac = inverted_fraction(y); + return (make_complex + (sc, real_part(x) * frac, imag_part(x) * frac)); + } + + case T_REAL: + { + s7_double r1; + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->divide_symbol, + set_elist_2(sc, x, y))); + r1 = 1.0 / real(y); + return (make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); /* (/ 0.0+1.0i +inf.0) */ + } + + case T_COMPLEX: + { + s7_double r1, r2, i1, i2, den; + r1 = real_part(x); + if (is_NaN(r1)) + return (real_NaN); + i1 = imag_part(x); + if (is_NaN(i1)) + return (real_NaN); + r2 = real_part(y); + if (is_NaN(r2)) + return (real_NaN); + if (is_inf(r2)) + return (complex_NaN); + i2 = imag_part(y); + if (is_NaN(i2)) + return (real_NaN); + den = 1.0 / (r2 * r2 + i2 * i2); + return (s7_make_complex + (sc, (r1 * r2 + i1 * i2) * den, + (r2 * i1 - r1 * i2) * den)); + } + +#if WITH_GMP + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_div_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) + || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return (complex_NaN); + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } + +#if WITH_GMP + case T_BIG_INTEGER: + switch (type(y)) { + case T_INTEGER: + if (integer(y) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpz_set_si(sc->mpz_1, integer(y)); + mpq_set_num(sc->mpq_1, big_integer(x)); + mpq_set_den(sc->mpq_1, sc->mpz_1); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_RATIO: + mpq_set_z(sc->mpq_2, big_integer(x)); + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); /* can't invert here, mpq den=unsigned */ + mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || + (is_inf(real_part(y))) || (is_inf(imag_part(y)))) + return (complex_NaN); + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpq_set_num(sc->mpq_1, big_integer(x)); + mpq_set_den(sc->mpq_1, big_integer(y)); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, 0, 1); + mpq_set_num(sc->mpq_1, big_integer(x)); + mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) + || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return (complex_NaN); + mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } + case T_BIG_RATIO: + switch (type(y)) { + case T_INTEGER: + if (integer(y) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpq_set_si(sc->mpq_1, integer(y), 1); + mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); + return (mpq_to_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || + (is_inf(real_part(y))) || (is_inf(imag_part(y)))) + return (complex_NaN); + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpq_set_z(sc->mpq_1, big_integer(y)); + mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_div(sc->mpq_1, big_ratio(x), big_ratio(y)); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) + || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return (complex_NaN); + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } + case T_BIG_REAL: + switch (type(y)) { + case T_INTEGER: + if (integer(y) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpfr_div_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpfr_div_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_REAL: + if (is_NaN(real(y))) + return (real_NaN); + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpfr_div_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || + (is_inf(real_part(y))) || (is_inf(imag_part(y)))) + return (complex_NaN); + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_fr_div(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpfr_div_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_div_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpfr_div(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) + || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return (complex_NaN); + mpc_fr_div(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } + case T_BIG_COMPLEX: + switch (type(y)) { + case T_INTEGER: + if (integer(y) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_REAL: + /* if (is_NaN(real(y))) return(real_NaN); */ + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_COMPLEX: + if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || + (is_inf(real_part(y))) || (is_inf(imag_part(y)))) + return (complex_NaN); + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + return (division_by_zero_error + (sc, sc->divide_symbol, set_elist_2(sc, x, y))); + mpc_div_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) + || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return (complex_NaN); + mpc_div(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); + default: + return (method_or_bust_with_type_pp + (sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } +#endif + + default: /* x is not a built-in number */ + return (method_or_bust_with_type_pp(sc, x, sc->divide_symbol, x, y, a_number_string, 1)); /* not args here! y = apply * to cdr(args) */ + } + return (NULL); /* make the compiler happy */ +} + +static s7_pointer g_divide(s7_scheme * sc, s7_pointer args) +{ +#define H_divide "(/ x1 ...) divides its first argument by the rest, or inverts the first if there is only one argument" +#define Q_divide sc->pcl_n + + s7_pointer x = car(args), y, p = cdr(args); + if (is_null(p)) { /* (/ x) */ + if (!is_number(x)) + return (method_or_bust_with_type_one_arg + (sc, x, sc->divide_symbol, args, a_number_string)); + return (invert_p_p(sc, x)); + } + if (is_null(cdr(p))) + return (divide_p_pp(sc, x, cadr(args))); + y = g_multiply(sc, p); /* in some schemes (/ 1 0 +nan.0) is not equal to (/ 1 (* 0 +nan.0)), in s7 they're both +nan.0 */ + return (divide_p_pp(sc, x, y)); +} + +static s7_pointer g_invert_1(s7_scheme * sc, s7_pointer args) +{ + return (invert_p_p(sc, car(args))); +} + +static s7_pointer g_divide_2(s7_scheme * sc, s7_pointer args) +{ + return (divide_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_divide_by_2(s7_scheme * sc, s7_pointer args) +{ + /* (/ x 2) */ + s7_pointer num = car(args); + if (is_t_integer(num)) { + s7_int i = integer(num); + if (i & 1) { + s7_pointer x; + new_cell(sc, x, T_RATIO); + numerator(x) = i; + denominator(x) = 2; + return (x); + } + return (make_integer(sc, i >> 1)); + } + switch (type(num)) { + case T_RATIO: +#if HAVE_OVERFLOW_CHECKS + { + s7_int dn; + if (multiply_overflow(denominator(num), 2, &dn)) { + if ((numerator(num) & 1) == 1) +#if WITH_GMP + { + mpq_set_si(sc->mpq_1, numerator(num), + denominator(num)); + mpq_set_si(sc->mpq_2, 1, 2); + mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_rational(sc, sc->mpq_1)); + } +#else + { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "ratio / 2 overflow: (/ %" ld64 "/%" ld64 + " 2)\n", numerator(num), denominator(num)); + return (make_real + (sc, + ((long_double) numerator(num) * 0.5) / + (long_double) denominator(num))); + } +#endif + return (make_ratio + (sc, numerator(num) / 2, denominator(num))); + } + return (s7_make_ratio(sc, numerator(num), dn)); + } +#else + return (make_ratio(sc, numerator(num), denominator(num) * 2)); +#endif + + case T_REAL: + return (make_real(sc, real(num) * 0.5)); + case T_COMPLEX: + return (make_complex_not_0i + (sc, real_part(num) * 0.5, imag_part(num) * 0.5)); + +#if WITH_GMP + case T_BIG_INTEGER: + mpq_set_z(sc->mpq_1, big_integer(num)); + mpz_mul_ui(mpq_denref(sc->mpq_1), mpq_denref(sc->mpq_1), 2); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, 2, 1); + mpq_div(sc->mpq_1, big_ratio(num), sc->mpq_1); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_div_si(sc->mpfr_1, big_real(num), 2, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_si(sc->mpc_1, 2, MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(num), sc->mpc_1, MPC_RNDNN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, num, sc->divide_symbol, num, int_two, a_number_string, + 1)); + } +} + +static s7_pointer g_invert_x(s7_scheme * sc, s7_pointer args) +{ + /* (/ 1.0 x) */ + if (is_t_real(cadr(args))) { + s7_double rl = real(cadr(args)); + if (rl == 0.0) + return (division_by_zero_error(sc, sc->divide_symbol, args)); + return ((is_NaN(rl)) ? real_NaN : make_real(sc, 1.0 / rl)); + } + return (g_divide(sc, args)); +} + +static s7_double divide_d_7d(s7_scheme * sc, s7_double x) +{ + if (x == 0.0) + division_by_zero_error(sc, sc->divide_symbol, + set_elist_1(sc, real_zero)); + return (1.0 / x); +} + +static s7_double divide_d_7dd(s7_scheme * sc, s7_double x1, s7_double x2) +{ + if (x2 == 0.0) + division_by_zero_error(sc, sc->divide_symbol, + set_elist_1(sc, real_zero)); + return (x1 / x2); +} + +static s7_pointer divide_p_ii(s7_scheme * sc, s7_int x, s7_int y) +{ + return (s7_make_ratio(sc, x, y)); +} /* s7_make-ratio checks for y==0 */ + +static s7_pointer divide_p_i(s7_scheme * sc, s7_int x) +{ + return (s7_make_ratio(sc, 1, x)); +} + +static s7_pointer divide_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if (args == 1) + return (sc->invert_1); + if ((ops) && (args == 2)) { + s7_pointer arg1 = cadr(expr); + if ((is_t_real(arg1)) && (real(arg1) == 1.0)) + return (sc->invert_x); + return (((is_t_integer(caddr(expr))) + && (integer(caddr(expr)) == + 2)) ? sc->divide_by_2 : sc->divide_2); + } + return (f); +} + + +/* -------------------------------- quotient -------------------------------- */ +static inline s7_int quotient_i_7ii(s7_scheme * sc, s7_int x, s7_int y) +{ + if ((y > 0) || (y < -1)) + return (x / y); + if (y == 0) + division_by_zero_error(sc, sc->quotient_symbol, + set_elist_2(sc, wrap_integer1(sc, x), + wrap_integer2(sc, y))); + if ((y == -1) && (x == S7_INT64_MIN)) /* (quotient most-negative-fixnum -1) */ + simple_out_of_range(sc, sc->quotient_symbol, + set_elist_2(sc, wrap_integer1(sc, x), + wrap_integer2(sc, y)), + its_too_large_string); + return (x / y); +} + +#if (!WITH_GMP) +static s7_pointer s7_truncate(s7_scheme * sc, s7_pointer caller, + s7_double xf) +{ /* can't use "truncate" -- it's in unistd.h */ + if (fabs(xf) > QUOTIENT_FLOAT_LIMIT) + return (simple_out_of_range + (sc, caller, wrap_real1(sc, xf), its_too_large_string)); + return ((xf > 0.0) ? make_integer(sc, + (s7_int) floor(xf)) : + make_integer(sc, (s7_int) ceil(xf))); +} + +static s7_int c_quo_dbl(s7_scheme * sc, s7_double x, s7_double y) +{ + s7_double xf; + if (y == 0.0) + division_by_zero_error(sc, sc->quotient_symbol, + set_elist_2(sc, wrap_real1(sc, x), + wrap_real2(sc, y))); + if ((is_inf(y)) || (is_NaN(y))) /* here we can't return NAN so I guess we should signal an error */ + wrong_type_argument_with_type(sc, sc->quotient_symbol, 2, + wrap_real1(sc, y), + a_normal_real_string); + xf = x / y; + if (fabs(xf) > QUOTIENT_FLOAT_LIMIT) + simple_out_of_range(sc, sc->quotient_symbol, wrap_real1(sc, xf), + its_too_large_string); + return ((xf > 0.0) ? (s7_int) floor(xf) : (s7_int) ceil(xf)); +} +#endif + +static s7_int quotient_i_ii_unchecked(s7_int i1, s7_int i2) +{ + return (i1 / i2); +} /* i2 > 0 */ + +static s7_pointer quotient_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ +#if WITH_GMP + if ((is_real(x)) && (is_real(y))) { + if (is_zero(sc, y)) + division_by_zero_error(sc, sc->quotient_symbol, + set_elist_2(sc, x, y)); + if ((s7_is_integer(x)) && (s7_is_integer(y))) { + if (is_t_integer(x)) + mpz_set_si(sc->mpz_1, integer(x)); + else + mpz_set(sc->mpz_1, big_integer(x)); + if (is_t_integer(y)) + mpz_set_si(sc->mpz_2, integer(y)); + else + mpz_set(sc->mpz_2, big_integer(y)); + mpz_tdiv_q(sc->mpz_1, sc->mpz_1, sc->mpz_2); + } else if ((!is_rational(x)) || (!is_rational(y))) { + if (any_real_to_mpfr(sc, x, sc->mpfr_1)) + return (real_NaN); + if (any_real_to_mpfr(sc, y, sc->mpfr_2)) + return (real_NaN); + mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ); + } else { + any_rational_to_mpq(sc, x, sc->mpq_1); + any_rational_to_mpq(sc, y, sc->mpq_2); + mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2); + mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), + mpq_denref(sc->mpq_3)); + } + return (mpz_to_integer(sc, sc->mpz_1)); + } + return (method_or_bust_pp + (sc, (is_real(x)) ? y : x, sc->quotient_symbol, x, y, T_REAL, + (is_real(x)) ? 2 : 1)); +#else + + s7_int d1, d2, n1, n2; + if ((is_t_integer(x)) && (is_t_integer(y))) + return (make_integer + (sc, quotient_i_7ii(sc, integer(x), integer(y)))); + + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_INTEGER: + return (make_integer + (sc, quotient_i_7ii(sc, integer(x), integer(y)))); + + case T_RATIO: + n1 = integer(x); + d1 = 1; + n2 = numerator(y); + d2 = denominator(y); + /* (quotient -9223372036854775808 -1/9223372036854775807): arithmetic exception in the no-overflow-checks case */ + goto RATIO_QUO_RATIO; + + case T_REAL: + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->quotient_symbol, set_elist_2(sc, x, y))); + if ((is_inf(real(y))) || (is_NaN(real(y)))) + return (real_NaN); + return (s7_truncate(sc, sc->quotient_symbol, (s7_double) integer(x) / real(y))); /* s7_truncate returns an integer */ + + default: + return (method_or_bust_pp + (sc, y, sc->quotient_symbol, x, y, T_REAL, 2)); + } + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + if (integer(y) == 0) + return (division_by_zero_error + (sc, sc->quotient_symbol, set_elist_2(sc, x, y))); + n1 = numerator(x); + d1 = denominator(x); + n2 = integer(y); + d2 = 1; + goto RATIO_QUO_RATIO; + /* this can lose: + * (quotient 1 2305843009213693952/4611686018427387903) -> 2, not 1 + * (quotient 21053343141/6701487259 3587785776203/1142027682075) -> 1, not 0 + */ + + case T_RATIO: + parcel_out_fractions(x, y); + RATIO_QUO_RATIO: + if (d1 == d2) + return (make_integer(sc, n1 / n2)); /* (quotient 3/9223372036854775807 1/9223372036854775807) */ + if (n1 == n2) + return (make_integer(sc, d2 / d1)); /* (quotient 9223372036854775807/2 9223372036854775807/8) */ +#if HAVE_OVERFLOW_CHECKS + { + s7_int n1d2, n2d1; + if ((multiply_overflow(n1, d2, &n1d2)) || + (multiply_overflow(n2, d1, &n2d1))) + return (s7_truncate + (sc, sc->quotient_symbol, + ((long_double) n1 / (long_double) n2) * + ((long_double) d2 / (long_double) d1))); + return (make_integer(sc, n1d2 / n2d1)); + } +#else + return (make_integer(sc, (n1 * d2) / (n2 * d1))); +#endif + + case T_REAL: + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->quotient_symbol, set_elist_2(sc, x, y))); + if ((is_inf(real(y))) || (is_NaN(real(y)))) + return (real_NaN); + return (s7_truncate + (sc, sc->quotient_symbol, + (s7_double) fraction(x) / real(y))); + + default: + return (method_or_bust_pp + (sc, y, sc->quotient_symbol, x, y, T_REAL, 2)); + } + + case T_REAL: + if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y))) + return (real_NaN); + /* if infs allowed we need to return infs/nans, else: + * (quotient inf.0 1e-309) -> -9223372036854775808 + * (quotient inf.0 inf.0) -> -9223372036854775808 + */ + + switch (type(y)) { + case T_INTEGER: + if (integer(y) == 0) + return (division_by_zero_error + (sc, sc->quotient_symbol, set_elist_2(sc, x, y))); + return (s7_truncate + (sc, sc->quotient_symbol, + (long_double) real(x) / (long_double) integer(y))); + + case T_RATIO: + return (s7_truncate + (sc, sc->quotient_symbol, + real(x) / (s7_double) fraction(y))); + case T_REAL: + return (make_integer(sc, c_quo_dbl(sc, real(x), real(y)))); /* c_quo_dbl returns an integer */ + default: + return (method_or_bust_pp + (sc, y, sc->quotient_symbol, x, y, T_REAL, 2)); + } + + default: + return (method_or_bust_pp + (sc, x, sc->quotient_symbol, x, y, T_REAL, 2)); + } +#endif +} + +static s7_pointer g_quotient(s7_scheme * sc, s7_pointer args) +{ +#define H_quotient "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 3) = 1" +#define Q_quotient sc->pcl_r + /* sig was '(integer? ...) but quotient can return NaN */ + /* (define (quo x1 x2) (truncate (/ x1 x2))) ; slib */ + return (quotient_p_pp(sc, car(args), cadr(args))); +} + + +/* -------------------------------- remainder -------------------------------- */ +#if WITH_GMP +static s7_pointer big_mod_or_rem(s7_scheme * sc, s7_pointer x, + s7_pointer y, bool use_floor) +{ + if ((is_real(x)) && (is_real(y))) { + if ((s7_is_integer(x)) && (s7_is_integer(y))) { + if (is_t_integer(x)) + mpz_set_si(sc->mpz_1, integer(x)); + else + mpz_set(sc->mpz_1, big_integer(x)); + if (is_t_integer(y)) + mpz_set_si(sc->mpz_2, integer(y)); + else + mpz_set(sc->mpz_2, big_integer(y)); + if (use_floor) + mpz_fdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2); + else + mpz_tdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2); + mpz_mul(sc->mpz_3, sc->mpz_3, sc->mpz_2); + mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_3); + return (mpz_to_integer(sc, sc->mpz_1)); + } + if ((!is_rational(x)) || (!is_rational(y))) { + any_real_to_mpfr(sc, x, sc->mpfr_1); + any_real_to_mpfr(sc, y, sc->mpfr_2); + mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + if (use_floor) + mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDD); + else + mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ); + mpfr_mul_z(sc->mpfr_2, sc->mpfr_2, sc->mpz_1, MPFR_RNDN); + mpfr_sub(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + } + any_rational_to_mpq(sc, x, sc->mpq_1); + any_rational_to_mpq(sc, y, sc->mpq_2); + mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2); + if (use_floor) + mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), + mpq_denref(sc->mpq_3)); + else + mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), + mpq_denref(sc->mpq_3)); + mpz_mul(mpq_numref(sc->mpq_2), sc->mpz_1, mpq_numref(sc->mpq_2)); + mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return (mpq_to_canonicalized_rational(sc, sc->mpq_1)); + } + return (method_or_bust_pp + (sc, (is_real(x)) ? y : x, + (use_floor) ? sc->modulo_symbol : sc->remainder_symbol, x, y, + T_REAL, (is_real(x)) ? 2 : 1)); +} +#endif + +#define REMAINDER_FLOAT_LIMIT 1e13 + +static inline s7_int remainder_i_7ii(s7_scheme * sc, s7_int x, s7_int y) +{ + if ((y > 1) || (y < -1)) + return (x % y); + if (y == 0) + division_by_zero_error(sc, sc->remainder_symbol, + set_elist_2(sc, wrap_integer1(sc, x), + wrap_integer2(sc, y))); + return (0); +} + +static s7_double c_rem_dbl(s7_scheme * sc, s7_double x, s7_double y) +{ + s7_int quo; + s7_double pre_quo; + if ((is_inf(y)) || (is_NaN(y))) + return (NAN); + pre_quo = x / y; + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + simple_out_of_range(sc, sc->remainder_symbol, + set_elist_2(sc, wrap_real1(sc, x), + wrap_real2(sc, y)), + its_too_large_string); + quo = + (pre_quo > 0.0) ? (s7_int) floor(pre_quo) : (s7_int) ceil(pre_quo); + return (x - (y * quo)); +} + +static s7_int remainder_i_ii_unchecked(s7_int i1, s7_int i2) +{ + return (i1 % i2); +} /* i2 > 1 */ + +static s7_double remainder_d_7dd(s7_scheme * sc, s7_double x1, + s7_double x2) +{ + if (x2 == 0.0) + division_by_zero_error(sc, sc->remainder_symbol, + set_elist_2(sc, wrap_real1(sc, x1), + wrap_real2(sc, x2))); + if ((is_inf(x1)) || (is_NaN(x1))) /* match remainder_p_pp */ + return (NAN); + return (c_rem_dbl(sc, x1, x2)); +} + +static s7_pointer remainder_p_pp(s7_scheme * sc, s7_pointer x, + s7_pointer y) +{ +#if WITH_GMP + if (is_zero(sc, y)) + division_by_zero_error(sc, sc->remainder_symbol, + set_elist_2(sc, x, y)); + return (big_mod_or_rem(sc, x, y, false)); +#else + s7_int quo, d1, d2, n1, n2; + s7_double pre_quo; + + if ((is_t_integer(x)) && (is_t_integer(y))) + return (make_integer + (sc, remainder_i_7ii(sc, integer(x), integer(y)))); + + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_INTEGER: + return (make_integer + (sc, remainder_i_7ii(sc, integer(x), integer(y)))); + + case T_RATIO: + n1 = integer(x); + d1 = 1; + n2 = numerator(y); + d2 = denominator(y); + goto RATIO_REM_RATIO; + + case T_REAL: + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->remainder_symbol, set_elist_2(sc, x, y))); + if ((is_inf(real(y))) || (is_NaN(real(y)))) + return (real_NaN); + pre_quo = (long_double) integer(x) / (long_double) real(y); + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + return (simple_out_of_range + (sc, sc->remainder_symbol, set_elist_2(sc, x, y), + its_too_large_string)); + if (pre_quo > 0.0) + quo = (s7_int) floor(pre_quo); + else + quo = (s7_int) ceil(pre_quo); + return (make_real(sc, integer(x) - real(y) * quo)); + + default: + return (method_or_bust_pp + (sc, y, sc->remainder_symbol, x, y, T_REAL, 2)); + } + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + n2 = integer(y); + if (n2 == 0) + return (division_by_zero_error + (sc, sc->remainder_symbol, set_elist_2(sc, x, y))); + n1 = numerator(x); + d1 = denominator(x); + d2 = 1; + goto RATIO_REM_RATIO; + + case T_RATIO: + parcel_out_fractions(x, y); + RATIO_REM_RATIO: + if (d1 == d2) + quo = (s7_int) (n1 / n2); + else { + if (n1 == n2) + quo = (s7_int) (d2 / d1); + else { +#if HAVE_OVERFLOW_CHECKS + s7_int n1d2, n2d1; + if ((multiply_overflow(n1, d2, &n1d2)) || + (multiply_overflow(n2, d1, &n2d1))) { + pre_quo = + ((long_double) n1 / (long_double) n2) * + ((long_double) d2 / (long_double) d1); + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + return (simple_out_of_range + (sc, sc->remainder_symbol, + set_elist_2(sc, x, y), + its_too_large_string)); + if (pre_quo > 0.0) + quo = (s7_int) floor(pre_quo); + else + quo = (s7_int) ceil(pre_quo); + } else + quo = n1d2 / n2d1; +#else + quo = (n1 * d2) / (n2 * d1); +#endif + } + } + if (quo == 0) + return (x); + +#if HAVE_OVERFLOW_CHECKS + { + s7_int dn, nq; + if (!multiply_overflow(n2, quo, &nq)) { + if ((d1 == d2) && (!subtract_overflow(n1, nq, &dn))) + return (s7_make_ratio(sc, dn, d1)); + + if ((!multiply_overflow(n1, d2, &dn)) && + (!multiply_overflow(nq, d1, &nq)) && + (!subtract_overflow(dn, nq, &nq)) && + (!multiply_overflow(d1, d2, &d1))) + return (s7_make_ratio(sc, nq, d1)); + } + } +#else + if (d1 == d2) + return (s7_make_ratio(sc, n1 - n2 * quo, d1)); + + return (s7_make_ratio(sc, n1 * d2 - n2 * d1 * quo, d1 * d2)); +#endif + return (simple_out_of_range + (sc, sc->remainder_symbol, set_elist_2(sc, x, y), + intermediate_too_large_string)); + + case T_REAL: + { + s7_double frac; + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->remainder_symbol, + set_elist_2(sc, x, y))); + if ((is_inf(real(y))) || (is_NaN(real(y)))) + return (real_NaN); + if (s7_int_abs(numerator(x)) > QUOTIENT_INT_LIMIT) + return (subtract_p_pp + (sc, x, + multiply_p_pp(sc, y, + quotient_p_pp(sc, x, y)))); + frac = (s7_double) fraction(x); + pre_quo = frac / real(y); + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + return (simple_out_of_range + (sc, sc->remainder_symbol, + set_elist_2(sc, x, y), its_too_large_string)); + if (pre_quo > 0.0) + quo = (s7_int) floor(pre_quo); + else + quo = (s7_int) ceil(pre_quo); + return (make_real(sc, frac - real(y) * quo)); + } + + default: + return (method_or_bust_pp + (sc, y, sc->remainder_symbol, x, y, T_REAL, 2)); + } + + case T_REAL: + if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y))) { + if (is_zero(sc, y)) + return (division_by_zero_error + (sc, sc->remainder_symbol, set_elist_2(sc, x, y))); + return (real_NaN); + } + switch (type(y)) { + case T_INTEGER: + if (integer(y) == 0) + return (division_by_zero_error + (sc, sc->remainder_symbol, set_elist_2(sc, x, y))); + /* actually here (and elsewhere) if y > INT64_TO_DOUBLE_LIMIT, the result is probably wrong */ + pre_quo = (long_double) real(x) / (long_double) integer(y); + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + return (simple_out_of_range + (sc, sc->remainder_symbol, set_elist_2(sc, x, y), + its_too_large_string)); + if (pre_quo > 0.0) + quo = (s7_int) floor(pre_quo); + else + quo = (s7_int) ceil(pre_quo); + return (make_real(sc, real(x) - integer(y) * quo)); + /* but... (remainder 1e+18 9223372036854775807) -> 1e+18 */ + + case T_RATIO: + if (s7_int_abs(numerator(y)) > QUOTIENT_INT_LIMIT) + return (subtract_p_pp + (sc, x, + multiply_p_pp(sc, y, quotient_p_pp(sc, x, y)))); + { + s7_double frac; + frac = (s7_double) fraction(y); + pre_quo = real(x) / frac; + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + return (simple_out_of_range + (sc, sc->remainder_symbol, + set_elist_2(sc, x, y), its_too_large_string)); + if (pre_quo > 0.0) + quo = (s7_int) floor(pre_quo); + else + quo = (s7_int) ceil(pre_quo); + return (make_real(sc, real(x) - frac * quo)); + } + + case T_REAL: + if (real(y) == 0.0) + return (division_by_zero_error + (sc, sc->remainder_symbol, set_elist_2(sc, x, y))); + return (make_real(sc, c_rem_dbl(sc, real(x), real(y)))); + /* see under sin -- this calculation is completely bogus if "a" is large + * (quotient 1e22 (* 2 pi)) -> -9223372036854775808 but it should be 1591549430918953357688, + * (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 -- the "remainder" is greater than the original argument! + * Clisp gives 0.0 here, as does sbcl, currently s7 throws an error (out-of-range). + */ + + default: + return (method_or_bust_pp + (sc, y, sc->remainder_symbol, x, y, T_REAL, 2)); + } + + default: + return (method_or_bust_pp + (sc, x, sc->remainder_symbol, x, y, T_REAL, 1)); + } +#endif +} + +static s7_pointer g_remainder(s7_scheme * sc, s7_pointer args) +{ +#define H_remainder "(remainder x1 x2) returns the remainder of x1/x2; (remainder 10 3) = 1" +#define Q_remainder sc->pcl_r + /* (define (rem x1 x2) (- x1 (* x2 (quo x1 x2)))) ; slib, if x2 is an integer (- x1 (truncate x1 x2)), fractional part: (remainder x 1) */ + + s7_pointer x = car(args), y = cadr(args); + if ((is_t_integer(x)) && (is_t_integer(y))) + return (make_integer + (sc, remainder_i_7ii(sc, integer(x), integer(y)))); + return (remainder_p_pp(sc, x, y)); +} + + +/* -------------------------------- modulo -------------------------------- */ +static s7_int modulo_i_ii(s7_int x, s7_int y) +{ + s7_int z; + if (y > 1) { + z = x % y; + return ((z >= 0) ? z : z + y); + } + if (y < -1) { + z = x % y; + return ((z > 0) ? z + y : z); + } + if (y == 0) + return (x); /* else arithmetic exception */ + return (0); +} + +static s7_int modulo_i_ii_unchecked(s7_int i1, s7_int i2) +{ /* here we know i2 > 1 */ + /* i2 > 1 */ + s7_int z = i1 % i2; + return ((z < 0) ? (z + i2) : z); +} + +static s7_double modulo_d_7dd(s7_scheme * sc, s7_double x1, s7_double x2) +{ + s7_double c; + if ((is_NaN(x1)) || (is_NaN(x2)) || (is_inf(x1)) || (is_inf(x2))) + return (NAN); + if (x2 == 0.0) + return (x1); + if (fabs(x1) > 1e17) + simple_out_of_range(sc, sc->modulo_symbol, wrap_real1(sc, x1), + its_too_large_string); + c = x1 / x2; + if ((c > 1e19) || (c < -1e19)) + simple_out_of_range(sc, sc->modulo_symbol, + set_elist_3(sc, sc->divide_symbol, + wrap_real1(sc, x1), wrap_real2(sc, + x2)), + intermediate_too_large_string); + return (x1 - x2 * (s7_int) floor(c)); +} + +static s7_pointer modulo_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ +#if WITH_GMP + /* as tricky as expt, so just use bignums; mpz_mod|_ui = mpz_fdiv_r_ui, but sign ignored -- probably not worth the code + * originally subtract_p_pp(sc, x, multiply_p_pp(sc, y, floor_p_p(sc, divide_p_pp(sc, x, y)))) + * quotient is truncate_p_p(sc, divide_p_pp(sc, x, y)) + * remainder is subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y))) + */ + if (!is_zero(sc, y)) + return (big_mod_or_rem(sc, x, y, true)); + if (is_real(x)) + return (x); + return (method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, T_REAL, 1)); +#else + s7_double a, b; + s7_int n1, n2, d1, d2; + + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_INTEGER: + return (make_integer(sc, modulo_i_ii(integer(x), integer(y)))); + + case T_RATIO: + n1 = integer(x); + d1 = 1; + n2 = numerator(y); + d2 = denominator(y); + if ((n1 == n2) && (d1 > d2)) + return (x); /* signs match so this should be ok */ + goto RATIO_MOD_RATIO; + + case T_REAL: + if ((integer(x) == S7_INT64_MIN) + || (s7_int_abs(integer(x)) > QUOTIENT_INT_LIMIT)) + return (simple_out_of_range + (sc, sc->modulo_symbol, x, its_too_large_string)); + b = real(y); + if (b == 0.0) + return (x); + if (is_NaN(b)) + return (y); + if (is_inf(b)) + return (real_NaN); + a = (s7_double) integer(x); + goto REAL_MOD; + + default: + return (method_or_bust_pp + (sc, y, sc->modulo_symbol, x, y, T_REAL, 2)); + } + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + if (integer(y) == 0) + return (x); + n1 = numerator(x); + d1 = denominator(x); + n2 = integer(y); + + if ((n2 > 0) && (n1 > 0) && (n2 > n1)) + return (x); + if ((n2 < 0) && (n1 < 0) && (n2 < n1)) + return (x); + if (n2 == S7_INT64_MIN) + return (simple_out_of_range(sc, sc->modulo_symbol, + set_elist_3(sc, + sc->divide_symbol, + x, y), + intermediate_too_large_string)); + /* the problem here is that (modulo 3/2 most-negative-fixnum) + * will segfault with signal SIGFPE, Arithmetic exception, so try to trap it. + */ + if ((n1 == n2) && (d1 > 1)) + return (x); + d2 = 1; + goto RATIO_MOD_RATIO; + + case T_RATIO: + parcel_out_fractions(x, y); + if (d1 == d2) + return (s7_make_ratio(sc, modulo_i_ii(n1, n2), d1)); + if ((n1 == n2) && (d1 > d2)) + return (x); + + RATIO_MOD_RATIO: +#if HAVE_OVERFLOW_CHECKS + { + s7_int n2d1, n1d2, d1d2, fl; + if (!multiply_overflow(n2, d1, &n2d1)) { + if ((n2d1 == 1) || (n2d1 == -1)) /* (modulo 100 -1/2) */ + return (int_zero); + + if (!multiply_overflow(n1, d2, &n1d2)) { + fl = (s7_int) (n1d2 / n2d1); + if (((n1 < 0) && (n2 > 0)) || + ((n1 > 0) && (n2 < 0))) + fl -= 1; + if (fl == 0) + return (x); + + if ((!multiply_overflow(d1, d2, &d1d2)) && + (!multiply_overflow(fl, n2d1, &fl)) && + (!subtract_overflow(n1d2, fl, &fl))) + return (s7_make_ratio(sc, fl, d1d2)); + } + } + } +#else + { + s7_int n1d2, n2d1, fl; + n1d2 = n1 * d2; + n2d1 = n2 * d1; + + if (n2d1 == 1) + return (int_zero); + + /* can't use "floor" here (float->int ruins everything) */ + fl = (s7_int) (n1d2 / n2d1); + if (((n1 < 0) && (n2 > 0)) || ((n1 > 0) && (n2 < 0))) + fl -= 1; + + if (fl == 0) + return (x); + + return (s7_make_ratio(sc, n1d2 - (n2d1 * fl), d1 * d2)); + } +#endif + return (simple_out_of_range(sc, sc->modulo_symbol, + set_elist_3(sc, sc->divide_symbol, + x, y), + intermediate_too_large_string)); + case T_REAL: + b = real(y); + if (is_inf(b)) + return (real_NaN); + if (fabs(b) > 1e17) + return (simple_out_of_range + (sc, sc->modulo_symbol, y, its_too_large_string)); + if (b == 0.0) + return (x); + if (is_NaN(b)) + return (y); + a = fraction(x); + return (make_real(sc, a - b * (s7_int) floor(a / b))); + + default: + return (method_or_bust_pp + (sc, y, sc->modulo_symbol, x, y, T_REAL, 2)); + } + + case T_REAL: + { + s7_double c; + a = real(x); + if (!is_real(y)) + return (method_or_bust_pp + (sc, y, sc->modulo_symbol, x, y, T_REAL, 2)); + if (is_NaN(a)) + return (x); + if (is_inf(a)) + return (real_NaN); /* not b */ + if (fabs(a) > 1e17) + return (simple_out_of_range + (sc, sc->modulo_symbol, x, its_too_large_string)); + + switch (type(y)) { + case T_INTEGER: + if (integer(y) == 0) + return (x); + if ((integer(y) == S7_INT64_MIN) + || (s7_int_abs(integer(y)) > QUOTIENT_INT_LIMIT)) + return (simple_out_of_range + (sc, sc->modulo_symbol, y, + its_too_large_string)); + b = (s7_double) integer(y); + goto REAL_MOD; + + case T_RATIO: + b = fraction(y); + goto REAL_MOD; + + case T_REAL: + b = real(y); + if (b == 0.0) + return (x); + if (is_NaN(b)) + return (y); + if (is_inf(b)) + return (real_NaN); + REAL_MOD: + c = a / b; + if (fabs(c) > 1e19) + return (simple_out_of_range(sc, sc->modulo_symbol, + set_elist_3(sc, + sc->divide_symbol, + x, y), + intermediate_too_large_string)); + return (make_real(sc, a - b * (s7_int) floor(c))); + + default: + return (method_or_bust_pp + (sc, y, sc->modulo_symbol, x, y, T_REAL, 2)); + } + } + + default: + return (method_or_bust_pp + (sc, x, sc->modulo_symbol, x, y, T_REAL, 1)); + } +#endif +} + +static s7_pointer g_modulo(s7_scheme * sc, s7_pointer args) +{ +#define H_modulo "(modulo x1 x2) returns x1 mod x2; (modulo 4 3) = 1. The arguments can be real numbers." +#define Q_modulo sc->pcl_r + /* (define (mod x1 x2) (- x1 (* x2 (floor (/ x1 x2))))) from slib + * (mod x 0) = x according to "Concrete Mathematics" + */ + return (modulo_p_pp(sc, car(args), cadr(args))); +} + + +/* ---------------------------------------- max ---------------------------------------- */ +static bool is_real_via_method_1(s7_scheme * sc, s7_pointer p) +{ + s7_pointer f; + f = find_method_with_let(sc, p, sc->is_real_symbol); + if (f != sc->undefined) + return (is_true(sc, call_method(sc, p, f, set_plist_1(sc, p)))); + return (false); +} + +#define is_real_via_method(sc, p) ((is_real(p)) || ((has_active_methods(sc, p)) && (is_real_via_method_1(sc, p)))) + +#define max_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->max_symbol, X, Y, T_REAL, 1) +#define max_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->max_symbol, X, Y, T_REAL, 2) + +static s7_pointer max_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + /* same basic code as lt_b_7_pp (or any relop) but max returns NaN if NaN encountered, and methods for < and max return + * different results, so it seems simpler to repeat the other code. + */ + if (type(x) == type(y)) { + if (is_t_integer(x)) + return ((integer(x) < integer(y)) ? y : x); + if (is_t_real(x)) + return (((is_NaN(real(x))) || (real(x) >= real(y))) ? x : y); + if (is_t_ratio(x)) + return ((fraction(x) < fraction(y)) ? y : x); +#if WITH_GMP + if (is_t_big_integer(x)) + return ((mpz_cmp(big_integer(x), big_integer(y)) < 0) ? y : x); + if (is_t_big_ratio(x)) + return ((mpq_cmp(big_ratio(x), big_ratio(y)) < 0) ? y : x); + if (is_t_big_real(x)) + return (((mpfr_nan_p(big_real(x)) != 0) || (mpfr_greaterequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */ +#endif + } + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_RATIO: + return ((integer(x) < fraction(y)) ? y : x); + case T_REAL: + if (is_NaN(real(y))) + return (y); + return ((integer(x) < real(y)) ? y : x); +#if WITH_GMP + case T_BIG_INTEGER: + return ((mpz_cmp_si(big_integer(y), integer(x)) < 0) ? x : y); + case T_BIG_RATIO: + return ((mpq_cmp_si(big_ratio(y), integer(x), 1) < 0) ? x : y); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) + return (y); + return ((mpfr_cmp_si(big_real(y), integer(x)) < 0) ? x : y); +#endif + default: + return (max_out_y(sc, x, y)); + } + break; + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + return ((fraction(x) < integer(y)) ? y : x); + case T_REAL: + if (is_NaN(real(y))) + return (y); + return ((fraction(x) < real(y)) ? y : x); +#if WITH_GMP + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return ((mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0) ? y : x); + case T_BIG_RATIO: + return ((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) + < 0) ? x : y); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) + return (y); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return ((mpfr_cmp_q(big_real(y), sc->mpq_1) < 0) ? x : y); +#endif + default: + return (max_out_y(sc, x, y)); + } + + case T_REAL: + switch (type(y)) { + case T_INTEGER: + if (is_NaN(real(x))) + return (x); + return ((real(x) < integer(y)) ? y : x); + case T_RATIO: + return ((real(x) < fraction(y)) ? y : x); +#if WITH_GMP + case T_BIG_INTEGER: + if (is_NaN(real(x))) + return (x); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return ((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0) ? y : x); + + case T_BIG_RATIO: + if (is_NaN(real(x))) + return (x); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return ((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0) ? y : x); + + case T_BIG_REAL: + if (is_NaN(real(x))) + return (x); + if (mpfr_nan_p(big_real(y))) + return (y); + return ((mpfr_cmp_d(big_real(y), real(x)) < 0) ? x : y); +#endif + default: + return (max_out_y(sc, x, y)); + } + break; + +#if WITH_GMP + case T_BIG_INTEGER: + switch (type(y)) { + case T_INTEGER: + return ((mpz_cmp_si(big_integer(x), integer(y)) < 0) ? y : x); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return ((mpq_cmp_z(sc->mpq_1, big_integer(x)) < 0) ? x : y); + case T_REAL: + if (is_NaN(real(y))) + return (y); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + return ((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x); + case T_BIG_RATIO: + return ((mpq_cmp_z(big_ratio(y), big_integer(x)) < 0) ? x : y); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) + return (y); + return ((mpfr_cmp_z(big_real(y), big_integer(x)) < 0) ? x : y); + default: + return (max_out_y(sc, x, y)); + } + case T_BIG_RATIO: + switch (type(y)) { + case T_INTEGER: + return ((mpq_cmp_si(big_ratio(x), integer(y), 1) < 0) ? y : x); + case T_RATIO: + return ((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) + < 0) ? y : x); + case T_REAL: + if (is_NaN(real(y))) + return (y); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return ((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x); + case T_BIG_INTEGER: + return ((mpq_cmp_z(big_ratio(x), big_integer(y)) < 0) ? y : x); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) + return (y); + return ((mpfr_cmp_q(big_real(y), big_ratio(x)) < 0) ? x : y); + default: + return (max_out_y(sc, x, y)); + } + + case T_BIG_REAL: + switch (type(y)) { + case T_INTEGER: + if (mpfr_nan_p(big_real(x))) + return (x); + return ((mpfr_cmp_si(big_real(x), integer(y)) < 0) ? y : x); + case T_RATIO: + if (mpfr_nan_p(big_real(x))) + return (x); + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return ((mpfr_cmp_q(big_real(x), sc->mpq_1) < 0) ? y : x); + case T_REAL: + if (mpfr_nan_p(big_real(x))) + return (x); + if (is_NaN(real(y))) + return (y); + return ((mpfr_cmp_d(big_real(x), real(y)) < 0) ? y : x); + case T_BIG_INTEGER: + if (mpfr_nan_p(big_real(x))) + return (x); + return ((mpfr_cmp_z(big_real(x), big_integer(y)) < 0) ? y : x); + case T_BIG_RATIO: + if (mpfr_nan_p(big_real(x))) + return (x); + return ((mpfr_cmp_q(big_real(x), big_ratio(y)) < 0) ? y : x); + default: + return (max_out_y(sc, x, y)); + } +#endif + default: + return (max_out_x(sc, x, y)); + } + return (x); +} + +static s7_pointer g_max(s7_scheme * sc, s7_pointer args) +{ +#define H_max "(max ...) returns the maximum of its arguments" +#define Q_max sc->pcl_r + + s7_pointer x = car(args), p; + if (is_null(cdr(args))) { + if (is_real(x)) + return (x); + return (method_or_bust_p(sc, x, sc->max_symbol, T_REAL)); + } + for (p = cdr(args); is_pair(p); p = cdr(p)) + x = max_p_pp(sc, x, car(p)); + return (x); +} + +static s7_pointer g_max_2(s7_scheme * sc, s7_pointer args) +{ + return (max_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_max_3(s7_scheme * sc, s7_pointer args) +{ + return (max_p_pp + (sc, max_p_pp(sc, car(args), cadr(args)), caddr(args))); +} + +static s7_pointer max_chooser(s7_scheme * sc, s7_pointer f, int32_t args, + s7_pointer expr, bool ops) +{ + return ((args == 2) ? sc->max_2 : ((args == 3) ? sc->max_3 : f)); +} + +static s7_int max_i_ii(s7_int i1, s7_int i2) +{ + return ((i1 > i2) ? i1 : i2); +} + +static s7_int max_i_iii(s7_int i1, s7_int i2, s7_int i3) +{ + return ((i1 > i2) ? ((i1 > i3) ? i1 : i3) : ((i2 > i3) ? i2 : i3)); +} + +static s7_double max_d_dd(s7_double x1, s7_double x2) +{ + if (is_NaN(x1)) + return (x1); + return ((x1 > x2) ? x1 : x2); +} + +static s7_double max_d_ddd(s7_double x1, s7_double x2, s7_double x3) +{ + return (max_d_dd(x1, max_d_dd(x2, x3))); +} + +static s7_double max_d_dddd(s7_double x1, s7_double x2, s7_double x3, + s7_double x4) +{ + return (max_d_dd(x1, max_d_ddd(x2, x3, x4))); +} + + +/* ---------------------------------------- min ---------------------------------------- */ +#define min_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->min_symbol, X, Y, T_REAL, 1) +#define min_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->min_symbol, X, Y, T_REAL, 2) + +static s7_pointer min_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (type(x) == type(y)) { + if (is_t_integer(x)) + return ((integer(x) > integer(y)) ? y : x); + if (is_t_real(x)) + return (((is_NaN(real(x))) || (real(x) <= real(y))) ? x : y); + if (is_t_ratio(x)) + return ((fraction(x) > fraction(y)) ? y : x); +#if WITH_GMP + if (is_t_big_integer(x)) + return ((mpz_cmp(big_integer(x), big_integer(y)) > 0) ? y : x); + if (is_t_big_ratio(x)) + return ((mpq_cmp(big_ratio(x), big_ratio(y)) > 0) ? y : x); + if (is_t_big_real(x)) + return (((mpfr_nan_p(big_real(x)) != 0) || (mpfr_lessequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */ +#endif + } + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_RATIO: + return ((integer(x) > fraction(y)) ? y : x); + case T_REAL: + if (is_NaN(real(y))) + return (y); + return ((integer(x) > real(y)) ? y : x); +#if WITH_GMP + case T_BIG_INTEGER: + return ((mpz_cmp_si(big_integer(y), integer(x)) > 0) ? x : y); + case T_BIG_RATIO: + return ((mpq_cmp_si(big_ratio(y), integer(x), 1) > 0) ? x : y); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) + return (y); + return ((mpfr_cmp_si(big_real(y), integer(x)) > 0) ? x : y); +#endif + default: + return (min_out_y(sc, x, y)); + } + break; + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + return ((fraction(x) > integer(y)) ? y : x); + case T_REAL: + if (is_NaN(real(y))) + return (y); + return ((fraction(x) > real(y)) ? y : x); +#if WITH_GMP + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return ((mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0) ? y : x); + case T_BIG_RATIO: + return ((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) + > 0) ? x : y); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) + return (y); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return ((mpfr_cmp_q(big_real(y), sc->mpq_1) > 0) ? x : y); +#endif + default: + return (min_out_y(sc, x, y)); + } + + case T_REAL: + switch (type(y)) { + case T_INTEGER: + if (is_NaN(real(x))) + return (x); + return ((real(x) > integer(y)) ? y : x); + case T_RATIO: + return ((real(x) > fraction(y)) ? y : x); +#if WITH_GMP + case T_BIG_INTEGER: + if (is_NaN(real(x))) + return (x); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return ((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0) ? y : x); + + case T_BIG_RATIO: + if (is_NaN(real(x))) + return (x); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return ((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0) ? y : x); + + case T_BIG_REAL: + if (is_NaN(real(x))) + return (x); + if (mpfr_nan_p(big_real(y))) + return (y); + return ((mpfr_cmp_d(big_real(y), real(x)) > 0) ? x : y); +#endif + default: + return (min_out_y(sc, x, y)); + } + break; + +#if WITH_GMP + case T_BIG_INTEGER: + switch (type(y)) { + case T_INTEGER: + return ((mpz_cmp_si(big_integer(x), integer(y)) > 0) ? y : x); + case T_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + return ((mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) > + 0) ? y : x); + case T_REAL: + if (is_NaN(real(y))) + return (y); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + return ((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x); + case T_BIG_RATIO: + return ((mpq_cmp_z(big_ratio(y), big_integer(x)) > 0) ? x : y); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) + return (y); + return ((mpfr_cmp_z(big_real(y), big_integer(x)) > 0) ? x : y); + default: + return (min_out_y(sc, x, y)); + } + case T_BIG_RATIO: + switch (type(y)) { + case T_INTEGER: + return ((mpq_cmp_si(big_ratio(x), integer(y), 1) > 0) ? y : x); + case T_RATIO: + return ((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) + > 0) ? y : x); + case T_REAL: + if (is_NaN(real(y))) + return (y); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return ((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x); + case T_BIG_INTEGER: + return ((mpq_cmp_z(big_ratio(x), big_integer(y)) > 0) ? y : x); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) + return (y); + return ((mpfr_cmp_q(big_real(y), big_ratio(x)) > 0) ? x : y); + default: + return (min_out_y(sc, x, y)); + } + + case T_BIG_REAL: + switch (type(y)) { + case T_INTEGER: + if (mpfr_nan_p(big_real(x))) + return (x); + return ((mpfr_cmp_si(big_real(x), integer(y)) > 0) ? y : x); + case T_RATIO: + if (mpfr_nan_p(big_real(x))) + return (x); + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return ((mpfr_cmp_q(big_real(x), sc->mpq_1) > 0) ? y : x); + case T_REAL: + if (mpfr_nan_p(big_real(x))) + return (x); + if (is_NaN(real(y))) + return (y); + return ((mpfr_cmp_d(big_real(x), real(y)) > 0) ? y : x); + case T_BIG_INTEGER: + if (mpfr_nan_p(big_real(x))) + return (x); + return ((mpfr_cmp_z(big_real(x), big_integer(y)) > 0) ? y : x); + case T_BIG_RATIO: + if (mpfr_nan_p(big_real(x))) + return (x); + return ((mpfr_cmp_q(big_real(x), big_ratio(y)) > 0) ? y : x); + default: + return (min_out_y(sc, x, y)); + } +#endif + default: + return (min_out_x(sc, x, y)); + } + return (x); +} + +static s7_pointer g_min(s7_scheme * sc, s7_pointer args) +{ +#define H_min "(min ...) returns the minimum of its arguments" +#define Q_min sc->pcl_r + + s7_pointer x = car(args), p; + if (is_null(cdr(args))) { + if (is_real(x)) + return (x); + return (method_or_bust_p(sc, x, sc->min_symbol, T_REAL)); + } + for (p = cdr(args); is_pair(p); p = cdr(p)) + x = min_p_pp(sc, x, car(p)); + return (x); +} + +static s7_pointer g_min_2(s7_scheme * sc, s7_pointer args) +{ + return (min_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_min_3(s7_scheme * sc, s7_pointer args) +{ + return (min_p_pp + (sc, min_p_pp(sc, car(args), cadr(args)), caddr(args))); +} + +static s7_pointer min_chooser(s7_scheme * sc, s7_pointer f, int32_t args, + s7_pointer expr, bool ops) +{ + return ((args == 2) ? sc->min_2 : ((args == 3) ? sc->min_3 : f)); +} + +static s7_int min_i_ii(s7_int i1, s7_int i2) +{ + return ((i1 < i2) ? i1 : i2); +} + +static s7_int min_i_iii(s7_int i1, s7_int i2, s7_int i3) +{ + return ((i1 < i2) ? ((i1 < i3) ? i1 : i3) : ((i2 < i3) ? i2 : i3)); +} + +static s7_double min_d_dd(s7_double x1, s7_double x2) +{ + if (is_NaN(x1)) + return (x1); + return ((x1 < x2) ? x1 : x2); +} + +static s7_double min_d_ddd(s7_double x1, s7_double x2, s7_double x3) +{ + return (min_d_dd(x1, min_d_dd(x2, x3))); +} + +static s7_double min_d_dddd(s7_double x1, s7_double x2, s7_double x3, + s7_double x4) +{ + return (min_d_dd(x1, min_d_ddd(x2, x3, x4))); +} + + +/* ---------------------------------------- = ---------------------------------------- */ +static bool eq_out_x(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (has_active_methods(sc, x)) + return (find_and_apply_method + (sc, x, sc->num_eq_symbol, + set_plist_2(sc, x, y)) != sc->F); + wrong_type_argument_with_type(sc, sc->num_eq_symbol, 1, x, + a_number_string); + return (false); +} + +static bool eq_out_y(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (has_active_methods(sc, y)) + return (find_and_apply_method + (sc, y, sc->num_eq_symbol, + set_plist_2(sc, x, y)) != sc->F); + wrong_type_argument_with_type(sc, sc->num_eq_symbol, 2, y, + a_number_string); + return (false); +} + +static bool num_eq_b_7pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (type(x) == type(y)) { + if (is_t_integer(x)) + return (integer(x) == integer(y)); + if (is_t_real(x)) + return (real(x) == real(y)); + if (is_t_complex(x)) + return ((real_part(x) == real_part(y)) + && (imag_part(x) == imag_part(y))); + if (is_t_ratio(x)) + return ((numerator(x) == numerator(y)) + && (denominator(x) == denominator(y))); +#if WITH_GMP + if (is_t_big_integer(x)) + return (mpz_cmp(big_integer(x), big_integer(y)) == 0); + if (is_t_big_ratio(x)) + return (mpq_equal(big_ratio(x), big_ratio(y))); + if (is_t_big_real(x)) + return (mpfr_equal_p(big_real(x), big_real(y))); + if (is_t_big_complex(x)) { /* mpc_cmp can't handle NaN */ + if ((mpfr_nan_p(mpc_realref(big_complex(x)))) + || (mpfr_nan_p(mpc_imagref(big_complex(x)))) + || (mpfr_nan_p(mpc_realref(big_complex(y)))) + || (mpfr_nan_p(mpc_imagref(big_complex(y))))) + return (false); + return (mpc_cmp(big_complex(x), big_complex(y)) == 0); + } +#endif + } + + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_RATIO: + return (false); + case T_REAL: +#if WITH_GMP + if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) { + if (is_NaN(real(y))) + return (false); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + return (mpfr_cmp_si(sc->mpfr_1, integer(x)) == 0); + } +#endif + return (integer(x) == real(y)); + case T_COMPLEX: + return (false); +#if WITH_GMP + case T_BIG_INTEGER: + return ((mpz_fits_slong_p(big_integer(y))) + && (integer(x) == mpz_get_si(big_integer(y)))); + case T_BIG_RATIO: + return (false); + case T_BIG_REAL: + return ((!mpfr_nan_p(big_real(y))) + && (mpfr_cmp_si(big_real(y), integer(x)) == 0)); + case T_BIG_COMPLEX: + return (false); +#endif + default: + return (eq_out_y(sc, x, y)); + } + break; + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + return (false); + case T_REAL: + return (fraction(x) == real(y)); + case T_COMPLEX: + return (false); +#if WITH_GMP + case T_BIG_INTEGER: + return (false); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return (mpq_equal(sc->mpq_1, big_ratio(y))); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) + return (false); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return (mpfr_cmp_q(big_real(y), sc->mpq_1) == 0); + case T_BIG_COMPLEX: + return (false); +#endif + default: + return (eq_out_y(sc, x, y)); + } + break; + + case T_REAL: + switch (type(y)) { + case T_INTEGER: + return (real(x) == integer(y)); + case T_RATIO: + return (real(x) == fraction(y)); + case T_COMPLEX: + return (false); +#if WITH_GMP + case T_BIG_INTEGER: + if (is_NaN(real(x))) + return (false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return (mpfr_cmp_z(sc->mpfr_1, big_integer(y)) == 0); + case T_BIG_RATIO: + if (is_NaN(real(x))) + return (false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return (mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) == 0); + case T_BIG_REAL: + if (is_NaN(real(x))) + return (false); + return ((!mpfr_nan_p(big_real(y))) + && (mpfr_cmp_d(big_real(y), real(x)) == 0)); + case T_BIG_COMPLEX: + return (false); +#endif + default: + return (eq_out_y(sc, x, y)); + } + break; + + case T_COMPLEX: + if (is_real(y)) + return (false); +#if WITH_GMP + if (is_t_big_complex(y)) { + if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) || + (mpfr_nan_p(mpc_realref(big_complex(y)))) + || (mpfr_nan_p(mpc_imagref(big_complex(y))))) + return (false); + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + return (mpc_cmp(big_complex(y), sc->mpc_1) == 0); + } +#endif + return (eq_out_y(sc, x, y)); + +#if WITH_GMP + case T_BIG_INTEGER: + switch (type(y)) { + case T_INTEGER: + return ((mpz_fits_slong_p(big_integer(x))) + && (integer(y) == mpz_get_si(big_integer(x)))); + case T_REAL: + if (is_NaN(real(y))) + return (false); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + return (mpfr_cmp_z(sc->mpfr_1, big_integer(x)) == 0); + case T_RATIO: + case T_COMPLEX: + case T_BIG_RATIO: + case T_BIG_COMPLEX: + return (false); + case T_BIG_REAL: + return ((!mpfr_nan_p(big_real(y))) + && (mpfr_cmp_z(big_real(y), big_integer(x)) == 0)); + default: + return (eq_out_y(sc, x, y)); + } + case T_BIG_RATIO: + switch (type(y)) { + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return (mpq_equal(sc->mpq_1, big_ratio(x))); + case T_REAL: + if (is_NaN(real(y))) + return (false); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + return (mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) == 0); + case T_INTEGER: + case T_BIG_INTEGER: + case T_COMPLEX: + case T_BIG_COMPLEX: + return (false); + case T_BIG_REAL: + return ((!mpfr_nan_p(big_real(y))) + && (mpfr_cmp_q(big_real(y), big_ratio(x)) == 0)); + default: + return (eq_out_y(sc, x, y)); + } + + case T_BIG_REAL: + if ((is_number(y)) && (mpfr_nan_p(big_real(x)))) + return (false); + switch (type(y)) { + case T_INTEGER: + return (mpfr_cmp_si(big_real(x), integer(y)) == 0); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return (mpfr_cmp_q(big_real(x), sc->mpq_1) == 0); + case T_REAL: + return ((!is_NaN(real(y))) + && (mpfr_cmp_d(big_real(x), real(y)) == 0)); + case T_BIG_INTEGER: + return (mpfr_cmp_z(big_real(x), big_integer(y)) == 0); + case T_BIG_RATIO: + return (mpfr_cmp_q(big_real(x), big_ratio(y)) == 0); + case T_COMPLEX: + case T_BIG_COMPLEX: + return (false); + default: + return (eq_out_y(sc, x, y)); + } + + case T_BIG_COMPLEX: + switch (type(y)) { + case T_RATIO: + case T_REAL: + case T_INTEGER: + case T_BIG_INTEGER: + case T_BIG_RATIO: + case T_BIG_REAL: + return (false); + case T_COMPLEX: + if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || + (mpfr_nan_p(mpc_realref(big_complex(x)))) + || (mpfr_nan_p(mpc_imagref(big_complex(x))))) + return (false); + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + return (mpc_cmp(big_complex(x), sc->mpc_1) == 0); /* NaN's not allowed! */ + default: + return (eq_out_y(sc, x, y)); + } +#endif + default: + return (eq_out_x(sc, x, y)); + } + return (false); +} + +static bool is_number_via_method(s7_scheme * sc, s7_pointer p) +{ + if (is_number(p)) + return (true); + if (has_active_methods(sc, p)) { + s7_pointer f; + f = find_method_with_let(sc, p, sc->is_number_symbol); + if (f != sc->undefined) + return (is_true + (sc, call_method(sc, p, f, set_plist_1(sc, p)))); + } + return (false); +} + +static s7_pointer g_num_eq(s7_scheme * sc, s7_pointer args) +{ +#define H_num_eq "(= z1 ...) returns #t if all its arguments are equal" +#define Q_num_eq s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_number_symbol) + + s7_pointer x = car(args), p = cdr(args); + if (is_null(cdr(p))) + return (make_boolean(sc, num_eq_b_7pp(sc, x, car(p)))); + + for (; is_pair(p); p = cdr(p)) + if (!num_eq_b_7pp(sc, x, car(p))) { + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_number_via_method(sc, car(p))) + return (wrong_type_argument_with_type + (sc, sc->num_eq_symbol, position_of(p, args), + car(p), a_number_string)); + return (sc->F); + } + return (sc->T); +} + +static bool num_eq_b_ii(s7_int i1, s7_int i2) +{ + return (i1 == i2); +} + +static bool num_eq_b_dd(s7_double i1, s7_double i2) +{ + return (i1 == i2); +} + +static s7_pointer num_eq_p_dd(s7_scheme * sc, s7_double x1, s7_double x2) +{ + return (make_boolean(sc, x1 == x2)); +} + +static s7_pointer num_eq_p_ii(s7_scheme * sc, s7_int x1, s7_int x2) +{ + return (make_boolean(sc, x1 == x2)); +} + +static s7_pointer num_eq_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + return (make_boolean(sc, num_eq_b_7pp(sc, x, y))); +} + +static s7_pointer num_eq_p_pi(s7_scheme * sc, s7_pointer p1, s7_int p2) +{ + if (is_t_integer(p1)) + return ((integer(p1) == p2) ? sc->T : sc->F); + if (is_t_real(p1)) + return ((real(p1) == p2) ? sc->T : sc->F); +#if WITH_GMP + if (is_t_big_integer(p1)) + return (((mpz_fits_slong_p(big_integer(p1))) + && (p2 == mpz_get_si(big_integer(p1)))) ? sc->T : sc->F); + if (is_t_big_real(p1)) + return ((mpfr_cmp_si(big_real(p1), p2) == 0) ? sc->T : sc->F); +#endif + return ((is_number(p1)) ? sc->F : + make_boolean(sc, eq_out_x(sc, p1, make_integer(sc, p2)))); +} + +static bool num_eq_b_pi(s7_scheme * sc, s7_pointer x, s7_int y) +{ + if (is_t_integer(x)) + return (integer(x) == y); + if (is_t_real(x)) + return (real(x) == y); +#if WITH_GMP + if (is_t_big_integer(x)) + return ((mpz_fits_slong_p(big_integer(x))) + && (y == mpz_get_si(big_integer(x)))); + if (is_t_big_real(x)) + return (mpfr_cmp_si(big_real(x), y) == 0); +#endif + if (!is_number(x)) /* complex/ratio */ + simple_wrong_type_argument_with_type(sc, sc->num_eq_symbol, x, + a_number_string); + /* return(eq_out_x(sc, x, make_integer(sc, y))); *//* much slower? see thash */ + return (false); +} + +static s7_pointer g_num_eq_2(s7_scheme * sc, s7_pointer args) +{ + s7_pointer x = car(args), y = cadr(args); + if ((is_t_integer(x)) && (is_t_integer(y))) /* this is by far the most common case (ratios aren't used much, and = with floats is frowned upon) */ + return (make_boolean(sc, integer(x) == integer(y))); + return (make_boolean(sc, num_eq_b_7pp(sc, x, y))); +} + +static inline s7_pointer num_eq_xx(s7_scheme * sc, s7_pointer x, + s7_pointer y) +{ + if (is_t_integer(x)) + return (make_boolean(sc, integer(x) == integer(y))); + if (is_t_real(x)) + return ((is_NaN(real(x))) ? sc->F : + make_boolean(sc, real(x) == integer(y))); + if (!is_number(x)) + return (make_boolean(sc, eq_out_x(sc, x, y))); +#if WITH_GMP + if (is_t_big_integer(x)) + return (make_boolean + (sc, mpz_cmp_si(big_integer(x), integer(y)) == 0)); + if (is_t_big_real(x)) { + if (mpfr_nan_p(big_real(x))) + return (sc->F); + return (make_boolean + (sc, mpfr_cmp_si(big_real(x), integer(y)) == 0)); + } + if (is_t_big_ratio(x)) + return (make_boolean + (sc, mpq_cmp_si(big_ratio(x), integer(y), 1) == 0)); +#endif + return (sc->F); +} + +static s7_pointer g_num_eq_xi(s7_scheme * sc, s7_pointer args) +{ + return (num_eq_xx(sc, car(args), cadr(args))); +} + +static s7_pointer g_num_eq_ix(s7_scheme * sc, s7_pointer args) +{ + return (num_eq_xx(sc, cadr(args), car(args))); +} + +static s7_pointer num_eq_chooser(s7_scheme * sc, s7_pointer ur_f, + int32_t args, s7_pointer expr, bool ops) +{ + if (args == 2) { + if ((ops) && (is_t_integer(caddr(expr)))) + return (sc->num_eq_xi); + return (((ops) + && (is_t_integer(cadr(expr)))) ? sc-> + num_eq_ix : sc->num_eq_2); + } + return (ur_f); +} + + +/* ---------------------------------------- < ---------------------------------------- */ +static bool lt_out_x(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (has_active_methods(sc, x)) + return (find_and_apply_method + (sc, x, sc->lt_symbol, set_plist_2(sc, x, y)) != sc->F); + wrong_type_argument(sc, sc->lt_symbol, 1, x, T_REAL); + return (false); +} + +static bool lt_out_y(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (has_active_methods(sc, y)) + return (find_and_apply_method + (sc, y, sc->lt_symbol, set_plist_2(sc, x, y)) != sc->F); + wrong_type_argument(sc, sc->lt_symbol, 2, y, T_REAL); + return (false); +} + +static bool lt_b_7pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (type(x) == type(y)) { + if (is_t_integer(x)) + return (integer(x) < integer(y)); + if (is_t_real(x)) + return (real(x) < real(y)); + if (is_t_ratio(x)) + return (fraction(x) < fraction(y)); +#if WITH_GMP + if (is_t_big_integer(x)) + return (mpz_cmp(big_integer(x), big_integer(y)) < 0); + if (is_t_big_ratio(x)) + return (mpq_cmp(big_ratio(x), big_ratio(y)) < 0); + if (is_t_big_real(x)) + return (mpfr_less_p(big_real(x), big_real(y))); +#endif + } + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_RATIO: + return (integer(x) < fraction(y)); /* ?? */ + case T_REAL: + return (integer(x) < real(y)); +#if WITH_GMP + case T_BIG_INTEGER: + return (mpz_cmp_si(big_integer(y), integer(x)) > 0); + case T_BIG_RATIO: + return (mpq_cmp_si(big_ratio(y), integer(x), 1) > 0); + case T_BIG_REAL: + return (mpfr_cmp_si(big_real(y), integer(x)) > 0); +#endif + default: + return (lt_out_y(sc, x, y)); + } + break; + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + return (fraction(x) < integer(y)); + case T_REAL: + return (fraction(x) < real(y)); +#if WITH_GMP + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return (mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0); + case T_BIG_RATIO: + return (mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) + > 0); + case T_BIG_REAL: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return (mpfr_cmp_q(big_real(y), sc->mpq_1) > 0); +#endif + default: + return (lt_out_y(sc, x, y)); + } + + case T_REAL: + switch (type(y)) { + case T_INTEGER: + return (real(x) < integer(y)); + case T_RATIO: + return (real(x) < fraction(y)); +#if WITH_GMP + case T_BIG_INTEGER: + if (is_NaN(real(x))) + return (false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return (mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0); + + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return (mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0); + + case T_BIG_REAL: + return (mpfr_cmp_d(big_real(y), real(x)) > 0); +#endif + default: + return (lt_out_y(sc, x, y)); + } + break; + +#if WITH_GMP + case T_BIG_INTEGER: + switch (type(y)) { + case T_INTEGER: + return (mpz_cmp_si(big_integer(x), integer(y)) < 0); + case T_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + return (mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) < + 0); + case T_REAL: + if (is_NaN(real(y))) + return (false); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + return (mpfr_cmp_d(sc->mpfr_1, real(y)) < 0); + case T_BIG_RATIO: + return (mpq_cmp_z(big_ratio(y), big_integer(x)) > 0); + case T_BIG_REAL: + return (mpfr_cmp_z(big_real(y), big_integer(x)) > 0); + default: + return (lt_out_y(sc, x, y)); + } + case T_BIG_RATIO: + switch (type(y)) { + case T_INTEGER: + return (mpq_cmp_si(big_ratio(x), integer(y), 1) < 0); + case T_RATIO: + return (mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) + < 0); + case T_REAL: + if (is_NaN(real(y))) + return (false); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return (mpfr_cmp_d(sc->mpfr_1, real(y)) < 0); + case T_BIG_INTEGER: + return (mpq_cmp_z(big_ratio(x), big_integer(y)) < 0); + case T_BIG_REAL: + return (mpfr_cmp_q(big_real(y), big_ratio(x)) > 0); + default: + return (lt_out_y(sc, x, y)); + } + + case T_BIG_REAL: + switch (type(y)) { + case T_INTEGER: + return (mpfr_cmp_si(big_real(x), integer(y)) < 0); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return (mpfr_cmp_q(big_real(x), sc->mpq_1) < 0); + case T_REAL: + return (mpfr_cmp_d(big_real(x), real(y)) < 0); + case T_BIG_INTEGER: + return (mpfr_cmp_z(big_real(x), big_integer(y)) < 0); + case T_BIG_RATIO: + return (mpfr_cmp_q(big_real(x), big_ratio(y)) < 0); + default: + return (lt_out_y(sc, x, y)); + } +#endif + default: + return (lt_out_x(sc, x, y)); + } + return (true); +} + +static s7_pointer g_less(s7_scheme * sc, s7_pointer args) +{ +#define H_less "(< x1 ...) returns #t if its arguments are in increasing order" +#define Q_less s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol) + + s7_pointer x = car(args), p = cdr(args); + if (is_null(cdr(p))) + return (make_boolean(sc, lt_b_7pp(sc, x, car(p)))); + + for (; is_pair(p); p = cdr(p)) { + if (!lt_b_7pp(sc, x, car(p))) { + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_real_via_method(sc, car(p))) + return (wrong_type_argument + (sc, sc->lt_symbol, position_of(p, args), + car(p), T_REAL)); + return (sc->F); + } + x = car(p); + } + return (sc->T); +} + +static bool ratio_lt_pi(s7_pointer x, s7_int y) +{ + if ((y >= 0) && (numerator(x) < 0)) + return (true); + if ((y <= 0) && (numerator(x) > 0)) + return (false); + if (denominator(x) < S7_INT32_MAX) + return (numerator(x) < (y * denominator(x))); + return (fraction(x) < y); +} + +static s7_pointer g_less_x0(s7_scheme * sc, s7_pointer args) +{ + s7_pointer x = car(args); + if (is_t_integer(x)) + return (make_boolean(sc, integer(x) < 0)); + if (is_small_real(x)) + return (make_boolean(sc, is_negative(sc, x))); +#if WITH_GMP + if (is_t_big_integer(x)) + return (make_boolean(sc, mpz_cmp_si(big_integer(x), 0) < 0)); + if (is_t_big_real(x)) + return (make_boolean(sc, mpfr_cmp_si(big_real(x), 0) < 0)); + if (is_t_big_ratio(x)) + return (make_boolean(sc, mpq_cmp_si(big_ratio(x), 0, 1) < 0)); +#endif + return (method_or_bust(sc, x, sc->lt_symbol, args, T_REAL, 1)); +} + +static s7_pointer g_less_xi(s7_scheme * sc, s7_pointer args) +{ + s7_int y = integer(cadr(args)); + s7_pointer x = car(args); + + if (is_t_integer(x)) + return (make_boolean(sc, integer(x) < y)); + if (is_t_real(x)) + return (make_boolean(sc, real(x) < y)); + if (is_t_ratio(x)) + return (make_boolean(sc, ratio_lt_pi(x, y))); +#if WITH_GMP + if (is_t_big_integer(x)) + return (make_boolean(sc, mpz_cmp_si(big_integer(x), y) < 0)); + if (is_t_big_real(x)) + return (make_boolean(sc, mpfr_cmp_si(big_real(x), y) < 0)); + if (is_t_big_ratio(x)) + return (make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) < 0)); +#endif + return (method_or_bust(sc, x, sc->lt_symbol, args, T_REAL, 1)); +} + +static s7_pointer g_less_xf(s7_scheme * sc, s7_pointer args) +{ + s7_double y = real(cadr(args)); /* chooser below checks is_t_real(y) */ + s7_pointer x = car(args); + + if (is_t_real(x)) + return (make_boolean(sc, real(x) < y)); + if (is_t_integer(x)) + return (make_boolean(sc, integer(x) < y)); + if (is_t_ratio(x)) + return (make_boolean(sc, fraction(x) < y)); +#if WITH_GMP + if (is_t_big_real(x)) + return (make_boolean(sc, mpfr_cmp_d(big_real(x), y) < 0)); + if (is_t_big_integer(x)) { + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + return (make_boolean + (sc, mpfr_cmp_z(sc->mpfr_1, big_integer(x)) > 0)); + } + if (is_t_big_ratio(x)) { + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + return (make_boolean + (sc, mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) > 0)); + } +#endif + return (method_or_bust(sc, x, sc->lt_symbol, args, T_REAL, 1)); +} + +static inline s7_pointer lt_p_pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + return (make_boolean(sc, lt_b_7pp(sc, p1, p2))); +} + +static bool lt_b_ii(s7_int i1, s7_int i2) +{ + return (i1 < i2); +} + +static bool lt_b_dd(s7_double i1, s7_double i2) +{ + return (i1 < i2); +} + +static s7_pointer lt_p_dd(s7_scheme * sc, s7_double x1, s7_double x2) +{ + return (make_boolean(sc, x1 < x2)); +} + +static s7_pointer lt_p_ii(s7_scheme * sc, s7_int x1, s7_int x2) +{ + return (make_boolean(sc, x1 < x2)); +} + +static bool lt_b_pi(s7_scheme * sc, s7_pointer p1, s7_int p2) +{ + if (is_t_integer(p1)) + return (integer(p1) < p2); + if (is_t_real(p1)) + return (real(p1) < p2); + if (is_t_ratio(p1)) + return (ratio_lt_pi(p1, p2)); +#if WITH_GMP + if (is_t_big_integer(p1)) + return (mpz_cmp_si(big_integer(p1), p2) < 0); + if (is_t_big_real(p1)) + return (mpfr_cmp_si(big_real(p1), p2) < 0); + if (is_t_big_ratio(p1)) + return (mpq_cmp_si(big_ratio(p1), p2, 1) < 0); +#endif + return (lt_out_x(sc, p1, make_integer(sc, p2))); +} + +static s7_pointer g_less_2(s7_scheme * sc, s7_pointer args) +{ + return (lt_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer lt_p_pi(s7_scheme * sc, s7_pointer p1, s7_int p2) +{ + return (make_boolean(sc, lt_b_pi(sc, p1, p2))); +} + +static s7_pointer less_chooser(s7_scheme * sc, s7_pointer f, int32_t args, + s7_pointer expr, bool ops) +{ + if (args == 2) { + if (ops) { + s7_pointer arg2 = caddr(expr); + if (is_t_integer(arg2)) { + if (integer(arg2) == 0) + return (sc->less_x0); + + if ((integer(arg2) < S7_INT32_MAX) && + (integer(arg2) > S7_INT32_MIN)) + return (sc->less_xi); + } + if (is_t_real(arg2)) + return (sc->less_xf); + } + return (sc->less_2); + } + return (f); +} + + +/* ---------------------------------------- <= ---------------------------------------- */ +static bool leq_out_x(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (has_active_methods(sc, x)) + return (find_and_apply_method + (sc, x, sc->leq_symbol, set_plist_2(sc, x, y)) != sc->F); + wrong_type_argument(sc, sc->leq_symbol, 1, x, T_REAL); + return (false); +} + +static bool leq_out_y(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (has_active_methods(sc, y)) + return (find_and_apply_method + (sc, y, sc->leq_symbol, set_plist_2(sc, x, y)) != sc->F); + wrong_type_argument(sc, sc->leq_symbol, 2, y, T_REAL); + return (false); +} + +static bool leq_b_7pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (type(x) == type(y)) { + if (is_t_integer(x)) + return (integer(x) <= integer(y)); + if (is_t_real(x)) + return (real(x) <= real(y)); + if (is_t_ratio(x)) + return (fraction(x) <= fraction(y)); +#if WITH_GMP + if (is_t_big_integer(x)) + return (mpz_cmp(big_integer(x), big_integer(y)) <= 0); + if (is_t_big_ratio(x)) + return (mpq_cmp(big_ratio(x), big_ratio(y)) <= 0); + if (is_t_big_real(x)) + return (mpfr_lessequal_p(big_real(x), big_real(y))); +#endif + } + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_RATIO: + return (integer(x) <= fraction(y)); /* ?? */ + case T_REAL: + return (integer(x) <= real(y)); +#if WITH_GMP + case T_BIG_INTEGER: + return (mpz_cmp_si(big_integer(y), integer(x)) >= 0); + case T_BIG_RATIO: + return (mpq_cmp_si(big_ratio(y), integer(x), 1) >= 0); + case T_BIG_REAL: + return ((!mpfr_nan_p(big_real(y))) + && (mpfr_cmp_si(big_real(y), integer(x)) >= 0)); +#endif + default: + return (leq_out_y(sc, x, y)); + } + break; + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + return (fraction(x) <= integer(y)); + case T_REAL: + return (fraction(x) <= real(y)); +#if WITH_GMP + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return (mpq_cmp_z(sc->mpq_1, big_integer(y)) <= 0); + case T_BIG_RATIO: + return (mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) + >= 0); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) + return (false); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return (mpfr_cmp_q(big_real(y), sc->mpq_1) >= 0); +#endif + default: + return (leq_out_y(sc, x, y)); + } + + case T_REAL: + switch (type(y)) { + case T_INTEGER: + return (real(x) <= integer(y)); + case T_RATIO: + return (real(x) <= fraction(y)); +#if WITH_GMP + case T_BIG_INTEGER: + if (is_NaN(real(x))) + return (false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return (mpfr_cmp_z(sc->mpfr_1, big_integer(y)) <= 0); + + case T_BIG_RATIO: + if (is_NaN(real(x))) + return (false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return (mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) <= 0); + + case T_BIG_REAL: + if (is_NaN(real(x))) + return (false); + return ((!mpfr_nan_p(big_real(y))) + && (mpfr_cmp_d(big_real(y), real(x)) >= 0)); +#endif + default: + return (leq_out_y(sc, x, y)); + } + break; + +#if WITH_GMP + case T_BIG_INTEGER: + switch (type(y)) { + case T_INTEGER: + return (mpz_cmp_si(big_integer(x), integer(y)) <= 0); + case T_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + return (mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) <= + 0); + case T_REAL: + if (is_NaN(real(y))) + return (false); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + return (mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0); + case T_BIG_RATIO: + return (mpq_cmp_z(big_ratio(y), big_integer(x)) >= 0); + case T_BIG_REAL: + return ((!mpfr_nan_p(big_real(y))) + && (mpfr_cmp_z(big_real(y), big_integer(x)) >= 0)); + default: + return (leq_out_y(sc, x, y)); + } + case T_BIG_RATIO: + switch (type(y)) { + case T_INTEGER: + return (mpq_cmp_si(big_ratio(x), integer(y), 1) <= 0); + case T_RATIO: + return (mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) + <= 0); + case T_REAL: + if (is_NaN(real(y))) + return (false); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return (mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0); + case T_BIG_INTEGER: + return (mpq_cmp_z(big_ratio(x), big_integer(y)) <= 0); + case T_BIG_REAL: + return ((!mpfr_nan_p(big_real(y))) + && (mpfr_cmp_q(big_real(y), big_ratio(x)) >= 0)); + default: + return (leq_out_y(sc, x, y)); + } + + case T_BIG_REAL: + if ((is_real(y)) && (mpfr_nan_p(big_real(x)))) + return (false); + switch (type(y)) { + case T_INTEGER: + return (mpfr_cmp_si(big_real(x), integer(y)) <= 0); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return (mpfr_cmp_q(big_real(x), sc->mpq_1) <= 0); + case T_REAL: + return ((!is_NaN(real(y))) + && (mpfr_cmp_d(big_real(x), real(y)) <= 0)); + case T_BIG_INTEGER: + return (mpfr_cmp_z(big_real(x), big_integer(y)) <= 0); + case T_BIG_RATIO: + return (mpfr_cmp_q(big_real(x), big_ratio(y)) <= 0); + default: + return (leq_out_y(sc, x, y)); + } +#endif + default: + return (leq_out_x(sc, x, y)); + } + return (true); +} + +static s7_pointer g_less_or_equal(s7_scheme * sc, s7_pointer args) +{ +#define H_less_or_equal "(<= x1 ...) returns #t if its arguments are in non-decreasing order" +#define Q_less_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol) + + s7_pointer x = car(args), p = cdr(args); + + if (is_null(cdr(p))) + return (make_boolean(sc, leq_b_7pp(sc, x, car(p)))); + + for (; is_pair(p); x = car(p), p = cdr(p)) + if (!leq_b_7pp(sc, x, car(p))) { + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_real_via_method(sc, car(p))) + return (wrong_type_argument + (sc, sc->leq_symbol, position_of(p, args), + car(p), T_REAL)); + return (sc->F); + } + return (sc->T); +} + +static inline s7_pointer leq_p_pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + return (make_boolean(sc, leq_b_7pp(sc, p1, p2))); +} + +static bool leq_b_ii(s7_int i1, s7_int i2) +{ + return (i1 <= i2); +} + +static bool leq_b_dd(s7_double i1, s7_double i2) +{ + return (i1 <= i2); +} + +static s7_pointer leq_p_dd(s7_scheme * sc, s7_double x1, s7_double x2) +{ + return (make_boolean(sc, x1 <= x2)); +} + +static s7_pointer leq_p_ii(s7_scheme * sc, s7_int x1, s7_int x2) +{ + return (make_boolean(sc, x1 <= x2)); +} + +static bool ratio_leq_pi(s7_pointer x, s7_int y) +{ + if ((y >= 0) && (numerator(x) <= 0)) + return (true); + if ((y <= 0) && (numerator(x) > 0)) + return (false); + if (denominator(x) < S7_INT32_MAX) + return (numerator(x) <= (y * denominator(x))); + return (fraction(x) <= y); +} + +static s7_pointer g_leq_xi(s7_scheme * sc, s7_pointer args) +{ + s7_int y = integer(cadr(args)); + s7_pointer x = car(args); + + if (is_t_integer(x)) + return (make_boolean(sc, integer(x) <= y)); + if (is_t_real(x)) + return (make_boolean(sc, real(x) <= y)); + if (is_t_ratio(x)) + return (make_boolean(sc, ratio_leq_pi(x, y))); +#if WITH_GMP + if (is_t_big_integer(x)) + return (make_boolean(sc, mpz_cmp_si(big_integer(x), y) <= 0)); + if (is_t_big_real(x)) { + if (mpfr_nan_p(big_real(x))) + return (sc->F); + return (make_boolean(sc, mpfr_cmp_si(big_real(x), y) <= 0)); + } + if (is_t_big_ratio(x)) + return (make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) <= 0)); +#endif + return (method_or_bust(sc, x, sc->leq_symbol, args, T_REAL, 1)); +} + +static bool leq_b_pi(s7_scheme * sc, s7_pointer p1, s7_int p2) +{ + if (is_t_integer(p1)) + return (integer(p1) <= p2); + if (is_t_real(p1)) + return (real(p1) <= p2); + if (is_t_ratio(p1)) + return (ratio_leq_pi(p1, p2)); +#if WITH_GMP + if (is_t_big_integer(p1)) + return (mpz_cmp_si(big_integer(p1), p2) <= 0); + if (is_t_big_real(p1)) + return (mpfr_cmp_si(big_real(p1), p2) <= 0); + if (is_t_big_ratio(p1)) + return (mpq_cmp_si(big_ratio(p1), p2, 1) <= 0); +#endif + return (leq_out_x(sc, p1, make_integer(sc, p2))); +} + +static s7_pointer leq_p_pi(s7_scheme * sc, s7_pointer p1, s7_int p2) +{ + return (make_boolean(sc, leq_b_pi(sc, p1, p2))); +} + +static s7_pointer g_leq_2(s7_scheme * sc, s7_pointer args) +{ + return (make_boolean(sc, leq_b_7pp(sc, car(args), cadr(args)))); +} + +static s7_pointer g_leq_ixx(s7_scheme * sc, s7_pointer args) +{ + s7_pointer p = cdr(args); + if (is_t_integer(car(p))) { + if (integer(car(args)) > integer(car(p))) { + if (!is_real_via_method(sc, cadr(p))) + return (wrong_type_argument + (sc, sc->leq_symbol, 3, cadr(p), T_REAL)); + return (sc->F); + } + if (is_t_integer(cadr(p))) + return ((integer(car(p)) > integer(cadr(p))) ? sc->F : sc->T); + } + return (g_less_or_equal(sc, args)); +} + +static s7_pointer leq_chooser(s7_scheme * sc, s7_pointer f, int32_t args, + s7_pointer expr, bool ops) +{ + if (args == 2) { + if (ops) { + s7_pointer arg2 = caddr(expr); + if ((is_t_integer(arg2)) && + (integer(arg2) < S7_INT32_MAX) && + (integer(arg2) > S7_INT32_MIN)) + return (sc->leq_xi); + } + return (sc->leq_2); + } + if ((args == 3) && (is_t_integer(cadr(expr)))) + return (sc->leq_ixx); + return (f); +} + + +/* ---------------------------------------- > ---------------------------------------- */ +static bool gt_out_x(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (has_active_methods(sc, x)) + return (find_and_apply_method + (sc, x, sc->gt_symbol, set_plist_2(sc, x, y)) != sc->F); + wrong_type_argument(sc, sc->gt_symbol, 1, x, T_REAL); + return (false); +} + +static bool gt_out_y(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (has_active_methods(sc, y)) + return (find_and_apply_method + (sc, y, sc->gt_symbol, set_plist_2(sc, x, y)) != sc->F); + wrong_type_argument(sc, sc->gt_symbol, 2, y, T_REAL); + return (false); +} + +static bool gt_b_7pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (type(x) == type(y)) { + if (is_t_integer(x)) + return (integer(x) > integer(y)); + if (is_t_real(x)) + return (real(x) > real(y)); + if (is_t_ratio(x)) + return (fraction(x) > fraction(y)); +#if WITH_GMP + if (is_t_big_integer(x)) + return (mpz_cmp(big_integer(x), big_integer(y)) > 0); + if (is_t_big_ratio(x)) + return (mpq_cmp(big_ratio(x), big_ratio(y)) > 0); + if (is_t_big_real(x)) + return (mpfr_greater_p(big_real(x), big_real(y))); +#endif + } + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_RATIO: + return (integer(x) > fraction(y)); /* ?? */ + case T_REAL: + return (integer(x) > real(y)); +#if WITH_GMP + case T_BIG_INTEGER: + return (mpz_cmp_si(big_integer(y), integer(x)) < 0); + case T_BIG_RATIO: + return (mpq_cmp_si(big_ratio(y), integer(x), 1) < 0); + case T_BIG_REAL: + return (mpfr_cmp_si(big_real(y), integer(x)) < 0); +#endif + default: + return (gt_out_y(sc, x, y)); + } + break; + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + return (fraction(x) > integer(y)); + case T_REAL: + return (fraction(x) > real(y)); +#if WITH_GMP + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return (mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0); + case T_BIG_RATIO: + return (mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) + < 0); + case T_BIG_REAL: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return (mpfr_cmp_q(big_real(y), sc->mpq_1) < 0); +#endif + default: + return (gt_out_y(sc, x, y)); + } + + case T_REAL: + switch (type(y)) { + case T_INTEGER: + return (real(x) > integer(y)); + case T_RATIO: + return (real(x) > fraction(y)); +#if WITH_GMP + case T_BIG_INTEGER: + if (is_NaN(real(x))) + return (false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return (mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0); + + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return (mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0); + + case T_BIG_REAL: + return (mpfr_cmp_d(big_real(y), real(x)) < 0); +#endif + default: + return (gt_out_y(sc, x, y)); + } + break; + +#if WITH_GMP + case T_BIG_INTEGER: + switch (type(y)) { + case T_INTEGER: + return (mpz_cmp_si(big_integer(x), integer(y)) > 0); + case T_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + return (mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) > + 0); + case T_REAL: + if (is_NaN(real(y))) + return (false); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + return (mpfr_cmp_d(sc->mpfr_1, real(y)) > 0); + case T_BIG_RATIO: + return (mpq_cmp_z(big_ratio(y), big_integer(x)) < 0); + case T_BIG_REAL: + return (mpfr_cmp_z(big_real(y), big_integer(x)) < 0); + default: + return (gt_out_y(sc, x, y)); + } + case T_BIG_RATIO: + switch (type(y)) { + case T_INTEGER: + return (mpq_cmp_si(big_ratio(x), integer(y), 1) > 0); + case T_RATIO: + return (mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) + > 0); + case T_REAL: + if (is_NaN(real(y))) + return (false); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return (mpfr_cmp_d(sc->mpfr_1, real(y)) > 0); + case T_BIG_INTEGER: + return (mpq_cmp_z(big_ratio(x), big_integer(y)) > 0); + case T_BIG_REAL: + return (mpfr_cmp_q(big_real(y), big_ratio(x)) < 0); + default: + return (gt_out_y(sc, x, y)); + } + + case T_BIG_REAL: + switch (type(y)) { + case T_INTEGER: + return (mpfr_cmp_si(big_real(x), integer(y)) > 0); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return (mpfr_cmp_q(big_real(x), sc->mpq_1) > 0); + case T_REAL: + return (mpfr_cmp_d(big_real(x), real(y)) > 0); + case T_BIG_INTEGER: + return (mpfr_cmp_z(big_real(x), big_integer(y)) > 0); + case T_BIG_RATIO: + return (mpfr_cmp_q(big_real(x), big_ratio(y)) > 0); + default: + return (gt_out_y(sc, x, y)); + } +#endif + default: + return (gt_out_x(sc, x, y)); + } + return (true); +} + +static s7_pointer g_greater(s7_scheme * sc, s7_pointer args) +{ +#define H_greater "(> x1 ...) returns #t if its arguments are in decreasing order" +#define Q_greater s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol) + + s7_pointer x = car(args), p = cdr(args); + + if (is_null(cdr(p))) + return (make_boolean(sc, gt_b_7pp(sc, x, car(p)))); + + for (; is_pair(p); x = car(p), p = cdr(p)) + if (!gt_b_7pp(sc, x, car(p))) { + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_real_via_method(sc, car(p))) + return (wrong_type_argument + (sc, sc->gt_symbol, position_of(p, args), + car(p), T_REAL)); + return (sc->F); + } + return (sc->T); +} + +static s7_pointer g_greater_xi(s7_scheme * sc, s7_pointer args) +{ + s7_int y = integer(cadr(args)); + s7_pointer x = car(args); + + if (is_t_integer(x)) + return (make_boolean(sc, integer(x) > y)); + if (is_t_real(x)) + return (make_boolean(sc, real(x) > y)); + if (is_t_ratio(x)) + return (make_boolean(sc, !ratio_leq_pi(x, y))); +#if WITH_GMP + if (is_t_big_integer(x)) + return (make_boolean(sc, mpz_cmp_si(big_integer(x), y) > 0)); + if (is_t_big_real(x)) + return (make_boolean(sc, mpfr_cmp_si(big_real(x), y) > 0)); + if (is_t_big_ratio(x)) + return (make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) > 0)); +#endif + return (method_or_bust_with_type + (sc, x, sc->gt_symbol, args, a_number_string, 1)); +} + +static s7_pointer g_greater_xf(s7_scheme * sc, s7_pointer args) +{ + s7_double y = real(cadr(args)); + s7_pointer x = car(args); + + if (is_t_real(x)) + return (make_boolean(sc, real(x) > y)); + + switch (type(x)) { + case T_INTEGER: + return (make_boolean(sc, integer(x) > y)); + + case T_RATIO: + /* (> 9223372036854775807/9223372036854775806 1.0) */ + if (denominator(x) < S7_INT32_MAX) /* y range check was handled in greater_chooser */ + return (make_boolean + (sc, (numerator(x) > (y * denominator(x))))); + return (make_boolean(sc, fraction(x) > y)); + +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + return (make_boolean + (sc, mpfr_cmp_z(sc->mpfr_1, big_integer(x)) < 0)); + + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + return (make_boolean + (sc, mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) < 0)); + + case T_BIG_REAL: + return (make_boolean(sc, mpfr_cmp_d(big_real(x), y) > 0)); +#endif + default: + return (method_or_bust_with_type + (sc, x, sc->gt_symbol, args, a_number_string, 1)); + } + return (sc->T); +} + +static inline s7_pointer gt_p_pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + return (make_boolean(sc, gt_b_7pp(sc, p1, p2))); +} + +static bool gt_b_ii(s7_int i1, s7_int i2) +{ + return (i1 > i2); +} + +static bool gt_b_dd(s7_double i1, s7_double i2) +{ + return (i1 > i2); +} + +static s7_pointer gt_p_dd(s7_scheme * sc, s7_double x1, s7_double x2) +{ + return (make_boolean(sc, x1 > x2)); +} + +static s7_pointer gt_p_ii(s7_scheme * sc, s7_int x1, s7_int x2) +{ + return (make_boolean(sc, x1 > x2)); +} + +static bool gt_b_pi(s7_scheme * sc, s7_pointer p1, s7_int p2) +{ + if (is_t_integer(p1)) + return (integer(p1) > p2); + if (is_t_real(p1)) + return (real(p1) > p2); + if (is_t_ratio(p1)) + return (!ratio_leq_pi(p1, p2)); +#if WITH_GMP + if (is_t_big_integer(p1)) + return (mpz_cmp_si(big_integer(p1), p2) > 0); + if (is_t_big_real(p1)) + return (mpfr_cmp_si(big_real(p1), p2) > 0); + if (is_t_big_ratio(p1)) + return (mpq_cmp_si(big_ratio(p1), p2, 1) > 0); +#endif + return (gt_out_x(sc, p1, make_integer(sc, p2))); +} + +static s7_pointer gt_p_pi(s7_scheme * sc, s7_pointer p1, s7_int p2) +{ + return (make_boolean(sc, gt_b_pi(sc, p1, p2))); +} + +static s7_pointer g_greater_2(s7_scheme * sc, s7_pointer args) +{ + /* ridiculous repetition, but overheads are killing this poor thing */ + s7_pointer x = car(args), y = cadr(args); + if (type(x) == type(y)) { + if (is_t_integer(x)) + return (make_boolean(sc, integer(x) > integer(y))); + if (is_t_real(x)) + return (make_boolean(sc, real(x) > real(y))); + if (is_t_ratio(x)) + return (make_boolean(sc, fraction(x) > fraction(y))); + } + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_RATIO: + return (gt_p_pp(sc, x, y)); + case T_REAL: + return (make_boolean(sc, integer(x) > real(y))); +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + case T_BIG_REAL: + return (gt_p_pp(sc, x, y)); +#endif + default: + return (make_boolean(sc, gt_out_y(sc, x, y))); + } + break; + + case T_RATIO: + return (gt_p_pp(sc, x, y)); + + case T_REAL: + switch (type(y)) { + case T_INTEGER: + return (make_boolean(sc, real(x) > integer(y))); + case T_RATIO: + return (make_boolean(sc, real(x) > fraction(y))); +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + case T_BIG_REAL: + return (gt_p_pp(sc, x, y)); +#endif + default: + return (make_boolean(sc, gt_out_y(sc, x, y))); + } + break; +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + case T_BIG_REAL: + return (gt_p_pp(sc, x, y)); +#endif + + default: + return (make_boolean(sc, gt_out_x(sc, x, y))); + } + return (sc->T); +} + +static s7_pointer greater_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if (args == 2) { + if (ops) { + s7_pointer arg2 = caddr(expr); + if ((is_t_integer(arg2)) && + (integer(arg2) < S7_INT32_MAX) && + (integer(arg2) > S7_INT32_MIN)) + return (sc->greater_xi); + if ((is_t_real(arg2)) && + (real(arg2) < S7_INT32_MAX) && (real(arg2) > S7_INT32_MIN)) + return (sc->greater_xf); + } + return (sc->greater_2); + } + return (f); +} + + +/* ---------------------------------------- >= ---------------------------------------- */ +static bool geq_out_x(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (has_active_methods(sc, x)) + return (find_and_apply_method + (sc, x, sc->geq_symbol, set_plist_2(sc, x, y)) != sc->F); + wrong_type_argument(sc, sc->geq_symbol, 1, x, T_REAL); + return (false); +} + +static bool geq_out_y(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (has_active_methods(sc, y)) + return (find_and_apply_method + (sc, y, sc->geq_symbol, set_plist_2(sc, x, y)) != sc->F); + wrong_type_argument(sc, sc->geq_symbol, 2, y, T_REAL); + return (false); +} + +static bool geq_b_7pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + if (type(x) == type(y)) { + if (is_t_integer(x)) + return (integer(x) >= integer(y)); + if (is_t_real(x)) + return (real(x) >= real(y)); + if (is_t_ratio(x)) + return (fraction(x) >= fraction(y)); +#if WITH_GMP + if (is_t_big_integer(x)) + return (mpz_cmp(big_integer(x), big_integer(y)) >= 0); + if (is_t_big_ratio(x)) + return (mpq_cmp(big_ratio(x), big_ratio(y)) >= 0); + if (is_t_big_real(x)) + return (mpfr_greaterequal_p(big_real(x), big_real(y))); +#endif + } + switch (type(x)) { + case T_INTEGER: + switch (type(y)) { + case T_RATIO: + return (integer(x) >= fraction(y)); /* ?? */ + case T_REAL: + return (integer(x) >= real(y)); +#if WITH_GMP + case T_BIG_INTEGER: + return (mpz_cmp_si(big_integer(y), integer(x)) <= 0); + case T_BIG_RATIO: + return (mpq_cmp_si(big_ratio(y), integer(x), 1) <= 0); + case T_BIG_REAL: + return ((!mpfr_nan_p(big_real(y))) + && (mpfr_cmp_si(big_real(y), integer(x)) <= 0)); +#endif + default: + return (geq_out_y(sc, x, y)); + } + break; + + case T_RATIO: + switch (type(y)) { + case T_INTEGER: + return (fraction(x) >= integer(y)); + case T_REAL: + return (fraction(x) >= real(y)); +#if WITH_GMP + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return (mpq_cmp_z(sc->mpq_1, big_integer(y)) >= 0); + case T_BIG_RATIO: + return (mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) + <= 0); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) + return (false); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return (mpfr_cmp_q(big_real(y), sc->mpq_1) <= 0); +#endif + default: + return (geq_out_y(sc, x, y)); + } + + case T_REAL: + switch (type(y)) { + case T_INTEGER: + return (real(x) >= integer(y)); + case T_RATIO: + return (real(x) >= fraction(y)); +#if WITH_GMP + case T_BIG_INTEGER: + if (is_NaN(real(x))) + return (false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return (mpfr_cmp_z(sc->mpfr_1, big_integer(y)) >= 0); + case T_BIG_RATIO: + if (is_NaN(real(x))) + return (false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return (mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) >= 0); + case T_BIG_REAL: + if (is_NaN(real(x))) + return (false); + return ((!mpfr_nan_p(big_real(y))) + && (mpfr_cmp_d(big_real(y), real(x)) <= 0)); +#endif + default: + return (geq_out_y(sc, x, y)); + } + break; + +#if WITH_GMP + case T_BIG_INTEGER: + switch (type(y)) { + case T_INTEGER: + return (mpz_cmp_si(big_integer(x), integer(y)) >= 0); + case T_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + return (mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) >= + 0); + case T_REAL: + if (is_NaN(real(y))) + return (false); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + return (mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0); + case T_BIG_RATIO: + return (mpq_cmp_z(big_ratio(y), big_integer(x)) <= 0); + case T_BIG_REAL: + return ((!mpfr_nan_p(big_real(y))) + && (mpfr_cmp_z(big_real(y), big_integer(x)) <= 0)); + default: + return (geq_out_y(sc, x, y)); + } + case T_BIG_RATIO: + switch (type(y)) { + case T_INTEGER: + return (mpq_cmp_si(big_ratio(x), integer(y), 1) >= 0); + case T_RATIO: + return (mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) + >= 0); + case T_REAL: + if (is_NaN(real(y))) + return (false); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return (mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0); + case T_BIG_INTEGER: + return (mpq_cmp_z(big_ratio(x), big_integer(y)) >= 0); + case T_BIG_REAL: + return ((!mpfr_nan_p(big_real(y))) + && (mpfr_cmp_q(big_real(y), big_ratio(x)) <= 0)); + default: + return (geq_out_y(sc, x, y)); + } + + case T_BIG_REAL: + if ((is_real(y)) && (mpfr_nan_p(big_real(x)))) + return (false); + switch (type(y)) { + case T_INTEGER: + return (mpfr_cmp_si(big_real(x), integer(y)) >= 0); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return (mpfr_cmp_q(big_real(x), sc->mpq_1) >= 0); + case T_REAL: + return ((!is_NaN(real(y))) + && (mpfr_cmp_d(big_real(x), real(y)) >= 0)); + case T_BIG_INTEGER: + return (mpfr_cmp_z(big_real(x), big_integer(y)) >= 0); + case T_BIG_RATIO: + return (mpfr_cmp_q(big_real(x), big_ratio(y)) >= 0); + default: + return (geq_out_y(sc, x, y)); + } +#endif + default: + return (geq_out_x(sc, x, y)); + } + return (true); +} + +static s7_pointer g_greater_or_equal(s7_scheme * sc, s7_pointer args) +{ +#define H_greater_or_equal "(>= x1 ...) returns #t if its arguments are in non-increasing order" +#define Q_greater_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol) + + s7_pointer x = car(args), p = cdr(args); + + if (is_null(cdr(p))) + return (make_boolean(sc, geq_b_7pp(sc, x, car(p)))); + + for (; is_pair(p); x = car(p), p = cdr(p)) + if (!geq_b_7pp(sc, x, car(p))) { + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_real_via_method(sc, car(p))) + return (wrong_type_argument + (sc, sc->geq_symbol, position_of(p, args), + car(p), T_REAL)); + return (sc->F); + } + return (sc->T); +} + +static inline s7_pointer geq_p_pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + return (make_boolean(sc, geq_b_7pp(sc, p1, p2))); +} + +static bool geq_b_ii(s7_int i1, s7_int i2) +{ + return (i1 >= i2); +} + +static bool geq_b_dd(s7_double i1, s7_double i2) +{ + return (i1 >= i2); +} + +static s7_pointer geq_p_dd(s7_scheme * sc, s7_double x1, s7_double x2) +{ + return (make_boolean(sc, x1 >= x2)); +} + +static s7_pointer geq_p_ii(s7_scheme * sc, s7_int x1, s7_int x2) +{ + return (make_boolean(sc, x1 >= x2)); +} + +static s7_pointer g_geq_2(s7_scheme * sc, s7_pointer args) +{ + return (make_boolean(sc, geq_b_7pp(sc, car(args), cadr(args)))); +} + +static s7_pointer g_geq_xf(s7_scheme * sc, s7_pointer args) +{ + s7_double y = real(cadr(args)); + s7_pointer x = car(args); + return (make_boolean + (sc, + ((is_t_real(x)) ? (real(x) >= y) : + geq_b_7pp(sc, car(args), cadr(args))))); +} + +static s7_pointer g_geq_xi(s7_scheme * sc, s7_pointer args) +{ + s7_int y = integer(cadr(args)); + s7_pointer x = car(args); + + if (is_t_integer(x)) + return (make_boolean(sc, integer(x) >= y)); + if (is_t_real(x)) + return (make_boolean(sc, real(x) >= y)); + if (is_t_ratio(x)) + return (make_boolean(sc, !ratio_lt_pi(x, y))); +#if WITH_GMP + if (is_t_big_integer(x)) + return (make_boolean(sc, mpz_cmp_si(big_integer(x), y) >= 0)); + if (is_t_big_real(x)) { + if (mpfr_nan_p(big_real(x))) + return (sc->F); + return (make_boolean(sc, mpfr_cmp_si(big_real(x), y) >= 0)); + } + if (is_t_big_ratio(x)) + return (make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) >= 0)); +#endif + return (method_or_bust(sc, x, sc->geq_symbol, args, T_REAL, 1)); +} + +static bool geq_b_pi(s7_scheme * sc, s7_pointer p1, s7_int p2) +{ + if (is_t_integer(p1)) + return (integer(p1) >= p2); + if (is_t_real(p1)) + return (real(p1) >= p2); + if (is_t_ratio(p1)) + return (!ratio_lt_pi(p1, p2)); +#if WITH_GMP + if (is_t_big_integer(p1)) + return (mpz_cmp_si(big_integer(p1), p2) >= 0); + if (is_t_big_real(p1)) + return ((!mpfr_nan_p(big_real(p1))) + && (mpfr_cmp_si(big_real(p1), p2) >= 0)); + if (is_t_big_ratio(p1)) + return (mpq_cmp_si(big_ratio(p1), p2, 1) >= 0); +#endif + return (geq_out_x(sc, p1, make_integer(sc, p2))); +} + +static s7_pointer geq_p_pi(s7_scheme * sc, s7_pointer p1, s7_int p2) +{ + return (make_boolean(sc, geq_b_pi(sc, p1, p2))); +} + +static s7_pointer geq_chooser(s7_scheme * sc, s7_pointer f, int32_t args, + s7_pointer expr, bool ops) +{ + if (args == 2) { + if (ops) { + s7_pointer arg2 = caddr(expr); + if ((is_t_integer(arg2)) && + (integer(arg2) < S7_INT32_MAX) && + (integer(arg2) > S7_INT32_MIN)) + return (sc->geq_xi); + if ((is_t_real(arg2)) && + (real(arg2) < S7_INT32_MAX) && (real(arg2) > S7_INT32_MIN)) + return (sc->geq_xf); + } + return (sc->geq_2); + } + return (f); +} + + +/* ---------------------------------------- real-part ---------------------------------------- */ +s7_double s7_real_part(s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + return ((s7_double) integer(x)); + case T_RATIO: + return (fraction(x)); + case T_REAL: + return (real(x)); + case T_COMPLEX: + return (real_part(x)); +#if WITH_GMP + case T_BIG_INTEGER: + return ((s7_double) mpz_get_si(big_integer(x))); + case T_BIG_RATIO: + return ((s7_double) + ((long_double) mpz_get_si(mpq_numref(big_ratio(x))) / + (long_double) mpz_get_si(mpq_denref(big_ratio(x))))); + case T_BIG_REAL: + return ((s7_double) mpfr_get_d(big_real(x), MPFR_RNDN)); + case T_BIG_COMPLEX: + return ((s7_double) + mpfr_get_d(mpc_realref(big_complex(x)), MPFR_RNDN)); +#endif + } + return (0.0); +} + +static s7_pointer real_part_p_p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_complex(p)) + return (make_real(sc, real_part(p))); + switch (type(p)) { + case T_INTEGER: + case T_RATIO: + case T_REAL: + return (p); +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + case T_BIG_REAL: + return (p); + case T_BIG_COMPLEX: + { + s7_pointer x; + new_cell(sc, x, T_BIG_REAL); + big_real_bgf(x) = alloc_bigflt(sc); + add_big_real(sc, x); + mpc_real(big_real(x), big_complex(p), MPFR_RNDN); + return (x); + } +#endif + default: + return (method_or_bust_with_type_one_arg_p + (sc, p, sc->real_part_symbol, a_number_string)); + } +} + +static s7_pointer g_real_part(s7_scheme * sc, s7_pointer args) +{ +#define H_real_part "(real-part num) returns the real part of num" +#define Q_real_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) + return (real_part_p_p(sc, car(args))); +} + + +/* ---------------------------------------- imag-part ---------------------------------------- */ +s7_double s7_imag_part(s7_pointer x) +{ + if (is_t_complex(x)) + return (imag_part(x)); +#if WITH_GMP + if (is_t_big_complex(x)) + return ((s7_double) + mpfr_get_d(mpc_imagref(big_complex(x)), MPFR_RNDN)); +#endif + return (0.0); +} + +static s7_pointer imag_part_p_p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_complex(p)) + return (make_real(sc, imag_part(p))); + switch (type(p)) { + case T_INTEGER: + case T_RATIO: + return (int_zero); + case T_REAL: + return (real_zero); +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + return (int_zero); + case T_BIG_REAL: + return (real_zero); + case T_BIG_COMPLEX: + { + s7_pointer x; + new_cell(sc, x, T_BIG_REAL); + big_real_bgf(x) = alloc_bigflt(sc); + add_big_real(sc, x); + mpc_imag(big_real(x), big_complex(p), MPFR_RNDN); + return (x); + } +#endif + default: + return (method_or_bust_with_type_one_arg_p + (sc, p, sc->imag_part_symbol, a_number_string)); + } +} + +static s7_pointer g_imag_part(s7_scheme * sc, s7_pointer args) +{ +#define H_imag_part "(imag-part num) returns the imaginary part of num" +#define Q_imag_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) + /* currently (imag-part +nan.0) -> 0.0 ? it's true but maybe confusing */ + return (imag_part_p_p(sc, car(args))); +} + + +/* ---------------------------------------- numerator denominator ---------------------------------------- */ +static s7_int numerator_i_7p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_ratio(p)) + return (numerator(p)); + if (is_t_integer(p)) + return (integer(p)); +#if WITH_GMP + if (is_t_big_ratio(p)) + return (mpz_get_si(mpq_numref(big_ratio(p)))); + if (is_t_big_integer(p)) + return (mpz_get_si(big_integer(p))); +#endif + return (integer + (method_or_bust_with_type_one_arg_p + (sc, p, sc->numerator_symbol, a_rational_string))); +} + +static s7_pointer g_numerator(s7_scheme * sc, s7_pointer args) +{ +#define H_numerator "(numerator rat) returns the numerator of the rational number rat" +#define Q_numerator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol) + + s7_pointer x = car(args); + switch (type(x)) { + case T_RATIO: + return (make_integer(sc, numerator(x))); + case T_INTEGER: + return (x); +#if WITH_GMP + case T_BIG_INTEGER: + return (x); + case T_BIG_RATIO: + return (mpz_to_integer(sc, mpq_numref(big_ratio(x)))); +#endif + default: + return (method_or_bust_with_type_one_arg + (sc, x, sc->numerator_symbol, args, a_rational_string)); + } +} + + +static s7_pointer g_denominator(s7_scheme * sc, s7_pointer args) +{ +#define H_denominator "(denominator rat) returns the denominator of the rational number rat" +#define Q_denominator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol) + + s7_pointer x = car(args); + switch (type(x)) { + case T_RATIO: + return (make_integer(sc, denominator(x))); + case T_INTEGER: + return (int_one); +#if WITH_GMP + case T_BIG_INTEGER: + return (int_one); + case T_BIG_RATIO: + return (mpz_to_integer(sc, mpq_denref(big_ratio(x)))); +#endif + default: + return (method_or_bust_with_type_one_arg + (sc, x, sc->denominator_symbol, args, a_rational_string)); + } +} + +static s7_int denominator_i_7p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_ratio(p)) + return (denominator(p)); + if (is_t_integer(p)) + return (1); +#if WITH_GMP + if (is_t_big_ratio(p)) + return (mpz_get_si(mpq_denref(big_ratio(p)))); + if (is_t_big_integer(p)) + return (1); +#endif + return (integer + (method_or_bust_with_type_one_arg_p + (sc, p, sc->denominator_symbol, a_rational_string))); +} + + +/* ---------------------------------------- number? bignum? complex? integer? byte? rational? real? ---------------------------------------- */ +static s7_pointer g_is_number(s7_scheme * sc, s7_pointer args) +{ +#define H_is_number "(number? obj) returns #t if obj is a number" +#define Q_is_number sc->pl_bt + check_boolean_method(sc, is_number, sc->is_number_symbol, args); +} + +bool s7_is_bignum(s7_pointer obj) +{ + return (is_big_number(obj)); +} + +static s7_pointer g_is_bignum(s7_scheme * sc, s7_pointer args) +{ +#define H_is_bignum "(bignum? obj) returns #t if obj is a multiprecision number." +#define Q_is_bignum sc->pl_bt + return (s7_make_boolean(sc, is_big_number(car(args)))); +} + +static s7_pointer g_is_integer(s7_scheme * sc, s7_pointer args) +{ +#define H_is_integer "(integer? obj) returns #t if obj is an integer" +#define Q_is_integer sc->pl_bt + check_boolean_method(sc, s7_is_integer, sc->is_integer_symbol, args); +} + +static bool is_byte(s7_pointer p) +{ + return ((s7_is_integer(p)) && (s7_integer(p) >= 0) + && (s7_integer(p) < 256)); +} + +static s7_pointer g_is_byte(s7_scheme * sc, s7_pointer args) +{ +#define H_is_byte "(byte? obj) returns #t if obj is a byte (an integer between 0 and 255)" +#define Q_is_byte sc->pl_bt + check_boolean_method(sc, is_byte, sc->is_byte_symbol, args); +} + +static s7_pointer g_is_real(s7_scheme * sc, s7_pointer args) +{ +#define H_is_real "(real? obj) returns #t if obj is a real number" +#define Q_is_real sc->pl_bt + check_boolean_method(sc, is_real, sc->is_real_symbol, args); +} + +static s7_pointer g_is_complex(s7_scheme * sc, s7_pointer args) +{ +#define H_is_complex "(complex? obj) returns #t if obj is a number" +#define Q_is_complex sc->pl_bt + check_boolean_method(sc, is_number, sc->is_complex_symbol, args); +} + +static s7_pointer g_is_rational(s7_scheme * sc, s7_pointer args) +{ +#define H_is_rational "(rational? obj) returns #t if obj is a rational number (either an integer or a ratio)" +#define Q_is_rational sc->pl_bt + check_boolean_method(sc, is_rational, sc->is_rational_symbol, args); + /* in the non-gmp case, (rational? 455702434782048082459/86885567283849955830) -> #f, not #t, and similarly for exact? etc. */ +} + +static s7_pointer g_is_float(s7_scheme * sc, s7_pointer args) +{ +#define H_is_float "(float? x) returns #t is x is real and not rational." +#define Q_is_float sc->pl_bt + s7_pointer p = car(args); +#if WITH_GMP + return (make_boolean(sc, (is_t_real(p)) || (is_t_big_real(p)))); /* (float? pi) */ +#else + return (make_boolean(sc, is_t_real(p))); +#endif +} + +#if WITH_GMP +static bool is_float_b(s7_pointer p) +{ + return ((is_t_real(p)) || (is_t_big_real(p))); +} +#else +static bool is_float_b(s7_pointer p) +{ + return (is_t_real(p)); +} +#endif + + +/* ---------------------------------------- nan? ---------------------------------------- */ +static bool is_nan_b_7p(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + case T_RATIO: + return (false); + case T_REAL: + return (is_NaN(real(x))); + case T_COMPLEX: + return ((is_NaN(real_part(x))) || (is_NaN(imag_part(x)))); +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + return (false); + case T_BIG_REAL: + return (mpfr_nan_p(big_real(x)) != 0); + case T_BIG_COMPLEX: + return ((mpfr_nan_p(mpc_realref(big_complex(x))) != 0) + || (mpfr_nan_p(mpc_imagref(big_complex(x))) != 0)); +#endif + default: + if (is_number(x)) + return (method_or_bust_with_type_one_arg_p + (sc, x, sc->is_nan_symbol, a_number_string) != sc->F); + } + return (false); +} + +static s7_pointer g_is_nan(s7_scheme * sc, s7_pointer args) +{ +#define H_is_nan "(nan? obj) returns #t if obj is a NaN" +#define Q_is_nan sc->pl_bt + return (make_boolean(sc, is_nan_b_7p(sc, car(args)))); +} + + +/* ---------------------------------------- infinite? ---------------------------------------- */ +static bool is_infinite_b_7p(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + case T_RATIO: + return (false); + case T_REAL: + return (is_inf(real(x))); + case T_COMPLEX: + return ((is_inf(real_part(x))) || (is_inf(imag_part(x)))); +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + return (false); + case T_BIG_REAL: + return (mpfr_inf_p(big_real(x)) != 0); + case T_BIG_COMPLEX: + return ((mpfr_inf_p(mpc_realref(big_complex(x))) != 0) || + (mpfr_inf_p(mpc_imagref(big_complex(x))) != 0)); +#endif + default: + if (is_number(x)) + return (method_or_bust_with_type_one_arg_p + (sc, x, sc->is_infinite_symbol, + a_number_string) != sc->F); + } + return (false); +} + +static s7_pointer g_is_infinite(s7_scheme * sc, s7_pointer args) +{ +#define H_is_infinite "(infinite? obj) returns #t if obj is an infinite real" +#define Q_is_infinite sc->pl_bt + return (make_boolean(sc, is_infinite_b_7p(sc, car(args)))); +} + + +/* ---------------------------------------- even? odd?---------------------------------------- */ +static bool is_even_b_7p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_integer(p)) + return ((integer(p) & 1) == 0); +#if WITH_GMP + if (is_t_big_integer(p)) + return (mpz_even_p(big_integer(p))); +#endif + return (method_or_bust_one_arg_p(sc, p, sc->is_even_symbol, T_INTEGER) + != sc->F); +} + +static bool is_even_i(s7_int i1) +{ + return ((i1 & 1) == 0); +} + +static s7_pointer g_is_even(s7_scheme * sc, s7_pointer args) +{ +#define H_is_even "(even? int) returns #t if the integer int32_t is even" +#define Q_is_even s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol) + return (make_boolean(sc, is_even_b_7p(sc, car(args)))); +} + + +static bool is_odd_b_7p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_integer(p)) + return ((integer(p) & 1) == 1); +#if WITH_GMP + if (is_t_big_integer(p)) + return (mpz_odd_p(big_integer(p))); +#endif + return (method_or_bust_one_arg_p(sc, p, sc->is_odd_symbol, T_INTEGER) + != sc->F); +} + +static bool is_odd_i(s7_int i1) +{ + return ((i1 & 1) == 1); +} + +static s7_pointer g_is_odd(s7_scheme * sc, s7_pointer args) +{ +#define H_is_odd "(odd? int) returns #t if the integer int32_t is odd" +#define Q_is_odd s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol) + return (make_boolean(sc, is_odd_b_7p(sc, car(args)))); +} + + +/* ---------------------------------------- zero? ---------------------------------------- */ +static bool is_zero(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + return (integer(x) == 0); + case T_REAL: + return (real(x) == 0.0); +#if WITH_GMP + case T_BIG_INTEGER: + return (mpz_cmp_ui(big_integer(x), 0) == 0); + case T_BIG_REAL: + return (mpfr_zero_p(big_real(x))); +#endif + default: + return (false); /* ratios and complex numbers here are already collapsed into integers and reals */ + } +} + +static bool is_zero_b_7p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_integer(p)) + return (integer(p) == 0); + if (is_t_real(p)) + return (real(p) == 0.0); + if (is_number(p)) + return (is_zero(sc, p)); + return (method_or_bust_with_type_one_arg_p + (sc, p, sc->is_zero_symbol, a_number_string) != sc->F); +} + +static s7_pointer g_is_zero(s7_scheme * sc, s7_pointer args) +{ +#define H_is_zero "(zero? num) returns #t if the number num is zero" +#define Q_is_zero sc->pl_bn + return (make_boolean(sc, is_zero_b_7p(sc, car(args)))); +} + +static s7_pointer is_zero_p_p(s7_scheme * sc, s7_pointer p) +{ + return (make_boolean(sc, is_zero_b_7p(sc, p))); +} + +static bool is_zero_i(s7_int p) +{ + return (p == 0); +} + +static bool is_zero_d(s7_double p) +{ + return (p == 0.0); +} + + +/* -------------------------------- positive? -------------------------------- */ +static bool is_positive(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + return (integer(x) > 0); + case T_RATIO: + return (numerator(x) > 0); + case T_REAL: + return (real(x) > 0.0); +#if WITH_GMP + case T_BIG_INTEGER: + return (mpz_cmp_ui(big_integer(x), 0) > 0); + case T_BIG_RATIO: + return (mpq_cmp_ui(big_ratio(x), 0, 1) > 0); + case T_BIG_REAL: + return (mpfr_cmp_ui(big_real(x), 0) > 0); +#endif + default: + return (simple_wrong_type_argument + (sc, sc->is_positive_symbol, x, T_REAL)); + } +} + +static bool is_positive_b_7p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_integer(p)) + return (integer(p) > 0); + if (is_t_real(p)) + return (real(p) > 0.0); + if (is_number(p)) + return (is_positive(sc, p)); + return (method_or_bust_one_arg_p(sc, p, sc->is_positive_symbol, T_REAL) + != sc->F); +} + +static s7_pointer g_is_positive(s7_scheme * sc, s7_pointer args) +{ +#define H_is_positive "(positive? num) returns #t if the real number num is positive (greater than 0)" +#define Q_is_positive s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol) + return (make_boolean(sc, is_positive_b_7p(sc, car(args)))); +} + +static s7_pointer is_positive_p_p(s7_scheme * sc, s7_pointer p) +{ + return (make_boolean(sc, is_positive_b_7p(sc, p))); +} + +static bool is_positive_i(s7_int p) +{ + return (p > 0); +} + +static bool is_positive_d(s7_double p) +{ + return (p > 0.0); +} + + +/* -------------------------------- negative? -------------------------------- */ +static bool is_negative(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_INTEGER: + return (integer(x) < 0); + case T_RATIO: + return (numerator(x) < 0); + case T_REAL: + return (real(x) < 0.0); +#if WITH_GMP + case T_BIG_INTEGER: + return (mpz_cmp_ui(big_integer(x), 0) < 0); + case T_BIG_RATIO: + return (mpq_cmp_ui(big_ratio(x), 0, 1) < 0); + case T_BIG_REAL: + return (mpfr_cmp_ui(big_real(x), 0) < 0); +#endif + default: + return (simple_wrong_type_argument + (sc, sc->is_negative_symbol, x, T_REAL)); + } +} + +static bool is_negative_b_7p(s7_scheme * sc, s7_pointer p) +{ + if (is_t_integer(p)) + return (integer(p) < 0); + if (is_t_real(p)) + return (real(p) < 0.0); + if (is_number(p)) + return (is_negative(sc, p)); + return (method_or_bust_one_arg_p(sc, p, sc->is_negative_symbol, T_REAL) + != sc->F); +} + +static s7_pointer g_is_negative(s7_scheme * sc, s7_pointer args) +{ +#define H_is_negative "(negative? num) returns #t if the real number num is negative (less than 0)" +#define Q_is_negative s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol) + return (make_boolean(sc, is_negative_b_7p(sc, car(args)))); +} + +static s7_pointer is_negative_p_p(s7_scheme * sc, s7_pointer p) +{ + return (make_boolean(sc, is_negative_b_7p(sc, p))); +} + +static bool is_negative_i(s7_int p) +{ + return (p < 0); +} + +static bool is_negative_d(s7_double p) +{ + return (p < 0.0); +} + + +#if (!WITH_PURE_S7) +/* ---------------------------------------- exact<->inexact exact? inexact? ---------------------------------------- */ +static s7_pointer g_exact_to_inexact(s7_scheme * sc, s7_pointer args) +{ +#define H_exact_to_inexact "(exact->inexact num) converts num to an inexact number; (exact->inexact 3/2) = 1.5" +#define Q_exact_to_inexact s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_number_symbol) + /* arg can be complex -> itself! */ + return (exact_to_inexact(sc, car(args))); +} + +static s7_pointer g_inexact_to_exact(s7_scheme * sc, s7_pointer args) +{ +#define H_inexact_to_exact "(inexact->exact num) converts num to an exact number; (inexact->exact 1.5) = 3/2" +#define Q_inexact_to_exact s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol) + return (inexact_to_exact(sc, car(args))); +} + +static s7_pointer g_is_exact(s7_scheme * sc, s7_pointer args) +{ +#define H_is_exact "(exact? num) returns #t if num is exact (an integer or a ratio)" +#define Q_is_exact sc->pl_bn + + s7_pointer x = car(args); + switch (type(x)) { + case T_INTEGER: + case T_BIG_INTEGER: + case T_RATIO: + case T_BIG_RATIO: + return (sc->T); + case T_REAL: + case T_BIG_REAL: + case T_COMPLEX: + case T_BIG_COMPLEX: + return (sc->F); + default: + return (method_or_bust_with_type_one_arg + (sc, x, sc->is_exact_symbol, args, a_number_string)); + } +} + +static bool is_exact_b_7p(s7_scheme * sc, s7_pointer p) +{ + if (!is_number(p)) + return (method_or_bust_with_type_one_arg + (sc, p, sc->is_exact_symbol, set_plist_1(sc, p), + a_number_string) != sc->F); + return (is_rational(p)); +} + + +static s7_pointer g_is_inexact(s7_scheme * sc, s7_pointer args) +{ +#define H_is_inexact "(inexact? num) returns #t if num is inexact (neither an integer nor a ratio)" +#define Q_is_inexact sc->pl_bn + + s7_pointer x = car(args); + switch (type(x)) { + case T_INTEGER: + case T_BIG_INTEGER: + case T_RATIO: + case T_BIG_RATIO: + return (sc->F); + case T_REAL: + case T_BIG_REAL: + case T_COMPLEX: + case T_BIG_COMPLEX: + return (sc->T); + default: + return (method_or_bust_with_type_one_arg + (sc, x, sc->is_inexact_symbol, args, a_number_string)); + } +} + +static bool is_inexact_b_7p(s7_scheme * sc, s7_pointer p) +{ + if (!is_number(p)) + return (method_or_bust_with_type_one_arg + (sc, p, sc->is_inexact_symbol, set_plist_1(sc, p), + a_number_string) != sc->F); + return (!is_rational(p)); +} + + +/* ---------------------------------------- integer-length ---------------------------------------- */ +static int32_t integer_length(s7_int a) +{ + if (a < 0) { + if (a == S7_INT64_MIN) + return (63); + a = -a; + } + if (a < 256LL) + return (intlen_bits[a]); /* in gmp, sbcl and clisp (integer-length 0) is 0 */ + if (a < 65536LL) + return (8 + intlen_bits[a >> 8]); + if (a < 16777216LL) + return (16 + intlen_bits[a >> 16]); + if (a < 4294967296LL) + return (24 + intlen_bits[a >> 24]); + if (a < 1099511627776LL) + return (32 + intlen_bits[a >> 32]); + if (a < 281474976710656LL) + return (40 + intlen_bits[a >> 40]); + if (a < 72057594037927936LL) + return (48 + intlen_bits[a >> 48]); + return (56 + intlen_bits[a >> 56]); +} + +static s7_pointer g_integer_length(s7_scheme * sc, s7_pointer args) +{ +#define H_integer_length "(integer-length arg) returns the number of bits required to represent the integer 'arg': (ceiling (log (if (< arg 0) (- arg) (+ arg 1)) 2))" +#define Q_integer_length sc->pcl_i + + s7_pointer p = car(args); + if (is_t_integer(p)) { + s7_int x; + x = integer(p); + return ((x < + 0) ? small_int(integer_length(-(x + 1))) : + small_int(integer_length(x))); + } +#if WITH_GMP + if (is_t_big_integer(p)) + return (make_integer(sc, mpz_sizeinbase(big_integer(p), 2))); +#endif + return (method_or_bust_one_arg + (sc, p, sc->integer_length_symbol, args, T_INTEGER)); +} + +static s7_int integer_length_i_i(s7_int x) +{ + return ((x < 0) ? integer_length(-(x + 1)) : integer_length(x)); +} +#endif /* !pure s7 */ + + +/* ---------------------------------------- integer-decode-float ---------------------------------------- */ +static s7_pointer g_integer_decode_float(s7_scheme * sc, s7_pointer args) +{ +#define H_integer_decode_float "(integer-decode-float x) returns a list containing the significand, exponent, and \ +sign of 'x' (1 = positive, -1 = negative). (integer-decode-float 0.0): (0 0 1)" +#define Q_integer_decode_float s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_float_symbol) + + typedef union { + int64_t ix; + double fx; + } decode_float_t; + + decode_float_t num; + s7_pointer x = car(args); + + if (is_t_real(x)) { + if (real(x) == 0.0) + return (list_3(sc, int_zero, int_zero, int_one)); + num.fx = (double) real(x); + return (list_3(sc, + make_integer(sc, + (s7_int) ((num.ix & 0xfffffffffffffLL) + | 0x10000000000000LL)), + make_integer(sc, + (s7_int) (((num.ix & + 0x7fffffffffffffffLL) + >> 52) - 1023 - 52)), + ((num.ix & 0x8000000000000000LL) != + 0) ? minus_one : int_one)); + } +#if WITH_GMP + if (is_t_big_real(x)) { + mp_exp_t exp_n; + bool neg; + exp_n = mpfr_get_z_exp(sc->mpz_1, big_real(x)); + neg = (mpz_cmp_ui(sc->mpz_1, 0) < 0); + if (neg) + mpz_abs(sc->mpz_1, sc->mpz_1); + return (list_3 + (sc, mpz_to_integer(sc, sc->mpz_1), + make_integer(sc, exp_n), (neg) ? minus_one : int_one)); + /* not gmp: (integer-decode-float +nan.0): (6755399441055744 972 1), gmp: (integer-decode-float (bignum +nan.0)): (0 -1073741823 1) */ + } +#endif + return (method_or_bust_with_type_one_arg + (sc, x, sc->integer_decode_float_symbol, args, + wrap_string(sc, "a non-rational real", 19))); +} + + +/* -------------------------------- logior -------------------------------- */ +#if WITH_GMP +static s7_pointer big_logior(s7_scheme * sc, s7_int start, s7_pointer args) +{ + s7_pointer x; + mpz_set_si(sc->mpz_1, start); + + for (x = args; is_not_null(x); x = cdr(x)) { + s7_pointer i = car(x); + switch (type(i)) { + case T_BIG_INTEGER: + mpz_ior(sc->mpz_1, sc->mpz_1, big_integer(i)); + break; + case T_INTEGER: + mpz_set_si(sc->mpz_2, integer(i)); + mpz_ior(sc->mpz_1, sc->mpz_1, sc->mpz_2); + break; + default: + if (!is_integer_via_method(sc, i)) + return (wrong_type_argument + (sc, sc->logior_symbol, position_of(x, args), i, + T_INTEGER)); + return (method_or_bust + (sc, i, sc->logior_symbol, + set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), + T_INTEGER, position_of(x, args))); + } + } + return (mpz_to_integer(sc, sc->mpz_1)); +} +#endif + +static s7_pointer g_logior(s7_scheme * sc, s7_pointer args) +{ +#define H_logior "(logior int32_t ...) returns the OR of its integer arguments (the bits that are on in any of the arguments)" +#define Q_logior sc->pcl_i + + s7_int result = 0; + s7_pointer x; + for (x = args; is_not_null(x); x = cdr(x)) { +#if WITH_GMP + if (is_t_big_integer(car(x))) + return (big_logior(sc, result, x)); +#endif + if (!is_t_integer(car(x))) + return (method_or_bust(sc, car(x), sc->logior_symbol, + (result == 0) ? x : set_ulist_1(sc, + make_integer + (sc, + result), + x), + T_INTEGER, position_of(x, args))); + result |= integer(car(x)); + } + return (make_integer(sc, result)); +} + +static s7_int logior_i_ii(s7_int i1, s7_int i2) +{ + return (i1 | i2); +} + +static s7_int logior_i_iii(s7_int i1, s7_int i2, s7_int i3) +{ + return (i1 | i2 | i3); +} + + +/* -------------------------------- logxor -------------------------------- */ +#if WITH_GMP +static s7_pointer big_logxor(s7_scheme * sc, s7_int start, s7_pointer args) +{ + s7_pointer x; + mpz_set_si(sc->mpz_1, start); + for (x = args; is_not_null(x); x = cdr(x)) { + s7_pointer i = car(x); + switch (type(i)) { + case T_BIG_INTEGER: + mpz_xor(sc->mpz_1, sc->mpz_1, big_integer(i)); + break; + case T_INTEGER: + mpz_set_si(sc->mpz_2, integer(i)); + mpz_xor(sc->mpz_1, sc->mpz_1, sc->mpz_2); + break; + default: + if (!is_integer_via_method(sc, i)) + return (wrong_type_argument + (sc, sc->logxor_symbol, position_of(x, args), i, + T_INTEGER)); + return (method_or_bust + (sc, i, sc->logxor_symbol, + set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), + T_INTEGER, position_of(x, args))); + } + } + return (mpz_to_integer(sc, sc->mpz_1)); +} +#endif + +static s7_pointer g_logxor(s7_scheme * sc, s7_pointer args) +{ +#define H_logxor "(logxor int32_t ...) returns the XOR of its integer arguments (the bits that are on in an odd number of the arguments)" +#define Q_logxor sc->pcl_i + + s7_int result = 0; + s7_pointer x; + for (x = args; is_not_null(x); x = cdr(x)) { +#if WITH_GMP + if (is_t_big_integer(car(x))) + return (big_logxor(sc, result, x)); +#endif + if (!is_t_integer(car(x))) + return (method_or_bust(sc, car(x), sc->logxor_symbol, + (result == 0) ? x : set_ulist_1(sc, + make_integer + (sc, + result), + x), + T_INTEGER, position_of(x, args))); + result ^= integer(car(x)); + } + return (make_integer(sc, result)); +} + +static s7_int logxor_i_ii(s7_int i1, s7_int i2) +{ + return (i1 ^ i2); +} + +static s7_int logxor_i_iii(s7_int i1, s7_int i2, s7_int i3) +{ + return (i1 ^ i2 ^ i3); +} + + +/* -------------------------------- logand -------------------------------- */ +#if WITH_GMP +static s7_pointer big_logand(s7_scheme * sc, s7_int start, s7_pointer args) +{ + s7_pointer x; + mpz_set_si(sc->mpz_1, start); + for (x = args; is_not_null(x); x = cdr(x)) { + s7_pointer i = car(x); + switch (type(i)) { + case T_BIG_INTEGER: + mpz_and(sc->mpz_1, sc->mpz_1, big_integer(i)); + break; + case T_INTEGER: + mpz_set_si(sc->mpz_2, integer(i)); + mpz_and(sc->mpz_1, sc->mpz_1, sc->mpz_2); + break; + default: + if (!is_integer_via_method(sc, i)) + return (wrong_type_argument + (sc, sc->logand_symbol, position_of(x, args), i, + T_INTEGER)); + return (method_or_bust + (sc, i, sc->logand_symbol, + set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), + T_INTEGER, position_of(x, args))); + } + } + return (mpz_to_integer(sc, sc->mpz_1)); +} +#endif + +static s7_pointer g_logand(s7_scheme * sc, s7_pointer args) +{ +#define H_logand "(logand int32_t ...) returns the AND of its integer arguments (the bits that are on in every argument)" +#define Q_logand sc->pcl_i + + s7_int result = -1; + s7_pointer x; + for (x = args; is_not_null(x); x = cdr(x)) { +#if WITH_GMP + if (is_t_big_integer(car(x))) + return (big_logand(sc, result, x)); +#endif + if (!is_t_integer(car(x))) + return (method_or_bust(sc, car(x), sc->logand_symbol, + (result == -1) ? x : set_ulist_1(sc, + make_integer + (sc, + result), + x), + T_INTEGER, position_of(x, args))); + result &= integer(car(x)); + } + return (make_integer(sc, result)); +} + +static s7_int logand_i_ii(s7_int i1, s7_int i2) +{ + return (i1 & i2); +} + +static s7_int logand_i_iii(s7_int i1, s7_int i2, s7_int i3) +{ + return (i1 & i2 & i3); +} + + +/* -------------------------------- lognot -------------------------------- */ +static s7_pointer g_lognot(s7_scheme * sc, s7_pointer args) +{ +#define H_lognot "(lognot num) returns the negation of num (its complement, the bits that are not on): (lognot 0) -> -1" +#define Q_lognot sc->pcl_i + + s7_pointer x = car(args); + if (is_t_integer(x)) + return (make_integer(sc, ~integer(x))); + +#if WITH_GMP + if (is_t_big_integer(x)) { + mpz_com(sc->mpz_1, big_integer(x)); + return (mpz_to_integer(sc, sc->mpz_1)); + } +#endif + return (method_or_bust_one_arg + (sc, x, sc->lognot_symbol, args, T_INTEGER)); +} + +static s7_int lognot_i_i(s7_int i1) +{ + return (~i1); +} + + +/* -------------------------------- logbit? -------------------------------- */ +/* logbit? CL is (logbitp index int) using 2^index, but that order strikes me as backwards + * at least gmp got the arg order right! + */ + +static s7_pointer g_logbit(s7_scheme * sc, s7_pointer args) +{ +#define H_logbit "(logbit? int index) returns #t if the index-th bit is on in int, otherwise #f. The argument \ +order here follows gmp, and is the opposite of the CL convention. (logbit? int bit) is the same as (not (zero? (logand int (ash 1 bit))))." +#define Q_logbit s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_integer_symbol) + + s7_pointer x = car(args), y = cadr(args); + s7_int index; /* index in gmp is mp_bitcnt which is an unsigned long int */ + + if (!s7_is_integer(x)) + return (method_or_bust + (sc, x, sc->logbit_symbol, args, T_INTEGER, 1)); + if (!s7_is_integer(y)) + return (method_or_bust + (sc, y, sc->logbit_symbol, args, T_INTEGER, 2)); + + index = s7_integer_checked(sc, y); + if (index < 0) + return (out_of_range + (sc, sc->logbit_symbol, int_two, y, its_negative_string)); + +#if WITH_GMP + if (is_t_big_integer(x)) + return (make_boolean + (sc, (mpz_tstbit(big_integer(x), index) != 0))); +#endif + + if (index >= S7_INT_BITS) /* not sure about the >: (logbit? -1 64) ?? */ + return (make_boolean(sc, integer(x) < 0)); + + /* (zero? (logand most-positive-fixnum (ash 1 63))) -> ash argument 2, 63, is out of range (shift is too large) + * so logbit? has a wider range than the logand/ash shuffle above. + */ + + /* all these int64_ts are necessary, else C turns it into an int, gets confused about signs etc */ + return (make_boolean + (sc, + ((((int64_t) (1LL << (int64_t) index)) & (int64_t) integer(x)) + != 0))); +} + +static bool logbit_b_7ii(s7_scheme * sc, s7_int i1, s7_int i2) +{ + if (i2 < 0) { + out_of_range(sc, sc->logbit_symbol, int_two, wrap_integer1(sc, i1), + its_negative_string); + return (false); + } + if (i2 >= S7_INT_BITS) + return (i1 < 0); + return ((((int64_t) (1LL << (int64_t) i2)) & (int64_t) i1) != 0); +} + +static bool logbit_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + if (is_t_integer(p1)) { + if (is_t_integer(p2)) + return (logbit_b_7ii(sc, integer(p1), integer(p2))); + return (method_or_bust + (sc, p2, sc->logbit_symbol, set_plist_2(sc, p1, p2), + T_INTEGER, 2) != sc->F); + } +#if WITH_GMP + return (g_logbit(sc, set_plist_2(sc, p1, p2))); +#else + return (method_or_bust + (sc, p1, sc->logbit_symbol, set_plist_2(sc, p1, p2), T_INTEGER, + 1) != sc->F); +#endif +} + + +/* -------------------------------- ash -------------------------------- */ +static s7_int c_ash(s7_scheme * sc, s7_int arg1, s7_int arg2) +{ + if (arg1 == 0) + return (0); + + if (arg2 >= S7_INT_BITS) { + if ((arg1 == -1) && (arg2 == 63)) /* (ash -1 63): most-negative-fixnum */ + return (S7_INT64_MIN); + out_of_range(sc, sc->ash_symbol, int_two, wrap_integer1(sc, arg2), + its_too_large_string); + } + + if (arg2 < -S7_INT_BITS) + return ((arg1 < 0) ? -1 : 0); /* (ash -31 -100) */ + + /* I can't see any point in protecting this: (ash 9223372036854775807 1) -> -2, but anyone using ash must know something about bits */ + if (arg2 < 0) + return (arg1 >> -arg2); + if (arg1 < 0) { + uint64_t z = (uint64_t) arg1; + return ((s7_int) (z << arg2)); + } + return (arg1 << arg2); +} + +static s7_pointer g_ash(s7_scheme * sc, s7_pointer args) +{ +#define H_ash "(ash i1 i2) returns i1 shifted right or left i2 times, i1 << i2, (ash 1 3) -> 8, (ash 8 -3) -> 1" +#define Q_ash sc->pcl_i + +#if WITH_GMP + /* here, as in expt, there are cases like (ash 1 63) which need to be handled as bignums */ + s7_pointer p0 = car(args), p1 = cadr(args); + + /* here, as in expt, there are cases like (ash 1 63) which need to be handled as bignums so there's no easy way to tell when it's safe to drop into g_ash instead. */ + if ((s7_is_integer(p0)) && /* this includes bignum ints... */ + (s7_is_integer(p1))) { + s7_int shift; + bool p0_is_big = is_big_number(p0); + int32_t p0_compared_to_zero = 0; + + if (p0_is_big) + p0_compared_to_zero = mpz_cmp_ui(big_integer(p0), 0); + else if (integer(p0) > 0) + p0_compared_to_zero = 1; + else + p0_compared_to_zero = (integer(p0) < 0) ? -1 : 0; + + if (p0_compared_to_zero == 0) + return (int_zero); + + if (is_big_number(p1)) { + if (!mpz_fits_sint_p(big_integer(p1))) { + if (mpz_cmp_ui(big_integer(p1), 0) > 0) + return (out_of_range + (sc, sc->ash_symbol, int_two, p1, + its_too_large_string)); + + /* here if p0 is negative, we need to return -1 */ + return ((p0_compared_to_zero == 1) ? int_zero : minus_one); + } + shift = mpz_get_si(big_integer(p1)); + } else { + shift = integer(p1); + if (shift < S7_INT32_MIN) + return ((p0_compared_to_zero == 1) ? int_zero : minus_one); + } + if (shift > S7_INT32_MAX) + return (out_of_range(sc, sc->ash_symbol, int_two, p1, its_too_large_string)); /* gmp calls abort if overflow here */ + + if (is_t_big_integer(p0)) + mpz_set(sc->mpz_1, big_integer(p0)); + else + mpz_set_si(sc->mpz_1, integer(p0)); + + if (shift > 0) /* left */ + mpz_mul_2exp(sc->mpz_1, sc->mpz_1, shift); + else if (shift < 0) /* right */ + mpz_fdiv_q_2exp(sc->mpz_1, sc->mpz_1, (uint32_t) (-shift)); + + return (mpz_to_integer(sc, sc->mpz_1)); + } + /* else fall through */ +#endif + s7_pointer x = car(args), y; + + if (!s7_is_integer(x)) + return (method_or_bust(sc, x, sc->ash_symbol, args, T_INTEGER, 1)); + + y = cadr(args); + if (!s7_is_integer(y)) + return (method_or_bust(sc, y, sc->ash_symbol, args, T_INTEGER, 2)); + return (make_integer + (sc, + c_ash(sc, s7_integer_checked(sc, x), + s7_integer_checked(sc, y)))); +} + +#if (!WITH_GMP) +static s7_int ash_i_7ii(s7_scheme * sc, s7_int i1, s7_int i2) +{ + return (c_ash(sc, i1, i2)); +} +#endif +static s7_int lsh_i_ii_unchecked(s7_int i1, s7_int i2) +{ + return (i1 << i2); +} /* this may need gmp special handling, and out-of-range as in c_ash */ + +static s7_int rsh_i_ii_unchecked(s7_int i1, s7_int i2) +{ + return (i1 >> (-i2)); +} + +static s7_int rsh_i_i2_direct(s7_int i1, s7_int i2) +{ + return (i1 >> 1); +} + + +/* -------------------------------- random-state -------------------------------- */ +/* random numbers. The simple version used in clm.c is probably adequate, but here I'll use Marsaglia's MWC algorithm. + * (random num) -> a number (0..num), if num == 0 return 0, use global default state + * (random num state) -> same but use this state + * (random-state seed) -> make a new state + * to save the current seed, use copy, to save it across load, random-state->list and list->random-state. + * random-state? returns #t if its arg is one of these guys + */ + +s7_pointer s7_random_state(s7_scheme * sc, s7_pointer args) +{ +#define H_random_state "(random-state seed (carry plausible-default)) returns a new random number state initialized with 'seed'. \ +Pass this as the second argument to 'random' to get a repeatable random number sequence:\n\ + (let ((seed (random-state 1234))) (random 1.0 seed))" +#define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->is_random_state_symbol, sc->is_integer_symbol) + +#if WITH_GMP + s7_pointer r, seed = car(args); + if (!s7_is_integer(seed)) + return (method_or_bust_one_arg + (sc, seed, sc->random_state_symbol, args, T_INTEGER)); + + if (is_t_integer(seed)) + seed = s7_int_to_big_integer(sc, integer(seed)); + + new_cell(sc, r, T_RANDOM_STATE); + gmp_randinit_default(random_gmp_state(r)); /* Mersenne twister */ + gmp_randseed(random_gmp_state(r), big_integer(seed)); /* this is ridiculously slow! */ + add_big_random_state(sc, r); + return (r); +#else + s7_pointer r1 = car(args), r2, p; + s7_int i1, i2; + + if (!s7_is_integer(r1)) + return (method_or_bust + (sc, r1, sc->random_state_symbol, args, T_INTEGER, 1)); + i1 = integer(r1); + if (i1 < 0) + return (out_of_range + (sc, sc->random_state_symbol, int_one, r1, + its_negative_string)); + + if (is_null(cdr(args))) { + new_cell(sc, p, T_RANDOM_STATE); + random_seed(p) = (uint64_t) i1; + random_carry(p) = 1675393560; /* should this be dependent on the seed? */ + return (p); + } + + r2 = cadr(args); + if (!s7_is_integer(r2)) + return (method_or_bust + (sc, r2, sc->random_state_symbol, args, T_INTEGER, 2)); + i2 = integer(r2); + if (i2 < 0) + return (out_of_range + (sc, sc->random_state_symbol, int_two, r2, + its_negative_string)); + + new_cell(sc, p, T_RANDOM_STATE); + random_seed(p) = (uint64_t) i1; + random_carry(p) = (uint64_t) i2; + return (p); +#endif +} + +#define g_random_state s7_random_state + +static s7_pointer rng_copy(s7_scheme * sc, s7_pointer args) +{ +#if WITH_GMP + return (sc->F); /* I can't find a way to copy a gmp random generator */ +#else + s7_pointer new_r, obj = car(args); + if (!is_random_state(obj)) + return (sc->F); + new_cell(sc, new_r, T_RANDOM_STATE); + random_seed(new_r) = random_seed(obj); + random_carry(new_r) = random_carry(obj); + return (new_r); +#endif +} + + +/* -------------------------------- random-state? -------------------------------- */ +static s7_pointer g_is_random_state(s7_scheme * sc, s7_pointer args) +{ +#define H_is_random_state "(random-state? obj) returns #t if obj is a random-state object (from random-state)." +#define Q_is_random_state sc->pl_bt + check_boolean_method(sc, is_random_state, sc->is_random_state_symbol, + args); +} + +bool s7_is_random_state(s7_pointer p) +{ + return (type(p) == T_RANDOM_STATE); +} + + +/* -------------------------------- random-state->list -------------------------------- */ +s7_pointer s7_random_state_to_list(s7_scheme * sc, s7_pointer args) +{ +#define H_random_state_to_list "(random-state->list r) returns the random state object as a list.\ +You can later apply random-state to this list to continue a random number sequence from any point." +#define Q_random_state_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_random_state_symbol) + +#if WITH_GMP + if ((is_pair(args)) && (!is_random_state(car(args)))) + return (method_or_bust_with_type + (sc, car(args), sc->random_state_to_list_symbol, args, + a_random_state_object_string, 1)); + return (sc->nil); +#else + s7_pointer r; + if (is_null(args)) + r = sc->default_rng; + else { + r = car(args); + if (!is_random_state(r)) + return (method_or_bust_with_type + (sc, r, sc->random_state_to_list_symbol, args, + a_random_state_object_string, 1)); + } + return (list_2 + (sc, make_integer(sc, random_seed(r)), + make_integer(sc, random_carry(r)))); +#endif +} + +#define g_random_state_to_list s7_random_state_to_list + +void s7_set_default_random_state(s7_scheme * sc, s7_int seed, s7_int carry) +{ +#if (!WITH_GMP) + s7_pointer p; + new_cell(sc, p, T_RANDOM_STATE); + random_seed(p) = (uint64_t) seed; + random_carry(p) = (uint64_t) carry; + sc->default_rng = p; +#endif +} + + +/* -------------------------------- random -------------------------------- */ +#if WITH_GMP +static double next_random(s7_scheme * sc) +#else +static double next_random(s7_pointer r) +#endif +{ +#if (!WITH_GMP) + /* The multiply-with-carry generator for 32-bit integers: + * x(n)=a*x(n-1) + carry mod 2^32 + * Choose multiplier a from this list: + * 1791398085 1929682203 1683268614 1965537969 1675393560 1967773755 1517746329 1447497129 1655692410 1606218150 + * 2051013963 1075433238 1557985959 1781943330 1893513180 1631296680 2131995753 2083801278 1873196400 1554115554 + * ( or any 'a' for which both a*2^32-1 and a*2^31-1 are prime) + */ + double result; + uint64_t temp; +#define RAN_MULT 2131995753UL + + temp = random_seed(r) * RAN_MULT + random_carry(r); + random_seed(r) = (temp & 0xffffffffUL); + random_carry(r) = (temp >> 32); + result = (double) ((uint32_t) (random_seed(r))) / 4294967295.5; + /* divisor was 2^32-1 = 4294967295.0, but somehow this can round up once in a billion tries? + * do we want the double just less than 2^32? + * can the multiply-add+logand above return 0? I'm getting 0's from (random (expt 2 62)) + */ + + /* (let ((mx 0) (mn 1000)) (do ((i 0 (+ i 1))) ((= i 10000)) (let ((val (random 123))) (set! mx (max mx val)) (set! mn (min mn val)))) (list mn mx)) */ + return (result); +#else + mpfr_urandomb(sc->mpfr_1, random_gmp_state(sc->default_rng)); + return (mpfr_get_d(sc->mpfr_1, MPFR_RNDN)); +#endif +} + +static s7_pointer g_random(s7_scheme * sc, s7_pointer args) +{ +#define H_random "(random num (state #f)) returns a random number of the same type as num between zero and num, equalling num only if num is zero" +#define Q_random s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_random_state_symbol) + s7_pointer r, num; + + /* if we disallow (random 0) the programmer has to protect every call on random with (if (eqv? x 0) 0 (random x)). If + * we claim we're using a half-open interval, then we should also disallow (random 0.0); otherwise the following + * must be true: (let* ((x 0.0) (y (random x))) (and (>= y 0.0) (< y x))). The definition above is consistent + * with (random 0) -> 0, simpler to use in practice, and certainly no worse than (/ 0 0) -> 1. + */ + if (is_null(cdr(args))) + r = sc->default_rng; + else { + r = cadr(args); + if (!is_random_state(r)) + return (method_or_bust_with_type + (sc, r, sc->random_symbol, args, + a_random_state_object_string, 2)); + } + num = car(args); + switch (type(num)) { +#if (!WITH_GMP) + case T_INTEGER: + return (make_integer + (sc, (s7_int) (integer(num) * next_random(r)))); + + case T_RATIO: + { + s7_double x = fraction(num), error; + s7_int numer = 0, denom = 1; + /* the error here needs to take the size of the fraction into account. Otherwise, if + * error is (say) 1e-6 and the fraction is (say) 9000000/9223372036854775807, + * c_rationalize will always return 0. But even that isn't foolproof: + * (random 1/562949953421312) -> 1/376367230475000 + */ + if ((x < 1.0e-10) && (x > -1.0e-10)) { + /* 1e-12 is not tight enough: + * (random 1/2251799813685248) -> 1/2250240579436280 + * (random -1/4503599627370496) -> -1/4492889778435526 + * (random 1/140737488355328) -> 1/140730223985746 + * (random -1/35184372088832) -> -1/35183145492420 + * (random -1/70368744177664) -> -1/70366866392738 + * (random 1/4398046511104) -> 1/4398033095756 + * (random 1/137438953472) -> 1/137438941127 + */ + if (numerator(num) < -10) + numer = + -(s7_int) (floor + (-numerator(num) * next_random(r))); + else if (numerator(num) > 10) + numer = + (s7_int) floor(numerator(num) * next_random(r)); + else { + int64_t diff; + numer = numerator(num); + diff = S7_INT64_MAX - denominator(num); + if (diff < 100) + return (make_ratio(sc, numer, denominator(num))); + denom = + denominator(num) + + (s7_int) floor(diff * next_random(r)); + return (s7_make_ratio(sc, numer, denom)); + } + return (make_ratio(sc, numer, denominator(num))); + } + error = ((x < 1e-6) && (x > -1e-6)) ? 1e-18 : 1e-12; + c_rationalize(x * next_random(r), error, &numer, &denom); + return (make_ratio(sc, numer, denom)); + } + + case T_REAL: + return (make_real(sc, real(num) * next_random(r))); + + case T_COMPLEX: + return (s7_make_complex + (sc, real_part(num) * next_random(r), + imag_part(num) * next_random(r))); + +#else + + case T_INTEGER: + if (integer(num) == 0) + return (int_zero); + mpz_set_si(sc->mpz_1, integer(num)); + mpz_urandomm(sc->mpz_1, random_gmp_state(r), sc->mpz_1); + if (integer(num) < 0) + mpz_neg(sc->mpz_1, sc->mpz_1); + return (make_integer(sc, mpz_get_si(sc->mpz_1))); + + case T_BIG_INTEGER: + if (mpz_cmp_si(big_integer(num), 0) == 0) + return (int_zero); + mpz_urandomm(sc->mpz_1, random_gmp_state(r), big_integer(num)); + /* this does not work if num is a negative number -- you get positive results. so check num for sign, and negate result if necessary. */ + if (mpz_cmp_ui(big_integer(num), 0) < 0) + mpz_neg(sc->mpz_1, sc->mpz_1); + return (mpz_to_integer(sc, sc->mpz_1)); + + case T_RATIO: + mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); + mpq_set_si(sc->mpq_1, numerator(num), denominator(num)); + mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, sc->mpq_1, MPFR_RNDN); + mpfr_mul_d(sc->mpfr_2, sc->mpfr_1, sc->default_rationalize_error, + MPFR_RNDN); + return (big_rationalize + (sc, + set_plist_2(sc, mpfr_to_big_real(sc, sc->mpfr_1), + mpfr_to_big_real(sc, sc->mpfr_2)))); + + case T_BIG_RATIO: + mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); + mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(num), MPFR_RNDN); + mpfr_mul_d(sc->mpfr_2, sc->mpfr_1, sc->default_rationalize_error, + MPFR_RNDN); + return (big_rationalize + (sc, + set_plist_2(sc, mpfr_to_big_real(sc, sc->mpfr_1), + mpfr_to_big_real(sc, sc->mpfr_2)))); + + case T_REAL: + mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); + mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(num), MPFR_RNDN); + return (make_real(sc, mpfr_get_d(sc->mpfr_1, MPFR_RNDN))); + + case T_BIG_REAL: + mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); + mpfr_mul(sc->mpfr_1, sc->mpfr_1, big_real(num), MPFR_RNDN); + return (mpfr_to_big_real(sc, sc->mpfr_1)); + + case T_COMPLEX: + mpc_urandom(sc->mpc_1, random_gmp_state(r)); + mpfr_mul_d(mpc_realref(sc->mpc_1), mpc_realref(sc->mpc_1), + real_part(num), MPFR_RNDN); + mpfr_mul_d(mpc_imagref(sc->mpc_1), mpc_imagref(sc->mpc_1), + imag_part(num), MPFR_RNDN); + return (s7_make_complex + (sc, mpfr_get_d(mpc_realref(sc->mpc_1), MPFR_RNDN), + mpfr_get_d(mpc_imagref(sc->mpc_1), MPFR_RNDN))); + + case T_BIG_COMPLEX: + mpc_urandom(sc->mpc_1, random_gmp_state(r)); + mpfr_mul(mpc_realref(sc->mpc_1), mpc_realref(sc->mpc_1), + mpc_realref(big_complex(num)), MPFR_RNDN); + mpfr_mul(mpc_imagref(sc->mpc_1), mpc_imagref(sc->mpc_1), + mpc_imagref(big_complex(num)), MPFR_RNDN); + return (mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return (method_or_bust_with_type + (sc, num, sc->random_symbol, args, a_number_string, 1)); + } + return (sc->F); +} + +s7_double s7_random(s7_scheme * sc, s7_pointer state) +{ +#if WITH_GMP + mpfr_set_ui(sc->mpfr_1, 1, MPFR_RNDN); + mpfr_urandomb(sc->mpfr_1, + random_gmp_state((state) ? state : sc->default_rng)); + return ((s7_double) mpfr_get_d(sc->mpfr_1, MPFR_RNDN)); +#else + return (next_random((state) ? state : sc->default_rng)); +#endif +} + +static s7_double random_d_7d(s7_scheme * sc, s7_double x) +{ +#if WITH_GMP + return (real(g_random(sc, set_plist_1(sc, wrap_real2(sc, x))))); +#else + return (x * next_random(sc->default_rng)); +#endif +} + +static s7_int random_i_7i(s7_scheme * sc, s7_int i) +{ +#if WITH_GMP + return (integer(g_random(sc, set_plist_1(sc, wrap_integer1(sc, i))))); +#else + return ((s7_int) (i * next_random(sc->default_rng))); +#endif +} + +static s7_pointer g_random_i(s7_scheme * sc, s7_pointer args) +{ +#if WITH_GMP + return (g_random(sc, args)); +#else + return (make_integer + (sc, + (s7_int) (integer(car(args)) * + next_random(sc->default_rng)))); +#endif +} + +static s7_pointer g_random_f(s7_scheme * sc, s7_pointer args) +{ +#if WITH_GMP + return (g_random(sc, args)); +#else + return (make_real(sc, real(car(args)) * next_random(sc->default_rng))); +#endif +} + +static s7_pointer g_random_1(s7_scheme * sc, s7_pointer args) +{ +#if (!WITH_GMP) + s7_pointer num = car(args), r = sc->default_rng; + if (is_t_integer(num)) + return (make_integer + (sc, (s7_int) (integer(num) * next_random(r)))); + if (is_t_real(num)) + return (make_real(sc, real(num) * next_random(r))); +#endif + return (g_random(sc, args)); +} + +static s7_pointer random_p_p(s7_scheme * sc, s7_pointer num) +{ +#if (!WITH_GMP) + if (is_t_integer(num)) + return (make_integer + (sc, + (s7_int) (integer(num) * next_random(sc->default_rng)))); + if (is_t_real(num)) + return (make_real(sc, real(num) * next_random(sc->default_rng))); +#endif + return (g_random(sc, set_plist_1(sc, num))); +} + +static s7_pointer random_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if ((ops) && (args == 1)) { + s7_pointer arg1 = cadr(expr); + if (is_t_integer(arg1)) + return (sc->random_i); + return ((is_t_real(arg1)) ? sc->random_f : sc->random_1); + } + return (f); +} + +static s7_pointer g_add_i_random(s7_scheme * sc, s7_pointer args) +{ +#if WITH_GMP + return (add_p_pp(sc, car(args), random_p_p(sc, cadadr(args)))); +#else + s7_int x = integer(car(args)), y = integer(opt3_int(args)); /* cadadr */ + return (make_integer(sc, x + (s7_int) (y * next_random(sc->default_rng)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */ +#endif +} + + +/* -------------------------------- characters -------------------------------- */ +/* -------------------------------- char<->integer -------------------------------- */ +static s7_pointer g_char_to_integer(s7_scheme * sc, s7_pointer args) +{ +#define H_char_to_integer "(char->integer c) converts the character c to an integer" +#define Q_char_to_integer s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_char_symbol) + + if (!is_character(car(args))) + return (method_or_bust_one_arg + (sc, car(args), sc->char_to_integer_symbol, args, + T_CHARACTER)); + return (small_int(character(car(args)))); +} + +static s7_int char_to_integer_i_7p(s7_scheme * sc, s7_pointer p) +{ + if (!is_character(p)) + return (integer + (method_or_bust_one_arg_p + (sc, p, sc->char_to_integer_symbol, T_CHARACTER))); + return (character(p)); +} + +static s7_pointer char_to_integer_p_p(s7_scheme * sc, s7_pointer p) +{ + if (!is_character(p)) + return (method_or_bust_one_arg_p + (sc, p, sc->char_to_integer_symbol, T_CHARACTER)); + return (make_integer(sc, character(p))); +} + +static s7_pointer integer_to_char_p_p(s7_scheme * sc, s7_pointer x) +{ + s7_int ind; + if (!s7_is_integer(x)) + return (method_or_bust_one_arg_p + (sc, x, sc->integer_to_char_symbol, T_INTEGER)); + ind = s7_integer_checked(sc, x); + if ((ind >= 0) && (ind < NUM_CHARS)) + return (chars[(uint8_t) ind]); + return (s7_out_of_range_error + (sc, "integer->char", 1, x, + "it doen't fit in an unsigned byte")); +} + +static s7_pointer g_integer_to_char(s7_scheme * sc, s7_pointer args) +{ +#define H_integer_to_char "(integer->char i) converts the non-negative integer i to a character" +#define Q_integer_to_char s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol) + return (integer_to_char_p_p(sc, car(args))); +} + +static s7_pointer integer_to_char_p_i(s7_scheme * sc, s7_int ind) +{ + if ((ind >= 0) && (ind < NUM_CHARS)) + return (chars[(uint8_t) ind]); + return (s7_out_of_range_error(sc, "integer->char", 1, wrap_integer2(sc, ind), "it doen't fit in an unsigned byte")); /* int2 s7_out... uses 1 */ +} + + +static uint8_t uppers[256], lowers[256]; +static void init_uppers(void) +{ + int32_t i; + for (i = 0; i < 256; i++) { + uppers[i] = (uint8_t) toupper(i); + lowers[i] = (uint8_t) tolower(i); + } +} + +static void init_chars(void) +{ + s7_cell *cells; + int32_t i; + + chars = (s7_pointer *) malloc((NUM_CHARS + 1) * sizeof(s7_pointer)); /* chars is declared far above */ + cells = (s7_cell *) calloc(NUM_CHARS + 1, sizeof(s7_cell)); + + chars[0] = &cells[0]; + eof_object = chars[0]; + set_full_type(eof_object, T_EOF | T_IMMUTABLE | T_UNHEAP); + eof_name_length(eof_object) = 6; + eof_name(eof_object) = "#"; + chars++; /* now chars[EOF] == chars[-1] == # */ + cells++; + + for (i = 0; i < NUM_CHARS; i++) { + s7_pointer cp = &cells[i]; + uint8_t c = (uint8_t) i; + + set_type_bit(cp, T_IMMUTABLE | T_CHARACTER | T_UNHEAP); + set_optimize_op(cp, OP_CON); + character(cp) = c; + upper_character(cp) = (uint8_t) toupper(i); + is_char_alphabetic(cp) = (bool) isalpha(i); + is_char_numeric(cp) = (bool) isdigit(i); + is_char_whitespace(cp) = white_space[i]; + is_char_uppercase(cp) = (((bool) isupper(i)) + || ((i >= 192) && (i < 208))); + is_char_lowercase(cp) = (bool) islower(i); + chars[i] = cp; + +#define make_character_name(S) memcpy((void *)(&(character_name(cp))), (const void *)(S), character_name_length(cp) = strlen(S)) + switch (c) { + case ' ': + make_character_name("#\\space"); + break; + case '\n': + make_character_name("#\\newline"); + break; + case '\r': + make_character_name("#\\return"); + break; + case '\t': + make_character_name("#\\tab"); + break; + case '\0': + make_character_name("#\\null"); + break; + case (char) 0x1b: + make_character_name("#\\escape"); + break; + case (char) 0x7f: + make_character_name("#\\delete"); + break; + case (char) 7: + make_character_name("#\\alarm"); + break; + case (char) 8: + make_character_name("#\\backspace"); + break; + default: + { +#define P_SIZE 12 + int32_t len; + if ((c < 32) || (c >= 127)) + len = + snprintf((char *) (&(character_name(cp))), P_SIZE, + "#\\x%x", c); + else + len = + snprintf((char *) (&(character_name(cp))), P_SIZE, + "#\\%c", c); + character_name_length(cp) = len; + break; + } + } + } +} + + +/* -------------------------------- char-upcase, char-downcase ----------------------- */ +static s7_pointer char_upcase_p_p(s7_scheme * sc, s7_pointer c) +{ + if (!is_character(c)) + return (method_or_bust_one_arg_p + (sc, c, sc->char_upcase_symbol, T_CHARACTER)); + return (chars[upper_character(c)]); +} + +static s7_pointer char_upcase_p_p_unchecked(s7_scheme * sc, s7_pointer c) +{ + return (chars[upper_character(c)]); +} + +static s7_pointer g_char_upcase(s7_scheme * sc, s7_pointer args) +{ +#define H_char_upcase "(char-upcase c) converts the character c to upper case" +#define Q_char_upcase sc->pcl_c + return (char_upcase_p_p(sc, car(args))); +} + +static s7_pointer g_char_downcase(s7_scheme * sc, s7_pointer args) +{ +#define H_char_downcase "(char-downcase c) converts the character c to lower case" +#define Q_char_downcase sc->pcl_c + if (!is_character(car(args))) + return (method_or_bust_one_arg + (sc, car(args), sc->char_downcase_symbol, args, + T_CHARACTER)); + return (chars[lowers[character(car(args))]]); +} + + +/* -------------------------------- char-alphabetic? char-numeric? char-whitespace? -------------------------------- */ +static s7_pointer g_is_char_alphabetic(s7_scheme * sc, s7_pointer args) +{ +#define H_is_char_alphabetic "(char-alphabetic? c) returns #t if the character c is alphabetic" +#define Q_is_char_alphabetic sc->pl_bc + if (!is_character(car(args))) + return (method_or_bust_one_arg + (sc, car(args), sc->is_char_alphabetic_symbol, args, + T_CHARACTER)); + return (make_boolean(sc, is_char_alphabetic(car(args)))); + /* isalpha returns #t for (integer->char 226) and others in that range */ +} + +static bool is_char_alphabetic_b_7p(s7_scheme * sc, s7_pointer c) +{ + if (!is_character(c)) + simple_wrong_type_argument(sc, sc->is_char_alphabetic_symbol, c, + T_CHARACTER); + /* return(method_or_bust_one_arg(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), T_CHARACTER) != sc->F); *//* slower? see tmisc */ + return (is_char_alphabetic(c)); +} + +static s7_pointer is_char_alphabetic_p_p(s7_scheme * sc, s7_pointer c) +{ + if (!is_character(c)) + return (method_or_bust_one_arg + (sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), + T_CHARACTER)); + return (make_boolean(sc, is_char_alphabetic(c))); +} + +static s7_pointer g_is_char_numeric(s7_scheme * sc, s7_pointer args) +{ +#define H_is_char_numeric "(char-numeric? c) returns #t if the character c is a digit" +#define Q_is_char_numeric sc->pl_bc + + s7_pointer arg = car(args); + if (!is_character(arg)) + return (method_or_bust_one_arg + (sc, arg, sc->is_char_numeric_symbol, args, T_CHARACTER)); + return (make_boolean(sc, is_char_numeric(arg))); +} + +static bool is_char_numeric_b_7p(s7_scheme * sc, s7_pointer c) +{ + if (!is_character(c)) + simple_wrong_type_argument(sc, sc->is_char_numeric_symbol, c, + T_CHARACTER); + /* return(method_or_bust_one_arg(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), T_CHARACTER) != sc->F); *//* as above */ + return (is_char_numeric(c)); +} + +static s7_pointer is_char_numeric_p_p(s7_scheme * sc, s7_pointer c) +{ + if (!is_character(c)) + return (method_or_bust_one_arg + (sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), + T_CHARACTER)); + return (make_boolean(sc, is_char_numeric(c))); +} + + +static s7_pointer g_is_char_whitespace(s7_scheme * sc, s7_pointer args) +{ +#define H_is_char_whitespace "(char-whitespace? c) returns #t if the character c is non-printing character" +#define Q_is_char_whitespace sc->pl_bc + + s7_pointer arg = car(args); + if (!is_character(arg)) + return (method_or_bust_one_arg + (sc, arg, sc->is_char_whitespace_symbol, args, + T_CHARACTER)); + return (make_boolean(sc, is_char_whitespace(arg))); +} + +static bool is_char_whitespace_b_7p(s7_scheme * sc, s7_pointer c) +{ + if (!is_character(c)) + simple_wrong_type_argument(sc, sc->is_char_whitespace_symbol, c, + T_CHARACTER); + return (is_char_whitespace(c)); +} + +static s7_pointer is_char_whitespace_p_p(s7_scheme * sc, s7_pointer c) +{ + if (!is_character(c)) + return (method_or_bust_one_arg + (sc, c, sc->is_char_whitespace_symbol, set_plist_1(sc, c), + T_CHARACTER)); + return (make_boolean(sc, is_char_whitespace(c))); +} + +static s7_pointer is_char_whitespace_p_p_unchecked(s7_scheme * sc, + s7_pointer c) +{ + return (make_boolean(sc, is_char_whitespace(c))); +} + + +/* -------------------------------- char-upper-case? char-lower-case? -------------------------------- */ +static s7_pointer g_is_char_upper_case(s7_scheme * sc, s7_pointer args) +{ +#define H_is_char_upper_case "(char-upper-case? c) returns #t if the character c is in upper case" +#define Q_is_char_upper_case sc->pl_bc + + s7_pointer arg = car(args); + if (!is_character(arg)) + return (method_or_bust_one_arg + (sc, arg, sc->is_char_upper_case_symbol, args, + T_CHARACTER)); + return (make_boolean(sc, is_char_uppercase(arg))); +} + +static bool is_char_upper_case_b_7p(s7_scheme * sc, s7_pointer c) +{ + if (!is_character(c)) + return (method_or_bust_one_arg + (sc, c, sc->is_char_upper_case_symbol, set_plist_1(sc, c), + T_CHARACTER) != sc->F); + return (is_char_uppercase(c)); +} + +static s7_pointer g_is_char_lower_case(s7_scheme * sc, s7_pointer args) +{ +#define H_is_char_lower_case "(char-lower-case? c) returns #t if the character c is in lower case" +#define Q_is_char_lower_case sc->pl_bc + + s7_pointer arg = car(args); + if (!is_character(arg)) + return (method_or_bust_one_arg + (sc, arg, sc->is_char_lower_case_symbol, args, + T_CHARACTER)); + return (make_boolean(sc, is_char_lowercase(arg))); +} + +static bool is_char_lower_case_b_7p(s7_scheme * sc, s7_pointer c) +{ + if (!is_character(c)) + return (method_or_bust_one_arg + (sc, c, sc->is_char_lower_case_symbol, set_plist_1(sc, c), + T_CHARACTER) != sc->F); + return (is_char_lowercase(c)); +} + + +/* -------------------------------- char? -------------------------------- */ +static s7_pointer g_is_char(s7_scheme * sc, s7_pointer args) +{ +#define H_is_char "(char? obj) returns #t if obj is a character" +#define Q_is_char sc->pl_bt + check_boolean_method(sc, is_character, sc->is_char_symbol, args); +} + +static s7_pointer is_char_p_p(s7_scheme * sc, s7_pointer p) +{ + return ((is_character(p)) ? sc->T : sc->F); +} + +s7_pointer s7_make_character(s7_scheme * sc, uint8_t c) +{ + return (chars[c]); +} + +bool s7_is_character(s7_pointer p) +{ + return (is_character(p)); +} + +uint8_t s7_character(s7_pointer p) +{ + return (character(p)); +} + + +/* -------------------------------- char? char>=? char=? -------------------------------- */ +static int32_t charcmp(uint8_t c1, uint8_t c2) +{ + return ((c1 == c2) ? 0 : (c1 < c2) ? -1 : 1); + /* not tolower here -- the single case is apparently supposed to be upper case + * this matters in a case like (char-ciis_char_symbol); + if (f != sc->undefined) + return (is_true + (sc, call_method(sc, p, f, set_plist_1(sc, p)))); + } + return (false); +} + +static s7_pointer char_with_error_check(s7_scheme * sc, s7_pointer x, + s7_pointer args, s7_pointer caller) +{ + s7_pointer y; + for (y = cdr(x); is_pair(y); y = cdr(y)) /* before returning #f, check for bad trailing arguments */ + if (!is_character_via_method(sc, car(y))) + return (wrong_type_argument + (sc, caller, position_of(y, args), car(y), + T_CHARACTER)); + return (sc->F); +} + +static s7_pointer g_char_cmp(s7_scheme * sc, s7_pointer args, int32_t val, + s7_pointer sym) +{ + s7_pointer x, y = car(args); + if (!is_character(y)) + return (method_or_bust(sc, y, sym, args, T_CHARACTER, 1)); + for (x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) { + if (!is_character(car(x))) + return (method_or_bust + (sc, car(x), sym, set_ulist_1(sc, y, x), T_CHARACTER, + position_of(x, args))); + if (charcmp(character(y), character(car(x))) != val) + return (char_with_error_check(sc, x, args, sym)); + } + return (sc->T); +} + +static s7_pointer g_char_cmp_not(s7_scheme * sc, s7_pointer args, + int32_t val, s7_pointer sym) +{ + s7_pointer x, y = car(args); + if (!is_character(y)) + return (method_or_bust(sc, y, sym, args, T_CHARACTER, 1)); + for (x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) { + if (!is_character(car(x))) + return (method_or_bust + (sc, car(x), sym, set_ulist_1(sc, y, x), T_CHARACTER, + position_of(x, args))); + if (charcmp(character(y), character(car(x))) == val) + return (char_with_error_check(sc, x, args, sym)); + } + return (sc->T); +} + +static s7_pointer g_chars_are_equal(s7_scheme * sc, s7_pointer args) +{ +#define H_chars_are_equal "(char=? char ...) returns #t if all the character arguments are equal" +#define Q_chars_are_equal sc->pcl_bc + + s7_pointer x, y = car(args); + if (!is_character(y)) + return (method_or_bust + (sc, y, sc->char_eq_symbol, args, T_CHARACTER, 1)); + for (x = cdr(args); is_pair(x); x = cdr(x)) { + if (!is_character(car(x))) + return (method_or_bust + (sc, car(x), sc->char_eq_symbol, set_ulist_1(sc, y, x), + T_CHARACTER, position_of(x, args))); + if (car(x) != y) + return (char_with_error_check + (sc, x, args, sc->char_eq_symbol)); + } + return (sc->T); +} + + +static s7_pointer g_chars_are_less(s7_scheme * sc, s7_pointer args) +{ +#define H_chars_are_less "(charpcl_bc + return (g_char_cmp(sc, args, -1, sc->char_lt_symbol)); +} + +static s7_pointer g_chars_are_greater(s7_scheme * sc, s7_pointer args) +{ +#define H_chars_are_greater "(char>? char ...) returns #t if all the character arguments are decreasing" +#define Q_chars_are_greater sc->pcl_bc + return (g_char_cmp(sc, args, 1, sc->char_gt_symbol)); +} + +static s7_pointer g_chars_are_geq(s7_scheme * sc, s7_pointer args) +{ +#define H_chars_are_geq "(char>=? char ...) returns #t if all the character arguments are equal or decreasing" +#define Q_chars_are_geq sc->pcl_bc + return (g_char_cmp_not(sc, args, -1, sc->char_geq_symbol)); +} + +static s7_pointer g_chars_are_leq(s7_scheme * sc, s7_pointer args) +{ +#define H_chars_are_leq "(char<=? char ...) returns #t if all the character arguments are equal or increasing" +#define Q_chars_are_leq sc->pcl_bc + return (g_char_cmp_not(sc, args, 1, sc->char_leq_symbol)); +} + +static s7_pointer g_simple_char_eq(s7_scheme * sc, s7_pointer args) +{ + return (make_boolean(sc, car(args) == cadr(args))); +} /* chooser checks types */ + +#define check_char2_args(Sc, Caller, P1, P2) \ + do { \ + if (!is_character(P1)) return(method_or_bust(Sc, P1, Caller, set_plist_2(Sc, P1, P2), T_CHARACTER, 1) != sc->F); \ + if (!is_character(P2)) return(method_or_bust(Sc, P2, Caller, set_plist_2(Sc, P1, P2), T_CHARACTER, 2) != sc->F); \ + } while (0) + +static bool char_lt_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (p1 < p2); +} + +static bool char_lt_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_char2_args(sc, sc->char_lt_symbol, p1, p2); + return (p1 < p2); +} + +static bool char_leq_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (p1 <= p2); +} + +static bool char_leq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_char2_args(sc, sc->char_leq_symbol, p1, p2); + return (p1 <= p2); +} + +static bool char_gt_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (p1 > p2); +} + +static bool char_gt_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_char2_args(sc, sc->char_gt_symbol, p1, p2); + return (p1 > p2); +} + +static bool char_geq_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (p1 >= p2); +} + +static bool char_geq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_char2_args(sc, sc->char_geq_symbol, p1, p2); + return (p1 >= p2); +} + +static bool char_eq_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (p1 == p2); +} + +static bool char_eq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + if (!is_character(p1)) + return (method_or_bust + (sc, p1, sc->char_eq_symbol, set_plist_2(sc, p1, p2), + T_CHARACTER, 1) != sc->F); + if (p1 == p2) + return (true); + if (!is_character(p2)) + return (method_or_bust + (sc, p2, sc->char_eq_symbol, set_plist_2(sc, p1, p2), + T_CHARACTER, 2) != sc->F); + return (false); +} + +static s7_pointer char_eq_p_pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + if (!is_character(p1)) + return (method_or_bust + (sc, p1, sc->char_eq_symbol, set_plist_2(sc, p1, p2), + T_CHARACTER, 1)); + if (p1 == p2) + return (sc->T); + if (!is_character(p2)) + return (method_or_bust + (sc, p2, sc->char_eq_symbol, set_plist_2(sc, p1, p2), + T_CHARACTER, 2)); + return (sc->F); +} + +static s7_pointer g_char_equal_2(s7_scheme * sc, s7_pointer args) +{ + if (!is_character(car(args))) + return (method_or_bust + (sc, car(args), sc->char_eq_symbol, args, T_CHARACTER, 1)); + if (car(args) == cadr(args)) + return (sc->T); + if (!is_character(cadr(args))) + return (method_or_bust + (sc, cadr(args), sc->char_eq_symbol, args, T_CHARACTER, + 2)); + return (sc->F); +} + +static s7_pointer g_char_less_2(s7_scheme * sc, s7_pointer args) +{ + if (!is_character(car(args))) + return (method_or_bust + (sc, car(args), sc->char_lt_symbol, args, T_CHARACTER, 1)); + if (!is_character(cadr(args))) + return (method_or_bust + (sc, cadr(args), sc->char_lt_symbol, args, T_CHARACTER, + 2)); + return (make_boolean + (sc, character(car(args)) < character(cadr(args)))); +} + +static s7_pointer g_char_greater_2(s7_scheme * sc, s7_pointer args) +{ + if (!is_character(car(args))) + return (method_or_bust + (sc, car(args), sc->char_gt_symbol, args, T_CHARACTER, 1)); + if (!is_character(cadr(args))) + return (method_or_bust + (sc, cadr(args), sc->char_gt_symbol, args, T_CHARACTER, + 2)); + return (make_boolean + (sc, character(car(args)) > character(cadr(args)))); +} + +static bool returns_char(s7_scheme * sc, s7_pointer arg) +{ + return (argument_type(sc, arg) == sc->is_char_symbol); +} + +static s7_pointer char_equal_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + if (args == 2) { + if (ops) { + s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if ((returns_char(sc, arg1)) && (returns_char(sc, arg2))) + return (sc->simple_char_eq); + } + return (sc->char_equal_2); + } + return (f); +} + +static s7_pointer char_less_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + return ((args == 2) ? sc->char_less_2 : f); +} + +static s7_pointer char_greater_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + return ((args == 2) ? sc->char_greater_2 : f); +} + + + +/* -------------------------------- char-ci? char-ci>=? char-ci=? -------------------------------- */ +#if (!WITH_PURE_S7) +static s7_pointer g_char_cmp_ci(s7_scheme * sc, s7_pointer args, + int32_t val, s7_pointer sym) +{ + s7_pointer x, y = car(args); + if (!is_character(y)) + return (method_or_bust(sc, y, sym, args, T_CHARACTER, 1)); + + for (x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) { + if (!is_character(car(x))) + return (method_or_bust + (sc, car(x), sym, set_ulist_1(sc, y, x), T_CHARACTER, + position_of(x, args))); + if (charcmp(upper_character(y), upper_character(car(x))) != val) + return (char_with_error_check(sc, x, args, sym)); + } + return (sc->T); +} + +static s7_pointer g_char_cmp_ci_not(s7_scheme * sc, s7_pointer args, + int32_t val, s7_pointer sym) +{ + s7_pointer x, y = car(args); + if (!is_character(y)) + return (method_or_bust(sc, y, sym, args, T_CHARACTER, 1)); + for (x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) { + if (!is_character(car(x))) + return (method_or_bust + (sc, car(x), sym, set_ulist_1(sc, y, x), T_CHARACTER, + position_of(x, args))); + if (charcmp(upper_character(y), upper_character(car(x))) == val) + return (char_with_error_check(sc, x, args, sym)); + } + return (sc->T); +} + +static s7_pointer g_chars_are_ci_equal(s7_scheme * sc, s7_pointer args) +{ +#define H_chars_are_ci_equal "(char-ci=? char ...) returns #t if all the character arguments are equal, ignoring case" +#define Q_chars_are_ci_equal sc->pcl_bc + return (g_char_cmp_ci(sc, args, 0, sc->char_ci_eq_symbol)); +} + +static s7_pointer g_chars_are_ci_less(s7_scheme * sc, s7_pointer args) +{ +#define H_chars_are_ci_less "(char-cipcl_bc + return (g_char_cmp_ci(sc, args, -1, sc->char_ci_lt_symbol)); +} + +static s7_pointer g_chars_are_ci_greater(s7_scheme * sc, s7_pointer args) +{ +#define H_chars_are_ci_greater "(char-ci>? char ...) returns #t if all the character arguments are decreasing, ignoring case" +#define Q_chars_are_ci_greater sc->pcl_bc + return (g_char_cmp_ci(sc, args, 1, sc->char_ci_gt_symbol)); +} + +static s7_pointer g_chars_are_ci_geq(s7_scheme * sc, s7_pointer args) +{ +#define H_chars_are_ci_geq "(char-ci>=? char ...) returns #t if all the character arguments are equal or decreasing, ignoring case" +#define Q_chars_are_ci_geq sc->pcl_bc + return (g_char_cmp_ci_not(sc, args, -1, sc->char_ci_geq_symbol)); +} + +static s7_pointer g_chars_are_ci_leq(s7_scheme * sc, s7_pointer args) +{ +#define H_chars_are_ci_leq "(char-ci<=? char ...) returns #t if all the character arguments are equal or increasing, ignoring case" +#define Q_chars_are_ci_leq sc->pcl_bc + return (g_char_cmp_ci_not(sc, args, 1, sc->char_ci_leq_symbol)); +} + + +static bool char_ci_lt_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (upper_character(p1) < upper_character(p2)); +} + +static bool char_ci_lt_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_char2_args(sc, sc->char_ci_lt_symbol, p1, p2); + return (upper_character(p1) < upper_character(p2)); +} + +static bool char_ci_leq_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (upper_character(p1) <= upper_character(p2)); +} + +static bool char_ci_leq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_char2_args(sc, sc->char_ci_leq_symbol, p1, p2); + return (upper_character(p1) <= upper_character(p2)); +} + +static bool char_ci_gt_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (upper_character(p1) > upper_character(p2)); +} + +static bool char_ci_gt_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_char2_args(sc, sc->char_ci_gt_symbol, p1, p2); + return (upper_character(p1) > upper_character(p2)); +} + +static bool char_ci_geq_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (upper_character(p1) >= upper_character(p2)); +} + +static bool char_ci_geq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_char2_args(sc, sc->char_ci_geq_symbol, p1, p2); + return (upper_character(p1) >= upper_character(p2)); +} + +static bool char_ci_eq_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (upper_character(p1) == upper_character(p2)); +} + +static bool char_ci_eq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_char2_args(sc, sc->char_ci_eq_symbol, p1, p2); + return (upper_character(p1) == upper_character(p2)); +} + +#endif /* not pure s7 */ + + +/* -------------------------------- char-position -------------------------------- */ +static s7_pointer g_char_position(s7_scheme * sc, s7_pointer args) +{ +#define H_char_position "(char-position char-or-str str (start 0)) returns the position of the first occurrence of char in str, or #f" +#define Q_char_position s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_string_symbol), sc->is_string_symbol, sc->is_integer_symbol) + + const char *porig, *pset; + s7_int start, pos, len; /* not "int" because start arg might be most-negative-fixnum */ + s7_pointer arg1 = car(args), arg2; + + if ((!is_character(arg1)) && (!is_string(arg1))) + return (method_or_bust + (sc, arg1, sc->char_position_symbol, args, T_CHARACTER, + 1)); + + arg2 = cadr(args); + if (!is_string(arg2)) + return (method_or_bust + (sc, arg2, sc->char_position_symbol, args, T_STRING, 2)); + + if (is_pair(cddr(args))) { + s7_pointer arg3 = caddr(args); + if (!s7_is_integer(arg3)) + return (method_or_bust + (sc, arg3, sc->char_position_symbol, args, T_INTEGER, + 3)); + start = s7_integer_checked(sc, arg3); + if (start < 0) + return (wrong_type_argument_with_type + (sc, sc->char_position_symbol, 3, arg3, + a_non_negative_integer_string)); + } else + start = 0; + + porig = string_value(arg2); + len = string_length(arg2); + if (start >= len) + return (sc->F); + + if (is_character(arg1)) { + char c = character(arg1); + const char *p; + p = strchr((const char *) (porig + start), (int) c); /* use strchrnul in Gnu C to catch embedded null case */ + return ((p) ? make_integer(sc, p - porig) : sc->F); + } + + if (string_length(arg1) == 0) + return (sc->F); + pset = string_value(arg1); + + pos = strcspn((const char *) (porig + start), (const char *) pset); + if ((pos + start) < len) + return (make_integer(sc, pos + start)); + + /* if the string has an embedded null, we can get erroneous results here -- + * perhaps check for null at pos+start? What about a searched-for string that also has embedded nulls? + */ + return (sc->F); +} + +static s7_pointer char_position_p_ppi(s7_scheme * sc, s7_pointer p1, + s7_pointer p2, s7_int start) +{ + /* p1 is char, p2 is string */ + const char *porig, *p; + s7_int len; + char c; + + if (!is_string(p2)) + simple_wrong_type_argument(sc, sc->char_position_symbol, p2, + T_STRING); + if (start < 0) + wrong_type_argument_with_type(sc, sc->char_position_symbol, 3, + make_integer(sc, start), + a_non_negative_integer_string); + + c = character(p1); + len = string_length(p2); + porig = string_value(p2); + if (start >= len) + return (sc->F); + p = strchr((const char *) (porig + start), (int) c); + if (p) + return (make_integer(sc, p - porig)); + return (sc->F); +} + +static s7_pointer g_char_position_csi(s7_scheme * sc, s7_pointer args) +{ + /* assume char arg1, no end */ + const char *porig, *p; + char c = character(car(args)); + s7_pointer arg2 = cadr(args); + s7_int start, len; + + if (!is_string(arg2)) + return (g_char_position(sc, args)); + + len = string_length(arg2); /* can't return #f here if len==0 -- need start error check first */ + porig = string_value(arg2); + + if (is_pair(cddr(args))) { + s7_pointer arg3 = caddr(args); + if (!s7_is_integer(arg3)) + return (g_char_position(sc, args)); + start = s7_integer_checked(sc, arg3); + if (start < 0) + return (wrong_type_argument_with_type + (sc, sc->char_position_symbol, 3, arg3, + a_non_negative_integer_string)); + if (start >= len) + return (sc->F); + } else + start = 0; + + if (len == 0) + return (sc->F); + p = strchr((const char *) (porig + start), (int) c); + return ((p) ? make_integer(sc, p - porig) : sc->F); +} + +static s7_pointer char_position_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + if (!ops) + return (f); + if ((is_character(cadr(expr))) && ((args == 2) || (args == 3))) + return (sc->char_position_csi); + return (f); +} + + +/* -------------------------------- string-position -------------------------------- */ +static s7_pointer g_string_position(s7_scheme * sc, s7_pointer args) +{ +#define H_string_position "(string-position str1 str2 (start 0)) returns the starting position of str1 in str2 or #f" +#define Q_string_position s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol) + const char *s1, *s2, *p2; + s7_int start = 0; + s7_pointer s1p = car(args), s2p; + + if (!is_string(s1p)) + return (method_or_bust + (sc, s1p, sc->string_position_symbol, args, T_STRING, 1)); + + s2p = cadr(args); + if (!is_string(s2p)) + return (method_or_bust + (sc, s2p, sc->string_position_symbol, args, T_STRING, 2)); + + if (is_pair(cddr(args))) { + s7_pointer arg3 = caddr(args); + if (!s7_is_integer(arg3)) + return (method_or_bust + (sc, arg3, sc->string_position_symbol, args, T_INTEGER, + 3)); + start = s7_integer_checked(sc, arg3); + if (start < 0) + return (wrong_type_argument_with_type + (sc, sc->string_position_symbol, 3, caddr(args), + a_non_negative_integer_string)); + } + + if (string_length(s1p) == 0) + return (sc->F); + s1 = string_value(s1p); + s2 = string_value(s2p); + if (start >= string_length(s2p)) + return (sc->F); + + p2 = strstr((const char *) (s2 + start), s1); + return ((p2) ? make_integer(sc, p2 - s2) : sc->F); +} + + +/* -------------------------------- strings -------------------------------- */ + +static s7_pointer nil_string; /* permanent "" */ + +bool s7_is_string(s7_pointer p) +{ + return (is_string(p)); +} + +const char *s7_string(s7_pointer p) +{ + return (string_value(p)); +} + +s7_int s7_string_length(s7_pointer str) +{ + return (string_length(str)); +} + +s7_pointer s7_make_string_with_length(s7_scheme * sc, const char *str, + s7_int len) +{ + return (make_string_with_length(sc, str, len)); +} + +#define NUM_STRING_WRAPPERS 8 /* should be a power of 2 */ + +static s7_pointer wrap_string(s7_scheme * sc, const char *str, s7_int len) +{ + s7_pointer x; + x = sc->string_wrappers[sc->string_wrapper_pos]; + sc->string_wrapper_pos = (sc->string_wrapper_pos + 1) & (NUM_STRING_WRAPPERS - 1); /* i.e. next is pos+1 modulo len */ + string_value(x) = (char *) str; + string_length(x) = len; + return (x); +} + +s7_pointer s7_make_string_wrapper(s7_scheme * sc, const char *str) +{ + return (wrap_string(sc, str, safe_strlen(str))); +} + +static Inline s7_pointer inline_make_empty_string(s7_scheme * sc, + s7_int len, char fill) +{ + s7_pointer x; + block_t *b; + if (len == 0) + return (nil_string); + new_cell(sc, x, T_STRING); + b = mallocate(sc, len + 1); + string_block(x) = b; + string_value(x) = (char *) block_data(b); + if (fill != '\0') + local_memset((void *) (string_value(x)), fill, len); + string_value(x)[len] = 0; + string_hash(x) = 0; + string_length(x) = len; + add_string(sc, x); + return (x); +} + +static s7_pointer make_empty_string(s7_scheme * sc, s7_int len, char fill) +{ + return (inline_make_empty_string(sc, len, fill)); +} + +s7_pointer s7_make_string(s7_scheme * sc, const char *str) +{ + return ((str) ? make_string_with_length(sc, str, safe_strlen(str)) : + nil_string); +} + +static char *make_permanent_c_string(s7_scheme * sc, const char *str) +{ + char *x; + s7_int len; + len = safe_strlen(str); + x = (char *) permalloc(sc, len + 1); + memcpy((void *) x, (void *) str, len); + x[len] = 0; + return (x); +} + +s7_pointer s7_make_permanent_string(s7_scheme * sc, const char *str) +{ + /* for the symbol table which is never GC'd */ + s7_pointer x; + s7_int len; + if (!str) + return (nil_string); + x = alloc_pointer(sc); + set_full_type(x, T_STRING | T_IMMUTABLE | T_UNHEAP); + set_optimize_op(x, OP_CON); + len = safe_strlen(str); + string_length(x) = len; + string_block(x) = NULL; + string_value(x) = (char *) permalloc(sc, len + 1); + memcpy((void *) string_value(x), (void *) str, len); + string_value(x)[len] = 0; + string_hash(x) = 0; + return (x); +} + +static s7_pointer g_is_string(s7_scheme * sc, s7_pointer args) +{ +#define H_is_string "(string? obj) returns #t if obj is a string" +#define Q_is_string sc->pl_bt + check_boolean_method(sc, is_string, sc->is_string_symbol, args); +} + +static s7_pointer make_permanent_string(const char *str) +{ + s7_pointer x; + s7_int len; + x = (s7_pointer) calloc(1, sizeof(s7_cell)); + set_full_type(x, T_STRING | T_IMMUTABLE | T_UNHEAP); + set_optimize_op(x, OP_CON); + len = safe_strlen(str); + string_length(x) = len; + string_block(x) = NULL; + string_value(x) = (char *) str; + string_hash(x) = 0; + return (x); +} + +static void init_strings(void) +{ + nil_string = make_permanent_string(""); + nil_string->tf.flag = T_STRING | T_UNHEAP; + set_optimize_op(nil_string, OP_CON); + + car_a_list_string = + make_permanent_string("a pair whose car is also a pair"); + cdr_a_list_string = + make_permanent_string("a pair whose cdr is also a pair"); + + caar_a_list_string = + make_permanent_string("a pair whose caar is also a pair"); + cadr_a_list_string = + make_permanent_string("a pair whose cadr is also a pair"); + cdar_a_list_string = + make_permanent_string("a pair whose cdar is also a pair"); + cddr_a_list_string = + make_permanent_string("a pair whose cddr is also a pair"); + + caaar_a_list_string = + make_permanent_string("a pair whose caaar is also a pair"); + caadr_a_list_string = + make_permanent_string("a pair whose caadr is also a pair"); + cadar_a_list_string = + make_permanent_string("a pair whose cadar is also a pair"); + caddr_a_list_string = + make_permanent_string("a pair whose caddr is also a pair"); + cdaar_a_list_string = + make_permanent_string("a pair whose cdaar is also a pair"); + cdadr_a_list_string = + make_permanent_string("a pair whose cdadr is also a pair"); + cddar_a_list_string = + make_permanent_string("a pair whose cddar is also a pair"); + cdddr_a_list_string = + make_permanent_string("a pair whose cdddr is also a pair"); + + a_list_string = make_permanent_string("a list"); + an_eq_func_string = + make_permanent_string("a procedure that can take 2 arguments"); + an_association_list_string = + make_permanent_string("an association list"); + a_normal_real_string = make_permanent_string("a normal real"); + a_rational_string = make_permanent_string("an integer or a ratio"); + a_number_string = make_permanent_string("a number"); + a_procedure_string = make_permanent_string("a procedure"); + a_procedure_or_a_macro_string = + make_permanent_string("a procedure or a macro"); + a_normal_procedure_string = + make_permanent_string("a normal procedure"); + a_let_string = make_permanent_string("a let (environment)"); + a_proper_list_string = make_permanent_string("a proper list"); + a_boolean_string = make_permanent_string("a boolean"); + a_byte_vector_string = make_permanent_string("a byte-vector"); + an_input_port_string = make_permanent_string("an input port"); + an_open_port_string = make_permanent_string("an open port"); + an_output_port_string = make_permanent_string("an output port"); + an_input_string_port_string = + make_permanent_string("an input string port"); + an_input_file_port_string = + make_permanent_string("an input file port"); + an_output_string_port_string = + make_permanent_string("an output string port"); + an_output_file_port_string = + make_permanent_string("an output file port"); + a_thunk_string = make_permanent_string("a thunk"); + a_symbol_string = make_permanent_string("a symbol"); + a_non_negative_integer_string = + make_permanent_string("a non-negative integer"); + an_unsigned_byte_string = make_permanent_string("an unsigned byte"); + something_applicable_string = + make_permanent_string("a procedure or something applicable"); + a_random_state_object_string = + make_permanent_string("a random-state object"); + a_format_port_string = + make_permanent_string("#f, #t, (), or an open output port"); + a_non_constant_symbol_string = + make_permanent_string("a non-constant symbol"); + a_sequence_string = make_permanent_string("a sequence"); + a_valid_radix_string = + make_permanent_string("should be between 2 and 16"); + result_is_too_large_string = + make_permanent_string("result is too large"); + its_too_large_string = make_permanent_string("it is too large"); + its_too_small_string = + make_permanent_string("it is less than the start position"); + its_negative_string = make_permanent_string("it is negative"); + its_nan_string = + make_permanent_string("NaN usually indicates a numerical error"); + its_infinite_string = make_permanent_string("it is infinite"); + too_many_indices_string = make_permanent_string("too many indices"); + value_is_missing_string = make_permanent_string("~A argument ~S's value is missing"); /* not '~A because it's normally a keyword */ + parameter_set_twice_string = + make_permanent_string("parameter set twice, ~S in ~S"); + immutable_error_string = + make_permanent_string("can't ~S ~S (it is immutable)"); + no_setter_string = + make_permanent_string("~A (~A) does not have a setter"); + cant_bind_immutable_string = + make_permanent_string("can't bind an immutable object: ~S"); + intermediate_too_large_string = + make_permanent_string("intermediate result is too large"); +#if (!HAVE_COMPLEX_NUMBERS) + no_complex_numbers_string = + make_permanent_string + ("this version of s7 does not support complex numbers"); +#endif + + format_string_1 = make_permanent_string("format: ~S ~{~S~^ ~}: ~A"); + format_string_2 = make_permanent_string("format: ~S: ~A"); + format_string_3 = + make_permanent_string("format: ~S ~{~S~^ ~}~&~NT^: ~A"); + format_string_4 = make_permanent_string("format: ~S~&~NT^: ~A"); + + too_many_arguments_string = + make_permanent_string("~S: too many arguments: ~A"); + not_enough_arguments_string = + make_permanent_string("~S: not enough arguments: ~A"); + missing_method_string = + make_permanent_string("missing ~S method in ~S"); +} + + +/* -------------------------------- make-string -------------------------------- */ +static s7_pointer g_make_string(s7_scheme * sc, s7_pointer args) +{ +#define H_make_string "(make-string len (val #\\space)) makes a string of length len filled with the character val (default: space)" +#define Q_make_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol) + + s7_pointer n = car(args); + s7_int len; + char fill; + if (!s7_is_integer(n)) { + check_method(sc, n, sc->make_string_symbol, args); + return (wrong_type_argument + (sc, sc->make_string_symbol, 1, n, T_INTEGER)); + } + len = s7_integer_checked(sc, n); + if (len == 0) + return (nil_string); + if ((len < 0) || (len > sc->max_string_length)) + return (out_of_range + (sc, sc->make_string_symbol, int_one, n, + (len < 0) ? its_negative_string : its_too_large_string)); + if (is_null(cdr(args))) + return (make_empty_string(sc, len, '\0')); /* #\null here means "don't fill/clear" */ + if (!is_character(cadr(args))) + return (method_or_bust + (sc, cadr(args), sc->make_string_symbol, args, T_CHARACTER, + 2)); + fill = s7_character(cadr(args)); + n = make_empty_string(sc, len, fill); + if (fill == '\0') + memclr((void *) string_value(n), (size_t) len); + return (n); +} + +static s7_pointer make_string_p_i(s7_scheme * sc, s7_int len) +{ + if (len == 0) + return (nil_string); + if ((len < 0) || (len > sc->max_string_length)) + return (out_of_range + (sc, sc->make_string_symbol, int_one, + wrap_integer1(sc, len), + (len < 0) ? its_negative_string : its_too_large_string)); + return (make_empty_string(sc, len, '\0')); +} + + +#if (!WITH_PURE_S7) +/* -------------------------------- string-length -------------------------------- */ +static s7_pointer g_string_length(s7_scheme * sc, s7_pointer args) +{ +#define H_string_length "(string-length str) returns the length of the string str" +#define Q_string_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol) + s7_pointer p = car(args); + if (!is_string(p)) + return (method_or_bust_one_arg + (sc, p, sc->string_length_symbol, args, T_STRING)); + return (make_integer(sc, string_length(p))); +} + +static s7_int string_length_i_7p(s7_scheme * sc, s7_pointer p) +{ + if (!is_string(p)) + return (integer + (method_or_bust_one_arg_p + (sc, p, sc->string_length_symbol, T_STRING))); + return (string_length(p)); +} +#endif + + +/* -------------------------------- string-up|downcase -------------------------------- */ +static s7_pointer g_string_downcase(s7_scheme * sc, s7_pointer args) +{ +#define H_string_downcase "(string-downcase str) returns the lower case version of str." +#define Q_string_downcase sc->pcl_s + + s7_pointer p = car(args), newstr; + s7_int i, len; + uint8_t *nstr, *ostr; + + if (!is_string(p)) + return (method_or_bust_one_arg_p + (sc, p, sc->string_downcase_symbol, T_STRING)); + len = string_length(p); + newstr = make_empty_string(sc, len, 0); + + ostr = (uint8_t *) string_value(p); + nstr = (uint8_t *) string_value(newstr); + + if (len >= 128) { + i = len - 1; + while (i >= 8) + LOOP_8(nstr[i] = lowers[(uint8_t) ostr[i]]; i--); + while (i >= 0) { + nstr[i] = lowers[(uint8_t) ostr[i]]; + i--; + } + } else + for (i = 0; i < len; i++) + nstr[i] = lowers[(uint8_t) ostr[i]]; + return (newstr); +} + +static s7_pointer g_string_upcase(s7_scheme * sc, s7_pointer args) +{ +#define H_string_upcase "(string-upcase str) returns the upper case version of str." +#define Q_string_upcase sc->pcl_s + + s7_pointer p = car(args), newstr; + s7_int i, len; + uint8_t *nstr, *ostr; + + if (!is_string(p)) + return (method_or_bust_one_arg_p + (sc, p, sc->string_upcase_symbol, T_STRING)); + len = string_length(p); + newstr = make_empty_string(sc, len, 0); + + ostr = (uint8_t *) string_value(p); + nstr = (uint8_t *) string_value(newstr); + + if (len >= 128) { + i = len - 1; + while (i >= 8) + LOOP_8(nstr[i] = uppers[(uint8_t) ostr[i]]; i--); + while (i >= 0) { + nstr[i] = uppers[(uint8_t) ostr[i]]; + i--; + } + } else + for (i = 0; i < len; i++) + nstr[i] = uppers[(uint8_t) ostr[i]]; + return (newstr); +} + + +/* -------------------------------- string-ref -------------------------------- */ +static s7_pointer string_ref_1(s7_scheme * sc, s7_pointer strng, + s7_pointer index) +{ + char *str; + s7_int ind; + + if (!s7_is_integer(index)) + return (method_or_bust_pp + (sc, index, sc->string_ref_symbol, strng, index, T_INTEGER, + 2)); + ind = s7_integer_checked(sc, index); + if (ind < 0) + return (out_of_range + (sc, sc->string_ref_symbol, int_two, index, + a_non_negative_integer_string)); + if (ind >= string_length(strng)) + return (out_of_range + (sc, sc->string_ref_symbol, int_two, index, + its_too_large_string)); + + str = string_value(strng); + return (chars[((uint8_t *) str)[ind]]); +} + +static s7_pointer g_string_ref(s7_scheme * sc, s7_pointer args) +{ +#define H_string_ref "(string-ref str index) returns the character at the index-th element of the string str" +#define Q_string_ref s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol) + + s7_pointer strng = car(args); + if (!is_string(strng)) + return (method_or_bust + (sc, strng, sc->string_ref_symbol, args, T_STRING, 1)); + return (string_ref_1(sc, strng, cadr(args))); +} + +static s7_pointer string_ref_p_pi(s7_scheme * sc, s7_pointer p1, s7_int i1) +{ + if (!is_string(p1)) + return (method_or_bust + (sc, p1, sc->string_ref_symbol, + set_plist_2(sc, p1, make_integer(sc, i1)), T_STRING, 1)); + if ((i1 >= 0) && (i1 < string_length(p1))) + return (chars[((uint8_t *) string_value(p1))[i1]]); + out_of_range(sc, sc->string_ref_symbol, int_two, wrap_integer1(sc, i1), + (i1 < 0) ? its_negative_string : its_too_large_string); + return (p1); +} + +static s7_pointer string_ref_p_pp(s7_scheme * sc, s7_pointer p1, + s7_pointer i1) +{ + if (!is_string(p1)) + return (method_or_bust_pp + (sc, p1, sc->string_ref_symbol, p1, i1, T_STRING, 1)); + return (string_ref_1(sc, p1, i1)); +} + +static s7_pointer string_ref_p_p0(s7_scheme * sc, s7_pointer p1, + s7_pointer i1) +{ /* i1 can be NULL */ + if (!is_string(p1)) + return (method_or_bust_pp + (sc, p1, sc->string_ref_symbol, p1, int_zero, T_STRING, + 1)); + if (string_length(p1) > 0) + return (chars[((uint8_t *) string_value(p1))[0]]); + out_of_range(sc, sc->string_ref_symbol, int_two, int_zero, + its_too_large_string); + return (p1); +} + +static s7_pointer string_plast_via_method(s7_scheme * sc, s7_pointer p1) +{ + s7_pointer len; + len = method_or_bust_one_arg_p(sc, p1, sc->length_symbol, T_STRING); + return (method_or_bust_with_type_pi + (sc, p1, sc->string_ref_symbol, p1, integer(len) - 1, + sc->prepackaged_type_names[T_STRING])); +} + +static s7_pointer string_ref_p_plast(s7_scheme * sc, s7_pointer p1, + s7_pointer i1) +{ + if (!is_string(p1)) + return (string_plast_via_method(sc, p1)); + if (string_length(p1) > 0) + return (chars + [((uint8_t *) string_value(p1))[string_length(p1) - 1]]); + out_of_range(sc, sc->string_ref_symbol, int_two, + wrap_integer1(sc, string_length(p1) - 1), + its_too_large_string); + return (p1); +} + +static s7_pointer string_ref_p_pi_unchecked(s7_scheme * sc, s7_pointer p1, + s7_int i1) +{ + if ((i1 >= 0) && (i1 < string_length(p1))) + return (chars[((uint8_t *) string_value(p1))[i1]]); + out_of_range(sc, sc->string_ref_symbol, int_two, wrap_integer1(sc, i1), + (i1 < 0) ? its_negative_string : its_too_large_string); + return (p1); +} + +static s7_pointer string_ref_unchecked(s7_scheme * sc, s7_pointer p1, + s7_int i1) +{ + return (chars[((uint8_t *) string_value(p1))[i1]]); +} + + +/* -------------------------------- string-set! -------------------------------- */ +static s7_pointer g_string_set(s7_scheme * sc, s7_pointer args) +{ +#define H_string_set "(string-set! str index chr) sets the index-th element of the string str to the character chr" +#define Q_string_set s7_make_signature(sc, 4, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol) + + s7_pointer strng = car(args), c, index; + char *str; + s7_int ind; + + if (!is_mutable_string(strng)) + return (mutable_method_or_bust + (sc, strng, sc->string_set_symbol, args, T_STRING, 1)); + + index = cadr(args); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, sc->string_set_symbol, args, T_INTEGER, 2)); + ind = s7_integer_checked(sc, index); + if (ind < 0) + return (out_of_range + (sc, sc->string_set_symbol, int_two, index, + a_non_negative_integer_string)); + if (ind >= string_length(strng)) + return (out_of_range + (sc, sc->string_set_symbol, int_two, index, + its_too_large_string)); + + str = string_value(strng); + c = caddr(args); + if (!is_character(c)) + return (method_or_bust + (sc, c, sc->string_set_symbol, args, T_CHARACTER, 3)); + + str[ind] = (char) s7_character(c); + return (c); +} + +static s7_pointer string_set_p_pip(s7_scheme * sc, s7_pointer p1, + s7_int i1, s7_pointer p2) +{ + if (!is_string(p1)) + simple_wrong_type_argument(sc, sc->string_set_symbol, p1, + T_STRING); + if (!is_character(p2)) + simple_wrong_type_argument(sc, sc->string_set_symbol, p2, + T_CHARACTER); + if ((i1 >= 0) && (i1 < string_length(p1))) + string_value(p1)[i1] = s7_character(p2); + else + out_of_range(sc, sc->string_set_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + return (p2); +} + +static s7_pointer string_set_p_pip_unchecked(s7_scheme * sc, s7_pointer p1, + s7_int i1, s7_pointer p2) +{ + if ((i1 >= 0) && (i1 < string_length(p1))) + string_value(p1)[i1] = s7_character(p2); + else + out_of_range(sc, sc->string_set_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + return (p2); +} + +static s7_pointer string_set_unchecked(s7_scheme * sc, s7_pointer p1, + s7_int i1, s7_pointer p2) +{ + string_value(p1)[i1] = s7_character(p2); + return (p2); +} + + +/* -------------------------------- string-append -------------------------------- */ +static s7_pointer g_string_append_1(s7_scheme * sc, s7_pointer args, + s7_pointer caller) +{ +#define H_string_append "(string-append str1 ...) appends all its string arguments into one string" +#define Q_string_append sc->pcl_s + + s7_int len = 0; + s7_pointer x, newstr; + char *pos; + + if (is_null(args)) + return (nil_string); + + s7_gc_protect_via_stack(sc, args); + /* get length for new string */ + for (x = args; is_not_null(x); x = cdr(x)) { + s7_pointer p; + p = car(x); + if (!is_string(p)) { + /* look for string-append and if found, cobble up a plausible intermediate call */ + if (has_active_methods(sc, p)) { + s7_pointer func; + func = find_method_with_let(sc, p, caller); + if (func != sc->undefined) { + s7_pointer y; + if (len == 0) { + unstack(sc); + return (call_method(sc, p, func, x)); /* not args (string-append "" "" ...) */ + } + newstr = make_empty_string(sc, len, 0); + for (pos = string_value(newstr), y = args; y != x; + pos += string_length(car(y)), y = cdr(y)) + memcpy(pos, string_value(car(y)), + string_length(car(y))); + unstack(sc); + return (call_method + (sc, p, func, set_ulist_1(sc, newstr, x))); + } + } + unstack(sc); + return (wrong_type_argument + (sc, caller, position_of(x, args), p, T_STRING)); + } + len += string_length(p); + } + if (len == 0) { + unstack(sc); + return (nil_string); + } + if (len > sc->max_string_length) { + unstack(sc); + return (s7_error(sc, sc->out_of_range_symbol, + set_elist_4(sc, + wrap_string(sc, + "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", + 70), caller, + wrap_integer1(sc, len), + wrap_integer2(sc, + sc->max_string_length)))); + } + newstr = inline_make_empty_string(sc, len, 0); + for (pos = string_value(newstr), x = args; is_not_null(x); x = cdr(x)) { + len = string_length(car(x)); + if (len > 0) { + memcpy(pos, string_value(car(x)), len); + pos += len; + } + } + unstack(sc); + return (newstr); +} + +static s7_pointer g_string_append(s7_scheme * sc, s7_pointer args) +{ + return (g_string_append_1(sc, args, sc->string_append_symbol)); +} + +static inline s7_pointer string_append_1(s7_scheme * sc, s7_pointer s1, + s7_pointer s2) +{ + if ((is_string(s1)) && (is_string(s2))) { + s7_int len, pos = string_length(s1); + s7_pointer newstr; + if (pos == 0) + return (make_string_with_length + (sc, string_value(s2), string_length(s2))); + len = pos + string_length(s2); + if (len == pos) + return (make_string_with_length + (sc, string_value(s1), string_length(s1))); + if (len > sc->max_string_length) + return (s7_error(sc, sc->out_of_range_symbol, + set_elist_4(sc, + wrap_string(sc, + "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", + 70), + sc->string_append_symbol, + wrap_integer1(sc, len), + wrap_integer2(sc, + sc->max_string_length)))); + newstr = make_empty_string(sc, len, 0); /* len+1 0-terminated */ + memcpy(string_value(newstr), string_value(s1), pos); + memcpy((char *) (string_value(newstr) + pos), string_value(s2), + string_length(s2)); + return (newstr); + } + return (g_string_append_1 + (sc, list_2(sc, s1, s2), sc->string_append_symbol)); +} + +static s7_pointer string_append_p_pp(s7_scheme * sc, s7_pointer s1, + s7_pointer s2) +{ + return (string_append_1(sc, s1, s2)); +} + +static s7_pointer g_string_append_2(s7_scheme * sc, s7_pointer args) +{ + return (string_append_1(sc, car(args), cadr(args))); +} + +static void check_for_substring_temp(s7_scheme * sc, s7_pointer expr); + +static s7_pointer string_append_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + check_for_substring_temp(sc, expr); + return ((args == 2) ? sc->string_append_2 : f); +} + + +/* -------------------------------- substring -------------------------------- */ +static s7_pointer start_and_end(s7_scheme * sc, s7_pointer caller, + s7_pointer args, int32_t position, + s7_pointer index_args, s7_int * start, + s7_int * end) +{ + /* we assume that *start=0 and *end=length, that end is "exclusive", return true if the start/end points are not changed */ + s7_pointer pstart = car(index_args); + s7_int index; + + if (!s7_is_integer(pstart)) + return (method_or_bust + (sc, pstart, caller, args, T_INTEGER, position)); + index = s7_integer_checked(sc, pstart); + if ((index < 0) || (index > *end)) /* *end == length here */ + return (out_of_range + (sc, caller, small_int(position), pstart, + (index < + 0) ? its_negative_string : its_too_large_string)); + *start = index; + + if (is_pair(cdr(index_args))) { + s7_pointer pend = cadr(index_args); + if (!s7_is_integer(pend)) + return (method_or_bust + (sc, pend, caller, args, T_INTEGER, position + 1)); + index = s7_integer_checked(sc, pend); + if ((index < *start) || (index > *end)) + return (out_of_range + (sc, caller, small_int(position + 1), pend, + (index < + *start) ? its_too_small_string : + its_too_large_string)); + *end = index; + } + return (sc->unused); +} + +static s7_pointer g_substring(s7_scheme * sc, s7_pointer args) +{ +#define H_substring "(substring str start (end (length str))) returns the portion of the string str between start and \ +end: (substring \"01234\" 1 2) -> \"1\"" +#define Q_substring s7_make_circular_signature(sc, 2, 3, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol) + + s7_pointer x, str = car(args); + s7_int start = 0, end, len; + char *s; + + if (!is_string(str)) + return (method_or_bust + (sc, str, sc->substring_symbol, args, T_STRING, 1)); + + end = string_length(str); + if (!is_null(cdr(args))) { + x = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args), + &start, &end); + if (x != sc->unused) + return (x); + } + s = string_value(str); + len = end - start; + if (len == 0) + return (nil_string); + x = inline_make_string_with_length(sc, (char *) (s + start), len); + string_value(x)[len] = 0; + return (x); +} + +static s7_pointer g_substring_uncopied(s7_scheme * sc, s7_pointer args) +{ + s7_pointer str = car(args); + s7_int start = 0, end; + + if (!is_string(str)) + return (method_or_bust + (sc, str, sc->substring_symbol, args, T_STRING, 1)); + + end = string_length(str); + if (!is_null(cdr(args))) { + s7_pointer x; + x = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args), + &start, &end); + if (x != sc->unused) + return (x); + } + return (wrap_string + (sc, (char *) (string_value(str) + start), end - start)); +} + +static s7_pointer substring_uncopied_p_pii(s7_scheme * sc, s7_pointer str, + s7_int start, s7_int end) +{ + if (!is_string(str)) + return (method_or_bust + (sc, str, sc->substring_symbol, + set_plist_3(sc, str, make_integer(sc, start), + make_integer(sc, end)), T_STRING, 1)); + if ((end < start) || (end > string_length(str))) + return (out_of_range + (sc, sc->substring_symbol, int_three, + wrap_integer1(sc, end), + (end < + start) ? its_too_small_string : its_too_large_string)); + if ((start < 0) || (start > end)) + return (out_of_range + (sc, sc->substring_symbol, int_two, + wrap_integer1(sc, start), + (start < + 0) ? its_negative_string : its_too_large_string)); + return (wrap_string + (sc, (char *) (string_value(str) + start), end - start)); +} + +static s7_pointer g_get_output_string(s7_scheme * sc, s7_pointer args); + +static void check_for_substring_temp(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer nps[NUM_STRING_WRAPPERS]; + s7_pointer p, arg; + int32_t substrs = 0, i; + /* don't use substring_uncopied for arg if arg is returned: (reverse! (write-string (substring x ...))) */ + for (p = cdr(expr); is_pair(p); p = cdr(p)) { + arg = car(p); + if ((is_pair(arg)) && + (is_symbol(car(arg))) && + (is_safely_optimized(arg)) && (has_fn(arg))) { + if (fn_proc(arg) == g_substring) { + if (substrs < NUM_STRING_WRAPPERS) + nps[substrs++] = arg; + } else if (fn_proc(arg) == g_symbol_to_string) + set_c_function(arg, sc->symbol_to_string_uncopied); + else if ((fn_proc(arg) == g_get_output_string) + && (is_null(cddr(arg)))) + set_c_function(arg, sc->get_output_string_uncopied); + } + } + for (i = 0; i < substrs; i++) + set_c_function(nps[i], sc->substring_uncopied); +} + +static s7_pointer string_substring_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + /* used by several string functions */ + check_for_substring_temp(sc, expr); + return (f); +} + + +/* -------------------------------- string-copy -------------------------------- */ +static s7_pointer g_string_copy(s7_scheme * sc, s7_pointer args) +{ +#define H_string_copy "(string-copy str dest-str (dest-start 0) dest-end) returns a copy of its string argument. If dest-str is given, \ + string-copy copies its first argument into the second, starting at dest-start in the second string and returns dest-str" +#define Q_string_copy s7_make_signature(sc, 5, sc->is_string_symbol, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol) + + s7_pointer source = car(args), p, dest; + s7_int start, end; + + if (!is_string(source)) + return (method_or_bust + (sc, source, sc->string_copy_symbol, args, T_STRING, 1)); + if (is_null(cdr(args))) + return (make_string_with_length + (sc, string_value(source), string_length(source))); + + dest = cadr(args); + if (!is_string(dest)) + return (wrong_type_argument + (sc, sc->string_copy_symbol, 2, dest, T_STRING)); + if (is_immutable(dest)) + return (immutable_object_error + (sc, + set_elist_2(sc, + wrap_string(sc, + "can't string-copy to ~S; it is immutable", + 40), dest))); + + end = string_length(dest); + p = cddr(args); + if (is_null(p)) + start = 0; + else { + if (!s7_is_integer(car(p))) + return (wrong_type_argument + (sc, sc->string_copy_symbol, 3, car(p), T_INTEGER)); + start = s7_integer_checked(sc, car(p)); + if (start < 0) + start = 0; + p = cdr(p); + if (is_null(p)) + end = start + string_length(source); + else { + if (!s7_is_integer(car(p))) + return (wrong_type_argument + (sc, sc->string_copy_symbol, 4, car(p), + T_INTEGER)); + end = s7_integer_checked(sc, car(p)); + if (end < 0) + end = start; + } + } + if (end > string_length(dest)) + end = string_length(dest); + if (end <= start) + return (dest); + if ((end - start) > string_length(source)) + end = start + string_length(source); + memcpy((void *) (string_value(dest) + start), + (void *) (string_value(source)), end - start); + return (dest); +} + +static s7_pointer string_copy_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + if (args == 1) + check_for_substring_temp(sc, expr); + return (f); +} + + +/* -------------------------------- string comparisons -------------------------------- */ +static int32_t scheme_strcmp(s7_pointer s1, s7_pointer s2) +{ + /* tricky here because str[i] must be treated as unsigned: (stringchar #xf0)) (string (integer->char #x70))) + * and null or lack thereof does not say anything about the string end + */ + size_t i, len, len1 = (size_t) string_length(s1), len2 = + (size_t) string_length(s2); + char *str1 = string_value(s1), *str2 = string_value(s2); + + len = (len1 > len2) ? len2 : len1; + if (len < sizeof(size_t)) { + for (i = 0; i < len; i++) { + if ((uint8_t) (str1[i]) < (uint8_t) (str2[i])) + return (-1); + if ((uint8_t) (str1[i]) > (uint8_t) (str2[i])) + return (1); + } + } else { + /* this algorithm from stackoverflow(?), with various changes (original did not work for large strings, etc) */ + size_t last, pos; + size_t *ptr1, *ptr2; + + last = len / sizeof(size_t); + for (ptr1 = (size_t *) str1, ptr2 = (size_t *) str2, i = 0; + i < last; i++) + if (ptr1[i] != ptr2[i]) + break; + + for (pos = i * sizeof(size_t); pos < len; pos++) { + if ((uint8_t) str1[pos] < (uint8_t) str2[pos]) + return (-1); + if ((uint8_t) str1[pos] > (uint8_t) str2[pos]) + return (1); + } + } + if (len1 < len2) + return (-1); + return ((len1 > len2) ? 1 : 0); +} + +static bool is_string_via_method(s7_scheme * sc, s7_pointer p) +{ + if (s7_is_string(p)) + return (true); + if (has_active_methods(sc, p)) { + s7_pointer f; + f = find_method_with_let(sc, p, sc->is_string_symbol); + if (f != sc->undefined) + return (is_true + (sc, call_method(sc, p, f, set_plist_1(sc, p)))); + } + return (false); +} + +static s7_pointer g_string_cmp(s7_scheme * sc, s7_pointer args, + int32_t val, s7_pointer sym) +{ + s7_pointer x, y = car(args); + if (!is_string(y)) + return (method_or_bust(sc, y, sym, args, T_STRING, 1)); + for (x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) { + if (!is_string(car(x))) + return (method_or_bust + (sc, car(x), sym, set_ulist_1(sc, y, x), T_STRING, + position_of(x, args))); + if (scheme_strcmp(y, car(x)) != val) { + for (y = cdr(x); is_pair(y); y = cdr(y)) + if (!is_string_via_method(sc, car(y))) + return (wrong_type_argument + (sc, sym, position_of(y, args), car(y), + T_STRING)); + return (sc->F); + } + } + return (sc->T); +} + +static s7_pointer g_string_cmp_not(s7_scheme * sc, s7_pointer args, + int32_t val, s7_pointer sym) +{ + s7_pointer x, y = car(args); + if (!is_string(y)) + return (method_or_bust(sc, y, sym, args, T_STRING, 1)); + for (x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) { + if (!is_string(car(x))) + return (method_or_bust + (sc, car(x), sym, set_ulist_1(sc, y, x), T_STRING, + position_of(x, args))); + if (scheme_strcmp(y, car(x)) == val) { + for (y = cdr(x); is_pair(y); y = cdr(y)) + if (!is_string_via_method(sc, car(y))) + return (wrong_type_argument + (sc, sym, position_of(y, args), car(y), + T_STRING)); + return (sc->F); + } + } + return (sc->T); +} + +static bool scheme_strings_are_equal(s7_pointer x, s7_pointer y) +{ + return ((string_length(x) == string_length(y)) && + (strings_are_equal_with_length + (string_value(x), string_value(y), string_length(x)))); +} + +static s7_pointer g_strings_are_equal(s7_scheme * sc, s7_pointer args) +{ +#define H_strings_are_equal "(string=? str ...) returns #t if all the string arguments are equal" +#define Q_strings_are_equal sc->pcl_bs + + /* C-based check stops at null, but we can have embedded nulls. + * (let ((s1 "1234") (s2 "1245")) (string-set! s1 1 #\null) (string-set! s2 1 #\null) (string=? s1 s2)) + */ + s7_pointer x, y = car(args); + bool happy = true; + + if (!is_string(y)) + return (method_or_bust + (sc, y, sc->string_eq_symbol, args, T_STRING, 1)); + + for (x = cdr(args); is_pair(x); x = cdr(x)) { + s7_pointer p = car(x); + if (y != p) { + if (!is_string(p)) + return (method_or_bust + (sc, p, sc->string_eq_symbol, + set_ulist_1(sc, y, x), T_STRING, position_of(x, + args))); + if (happy) + happy = scheme_strings_are_equal(p, y); + } + } + return ((happy) ? sc->T : sc->F); +} + +static s7_pointer g_strings_are_less(s7_scheme * sc, s7_pointer args) +{ +#define H_strings_are_less "(stringpcl_bs + return (g_string_cmp(sc, args, -1, sc->string_lt_symbol)); +} + +static s7_pointer g_strings_are_greater(s7_scheme * sc, s7_pointer args) +{ +#define H_strings_are_greater "(string>? str ...) returns #t if all the string arguments are decreasing" +#define Q_strings_are_greater sc->pcl_bs + return (g_string_cmp(sc, args, 1, sc->string_gt_symbol)); +} + +static s7_pointer g_strings_are_geq(s7_scheme * sc, s7_pointer args) +{ +#define H_strings_are_geq "(string>=? str ...) returns #t if all the string arguments are equal or decreasing" +#define Q_strings_are_geq sc->pcl_bs + return (g_string_cmp_not(sc, args, -1, sc->string_geq_symbol)); +} + +static s7_pointer g_strings_are_leq(s7_scheme * sc, s7_pointer args) +{ +#define H_strings_are_leq "(string<=? str ...) returns #t if all the string arguments are equal or increasing" +#define Q_strings_are_leq sc->pcl_bs + return (g_string_cmp_not(sc, args, 1, sc->string_leq_symbol)); +} + +static s7_pointer g_string_equal_2(s7_scheme * sc, s7_pointer args) +{ + if (!is_string(car(args))) + return (method_or_bust + (sc, car(args), sc->string_eq_symbol, args, T_STRING, 1)); + if (!is_string(cadr(args))) + return (method_or_bust + (sc, cadr(args), sc->string_eq_symbol, args, T_STRING, 2)); + return (make_boolean + (sc, scheme_strings_are_equal(car(args), cadr(args)))); +} + +static s7_pointer g_string_equal_2c(s7_scheme * sc, s7_pointer args) +{ + if (!is_string(car(args))) + return (method_or_bust + (sc, car(args), sc->string_eq_symbol, args, T_STRING, 1)); + return (make_boolean + (sc, scheme_strings_are_equal(car(args), cadr(args)))); +} + +static s7_pointer g_string_less_2(s7_scheme * sc, s7_pointer args) +{ + if (!is_string(car(args))) + return (method_or_bust + (sc, car(args), sc->string_lt_symbol, args, T_STRING, 1)); + if (!is_string(cadr(args))) + return (method_or_bust + (sc, cadr(args), sc->string_lt_symbol, args, T_STRING, 2)); + return (make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == -1)); +} + +static s7_pointer g_string_greater_2(s7_scheme * sc, s7_pointer args) +{ + if (!is_string(car(args))) + return (method_or_bust + (sc, car(args), sc->string_gt_symbol, args, T_STRING, 1)); + if (!is_string(cadr(args))) + return (method_or_bust + (sc, cadr(args), sc->string_gt_symbol, args, T_STRING, 2)); + return (make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == 1)); +} + +#define check_string2_args(Sc, Caller, P1, P2) \ + do { \ + if (!is_string(p1)) return(method_or_bust(sc, P1, Caller, set_plist_2(Sc, P1, P2), T_STRING, 1) != Sc->F); \ + if (!is_string(p2)) return(method_or_bust(sc, P2, Caller, set_plist_2(Sc, P1, P2), T_STRING, 2) != Sc->F); \ + } while (0) + +static bool string_lt_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (scheme_strcmp(p1, p2) == -1); +} + +static bool string_lt_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_string2_args(sc, sc->string_lt_symbol, p1, p2); + return (scheme_strcmp(p1, p2) == -1); +} + +static bool string_leq_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (scheme_strcmp(p1, p2) != 1); +} + +static bool string_leq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_string2_args(sc, sc->string_leq_symbol, p1, p2); + return (scheme_strcmp(p1, p2) != 1); +} + +static bool string_gt_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (scheme_strcmp(p1, p2) == 1); +} + +static bool string_gt_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_string2_args(sc, sc->string_gt_symbol, p1, p2); + return (scheme_strcmp(p1, p2) == 1); +} + +static bool string_geq_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (scheme_strcmp(p1, p2) != -1); +} + +static bool string_geq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_string2_args(sc, sc->string_geq_symbol, p1, p2); + return (scheme_strcmp(p1, p2) != -1); +} + +static bool string_eq_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (scheme_strings_are_equal(p1, p2)); +} + +static bool string_eq_b_7pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + check_string2_args(sc, sc->string_eq_symbol, p1, p2); + return (scheme_strings_are_equal(p1, p2)); +} + + +static s7_pointer string_equal_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + check_for_substring_temp(sc, expr); + return ((args == + 2) ? ((is_string(caddr(expr))) ? sc-> + string_equal_2c : sc->string_equal_2) : f); +} + +static s7_pointer string_less_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + check_for_substring_temp(sc, expr); + return ((args == 2) ? sc->string_less_2 : f); +} + +static s7_pointer string_greater_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + check_for_substring_temp(sc, expr); + return ((args == 2) ? sc->string_greater_2 : f); +} + + +#if (!WITH_PURE_S7) +static int32_t scheme_strcasecmp(s7_pointer s1, s7_pointer s2) +{ + /* same as scheme_strcmp -- watch out for unwanted sign! and lack of trailing null (length sets string end). + */ + s7_int i, len, len1 = string_length(s1), len2 = string_length(s2); + uint8_t *str1 = (uint8_t *) string_value(s1), *str2 = + (uint8_t *) string_value(s2); + + len = (len1 > len2) ? len2 : len1; + for (i = 0; i < len; i++) { + if (uppers[(int32_t) str1[i]] < uppers[(int32_t) str2[i]]) + return (-1); + if (uppers[(int32_t) str1[i]] > uppers[(int32_t) str2[i]]) + return (1); + } + if (len1 < len2) + return (-1); + return ((len1 > len2) ? 1 : 0); +} + +static bool scheme_strequal_ci(s7_pointer s1, s7_pointer s2) +{ + /* same as scheme_strcmp -- watch out for unwanted sign! */ + s7_int i, len = string_length(s1), len2 = string_length(s2); + uint8_t *str1, *str2; + + if (len != len2) + return (false); + str1 = (uint8_t *) string_value(s1); + str2 = (uint8_t *) string_value(s2); + for (i = 0; i < len; i++) + if (uppers[(int32_t) str1[i]] != uppers[(int32_t) str2[i]]) + return (false); + return (true); +} + +static s7_pointer string_check_method(s7_scheme * sc, s7_pointer sym, + s7_pointer x, s7_pointer y, + s7_pointer args) +{ + for (y = cdr(x); is_pair(y); y = cdr(y)) + if (!is_string_via_method(sc, car(y))) + return (wrong_type_argument + (sc, sym, position_of(y, args), car(y), T_STRING)); + return (sc->F); +} + +static s7_pointer g_string_ci_cmp(s7_scheme * sc, s7_pointer args, + int32_t val, s7_pointer sym) +{ + s7_pointer x, y = car(args); + + if (!is_string(y)) + return (method_or_bust(sc, y, sym, args, T_STRING, 1)); + + for (x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) { + if (!is_string(car(x))) + return (method_or_bust + (sc, car(x), sym, set_ulist_1(sc, y, x), T_STRING, + position_of(x, args))); + if (val == 0) { + if (!scheme_strequal_ci(y, car(x))) + return (string_check_method(sc, sym, x, y, args)); + } else if (scheme_strcasecmp(y, car(x)) != val) + return (string_check_method(sc, sym, x, y, args)); + } + return (sc->T); +} + +static s7_pointer g_string_ci_cmp_not(s7_scheme * sc, s7_pointer args, + int32_t val, s7_pointer sym) +{ + s7_pointer x, y = car(args); + + if (!is_string(y)) + return (method_or_bust(sc, y, sym, args, T_STRING, 1)); + + for (x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) { + if (!is_string(car(x))) + return (method_or_bust + (sc, car(x), sym, set_ulist_1(sc, y, x), T_STRING, + position_of(x, args))); + if (scheme_strcasecmp(y, car(x)) == val) + return (string_check_method(sc, sym, x, y, args)); + } + return (sc->T); +} + +static s7_pointer g_strings_are_ci_equal(s7_scheme * sc, s7_pointer args) +{ +#define H_strings_are_ci_equal "(string-ci=? str ...) returns #t if all the string arguments are equal, ignoring case" +#define Q_strings_are_ci_equal sc->pcl_bs + return (g_string_ci_cmp(sc, args, 0, sc->string_ci_eq_symbol)); +} + +static s7_pointer g_strings_are_ci_less(s7_scheme * sc, s7_pointer args) +{ +#define H_strings_are_ci_less "(string-cipcl_bs + return (g_string_ci_cmp(sc, args, -1, sc->string_ci_lt_symbol)); +} + +static s7_pointer g_strings_are_ci_greater(s7_scheme * sc, s7_pointer args) +{ +#define H_strings_are_ci_greater "(string-ci>? str ...) returns #t if all the string arguments are decreasing, ignoring case" +#define Q_strings_are_ci_greater sc->pcl_bs + return (g_string_ci_cmp(sc, args, 1, sc->string_ci_gt_symbol)); +} + +static s7_pointer g_strings_are_ci_geq(s7_scheme * sc, s7_pointer args) +{ +#define H_strings_are_ci_geq "(string-ci>=? str ...) returns #t if all the string arguments are equal or decreasing, ignoring case" +#define Q_strings_are_ci_geq sc->pcl_bs + return (g_string_ci_cmp_not(sc, args, -1, sc->string_ci_geq_symbol)); +} + +static s7_pointer g_strings_are_ci_leq(s7_scheme * sc, s7_pointer args) +{ +#define H_strings_are_ci_leq "(string-ci<=? str ...) returns #t if all the string arguments are equal or increasing, ignoring case" +#define Q_strings_are_ci_leq sc->pcl_bs + return (g_string_ci_cmp_not(sc, args, 1, sc->string_ci_leq_symbol)); +} + +static bool string_ci_lt_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (scheme_strcasecmp(p1, p2) == -1); +} + +static bool string_ci_lt_b_7pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + check_string2_args(sc, sc->string_ci_lt_symbol, p1, p2); + return (scheme_strcasecmp(p1, p2) == -1); +} + +static bool string_ci_leq_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (scheme_strcasecmp(p1, p2) != 1); +} + +static bool string_ci_leq_b_7pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + check_string2_args(sc, sc->string_ci_leq_symbol, p1, p2); + return (scheme_strcasecmp(p1, p2) != 1); +} + +static bool string_ci_gt_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (scheme_strcasecmp(p1, p2) == 1); +} + +static bool string_ci_gt_b_7pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + check_string2_args(sc, sc->string_ci_gt_symbol, p1, p2); + return (scheme_strcasecmp(p1, p2) == 1); +} + +static bool string_ci_geq_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (scheme_strcasecmp(p1, p2) != -1); +} + +static bool string_ci_geq_b_7pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + check_string2_args(sc, sc->string_ci_geq_symbol, p1, p2); + return (scheme_strcasecmp(p1, p2) != -1); +} + +static bool string_ci_eq_b_unchecked(s7_pointer p1, s7_pointer p2) +{ + return (scheme_strcasecmp(p1, p2) == 0); +} + +static bool string_ci_eq_b_7pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + check_string2_args(sc, sc->string_ci_eq_symbol, p1, p2); + return (scheme_strcasecmp(p1, p2) == 0); +} +#endif /* pure s7 */ + +static s7_pointer g_string_fill_1(s7_scheme * sc, s7_pointer caller, + s7_pointer args) +{ + s7_pointer x = car(args), chr; + s7_int start = 0, end; + + if (!is_string(x)) + return (method_or_bust(sc, x, caller, args, T_STRING, 1)); /* not two methods here */ + if (is_immutable_string(x)) + return (immutable_object_error + (sc, set_elist_3(sc, immutable_error_string, caller, x))); + + chr = cadr(args); + if (!is_character(chr)) + return (method_or_bust(sc, chr, caller, args, T_CHARACTER, 2)); + + end = string_length(x); + if (!is_null(cddr(args))) { + s7_pointer p; + p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); + if (p != sc->unused) + return (p); + if (start == end) + return (chr); + } + if (end == 0) + return (chr); + local_memset((void *) (string_value(x) + start), (int32_t) character(chr), end - start); /* not memclr even if chr=#\null! */ + return (chr); +} + +#if (!WITH_PURE_S7) +/* -------------------------------- string-fill! -------------------------------- */ +static s7_pointer g_string_fill(s7_scheme * sc, s7_pointer args) +{ +#define H_string_fill "(string-fill! str chr start end) fills the string str with the character chr" +#define Q_string_fill s7_make_signature(sc, 5, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol), sc->is_string_symbol, sc->is_char_symbol, sc->is_integer_symbol, sc->is_integer_symbol) + return (g_string_fill_1(sc, sc->string_fill_symbol, args)); +} +#endif + + +/* -------------------------------- string -------------------------------- */ +static s7_pointer g_string_1(s7_scheme * sc, s7_pointer args, + s7_pointer sym) +{ + int32_t i, len; + s7_pointer x, newstr; + char *str; + if (is_null(args)) + return (nil_string); + + /* get length for new string and check arg types */ + for (len = 0, x = args; is_not_null(x); len++, x = cdr(x)) { + s7_pointer p = car(x); + if (!is_character(p)) { + if (has_active_methods(sc, p)) { + s7_pointer func; + func = find_method_with_let(sc, p, sym); + if (func != sc->undefined) { + s7_pointer y; + if (len == 0) + return (call_method(sc, p, func, args)); + newstr = make_empty_string(sc, len, 0); + str = string_value(newstr); + for (i = 0, y = args; y != x; i++, y = cdr(y)) + str[i] = character(car(y)); + return (g_string_append_1 + (sc, + set_plist_2(sc, newstr, + call_method(sc, p, func, x)), + sym)); + } + } + return (wrong_type_argument + (sc, sym, len + 1, car(x), T_CHARACTER)); + } + } + newstr = inline_make_empty_string(sc, len, 0); + str = string_value(newstr); + for (i = 0, x = args; is_not_null(x); i++, x = cdr(x)) + str[i] = character(car(x)); + return (newstr); +} + +static s7_pointer g_string(s7_scheme * sc, s7_pointer args) +{ +#define H_string "(string chr...) appends all its character arguments into one string" +#define Q_string s7_make_circular_signature(sc, 1, 2, sc->is_string_symbol, sc->is_char_symbol) + return ((is_null(args)) ? nil_string : + g_string_1(sc, args, sc->string_symbol)); +} + +static s7_pointer g_string_c1(s7_scheme * sc, s7_pointer args) +{ + s7_pointer c = car(args), str; + /* no multiple values here because no pairs below */ + if (!is_character(c)) + return (method_or_bust + (sc, c, sc->string_symbol, args, T_CHARACTER, 1)); + str = inline_make_empty_string(sc, 1, 0); /* can't put character(c) here because null is handled specially */ + string_value(str)[0] = character(c); + return (str); +} + +static s7_pointer string_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + return (((args == 1) && (!is_pair(cadr(expr)))) ? sc->string_c1 : f); +} + +static s7_pointer string_p_p(s7_scheme * sc, s7_pointer p) +{ + s7_pointer str; + if (!is_character(p)) + return (g_string_1(sc, set_plist_1(sc, p), sc->string_symbol)); + str = inline_make_empty_string(sc, 1, 0); + string_value(str)[0] = character(p); + return (str); +} + + +/* -------------------------------- list->string -------------------------------- */ +#if (!WITH_PURE_S7) +static s7_pointer g_list_to_string(s7_scheme * sc, s7_pointer args) +{ +#define H_list_to_string "(list->string lst) appends all the list's characters into one string; (apply string lst)" +#define Q_list_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_proper_list_symbol) + + if (is_null(car(args))) + return (nil_string); + + if (!s7_is_proper_list(sc, car(args))) + return (method_or_bust_with_type_one_arg + (sc, car(args), sc->list_to_string_symbol, args, + wrap_string(sc, + "a (proper, non-circular) list of characters", + 43))); + return (g_string_1(sc, car(args), sc->list_to_string_symbol)); +} +#endif + + +/* -------------------------------- string->list -------------------------------- */ +static s7_pointer string_to_list(s7_scheme * sc, const char *str, + s7_int len) +{ + s7_int i; + s7_pointer result; + if (len == 0) + return (sc->nil); + check_free_heap_size(sc, len); + sc->v = sc->nil; + for (i = len - 1; i >= 0; i--) + sc->v = cons_unchecked(sc, chars[((uint8_t) str[i])], sc->v); + result = sc->v; + sc->v = sc->nil; + return (result); +} + +#if (!WITH_PURE_S7) +static s7_pointer g_string_to_list(s7_scheme * sc, s7_pointer args) +{ +#define H_string_to_list "(string->list str start end) returns the elements of the string str in a list; (map values str)" +#define Q_string_to_list s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_string_symbol, sc->is_integer_symbol) + + s7_int i, start = 0, end; + s7_pointer p, str = car(args); + + if (!is_string(str)) + return (method_or_bust_one_arg + (sc, str, sc->string_to_list_symbol, args, T_STRING)); + + end = string_length(str); + if (!is_null(cdr(args))) { + p = start_and_end(sc, sc->string_to_list_symbol, args, 2, + cdr(args), &start, &end); + if (p != sc->unused) + return (p); + if (start == end) + return (sc->nil); + } else if (end == 0) + return (sc->nil); + if ((end - start) > sc->max_list_length) + return (out_of_range + (sc, sc->string_to_list_symbol, int_one, car(args), + its_too_large_string)); + + sc->w = sc->nil; + check_free_heap_size(sc, end - start); + for (i = end - 1; i >= start; i--) + sc->w = + cons_unchecked(sc, chars[((uint8_t) string_value(str)[i])], + sc->w); + p = sc->w; + sc->w = sc->nil; + return (p); +} + +static s7_pointer string_to_list_p_p(s7_scheme * sc, s7_pointer str) +{ + s7_int i, len; + s7_pointer p; + const uint8_t *val; + if (!is_string(str)) + return (method_or_bust_one_arg + (sc, str, sc->string_to_list_symbol, set_plist_1(sc, str), + T_STRING)); + len = string_length(str); + if (len == 0) + return (sc->nil); + check_free_heap_size(sc, len); + val = (const uint8_t *) string_value(str); + for (p = sc->nil, i = len - 1; i >= 0; i--) + p = cons_unchecked(sc, chars[val[i]], p); + return (p); +} +#endif + + +/* -------------------------------- port-closed? -------------------------------- */ +static s7_pointer g_is_port_closed(s7_scheme * sc, s7_pointer args) +{ +#define H_is_port_closed "(port-closed? p) returns #t if the port p is closed." +#define Q_is_port_closed s7_make_signature(sc, 2, sc->is_boolean_symbol, s7_make_signature(sc, 3, sc->is_input_port_symbol, sc->is_output_port_symbol, sc->not_symbol)) + + s7_pointer x = car(args); + if ((is_input_port(x)) || (is_output_port(x))) + return (make_boolean(sc, port_is_closed(x))); + if ((x == current_output_port(sc)) && (x == sc->F)) + return (sc->F); + return (method_or_bust_with_type_one_arg + (sc, x, sc->is_port_closed_symbol, args, + wrap_string(sc, "a port", 6))); +} + +static bool is_port_closed_b_7p(s7_scheme * sc, s7_pointer x) +{ + if ((is_input_port(x)) || (is_output_port(x))) + return (port_is_closed(x)); + if ((x == current_output_port(sc)) && (x == sc->F)) + return (false); + return (method_or_bust_with_type_one_arg + (sc, x, sc->is_port_closed_symbol, set_plist_1(sc, x), + wrap_string(sc, "a port", 6)) != sc->F); +} + + +/* -------------------------------- port-position -------------------------------- */ +static s7_pointer g_port_position(s7_scheme * sc, s7_pointer args) +{ +#define H_port_position "(port-position input-port) returns the current location (in bytes) in the port's data where the next read will take place." +#define Q_port_position s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_input_port_symbol) + + s7_pointer port = car(args); + if (!(is_input_port(port))) + return (simple_wrong_type_argument + (sc, sc->port_position_symbol, port, T_INPUT_PORT)); + if (port_is_closed(port)) + return (s7_wrong_type_arg_error + (sc, "port-position", 0, port, "an open input port")); + if (is_string_port(port)) + return (make_integer(sc, port_position(port))); +#if (!MS_WINDOWS) + if (is_file_port(port)) + return (make_integer(sc, ftell(port_file(port)))); +#endif + return (int_zero); +} + +static s7_pointer g_set_port_position(s7_scheme * sc, s7_pointer args) +{ + s7_pointer port = car(args), pos; + s7_int position; + + if (!(is_input_port(port))) + return (s7_wrong_type_arg_error + (sc, "set! port-position", 1, port, "an input port")); + if (port_is_closed(port)) + return (s7_wrong_type_arg_error + (sc, "set! port-position", 1, port, "an open input port")); + + pos = cadr(args); + if (!is_t_integer(pos)) + return (s7_wrong_type_arg_error + (sc, "set! port-position", 2, pos, "an integer")); + position = s7_integer_checked(sc, pos); + if (position < 0) + return (out_of_range + (sc, sc->port_position_symbol, int_two, pos, + its_negative_string)); + + if (is_string_port(port)) + port_position(port) = position; +#if (!MS_WINDOWS) + else if (is_file_port(port)) { + rewind(port_file(port)); + fseek(port_file(port), (long) position, SEEK_SET); + } +#endif + return (pos); +} + + +/* -------------------------------- port-file -------------------------------- */ +static s7_pointer g_port_file(s7_scheme * sc, s7_pointer args) +{ +#define H_port_file "(port-file port) returns the FILE* pointer associated with the port, wrapped in a c-pointer object" +#define Q_port_file s7_make_signature(sc, 2, sc->is_c_pointer_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol)) + + s7_pointer port = car(args); + if ((!is_input_port(port)) && (!is_output_port(port))) + return (s7_wrong_type_arg_error + (sc, "port-file", 0, port, "a port")); + if (port_is_closed(port)) + return (s7_wrong_type_arg_error + (sc, "port-file", 0, port, "an open port")); +#if (!MS_WINDOWS) + if (is_file_port(port)) + return (s7_make_c_pointer_with_type + (sc, (void *) (port_file(port)), sc->file__symbol, sc->F)); +#endif + return (s7_make_c_pointer(sc, NULL)); +} + + +/* -------------------------------- port-line-number -------------------------------- */ +static s7_pointer port_line_number_p_p(s7_scheme * sc, s7_pointer x) +{ + if ((!(is_input_port(x))) || (port_is_closed(x))) + return (method_or_bust_with_type_one_arg_p + (sc, x, sc->port_line_number_symbol, + an_input_port_string)); + return (make_integer(sc, port_line_number(x))); +} + +static s7_pointer g_port_line_number(s7_scheme * sc, s7_pointer args) +{ +#define H_port_line_number "(port-line-number input-file-port) returns the current read line number of port" +#define Q_port_line_number s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_input_port_symbol) + return (port_line_number_p_p + (sc, (is_null(args)) ? current_input_port(sc) : car(args))); +} + +s7_int s7_port_line_number(s7_scheme * sc, s7_pointer p) +{ + if (!(is_input_port(p))) + simple_wrong_type_argument(sc, sc->port_line_number_symbol, p, + T_INPUT_PORT); + return (port_line_number(p)); +} + +static s7_pointer g_set_port_line_number(s7_scheme * sc, s7_pointer args) +{ + s7_pointer p, line; + if ((is_null(car(args))) || + ((is_null(cdr(args))) && (is_t_integer(car(args))))) + p = current_input_port(sc); + else { + p = car(args); + if (!(is_input_port(p))) + return (s7_wrong_type_arg_error + (sc, "set! port-line-number", 1, p, "an input port")); + } + line = (is_null(cdr(args)) ? car(args) : cadr(args)); + if (!is_t_integer(line)) + return (s7_wrong_type_arg_error + (sc, "set! port-line-number", 2, line, "an integer")); + port_line_number(p) = integer(line); + return (line); +} + + +/* -------------------------------- port-filename -------------------------------- */ +const char *s7_port_filename(s7_scheme * sc, s7_pointer x) +{ + if (((is_input_port(x)) || + (is_output_port(x))) && (!port_is_closed(x))) + return (port_filename(x)); + return (NULL); +} + +static s7_pointer port_filename_p_p(s7_scheme * sc, s7_pointer x) +{ + if (((is_input_port(x)) || (is_output_port(x))) && + (!port_is_closed(x))) { + if (port_filename(x)) + return (make_string_with_length(sc, port_filename(x), port_filename_length(x))); /* not wrapper here! */ + return (nil_string); + /* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */ + } + return (method_or_bust_with_type_one_arg_p + (sc, x, sc->port_filename_symbol, an_open_port_string)); +} + +static s7_pointer g_port_filename(s7_scheme * sc, s7_pointer args) +{ +#define H_port_filename "(port-filename file-port) returns the filename associated with port" +#define Q_port_filename s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol)) + return (port_filename_p_p + (sc, (is_null(args)) ? current_input_port(sc) : car(args))); +} + + +/* -------------------------------- pair-line-number -------------------------------- */ +static s7_pointer pair_line_number_p_p(s7_scheme * sc, s7_pointer p) +{ + if (!is_pair(p)) + return (method_or_bust_one_arg_p + (sc, p, sc->pair_line_number_symbol, T_PAIR)); + return ((has_location(p)) ? make_integer(sc, pair_line_number(p)) : + sc->F); +} + +static s7_pointer g_pair_line_number(s7_scheme * sc, s7_pointer args) +{ +#define H_pair_line_number "(pair-line-number pair) returns the line number at which it read 'pair', or #f if no such number is available" +#define Q_pair_line_number s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), sc->is_pair_symbol) + return (pair_line_number_p_p(sc, car(args))); +} + + +/* -------------------------------- pair-filename -------------------------------- */ +static s7_pointer g_pair_filename(s7_scheme * sc, s7_pointer args) +{ +#define H_pair_filename "(pair-filename pair) returns the name of the file containing 'pair'" +#define Q_pair_filename s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), sc->is_pair_symbol) + + s7_pointer p = car(args); + if (is_pair(p)) + return ((has_location(p)) ? sc->file_names[pair_file_number(p)] : sc->F); /* maybe also pair_file_number(p) > 0 */ + check_method(sc, p, sc->pair_filename_symbol, args); + return (simple_wrong_type_argument + (sc, sc->pair_filename_symbol, p, T_PAIR)); +} + + +/* -------------------------------- input-port? -------------------------------- */ +bool s7_is_input_port(s7_scheme * sc, s7_pointer p) +{ + return (is_input_port(p)); +} + +static bool is_input_port_b(s7_pointer p) +{ + return (is_input_port(p)); +} + +static s7_pointer g_is_input_port(s7_scheme * sc, s7_pointer args) +{ +#define H_is_input_port "(input-port? p) returns #t if p is an input port" +#define Q_is_input_port sc->pl_bt + check_boolean_method(sc, is_input_port, sc->is_input_port_symbol, + args); +} + + +/* -------------------------------- output-port? -------------------------------- */ +bool s7_is_output_port(s7_scheme * sc, s7_pointer p) +{ + return (is_output_port(p)); +} + +static bool is_output_port_b(s7_pointer p) +{ + return (is_output_port(p)); +} + +static s7_pointer g_is_output_port(s7_scheme * sc, s7_pointer args) +{ +#define H_is_output_port "(output-port? p) returns #t if p is an output port" +#define Q_is_output_port sc->pl_bt + check_boolean_method(sc, is_output_port, sc->is_output_port_symbol, + args); +} + + +/* -------------------------------- current-input-port -------------------------------- */ +s7_pointer s7_current_input_port(s7_scheme * sc) +{ + return (current_input_port(sc)); +} + +static s7_pointer g_current_input_port(s7_scheme * sc, s7_pointer args) +{ +#define H_current_input_port "(current-input-port) returns the current input port" +#define Q_current_input_port s7_make_signature(sc, 1, sc->is_input_port_symbol) + return (current_input_port(sc)); +} + +static s7_pointer g_set_current_input_port(s7_scheme * sc, s7_pointer args) +{ +#define H_set_current_input_port "(set-current-input-port port) sets the current-input port to port and returns the previous value of the input port" +#define Q_set_current_input_port s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_input_port_symbol) + + s7_pointer port = car(args), old_port = current_input_port(sc); + if ((is_input_port(port)) && (!port_is_closed(port))) + set_current_input_port(sc, port); + else { + check_method(sc, port, sc->set_current_input_port_symbol, args); + return (s7_wrong_type_arg_error + (sc, "set-current-input-port", 0, port, + "an open input port")); + } + return (old_port); +} + +s7_pointer s7_set_current_input_port(s7_scheme * sc, s7_pointer port) +{ + s7_pointer old_port = current_input_port(sc); + set_current_input_port(sc, port); + return (old_port); +} + + +/* -------------------------------- current-output-port -------------------------------- */ +s7_pointer s7_current_output_port(s7_scheme * sc) +{ + return (current_output_port(sc)); +} + +s7_pointer s7_set_current_output_port(s7_scheme * sc, s7_pointer port) +{ + s7_pointer old_port = current_output_port(sc); + set_current_output_port(sc, port); + return (old_port); +} + +static s7_pointer g_current_output_port(s7_scheme * sc, s7_pointer args) +{ +#define H_current_output_port "(current-output-port) returns the current output port" +#define Q_current_output_port s7_make_signature(sc, 1, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) + return (current_output_port(sc)); +} + +static s7_pointer g_set_current_output_port(s7_scheme * sc, + s7_pointer args) +{ +#define H_set_current_output_port "(set-current-output-port port) sets the current-output port to port and returns the previous value of the output port" +#define Q_set_current_output_port s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) + + s7_pointer port = car(args), old_port = current_output_port(sc); + if (((is_output_port(port)) && + (!port_is_closed(port))) || (port == sc->F)) + set_current_output_port(sc, port); + else { + check_method(sc, port, sc->set_current_output_port_symbol, args); + return (s7_wrong_type_arg_error + (sc, "set-current-output-port", 0, port, + "an open output port")); + } + return (old_port); +} + + +/* -------------------------------- current-error-port -------------------------------- */ +s7_pointer s7_current_error_port(s7_scheme * sc) +{ + return (sc->error_port); +} + +s7_pointer s7_set_current_error_port(s7_scheme * sc, s7_pointer port) +{ + s7_pointer old_port = sc->error_port; + sc->error_port = port; + return (old_port); +} + +static s7_pointer g_current_error_port(s7_scheme * sc, s7_pointer args) +{ +#define H_current_error_port "(current-error-port) returns the current error port" +#define Q_current_error_port s7_make_signature(sc, 1, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) + return (sc->error_port); +} + +static s7_pointer g_set_current_error_port(s7_scheme * sc, s7_pointer args) +{ +#define H_set_current_error_port "(set-current-error-port port) sets the current-error port to port and returns the previous value of the error port" +#define Q_set_current_error_port s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) + + s7_pointer port = car(args), old_port = sc->error_port; + if (((is_output_port(port)) && + (!port_is_closed(port))) || (port == sc->F)) + sc->error_port = port; + else { + check_method(sc, port, sc->set_current_error_port_symbol, args); + return (s7_wrong_type_arg_error + (sc, "set-current-error-port", 0, port, + "an open output port")); + } + return (old_port); +} + + +/* -------------------------------- char-ready? -------------------------------- */ +#if (!WITH_PURE_S7) +static s7_pointer g_is_char_ready(s7_scheme * sc, s7_pointer args) +{ +#define H_is_char_ready "(char-ready? (port (current-input-port))) returns #t if a character is ready for input on the given port" +#define Q_is_char_ready s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_input_port_symbol) + s7_pointer pt, res; + + if (is_null(args)) + return (make_boolean(sc, (is_input_port(current_input_port(sc))) + && (is_string_port(current_input_port(sc))))); + + pt = car(args); + if (!is_input_port(pt)) + return (method_or_bust_with_type_one_arg + (sc, pt, sc->is_char_ready_symbol, args, + an_input_port_string)); + if (port_is_closed(pt)) + return (simple_wrong_type_argument_with_type + (sc, sc->is_char_ready_symbol, pt, an_open_port_string)); + if (!is_function_port(pt)) + return (make_boolean(sc, is_string_port(pt))); + + res = (*(port_input_function(pt))) (sc, S7_IS_CHAR_READY, pt); + if (is_multiple_value(res)) { /* can only happen if more than one value in res */ + clear_multiple_value(res); + s7_error(sc, sc->bad_result_symbol, + set_elist_2(sc, + wrap_string(sc, + "input-function-port char-ready? returned: ~S", + 44), res)); + } + return (make_boolean(sc, (res != sc->F))); /* char-ready? returns a boolean */ +} +#endif + +/* -------- ports -------- */ +static int32_t closed_port_read_char(s7_scheme * sc, s7_pointer port); +static s7_pointer closed_port_read_line(s7_scheme * sc, s7_pointer port, + bool with_eol); +static void closed_port_write_char(s7_scheme * sc, uint8_t c, + s7_pointer port); +static void closed_port_write_string(s7_scheme * sc, const char *str, + s7_int len, s7_pointer port); +static void closed_port_display(s7_scheme * sc, const char *s, + s7_pointer port); + +static void close_closed_port(s7_scheme * sc, s7_pointer port) +{ + return; +} + +static port_functions_t closed_port_functions = + { closed_port_read_char, closed_port_write_char, + closed_port_write_string, NULL, NULL, NULL, NULL, + closed_port_read_line, closed_port_display, close_closed_port +}; + + +static void close_input_file(s7_scheme * sc, s7_pointer p) +{ + if (port_filename(p)) { + /* for string ports, this is the original input file name */ + liberate(sc, port_filename_block(p)); + port_filename(p) = NULL; + } + if (port_file(p)) { + fclose(port_file(p)); + port_file(p) = NULL; + } + if (port_needs_free(p)) + free_port_data(sc, p); + + port_port(p)->pf = &closed_port_functions; + port_set_closed(p, true); + port_position(p) = 0; +} + +static void close_input_string(s7_scheme * sc, s7_pointer p) +{ + if (port_filename(p)) { + /* for string ports, this is the original input file name */ + liberate(sc, port_filename_block(p)); + port_filename(p) = NULL; + } + if (port_needs_free(p)) + free_port_data(sc, p); + + port_port(p)->pf = &closed_port_functions; + port_set_closed(p, true); + port_position(p) = 0; +} + +static void close_simple_input_string(s7_scheme * sc, s7_pointer p) +{ +#if S7_DEBUGGING + if (port_filename(p)) + fprintf(stderr, "%s: port has a filename\n", __func__); + if (port_needs_free(p)) + fprintf(stderr, "%s: port needs free\n", __func__); +#endif + port_port(p)->pf = &closed_port_functions; + port_set_closed(p, true); + port_position(p) = 0; +} + +void s7_close_input_port(s7_scheme * sc, s7_pointer p) +{ + port_close(p) (sc, p); +} + + +/* -------------------------------- close-input-port -------------------------------- */ +static s7_pointer g_close_input_port(s7_scheme * sc, s7_pointer args) +{ +#define H_close_input_port "(close-input-port port) closes the port" +#define Q_close_input_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, sc->is_input_port_symbol) + + s7_pointer pt = car(args); + if (!is_input_port(pt)) + return (method_or_bust_with_type_one_arg_p + (sc, pt, sc->close_input_port_symbol, + an_input_port_string)); + if ((!is_immutable_port(pt)) && /* (close-input-port *stdin*) */ + (!is_loader_port(pt))) /* top-level unmatched (close-input-port (current-input-port)) should not clobber the loader's input port */ + s7_close_input_port(sc, pt); + return (sc->unspecified); +} + + +/* -------------------------------- flush-output-port -------------------------------- */ +bool s7_flush_output_port(s7_scheme * sc, s7_pointer p) +{ + bool result = true; + if ((is_output_port(p)) && /* type=T_OUTPUT_PORT, so this excludes #f */ + (is_file_port(p)) && (!port_is_closed(p)) && (port_file(p))) { + if (port_position(p) > 0) { + result = + (fwrite + ((void *) (port_data(p)), 1, port_position(p), + port_file(p)) == (size_t) port_position(p)); + port_position(p) = 0; + } + fflush(port_file(p)); + } + return (result); +} + +static s7_pointer g_flush_output_port(s7_scheme * sc, s7_pointer args) +{ +#define H_flush_output_port "(flush-output-port port) flushes the file port (that is, it writes any accumulated output to the output file)" +#define Q_flush_output_port s7_make_signature(sc, 2, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) + + s7_pointer pt; + pt = (is_null(args)) ? current_output_port(sc) : car(args); + if (!is_output_port(pt)) { + if (pt == sc->F) + return (pt); + return (method_or_bust_with_type_one_arg + (sc, pt, sc->flush_output_port_symbol, args, + an_output_port_string)); + } + s7_flush_output_port(sc, pt); + return (pt); +} + + +/* -------------------------------- close-output-port -------------------------------- */ +static void close_output_file(s7_scheme * sc, s7_pointer p) +{ + if (port_filename(p)) { /* only a file output port has a filename(?) */ + liberate(sc, port_filename_block(p)); + port_filename(p) = NULL; + port_filename_length(p) = 0; + } + if (port_file(p)) { +#if (WITH_WARNINGS) + if ((port_position(p) > 0) && + (fwrite + ((void *) (port_data(p)), 1, port_position(p), + port_file(p)) != (size_t) port_position(p))) + s7_warn(sc, 64, "fwrite trouble in close-output-port\n"); +#else + if (port_position(p) > 0) + fwrite((void *) (port_data(p)), 1, port_position(p), + port_file(p)); +#endif + fflush(port_file(p)); + fclose(port_file(p)); + port_file(p) = NULL; + } + port_port(p)->pf = &closed_port_functions; + port_set_closed(p, true); + port_position(p) = 0; +} + +static void close_output_string(s7_scheme * sc, s7_pointer p) +{ + if (port_data(p)) { + port_data(p) = NULL; + port_data_size(p) = 0; + } + port_port(p)->pf = &closed_port_functions; + port_set_closed(p, true); + port_position(p) = 0; +} + +static void close_output_port(s7_scheme * sc, s7_pointer p) +{ + port_close(p) (sc, p); +} + +void s7_close_output_port(s7_scheme * sc, s7_pointer p) +{ + if ((p == sc->F) || (is_immutable_port(p))) + return; /* can these happen? */ + close_output_port(sc, p); +} + +static s7_pointer g_close_output_port(s7_scheme * sc, s7_pointer args) +{ +#define H_close_output_port "(close-output-port port) closes the port" +#define Q_close_output_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) + + s7_pointer pt = car(args); + if (!is_output_port(pt)) { + if (pt == sc->F) + return (sc->unspecified); + return (method_or_bust_with_type_one_arg_p + (sc, pt, sc->close_output_port_symbol, + an_output_port_string)); + } + s7_close_output_port(sc, pt); + return (sc->unspecified); +} + + +/* -------- read character functions -------- */ + +static int32_t file_read_char(s7_scheme * sc, s7_pointer port) +{ + return (fgetc(port_file(port))); +} + +static int32_t function_read_char(s7_scheme * sc, s7_pointer port) +{ + s7_pointer res; + res = (*(port_input_function(port))) (sc, S7_READ_CHAR, port); + if (is_eof(res)) + return (EOF); + if (!is_character(res)) { /* port_input_function might return some non-character */ + if (is_multiple_value(res)) { + clear_multiple_value(res); + s7_error(sc, sc->bad_result_symbol, + set_elist_2(sc, + wrap_string(sc, + "input-function-port read-char returned: ~S", + 42), res)); + } + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "input_function_port read_char returned: ~S", + 42), res)); + } + return ((int32_t) character(res)); /* kinda nutty -- we return chars[this] in g_read_char! */ +} + +static int32_t string_read_char(s7_scheme * sc, s7_pointer port) +{ + return ((port_data_size(port) <= port_position(port)) ? EOF : (uint8_t) port_data(port)[port_position(port)++]); /* port_string_length is 0 if no port string */ +} + +static int32_t output_read_char(s7_scheme * sc, s7_pointer port) +{ + simple_wrong_type_argument_with_type(sc, sc->read_char_symbol, port, + an_input_port_string); + return (0); +} + +static int32_t closed_port_read_char(s7_scheme * sc, s7_pointer port) +{ + simple_wrong_type_argument_with_type(sc, sc->read_char_symbol, port, + an_open_port_string); + return (0); +} + + +/* -------- read line functions -------- */ + +static s7_pointer output_read_line(s7_scheme * sc, s7_pointer port, + bool with_eol) +{ + return (simple_wrong_type_argument_with_type + (sc, sc->read_line_symbol, port, an_input_port_string)); +} + +static s7_pointer closed_port_read_line(s7_scheme * sc, s7_pointer port, + bool with_eol) +{ + return (simple_wrong_type_argument_with_type + (sc, sc->read_line_symbol, port, an_open_port_string)); +} + +static s7_pointer function_read_line(s7_scheme * sc, s7_pointer port, + bool with_eol) +{ + s7_pointer res; + res = (*(port_input_function(port))) (sc, S7_READ_LINE, port); + if (is_multiple_value(res)) { + clear_multiple_value(res); + s7_error(sc, sc->bad_result_symbol, + set_elist_2(sc, + wrap_string(sc, + "input-function-port read-line returned: ~S", + 42), res)); + } + return (res); +} + +static s7_pointer stdin_read_line(s7_scheme * sc, s7_pointer port, + bool with_eol) +{ + if (!sc->read_line_buf) { + sc->read_line_buf_size = 1024; + sc->read_line_buf = (char *) Malloc(sc->read_line_buf_size); + } + if (fgets(sc->read_line_buf, sc->read_line_buf_size, stdin)) + return (s7_make_string(sc, sc->read_line_buf)); /* fgets adds the trailing '\0' */ + return (nil_string); /* make_string_with_length(sc, NULL, 0)); */ +} + +static s7_pointer file_read_line(s7_scheme * sc, s7_pointer port, + bool with_eol) +{ + /* read into read_line_buf concatenating reads until newline found. string is read_line_buf to pos-of-newline. + * reset file position to reflect newline pos. + */ + int32_t reads = 0; + char *str; + s7_int read_size; + if (!sc->read_line_buf) { + sc->read_line_buf_size = 1024; + sc->read_line_buf = (char *) Malloc(sc->read_line_buf_size); + } + read_size = sc->read_line_buf_size; + str = fgets(sc->read_line_buf, read_size, port_file(port)); /* reads size-1 at most, EOF and newline also terminate read */ + if (!str) + return (eof_object); /* EOF or error with no char read */ + + while (true) { + s7_int cur_size; + char *buf, *snew; + + snew = strchr(sc->read_line_buf, (int) '\n'); /* or maybe just strlen + end-of-string=newline */ + if (snew) { + s7_int pos = (s7_int) (snew - sc->read_line_buf); + port_line_number(port)++; + return (make_string_with_length + (sc, sc->read_line_buf, (with_eol) ? (pos + 1) : pos)); + } + reads++; + cur_size = strlen(sc->read_line_buf); + if ((cur_size + reads) < read_size) /* end of data, no newline */ + return (make_string_with_length + (sc, sc->read_line_buf, cur_size)); + + /* need more data */ + sc->read_line_buf_size *= 2; + sc->read_line_buf = + (char *) Realloc(sc->read_line_buf, sc->read_line_buf_size); + buf = (char *) (sc->read_line_buf + cur_size); + str = fgets(buf, read_size, port_file(port)); + if (!str) + return (eof_object); + read_size = sc->read_line_buf_size; + } + return (eof_object); +} + +static s7_pointer string_read_line(s7_scheme * sc, s7_pointer port, + bool with_eol) +{ + s7_int i, port_start = port_position(port); + uint8_t *cur, *start, *port_str = port_data(port); + + start = (uint8_t *) (port_str + port_start); + cur = (uint8_t *) strchr((const char *) start, (int) '\n'); /* this can run off the end making valgrind unhappy, but I think it's innocuous */ + if (cur) { + port_line_number(port)++; + i = cur - port_str; + port_position(port) = i + 1; + return (make_string_with_length + (sc, (const char *) start, + ((with_eol) ? i + 1 : i) - port_start)); + } + i = port_data_size(port); + port_position(port) = i; + if (i <= port_start) /* the < part can happen -- if not caught we try to create a string of length - 1 -> segfault */ + return (eof_object); + return (inline_make_string_with_length + (sc, (const char *) start, i - port_start)); +} + + +/* -------- write character functions -------- */ + +static void resize_port_data(s7_scheme * sc, s7_pointer pt, + s7_int new_size) +{ + s7_int loc = port_data_size(pt); + block_t *nb; + + if (new_size < loc) + return; + if (new_size > sc->max_port_data_size) + s7_error(sc, make_symbol(sc, "port-too-big"), + set_elist_1(sc, + wrap_string(sc, + "port data size has grown past (*s7* 'max-port-data-size)", + 56))); + + nb = reallocate(sc, port_data_block(pt), new_size); + port_data_block(pt) = nb; + port_data(pt) = (uint8_t *) (block_data(nb)); + port_data_size(pt) = new_size; +} + +static void string_write_char_resized(s7_scheme * sc, uint8_t c, + s7_pointer pt) +{ + /* this division looks repetitive, but it is much faster */ + resize_port_data(sc, pt, port_data_size(pt) * 2); + port_data(pt)[port_position(pt)++] = c; +} + +static void string_write_char(s7_scheme * sc, uint8_t c, s7_pointer pt) +{ + if (port_position(pt) < port_data_size(pt)) + port_data(pt)[port_position(pt)++] = c; + else + string_write_char_resized(sc, c, pt); +} + +static void stdout_write_char(s7_scheme * sc, uint8_t c, s7_pointer port) +{ + fputc(c, stdout); +} + +static void stderr_write_char(s7_scheme * sc, uint8_t c, s7_pointer port) +{ + fputc(c, stderr); +} + +static void function_write_char(s7_scheme * sc, uint8_t c, s7_pointer port) +{ + push_stack_no_let_no_code(sc, OP_NO_VALUES, sc->nil); + (*(port_output_function(port))) (sc, c, port); + unstack_with(sc, OP_NO_VALUES); +} + +static Inline void inline_file_write_char(s7_scheme * sc, uint8_t c, + s7_pointer port) +{ + if (port_position(port) == sc->output_port_data_size) { + fwrite((void *) (port_data(port)), 1, sc->output_port_data_size, + port_file(port)); + port_position(port) = 0; + } + port_data(port)[port_position(port)++] = c; +} + +static void file_write_char(s7_scheme * sc, uint8_t c, s7_pointer port) +{ + return (inline_file_write_char(sc, c, port)); +} + +static void input_write_char(s7_scheme * sc, uint8_t c, s7_pointer port) +{ + simple_wrong_type_argument_with_type(sc, sc->write_char_symbol, port, + an_output_port_string); +} + +static void closed_port_write_char(s7_scheme * sc, uint8_t c, + s7_pointer port) +{ + simple_wrong_type_argument_with_type(sc, sc->write_char_symbol, port, + an_open_port_string); +} + + +/* -------- write string functions -------- */ + +static void input_write_string(s7_scheme * sc, const char *str, s7_int len, + s7_pointer port) +{ + simple_wrong_type_argument_with_type(sc, sc->write_symbol, port, + an_output_port_string); +} + +static void closed_port_write_string(s7_scheme * sc, const char *str, + s7_int len, s7_pointer port) +{ + simple_wrong_type_argument_with_type(sc, sc->write_symbol, port, + an_open_port_string); +} + +static void input_display(s7_scheme * sc, const char *s, s7_pointer port) +{ + simple_wrong_type_argument_with_type(sc, sc->display_symbol, port, + an_output_port_string); +} + +static void closed_port_display(s7_scheme * sc, const char *s, + s7_pointer port) +{ + simple_wrong_type_argument_with_type(sc, sc->display_symbol, port, + an_open_port_string); +} + +static void stdout_write_string(s7_scheme * sc, const char *str, + s7_int len, s7_pointer port) +{ + if (str[len] == '\0') + fputs(str, stdout); + else { + s7_int i; + for (i = 0; i < len; i++) + fputc(str[i], stdout); + } +} + +static void stderr_write_string(s7_scheme * sc, const char *str, + s7_int len, s7_pointer port) +{ + if (str[len] == '\0') + fputs(str, stderr); + else { + s7_int i; + for (i = 0; i < len; i++) + fputc(str[i], stderr); + } +} + +static void string_write_string_resized(s7_scheme * sc, const char *str, + s7_int len, s7_pointer pt) +{ + s7_int new_len = port_position(pt) + len; /* len is known to be non-zero, str might not be 0-terminated */ + resize_port_data(sc, pt, new_len * 2); + memcpy((void *) (port_data(pt) + port_position(pt)), (void *) str, + len); + port_position(pt) = new_len; +} + +static void string_write_string(s7_scheme * sc, const char *str, + s7_int len, s7_pointer pt) +{ + if ((S7_DEBUGGING) && (len == 0)) { + fprintf(stderr, "string_write_string len == 0\n"); + abort(); + } + if (port_position(pt) + len < port_data_size(pt)) { + memcpy((void *) (port_data(pt) + port_position(pt)), (void *) str, + len); + /* memcpy is much faster than the equivalent while loop, and faster than using the 4-bytes-at-a-time shuffle */ + port_position(pt) += len; + } else + string_write_string_resized(sc, str, len, pt); +} + +static void file_write_string(s7_scheme * sc, const char *str, s7_int len, + s7_pointer pt) +{ + s7_int new_len = port_position(pt) + len; + if (new_len >= sc->output_port_data_size) { + if (port_position(pt) > 0) { +#if (WITH_WARNINGS) + if (fwrite + ((void *) (port_data(pt)), 1, port_position(pt), + port_file(pt)) != (size_t) port_position(pt)) + s7_warn(sc, 64, "fwrite trouble in write-string\n"); +#else + fwrite((void *) (port_data(pt)), 1, port_position(pt), + port_file(pt)); +#endif + port_position(pt) = 0; + } + fwrite((void *) str, 1, len, port_file(pt)); + } else { + memcpy((void *) (port_data(pt) + port_position(pt)), (void *) str, + len); + port_position(pt) = new_len; + } +} + +static void string_display(s7_scheme * sc, const char *s, s7_pointer port) +{ + if (s) + string_write_string(sc, s, safe_strlen(s), port); +} + +static void file_display(s7_scheme * sc, const char *s, s7_pointer port) +{ + if (s) { + if (port_position(port) > 0) { +#if (WITH_WARNINGS) + if (fwrite + ((void *) (port_data(port)), 1, port_position(port), + port_file(port)) != (size_t) port_position(port)) + s7_warn(sc, 64, "fwrite trouble in display\n"); +#else + fwrite((void *) (port_data(port)), 1, port_position(port), + port_file(port)); +#endif + port_position(port) = 0; + } +#if (WITH_WARNINGS) + if (fputs(s, port_file(port)) == EOF) + s7_warn(sc, 64, "write to %s: %s\n", port_filename(port), + strerror(errno)); +#else + fputs(s, port_file(port)); +#endif + } +} + +static void function_display(s7_scheme * sc, const char *s, + s7_pointer port) +{ + if (s) + for (; *s; s++) + (*(port_output_function(port))) (sc, *s, port); +} + +static void function_write_string(s7_scheme * sc, const char *str, + s7_int len, s7_pointer pt) +{ + s7_int i; + for (i = 0; i < len; i++) + (*(port_output_function(pt))) (sc, str[i], pt); +} + +static void stdout_display(s7_scheme * sc, const char *s, s7_pointer port) +{ + if (s) + fputs(s, stdout); +} + +static void stderr_display(s7_scheme * sc, const char *s, s7_pointer port) +{ + if (s) + fputs(s, stderr); +} + + +/* -------------------------------- write-string -------------------------------- */ +static s7_pointer g_write_string(s7_scheme * sc, s7_pointer args) +{ +#define H_write_string "(write-string str port start end) writes str to port." +#define Q_write_string s7_make_circular_signature(sc, 3, 4, sc->is_string_symbol, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), sc->is_integer_symbol) + + s7_pointer str = car(args), port; + s7_int start = 0, end; + if (!is_string(str)) + return (method_or_bust + (sc, str, sc->write_string_symbol, args, T_STRING, 1)); + + end = string_length(str); + if (!is_null(cdr(args))) { + s7_pointer inds; + port = cadr(args); + inds = cddr(args); + if (!is_null(inds)) { + s7_pointer p; + p = start_and_end(sc, sc->write_string_symbol, args, 3, inds, + &start, &end); + if (p != sc->unused) + return (p); + } + } else + port = current_output_port(sc); + if (!is_output_port(port)) { + if (port == sc->F) { + s7_int len; + if ((start == 0) && (end == string_length(str))) + return (str); + len = (s7_int) (end - start); + return (make_string_with_length + (sc, (char *) (string_value(str) + start), len)); + } + return (method_or_bust_with_type + (sc, port, sc->write_string_symbol, args, + an_output_port_string, 2)); + } + if (start == end) + return (str); + port_write_string(port) (sc, (char *) (string_value(str) + start), + (end - start), port); + return (str); +} + +static s7_pointer write_string_p_pp(s7_scheme * sc, s7_pointer str, + s7_pointer port) +{ + if (!is_string(str)) + return (method_or_bust_pp + (sc, str, sc->write_string_symbol, str, port, T_STRING, + 1)); + if (!is_output_port(port)) { + if (port == sc->F) + return (str); + return (method_or_bust_with_type_pp + (sc, port, sc->write_string_symbol, str, port, + an_output_port_string, 2)); + } + if (string_length(str) > 0) + port_write_string(port) (sc, string_value(str), string_length(str), + port); + return (str); +} + + +/* -------- skip to newline readers -------- */ +static token_t token(s7_scheme * sc); + +static token_t file_read_semicolon(s7_scheme * sc, s7_pointer pt) +{ + int32_t c; + do + (c = fgetc(port_file(pt))); + while ((c != '\n') && (c != EOF)); + port_line_number(pt)++; + return ((c == EOF) ? TOKEN_EOF : token(sc)); +} + +static token_t string_read_semicolon(s7_scheme * sc, s7_pointer pt) +{ + const char *orig_str, *str; + str = (const char *) (port_data(pt) + port_position(pt)); + orig_str = strchr(str, (int) '\n'); + if (!orig_str) { + port_position(pt) = port_data_size(pt); + return (TOKEN_EOF); + } + port_position(pt) += (orig_str - str + 1); /* + 1 because strchr leaves orig_str pointing at the newline */ + port_line_number(pt)++; + return (token(sc)); +} + + +/* -------- white space readers -------- */ + +static int32_t file_read_white_space(s7_scheme * sc, s7_pointer port) +{ + int32_t c; + while (is_white_space(c = fgetc(port_file(port)))) + if (c == '\n') + port_line_number(port)++; + return (c); +} + +static int32_t terminated_string_read_white_space(s7_scheme * sc, + s7_pointer pt) +{ + const uint8_t *str; + uint8_t c; + /* here we know we have null termination and white_space[#\null] is false. */ + str = (const uint8_t *) (port_data(pt) + port_position(pt)); + while (white_space[c = *str++]) /* 255 is not -1 = EOF */ + if (c == '\n') + port_line_number(pt)++; + port_position(pt) = (c) ? str - port_data(pt) : port_data_size(pt); + return ((int32_t) c); +} + + +/* -------- name readers -------- */ +#define BASE_10 10 + +static s7_pointer file_read_name_or_sharp(s7_scheme * sc, s7_pointer pt, + bool atom_case) +{ + int32_t c; + s7_int i = 1; + /* sc->strbuf[0] has the first char of the string we're reading */ + + do { + c = fgetc(port_file(pt)); /* might return EOF */ + if (c == '\n') + port_line_number(pt)++; + + sc->strbuf[i++] = (unsigned char) c; + if (i >= sc->strbuf_size) + resize_strbuf(sc, i); + } while ((c != EOF) && (char_ok_in_a_name[c])); + + if ((i == 2) && (sc->strbuf[0] == '\\')) + sc->strbuf[2] = '\0'; + else { + if (c != EOF) { + if (c == '\n') + port_line_number(pt)--; + ungetc(c, port_file(pt)); + } + sc->strbuf[i - 1] = '\0'; + } + + if (atom_case) + return (make_atom + (sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR)); + return (make_sharp_constant + (sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true)); +} + +static s7_pointer file_read_name(s7_scheme * sc, s7_pointer pt) +{ + return (file_read_name_or_sharp(sc, pt, true)); +} + +static s7_pointer file_read_sharp(s7_scheme * sc, s7_pointer pt) +{ + return (file_read_name_or_sharp(sc, pt, false)); +} + +static s7_pointer string_read_name_no_free(s7_scheme * sc, s7_pointer pt) +{ + /* sc->strbuf[0] has the first char of the string we're reading */ + s7_pointer result; + char *str; + str = (char *) (port_data(pt) + port_position(pt)); + + if (char_ok_in_a_name[(uint8_t) * str]) { + s7_int k; + char *orig_str = (char *) (str - 1); + str++; + while (char_ok_in_a_name[(uint8_t) (*str)]) { + str++; + } + k = str - orig_str; + if (*str != 0) + port_position(pt) += (k - 1); + else + port_position(pt) = port_data_size(pt); + /* this is equivalent to: + * str = strpbrk(str, "(); \"\t\r\n"); + * if (!str) + * { + * k = strlen(orig_str); + * str = (char *)(orig_str + k); + * } + * else k = str - orig_str; + * but slightly faster. + */ + if (!number_table[(uint8_t) (*orig_str)]) + return (make_symbol_with_length(sc, orig_str, k)); + + /* eval_c_string string is a constant so we can't set and unset the token's end char */ + if ((k + 1) >= sc->strbuf_size) + resize_strbuf(sc, k + 1); + + memcpy((void *) (sc->strbuf), (void *) orig_str, k); + sc->strbuf[k] = '\0'; + return (make_atom + (sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR)); + } + + result = sc->singletons[(uint8_t) (sc->strbuf[0])]; + if (!result) { + sc->strbuf[1] = '\0'; + result = make_symbol_with_length(sc, sc->strbuf, 1); + sc->singletons[(uint8_t) (sc->strbuf[0])] = result; + } + return (result); +} + +static s7_pointer string_read_sharp(s7_scheme * sc, s7_pointer pt) +{ + /* sc->strbuf[0] has the first char of the string we're reading. + * since a *#readers* function might want to get further input, we can't mess with the input even when it is otherwise safe + */ + char *str; + str = (char *) (port_data(pt) + port_position(pt)); + if (char_ok_in_a_name[(uint8_t) * str]) { + s7_int k; + char *orig_str = (char *) (str - 1); + str++; + while (char_ok_in_a_name[(uint8_t) (*str)]) { + str++; + } + k = str - orig_str; + if (*str != 0) + port_position(pt) += (k - 1); + else + port_position(pt) += k; + if ((k + 1) >= sc->strbuf_size) + resize_strbuf(sc, k + 1); + memcpy((void *) (sc->strbuf), (void *) orig_str, k); + sc->strbuf[k] = '\0'; + return (make_sharp_constant + (sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true)); + } + if (sc->strbuf[0] == 'f') + return (sc->F); + if (sc->strbuf[0] == 't') + return (sc->T); + if (sc->strbuf[0] == '\\') { + /* must be from #\( and friends -- a character that happens to be not ok-in-a-name */ + sc->strbuf[1] = str[0]; + sc->strbuf[2] = '\0'; + port_position(pt)++; + } else + sc->strbuf[1] = '\0'; + return (make_sharp_constant + (sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true)); +} + +static s7_pointer string_read_name(s7_scheme * sc, s7_pointer pt) +{ + /* port_string was allocated (and read from a file) so we can mess with it directly */ + s7_pointer result; + char *str; + + str = (char *) (port_data(pt) + port_position(pt)); + if (char_ok_in_a_name[(uint8_t) * str]) { + s7_int k; + char endc; + char *orig_str = (char *) (str - 1); + str++; + while (char_ok_in_a_name[(uint8_t) (*str)]) { + str++; + } + k = str - orig_str; + if (*str != 0) + port_position(pt) += (k - 1); + else + port_position(pt) = port_data_size(pt); + + if (!number_table[(uint8_t) (*orig_str)]) + return (make_symbol_with_length(sc, orig_str, k)); + + endc = (*str); + (*str) = '\0'; + result = + make_atom(sc, orig_str, BASE_10, SYMBOL_OK, + WITH_OVERFLOW_ERROR); + (*str) = endc; + return (result); + } + result = sc->singletons[(uint8_t) (sc->strbuf[0])]; + if (!result) { + sc->strbuf[1] = '\0'; + result = make_symbol_with_length(sc, sc->strbuf, 1); + sc->singletons[(uint8_t) (sc->strbuf[0])] = result; + } + return (result); +} + +static inline void port_set_filename(s7_scheme * sc, s7_pointer p, + const char *name, size_t len) +{ + block_t *b; + b = mallocate(sc, len + 1); + port_filename_block(p) = b; + port_filename(p) = (char *) block_data(b); + memcpy((void *) block_data(b), (void *) name, len); + port_filename(p)[len] = '\0'; +} + +static block_t *mallocate_port(s7_scheme * sc) +{ +#define PORT_LIST 8 /* sizeof(port_t): 160 */ + block_t *p; + p = sc->block_lists[PORT_LIST]; + if (p) + sc->block_lists[PORT_LIST] = (block_t *) block_next(p); + else { /* this is mallocate without the index calc */ + p = mallocate_block(sc); + block_data(p) = (void *) permalloc(sc, (size_t) (1 << PORT_LIST)); + block_set_index(p, PORT_LIST); + } + block_set_size(p, sizeof(port_t)); + return (p); +} + +static port_functions_t input_file_functions = + { file_read_char, input_write_char, input_write_string, + file_read_semicolon, file_read_white_space, + file_read_name, file_read_sharp, file_read_line, input_display, + close_input_file +}; + +static port_functions_t input_string_functions_1 = + { string_read_char, input_write_char, input_write_string, + string_read_semicolon, terminated_string_read_white_space, + string_read_name, string_read_sharp, string_read_line, input_display, + close_input_string +}; + +static s7_pointer read_file(s7_scheme * sc, FILE * fp, const char *name, + s7_int max_size, const char *caller) +{ + s7_pointer port; +#if (!MS_WINDOWS) + s7_int size; +#endif + s7_int port_loc; + block_t *b; + + new_cell(sc, port, T_INPUT_PORT); + port_loc = gc_protect_1(sc, port); + b = mallocate_port(sc); + port_block(port) = b; + port_port(port) = (port_t *) block_data(b); + port_set_closed(port, false); + port_original_input_string(port) = sc->nil; + /* if we're constantly opening files, and each open saves the file name in permanent memory, we gradually core-up. */ + port_filename_length(port) = safe_strlen(name); + port_set_filename(sc, port, name, port_filename_length(port)); + port_line_number(port) = 1; /* first line is numbered 1 */ + port_file_number(port) = 0; + add_input_port(sc, port); + +#if (!MS_WINDOWS) + /* this doesn't work in MS C */ + fseek(fp, 0, SEEK_END); + size = ftell(fp); + rewind(fp); + + /* pseudo files (under /proc for example) have size=0, but we can read them, so don't assume a 0 length file is empty */ + + if ((size > 0) && /* if (size != 0) we get (open-input-file "/dev/tty") -> (open "/dev/tty") read 0 bytes of an expected -1? */ + ((max_size < 0) || (size < max_size))) { /* load uses max_size = -1 */ + size_t bytes; + block_t *block; + uint8_t *content; + + block = mallocate(sc, size + 2); + content = (uint8_t *) (block_data(block)); + bytes = fread(content, sizeof(uint8_t), size, fp); + if (bytes != (size_t) size) { + if (current_output_port(sc) != sc->F) { + char tmp[256]; + int32_t len; + len = + snprintf(tmp, 256, + "(%s \"%s\") read %ld bytes of an expected %" + ld64 "?", caller, name, (long) bytes, size); + port_write_string(current_output_port(sc)) (sc, tmp, + clamp_length + (len, 256), + current_output_port + (sc)); + } + size = bytes; + } + content[size] = '\0'; + content[size + 1] = '\0'; + fclose(fp); + + port_file(port) = NULL; /* make valgrind happy */ + port_type(port) = STRING_PORT; + port_data(port) = content; + port_data_block(port) = block; + port_data_size(port) = size; + port_position(port) = 0; + port_needs_free(port) = true; + port_port(port)->pf = &input_string_functions_1; + } else { + port_file(port) = fp; + port_type(port) = FILE_PORT; + port_data(port) = NULL; + port_data_block(port) = NULL; + port_data_size(port) = 0; + port_position(port) = 0; + port_needs_free(port) = false; + port_port(port)->pf = &input_file_functions; + } +#else + /* _stat64 is no better than the fseek/ftell route, and + * GetFileSizeEx and friends requires Windows.h which makes hash of everything else. + * fread until done takes too long on big files, so use a file port + */ + port_file(port) = fp; + port_type(port) = FILE_PORT; + port_needs_free(port) = false; + port_data(port) = NULL; + port_data_block(port) = NULL; + port_data_size(port) = 0; + port_position(port) = 0; + port_port(port)->pf = &input_file_functions; +#endif + s7_gc_unprotect_at(sc, port_loc); + return (port); +} + + +/* -------------------------------- open-input-file -------------------------------- */ +static int32_t remember_file_name(s7_scheme * sc, const char *file) +{ + int32_t i; + + for (i = 0; i <= sc->file_names_top; i++) + if (safe_strcmp(file, string_value(sc->file_names[i]))) + return (i); + + sc->file_names_top++; + if (sc->file_names_top >= sc->file_names_size) { + int32_t old_size = 0; + /* what if file_names_size is greater than file_bits in pair|profile_file? */ + if (sc->file_names_size == 0) { + sc->file_names_size = INITIAL_FILE_NAMES_SIZE; + sc->file_names = + (s7_pointer *) Malloc(sc->file_names_size * + sizeof(s7_pointer)); + } else { + old_size = sc->file_names_size; + sc->file_names_size *= 2; + sc->file_names = + (s7_pointer *) Realloc(sc->file_names, + sc->file_names_size * + sizeof(s7_pointer)); + } + for (i = old_size; i < sc->file_names_size; i++) + sc->file_names[i] = sc->F; + } + sc->file_names[sc->file_names_top] = + s7_make_permanent_string(sc, file); + return (sc->file_names_top); +} + + +#ifndef MAX_SIZE_FOR_STRING_PORT +#define MAX_SIZE_FOR_STRING_PORT 10000000 +#endif + +static s7_pointer make_input_file(s7_scheme * sc, const char *name, + FILE * fp) +{ + return (read_file(sc, fp, name, MAX_SIZE_FOR_STRING_PORT, "open")); +} + + +#if (!MS_WINDOWS) +#include +#endif + +static bool is_directory(const char *filename) +{ +#if (!MS_WINDOWS) +#ifdef S_ISDIR + struct stat statbuf; + return ((stat(filename, &statbuf) >= 0) && (S_ISDIR(statbuf.st_mode))); +#endif +#endif + return (false); +} + +static s7_pointer file_error(s7_scheme * sc, const char *caller, + const char *descr, const char *name); + +static s7_pointer open_input_file_1(s7_scheme * sc, const char *name, + const char *mode, const char *caller) +{ + FILE *fp; + /* see if we can open this file before allocating a port */ + + if (is_directory(name)) + return (file_error(sc, caller, "file is a directory:", name)); + + errno = 0; + fp = fopen(name, mode); + if (fp) + return (make_input_file(sc, name, fp)); + +#if (!MS_WINDOWS) + if (errno == EINVAL) + return (file_error(sc, caller, "invalid mode", mode)); +#if WITH_GCC + if ((name[0] == '~') && /* catch one special case, "~/..." */ + (name[1] == '/')) { + char *home; + home = getenv("HOME"); + if (home) { + block_t *b; + char *filename; + s7_int len; + len = safe_strlen(name) + safe_strlen(home) + 1; + b = mallocate(sc, len); + filename = (char *) block_data(b); + filename[0] = '\0'; + catstrs(filename, len, home, (char *) (name + 1), + (char *) NULL); + fp = fopen(filename, "r"); + liberate(sc, b); + if (fp) + return (make_input_file(sc, name, fp)); + } + } +#endif +#endif + return (file_error(sc, caller, strerror(errno), name)); +} + +s7_pointer s7_open_input_file(s7_scheme * sc, const char *name, + const char *mode) +{ + return (open_input_file_1(sc, name, mode, "open-input-file")); +} + +static s7_pointer g_open_input_file(s7_scheme * sc, s7_pointer args) +{ +#define H_open_input_file "(open-input-file filename (mode \"r\")) opens filename for reading" +#define Q_open_input_file s7_make_signature(sc, 3, sc->is_input_port_symbol, sc->is_string_symbol, sc->is_string_symbol) + + s7_pointer mode, name = car(args); + /* open-input-file can create a new output file if the file to be opened does not exist, and the "a" mode is given */ + + if (!is_string(name)) + return (method_or_bust + (sc, name, sc->open_input_file_symbol, args, T_STRING, 1)); + + if (!is_pair(cdr(args))) + return (open_input_file_1 + (sc, string_value(name), "r", "open-input-file")); + + mode = cadr(args); + if (!is_string(mode)) + return (method_or_bust_with_type + (sc, mode, sc->open_input_file_symbol, args, + wrap_string(sc, "a string (a mode such as \"r\")", 29), + 2)); + /* since scheme allows embedded nulls, dumb stuff is accepted here: (open-input-file file "a\x00b") -- should this be an error? */ + return (open_input_file_1 + (sc, string_value(name), string_value(mode), + "open-input-file")); +} + +static void close_stdin(s7_scheme * sc, s7_pointer port) +{ + return; +} + +static void close_stdout(s7_scheme * sc, s7_pointer port) +{ + return; +} + +static void close_stderr(s7_scheme * sc, s7_pointer port) +{ + return; +} + +static const port_functions_t stdin_functions = + { file_read_char, input_write_char, input_write_string, + file_read_semicolon, file_read_white_space, + file_read_name, file_read_sharp, stdin_read_line, input_display, + close_stdin +}; + +static const port_functions_t stdout_functions = + { output_read_char, stdout_write_char, stdout_write_string, NULL, NULL, + NULL, NULL, output_read_line, stdout_display, close_stdout +}; + +static const port_functions_t stderr_functions = + { output_read_char, stderr_write_char, stderr_write_string, NULL, NULL, + NULL, NULL, output_read_line, stderr_display, close_stderr +}; + +static void init_standard_ports(s7_scheme * sc) +{ + s7_pointer x; + + /* standard output */ + x = alloc_pointer(sc); + set_full_type(x, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP); + port_port(x) = (port_t *) calloc(1, sizeof(port_t)); + port_type(x) = FILE_PORT; + port_data(x) = NULL; + port_data_block(x) = NULL; + port_set_closed(x, false); + port_filename_length(x) = 8; + port_set_filename(sc, x, "*stdout*", 8); + port_file_number(x) = remember_file_name(sc, port_filename(x)); /* these numbers need to be correct for the evaluator (*function* data) */ + port_line_number(x) = 0; + port_file(x) = stdout; + port_needs_free(x) = false; + port_port(x)->pf = &stdout_functions; + sc->standard_output = x; + + /* standard error */ + x = alloc_pointer(sc); + set_full_type(x, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP); + port_port(x) = (port_t *) calloc(1, sizeof(port_t)); + port_type(x) = FILE_PORT; + port_data(x) = NULL; + port_data_block(x) = NULL; + port_set_closed(x, false); + port_filename_length(x) = 8; + port_set_filename(sc, x, "*stderr*", 8); + port_file_number(x) = remember_file_name(sc, port_filename(x)); + port_line_number(x) = 0; + port_file(x) = stderr; + port_needs_free(x) = false; + port_port(x)->pf = &stderr_functions; + sc->standard_error = x; + + /* standard input */ + x = alloc_pointer(sc); + set_full_type(x, T_INPUT_PORT | T_IMMUTABLE | T_UNHEAP); + port_port(x) = (port_t *) calloc(1, sizeof(port_t)); + port_type(x) = FILE_PORT; + port_set_closed(x, false); + port_original_input_string(x) = sc->nil; + port_filename_length(x) = 7; + port_set_filename(sc, x, "*stdin*", 7); + port_file_number(x) = remember_file_name(sc, port_filename(x)); + port_line_number(x) = 0; + port_file(x) = stdin; + port_data_block(x) = NULL; + port_needs_free(x) = false; + port_port(x)->pf = &stdin_functions; + sc->standard_input = x; + + s7_define_variable_with_documentation(sc, "*stdin*", + sc->standard_input, + "*stdin* is the built-in input port, C's stdin"); + s7_define_variable_with_documentation(sc, "*stdout*", + sc->standard_output, + "*stdout* is the built-in buffered output port, C's stdout"); + s7_define_variable_with_documentation(sc, "*stderr*", + sc->standard_error, + "*stderr* is the built-in unbuffered output port, C's stderr"); + + set_current_input_port(sc, sc->standard_input); + set_current_output_port(sc, sc->standard_output); + sc->error_port = sc->standard_error; + sc->current_file = NULL; + sc->current_line = -1; +} + + +/* -------------------------------- open-output-file -------------------------------- */ +static const port_functions_t output_file_functions = + { output_read_char, file_write_char, file_write_string, NULL, NULL, + NULL, NULL, output_read_line, file_display, close_output_file +}; + +s7_pointer s7_open_output_file(s7_scheme * sc, const char *name, + const char *mode) +{ + FILE *fp; + s7_pointer x; + block_t *block, *b; + /* see if we can open this file before allocating a port */ + + errno = 0; + fp = fopen(name, mode); + if (!fp) { +#if (!MS_WINDOWS) + if (errno == EINVAL) + return (file_error + (sc, "open-output-file", "invalid mode", mode)); +#endif + return (file_error(sc, "open-output-file", strerror(errno), name)); + } + + new_cell(sc, x, T_OUTPUT_PORT); + b = mallocate_port(sc); + port_block(x) = b; + port_port(x) = (port_t *) block_data(b); + port_type(x) = FILE_PORT; + port_set_closed(x, false); + port_filename_length(x) = safe_strlen(name); + port_set_filename(sc, x, name, port_filename_length(x)); + port_line_number(x) = 1; + port_file_number(x) = 0; + port_file(x) = fp; + port_needs_free(x) = true; /* hmm -- I think these are freed via s7_close_output_port -> close_output_port */ + port_position(x) = 0; + port_data_size(x) = sc->output_port_data_size; + block = mallocate(sc, sc->output_port_data_size); + port_data_block(x) = block; + port_data(x) = (uint8_t *) (block_data(block)); + port_port(x)->pf = &output_file_functions; + add_output_port(sc, x); + return (x); +} + +static s7_pointer g_open_output_file(s7_scheme * sc, s7_pointer args) +{ +#define H_open_output_file "(open-output-file filename (mode \"w\")) opens filename for writing" +#define Q_open_output_file s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_string_symbol, sc->is_string_symbol) + + s7_pointer name = car(args); + if (!is_string(name)) + return (method_or_bust + (sc, name, sc->open_output_file_symbol, args, T_STRING, + 1)); + if (!is_pair(cdr(args))) + return (s7_open_output_file(sc, string_value(name), "w")); + if (!is_string(cadr(args))) + return (method_or_bust_with_type + (sc, cadr(args), sc->open_output_file_symbol, args, + wrap_string(sc, "a string (a mode such as \"w\")", 29), + 2)); + return (s7_open_output_file + (sc, string_value(name), string_value(cadr(args)))); +} + + +/* -------------------------------- open-input-string -------------------------------- */ + /* a version of string ports using a pointer to the current location and a pointer to the end + * (rather than an integer for both, indexing from the base string) was not faster. + */ + +static const port_functions_t input_string_functions = + { string_read_char, input_write_char, input_write_string, + string_read_semicolon, terminated_string_read_white_space, + string_read_name_no_free, string_read_sharp, string_read_line, + input_display, close_simple_input_string +}; + +static s7_pointer open_input_string(s7_scheme * sc, + const char *input_string, s7_int len) +{ + s7_pointer x; + block_t *b; + new_cell(sc, x, T_INPUT_PORT); + b = mallocate_port(sc); + port_block(x) = b; + port_port(x) = (port_t *) block_data(b); + port_type(x) = STRING_PORT; + port_set_closed(x, false); + port_original_input_string(x) = sc->nil; + port_data(x) = (uint8_t *) input_string; + port_data_block(x) = NULL; + port_data_size(x) = len; + port_position(x) = 0; + port_filename_block(x) = NULL; + port_filename_length(x) = 0; + port_filename(x) = NULL; + port_file_number(x) = 0; + port_line_number(x) = 0; + port_file(x) = NULL; + port_needs_free(x) = false; +#if S7_DEBUGGING + if (input_string[len] != '\0') { + fprintf(stderr, + "%s[%d]: read_white_space string is not terminated: len: %" + ld64 ", at end: %c%c, str: %s", __func__, __LINE__, len, + input_string[len - 1], input_string[len], input_string); + abort(); + } +#endif + port_port(x)->pf = &input_string_functions; + add_input_string_port(sc, x); + return (x); +} + +static inline s7_pointer open_and_protect_input_string(s7_scheme * sc, + s7_pointer str) +{ + s7_pointer p; + p = open_input_string(sc, string_value(str), string_length(str)); + port_original_input_string(p) = str; + return (p); +} + +s7_pointer s7_open_input_string(s7_scheme * sc, const char *input_string) +{ + return (open_input_string + (sc, input_string, safe_strlen(input_string))); +} + +static s7_pointer g_open_input_string(s7_scheme * sc, s7_pointer args) +{ +#define H_open_input_string "(open-input-string str) opens an input port reading str" +#define Q_open_input_string s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_string_symbol) + + s7_pointer input_string = car(args), port; + if (!is_string(input_string)) + return (method_or_bust_one_arg + (sc, input_string, sc->open_input_string_symbol, args, + T_STRING)); + port = open_and_protect_input_string(sc, input_string); + return (port); +} + + +/* -------------------------------- open-output-string -------------------------------- */ +#define FORMAT_PORT_LENGTH 128 +/* the large majority (> 99% in my tests) of the output strings have less than 128 chars when the port is finally closed + * 256 is slightly slower (the calloc time below dominates the realloc time in string_write_string) + * 64 is much slower (realloc dominates) + */ + +static const port_functions_t output_string_functions = + { output_read_char, string_write_char, string_write_string, NULL, NULL, + NULL, NULL, output_read_line, string_display, close_output_string +}; + +s7_pointer s7_open_output_string(s7_scheme * sc) +{ + s7_pointer x; + block_t *block, *b; + new_cell(sc, x, T_OUTPUT_PORT); + b = mallocate_port(sc); + port_block(x) = b; + port_port(x) = (port_t *) block_data(b); + port_type(x) = STRING_PORT; + port_set_closed(x, false); + port_data_size(x) = sc->initial_string_port_length; + block = mallocate(sc, sc->initial_string_port_length); + port_data_block(x) = block; + port_data(x) = (uint8_t *) (block_data(block)); + port_data(x)[0] = '\0'; /* in case s7_get_output_string before any output */ + port_position(x) = 0; + port_needs_free(x) = true; + port_filename_block(x) = NULL; + port_filename_length(x) = 0; /* protect against (port-filename (open-output-string)) */ + port_filename(x) = NULL; + port_port(x)->pf = &output_string_functions; + add_output_port(sc, x); + return (x); +} + +static s7_pointer g_open_output_string(s7_scheme * sc, s7_pointer args) +{ +#define H_open_output_string "(open-output-string) opens an output string port" +#define Q_open_output_string s7_make_signature(sc, 1, sc->is_output_port_symbol) + return (s7_open_output_string(sc)); +} + + +/* -------------------------------- get-output-string -------------------------------- */ +const char *s7_get_output_string(s7_scheme * sc, s7_pointer p) +{ + port_data(p)[port_position(p)] = '\0'; + return ((const char *) port_data(p)); +} + +s7_pointer s7_output_string(s7_scheme * sc, s7_pointer p) +{ + port_data(p)[port_position(p)] = '\0'; + return (make_string_with_length + (sc, (const char *) port_data(p), port_position(p))); +} + +static inline void check_get_output_string_port(s7_scheme * sc, + s7_pointer p) +{ + if (port_is_closed(p)) + simple_wrong_type_argument_with_type(sc, + sc->get_output_string_symbol, + p, wrap_string(sc, + "an active (open) string port", + 28)); + + if (port_position(p) > sc->max_string_length) + s7_error(sc, sc->out_of_range_symbol, + set_elist_2(sc, + wrap_string(sc, + "port-position ~D is greater than (*s7* 'max-string-length)", + 58), wrap_integer1(sc, + port_position + (p)))); +} + +static s7_pointer g_get_output_string(s7_scheme * sc, s7_pointer args) +{ +#define H_get_output_string "(get-output-string port clear-port) returns the output accumulated in port. \ +If the optional 'clear-port' is #t, the current string is flushed." +#define Q_get_output_string s7_make_signature(sc, 3, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), sc->is_boolean_symbol) + + s7_pointer p; + bool clear_port = false; + + if (is_pair(cdr(args))) { + p = cadr(args); + if (!s7_is_boolean(p)) + return (wrong_type_argument + (sc, sc->get_output_string_symbol, 2, p, T_BOOLEAN)); + clear_port = (p == sc->T); + } + p = car(args); + if ((!is_output_port(p)) || (!is_string_port(p))) { + if (p == sc->F) + return (nil_string); + return (method_or_bust_with_type_one_arg + (sc, p, sc->get_output_string_symbol, args, + wrap_string(sc, "an output string port", 21))); + } + check_get_output_string_port(sc, p); + + if ((clear_port) && (port_position(p) < port_data_size(p))) { + block_t *block; + s7_pointer result; + result = block_to_string(sc, port_data_block(p), port_position(p)); + /* this is slightly faster than make_string_with_length(sc, (char *)(port_data(p)), port_position(p)): we're trading a mallocate for a memcpy */ + port_data_size(p) = sc->initial_string_port_length; + block = mallocate(sc, port_data_size(p)); + port_data_block(p) = block; + port_data(p) = (uint8_t *) (block_data(block)); + port_position(p) = 0; + port_data(p)[0] = '\0'; + return (result); + } + return (make_string_with_length + (sc, (const char *) port_data(p), port_position(p))); +} + +static void op_get_output_string(s7_scheme * sc) +{ + s7_pointer port = sc->code; + if (!is_output_port(port)) + simple_wrong_type_argument_with_type(sc, + sc->with_output_to_string_symbol, + port, wrap_string(sc, + "an open string output port", + 26)); + check_get_output_string_port(sc, port); + + if (port_position(port) >= port_data_size(port)) /* can the > part happen? */ + sc->value = + block_to_string(sc, + reallocate(sc, port_data_block(port), + port_position(port) + 1), + port_position(port)); + else + sc->value = + block_to_string(sc, port_data_block(port), + port_position(port)); + + port_data(port) = NULL; + port_data_size(port) = 0; + port_data_block(port) = NULL; + port_needs_free(port) = false; +} + +static s7_pointer g_get_output_string_uncopied(s7_scheme * sc, + s7_pointer args) +{ + s7_pointer p = car(args); + if ((!is_output_port(p)) || (!is_string_port(p))) { + if (p == sc->F) + return (nil_string); + return (method_or_bust_with_type_one_arg + (sc, p, sc->get_output_string_symbol, args, + wrap_string(sc, "an output string port", 21))); + } + check_get_output_string_port(sc, p); + return (wrap_string + (sc, (const char *) port_data(p), port_position(p))); +} + + +/* -------------------------------- open-input-function -------------------------------- */ +static s7_pointer g_closed_input_function_port(s7_scheme * sc, + s7_pointer args) +{ + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_1(sc, + wrap_string(sc, + "attempt to read from a closed input-function port", + 49)))); +} + +static void close_input_function(s7_scheme * sc, s7_pointer p) +{ + port_port(p)->pf = &closed_port_functions; + port_input_scheme_function(p) = sc->closed_input_function; /* from s7_make_function so it is GC-protected */ + port_set_closed(p, true); +} + +static const port_functions_t input_function_functions = + { function_read_char, input_write_char, input_write_string, NULL, NULL, + NULL, NULL, function_read_line, input_display, close_input_function +}; + +static void function_port_set_defaults(s7_pointer x) +{ + port_type(x) = FUNCTION_PORT; + port_data(x) = NULL; + port_data_block(x) = NULL; + port_set_closed(x, false); + port_needs_free(x) = false; + port_filename_block(x) = NULL; /* next three protect against port-filename misunderstandings */ + port_filename(x) = NULL; + port_filename_length(x) = 0; + port_file_number(x) = 0; + port_line_number(x) = 0; + port_file(x) = NULL; +} + +s7_pointer s7_open_input_function(s7_scheme * sc, + s7_pointer(*function) (s7_scheme * sc, + s7_read_t + read_choice, + s7_pointer port)) +{ + s7_pointer x; + block_t *b; + new_cell(sc, x, T_INPUT_PORT); + b = mallocate_port(sc); + port_block(x) = b; + port_port(x) = (port_t *) block_data(b); + function_port_set_defaults(x); + port_input_scheme_function(x) = sc->nil; + port_input_function(x) = function; + port_port(x)->pf = &input_function_functions; + add_input_port(sc, x); + return (x); +} + +static void init_open_input_function_choices(s7_scheme * sc) +{ + sc->open_input_function_choices[S7_READ] = sc->read_symbol; + sc->open_input_function_choices[S7_READ_CHAR] = sc->read_char_symbol; + sc->open_input_function_choices[S7_READ_LINE] = sc->read_line_symbol; + sc->open_input_function_choices[S7_PEEK_CHAR] = sc->peek_char_symbol; +#if (!WITH_PURE_S7) + sc->open_input_function_choices[S7_IS_CHAR_READY] = + sc->is_char_ready_symbol; +#endif +} + +static s7_pointer input_scheme_function_wrapper(s7_scheme * sc, + s7_read_t read_choice, + s7_pointer port) +{ + return (s7_apply_function + (sc, port_input_scheme_function(port), + set_plist_1(sc, + sc->open_input_function_choices[(int) + read_choice]))); +} + +static s7_pointer g_open_input_function(s7_scheme * sc, s7_pointer args) +{ +#define H_open_input_function "(open-input-function func) opens an input function port" +#define Q_open_input_function s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_procedure_symbol) + + s7_pointer port, func = car(args); + + if (!is_any_procedure(func)) /* is_procedure is too lenient: we need to flag (open-input-function (block)) for example */ + return (wrong_type_argument_with_type + (sc, sc->open_input_function_symbol, 0, func, + a_procedure_string)); + if (!s7_is_aritable(sc, func, 1)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "input-function-port function, ~A, should take one argument", + 58), func))); + + port = s7_open_input_function(sc, input_scheme_function_wrapper); + port_input_scheme_function(port) = func; + return (port); +} + + +/* -------------------------------- open-output-function -------------------------------- */ +static s7_pointer g_closed_output_function_port(s7_scheme * sc, + s7_pointer args) +{ + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_1(sc, + wrap_string(sc, + "attempt to write to a closed output-function port", + 49)))); +} + +static void close_output_function(s7_scheme * sc, s7_pointer p) +{ + port_port(p)->pf = &closed_port_functions; + port_output_scheme_function(p) = sc->closed_output_function; + port_set_closed(p, true); +} + +static const port_functions_t output_function_functions = + { output_read_char, function_write_char, function_write_string, NULL, + NULL, NULL, NULL, output_read_line, function_display, + close_output_function +}; + +s7_pointer s7_open_output_function(s7_scheme * sc, + void (*function)(s7_scheme * sc, + uint8_t c, + s7_pointer port)) +{ + s7_pointer x; + block_t *b; + new_cell(sc, x, T_OUTPUT_PORT); + b = mallocate_port(sc); + port_block(x) = b; + port_port(x) = (port_t *) block_data(b); + function_port_set_defaults(x); + port_output_function(x) = function; + port_output_scheme_function(x) = sc->nil; + port_port(x)->pf = &output_function_functions; + add_output_port(sc, x); + return (x); +} + +static void output_scheme_function_wrapper(s7_scheme * sc, uint8_t c, + s7_pointer port) +{ + s7_apply_function(sc, port_output_scheme_function(port), + set_plist_1(sc, make_integer(sc, c))); +} + +static s7_pointer g_open_output_function(s7_scheme * sc, s7_pointer args) +{ +#define H_open_output_function "(open-output-function func) opens an output function port" +#define Q_open_output_function s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->is_procedure_symbol) + + s7_pointer port, func = car(args); + + if (!is_any_procedure(func)) + return (wrong_type_argument_with_type + (sc, sc->open_output_function_symbol, 0, func, + a_procedure_string)); + if (!s7_is_aritable(sc, func, 1)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "output-function-port function, ~A, should take one argument", + 59), func))); + + port = s7_open_output_function(sc, output_scheme_function_wrapper); + port_output_scheme_function(port) = func; + mark_function[T_OUTPUT_PORT] = mark_output_port; + return (port); +} + + +/* -------- current-input-port stack -------- */ +#define INPUT_PORT_STACK_INITIAL_SIZE 4 + +static inline void push_input_port(s7_scheme * sc, s7_pointer new_port) +{ + if (sc->input_port_stack_loc >= sc->input_port_stack_size) { + sc->input_port_stack_size *= 2; + sc->input_port_stack = + (s7_pointer *) Realloc(sc->input_port_stack, + sc->input_port_stack_size * + sizeof(s7_pointer)); + } + sc->input_port_stack[sc->input_port_stack_loc++] = + current_input_port(sc); + set_current_input_port(sc, new_port); +} + +static void pop_input_port(s7_scheme * sc) +{ + if (sc->input_port_stack_loc > 0) + set_current_input_port(sc, + sc->input_port_stack[-- + (sc->input_port_stack_loc)]); + else + set_current_input_port(sc, sc->standard_input); +} + +static s7_pointer input_port_if_not_loading(s7_scheme * sc) +{ + s7_pointer port = current_input_port(sc); + int32_t c; + if (!is_loader_port(port)) /* this flag is turned off by the reader macros, so we aren't in that context */ + return (port); + c = port_read_white_space(port) (sc, port); + if (c > 0) { /* we can get either EOF or NULL at the end */ + backchar(c, port); + return (NULL); + } + return (sc->standard_input); +} + + +/* -------------------------------- read-char -------------------------------- */ +s7_pointer s7_read_char(s7_scheme * sc, s7_pointer port) +{ + int32_t c; + c = port_read_character(port) (sc, port); + return ((c == EOF) ? eof_object : chars[c]); +} + +static s7_pointer g_read_char(s7_scheme * sc, s7_pointer args) +{ +#define H_read_char "(read-char (port (current-input-port))) returns the next character in the input port" +#define Q_read_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol) + + s7_pointer port; + if (is_not_null(args)) + port = car(args); + else { + port = input_port_if_not_loading(sc); + if (!port) + return (eof_object); + } + if (!is_input_port(port)) + return (method_or_bust_with_type_one_arg + (sc, port, sc->read_char_symbol, args, + an_input_port_string)); + return (chars[port_read_character(port) (sc, port)]); +} + +static s7_pointer read_char_p_p(s7_scheme * sc, s7_pointer port) +{ + if (!is_input_port(port)) + return (method_or_bust_with_type_one_arg_p + (sc, port, sc->read_char_symbol, an_input_port_string)); + return (chars[port_read_character(port) (sc, port)]); +} + +static s7_pointer g_read_char_1(s7_scheme * sc, s7_pointer args) +{ + s7_pointer port = car(args); + if (!is_input_port(port)) + return (method_or_bust_with_type_one_arg + (sc, port, sc->read_char_symbol, args, + an_input_port_string)); + return (chars[port_read_character(port) (sc, port)]); +} + +static s7_pointer read_char_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + return ((args == 1) ? sc->read_char_1 : f); +} + + +/* -------------------------------- write-char -------------------------------- */ +s7_pointer s7_write_char(s7_scheme * sc, s7_pointer c, s7_pointer pt) +{ + if (pt != sc->F) + port_write_character(pt) (sc, s7_character(c), pt); + return (c); +} + +static s7_pointer write_char_p_pp(s7_scheme * sc, s7_pointer c, + s7_pointer port) +{ + if (!is_character(c)) + return (method_or_bust_pp + (sc, c, sc->write_char_symbol, c, port, T_CHARACTER, 1)); + if (port == sc->F) + return (c); + if (!is_output_port(port)) + return (method_or_bust_with_type_pp + (sc, port, sc->write_char_symbol, c, port, + an_output_port_string, 2)); + port_write_character(port) (sc, s7_character(c), port); + return (c); +} + +static s7_pointer g_write_char(s7_scheme * sc, s7_pointer args) +{ +#define H_write_char "(write-char char (port (current-output-port))) writes char to the output port" +#define Q_write_char s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) + return (write_char_p_pp + (sc, car(args), + (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc))); +} + +static s7_pointer write_char_p_p(s7_scheme * sc, s7_pointer c) +{ + if (!is_character(c)) + return (method_or_bust_p + (sc, c, sc->write_char_symbol, T_CHARACTER)); + if (current_output_port(sc) == sc->F) + return (c); + port_write_character(current_output_port(sc)) (sc, s7_character(c), + current_output_port + (sc)); + return (c); +} + +/* (with-output-to-string (lambda () (write-char #\space))) -> " " + * (with-output-to-string (lambda () (write #\space))) -> "#\\space" + * (with-output-to-string (lambda () (display #\space))) -> " " + * is this correct? It's what Guile does. write-char is actually display-char. + */ + + +/* -------------------------------- peek-char -------------------------------- */ +s7_pointer s7_peek_char(s7_scheme * sc, s7_pointer port) +{ + int32_t c; /* needs to be an int32_t so EOF=-1, but not 255 */ + if (is_string_port(port)) + return ((port_data_size(port) <= + port_position(port)) ? chars[EOF] : chars[(uint8_t) + port_data(port) + [port_position + (port)]]); + c = port_read_character(port) (sc, port); + if (c == EOF) + return (eof_object); + backchar(c, port); + return (chars[c]); +} + +static s7_pointer g_peek_char(s7_scheme * sc, s7_pointer args) +{ +#define H_peek_char "(peek-char (port (current-input-port))) returns the next character in the input port, but does not remove it from the input stream" +#define Q_peek_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol) + + s7_pointer port, res; + port = (is_not_null(args)) ? car(args) : current_input_port(sc); + if (!is_input_port(port)) + return (method_or_bust_with_type_one_arg + (sc, port, sc->peek_char_symbol, args, + an_input_port_string)); + if (port_is_closed(port)) + return (simple_wrong_type_argument_with_type + (sc, sc->peek_char_symbol, port, an_open_port_string)); + if (!is_function_port(port)) + return (s7_peek_char(sc, port)); + + res = (*(port_input_function(port))) (sc, S7_PEEK_CHAR, port); + if (is_multiple_value(res)) { + clear_multiple_value(res); + s7_error(sc, sc->bad_result_symbol, + set_elist_2(sc, + wrap_string(sc, + "input-function-port peek-char returned: ~S", + 42), res)); + } + if (!is_character(res)) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "input_function_port peek_char returned: ~S", + 42), res)); + return (res); +} + + +/* -------------------------------- read-byte -------------------------------- */ +static s7_pointer g_read_byte(s7_scheme * sc, s7_pointer args) +{ +#define H_read_byte "(read-byte (port (current-input-port))): reads a byte from the input port" +#define Q_read_byte s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_byte_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol) + + s7_pointer port; + int32_t c; + if (is_not_null(args)) + port = car(args); + else { + port = input_port_if_not_loading(sc); + if (!port) + return (eof_object); + } + if (!is_input_port(port)) + return (method_or_bust_with_type_one_arg + (sc, port, sc->read_byte_symbol, args, + an_input_port_string)); + + c = port_read_character(port) (sc, port); + return ((c == EOF) ? eof_object : small_int(c)); +} + + +/* -------------------------------- write-byte -------------------------------- */ +static s7_pointer g_write_byte(s7_scheme * sc, s7_pointer args) +{ +#define H_write_byte "(write-byte byte (port (current-output-port))): writes byte to the output port" +#define Q_write_byte s7_make_signature(sc, 3, sc->is_byte_symbol, sc->is_byte_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) + + s7_pointer port, b = car(args); + s7_int val; + if (!s7_is_integer(b)) + return (method_or_bust + (sc, car(args), sc->write_byte_symbol, args, T_INTEGER, + 1)); + + val = s7_integer_checked(sc, b); + if ((val < 0) || (val > 255)) /* need to check this before port==#f, else (write-byte most-positive-fixnum #f) is not an error */ + return (wrong_type_argument_with_type + (sc, sc->write_byte_symbol, 1, b, + an_unsigned_byte_string)); + + port = (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc); + if (!is_output_port(port)) { + if (port == sc->F) + return (car(args)); + return (method_or_bust_with_type_one_arg + (sc, port, sc->write_byte_symbol, args, + an_output_port_string)); + } + port_write_character(port) (sc, (uint8_t) val, port); + return (b); +} + + +/* -------------------------------- read-line -------------------------------- */ +static s7_pointer g_read_line(s7_scheme * sc, s7_pointer args) +{ +#define H_read_line "(read-line port (with-eol #f)) returns the next line from port, or #. \ +If 'with-eol' is not #f, read-line includes the trailing end-of-line character." +#define Q_read_line s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol, sc->is_boolean_symbol) + + s7_pointer port; + bool with_eol = false; + if (is_not_null(args)) { + port = car(args); + if (!is_input_port(port)) + return (method_or_bust_with_type + (sc, port, sc->read_line_symbol, args, + an_input_port_string, 1)); + + if (is_not_null(cdr(args))) + with_eol = (cadr(args) != sc->F); /* perhaps this should insist on #t: (read-line port (c-pointer 0)) */ + } else { + port = input_port_if_not_loading(sc); + if (!port) + return (eof_object); + } + return (port_read_line(port) (sc, port, with_eol)); +} + +static s7_pointer read_line_p_pp(s7_scheme * sc, s7_pointer port, + s7_pointer with_eol) +{ + if (!is_input_port(port)) + return (method_or_bust_with_type_pp + (sc, port, sc->read_line_symbol, port, with_eol, + an_input_port_string, 1)); + return (port_read_line(port) (sc, port, with_eol != sc->F)); +} + +static s7_pointer read_line_p_p(s7_scheme * sc, s7_pointer port) +{ + if (!is_input_port(port)) + return (method_or_bust_with_type_one_arg_p + (sc, port, sc->read_line_symbol, an_input_port_string)); + return (port_read_line(port) (sc, port, false)); /* with_eol default is #f */ +} + + +/* -------------------------------- read-string -------------------------------- */ +static s7_pointer g_read_string(s7_scheme * sc, s7_pointer args) +{ + /* read-chars would be a better name -- read-string could mean CL-style read-from-string (like eval-string) + * similarly read-bytes could return a byte-vector (rather than r7rs's read-bytevector) + * and write-string -> write-chars, write-bytevector -> write-bytes + */ +#define H_read_string "(read-string k port) reads k characters from port into a new string and returns it." +#define Q_read_string s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), sc->is_integer_symbol, sc->is_input_port_symbol) + + s7_pointer k = car(args), port, s; + s7_int i, nchars; + uint8_t *str; + + if (!s7_is_integer(k)) + return (method_or_bust + (sc, k, sc->read_string_symbol, args, T_INTEGER, 1)); + nchars = s7_integer_checked(sc, k); + if (nchars < 0) + return (wrong_type_argument_with_type + (sc, sc->read_string_symbol, 1, k, + a_non_negative_integer_string)); + if (nchars > sc->max_string_length) + return (out_of_range + (sc, sc->read_string_symbol, int_one, k, + its_too_large_string)); + + if (!is_null(cdr(args))) + port = cadr(args); + else { + port = input_port_if_not_loading(sc); + if (!port) + return (eof_object); + } + if (!is_input_port(port)) + return (method_or_bust_with_type_pp + (sc, port, sc->read_string_symbol, k, port, + an_input_port_string, 2)); + if (port_is_closed(port)) + return (simple_wrong_type_argument_with_type + (sc, sc->read_string_symbol, port, an_open_port_string)); + + s = make_empty_string(sc, nchars, 0); + if (nchars == 0) + return (s); + str = (uint8_t *) string_value(s); + if (is_string_port(port)) { + s7_int len, pos = port_position(port), end = port_data_size(port); + len = end - pos; + if (len > nchars) + len = nchars; + if (len <= 0) + return (eof_object); + memcpy((void *) str, (void *) (port_data(port) + pos), len); + string_length(s) = len; + str[len] = '\0'; + port_position(port) += len; + return (s); + } + if (is_file_port(port)) { + size_t len; + len = fread((void *) str, 1, nchars, port_file(port)); + str[len] = '\0'; + string_length(s) = len; + return (s); + } + for (i = 0; i < nchars; i++) { + int32_t c; + c = port_read_character(port) (sc, port); + if (c == EOF) { + if (i == 0) + return (eof_object); + string_length(s) = i; + return (s); + } + str[i] = (uint8_t) c; + } + return (s); +} + + +/* -------------------------------- read -------------------------------- */ +#define declare_jump_info() bool old_longjmp; int32_t old_jump_loc, jump_loc; Jmp_Buf old_goto_start + +#define store_jump_info(Sc) \ + do { \ + old_longjmp = Sc->longjmp_ok; \ + old_jump_loc = Sc->setjmp_loc; \ + memcpy((void *)old_goto_start, (void *)(Sc->goto_start), sizeof(Jmp_Buf)); \ + } while (0) + +#define restore_jump_info(Sc) \ + do { \ + Sc->longjmp_ok = old_longjmp; \ + Sc->setjmp_loc = old_jump_loc; \ + memcpy((void *)(Sc->goto_start), (void *)old_goto_start, sizeof(Jmp_Buf)); \ + if ((jump_loc == ERROR_JUMP) && \ + (sc->longjmp_ok)) \ + LongJmp(sc->goto_start, ERROR_JUMP); \ + } while (0) + +#define set_jump_info(Sc, Tag) \ + do { \ + sc->longjmp_ok = true; \ + sc->setjmp_loc = Tag; \ + jump_loc = SetJmp(sc->goto_start, 1); \ + } while (0) + +s7_pointer s7_read(s7_scheme * sc, s7_pointer port) +{ + if (is_input_port(port)) { + s7_pointer old_let; + declare_jump_info(); + + old_let = sc->curlet; + sc->curlet = sc->nil; + push_input_port(sc, port); + + store_jump_info(sc); + set_jump_info(sc, READ_SET_JUMP); + if (jump_loc != NO_JUMP) { + if (jump_loc != ERROR_JUMP) + eval(sc, sc->cur_op); + } else { + push_stack_no_let_no_code(sc, OP_BARRIER, port); + push_stack_direct(sc, OP_EVAL_DONE); + eval(sc, OP_READ_INTERNAL); + if (sc->tok == TOKEN_EOF) + sc->value = eof_object; + if ((sc->cur_op == OP_EVAL_DONE) && + (stack_op(sc->stack, current_stack_top(sc) - 1) == + OP_BARRIER)) + pop_stack(sc); + } + pop_input_port(sc); + set_curlet(sc, old_let); + + restore_jump_info(sc); + return (sc->value); + } + return (simple_wrong_type_argument_with_type + (sc, sc->read_symbol, port, an_input_port_string)); +} + +static s7_pointer g_read(s7_scheme * sc, s7_pointer args) +{ +#define H_read "(read (port (current-input-port))) returns the next object in the input port, or # at the end" +#define Q_read s7_make_signature(sc, 2, sc->T, sc->is_input_port_symbol) + + s7_pointer port; + if (is_not_null(args)) + port = car(args); + else { + port = input_port_if_not_loading(sc); + if (!port) + return (eof_object); + } + if (!is_input_port(port)) + return (method_or_bust_with_type_one_arg + (sc, port, sc->read_symbol, args, an_input_port_string)); + + if (is_function_port(port)) { + s7_pointer res; + res = (*(port_input_function(port))) (sc, S7_READ, port); + if (is_multiple_value(res)) { + clear_multiple_value(res); + s7_error(sc, sc->bad_result_symbol, + set_elist_2(sc, + wrap_string(sc, + "input-function-port read returned: ~S", + 37), res)); + } + return (res); + } + if ((is_string_port(port)) && + (port_data_size(port) <= port_position(port))) + return (eof_object); + + push_input_port(sc, port); + push_stack_op_let(sc, OP_READ_DONE); /* this stops the internal read process so we only get one form */ + push_stack_op_let(sc, OP_READ_INTERNAL); + return (port); +} + + +/* -------------------------------- load -------------------------------- */ +#if WITH_MULTITHREAD_CHECKS +typedef struct { + s7_scheme *sc; + const int32_t lock_count; /* Remember lock count in case we have skipped calls to leave_track_scope by longjmp-ing. */ +} lock_scope_t; + +static lock_scope_t enter_lock_scope(s7_scheme * sc) +{ + int result = pthread_mutex_trylock(&sc->lock); + if (result != 0) { + fprintf(stderr, "pthread_mutex_trylock failed: %d (EBUSY: %d)", + result, EBUSY); + abort(); + } + sc->lock_count++; + { + lock_scope_t st = {.sc = sc,.lock_count = sc->lock_count }; + return (st); + } +} + +static void leave_lock_scope(lock_scope_t * st) +{ + while (st->sc->lock_count > st->lock_count) { + st->sc->lock_count--; + pthread_mutex_unlock(&st->sc->lock); + } +} + +#define TRACK(Sc) lock_scope_t lock_scope __attribute__ ((__cleanup__(leave_lock_scope))) = enter_lock_scope(Sc) +#else +#define TRACK(Sc) +#endif + +/* various changes in this section courtesy of Woody Douglass 12-Jul-19 */ + +static block_t *search_load_path(s7_scheme * sc, const char *name) +{ + s7_pointer lst = s7_load_path(sc); + if (is_pair(lst)) { + block_t *b; + char *filename; + s7_pointer dir_names; + s7_int name_len; + + /* linux: PATH_MAX: 4096, windows: MAX_PATH: unlimited?, Mac: 1016?, BSD: MAX_PATH_LENGTH: 1024 */ +#if MS_WINDOWS || defined(__linux__) +#define S7_FILENAME_MAX 4096 /* so we can handle 4095 chars (need trailing null) -- this limit could be added to *s7* */ +#else +#define S7_FILENAME_MAX 1024 +#endif + b = mallocate(sc, S7_FILENAME_MAX); + + filename = (char *) block_data(b); + name_len = safe_strlen(name); + + for (dir_names = lst; is_pair(dir_names); + dir_names = cdr(dir_names)) { + const char *new_dir = string_value(car(dir_names)); + if (new_dir) { + if ((WITH_WARNINGS) + && (string_length(car(dir_names)) + name_len >= + S7_FILENAME_MAX)) + s7_warn(sc, 256, + "load: file + directory name too long: %" ld64 + " + %" ld64 " > %d\n", name_len, + string_length(car(dir_names)), + S7_FILENAME_MAX); + filename[0] = '\0'; + if (new_dir[strlen(new_dir) - 1] == '/') + catstrs(filename, S7_FILENAME_MAX, new_dir, name, + (char *) NULL); + else + catstrs(filename, S7_FILENAME_MAX, new_dir, "/", name, + (char *) NULL); +#ifdef _MSC_VER + if (_access(filename, 0) != -1) + return (b); +#else + if (access(filename, F_OK) == 0) + return (b); +#endif + } + } + liberate(sc, b); + } + return (NULL); +} + +#if WITH_C_LOADER +#include + +static block_t *full_filename(s7_scheme * sc, const char *filename) +{ + s7_int len; + char *rtn; + block_t *block; + if (filename[0] == '/') { + len = safe_strlen(filename); + block = mallocate(sc, len + 1); + rtn = (char *) block_data(block); + memcpy((void *) rtn, (void *) filename, len); + rtn[len] = '\0'; + } else { + size_t pwd_len, filename_len; + char *pwd = getcwd(NULL, 0); /* docs say this means it will return a new string of the right size */ + pwd_len = safe_strlen(pwd); + filename_len = safe_strlen(filename); + len = pwd_len + filename_len + 2; /* not 1! we need room for the '/' and the terminating 0 */ + block = mallocate(sc, len); + rtn = (char *) block_data(block); + if (pwd) { + memcpy((void *) rtn, (void *) pwd, pwd_len); + rtn[pwd_len] = '/'; + memcpy((void *) (rtn + pwd_len + 1), (void *) filename, + filename_len); + rtn[pwd_len + filename_len + 1] = '\0'; + free(pwd); + } else { /* isn't this an error? -- perhaps warn about getcwd, strerror(errno) */ + memcpy((void *) rtn, (void *) filename, filename_len); + rtn[filename_len] = '\0'; + }} + return (block); +} + +static s7_pointer load_shared_object(s7_scheme * sc, const char *fname, + s7_pointer let) +{ + /* if fname ends in .so, try loading it as a C shared object: (load "/home/bil/cl/m_j0.so" (inlet 'init_func 'init_m_j0)) */ + s7_int fname_len; + + fname_len = safe_strlen(fname); + if ((fname_len > 3) && + (local_strcmp((const char *) (fname + (fname_len - 3)), ".so"))) { + void *library; + char *pwd_name = NULL; + block_t *pname = NULL; + + if ((access(fname, F_OK) == 0) || (fname[0] == '/')) { + pname = full_filename(sc, fname); + pwd_name = (char *) block_data(pname); + } else { + block_t *searched; + searched = search_load_path(sc, fname); /* returns NULL if *load-path* is nil, or if nothing matches */ + if (searched) { + if (((const char *) block_data(searched))[0] == '/') + pname = searched; + else { + pname = full_filename(sc, (const char *) block_data(searched)); /* this is necessary, at least in Linux -- we can't blithely dlopen whatever is passed to us */ + liberate(sc, searched); + } + pwd_name = (char *) block_data(pname); + } else { /* perhaps no *load-path* entries */ + pname = full_filename(sc, fname); + pwd_name = (char *) block_data(pname); + }} + /* else pname is NULL, so use fname -- can this happen? */ + if ((S7_DEBUGGING) && (!pname)) + fprintf(stderr, "pname is null\n"); + library = dlopen((pname) ? pwd_name : fname, RTLD_NOW); + if (!library) + s7_warn(sc, 512, "load %s failed: %s\n", + (pname) ? pwd_name : fname, dlerror()); + else if (let) { /* look for 'init_func in let */ + s7_pointer init; + init = s7_let_ref(sc, let, make_symbol(sc, "init_func")); + /* init is a symbol (surely not a gensym?), so it should not need to be protected */ + if (!is_symbol(init)) + s7_warn(sc, 512, "can't load %s: no init function\n", + fname); + else { + const char *init_name; + void *init_func; + + if (hook_has_functions(sc->load_hook)) + s7_apply_function(sc, sc->load_hook, + set_plist_1(sc, sc->temp6 = + s7_make_string(sc, + (pname) + ? (const + char *) + pwd_name : + fname))); + + init_name = symbol_name(init); + init_func = dlsym(library, init_name); + if (init_func) { + typedef void (*dl_func)(s7_scheme * sc); + typedef s7_pointer(*dl_func_with_args) (s7_scheme * sc, + s7_pointer + args); + s7_pointer init_args, p; + + init_args = + s7_let_ref(sc, let, make_symbol(sc, "init_args")); + gc_protect_via_stack(sc, init_args); + if (is_pair(init_args)) { + p = ((dl_func_with_args) init_func) (sc, + init_args); + stack_protected2(sc) = p; + } + /* if caller includes init_args, but init_func is actually a dl_func, it seems to be ok, + * but the returned value is whatever was last computed in the init_func. + */ + else { + /* if the init_func is expecting args, but caller forgets init_args, this gives a segfault when + * init_func accesses the forgotten args. s7_is_valid can't catch this currently -- + * we need a better way to tell that a random value can't be a cell pointer (scan permallocs and use heap_location?) + */ + ((dl_func) init_func) (sc); + p = sc->F; + } + unstack(sc); + if (pname) + liberate(sc, pname); + return (p); + } + s7_warn(sc, 512, + "loaded %s, but can't find init_func %s, dlerror: %s, let: %s\n", + fname, init_name, dlerror(), display(let)); + dlclose(library); + } + if (S7_DEBUGGING) + fprintf(stderr, "init_func trouble in %s, %s\n", fname, + display(init)); + if (pname) + liberate(sc, pname); + return (sc->undefined); + } + if (pname) + liberate(sc, pname); + } + return (NULL); +} +#endif + +static s7_pointer load_file_1(s7_scheme * sc, const char *filename) +{ + FILE *fp; + if (is_directory(filename)) + return (NULL); + fp = fopen(filename, "r"); +#if WITH_GCC + if ((!fp) && /* catch one special case, "~/..." since it causes 99.9% of the "can't load ..." errors */ + (filename[0] == '~') && (filename[1] == '/')) { + char *home; + home = getenv("HOME"); + if (home) { + block_t *b; + char *fname; + s7_int len, file_len, home_len; + file_len = safe_strlen(filename); + home_len = safe_strlen(home); + len = file_len + home_len; + b = mallocate(sc, len); + fname = (char *) block_data(b); + memcpy((void *) fname, home, home_len); + memcpy((void *) (fname + home_len), (char *) (filename + 1), + file_len - 1); + fname[len - 1] = '\0'; + fp = fopen(fname, "r"); + if (fp) + filename = copy_string_with_length(fname, len - 1); + liberate(sc, b); + } + } +#endif + if (!fp) { + block_t *b; + const char *fname; + b = search_load_path(sc, filename); + if (!b) + return (NULL); + fname = (const char *) block_data(b); + fp = fopen(fname, "r"); + if (fp) + filename = copy_string(fname); + liberate(sc, b); + } + if (fp) { + s7_pointer port; + if (hook_has_functions(sc->load_hook)) + s7_apply_function(sc, sc->load_hook, + set_plist_1(sc, sc->temp6 = + s7_make_string(sc, filename))); + port = read_file(sc, fp, filename, -1, "load"); /* -1 = read entire file into string, this is currently not tweakable */ + port_file_number(port) = remember_file_name(sc, filename); + set_loader_port(port); + sc->temp6 = port; + push_input_port(sc, port); + sc->temp6 = sc->nil; + return (port); + } + return (NULL); +} + +s7_pointer s7_load_with_environment(s7_scheme * sc, const char *filename, + s7_pointer e) +{ + /* returns either the value of the load or NULL if filename not found */ + s7_pointer port; + declare_jump_info(); + TRACK(sc); + if (e == sc->s7_let) + return (NULL); + +#if WITH_C_LOADER + port = + load_shared_object(sc, filename, (is_null(e)) ? sc->rootlet : e); + if (port) + return (port); +#endif + + port = load_file_1(sc, filename); + if (!port) + return (NULL); + + set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); + push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code); + + store_jump_info(sc); + set_jump_info(sc, LOAD_SET_JUMP); + if (jump_loc == NO_JUMP) + eval(sc, OP_READ_INTERNAL); + else if (jump_loc != ERROR_JUMP) + eval(sc, sc->cur_op); + + pop_input_port(sc); + if (is_input_port(port)) + s7_close_input_port(sc, port); + + restore_jump_info(sc); + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return (sc->value); +} + +s7_pointer s7_load(s7_scheme * sc, const char *filename) +{ + return (s7_load_with_environment(sc, filename, sc->nil)); +} + +s7_pointer s7_load_c_string_with_environment(s7_scheme * sc, + const char *content, + s7_int bytes, s7_pointer e) +{ +#if (!MS_WINDOWS) + s7_pointer port; + s7_int port_loc; + declare_jump_info(); + TRACK(sc); + + if (content[bytes] != 0) + s7_error(sc, make_symbol(sc, "bad-data"), + set_elist_1(sc, + wrap_string(sc, + "s7_load_c_string content is not terminated", + 42))); + port = open_input_string(sc, content, bytes); + port_loc = gc_protect_1(sc, port); + set_loader_port(port); + push_input_port(sc, port); + set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); + push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code); + s7_gc_unprotect_at(sc, port_loc); + + store_jump_info(sc); + set_jump_info(sc, LOAD_SET_JUMP); + if (jump_loc == NO_JUMP) + eval(sc, OP_READ_INTERNAL); + else if (jump_loc != ERROR_JUMP) + eval(sc, sc->cur_op); + + pop_input_port(sc); + if (is_input_port(port)) + s7_close_input_port(sc, port); + + restore_jump_info(sc); + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return (sc->value); +#else + return (sc->F); +#endif +} + +s7_pointer s7_load_c_string(s7_scheme * sc, const char *content, + s7_int bytes) +{ + return (s7_load_c_string_with_environment + (sc, content, bytes, sc->nil)); +} + +static s7_pointer g_load(s7_scheme * sc, s7_pointer args) +{ +#define H_load "(load file (let (rootlet))) loads the scheme file 'file'. The 'let' argument \ +defaults to the rootlet. To load into the current environment instead, pass (curlet)." +#define Q_load s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol) + + s7_pointer name = car(args); + const char *fname; + + if (!is_string(name)) + return (method_or_bust + (sc, name, sc->load_symbol, args, T_STRING, 1)); + + if (is_pair(cdr(args))) { + s7_pointer e = cadr(args); + if (!is_let(e)) + return (wrong_type_argument_with_type + (sc, sc->load_symbol, 2, e, a_let_string)); + if (e == sc->s7_let) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, "can't load ~S into *s7*", + 23), name))); + set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); + } else + sc->curlet = sc->nil; + + fname = string_value(name); + if ((!fname) || (!(*fname))) /* fopen("", "r") returns a file pointer?? */ + return (s7_error + (sc, sc->out_of_range_symbol, + set_elist_2(sc, + wrap_string(sc, + "load's first argument, ~S, should be a filename", + 47), name))); + +#if WITH_C_LOADER + { + s7_pointer p; + p = load_shared_object(sc, fname, + (is_null(sc->curlet)) ? sc-> + rootlet : sc->curlet); + if (p) + return (p); + } +#endif + errno = 0; + if (!load_file_1(sc, fname)) + return (file_error(sc, "load", strerror(errno), fname)); + + push_stack_op_let(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF); /* was pushing args and code, but I don't think they're used later */ + push_stack_op_let(sc, OP_READ_INTERNAL); + return (sc->unspecified); +} + + +/* -------- *load-path* -------- */ +s7_pointer s7_load_path(s7_scheme * sc) +{ + return (s7_symbol_value(sc, sc->load_path_symbol)); +} + +s7_pointer s7_add_to_load_path(s7_scheme * sc, const char *dir) +{ + s7_symbol_set_value(sc, sc->load_path_symbol, + cons(sc, s7_make_string(sc, dir), + s7_symbol_value(sc, sc->load_path_symbol))); + return (s7_symbol_value(sc, sc->load_path_symbol)); +} + +static s7_pointer g_load_path_set(s7_scheme * sc, s7_pointer args) +{ + /* new value must be either () or a proper list of strings */ + if (is_null(cadr(args))) + return (cadr(args)); + if (is_pair(cadr(args))) { + s7_pointer x; + for (x = cadr(args); is_pair(x); x = cdr(x)) + if (!is_string(car(x))) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "can't set *load-path* to ~S", + 27), cadr(args)))); + if (is_null(x)) + return (cadr(args)); + } + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, "can't set *load-path* to ~S", + 27), cadr(args)))); +} + +/* -------- *cload-directory* -------- */ +static s7_pointer g_cload_directory_set(s7_scheme * sc, s7_pointer args) +{ + /* this sets the directory for cload.scm's output */ + s7_pointer cl_dir = cadr(args); + if (!is_string(cl_dir)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "can't set *cload-directory* to ~S", + 33), cadr(args)))); + s7_symbol_set_value(sc, sc->cload_directory_symbol, cl_dir); + if (safe_strlen(string_value(cl_dir)) > 0) + s7_add_to_load_path(sc, (const char *) (string_value(cl_dir))); + /* should this remove the previous *cload-directory* name first? or not affect *load-path* at all? */ + return (cl_dir); +} + + +/* ---------------- autoload ---------------- */ +#define INITIAL_AUTOLOAD_NAMES_SIZE 4 + +void s7_autoload_set_names(s7_scheme * sc, const char **names, s7_int size) +{ + /* names should be sorted alphabetically by the symbol name (the even indexes in the names array) + * size is the number of symbol names (half the size of the names array( + * the idea here is that by sticking to string constants we can handle 90% of the work at compile-time, + * with less start-up memory. Then eventually we'll add C libraries and every name in those libraries + * will come as an import once dlopen has picked up the library. + */ + if (sc->safety > 1) { + int32_t i, k; + for (i = 0, k = 2; k < (size * 2); i += 2, k += 2) + if ((names[i]) && (names[k]) + && (strcmp(names[i], names[k]) > 0)) { + s7_warn(sc, 256, "%s: names[%d]: %s is out of order\n", + __func__, k, names[k]); + break; + } + } + if (!sc->autoload_names) { + sc->autoload_names = + (const char ***) Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, + sizeof(const char **)); + sc->autoload_names_sizes = + (s7_int *) Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(s7_int)); + sc->autoloaded_already = + (bool **) Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(bool *)); + sc->autoload_names_top = INITIAL_AUTOLOAD_NAMES_SIZE; + sc->autoload_names_loc = 0; + } else if (sc->autoload_names_loc >= sc->autoload_names_top) { + s7_int i; + sc->autoload_names_top *= 2; + sc->autoload_names = + (const char ***) Realloc(sc->autoload_names, + sc->autoload_names_top * + sizeof(const char **)); + sc->autoload_names_sizes = + (s7_int *) Realloc(sc->autoload_names_sizes, + sc->autoload_names_top * sizeof(s7_int)); + sc->autoloaded_already = + (bool **) Realloc(sc->autoloaded_already, + sc->autoload_names_top * sizeof(bool *)); + for (i = sc->autoload_names_loc; i < sc->autoload_names_top; i++) { + sc->autoload_names[i] = NULL; + sc->autoload_names_sizes[i] = 0; + sc->autoloaded_already[i] = NULL; + } + } + sc->autoload_names[sc->autoload_names_loc] = names; + sc->autoload_names_sizes[sc->autoload_names_loc] = size; + sc->autoloaded_already[sc->autoload_names_loc] = + (bool *) Calloc(size, sizeof(bool)); + sc->autoload_names_loc++; +} + +static const char *find_autoload_name(s7_scheme * sc, s7_pointer symbol, + bool *already_loaded, bool loading) +{ + s7_int l = 0, lib, libs; + const char *name = symbol_name(symbol); + libs = sc->autoload_names_loc; + for (lib = 0; lib < libs; lib++) { + const char **names; + s7_int u; + u = sc->autoload_names_sizes[lib] - 1; + names = sc->autoload_names[lib]; + + while (true) { + s7_int comp, pos; + const char *this_name; + if (u < l) + break; + pos = (l + u) / 2; + this_name = names[pos * 2]; + comp = strcmp(this_name, name); + if (comp == 0) { + *already_loaded = sc->autoloaded_already[lib][pos]; + if (loading) + sc->autoloaded_already[lib][pos] = true; + return (names[pos * 2 + 1]); /* file name given func name */ + } + if (comp < 0) + l = pos + 1; + else + u = pos - 1; + } + } + return (NULL); +} + +s7_pointer s7_autoload(s7_scheme * sc, s7_pointer symbol, + s7_pointer file_or_function) +{ + /* add '(symbol . file) to s7's autoload table */ + if (is_null(sc->autoload_table)) + sc->autoload_table = + s7_make_hash_table(sc, sc->default_hash_table_length); + if (sc->safety >= MORE_SAFETY_WARNINGS) { + s7_pointer p; + p = s7_hash_table_ref(sc, sc->autoload_table, symbol); + if ((p != sc->F) && (p != file_or_function)) + s7_warn(sc, 256, "'%s autoload value changed\n", + symbol_name(symbol)); + } + s7_hash_table_set(sc, sc->autoload_table, symbol, file_or_function); + return (file_or_function); +} + +static s7_pointer g_autoload(s7_scheme * sc, s7_pointer args) +{ +#define H_autoload "(autoload symbol file-or-function) adds the symbol to its table of autoloadable symbols. \ +If that symbol is encountered as an unbound variable, s7 either loads the file (following *load-path*), or calls \ +the function. The function takes one argument, the calling environment. Presumably the symbol is defined \ +in the file, or by the function." +#define Q_autoload s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->T) + + s7_pointer sym = car(args), value; + + if (is_string(sym)) { + if (string_length(sym) == 0) /* (autoload "" ...) */ + return (s7_wrong_type_arg_error + (sc, "autoload", 1, sym, "a symbol-name or a symbol")); + sym = + make_symbol_with_length(sc, string_value(sym), + string_length(sym)); + } + if (!is_symbol(sym)) { + check_method(sc, sym, sc->autoload_symbol, args); + return (s7_wrong_type_arg_error + (sc, "autoload", 1, sym, + "a string (symbol-name) or a symbol")); + } + if (is_keyword(sym)) + return (s7_wrong_type_arg_error + (sc, "autoload", 1, sym, + "a normal symbol (a keyword is never unbound)")); + + value = cadr(args); + if (is_string(value)) + return (s7_autoload + (sc, sym, + s7_immutable(make_string_with_length + (sc, string_value(value), + string_length(value))))); + if (((is_closure(value)) || (is_closure_star(value))) + && (s7_is_aritable(sc, value, 1))) + return (s7_autoload(sc, sym, value)); + + check_method(sc, value, sc->autoload_symbol, args); + return (s7_wrong_type_arg_error + (sc, "autoload", 2, value, "a string (file-name) or a thunk")); +} + + +/* -------------------------------- *autoload* -------------------------------- */ +static s7_pointer g_autoloader(s7_scheme * sc, s7_pointer args) +{ /* the *autoload* function */ +#define H_autoloader "(*autoload* sym) returns the autoload info for the symbol sym, or #f." +#define Q_autoloader s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol) + + s7_pointer sym = car(args); + if (!is_symbol(sym)) { + check_method(sc, sym, sc->autoloader_symbol, set_plist_1(sc, sym)); + return (s7_wrong_type_arg_error + (sc, "*autoload*", 1, sym, "a symbol")); + } + if (sc->autoload_names) { + const char *file; + bool loaded = false; + file = find_autoload_name(sc, sym, &loaded, false); + if (file) + return (s7_make_string(sc, file)); + } + if (is_hash_table(sc->autoload_table)) + return (s7_hash_table_ref(sc, sc->autoload_table, sym)); + return (sc->F); +} + + +/* ---------------- require ---------------- */ +static bool is_memq(s7_pointer sym, s7_pointer lst) +{ + s7_pointer x; + for (x = lst; is_pair(x); x = cdr(x)) + if (sym == car(x)) + return (true); + return (false); +} + +static s7_pointer g_require(s7_scheme * sc, s7_pointer args) +{ +#define H_require "(require symbol . symbols) loads each file associated with each symbol if it has not been loaded already.\ +The symbols refer to the argument to \"provide\". (require lint.scm)" + /* #define Q_require s7_make_circular_signature(sc, 1, 2, sc->T, sc->is_symbol_symbol) */ + + s7_pointer p; + s7_gc_protect_via_stack(sc, args); + for (p = args; is_pair(p); p = cdr(p)) { + s7_pointer sym; + if (is_symbol(car(p))) + sym = car(p); + else if ((is_proper_quote(sc, car(p))) && (is_symbol(cadar(p)))) + sym = cadar(p); + else + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "require: ~S is not a symbol", + 27), car(p)))); + + if ((!is_memq(sym, s7_symbol_value(sc, sc->features_symbol))) && + (sc->is_autoloading)) { + s7_pointer f; + f = g_autoloader(sc, set_plist_1(sc, sym)); + if (is_false(sc, f)) + return (s7_error + (sc, sc->autoload_error_symbol, + set_elist_2(sc, + wrap_string(sc, + "require: no autoload info for ~S", + 32), sym))); + if (hook_has_functions(sc->autoload_hook)) + s7_apply_function(sc, sc->autoload_hook, + set_plist_2(sc, sym, f)); + if (is_string(f)) + s7_load_with_environment(sc, string_value(f), sc->curlet); + else if (is_closure(f)) /* f should be a function of one argument, the current (calling) environment */ + s7_call(sc, f, set_ulist_1(sc, sc->curlet, sc->nil)); + } + } + unstack(sc); + return (sc->T); +} + + +/* ---------------- provided? ---------------- */ +static s7_pointer g_is_provided(s7_scheme * sc, s7_pointer args) +{ +#define H_is_provided "(provided? symbol) returns #t if symbol is a member of the *features* list" +#define Q_is_provided s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_symbol_symbol) + + s7_pointer sym = car(args), topf, x; + if (!is_symbol(sym)) + return (method_or_bust_one_arg_p + (sc, sym, sc->is_provided_symbol, T_SYMBOL)); + + /* here the *features* list is spread out (or can be anyway) along the curlet chain, + * so we need to travel back all the way to the top level checking each *features* list in turn. + * Since *features* grows via cons (newest first), we can stop the scan if we hit the shared + * top-level at least. + */ + topf = global_value(sc->features_symbol); + if (is_memq(sym, topf)) + return (sc->T); + + if (is_global(sc->features_symbol)) + return (sc->F); + for (x = sc->curlet; symbol_id(sc->features_symbol) < let_id(x); + x = let_outlet(x)); + for (; is_let(x); x = let_outlet(x)) { + s7_pointer y; + for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + if ((slot_symbol(y) == sc->features_symbol) && + (slot_value(y) != topf) && (is_memq(sym, slot_value(y)))) + return (sc->T); + } + return (sc->F); +} + +bool s7_is_provided(s7_scheme * sc, const char *feature) +{ + return (is_memq(make_symbol(sc, feature), s7_symbol_value(sc, sc->features_symbol))); /* this goes from local outward */ +} + +static bool is_provided_b_7p(s7_scheme * sc, s7_pointer sym) +{ + if (!is_symbol(sym)) + return (method_or_bust_one_arg_p + (sc, sym, sc->is_provided_symbol, T_SYMBOL) != sc->F); + return (is_memq(sym, s7_symbol_value(sc, sc->features_symbol))); +} + + +/* ---------------- provide ---------------- */ +static s7_pointer c_provide(s7_scheme * sc, s7_pointer sym) +{ + /* this has to be relative to the curlet: (load file env) + * the things loaded are only present in env, and go away with it, so should not be in the global *features* list + */ + s7_pointer p; + if (!is_symbol(sym)) + return (method_or_bust_one_arg_p + (sc, sym, sc->provide_symbol, T_SYMBOL)); + + if ((S7_DEBUGGING) && (sc->curlet == sc->rootlet)) + fprintf(stderr, "%s[%d]: curlet==rootlet!\n", __func__, __LINE__); + if ((sc->curlet == sc->nil) || (sc->curlet == sc->shadow_rootlet)) + p = global_slot(sc->features_symbol); + else + p = symbol_to_local_slot(sc, sc->features_symbol, sc->curlet); /* if sc->curlet is nil, this returns the global slot, else local slot */ + if ((is_slot(p)) && (is_immutable(p))) + s7_warn(sc, 256, "provide: *features* is immutable!\n"); + else { + s7_pointer lst; + lst = slot_value(lookup_slot_from(sc->features_symbol, sc->curlet)); /* in either case, we want the current *features* list */ + if (p == sc->undefined) + add_slot_checked_with_id(sc, sc->curlet, sc->features_symbol, + cons(sc, sym, lst)); + else if ((!is_memq(sym, lst)) && (!is_memq(sym, slot_value(p)))) + slot_set_value(p, cons(sc, sym, slot_value(p))); + } + return (sym); +} + +static s7_pointer g_provide(s7_scheme * sc, s7_pointer args) +{ +#define H_provide "(provide symbol) adds symbol to the *features* list" +#define Q_provide s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_symbol_symbol) + + if ((is_immutable(sc->curlet)) && (sc->curlet != sc->nil)) + s7_error(sc, sc->immutable_error_symbol, + set_elist_2(sc, + wrap_string(sc, + "can't provide '~S (current environment is immutable)", + 52), car(args))); + return (c_provide(sc, car(args))); +} + +void s7_provide(s7_scheme * sc, const char *feature) +{ + c_provide(sc, s7_make_symbol(sc, feature)); +} + + +static s7_pointer g_features_set(s7_scheme * sc, s7_pointer args) +{ /* *features* setter */ + s7_pointer p, nf = cadr(args); + if (is_null(nf)) + return (sc->nil); + if (!is_pair(nf)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, "can't set *features* to ~S", + 26), nf))); + if (s7_list_length(sc, nf) <= 0) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, "can't set *features* to ~S", + 26), nf))); + for (p = nf; is_pair(p); p = cdr(p)) + if (!is_symbol(car(p))) + return (simple_wrong_type_argument + (sc, sc->features_symbol, car(p), T_SYMBOL)); + return (nf); +} + +static s7_pointer g_libraries_set(s7_scheme * sc, s7_pointer args) +{ /* *libraries* setter */ + s7_pointer p, nf = cadr(args); + if (is_null(nf)) + return (sc->nil); + if (!is_pair(nf)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, "can't set *libraries* to ~S", + 27), nf))); + if (s7_list_length(sc, nf) <= 0) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, "can't set *libraries* to ~S", + 27), nf))); + for (p = nf; is_pair(p); p = cdr(p)) + if ((!is_pair(car(p))) || + (!is_string(caar(p))) || (!is_let(cdar(p)))) + return (simple_wrong_type_argument_with_type + (sc, sc->libraries_symbol, car(p), + wrap_string(sc, + "a list of conses of the form (string . let)", + 43))); + return (nf); +} + + +/* -------------------------------- eval-string -------------------------------- */ +s7_pointer s7_eval_c_string_with_environment(s7_scheme * sc, + const char *str, s7_pointer e) +{ + s7_pointer code, port, result; + TRACK(sc); + push_stack_direct(sc, OP_GC_PROTECT); /* not gc protection here, but restoration of original context */ + port = s7_open_input_string(sc, str); + code = s7_read(sc, port); + s7_close_input_port(sc, port); + result = s7_eval(sc, T_Pos(code), e); + pop_stack(sc); + return (result); +} + +s7_pointer s7_eval_c_string(s7_scheme * sc, const char *str) +{ + return (s7_eval_c_string_with_environment(sc, str, sc->nil)); +} + +static s7_pointer g_eval_string(s7_scheme * sc, s7_pointer args) +{ +#define H_eval_string "(eval-string str (let (curlet))) returns the result of evaluating the string str as Scheme code" +#define Q_eval_string s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol) + + s7_pointer port, str = car(args); + if (!is_string(str)) + return (method_or_bust + (sc, str, sc->eval_string_symbol, args, T_STRING, 1)); + + if (is_not_null(cdr(args))) { + s7_pointer e = cadr(args); + if (!is_let(e)) + return (wrong_type_argument_with_type + (sc, sc->eval_string_symbol, 2, e, a_let_string)); + set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); + } + sc->temp3 = sc->args; + push_stack(sc, OP_EVAL_STRING, args, sc->code); + port = open_and_protect_input_string(sc, str); + push_input_port(sc, port); + push_stack_op_let(sc, OP_READ_INTERNAL); + return (sc->F); /* I think this means that sc->value defaults to #f in op_eval_string below, so (eval-string "") mimics (eval) -> #f */ +} + +static s7_pointer eval_string_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + check_for_substring_temp(sc, expr); + return (f); +} + +static s7_pointer op_eval_string(s7_scheme * sc) +{ + while (s7_peek_char(sc, current_input_port(sc)) != eof_object) { /* (eval-string "(+ 1 2) this is a mistake") */ + int32_t tk; + tk = token(sc); /* (eval-string "(+ 1 2) ; a comment (not a mistake)") */ + if (tk != TOKEN_EOF) { + s7_int trail_len; + s7_pointer trail_data; + trail_len = + port_data_size(current_input_port(sc)) - + port_position(current_input_port(sc)) + 1; + if (trail_len > 32) + trail_len = 32; + trail_data = + make_string_with_length(sc, + (const char + *) (port_data(current_input_port + (sc)) + + port_position + (current_input_port(sc)) - 1), + trail_len); + s7_close_input_port(sc, current_input_port(sc)); + pop_input_port(sc); + s7_error(sc, sc->read_error_symbol, + set_elist_2(sc, + wrap_string(sc, + "eval-string trailing junk: ~S", + 29), trail_data)); + } + } + s7_close_input_port(sc, current_input_port(sc)); + pop_input_port(sc); + sc->code = sc->value; + set_current_code(sc, sc->code); + return (NULL); +} + + +/* -------------------------------- call-with-input-string -------------------------------- */ +static s7_pointer call_with_input(s7_scheme * sc, s7_pointer port, + s7_pointer args) +{ + s7_pointer p = cadr(args); + port_original_input_string(port) = car(args); + push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); /* # here is a marker (needed) */ + push_stack(sc, OP_APPLY, list_1(sc, port), p); + return (sc->F); +} + +static s7_pointer g_call_with_input_string(s7_scheme * sc, s7_pointer args) +{ +#define H_call_with_input_string "(call-with-input-string str proc) opens a string port for str and applies proc to it" +#define Q_call_with_input_string sc->pl_sf + /* (call-with-input-string "44" (lambda (p) (+ 1 (read p)))) -> 45 */ + + s7_pointer str = car(args), proc; + if (!is_string(str)) + return (method_or_bust + (sc, str, sc->call_with_input_string_symbol, args, + T_STRING, 1)); + + proc = cadr(args); + if (is_let(proc)) + check_method(sc, proc, sc->call_with_input_string_symbol, args); + + if (!s7_is_aritable(sc, proc, 1)) + return (wrong_type_argument_with_type + (sc, sc->call_with_input_string_symbol, 2, proc, + wrap_string(sc, "a procedure of one argument (the port)", + 38))); + if ((is_continuation(proc)) || (is_goto(proc))) + return (wrong_type_argument_with_type + (sc, sc->call_with_input_string_symbol, 2, proc, + a_normal_procedure_string)); + return (call_with_input + (sc, open_and_protect_input_string(sc, str), args)); +} + + +/* -------------------------------- call-with-input-file -------------------------------- */ +static s7_pointer g_call_with_input_file(s7_scheme * sc, s7_pointer args) +{ +#define H_call_with_input_file "(call-with-input-file filename proc) opens filename and calls proc with the input port as its argument" +#define Q_call_with_input_file sc->pl_sf + + s7_pointer str = car(args), proc; + if (!is_string(str)) + return (method_or_bust + (sc, str, sc->call_with_input_file_symbol, args, T_STRING, + 1)); + + proc = cadr(args); + if (!s7_is_aritable(sc, proc, 1)) + return (wrong_type_argument_with_type + (sc, sc->call_with_input_file_symbol, 2, proc, + wrap_string(sc, "a procedure of one argument (the port)", + 38))); + if ((is_continuation(proc)) || (is_goto(proc))) + return (wrong_type_argument_with_type + (sc, sc->call_with_input_file_symbol, 2, proc, + a_normal_procedure_string)); + return (call_with_input + (sc, + open_input_file_1(sc, string_value(str), "r", + "call-with-input-file"), args)); +} + + +/* -------------------------------- with-input-from-string -------------------------------- */ +static s7_pointer with_input(s7_scheme * sc, s7_pointer port, + s7_pointer args) +{ + s7_pointer p, old_input_port = current_input_port(sc); + set_current_input_port(sc, port); + port_original_input_string(port) = car(args); + push_stack(sc, OP_UNWIND_INPUT, old_input_port, port); + p = cadr(args); + push_stack(sc, OP_APPLY, sc->nil, p); + return (sc->F); +} + +static s7_pointer g_with_input_from_string(s7_scheme * sc, s7_pointer args) +{ +#define H_with_input_from_string "(with-input-from-string str thunk) opens str as the temporary current-input-port and calls thunk" +#define Q_with_input_from_string sc->pl_sf + + s7_pointer str = car(args); + if (!is_string(str)) + return (method_or_bust + (sc, str, sc->with_input_from_string_symbol, args, + T_STRING, 1)); + + if (cadr(args) == global_value(sc->read_symbol)) { + if (string_length(str) == 0) + return (eof_object); + push_input_port(sc, current_input_port(sc)); + set_current_input_port(sc, open_and_protect_input_string(sc, str)); + port_original_input_string(current_input_port(sc)) = str; + push_stack(sc, OP_UNWIND_INPUT, sc->unused, + current_input_port(sc)); + push_stack_op_let(sc, OP_READ_DONE); + push_stack_op_let(sc, OP_READ_INTERNAL); + return (current_input_port(sc)); + } + + if (!is_thunk(sc, cadr(args))) + return (method_or_bust_with_type + (sc, cadr(args), sc->with_input_from_string_symbol, args, + a_thunk_string, 2)); + + /* since the arguments are evaluated before we get here, we can get some confusing situations: + * (with-input-from-string "#x2.1" (read)) + * (read) -> whatever it can get from the current input port! + * ";with-input-from-string argument 2, #, is untyped but should be a thunk" + * (with-input-from-string "" (read-line)) -> hangs awaiting stdin input + */ + return (with_input(sc, open_and_protect_input_string(sc, str), args)); +} + + +/* -------------------------------- with-input-from-file -------------------------------- */ +static s7_pointer g_with_input_from_file(s7_scheme * sc, s7_pointer args) +{ +#define H_with_input_from_file "(with-input-from-file filename thunk) opens filename as the temporary current-input-port and calls thunk" +#define Q_with_input_from_file sc->pl_sf + + if (!is_string(car(args))) + return (method_or_bust + (sc, car(args), sc->with_input_from_file_symbol, args, + T_STRING, 1)); + if (!is_thunk(sc, cadr(args))) + return (method_or_bust_with_type + (sc, cadr(args), sc->with_input_from_file_symbol, args, + a_thunk_string, 2)); + return (with_input + (sc, + open_input_file_1(sc, string_value(car(args)), "r", + "with-input-from-file"), args)); +} + +static s7_pointer with_string_in(s7_scheme * sc, s7_pointer args) +{ + s7_pointer old_port = current_input_port(sc); + set_current_input_port(sc, + open_and_protect_input_string(sc, sc->value)); + push_stack(sc, OP_UNWIND_INPUT, old_port, current_input_port(sc)); + sc->curlet = make_let(sc, sc->curlet); + return (opt2_pair(sc->code)); +} + +static s7_pointer with_file_in(s7_scheme * sc, s7_pointer args) +{ + s7_pointer old_port = current_input_port(sc); + set_current_input_port(sc, + open_input_file_1(sc, string_value(sc->value), + "r", "with-input-from-file")); + push_stack(sc, OP_UNWIND_INPUT, old_port, current_input_port(sc)); + sc->curlet = make_let(sc, sc->curlet); + return (opt2_pair(sc->code)); +} + +static s7_pointer with_file_out(s7_scheme * sc, s7_pointer args) +{ + s7_pointer old_port = current_output_port(sc); + set_current_output_port(sc, + s7_open_output_file(sc, + string_value(sc->value), + "w")); + push_stack(sc, OP_UNWIND_OUTPUT, old_port, current_output_port(sc)); + sc->curlet = make_let(sc, sc->curlet); + return (opt2_pair(sc->code)); +} + +static s7_pointer call_string_in(s7_scheme * sc, s7_pointer args) +{ + s7_pointer port; + port = open_and_protect_input_string(sc, sc->value); + push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); + sc->curlet = + make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); + return (opt2_pair(sc->code)); +} + +static s7_pointer call_file_in(s7_scheme * sc, s7_pointer args) +{ + s7_pointer port; + port = + open_input_file_1(sc, string_value(sc->value), "r", + "with-input-from-file"); + push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); + sc->curlet = + make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); + return (opt2_pair(sc->code)); +} + +static s7_pointer call_file_out(s7_scheme * sc, s7_pointer args) +{ + s7_pointer port; + port = s7_open_output_file(sc, string_value(sc->value), "w"); + push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); + sc->curlet = + make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); + return (opt2_pair(sc->code)); +} + +#define op_with_io_1(Sc) (((s7_function)((Sc->code)->object.cons.opt1))(Sc, Sc->nil)) + +static s7_pointer op_lambda(s7_scheme * sc, s7_pointer code); + +static void op_with_io_1_method(s7_scheme * sc) +{ + s7_pointer lt = sc->value; + if (has_active_methods(sc, lt)) { + s7_pointer method = car(sc->code); + if (is_c_function(method)) /* #_call-with-input-string et al */ + method = make_symbol(sc, c_function_name(method)); + push_stack(sc, OP_GC_PROTECT, lt, sc->code); + sc->code = caddr(sc->code); + sc->value = op_lambda(sc, sc->code); /* don't unstack */ + sc->value = + find_and_apply_method(sc, lt, method, + list_2(sc, lt, sc->value)); + } else if (is_symbol(car(sc->code))) /* might be e.g. #_call-with-input-string so use c_function_name */ + wrong_type_argument(sc, car(sc->code), 1, lt, T_STRING); + else + wrong_type_arg_error_prepackaged(sc, + wrap_string(sc, + c_function_name(car + (sc->code)), + strlen(c_function_name + (car + (sc->code)))), + int_one, lt, sc->unused, + sc->prepackaged_type_names + [T_STRING]); +} + +static bool op_with_io_op(s7_scheme * sc) +{ + sc->value = cadr(sc->code); + if (is_string(sc->value)) { + sc->code = op_with_io_1(sc); + return (false); + } + push_stack_no_args(sc, OP_WITH_IO_1, sc->code); + sc->code = sc->value; + return (true); +} + +static void op_with_output_to_string(s7_scheme * sc) +{ + s7_pointer old_port = current_output_port(sc); + set_current_output_port(sc, s7_open_output_string(sc)); + push_stack(sc, OP_UNWIND_OUTPUT, old_port, current_output_port(sc)); + sc->curlet = make_let(sc, sc->curlet); + push_stack(sc, OP_GET_OUTPUT_STRING, old_port, + current_output_port(sc)); + sc->code = opt2_pair(sc->code); +} + +static void op_call_with_output_string(s7_scheme * sc) +{ + s7_pointer port; + port = s7_open_output_string(sc); + push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); + sc->curlet = + make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); + push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port); + sc->code = opt2_pair(sc->code); +} + + +/* -------------------------------- iterators -------------------------------- */ + +#if S7_DEBUGGING +static s7_pointer titr_let(s7_scheme * sc, s7_pointer p, const char *func, + int32_t line) +{ + if (!is_let(iterator_sequence(p))) { + fprintf(stderr, "%s%s[%d]: let iterator sequence is %s%s\n", + BOLD_TEXT, func, line, check_name(sc, + unchecked_type + (iterator_sequence(p))), + UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + return (p); +} + +static s7_pointer titr_pair(s7_scheme * sc, s7_pointer p, const char *func, + int32_t line) +{ + if (!is_pair(iterator_sequence(p))) { + fprintf(stderr, "%s%s[%d]: pair iterator sequence is %s%s\n", + BOLD_TEXT, func, line, check_name(sc, + unchecked_type + (iterator_sequence(p))), + UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + return (p); +} + +static s7_pointer titr_hash(s7_scheme * sc, s7_pointer p, const char *func, + int32_t line) +{ + if (!is_hash_table(iterator_sequence(p))) { + fprintf(stderr, "%s%s[%d]: hash iterator sequence is %s%s\n", + BOLD_TEXT, func, line, check_name(sc, + unchecked_type + (iterator_sequence(p))), + UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + return (p); +} + +static s7_pointer titr_len(s7_scheme * sc, s7_pointer p, const char *func, + int32_t line) +{ + if ((is_hash_table(iterator_sequence(p))) + || (is_pair(iterator_sequence(p)))) { + fprintf(stderr, "%s%s[%d]: iterator length sequence is %s%s\n", + BOLD_TEXT, func, line, check_name(sc, + unchecked_type + (iterator_sequence(p))), + UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + return (p); +} + +static s7_pointer titr_pos(s7_scheme * sc, s7_pointer p, const char *func, + int32_t line) +{ + if (((is_let(iterator_sequence(p))) + && (iterator_sequence(p) != sc->rootlet) + && (iterator_sequence(p) != sc->s7_let)) + || (is_pair(iterator_sequence(p)))) { + fprintf(stderr, "%s%s[%d]: iterator-position sequence is %s%s\n", + BOLD_TEXT, func, line, check_name(sc, + unchecked_type + (iterator_sequence(p))), + UNBOLD_TEXT); + if (sc->stop_at_error) + abort(); + } + return (p); +} +#endif + + +/* -------------------------------- iterator? -------------------------------- */ +static s7_pointer g_is_iterator(s7_scheme * sc, s7_pointer args) +{ +#define H_is_iterator "(iterator? obj) returns #t if obj is an iterator." +#define Q_is_iterator sc->pl_bt + + s7_pointer x = car(args); + if (is_iterator(x)) + return (sc->T); + /* closure itself is not an iterator: (let ((c1 (let ((+iterator+ #t) (a 0)) (lambda () (set! a (+ a 1)))))) (iterate c1)): error (a function not an iterator) */ + check_boolean_method(sc, is_iterator, sc->is_iterator_symbol, args); + return (sc->F); +} + +bool s7_is_iterator(s7_pointer obj) +{ + return (is_iterator(obj)); +} + +static bool is_iterator_b_7p(s7_scheme * sc, s7_pointer obj) +{ + return (g_is_iterator(sc, set_plist_1(sc, obj)) != sc->F); +} + + +static s7_pointer iterator_copy(s7_scheme * sc, s7_pointer p) +{ + /* fields are obj cur [loc|lcur] [len|slow|hcur] next, but untangling them in debugging case is a pain */ + s7_pointer iter; + new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE); + memcpy((void *) iter, (void *) p, sizeof(s7_cell)); + return (iter); +} + +static s7_pointer iterator_finished(s7_scheme * sc, s7_pointer iterator) +{ + return (ITERATOR_END); +} + +static s7_pointer iterator_quit(s7_pointer iterator) +{ + iterator_next(iterator) = iterator_finished; + clear_iter_ok(iterator); + return (ITERATOR_END); +} + +static s7_pointer let_iterate(s7_scheme * sc, s7_pointer iterator) +{ + s7_pointer p, slot = iterator_current_slot(iterator); + if (!tis_slot(slot)) + return (iterator_quit(iterator)); + iterator_set_current_slot(iterator, next_slot(slot)); + if (!iterator_let_cons(iterator)) + return (cons(sc, slot_symbol(slot), slot_value(slot))); + p = iterator_let_cons(iterator); + set_car(p, slot_symbol(slot)); + set_cdr(p, slot_value(slot)); + return (p); +} + +static s7_pointer rootlet_iterate(s7_scheme * sc, s7_pointer iterator) +{ + s7_pointer slot = iterator_current(iterator); + if (!is_slot(slot)) + return (iterator_quit(iterator)); + if (iterator_position(iterator) < sc->rootlet_entries) { + iterator_position(iterator)++; + iterator_current(iterator) = + rootlet_element(sc->rootlet, iterator_position(iterator)); + } else + iterator_current(iterator) = sc->nil; + return (cons(sc, slot_symbol(slot), slot_value(slot))); +} + +static s7_pointer hash_entry_to_cons(s7_scheme * sc, hash_entry_t * entry, + s7_pointer p) +{ + if (!p) + return (cons(sc, hash_entry_key(entry), hash_entry_value(entry))); + set_car(p, hash_entry_key(entry)); + set_cdr(p, hash_entry_value(entry)); + return (p); +} + +static s7_pointer hash_table_iterate(s7_scheme * sc, s7_pointer iterator) +{ + s7_pointer table; + s7_int loc, len; + hash_entry_t **elements; + hash_entry_t *lst; + + lst = iterator_hash_current(iterator); + if (lst) { + iterator_hash_current(iterator) = hash_entry_next(lst); + return (hash_entry_to_cons(sc, lst, iterator_current(iterator))); + } + table = iterator_sequence(iterator); /* using iterator_length and hash_table_entries here was slightly slower */ + len = hash_table_mask(table) + 1; + elements = hash_table_elements(table); + + for (loc = iterator_position(iterator) + 1; loc < len; loc++) { + hash_entry_t *x = elements[loc]; + if (x) { + iterator_position(iterator) = loc; + iterator_hash_current(iterator) = hash_entry_next(x); + return (hash_entry_to_cons(sc, x, iterator_current(iterator))); + } + } + if (is_weak_hash_table(table)) { + clear_weak_hash_iterator(iterator); + weak_hash_iters(table)--; + } + return (iterator_quit(iterator)); +} + +static s7_pointer string_iterate(s7_scheme * sc, s7_pointer obj) +{ + if (iterator_position(obj) < iterator_length(obj)) + return (chars[(uint8_t) + (string_value(iterator_sequence(obj)) + [iterator_position(obj)++])]); + return (iterator_quit(obj)); +} + +static s7_pointer byte_vector_iterate(s7_scheme * sc, s7_pointer obj) +{ + if (iterator_position(obj) < iterator_length(obj)) + return (small_int + (byte_vector + (iterator_sequence(obj), iterator_position(obj)++))); + return (iterator_quit(obj)); +} + +static s7_pointer float_vector_iterate(s7_scheme * sc, s7_pointer obj) +{ + if (iterator_position(obj) < iterator_length(obj)) + return (make_real + (sc, + float_vector(iterator_sequence(obj), + iterator_position(obj)++))); + return (iterator_quit(obj)); +} + +static s7_pointer int_vector_iterate(s7_scheme * sc, s7_pointer obj) +{ + if (iterator_position(obj) < iterator_length(obj)) + return (make_integer + (sc, + int_vector(iterator_sequence(obj), + iterator_position(obj)++))); + return (iterator_quit(obj)); +} + +static s7_pointer vector_iterate(s7_scheme * sc, s7_pointer obj) +{ + if (iterator_position(obj) < iterator_length(obj)) + return (vector_element + (iterator_sequence(obj), iterator_position(obj)++)); + return (iterator_quit(obj)); +} + +static s7_pointer closure_iterate(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer result; + result = s7_call(sc, iterator_sequence(obj), sc->nil); + /* this can't use s7_apply_function -- we need to catch the error handler's longjmp here */ + if (result == ITERATOR_END) { + iterator_next(obj) = iterator_finished; + clear_iter_ok(obj); + } + return (result); +} + +static s7_pointer c_object_iterate(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer result, p, cur; + if (iterator_position(obj) >= iterator_length(obj)) + return (iterator_quit(obj)); + p = iterator_sequence(obj); + cur = iterator_current(obj); + set_car(sc->z2_1, sc->x); + set_car(sc->z2_2, sc->z); /* is this necessary? (save/restore sc->x/y across c_object iteration) */ + set_car(cur, p); + set_car(cdr(cur), make_integer(sc, iterator_position(obj))); + result = (*(c_object_ref(sc, p))) (sc, cur); + sc->x = car(sc->z2_1); + sc->z = car(sc->z2_2); + iterator_position(obj)++; + if (result == ITERATOR_END) { + iterator_next(obj) = iterator_finished; + clear_iter_ok(obj); + } + return (result); +} + +static s7_pointer pair_iterate_1(s7_scheme * sc, s7_pointer obj); +static s7_pointer pair_iterate(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer result; + if (!is_pair(iterator_current(obj))) + return (iterator_quit(obj)); + result = car(iterator_current(obj)); + iterator_current(obj) = cdr(iterator_current(obj)); + if (iterator_current(obj) == iterator_slow(obj)) + iterator_current(obj) = sc->nil; + iterator_next(obj) = pair_iterate_1; + return (result); +} + +static s7_pointer pair_iterate_1(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer result; + if (!is_pair(iterator_current(obj))) + return (iterator_quit(obj)); + result = car(iterator_current(obj)); + iterator_current(obj) = cdr(iterator_current(obj)); + if (iterator_current(obj) == iterator_slow(obj)) + iterator_current(obj) = sc->nil; + else + iterator_set_slow(obj, cdr(iterator_slow(obj))); + iterator_next(obj) = pair_iterate; + return (result); +} + +static s7_pointer find_make_iterator_method(s7_scheme * sc, s7_pointer e) +{ + s7_pointer func; + if ((has_active_methods(sc, e)) && + ((func = + find_method_with_let(sc, e, + sc->make_iterator_symbol)) != + sc->undefined)) { + s7_pointer it; + it = call_method(sc, e, func, set_plist_1(sc, e)); + if (!is_iterator(it)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "make-iterator method must return an iterator: ~S", + 48), it))); + return (it); + } + return (NULL); +} + + +/* -------------------------------- make-iterator -------------------------------- */ +static s7_pointer funclet_entry(s7_scheme * sc, s7_pointer x, + s7_pointer sym) +{ + if ((has_closure_let(x)) && (is_let(closure_let(x)))) { + s7_pointer val; + val = symbol_to_local_slot(sc, sym, closure_let(x)); + if ((!is_slot(val)) && (is_let(let_outlet(closure_let(x))))) + val = + symbol_to_local_slot(sc, sym, let_outlet(closure_let(x))); + if (is_slot(val)) + return (slot_value(val)); + } + return (NULL); +} + +static bool is_iterable_closure(s7_scheme * sc, s7_pointer x) +{ + s7_pointer iter; + if (!is_thunk(sc, x)) + wrong_type_argument_with_type(sc, sc->make_iterator_symbol, 1, x, + a_thunk_string); + iter = funclet_entry(sc, x, sc->local_iterator_symbol); + return ((iter) && (iter != sc->F)); +} + +static s7_pointer s7_let_make_iterator(s7_scheme * sc, s7_pointer iter); +static s7_int c_object_length_to_int(s7_scheme * sc, s7_pointer obj); + +s7_pointer s7_make_iterator(s7_scheme * sc, s7_pointer e) +{ + s7_pointer iter, p; + new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE | T_ITER_OK); + iterator_sequence(iter) = e; + + if (is_pair(e)) { /* by far the most common case */ + iterator_current(iter) = e; + iterator_next(iter) = pair_iterate; + iterator_set_slow(iter, e); + return (iter); + } + if (!is_let(e)) + iterator_position(iter) = 0; + + switch (type(e)) { + case T_LET: + if (e == sc->rootlet) { + iterator_current(iter) = rootlet_element(e, 0); /* unfortunately tricky -- let_iterate uses different fields */ + iterator_position(iter) = 0; + iterator_next(iter) = rootlet_iterate; + return (iter); + } + if (e == sc->s7_let) + return (s7_let_make_iterator(sc, iter)); + sc->temp6 = iter; + p = find_make_iterator_method(sc, e); + sc->temp6 = sc->nil; + if (p) { + free_cell(sc, iter); + return (p); + } + iterator_set_current_slot(iter, let_slots(e)); + iterator_next(iter) = let_iterate; + iterator_let_cons(iter) = NULL; + break; + + case T_HASH_TABLE: + iterator_hash_current(iter) = NULL; + iterator_current(iter) = NULL; + iterator_position(iter) = -1; + iterator_next(iter) = hash_table_iterate; + if (is_weak_hash_table(e)) { + set_weak_hash_iterator(iter); + weak_hash_iters(e)++; + add_weak_hash_iterator(sc, iter); + } + break; + + case T_STRING: + iterator_length(iter) = string_length(e); + iterator_next(iter) = string_iterate; + break; + + case T_BYTE_VECTOR: + iterator_length(iter) = byte_vector_length(e); + iterator_next(iter) = byte_vector_iterate; + break; + + case T_VECTOR: + iterator_length(iter) = vector_length(e); + iterator_next(iter) = vector_iterate; + break; + + case T_INT_VECTOR: + iterator_length(iter) = vector_length(e); + iterator_next(iter) = int_vector_iterate; + break; + + case T_FLOAT_VECTOR: + iterator_length(iter) = vector_length(e); + iterator_next(iter) = float_vector_iterate; + break; + + case T_NIL: /* (make-iterator #()) -> #, so I guess () should also work */ + iterator_length(iter) = 0; + iterator_next(iter) = iterator_finished; + clear_iter_ok(iter); + break; + + case T_MACRO: + case T_MACRO_STAR: + case T_BACRO: + case T_BACRO_STAR: + case T_CLOSURE: + case T_CLOSURE_STAR: + if (is_iterable_closure(sc, e)) { + p = list_1_unchecked(sc, int_zero); + iterator_current(iter) = p; + set_mark_seq(iter); + iterator_next(iter) = closure_iterate; + iterator_length(iter) = + (has_active_methods(sc, e)) ? closure_length(sc, + e) : + S7_INT64_MAX; + } else { + free_cell(sc, iter); + return (simple_wrong_type_argument_with_type + (sc, sc->make_iterator_symbol, e, + wrap_string(sc, + "a function or macro with a '+iterator+ local that is not #f", + 59))); + } + break; + + case T_C_OBJECT: + iterator_length(iter) = c_object_length_to_int(sc, e); + sc->temp6 = iter; + p = find_make_iterator_method(sc, e); + sc->temp6 = sc->nil; + if (p) { + free_cell(sc, iter); + return (p); + } + iterator_current(iter) = list_2(sc, e, int_zero); + set_mark_seq(iter); + iterator_next(iter) = c_object_iterate; + break; + + default: + return (simple_wrong_type_argument_with_type + (sc, sc->make_iterator_symbol, e, a_sequence_string)); + } + return (iter); +} + +static s7_pointer g_make_iterator(s7_scheme * sc, s7_pointer args) +{ +#define H_make_iterator "(make-iterator sequence carrier) returns an iterator object that returns the next value \ +in the sequence each time it is called. When it reaches the end, it returns " ITERATOR_END_NAME "." +#define Q_make_iterator s7_make_signature(sc, 3, sc->is_iterator_symbol, sc->is_sequence_symbol, sc->is_pair_symbol) + + s7_pointer iter, seq = car(args), carrier; + /* we need to call s7_make_iterator before fixing up the optional second arg in case let->method */ + + carrier = (is_pair(cdr(args))) ? cadr(args) : NULL; + iter = s7_make_iterator(sc, seq); + + if (carrier) { + if (!is_pair(carrier)) + return (simple_wrong_type_argument + (sc, sc->make_iterator_symbol, carrier, T_PAIR)); + if (is_immutable_pair(carrier)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->make_iterator_symbol, carrier))); + + if (is_hash_table(iterator_sequence(iter))) { + iterator_current(iter) = carrier; + set_mark_seq(iter); + } else + if ((is_let(iterator_sequence(iter))) && + (iterator_sequence(iter) != sc->rootlet)) { + iterator_let_cons(iter) = carrier; + set_mark_seq(iter); + } + } + return (iter); +} + + +/* -------------------------------- iterate -------------------------------- */ +static s7_pointer g_iterate(s7_scheme * sc, s7_pointer args) +{ +#define H_iterate "(iterate obj) returns the next element from the iterator obj, or " ITERATOR_END_NAME "." +#define Q_iterate s7_make_signature(sc, 2, sc->T, sc->is_iterator_symbol) + s7_pointer iter = car(args); + if (!is_iterator(iter)) + return (method_or_bust_one_arg + (sc, iter, sc->iterate_symbol, args, T_ITERATOR)); + return ((iterator_next(iter)) (sc, iter)); +} + +static s7_pointer iterate_p_p(s7_scheme * sc, s7_pointer iter) +{ + if (!is_iterator(iter)) + return (method_or_bust_one_arg_p + (sc, iter, sc->iterate_symbol, T_ITERATOR)); + return ((iterator_next(iter)) (sc, iter)); +} + +s7_pointer s7_iterate(s7_scheme * sc, s7_pointer obj) +{ + return ((iterator_next(obj)) (sc, obj)); +} + +bool s7_iterator_is_at_end(s7_scheme * sc, s7_pointer obj) +{ + if (!is_iterator(obj)) + simple_wrong_type_argument(sc, sc->iterator_is_at_end_symbol, obj, + T_ITERATOR); + return (!iter_ok(obj)); +} + +static bool op_implicit_iterate(s7_scheme * sc) +{ + s7_pointer s; + s = lookup_checked(sc, car(sc->code)); + if (!is_iterator(s)) { + sc->last_function = s; + return (false); + } + sc->value = (iterator_next(s)) (sc, s); + return (true); +} + + +/* -------------------------------- iterator-at-end? -------------------------------- */ +static bool iterator_is_at_end_b_7p(s7_scheme * sc, s7_pointer obj) +{ + if (!is_iterator(obj)) + simple_wrong_type_argument(sc, sc->iterator_is_at_end_symbol, obj, + T_ITERATOR); + return (!iter_ok(obj)); +} + +static s7_pointer g_iterator_is_at_end(s7_scheme * sc, s7_pointer args) +{ +#define H_iterator_is_at_end "(iterator-at-end? iter) returns #t if the iterator has reached the end of its sequence." +#define Q_iterator_is_at_end s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_iterator_symbol) + s7_pointer iter = car(args); + if (!is_iterator(iter)) + return (method_or_bust_one_arg + (sc, iter, sc->iterator_is_at_end_symbol, args, + T_ITERATOR)); + return (make_boolean(sc, !iter_ok(iter))); +} + + +/* -------------------------------- iterator-sequence -------------------------------- */ +static s7_pointer g_iterator_sequence(s7_scheme * sc, s7_pointer args) +{ +#define H_iterator_sequence "(iterator-sequence iterator) returns the sequence that iterator is traversing." +#define Q_iterator_sequence s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_iterator_symbol) + s7_pointer iter = car(args); + if (!is_iterator(iter)) + return (method_or_bust_one_arg + (sc, iter, sc->iterator_sequence_symbol, args, + T_ITERATOR)); + return (iterator_sequence(iter)); +} + + +/* -------- cycles -------- */ + +#define INITIAL_SHARED_INFO_SIZE 8 + +static int32_t shared_ref(shared_info_t * ci, s7_pointer p) +{ + /* from print after collecting refs, not called by equality check, only called in object_to_port_with_circle_check_1 */ + int32_t i; + s7_pointer *objs = ci->objs; + for (i = 0; i < ci->top; i++) + if (objs[i] == p) { + int32_t val = ci->refs[i]; + if (val > 0) + ci->refs[i] = -ci->refs[i]; + return (val); + } + return (0); +} + +static void flip_ref(shared_info_t * ci, s7_pointer p) +{ + int32_t i; + s7_pointer *objs = ci->objs; + + for (i = 0; i < ci->top; i++) + if (objs[i] == p) { + ci->refs[i] = -ci->refs[i]; + break; + } +} + +static int32_t peek_shared_ref_1(shared_info_t * ci, s7_pointer p) +{ + /* returns 0 if not found, otherwise the ref value for p */ + int32_t i; + s7_pointer *objs = ci->objs; + for (i = 0; i < ci->top; i++) + if (objs[i] == p) + return (ci->refs[i]); + return (0); +} + +static int32_t peek_shared_ref(shared_info_t * ci, s7_pointer p) +{ + /* returns 0 if not found, otherwise the ref value for p */ + return ((is_collected_unchecked(p)) ? peek_shared_ref_1(ci, p) : 0); +} + +static void enlarge_shared_info(shared_info_t * ci) +{ + int32_t i; + ci->size *= 2; + ci->size2 = ci->size - 2; + ci->objs = + (s7_pointer *) Realloc(ci->objs, ci->size * sizeof(s7_pointer)); + ci->refs = (int32_t *) Realloc(ci->refs, ci->size * sizeof(int32_t)); + ci->defined = (bool *) Realloc(ci->defined, ci->size * sizeof(bool)); + /* this clearing is needed */ + for (i = ci->top; i < ci->size; i++) { + ci->refs[i] = 0; + ci->objs[i] = NULL; + } +} + +static bool collect_shared_info(s7_scheme * sc, shared_info_t * ci, + s7_pointer top, bool stop_at_print_length); +static hash_entry_t *hash_equal(s7_scheme * sc, s7_pointer table, + s7_pointer key); +static hash_entry_t *hash_equivalent(s7_scheme * sc, s7_pointer table, + s7_pointer key); + +static bool check_collected(s7_pointer top, shared_info_t * ci) +{ + s7_pointer *p, *objs_end; + int32_t i; + + objs_end = (s7_pointer *) (ci->objs + ci->top); + for (p = ci->objs; p < objs_end; p++) + if ((*p) == top) { + i = (int32_t) (p - ci->objs); + if (ci->refs[i] == 0) { + ci->has_hits = true; + ci->refs[i] = ++ci->ref; /* if found, set the ref number */ + } + break; + } + set_cyclic(top); + return (true); +} + +static bool collect_vector_info(s7_scheme * sc, shared_info_t * ci, + s7_pointer top, bool stop_at_print_length) +{ + s7_int i, plen; + bool cyclic = false; + + if (stop_at_print_length) { + plen = sc->print_length; + if (plen > vector_length(top)) + plen = vector_length(top); + } else + plen = vector_length(top); + + for (i = 0; i < plen; i++) { + s7_pointer vel = unchecked_vector_element(top, i); /* "unchecked" because top might be rootlet, I think */ + if ((has_structure(vel)) && + (collect_shared_info(sc, ci, vel, stop_at_print_length))) { + set_cyclic(vel); + cyclic = true; + if ((is_c_pointer(vel)) || + (is_iterator(vel)) || (is_c_object(vel))) + check_collected(top, ci); + } + } + if (cyclic) + set_cyclic(top); + return (cyclic); +} + +static bool collect_shared_info(s7_scheme * sc, shared_info_t * ci, + s7_pointer top, bool stop_at_print_length) +{ + /* look for top in current list. + * As we collect objects (guaranteed to have structure) we set the collected bit. If we ever + * encounter an object with that bit on, we've seen it before so we have a possible cycle. + * Once the collection pass is done, we run through our list, and clear all these bits. + */ + bool top_cyclic; + + if (is_collected_or_shared(top)) + return ((!is_shared(top)) && (check_collected(top, ci))); + + /* top not seen before -- add it to the list */ + set_collected(top); + + if (ci->top == ci->size) + enlarge_shared_info(ci); + ci->objs[ci->top++] = top; + + top_cyclic = false; + /* now search the rest of this structure */ + if (is_pair(top)) { + s7_pointer p, cp; + if ((has_structure(car(top))) && + (collect_shared_info(sc, ci, car(top), stop_at_print_length))) + top_cyclic = true; + + for (p = cdr(top); is_pair(p); p = cdr(p)) { + if (is_collected_or_shared(p)) { + set_cyclic(top); + set_cyclic(p); + if (!is_shared(p)) + return (check_collected(p, ci)); + if (!top_cyclic) + for (cp = top; cp != p; cp = cdr(cp)) + set_shared(cp); + return (top_cyclic); + } + set_collected(p); + if (ci->top == ci->size) + enlarge_shared_info(ci); + ci->objs[ci->top++] = p; + if ((has_structure(car(p))) && + (collect_shared_info + (sc, ci, car(p), stop_at_print_length))) + top_cyclic = true; + } + if ((has_structure(p)) && + (collect_shared_info(sc, ci, p, stop_at_print_length))) { + set_cyclic(top); + return (true); + } + if (!top_cyclic) + for (cp = top; is_pair(cp); cp = cdr(cp)) + set_shared(cp); + else + set_cyclic(top); + return (top_cyclic); + } + + switch (type(top)) { + case T_VECTOR: + if (collect_vector_info(sc, ci, top, stop_at_print_length)) + top_cyclic = true; + break; + + case T_ITERATOR: + if ((is_sequence(iterator_sequence(top))) && /* might be a function with +iterator+ local */ + (collect_shared_info + (sc, ci, iterator_sequence(top), stop_at_print_length))) { + if (peek_shared_ref(ci, iterator_sequence(top)) == 0) + check_collected(iterator_sequence(top), ci); + top_cyclic = true; + } + break; + + case T_HASH_TABLE: + if (hash_table_entries(top) > 0) { + s7_int i, len = hash_table_mask(top) + 1; + hash_entry_t **entries = hash_table_elements(top); + bool keys_safe; + + keys_safe = ((hash_table_checker(top) != hash_equal) && + (hash_table_checker(top) != hash_equivalent) && + (!hash_table_checker_locked(top))); + for (i = 0; i < len; i++) { + hash_entry_t *p; + for (p = entries[i]; p; p = hash_entry_next(p)) { + if ((!keys_safe) && + (has_structure(hash_entry_key(p))) && + (collect_shared_info + (sc, ci, hash_entry_key(p), + stop_at_print_length))) + top_cyclic = true; + if ((has_structure(hash_entry_value(p))) && + (collect_shared_info + (sc, ci, hash_entry_value(p), + stop_at_print_length))) { + if ((is_c_pointer(hash_entry_value(p))) + || (is_iterator(hash_entry_value(p))) + || (is_c_object(hash_entry_value(p)))) + check_collected(top, ci); + top_cyclic = true; + } + } + } + } + break; + + case T_SLOT: /* this can be hit if we somehow collect_shared_info on sc->rootlet via collect_vector_info (see the let case below) */ + if ((has_structure(slot_value(top))) && + (collect_shared_info + (sc, ci, slot_value(top), stop_at_print_length))) + top_cyclic = true; + break; + + case T_LET: + if (top == sc->rootlet) { + if (collect_vector_info(sc, ci, top, stop_at_print_length)) + top_cyclic = true; + } else { + s7_pointer p, q; + for (q = top; is_let(q) && (q != sc->rootlet); + q = let_outlet(q)) + for (p = let_slots(q); tis_slot(p); p = next_slot(p)) + if ((has_structure(slot_value(p))) && + (collect_shared_info + (sc, ci, slot_value(p), stop_at_print_length))) { + top_cyclic = true; + if ((is_c_pointer(slot_value(p))) || + (is_iterator(slot_value(p))) || + (is_c_object(slot_value(p)))) + check_collected(top, ci); + } + } + break; + + case T_CLOSURE: + case T_CLOSURE_STAR: + if (collect_shared_info + (sc, ci, closure_body(top), stop_at_print_length)) { + if (peek_shared_ref(ci, top) == 0) + check_collected(top, ci); + top_cyclic = true; + } + break; + + case T_C_POINTER: + if ((has_structure(c_pointer_type(top))) && + (collect_shared_info + (sc, ci, c_pointer_type(top), stop_at_print_length))) { + if (peek_shared_ref(ci, c_pointer_type(top)) == 0) + check_collected(c_pointer_type(top), ci); + top_cyclic = true; + } + if ((has_structure(c_pointer_info(top))) && + (collect_shared_info + (sc, ci, c_pointer_info(top), stop_at_print_length))) { + if (peek_shared_ref(ci, c_pointer_info(top)) == 0) + check_collected(c_pointer_info(top), ci); + top_cyclic = true; + } + break; + + case T_C_OBJECT: + if ((c_object_to_list(sc, top)) && + (c_object_set(sc, top)) && + (collect_shared_info + (sc, ci, + (*(c_object_to_list(sc, top))) (sc, set_plist_1(sc, top)), + stop_at_print_length))) { + if (peek_shared_ref(ci, top) == 0) + check_collected(top, ci); + top_cyclic = true; + } + break; + } + + if (!top_cyclic) + set_shared(top); + else + set_cyclic(top); + return (top_cyclic); +} + +static shared_info_t *init_circle_info(s7_scheme * sc) +{ + shared_info_t *ci; + ci = (shared_info_t *) calloc(1, sizeof(shared_info_t)); + ci->size = INITIAL_SHARED_INFO_SIZE; + ci->size2 = ci->size - 2; + ci->objs = (s7_pointer *) malloc(ci->size * sizeof(s7_pointer)); + ci->refs = (int32_t *) calloc(ci->size, sizeof(int32_t)); /* finder expects 0 = unseen previously */ + ci->defined = (bool *) calloc(ci->size, sizeof(bool)); + ci->cycle_port = sc->F; + ci->init_port = sc->F; + return (ci); +} + +static inline shared_info_t *new_shared_info(s7_scheme * sc) +{ + shared_info_t *ci = sc->circle_info; + if (ci->top > 0) { + int32_t i; + memclr((void *) (ci->refs), ci->top * sizeof(int32_t)); + memclr((void *) (ci->defined), ci->top * sizeof(bool)); + for (i = 0; i < ci->top; i++) + clear_cyclic_bits(ci->objs[i]); /* LOOP_4 is not faster */ + ci->top = 0; + } + ci->ref = 0; + ci->has_hits = false; + return (ci); +} + +static shared_info_t *make_shared_info(s7_scheme * sc, s7_pointer top, + bool stop_at_print_length) +{ + /* for the printer */ + shared_info_t *ci; + int32_t i, refs; + s7_pointer *ci_objs; + int32_t *ci_refs; + bool no_problem = true, cyclic = false; + s7_int k, stop_len; + + /* check for simple cases first */ + if (is_pair(top)) { + s7_pointer x = top; + if (stop_at_print_length) { + s7_pointer slow = top; + stop_len = sc->print_length; + for (k = 0; k < stop_len; k += 2) { + if (!is_pair(x)) + break; + if (has_structure(car(x))) { + no_problem = false; + break; + } + x = cdr(x); + if (!is_pair(x)) + break; + if (has_structure(car(x))) { + no_problem = false; + break; + } + x = cdr(x); + slow = cdr(slow); + if (x == slow) { + no_problem = false; + break; + } + } + } else if (s7_list_length(sc, top) == 0) /* it is circular at the top level (following cdr) */ + no_problem = false; + else + for (; is_pair(x); x = cdr(x)) + if (has_structure(car(x))) { + /* it can help a little in some cases to scan vectors here (and slots): + * if no element has structure, it's ok (maybe also hash_table_entries == 0) + */ + no_problem = false; + break; + } + if ((no_problem) && (!is_null(x)) && (has_structure(x))) + no_problem = false; + + if (no_problem) + return (NULL); + } else if (is_any_vector(top)) { + if (!is_normal_vector(top)) + return (NULL); + + stop_len = vector_length(top); + if ((stop_at_print_length) && (stop_len > sc->print_length)) + stop_len = sc->print_length; + + for (k = 0; k < stop_len; k++) + if (has_structure(vector_element(top, k))) { + no_problem = false; + break; + } + if (no_problem) + return (NULL); + } + ci = new_shared_info(sc); + + /* collect all pointers associated with top */ + cyclic = collect_shared_info(sc, ci, top, stop_at_print_length); + + ci_objs = ci->objs; + for (i = 0; i < ci->top; i++) + clear_collected_and_shared(ci_objs[i]); + + if (!cyclic) + return (NULL); + + if (!(ci->has_hits)) + return (NULL); + + ci_refs = ci->refs; + /* find if any were referenced twice (once for just being there, so twice=shared) + * we know there's at least one such reference because has_hits is true. + */ + for (i = 0, refs = 0; i < ci->top; i++) + if (ci_refs[i] > 0) { + set_collected(ci_objs[i]); + if (i == refs) + refs++; + else { + ci_objs[refs] = ci_objs[i]; + ci_refs[refs++] = ci_refs[i]; + ci_refs[i] = 0; + ci_objs[i] = NULL; + } + } + ci->top = refs; + return (ci); +} + + +/* -------------------------------- cyclic-sequences -------------------------------- */ +static s7_pointer cyclic_sequences_p_p(s7_scheme * sc, s7_pointer obj) +{ + if (has_structure(obj)) { + shared_info_t *ci; + ci = (sc->object_out_locked) ? sc->circle_info : make_shared_info(sc, obj, false); /* false=don't stop at print length (vectors etc) */ + if (ci) { + int32_t i; + s7_pointer lst; + sc->w = sc->nil; + check_free_heap_size(sc, ci->top); + for (i = 0; i < ci->top; i++) + sc->w = cons_unchecked(sc, ci->objs[i], sc->w); + lst = sc->w; + sc->w = sc->nil; + return (lst); + } + } + return (sc->nil); +} + +static s7_pointer g_cyclic_sequences(s7_scheme * sc, s7_pointer args) +{ +#define H_cyclic_sequences "(cyclic-sequences obj) returns a list of elements that are cyclic." +#define Q_cyclic_sequences s7_make_signature(sc, 2, sc->is_proper_list_symbol, sc->T) + return (cyclic_sequences_p_p(sc, car(args))); +} + +static int32_t circular_list_entries(s7_pointer lst) +{ + int32_t i; + s7_pointer x; + for (i = 1, x = cdr(lst);; i++, x = cdr(x)) { + int32_t j; + s7_pointer y; + for (y = lst, j = 0; j < i; y = cdr(y), j++) + if (x == y) + return (i); + } +} + +static void object_to_port_with_circle_check_1(s7_scheme * sc, + s7_pointer vr, + s7_pointer port, + use_write_t use_write, + shared_info_t * ci); +#define object_to_port_with_circle_check(Sc, Vr, Port, Use_Write, Ci) \ + do { \ + s7_pointer _V_ = Vr; \ + if ((Ci) && (has_structure(_V_))) \ + object_to_port_with_circle_check_1(Sc, _V_, Port, Use_Write, Ci); \ + else object_to_port(Sc, _V_, Port, Use_Write, Ci); \ + } while (0) + +static void (*display_functions[256])(s7_scheme * sc, s7_pointer obj, + s7_pointer port, + use_write_t use_write, + shared_info_t * ci); +#define object_to_port(Sc, Obj, Port, Use_Write, Ci) (*display_functions[unchecked_type(Obj)])(Sc, Obj, Port, Use_Write, Ci) + +static bool string_needs_slashification(const char *str, s7_int len) +{ + /* we have to go by len (str len) not *s==0 because s7 strings can have embedded nulls */ + uint8_t *p, *pend; + pend = (uint8_t *) (str + len); + for (p = (uint8_t *) str; p < pend; p++) + if (slashify_table[*p]) + return (true); + return (false); +} + +#define IN_QUOTES true +#define NOT_IN_QUOTES false + +static void slashify_string_to_port(s7_scheme * sc, s7_pointer port, + const char *p, s7_int len, bool quoted) +{ + uint8_t *pcur, *pend, *pstart = NULL; + if (len == 0) { + if (quoted) + port_write_string(port) (sc, "\"\"", 2, port); + return; + } + pend = (uint8_t *) (p + len); + + /* what about the trailing nulls? Guile writes them out (as does s7 currently) + * but that is not ideal. I'd like to use ~S for error messages, so that + * strings are clearly identified via the double-quotes, but this way of + * writing them is ugly: + * (let ((str (make-string 8 #\null))) (set! (str 0) #\a) str) -> "a\x00\x00\x00\x00\x00\x00\x00" + * but it would be misleading to omit them because: + * (let ((str (make-string 8 #\null))) (set! (str 0) #\a) (string-append str "bc")) -> "a\x00\x00\x00\x00\x00\x00\x00bc" + * also it is problematic to use sc->print_length here (rather than a separate string-print-length) because + * it is normally (say) 8 which truncates just about every string. In CL, *print-length* + * does not affect strings, symbols, or bit-vectors. But if the string is enormous, + * this function can bring us to a complete halt. string-print-length (as a *s7* field) is + * also problematic -- it does not behave as expected in many cases if it is limited to this + * function and string_to_port below, and if set too low, disables the repl. + */ + if (quoted) + port_write_character(port) (sc, '"', port); + for (pcur = (uint8_t *) p; pcur < pend; pcur++) { + if (slashify_table[*pcur]) { + if (pstart) + pstart++; + else + pstart = (uint8_t *) p; + if (pstart != pcur) { + port_write_string(port) (sc, (char *) pstart, + pcur - pstart, port); + pstart = pcur; + } + port_write_character(port) (sc, '\\', port); + switch (*pcur) { + case '"': + port_write_character(port) (sc, '"', port); + break; + case '\\': + port_write_character(port) (sc, '\\', port); + break; + case '\'': + port_write_character(port) (sc, '\'', port); + break; + case '\t': + port_write_character(port) (sc, 't', port); + break; + case '\r': + port_write_character(port) (sc, 'r', port); + break; + case '\b': + port_write_character(port) (sc, 'b', port); + break; + case '\f': + port_write_character(port) (sc, 'f', port); + break; + case '\?': + port_write_character(port) (sc, '?', port); + break; + case 'x': + port_write_character(port) (sc, 'x', port); + break; + default: + { + char buf[5]; + s7_int n = (s7_int) (*pcur); + buf[0] = 'x'; + buf[1] = (n < 16) ? '0' : dignum[(n / 16) % 16]; + buf[2] = dignum[n % 16]; + buf[3] = ';'; + buf[4] = '\0'; + port_write_string(port) (sc, buf, 4, port); + } + break; + } + } + } + if (!pstart) + port_write_string(port) (sc, (char *) p, len, port); + else { + pstart++; + if (pstart != pcur) + port_write_string(port) (sc, (char *) pstart, pcur - pstart, + port); + } + if (quoted) + port_write_character(port) (sc, '"', port); +} + +static void output_port_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + if ((obj == sc->standard_output) || (obj == sc->standard_error)) + port_write_string(port) (sc, port_filename(obj), + port_filename_length(obj), port); + else { + if (use_write == P_READABLE) { + if (port_is_closed(obj)) + port_write_string(port) (sc, + "(let ((p (open-output-string))) (close-output-port p) p)", + 56, port); + else { + if (is_string_port(obj)) { + port_write_string(port) (sc, + "(let ((p (open-output-string)))", + 31, port); + if (port_position(obj) > 0) { + port_write_string(port) (sc, " (display ", 10, + port); + slashify_string_to_port(sc, port, (const char *) + port_data(obj), + port_position(obj), + IN_QUOTES); + port_write_string(port) (sc, " p)", 3, port); + } + port_write_string(port) (sc, " p)", 3, port); + } else if (is_file_port(obj)) { + char str[256]; + int32_t nlen; + str[0] = '\0'; + nlen = + catstrs(str, 256, "(open-output-file \"", + port_filename(obj), "\" \"a\")", + (char *) NULL); + port_write_string(port) (sc, str, nlen, port); + } else + port_write_string(port) (sc, "#", + 23, port); + } + } else { + if (is_string_port(obj)) + port_write_string(port) (sc, "#", 8, port); + else + port_write_character(port) (sc, '>', port); + } + } +} + +static void input_port_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + if (obj == sc->standard_input) + port_write_string(port) (sc, port_filename(obj), + port_filename_length(obj), port); + else { + if (use_write == P_READABLE) { + if (port_is_closed(obj)) + port_write_string(port) (sc, + "(call-with-input-string \"\" (lambda (p) p))", + 42, port); + else if (is_function_port(obj)) + port_write_string(port) (sc, "#", 22, + port); + else if (is_file_port(obj)) { + char str[256]; + int32_t nlen; + str[0] = '\0'; + nlen = + catstrs(str, 256, "(open-input-file \"", + port_filename(obj), "\")", (char *) NULL); + port_write_string(port) (sc, str, nlen, port); + } else { + s7_int data_len; + data_len = port_data_size(obj) - port_position(obj); + if (data_len > 100) { + const char *filename; + filename = (const char *) s7_port_filename(sc, obj); + if (filename) { +#define DO_STR_LEN 1024 + char do_str[DO_STR_LEN]; + int32_t len; + do_str[0] = '\0'; + if (port_position(obj) > 0) { + len = + catstrs(do_str, DO_STR_LEN, + "(let ((port (open-input-file \"", + filename, "\")))", (char *) NULL); + port_write_string(port) (sc, do_str, len, + port); + do_str[0] = '\0'; + len = + catstrs(do_str, DO_STR_LEN, + " (do ((i 0 (+ i 1)) (c (read-char port) (read-char port))) ((= i ", + pos_int_to_str_direct(sc, + port_position + (obj) - 1), + ") port)))", (char *) NULL); + } else + len = + catstrs(do_str, DO_STR_LEN, + "(open-input-file \"", filename, + "\")", (char *) NULL); + port_write_string(port) (sc, do_str, len, port); + return; + } + } + port_write_string(port) (sc, "(open-input-string ", 19, + port); + /* not port_write_string here because there might be embedded double-quotes */ + slashify_string_to_port(sc, port, + (const char *) (port_data(obj) + + port_position + (obj)), + port_data_size(obj) - + port_position(obj), IN_QUOTES); + port_write_character(port) (sc, ')', port); + }} else { + if (is_string_port(obj)) + port_write_string(port) (sc, "#", 8, port); + else + port_write_character(port) (sc, '>', port); + } + } +} + +static bool symbol_needs_slashification(s7_scheme * sc, s7_pointer obj) +{ + uint8_t *p, *pend; + const char *str = symbol_name(obj); + s7_int len; + + if ((str[0] == '#') || (str[0] == '\'') || (str[0] == ',')) + return (true); + + if (is_number + (make_atom + (sc, (char *) str, 10, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR))) + return (true); + + len = symbol_name_length(obj); + pend = (uint8_t *) (str + len); + for (p = (uint8_t *) str; p < pend; p++) + if (symbol_slashify_table[*p]) + return (true); + set_clean_symbol(obj); + return (false); +} + +static inline void symbol_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + /* I think this is the only place we print a symbol's name */ + if ((!is_clean_symbol(obj)) && (symbol_needs_slashification(sc, obj))) { + port_write_string(port) (sc, "(symbol \"", 9, port); + slashify_string_to_port(sc, port, symbol_name(obj), + symbol_name_length(obj), NOT_IN_QUOTES); + port_write_string(port) (sc, "\")", 2, port); + } else { + char c = '\0'; + if (use_write == P_READABLE) { + if (!is_keyword(obj)) + c = '\''; + } else if ((use_write == P_KEY) && (!is_keyword(obj))) + c = ':'; + if (is_string_port(port)) { + s7_int new_len; + new_len = + port_position(port) + symbol_name_length(obj) + + ((c) ? 1 : 0); + if (new_len >= port_data_size(port)) + resize_port_data(sc, port, new_len * 2); + if (c) + port_data(port)[port_position(port)++] = c; + memcpy((void *) (port_data(port) + port_position(port)), + (void *) symbol_name(obj), symbol_name_length(obj)); + port_position(port) = new_len; + } else { + if (c) + port_write_character(port) (sc, c, port); + port_write_string(port) (sc, symbol_name(obj), + symbol_name_length(obj), port); + } + } +} + +static char *multivector_indices_to_string(s7_scheme * sc, s7_int index, + s7_pointer vect, char *str, + int32_t str_len, + int32_t cur_dim) +{ + s7_int size, ind; + size = vector_dimension(vect, cur_dim); + ind = index % size; + if (cur_dim > 0) + multivector_indices_to_string(sc, (index - ind) / size, vect, str, + str_len, cur_dim - 1); + catstrs(str, str_len, " ", pos_int_to_str_direct(sc, ind), + (char *) NULL); + return (str); +} + +#define NOT_P_DISPLAY(Choice) ((Choice == P_DISPLAY) ? P_WRITE : Choice) + +static int32_t multivector_to_port(s7_scheme * sc, s7_pointer vec, + s7_pointer port, int32_t out_len, + int32_t flat_ref, int32_t dimension, + int32_t dimensions, bool *last, + use_write_t use_write, + shared_info_t * ci) +{ + int32_t i; + if (use_write != P_READABLE) { + if (*last) + port_write_string(port) (sc, " (", 2, port); + else + port_write_character(port) (sc, '(', port); + (*last) = false; + } + for (i = 0; i < vector_dimension(vec, dimension); i++) { + if (dimension == (dimensions - 1)) { + if (flat_ref < out_len) { + object_to_port_with_circle_check(sc, + vector_getter(vec) (sc, + vec, + flat_ref), + port, + NOT_P_DISPLAY(use_write), + ci); + + if (use_write == P_READABLE) + port_write_string(port) (sc, ") ", 2, port); + flat_ref++; + } else { + port_write_string(port) (sc, "...)", 4, port); + return (flat_ref); + } + if ((use_write != P_READABLE) && + (i < (vector_dimension(vec, dimension) - 1))) + port_write_character(port) (sc, ' ', port); + } else if (flat_ref < out_len) + flat_ref = + multivector_to_port(sc, vec, port, out_len, flat_ref, + dimension + 1, dimensions, last, + NOT_P_DISPLAY(use_write), ci); + else { + port_write_string(port) (sc, "...)", 4, port); + return (flat_ref); + } + } + if (use_write != P_READABLE) + port_write_character(port) (sc, ')', port); + (*last) = true; + return (flat_ref); +} + +static void make_vector_to_port(s7_scheme * sc, s7_pointer vect, + s7_pointer port) +{ + s7_int vlen; + int32_t plen; + char buf[128]; + const char *vtyp = ""; + + if (is_float_vector(vect)) + vtyp = "float-"; + else if (is_int_vector(vect)) + vtyp = "int-"; + else if (is_byte_vector(vect)) + vtyp = "byte-"; + vlen = vector_length(vect); + if (vector_rank(vect) == 1) { + plen = + catstrs_direct(buf, "(make-", vtyp, "vector ", + integer_to_string_no_length(sc, vlen), " ", + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + } else { + s7_int dim; + plen = + catstrs_direct(buf, "(make-", vtyp, "vector '(", + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + for (dim = 0; dim < vector_ndims(vect) - 1; dim++) { + plen = + catstrs_direct(buf, + integer_to_string_no_length(sc, + vector_dimension + (vect, dim)), + " ", (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + } + plen = + catstrs_direct(buf, + integer_to_string_no_length(sc, + vector_dimension + (vect, dim)), ") ", + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + } +} + +static void write_vector_dimensions(s7_scheme * sc, s7_pointer vect, + s7_pointer port) +{ + char buf[128]; + s7_int dim, plen; + port_write_string(port) (sc, " '(", 3, port); + for (dim = 0; dim < vector_ndims(vect) - 1; dim++) { + plen = + catstrs_direct(buf, + integer_to_string_no_length(sc, + vector_dimension + (vect, dim)), " ", + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + } + plen = + catstrs_direct(buf, + integer_to_string_no_length(sc, + vector_dimension(vect, + dim)), + "))", (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); +} + +static void vector_to_port(s7_scheme * sc, s7_pointer vect, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + s7_int i, len = vector_length(vect), plen; + bool too_long = false; + char buf[2048]; /* 128 is too small -- this is the list of indices with a few minor flourishes */ + + if (len == 0) { + if (vector_rank(vect) > 1) { + plen = + catstrs_direct(buf, "#", + pos_int_to_str_direct(sc, + vector_ndims(vect)), + "d()", (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + } else + port_write_string(port) (sc, "#()", 3, port); + return; + } + if (use_write != P_READABLE) { + if (sc->print_length == 0) { + if (vector_rank(vect) > 1) { + plen = + catstrs_direct(buf, "#", + pos_int_to_str_direct(sc, + vector_ndims + (vect)), "d(...)", + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + } else + port_write_string(port) (sc, "#(...)", 6, port); + return; + } + if (len > sc->print_length) { + too_long = true; + len = sc->print_length; + } + } + if ((!ci) && (len > 1000)) { + s7_int vlen = vector_length(vect); + s7_pointer p0; + s7_pointer *els = vector_elements(vect); + p0 = els[0]; + for (i = 1; i < vlen; i++) + if (els[i] != p0) + break; + if (i == vlen) { + make_vector_to_port(sc, vect, port); + object_to_port(sc, p0, port, use_write, NULL); + port_write_character(port) (sc, ')', port); + return; + } + } + + check_stack_size(sc); + s7_gc_protect_via_stack(sc, vect); + if (use_write == P_READABLE) { + int32_t vref; + if ((ci) && + (is_cyclic(vect)) && + ((vref = peek_shared_ref(ci, vect)) != 0)) { + s7_pointer *els = vector_elements(vect); + if (vref < 0) + vref = -vref; + if ((ci->defined[vref]) || (port == ci->cycle_port)) { + plen = + catstrs_direct(buf, "<", + pos_int_to_str_direct(sc, vref), ">", + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + unstack(sc); + return; + } + + if (vector_rank(vect) > 1) + port_write_string(port) (sc, "(subvector ", 11, port); + + port_write_string(port) (sc, "(vector", 7, port); /* top level let */ + for (i = 0; i < len; i++) { + if (has_structure(els[i])) { + char *indices; + int32_t eref; + port_write_string(port) (sc, " #f", 3, port); + eref = peek_shared_ref(ci, els[i]); + + if (eref != 0) { + if (eref < 0) + eref = -eref; + if (vector_rank(vect) > 1) { + s7_int dimension = vector_rank(vect) - 1; + int32_t str_len; + block_t *b; + str_len = + (dimension < + 8) ? 128 : ((dimension + 1) * 16); + b = callocate(sc, str_len); + indices = (char *) block_data(b); + multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* calls pos_int_to_str_direct, writes to indices */ + plen = + catstrs_direct(buf, " (set! (<", + pos_int_to_str_direct(sc, + vref), + ">", indices, ") <", + pos_int_to_str_direct_1(sc, + eref), + ">) ", (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, + plen, + ci->cycle_port); + liberate(sc, b); + } else { + size_t len1; + len1 = + catstrs_direct(buf, " (set! (<", + pos_int_to_str_direct(sc, + vref), + "> ", integer_to_string(sc, + i, + &plen), + ") <", + pos_int_to_str_direct_1(sc, + eref), + ">) ", (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, + len1, + ci->cycle_port); + }} else { + if (vector_rank(vect) > 1) { + s7_int dimension = vector_rank(vect) - 1; + int32_t str_len; + block_t *b; + str_len = + (dimension < + 8) ? 128 : ((dimension + 1) * 16); + b = callocate(sc, str_len); + indices = (char *) block_data(b); + buf[0] = '\0'; + multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* writes to indices */ + plen = + catstrs(buf, 2048, " (set! (<", + pos_int_to_str_direct(sc, vref), + ">", indices, ") ", (char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, + plen, + ci->cycle_port); + liberate(sc, b); + } else { + size_t len1; + len1 = + catstrs_direct(buf, " (set! (<", + pos_int_to_str_direct(sc, + vref), + "> ", + integer_to_string_no_length + (sc, i), ") ", + (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, + len1, + ci->cycle_port); + } + object_to_port_with_circle_check(sc, els[i], + ci->cycle_port, + P_READABLE, ci); + port_write_string(ci->cycle_port) (sc, ") ", 2, + ci->cycle_port); + }} else { + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, els[i], port, + P_READABLE, ci); + } + } + port_write_character(port) (sc, ')', port); + if (vector_rank(vect) > 1) { + plen = + catstrs_direct(buf, " 0 ", + pos_int_to_str_direct(sc, len), + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + write_vector_dimensions(sc, vect, port); + } + } else { + if (vector_rank(vect) > 1) + port_write_string(port) (sc, "(subvector ", 11, port); + + if (is_immutable_vector(vect)) + port_write_string(port) (sc, "(immutable! ", 12, port); + + port_write_string(port) (sc, "(vector", 7, port); + for (i = 0; i < len; i++) { + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, + vector_element(vect, i), + port, P_READABLE, ci); + } + if (is_immutable_vector(vect)) + port_write_string(port) (sc, "))", 2, port); + else + port_write_character(port) (sc, ')', port); + + if (vector_rank(vect) > 1) { + plen = + catstrs_direct(buf, " 0 ", + pos_int_to_str_direct(sc, len), + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + write_vector_dimensions(sc, vect, port); + } + }} else { /* not readable write */ + if (vector_rank(vect) > 1) { + bool last = false; + if (vector_ndims(vect) > 1) { + plen = + catstrs_direct(buf, "#", + pos_int_to_str_direct(sc, + vector_ndims + (vect)), "d", + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + } else + port_write_character(port) (sc, '#', port); + multivector_to_port(sc, vect, port, len, 0, 0, + vector_ndims(vect), &last, use_write, ci); + } else { + port_write_string(port) (sc, "#(", 2, port); + for (i = 0; i < len - 1; i++) { + object_to_port_with_circle_check(sc, + vector_element(vect, i), + port, + NOT_P_DISPLAY(use_write), + ci); + port_write_character(port) (sc, ' ', port); + } + object_to_port_with_circle_check(sc, vector_element(vect, i), + port, + NOT_P_DISPLAY(use_write), ci); + + if (too_long) + port_write_string(port) (sc, " ...)", 5, port); + else + port_write_character(port) (sc, ')', port); + } + } + unstack(sc); +} + +static int32_t print_vector_length(s7_scheme * sc, s7_pointer vect, + s7_pointer port, use_write_t use_write) +{ + int32_t plen, len = vector_length(vect); + char buf[128]; + const char *vtype = "r"; + + if (is_int_vector(vect)) + vtype = "i"; + else if (is_byte_vector(vect)) + vtype = "u"; + if (len == 0) { + if (vector_rank(vect) > 1) + plen = + catstrs_direct(buf, "#", vtype, + pos_int_to_str_direct(sc, + vector_ndims(vect)), + "d()", (const char *) (const char *) NULL); + else + plen = + catstrs_direct(buf, "#", vtype, "()", (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + return (-1); + } + if (use_write == P_READABLE) + return (len); + if (sc->print_length != 0) + return ((len > sc->print_length) ? sc->print_length : len); + + if (vector_rank(vect) > 1) { + plen = + catstrs_direct(buf, "#", vtype, + pos_int_to_str_direct(sc, vector_ndims(vect)), + "d(...)", (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + } else if (is_int_vector(vect)) + port_write_string(port) (sc, "#i(...)", 7, port); + else if (is_float_vector(vect)) + port_write_string(port) (sc, "#r(...)", 7, port); + else + port_write_string(port) (sc, "#u(...)", 7, port); + return (-1); +} + +static void int_vector_to_port(s7_scheme * sc, s7_pointer vect, + s7_pointer port, use_write_t use_write, + shared_info_t * ignored) +{ + s7_int i, len, plen; + bool too_long; + char buf[128]; + char *p; + + len = print_vector_length(sc, vect, port, use_write); + if (len < 0) + return; + too_long = (len < vector_length(vect)); + + if ((use_write == P_READABLE) && (is_immutable_vector(vect))) + port_write_string(port) (sc, "(immutable! ", 12, port); + + if (len > 1000) { + s7_int vlen = vector_length(vect); + s7_int first; + s7_int *els = int_vector_ints(vect); + first = els[0]; + for (i = 1; i < vlen; i++) + if (els[i] != first) + break; + if (i == vlen) { + make_vector_to_port(sc, vect, port); + p = integer_to_string(sc, int_vector(vect, 0), &plen); + port_write_string(port) (sc, p, plen, port); + if ((use_write == P_READABLE) && (is_immutable_vector(vect))) + port_write_string(port) (sc, "))", 2, port); + else + port_write_character(port) (sc, ')', port); + return; + } + } + if (vector_rank(vect) == 1) { + port_write_string(port) (sc, "#i(", 3, port); + if (!is_string_port(port)) { + p = integer_to_string(sc, int_vector(vect, 0), &plen); + port_write_string(port) (sc, p, plen, port); + for (i = 1; i < len; i++) { + plen = + catstrs_direct(buf, " ", + integer_to_string_no_length(sc, + int_vector + (vect, i)), + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + }} else { + s7_int new_len = port_position(port), next_len = + port_data_size(port) - 128; + uint8_t *dbuf = port_data(port); + if (new_len >= next_len) { + resize_port_data(sc, port, port_data_size(port) * 2); + next_len = port_data_size(port) - 128; + dbuf = port_data(port); + } + p = integer_to_string(sc, int_vector(vect, 0), &plen); + memcpy((void *) (dbuf + new_len), (void *) p, plen); + new_len += plen; + for (i = 1; i < len; i++) { + if (new_len >= next_len) { + resize_port_data(sc, port, port_data_size(port) * 2); + next_len = port_data_size(port) - 128; + dbuf = port_data(port); + } + plen = + catstrs_direct((char *) (dbuf + new_len), " ", + integer_to_string_no_length(sc, + int_vector + (vect, i)), + (const char *) NULL); + new_len += plen; + } + port_position(port) = new_len; + } + if (too_long) + port_write_string(port) (sc, " ...)", 5, port); + else + port_write_character(port) (sc, ')', port); + } else { + bool last = false; + plen = + catstrs_direct(buf, "#i", + pos_int_to_str_direct(sc, vector_ndims(vect)), + "d", (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + s7_gc_protect_via_stack(sc, vect); + multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), + &last, P_DISPLAY, NULL); + unstack(sc); + } + if ((use_write == P_READABLE) && (is_immutable_vector(vect))) + port_write_character(port) (sc, ')', port); +} + +static void float_vector_to_port(s7_scheme * sc, s7_pointer vect, + s7_pointer port, use_write_t use_write, + shared_info_t * ignored) +{ + s7_int i, len, plen; + bool too_long; +#define FV_BUFSIZE 256 + char buf[FV_BUFSIZE]; + s7_double *els = float_vector_floats(vect); + + len = print_vector_length(sc, vect, port, use_write); + if (len < 0) + return; /* vector-length=0 etc */ + too_long = (len < vector_length(vect)); + + if ((use_write == P_READABLE) && (is_immutable_vector(vect))) + port_write_string(port) (sc, "(immutable! ", 12, port); + + if (len > 1000) { + s7_int vlen = vector_length(vect); + s7_double first = els[0]; + for (i = 1; i < vlen; i++) + if (els[i] != first) + break; + if (i == vlen) { + make_vector_to_port(sc, vect, port); + plen = + snprintf(buf, FV_BUFSIZE, "%.*g)", + sc->float_format_precision, first); + port_write_string(port) (sc, buf, + clamp_length(plen, FV_BUFSIZE), port); + if ((use_write == P_READABLE) && (is_immutable_vector(vect))) + port_write_character(port) (sc, ')', port); + return; + } + } + + if (vector_rank(vect) == 1) { + port_write_string(port) (sc, "#r(", 3, port); + plen = snprintf(buf, FV_BUFSIZE - 4, "%.*g", sc->float_format_precision, els[0]); /* -4 so floatify has room */ + floatify(buf, &plen); + port_write_string(port) (sc, buf, clamp_length(plen, FV_BUFSIZE), + port); + for (i = 1; i < len; i++) { + plen = + snprintf(buf, FV_BUFSIZE - 4, " %.*g", + sc->float_format_precision, els[i]); + plen--; /* fixup for the initial #\space */ + floatify((char *) (buf + 1), &plen); + port_write_string(port) (sc, buf, + clamp_length(plen + 1, FV_BUFSIZE), + port); + } + if (too_long) + port_write_string(port) (sc, " ...)", 5, port); + else + port_write_character(port) (sc, ')', port); + } else { + bool last = false; + plen = + catstrs_direct(buf, "#r", + pos_int_to_str_direct(sc, vector_ndims(vect)), + "d", (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + s7_gc_protect_via_stack(sc, vect); + multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), + &last, P_DISPLAY, NULL); + unstack(sc); + } + if ((use_write == P_READABLE) && (is_immutable_vector(vect))) + port_write_character(port) (sc, ')', port); +} + +static void byte_vector_to_port(s7_scheme * sc, s7_pointer vect, + s7_pointer port, use_write_t use_write, + shared_info_t * ignored) +{ + s7_int i, len, plen; + bool too_long; + char buf[128]; + char *p; + + len = print_vector_length(sc, vect, port, use_write); + if (len < 0) + return; + too_long = (len < vector_length(vect)); + + if ((use_write == P_READABLE) && (is_immutable_vector(vect))) + port_write_string(port) (sc, "(immutable! ", 12, port); + + if (len > 1000) { + s7_int vlen = vector_length(vect); + uint8_t first; + uint8_t *els = byte_vector_bytes(vect); + first = els[0]; + for (i = 1; i < vlen; i++) + if (els[i] != first) + break; + if (i == vlen) { + make_vector_to_port(sc, vect, port); + p = integer_to_string(sc, byte_vector(vect, 0), &plen); + port_write_string(port) (sc, p, plen, port); + if ((use_write == P_READABLE) && (is_immutable_vector(vect))) + port_write_string(port) (sc, "))", 2, port); + else + port_write_character(port) (sc, ')', port); + return; + } + } + + if (vector_rank(vect) == 1) { + port_write_string(port) (sc, "#u(", 3, port); + p = integer_to_string(sc, byte_vector(vect, 0), &plen); + port_write_string(port) (sc, p, plen, port); + for (i = 1; i < len; i++) { + plen = + catstrs_direct(buf, " ", + integer_to_string_no_length(sc, + byte_vector + (vect, i)), + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + } + if (too_long) + port_write_string(port) (sc, " ...)", 5, port); + else + port_write_character(port) (sc, ')', port); + } else { + bool last = false; + plen = + catstrs_direct(buf, "#u", + pos_int_to_str_direct(sc, vector_ndims(vect)), + "d", (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), + &last, P_DISPLAY, NULL); + } + if ((use_write == P_READABLE) && (is_immutable_vector(vect))) + port_write_character(port) (sc, ')', port); +} + +static void string_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ignored) +{ + bool immutable; + immutable = ((use_write == P_READABLE) && (is_immutable_string(obj)) && (string_length(obj) > 0)); /* (immutable "") looks dumb */ + if (immutable) + port_write_string(port) (sc, "(immutable! ", 12, port); + + if (string_length(obj) > 0) { + /* since string_length is a scheme length, not C, this write can embed nulls from C's point of view */ + if (string_length(obj) > 1000) { /* was 10000 28-Feb-18 */ + size_t size; + char buf[128]; + buf[0] = string_value(obj)[0]; + buf[1] = '\0'; + size = strspn((const char *) (string_value(obj) + 1), buf); /* if all #\null, this won't work */ + if (size == (size_t) (string_length(obj) - 1)) { + int32_t nlen; + s7_pointer c = chars[(int32_t) ((uint8_t) (buf[0]))]; + nlen = + catstrs_direct(buf, "(make-string ", + pos_int_to_str_direct(sc, + string_length + (obj)), " ", + (const char *) NULL); + port_write_string(port) (sc, buf, nlen, port); + port_write_string(port) (sc, character_name(c), + character_name_length(c), port); + if (immutable) + port_write_string(port) (sc, "))", 2, port); + else + port_write_character(port) (sc, ')', port); + return; + } + } + if (use_write == P_DISPLAY) + port_write_string(port) (sc, string_value(obj), + string_length(obj), port); + else if (!string_needs_slashification + (string_value(obj), string_length(obj))) { + port_write_character(port) (sc, '"', port); + port_write_string(port) (sc, string_value(obj), + string_length(obj), port); + port_write_character(port) (sc, '"', port); + } else + slashify_string_to_port(sc, port, string_value(obj), + string_length(obj), IN_QUOTES); + } else if (use_write != P_DISPLAY) + port_write_string(port) (sc, "\"\"", 2, port); + + if (immutable) + port_write_character(port) (sc, ')', port); +} + +static void simple_list_readable_display(s7_scheme * sc, s7_pointer lst, + s7_int true_len, s7_int len, + s7_pointer port, + shared_info_t * ci) +{ + /* the easier cases: no circles or shared refs to patch up */ + s7_pointer x; + + if (is_immutable(lst)) + port_write_string(port) (sc, "immutable! (", 12, port); + + if (true_len > 0) { + port_write_string(port) (sc, "list", 4, port); + for (x = lst; is_pair(x); x = cdr(x)) { + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, car(x), port, P_READABLE, + ci); + } + port_write_character(port) (sc, ')', port); + } else { + s7_int i; + port_write_string(port) (sc, "cons ", 5, port); + object_to_port_with_circle_check(sc, car(lst), port, P_READABLE, + ci); + for (x = cdr(lst); is_pair(x); x = cdr(x)) { + port_write_string(port) (sc, " (cons ", 7, port); + object_to_port_with_circle_check(sc, car(x), port, P_READABLE, + ci); + } + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, x, port, P_READABLE, ci); + for (i = 1; i < len; i++) + port_write_character(port) (sc, ')', port); + } + if (is_immutable(lst)) + port_write_character(port) (sc, ')', port); +} + +static void pair_to_port(s7_scheme * sc, s7_pointer lst, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ + s7_pointer x; + s7_int i, len, true_len; + + true_len = s7_list_length(sc, lst); + if (true_len < 0) /* a dotted list -- handle cars, then final cdr */ + len = (-true_len + 1); + else + len = (true_len == 0) ? circular_list_entries(lst) : true_len; /* circular list (nil is handled by unique_to_port) */ + + if ((use_write == P_READABLE) && (ci)) { + int32_t href; + href = peek_shared_ref(ci, lst); + if (href != 0) { + if (href < 0) + href = -href; + if ((ci->defined[href]) || (port == ci->cycle_port)) { + char buf[128]; + int32_t plen; + plen = + catstrs_direct(buf, "<", + pos_int_to_str_direct(sc, href), ">", + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + return; + } + } + } + + if ((use_write != P_READABLE) && + (car(lst) == sc->quote_symbol) && (true_len == 2)) { + /* len == 1 is important, otherwise (list 'quote 1 2) -> '1 2 which looks weird + * or (object->string (apply . `''1)) -> "'quote 1" + * so (quote x) = 'x but (quote x y z) should be left alone (if evaluated, it's an error) + * :readable is tricky because the list might be something like (list 'quote (lambda () #f)) which needs to be evalable back to its original + */ + port_write_character(port) (sc, '\'', port); + object_to_port_with_circle_check(sc, cadr(lst), port, P_WRITE, ci); + return; + } + + if (is_multiple_value(lst)) + port_write_string(port) (sc, "(values ", 8, port); + else + port_write_character(port) (sc, '(', port); + + check_stack_size(sc); + s7_gc_protect_via_stack(sc, lst); + + if (use_write == P_READABLE) { + if (!is_cyclic(lst)) { + simple_list_readable_display(sc, lst, true_len, len, port, ci); + unstack(sc); + return; + } + if (ci) { + int32_t plen; + char buf[128], lst_name[128]; + int32_t lst_ref; + bool lst_local = false; + s7_pointer local_port; + + lst_ref = peek_shared_ref(ci, lst); + if (lst_ref == 0) { + s7_pointer p; + for (p = lst; is_pair(p); p = cdr(p)) + if ((has_structure(car(p))) || + ((is_pair(cdr(p))) && + (peek_shared_ref(ci, cdr(p)) != 0))) { + lst_name[0] = '<'; + lst_name[1] = 'L'; + lst_name[2] = '>'; + lst_name[3] = '\0'; + lst_local = true; + port_write_string(port) (sc, "let (( (list", 15, port); /* '(' above */ + break; + } + if (!lst_local) { + if (has_structure(p)) { + lst_name[0] = '<'; + lst_name[1] = 'L'; + lst_name[2] = '>'; + lst_name[3] = '\0'; + lst_local = true; + port_write_string(port) (sc, "let (( (list", 15, port); /* '(' above */ + } else { + simple_list_readable_display(sc, lst, true_len, + len, port, ci); + unstack(sc); + return; + } + } + } else { + if (lst_ref < 0) + lst_ref = -lst_ref; + catstrs_direct(lst_name, "<", + pos_int_to_str_direct(sc, lst_ref), ">", + (const char *) NULL); + port_write_string(port) (sc, "list", 4, port); /* '(' above */ + } + + for (i = 0, x = lst; (i < len) && (is_pair(x)); + x = cdr(x), i++) { + if ((has_structure(car(x))) && (is_cyclic(car(x)))) + port_write_string(port) (sc, " #f", 3, port); + else { + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, car(x), port, + use_write, ci); + } + if ((is_pair(cdr(x))) && + (peek_shared_ref(ci, cdr(x)) != 0)) + break; + } + + if (lst_local) + port_write_string(port) (sc, "))) ", 4, port); + else + port_write_character(port) (sc, ')', port); + + /* fill in the cyclic entries */ + local_port = ((lst_local) || (ci->cycle_port == sc->F)) ? port : ci->cycle_port; /* (object->string (list-values `(x . 1) (signature (int-vector))) :readable) */ + for (x = lst, i = 0; (i < len) && (is_pair(x)); + x = cdr(x), i++) { + int32_t lref; + if ((has_structure(car(x))) && (is_cyclic(car(x)))) { + if (i == 0) + plen = + catstrs_direct(buf, " (set-car! ", lst_name, + " ", (const char *) NULL); + else + plen = + catstrs_direct(buf, " (set! (", lst_name, " ", + pos_int_to_str_direct(sc, i), + ") ", (const char *) NULL); + port_write_string(local_port) (sc, buf, plen, + local_port); + lref = peek_shared_ref(ci, car(x)); + if (lref == 0) + object_to_port_with_circle_check(sc, car(x), + local_port, + use_write, ci); + else { + if (lref < 0) + lref = -lref; + plen = + catstrs_direct(buf, "<", + pos_int_to_str_direct(sc, lref), + ">", (const char *) NULL); + port_write_string(local_port) (sc, buf, plen, + local_port); + } + port_write_string(local_port) (sc, ") ", 2, + local_port); + } + if ((is_pair(cdr(x))) && + ((lref = peek_shared_ref(ci, cdr(x))) != 0)) { + if (lref < 0) + lref = -lref; + if (i == 0) + plen = + catstrs_direct(buf, + (lst_local) ? " " : " ", + "(set-cdr! ", lst_name, " <", + pos_int_to_str_direct(sc, lref), + ">) ", (const char *) NULL); + else if (i == 1) + plen = + catstrs_direct(buf, + (lst_local) ? " " : " ", + "(set-cdr! (cdr ", lst_name, + ") <", pos_int_to_str_direct(sc, + lref), + ">) ", (const char *) NULL); + else + plen = + catstrs_direct(buf, + (lst_local) ? " " : " ", + "(set-cdr! (list-tail ", + lst_name, " ", + pos_int_to_str_direct_1(sc, i), + ") <", pos_int_to_str_direct(sc, + lref), + ">) ", (const char *) NULL); + port_write_string(local_port) (sc, buf, plen, + local_port); + break; + } + } + if (true_len < 0) { /* dotted list */ + s7_pointer end_x; + for (end_x = lst; is_pair(end_x); end_x = cdr(end_x)); /* or maybe faster, start at x? */ + /* we can't depend on the loops above to set x to the last element because they sometimes break out */ + if (true_len == -1) /* cons cell */ + plen = + catstrs_direct(buf, (lst_local) ? " " : " ", + "(set-cdr! ", lst_name, " ", + (const char *) NULL); + else if (true_len == -2) + plen = + catstrs_direct(buf, (lst_local) ? " " : " ", + "(set-cdr! (cdr ", lst_name, ") ", + (const char *) NULL); + else + plen = + catstrs_direct(buf, "(set-cdr! (list-tail ", + lst_name, " ", + pos_int_to_str_direct(sc, len - 2), + ") ", (const char *) NULL); + port_write_string(local_port) (sc, buf, plen, local_port); + object_to_port_with_circle_check(sc, end_x, local_port, + use_write, ci); + port_write_string(local_port) (sc, ") ", 2, local_port); + } + + if (lst_local) + port_write_string(local_port) (sc, " )", 8, + local_port); + } else + simple_list_readable_display(sc, lst, true_len, len, port, ci); + } else { /* not :readable */ + s7_int plen; + plen = (len > sc->print_length) ? sc->print_length : len; + if (plen <= 0) { + port_write_string(port) (sc, "(...))", 6, port); /* open paren above about 150 lines, "list" here is wrong if it's a cons */ + unstack(sc); + return; + } + if (ci) { + for (x = lst, i = 0; (is_pair(x)) && (i < plen) && ((i == 0) + || + (peek_shared_ref + (ci, x) + == 0)); + i++, x = cdr(x)) { + object_to_port_with_circle_check(sc, car(x), port, + NOT_P_DISPLAY(use_write), + ci); + if (i < (len - 1)) + port_write_character(port) (sc, ' ', port); + } + if (is_not_null(x)) { + if (plen < len) + port_write_string(port) (sc, " ...", 4, port); + else { + if ((true_len == 0) && (i == len)) + port_write_string(port) (sc, " . ", 3, port); + else + port_write_string(port) (sc, ". ", 2, port); + object_to_port_with_circle_check(sc, x, port, + NOT_P_DISPLAY + (use_write), ci); + } + } + port_write_character(port) (sc, ')', port); + } else { + s7_int len1; + len1 = plen - 1; + if (is_string_port(port)) { + for (x = lst, i = 0; (is_pair(x)) && (i < len1); + i++, x = cdr(x)) { + object_to_port(sc, car(x), port, + NOT_P_DISPLAY(use_write), ci); + if (port_position(port) >= sc->objstr_max_len) { + unstack(sc); + return; + } + if (port_position(port) >= port_data_size(port)) + resize_port_data(sc, port, + port_data_size(port) * 2); + port_data(port)[port_position(port)++] = (uint8_t) ' '; + } + } else + for (x = lst, i = 0; (is_pair(x)) && (i < len1); + i++, x = cdr(x)) { + object_to_port(sc, car(x), port, + NOT_P_DISPLAY(use_write), ci); + port_write_character(port) (sc, ' ', port); + } + if (is_pair(x)) { + object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write), + ci); + x = cdr(x); + } + if (is_not_null(x)) { + if (plen < len) + port_write_string(port) (sc, " ...", 4, port); + else { + port_write_string(port) (sc, ". ", 2, port); + object_to_port(sc, x, port, NOT_P_DISPLAY(use_write), + ci); + } + } + port_write_character(port) (sc, ')', port); + } + } + unstack(sc); +} + +static void hash_table_to_port(s7_scheme * sc, s7_pointer hash, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + s7_int i, gc_iter, len = hash_table_entries(hash); + bool too_long = false; + s7_pointer iterator, p; + int32_t href; + + /* if hash is a member of ci, just print its number + * (let ((ht (hash-table '(a . 1)))) (hash-table-set! ht 'b ht)) + * + * since equal? does not care about the hash-table lengths, we can ignore that complication in the :readable case + * there's no way to make a truly :readable version of a weak hash-table (or a normal hash-table that uses eq? with pairs, for example) + */ + if (len == 0) { + if (is_weak_hash_table(hash)) + port_write_string(port) (sc, "(weak-hash-table)", 17, port); + else + port_write_string(port) (sc, "(hash-table)", 12, port); + return; + } + if (use_write != P_READABLE) { + s7_int plen = sc->print_length; + if (plen <= 0) { + port_write_string(port) (sc, "(hash-table ...)", 16, port); + return; + } + if (len > plen) { + too_long = true; + len = plen; + } + } + if ((use_write == P_READABLE) && (ci)) { + href = peek_shared_ref(ci, hash); + if (href != 0) { + if (href < 0) + href = -href; + if ((ci->defined[href]) || (port == ci->cycle_port)) { + char buf[128]; + int32_t plen; + plen = + catstrs_direct(buf, "<", + pos_int_to_str_direct(sc, href), ">", + (const char *) NULL); + port_write_string(port) (sc, buf, plen, port); + return; + } + } + } + + iterator = s7_make_iterator(sc, hash); + gc_iter = gc_protect_1(sc, iterator); + p = cons_unchecked(sc, sc->F, sc->F); + iterator_current(iterator) = p; + set_mark_seq(iterator); + + if ((use_write == P_READABLE) && (is_immutable(hash))) + port_write_string(port) (sc, "(immutable! ", 12, port); + + if ((use_write == P_READABLE) && + (ci) && + (is_cyclic(hash)) && ((href = peek_shared_ref(ci, hash)) != 0)) { + if (href < 0) + href = -href; + + if (is_weak_hash_table(hash)) + port_write_string(port) (sc, "(weak-hash-table", 16, port); + else + port_write_string(port) (sc, "(hash-table", 11, port); /* top level let */ + for (i = 0; i < len; i++) { + s7_pointer key_val, key, val; + + key_val = hash_table_iterate(sc, iterator); + key = car(key_val); + val = cdr(key_val); + if ((has_structure(val)) || (has_structure(key))) { + char buf[128]; + int32_t eref, kref, plen; + eref = peek_shared_ref(ci, val); + kref = peek_shared_ref(ci, key); + plen = + catstrs_direct(buf, " (set! (<", + pos_int_to_str_direct(sc, href), "> ", + (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, plen, + ci->cycle_port); + + if (kref != 0) { + if (kref < 0) + kref = -kref; + plen = + catstrs_direct(buf, "<", + pos_int_to_str_direct(sc, kref), + ">", (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, plen, + ci->cycle_port); + } else + object_to_port(sc, key, ci->cycle_port, P_READABLE, + ci); + + if (eref != 0) { + if (eref < 0) + eref = -eref; + plen = + catstrs_direct(buf, ") <", + pos_int_to_str_direct(sc, eref), + ">) ", (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, plen, + ci->cycle_port); + } else { + port_write_string(ci->cycle_port) (sc, ") ", 2, + ci->cycle_port); + object_to_port_with_circle_check(sc, val, + ci->cycle_port, + P_READABLE, ci); + port_write_string(ci->cycle_port) (sc, ") ", 2, + ci->cycle_port); + } + } else { + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, key, port, P_READABLE, + ci); + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, val, port, P_READABLE, + ci); + } + } + port_write_character(port) (sc, ')', port); + } else { + if (is_weak_hash_table(hash)) + port_write_string(port) (sc, "(weak-hash-table", 16, port); + else + port_write_string(port) (sc, "(hash-table", 11, port); + for (i = 0; i < len; i++) { + s7_pointer key_val; + port_write_character(port) (sc, ' ', port); + key_val = hash_table_iterate(sc, iterator); + if ((use_write != P_READABLE) && + (is_normal_symbol(car(key_val)))) + port_write_character(port) (sc, '\'', port); + object_to_port_with_circle_check(sc, car(key_val), port, + NOT_P_DISPLAY(use_write), ci); + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, cdr(key_val), port, + NOT_P_DISPLAY(use_write), ci); + } + if (too_long) + port_write_string(port) (sc, " ...)", 5, port); + else + port_write_character(port) (sc, ')', port); + } + if ((use_write == P_READABLE) && (is_immutable(hash))) + port_write_character(port) (sc, ')', port); + + s7_gc_unprotect_at(sc, gc_iter); + iterator_current(iterator) = sc->nil; + free_cell(sc, p); /* free_cell(sc, iterator); *//* 18-Dec-18 removed */ +} + +static int32_t slot_to_port_1(s7_scheme * sc, s7_pointer x, + s7_pointer port, use_write_t use_write, + shared_info_t * ci, int32_t n) +{ +#if S7_DEBUGGING + if ((x) && (!is_slot(x))) + fprintf(stderr, "%s: x is %s\n", __func__, + s7_type_names[unchecked_type(x)]); +#endif + if (tis_slot(x)) { + n = slot_to_port_1(sc, next_slot(x), port, use_write, ci, n); + if (n <= sc->print_length) { + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, x, port, use_write, ci); + } else if (n == (sc->print_length + 1)) + port_write_string(port) (sc, " ...", 4, port); + } + return (n + 1); +} + +static void funclet_slots_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + int32_t i; + s7_pointer slot; + for (i = 0, slot = let_slots(obj); tis_slot(slot); + i++, slot = next_slot(slot)) { + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, slot, port, use_write, ci); + if (i == (sc->print_length + 1)) { + port_write_string(port) (sc, " ...", 4, port); + break; + } + } +} + +static void slot_list_to_port(s7_scheme * sc, s7_pointer slot, + s7_pointer port, shared_info_t * ci, + bool bindings) +{ + if (tis_slot(slot)) { + slot_list_to_port(sc, next_slot(slot), port, ci, bindings); + if (bindings) { + if (tis_slot(next_slot(slot))) + port_write_string(port) (sc, " (", 2, port); + else + port_write_character(port) (sc, '(', port); + } else + port_write_character(port) (sc, ' ', port); + symbol_to_port(sc, slot_symbol(slot), port, (bindings) ? P_DISPLAY : P_KEY, ci); /* (object->string (inlet (symbol "(\")") 1) :readable) */ + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, slot_value(slot), port, + P_READABLE, ci); + if (bindings) + port_write_character(port) (sc, ')', port); + } +} + +static void slot_list_to_port_with_cycle(s7_scheme * sc, s7_pointer obj, + s7_pointer slot, s7_pointer port, + shared_info_t * ci, bool bindings) +{ + if (tis_slot(slot)) { + s7_pointer sym, val; + slot_list_to_port_with_cycle(sc, obj, next_slot(slot), port, ci, + bindings); + sym = slot_symbol(slot); + val = slot_value(slot); + + if (bindings) { + if (tis_slot(next_slot(slot))) + port_write_string(port) (sc, " (", 2, port); + else + port_write_character(port) (sc, '(', port); + } else + port_write_character(port) (sc, ' ', port); + symbol_to_port(sc, sym, port, (bindings) ? P_DISPLAY : P_KEY, ci); + if (has_structure(val)) { + char buf[128]; + int32_t symref, len; + port_write_string(port) (sc, " #f", 3, port); + + len = + catstrs_direct(buf, " (set! (<", + pos_int_to_str_direct(sc, + -peek_shared_ref(ci, + obj)), + "> ", (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, len, + ci->cycle_port); + symbol_to_port(sc, sym, ci->cycle_port, P_KEY, ci); + + symref = peek_shared_ref(ci, val); + if (symref != 0) { + if (symref < 0) + symref = -symref; + len = + catstrs_direct(buf, ") <", + pos_int_to_str_direct(sc, symref), + ">) ", (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, len, + ci->cycle_port); + } else { + port_write_string(ci->cycle_port) (sc, ") ", 2, + ci->cycle_port); + object_to_port_with_circle_check(sc, val, ci->cycle_port, + P_READABLE, ci); + port_write_string(ci->cycle_port) (sc, ") ", 2, + ci->cycle_port); + } + } else { + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, val, port, P_READABLE, + ci); + } + if (bindings) + port_write_character(port) (sc, ')', port); + if (is_immutable(obj)) { + char buf[128]; + int32_t len; + len = + catstrs_direct(buf, " (immutable! <", + pos_int_to_str_direct(sc, + -peek_shared_ref(ci, + obj)), + ">) ", (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, len, + ci->cycle_port); + } + } +} + +static bool let_has_setter(s7_pointer obj) +{ + s7_pointer slot; + for (slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot)) + if (slot_has_setter(slot)) + return (true); + return (false); +} + +static void slot_setters_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, shared_info_t * ci) +{ + s7_pointer slot; + for (slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot)) + if (slot_has_setter(slot)) { + port_write_string(port) (sc, "(set! (setter '", 15, port); + symbol_to_port(sc, slot_symbol(slot), port, P_DISPLAY, ci); + port_write_string(port) (sc, ") ", 2, port); + object_to_port_with_circle_check(sc, slot_setter(slot), port, + P_READABLE, ci); + port_write_character(port) (sc, ')', port); + } +} + +static void let_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ + /* if outer env points to (say) method list, the object needs to specialize object->string itself */ + if (has_active_methods(sc, obj)) { + s7_pointer print_func; + print_func = find_method(sc, obj, sc->object_to_string_symbol); + if (print_func != sc->undefined) { + s7_pointer p; + /* what needs to be protected here? for one, the function might not return a string! */ + + clear_has_methods(obj); + if (use_write == P_WRITE) + p = call_method(sc, obj, print_func, set_plist_1(sc, obj)); + else + p = call_method(sc, obj, print_func, + set_plist_2(sc, obj, + (use_write == + P_DISPLAY) ? sc-> + F : sc->key_readable_symbol)); + set_has_methods(obj); + + if ((is_string(p)) && (string_length(p) > 0)) + port_write_string(port) (sc, string_value(p), + string_length(p), port); + return; + } + } + if (obj == sc->rootlet) + port_write_string(port) (sc, "(rootlet)", 9, port); + else { + if (obj == sc->s7_let) + port_write_string(port) (sc, "*s7*", 4, port); + else { + if (sc->short_print) + port_write_string(port) (sc, "#", 6, port); + else { + /* circles can happen here: + * (let () (let ((b (curlet))) (curlet))): #> + * or (let ((b #f)) (set! b (curlet)) (curlet)): #1=# + */ + if (use_write == P_READABLE) { + int32_t lref; + if ((ci) && + (is_cyclic(obj)) && + ((lref = peek_shared_ref(ci, obj)) != 0)) { + if (lref < 0) + lref = -lref; + if ((ci->defined[lref]) + || (port == ci->cycle_port)) { + char buf[128]; + int32_t len; + len = + catstrs_direct(buf, "<", + pos_int_to_str_direct(sc, + lref), + ">", (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, + len, + ci->cycle_port); + return; + } + if ((let_outlet(obj) != sc->nil) && + (let_outlet(obj) != sc->rootlet)) { + char buf[128]; + int32_t len; + len = + catstrs_direct(buf, " (set! (outlet <", + pos_int_to_str_direct(sc, + lref), + ">) ", (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, + len, + ci->cycle_port); + let_to_port(sc, let_outlet(obj), + ci->cycle_port, use_write, ci); + port_write_string(ci->cycle_port) (sc, ") ", 2, + ci->cycle_port); + } + if (has_methods(obj)) + port_write_string(port) (sc, "(openlet ", 9, + port); + /* not immutable here because we'll need to set the let fields below, then declare it immutable */ + if (let_has_setter(obj)) { + port_write_string(port) (sc, "(let (", 6, + port); + slot_list_to_port_with_cycle(sc, obj, + let_slots(obj), + port, ci, true); + port_write_string(port) (sc, ") ", 2, port); + slot_setters_to_port(sc, obj, port, ci); + port_write_string(port) (sc, " (curlet))", 10, + port); + } else { + port_write_string(port) (sc, "(inlet", 6, + port); + slot_list_to_port_with_cycle(sc, obj, + let_slots(obj), + port, ci, false); + port_write_character(port) (sc, ')', port); + } + if (has_methods(obj)) + port_write_character(port) (sc, ')', port); + } else { + if (has_methods(obj)) + port_write_string(port) (sc, "(openlet ", 9, + port); + if (is_immutable(obj)) + port_write_string(port) (sc, "(immutable! ", + 12, port); + + /* this ignores outlet -- but is that a problem? */ + /* (object->string (let ((i 0)) (set! (setter 'i) integer?) (curlet)) :readable) -> "(let ((i 0)) (set! (setter 'i) #_integer?) (curlet))" */ + if (let_has_setter(obj)) { + port_write_string(port) (sc, "(let (", 6, + port); + slot_list_to_port(sc, let_slots(obj), port, ci, + true); + port_write_string(port) (sc, ") ", 2, port); + slot_setters_to_port(sc, obj, port, ci); + /* perhaps set outlet here?? */ + port_write_string(port) (sc, " (curlet))", 10, + port); + } else { + if ((let_outlet(obj) != sc->nil) && + (let_outlet(obj) != sc->rootlet)) { + int32_t ref; + port_write_string(port) (sc, "(sublet ", 8, + port); + if ((ci) + && + ((ref = + peek_shared_ref(ci, + let_outlet(obj))) < + 0)) { + char buf[128]; + int32_t len; + len = + catstrs_direct(buf, "<", + pos_int_to_str_direct + (sc, -ref), ">", + (const char *) + NULL); + port_write_string(port) (sc, buf, len, + port); + } else { + s7_pointer name; + name = + s7_let_ref(sc, obj, + sc->class_name_symbol); + if (is_symbol(name)) + symbol_to_port(sc, name, port, + P_DISPLAY, ci); + else + let_to_port(sc, let_outlet(obj), + port, use_write, ci); + } + } else + port_write_string(port) (sc, "(inlet", 6, + port); + slot_list_to_port(sc, let_slots(obj), port, ci, + false); + port_write_character(port) (sc, ')', port); + } + if (is_immutable(obj)) + port_write_character(port) (sc, ')', port); + if (has_methods(obj)) + port_write_character(port) (sc, ')', port); + } + } else { /* not readable write */ + port_write_string(port) (sc, "(inlet", 6, port); + if (is_funclet(obj)) + funclet_slots_to_port(sc, obj, port, use_write, + ci); + else + slot_to_port_1(sc, let_slots(obj), port, use_write, + ci, 0); + port_write_character(port) (sc, ')', port); + } + } + } + } +} + +static void write_macro_readably(s7_scheme * sc, s7_pointer obj, + s7_pointer port) +{ + s7_pointer expr, body = closure_body(obj), arglist = closure_args(obj); + + port_write_string(port) (sc, + (is_either_macro(obj)) ? "(macro" : "(bacro", + 6, port); + if ((is_macro_star(obj)) || (is_bacro_star(obj))) + port_write_character(port) (sc, '*', port); + if (is_symbol(arglist)) { + port_write_character(port) (sc, ' ', port); + port_write_string(port) (sc, symbol_name(arglist), + symbol_name_length(arglist), port); + port_write_character(port) (sc, ' ', port); + } else if (is_pair(arglist)) { + port_write_string(port) (sc, " (", 2, port); + for (expr = arglist; is_pair(expr); expr = cdr(expr)) { + object_to_port(sc, car(expr), port, P_WRITE, NULL); + if (is_pair(cdr(expr))) + port_write_character(port) (sc, ' ', port); + } + if (!is_null(expr)) { + port_write_string(port) (sc, " . ", 3, port); + object_to_port(sc, expr, port, P_WRITE, NULL); + } + port_write_string(port) (sc, ") ", 2, port); + } else + port_write_string(port) (sc, " () ", 4, port); + + for (expr = body; is_pair(expr); expr = cdr(expr)) + object_to_port(sc, car(expr), port, P_WRITE, NULL); + port_write_character(port) (sc, ')', port); +} + + +static s7_pointer match_symbol(s7_pointer symbol, s7_pointer e) +{ + s7_pointer y, le; + for (le = e; is_let(le); le = let_outlet(le)) + for (y = let_slots(le); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == symbol) + return (y); + return (NULL); +} + +static bool slot_memq(s7_pointer symbol, s7_pointer symbols) +{ + s7_pointer x; + for (x = symbols; is_pair(x); x = cdr(x)) + if (slot_symbol(car(x)) == symbol) + return (true); + return (false); +} + +static bool arg_memq(s7_pointer symbol, s7_pointer args) +{ + s7_pointer x; + for (x = args; is_pair(x); x = cdr(x)) + if ((car(x) == symbol) || + ((is_pair(car(x))) && (caar(x) == symbol))) + return (true); + return (false); +} + +static void collect_symbol(s7_scheme * sc, s7_pointer sym, s7_pointer e, + s7_pointer args, s7_int gc_loc) +{ + if ((!arg_memq(T_Sym(sym), args)) && + (!slot_memq(sym, gc_protected_at(sc, gc_loc)))) { + s7_pointer slot; + slot = match_symbol(sym, e); + if (slot) + gc_protected_at(sc, gc_loc) = + cons(sc, slot, gc_protected_at(sc, gc_loc)); + } +} + +static void collect_locals(s7_scheme * sc, s7_pointer body, s7_pointer e, + s7_pointer args, s7_int gc_loc) +{ /* currently called only in write_closure_readably */ + if (is_pair(body)) { + collect_locals(sc, car(body), e, args, gc_loc); + collect_locals(sc, cdr(body), e, args, gc_loc); + } else if (is_symbol(body)) + collect_symbol(sc, body, e, args, gc_loc); +} + +static void collect_specials(s7_scheme * sc, s7_pointer e, s7_pointer args, + s7_int gc_loc) +{ + collect_symbol(sc, sc->local_signature_symbol, e, args, gc_loc); + collect_symbol(sc, sc->local_setter_symbol, e, args, gc_loc); + collect_symbol(sc, sc->local_documentation_symbol, e, args, gc_loc); + collect_symbol(sc, sc->local_iterator_symbol, e, args, gc_loc); +} + +static s7_pointer find_closure(s7_scheme * sc, s7_pointer closure, + s7_pointer current_let) +{ + s7_pointer e, y; + for (e = current_let; is_let(e); e = let_outlet(e)) { + if ((is_funclet(e)) || (is_maclet(e))) { + s7_pointer sym, f; + sym = funclet_function(e); + f = s7_symbol_local_value(sc, sym, e); + if (f == closure) + return (sym); + } + for (y = let_slots(e); tis_slot(y); y = next_slot(y)) + if (slot_value(y) == closure) + return (slot_symbol(y)); + } + if ((is_any_macro(closure)) && /* can't be a c_macro here */ + (has_pair_macro(closure))) /* maybe macro never called, so no maclet exists */ + return (pair_macro(closure_body(closure))); + return (sc->nil); +} + +static void write_closure_name(s7_scheme * sc, s7_pointer closure, + s7_pointer port) +{ + s7_pointer x; + x = find_closure(sc, closure, closure_let(closure)); + /* this can be confusing! + * (let ((a (lambda () 1))) a) -> # + * (letrec ((a (lambda () 1))) a) -> a + * (let () (define (a) 1) a) -> a + * (let () (define a (lambda () 1))) -> a + * (let () (define (a) (lambda () 1)) (a)) -> # + */ + if (is_symbol(x)) { /* after find_closure */ + port_write_string(port) (sc, symbol_name(x), symbol_name_length(x), + port); + return; + } + switch (type(closure)) { + case T_CLOSURE: + port_write_string(port) (sc, "#", 3, port); + else { + s7_pointer args = closure_args(closure); + if (is_symbol(args)) { + port_write_string(port) (sc, symbol_name(args), + symbol_name_length(args), port); + port_write_character(port) (sc, '>', port); /* (lambda a a) -> # */ + } else { + port_write_character(port) (sc, '(', port); + x = car(args); + if (is_pair(x)) + x = car(x); + port_write_string(port) (sc, symbol_name(x), + symbol_name_length(x), port); + if (!is_null(cdr(args))) { + s7_pointer y; + port_write_character(port) (sc, ' ', port); + if (is_pair(cdr(args))) { + y = cadr(args); + if (is_pair(y)) + y = car(y); + else if (y == sc->key_rest_symbol) { + port_write_string(port) (sc, ":rest ", 6, port); + args = cdr(args); + y = cadr(args); + if (is_pair(y)) + y = car(y); + } + } else { + port_write_string(port) (sc, ". ", 2, port); + y = cdr(args); + } + port_write_string(port) (sc, symbol_name(y), + symbol_name_length(y), port); + if ((is_pair(cdr(args))) && (!is_null(cddr(args)))) + port_write_string(port) (sc, " ...", 4, port); + } + port_write_string(port) (sc, ")>", 2, port); + } + } +} + +static s7_pointer closure_name(s7_scheme * sc, s7_pointer closure) +{ + /* this is used by the error handlers to get the current function name */ + s7_pointer x; + x = find_closure(sc, closure, sc->curlet); + if (is_symbol(x)) + return (x); + if (is_pair(current_code(sc))) + return (current_code(sc)); + return (closure); /* desperation -- the parameter list (caar here) will cause endless confusion in OP_APPLY errors! */ +} + +static s7_pointer pair_append(s7_scheme * sc, s7_pointer a, s7_pointer b) +{ + s7_pointer p = cdr(a), tp, np; + if (is_null(p)) + return (cons(sc, car(a), b)); + tp = list_1(sc, car(a)); + gc_protect_via_stack(sc, tp); + for (np = tp; is_pair(p); p = cdr(p), np = cdr(np)) + set_cdr(np, list_1(sc, car(p))); + set_cdr(np, b); + unstack(sc); + return (tp); +} + +static void write_closure_readably_1(s7_scheme * sc, s7_pointer obj, + s7_pointer arglist, s7_pointer body, + s7_pointer port) +{ + s7_int old_print_length; + s7_pointer p; + + if (type(obj) == T_CLOSURE_STAR) + port_write_string(port) (sc, "(lambda* ", 9, port); + else + port_write_string(port) (sc, "(lambda ", 8, port); + + if ((is_pair(arglist)) && (allows_other_keys(arglist))) { + sc->temp9 = + (is_null(cdr(arglist))) ? set_plist_2(sc, car(arglist), + sc->key_allow_other_keys_symbol) + : pair_append(sc, arglist, + list_1(sc, sc->key_allow_other_keys_symbol)); + object_to_port(sc, sc->temp9, port, P_WRITE, NULL); + sc->temp9 = sc->nil; + } else + object_to_port(sc, arglist, port, P_WRITE, NULL); /* here we just want the straight output (a b) not (list 'a 'b) */ + + old_print_length = sc->print_length; + sc->print_length = 1048576; + for (p = body; is_pair(p); p = cdr(p)) { + port_write_character(port) (sc, ' ', port); + object_to_port(sc, car(p), port, P_WRITE, NULL); + } + port_write_character(port) (sc, ')', port); + sc->print_length = old_print_length; +} + +static void write_closure_readably(s7_scheme * sc, s7_pointer obj, + s7_pointer port, shared_info_t * ci) +{ + s7_pointer body = closure_body(obj), arglist, pe, local_slots, setter = + NULL; + s7_int gc_loc; + + if (sc->safety > NO_SAFETY) { + if (tree_is_cyclic(sc, body)) { + port_write_string(port) (sc, "#", 32, port); /* not s7_error here! */ + return; + } + /* perhaps: if any sequence in the closure_body is cyclic, complain, but how to check without clobbering ci? + * perhaps pass ci, and use make_shared_info if ci=null else continue_shared_info? + * this can happen only if (apply lambda ... cyclic-seq ...) I think + * long-term we need to include closure_body(obj) in the top object_out make_shared_info + */ + } + arglist = closure_args(obj); + if (is_symbol(arglist)) + arglist = set_dlist_1(sc, arglist); + pe = closure_let(obj); + + gc_loc = gc_protect_1(sc, sc->nil); + collect_locals(sc, body, pe, arglist, gc_loc); /* collect locals used only here (and below) */ + collect_specials(sc, pe, arglist, gc_loc); + + if (s7_is_dilambda(obj)) { + setter = closure_setter(obj); + if (has_closure_let(setter)) { /* collect args etc so need the arglist */ + arglist = closure_args(setter); + if (is_symbol(arglist)) + arglist = set_dlist_1(sc, arglist); + collect_locals(sc, closure_body(setter), pe, arglist, gc_loc); + } + } + + local_slots = T_Lst(gc_protected_at(sc, gc_loc)); /* possibly a list of slots */ + if (!is_null(local_slots)) { + s7_pointer x; + port_write_string(port) (sc, "(let (", 6, port); + for (x = local_slots; is_pair(x); x = cdr(x)) { + s7_pointer slot; + slot = car(x); + if ((!is_any_closure(slot_value(slot))) && /* mutually referencing closures? ./snd -l snd-test 24 hits this in the effects dialogs */ + ((!has_structure(slot_value(slot))) || /* see s7test example, vector has closure that refers to vector */ + (slot_symbol(slot) == sc->local_signature_symbol))) { + port_write_character(port) (sc, '(', port); + port_write_string(port) (sc, + symbol_name(slot_symbol(slot)), + symbol_name_length(slot_symbol + (slot)), port); + port_write_character(port) (sc, ' ', port); + /* (object->string (list (let ((local 1)) (lambda (x) (+ x local)))) :readable) */ + object_to_port(sc, slot_value(slot), port, P_READABLE, + NULL); + if (is_null(cdr(x))) + port_write_character(port) (sc, ')', port); + else + port_write_string(port) (sc, ") ", 2, port); + } + } + port_write_string(port) (sc, ") ", 2, port); + } + + if (setter) + port_write_string(port) (sc, "(dilambda ", 10, port); + + write_closure_readably_1(sc, obj, closure_args(obj), body, port); + + if (setter) { + port_write_character(port) (sc, ' ', port); + if (has_closure_let(setter)) + write_closure_readably_1(sc, setter, closure_args(setter), + closure_body(setter), port); + else + object_to_port_with_circle_check(sc, setter, port, P_READABLE, + ci); + port_write_character(port) (sc, ')', port); + } + if (!is_null(local_slots)) + port_write_character(port) (sc, ')', port); + s7_gc_unprotect_at(sc, gc_loc); +} + +static void iterator_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + if (use_write == P_READABLE) { + if (iterator_is_at_end(obj)) { + switch (type(iterator_sequence(obj))) { + case T_NIL: + case T_PAIR: + port_write_string(port) (sc, "(make-iterator ())", 18, + port); + break; + case T_STRING: + port_write_string(port) (sc, "(make-iterator \"\")", 18, + port); + break; + case T_BYTE_VECTOR: + port_write_string(port) (sc, "(make-iterator #u())", 20, + port); + break; + case T_VECTOR: + port_write_string(port) (sc, "(make-iterator #())", 19, + port); + break; + case T_INT_VECTOR: + port_write_string(port) (sc, "(make-iterator #i())", 20, + port); + break; + case T_FLOAT_VECTOR: + port_write_string(port) (sc, "(make-iterator #r())", 20, + port); + break; + case T_LET: + port_write_string(port) (sc, "(make-iterator (inlet))", 23, + port); + break; + + case T_HASH_TABLE: + if (is_weak_hash_table(iterator_sequence(obj))) + port_write_string(port) (sc, + "(make-iterator (weak-hash-table))", + 33, port); + else + port_write_string(port) (sc, + "(make-iterator (hash-table))", + 28, port); + break; + + default: + port_write_string(port) (sc, "(make-iterator ())", 18, + port); + break; /* c-object?? function? */ + } + } else { + s7_pointer seq; + int32_t iter_ref; + seq = iterator_sequence(obj); + if ((ci) && + (is_cyclic(obj)) && + ((iter_ref = peek_shared_ref(ci, obj)) != 0)) { + /* basically the same as c_pointer_to_port */ + if (!is_cyclic_set(obj)) { + int32_t nlen; + char buf[128]; + if (iter_ref < 0) + iter_ref = -iter_ref; + + if (ci->init_port == sc->F) { + ci->init_port = s7_open_output_string(sc); + ci->init_loc = gc_protect_1(sc, ci->init_port); + } + port_write_string(port) (sc, "#f", 2, port); + nlen = + catstrs_direct(buf, " (set! <", + pos_int_to_str_direct(sc, iter_ref), + "> (make-iterator ", + (const char *) NULL); + port_write_string(ci->init_port) (sc, buf, nlen, + ci->init_port); + + flip_ref(ci, seq); + object_to_port_with_circle_check(sc, seq, + ci->init_port, + use_write, ci); + flip_ref(ci, seq); + + port_write_string(ci->init_port) (sc, "))\n", 3, + ci->init_port); + set_cyclic_set(obj); + return; + } + } + + if (is_string(seq)) { + char *iter_str; + s7_int len; + iter_str = + (char *) (string_value(seq) + iterator_position(obj)); + len = string_length(seq) - iterator_position(obj); + if (len == 0) + port_write_string(port) (sc, "(make-iterator \"\")", + 18, port); + else { + port_write_string(port) (sc, "(make-iterator \"", 16, + port); + if (!string_needs_slashification(iter_str, len)) + port_write_string(port) (sc, iter_str, len, port); + else + slashify_string_to_port(sc, port, iter_str, len, + NOT_IN_QUOTES); + port_write_string(port) (sc, "\")", 2, port); + } + } else { + if (is_pair(seq)) { + port_write_string(port) (sc, "(make-iterator ", 15, + port); + object_to_port_with_circle_check(sc, + iterator_current(obj), + port, use_write, ci); + port_write_character(port) (sc, ')', port); + } else { + if ((is_let(seq)) && (seq != sc->rootlet) + && (seq != sc->s7_let)) { + s7_pointer slot; + port_write_string(port) (sc, + "(let ((iter (make-iterator ", + 27, port); + object_to_port_with_circle_check(sc, seq, port, + use_write, ci); + port_write_string(port) (sc, "))) ", 4, port); + for (slot = let_slots(seq); + slot != iterator_current_slot(obj); + slot = next_slot(slot)) + port_write_string(port) (sc, "(iter) ", 7, + port); + port_write_string(port) (sc, "iter)", 5, port); + } else { + if (iterator_position(obj) > 0) + port_write_string(port) (sc, + "(let ((iter (make-iterator ", + 27, port); + else + port_write_string(port) (sc, "(make-iterator ", + 15, port); + object_to_port_with_circle_check(sc, seq, port, + use_write, ci); + if (iterator_position(obj) > 0) { + if (iterator_position(obj) == 1) + port_write_string(port) (sc, + "))) (iter) iter)", + 16, port); + else { + int32_t nlen; + char str[128]; + nlen = + catstrs_direct(str, + "))) (do ((i 0 (+ i 1))) ((= i ", + pos_int_to_str_direct + (sc, + iterator_position + (obj)), + ") iter) (iter)))", + (const char *) NULL); + port_write_string(port) (sc, str, nlen, + port); + }} else + port_write_character(port) (sc, ')', port); + } + } + } + } + } else { + const char *str; + if ((is_hash_table(iterator_sequence(obj))) + && (is_weak_hash_table(iterator_sequence(obj)))) + str = "weak-hash-table"; + else + str = type_name(sc, iterator_sequence(obj), NO_ARTICLE); + port_write_string(port) (sc, "#', port); + } +} + +static void c_pointer_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ +#define CP_BUFSIZE 128 + int32_t nlen; + char buf[CP_BUFSIZE]; + /* c-pointer is special because we can't set the type or info fields from scheme except via the c-pointer function */ + + if (use_write == P_READABLE) { + int32_t ref; + if ((ci) && + (is_cyclic(obj)) && ((ref = peek_shared_ref(ci, obj)) != 0)) { + port_write_string(port) (sc, "#f", 2, port); + if (!is_cyclic_set(obj)) { + if (ci->init_port == sc->F) { + ci->init_port = s7_open_output_string(sc); + ci->init_loc = gc_protect_1(sc, ci->init_port); + } + nlen = + snprintf(buf, CP_BUFSIZE, + " (set! <%d> (c-pointer %" p64, -ref, + (intptr_t) c_pointer(obj)); + port_write_string(ci->init_port) (sc, buf, nlen, + ci->init_port); + + if ((c_pointer_type(obj) != sc->F) || + (c_pointer_info(obj) != sc->F)) { + flip_ref(ci, c_pointer_type(obj)); + + port_write_character(ci->init_port) (sc, ' ', + ci->init_port); + object_to_port_with_circle_check(sc, + c_pointer_type(obj), + ci->init_port, + use_write, ci); + + flip_ref(ci, c_pointer_type(obj)); + flip_ref(ci, c_pointer_info(obj)); + + port_write_character(ci->init_port) (sc, ' ', + ci->init_port); + object_to_port_with_circle_check(sc, + c_pointer_info(obj), + ci->init_port, + use_write, ci); + + flip_ref(ci, c_pointer_info(obj)); + } + port_write_string(ci->init_port) (sc, "))\n", 3, + ci->init_port); + set_cyclic_set(obj); + } + } else { + nlen = + snprintf(buf, CP_BUFSIZE, "(c-pointer %" p64, + (intptr_t) c_pointer(obj)); + port_write_string(port) (sc, buf, + clamp_length(nlen, CP_BUFSIZE), port); + if ((c_pointer_type(obj) != sc->F) + || (c_pointer_info(obj) != sc->F)) { + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, c_pointer_type(obj), + port, use_write, ci); + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, c_pointer_info(obj), + port, use_write, ci); + } + port_write_character(port) (sc, ')', port); + } + } else { + if ((is_symbol(c_pointer_type(obj))) && + (symbol_name_length(c_pointer_type(obj)) < (CP_BUFSIZE / 2))) + nlen = + snprintf(buf, CP_BUFSIZE, "#<%s %p>", + symbol_name(c_pointer_type(obj)), c_pointer(obj)); + else + nlen = + snprintf(buf, CP_BUFSIZE, "#", + c_pointer(obj)); + port_write_string(port) (sc, buf, clamp_length(nlen, CP_BUFSIZE), + port); + } +} + +static void rng_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ + int32_t nlen; + char buf[128]; +#if WITH_GMP + if (use_write == P_READABLE) + nlen = snprintf(buf, 128, "#"); + else + nlen = snprintf(buf, 128, "#", obj); +#else + if (use_write == P_READABLE) + nlen = + snprintf(buf, 128, "(random-state %" PRIu64 " %" PRIu64 ")", + random_seed(obj), random_carry(obj)); + else + nlen = + snprintf(buf, 128, "#", + random_seed(obj), random_carry(obj)); +#endif + port_write_string(port) (sc, buf, clamp_length(nlen, 128), port); +} + +static void display_any(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ +#if S7_DEBUGGING + print_debugging_state(sc, obj, port); +#else + { + char *str, *tmp; + block_t *b; + s7_int nlen, len; + tmp = describe_type_bits(sc, obj); + len = 32 + safe_strlen(tmp); + b = mallocate(sc, len); + str = (char *) block_data(b); + if (is_free(obj)) + nlen = + catstrs_direct(str, "", + (const char *) NULL); + else + nlen = + catstrs_direct(str, "", + (const char *) NULL); + port_write_string(port) (sc, str, nlen, port); + free(tmp); + liberate(sc, b); + } +#endif +} + +static void unique_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ + port_write_string(port) (sc, unique_name(obj), unique_name_length(obj), + port); +} + +static void undefined_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + if ((obj != sc->undefined) && (use_write == P_READABLE)) { + port_write_string(port) (sc, "(with-input-from-string \"", 25, + port); + port_write_string(port) (sc, undefined_name(obj), + undefined_name_length(obj), port); + port_write_string(port) (sc, "\" read)", 7, port); + } else + port_write_string(port) (sc, undefined_name(obj), + undefined_name_length(obj), port); +} + +static void eof_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ + if (use_write == P_READABLE) + port_write_string(port) (sc, "(begin #)", 14, port); + else + port_write_string(port) (sc, eof_name(obj), eof_name_length(obj), + port); +} + +static void counter_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + port_write_string(port) (sc, "#", 10, port); +} + +static void integer_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + if (has_number_name(obj)) { + if (is_string_port(port)) { + if (port_position(port) + number_name_length(obj) < + port_data_size(port)) { + memcpy((void *) (port_data(port) + port_position(port)), + (void *) number_name(obj), number_name_length(obj)); + port_position(port) += number_name_length(obj); + } else + string_write_string_resized(sc, number_name(obj), + number_name_length(obj), port); + } else + port_write_string(port) (sc, number_name(obj), + number_name_length(obj), port); + } else { + s7_int nlen; + char *str; + str = integer_to_string(sc, integer(obj), &nlen); + set_number_name(obj, str, nlen); + port_write_string(port) (sc, str, nlen, port); + } +} + +static void number_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ + if (has_number_name(obj)) + port_write_string(port) (sc, number_name(obj), + number_name_length(obj), port); + else { + s7_int nlen; + char *str; + nlen = 0; + str = number_to_string_base_10(sc, obj, 0, sc->float_format_precision, 'g', &nlen, use_write); /* was 14 */ + if ((nlen < NUMBER_NAME_SIZE) && + (str[0] != 'n') && (str[0] != 'i') && + ((!(is_t_complex(obj))) || + ((!is_NaN(imag_part(obj))) && (!is_inf(imag_part(obj)))))) + set_number_name(obj, str, nlen); + port_write_string(port) (sc, str, nlen, port); + } +} + +#if WITH_GMP +static void big_number_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + s7_int nlen; + block_t *str; + nlen = 0; + str = + big_number_to_string_with_radix(sc, obj, BASE_10, 0, &nlen, + use_write); + port_write_string(port) (sc, (char *) block_data(str), nlen, port); + liberate(sc, str); +} +#endif + +static void syntax_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ + port_display(port) (sc, symbol_name(syntax_symbol(obj)), port); +} + +static void character_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + if (use_write == P_DISPLAY) + port_write_character(port) (sc, character(obj), port); + else + port_write_string(port) (sc, character_name(obj), + character_name_length(obj), port); +} + +static void closure_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + if (has_active_methods(sc, obj)) { + /* look for object->string method else fallback on ordinary case. + * can't use recursion on closure_let here because then the fallback name is #. + * this is tricky!: (display (openlet (with-let (mock-c-pointer 0) (lambda () 1)))) + * calls object->string on the closure whose closure_let is the mock-c-pointer; + * it has an object->string method that clears mock-c-pointers and tries again... + * so, display methods need to use coverlet/openlet. + */ + s7_pointer print_func; + print_func = + find_method(sc, closure_let(obj), sc->object_to_string_symbol); + if (print_func != sc->undefined) { + s7_pointer p; + p = call_method(sc, obj, print_func, set_plist_1(sc, obj)); + if (string_length(p) > 0) + port_write_string(port) (sc, string_value(p), + string_length(p), port); + return; + } + } + if (use_write == P_READABLE) + write_closure_readably(sc, obj, port, ci); + else + write_closure_name(sc, obj, port); +} + +static void macro_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ + if (use_write == P_READABLE) + write_macro_readably(sc, obj, port); + else + write_closure_name(sc, obj, port); +} + +static void c_function_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + s7_pointer sym; + sym = make_symbol(sc, c_function_name(obj)); + if ((!is_global(sym)) && + (is_slot(initial_slot(sym))) && ((use_write == P_READABLE) + || (lookup(sc, sym) != + initial_value(sym)))) { + port_write_string(port) (sc, "#_", 2, port); + port_write_string(port) (sc, c_function_name(obj), + c_function_name_length(obj), port); + return; + } + if (c_function_name_length(obj) > 0) + port_write_string(port) (sc, c_function_name(obj), + c_function_name_length(obj), port); + else + port_write_string(port) (sc, "#", 13, port); +} + +static void c_macro_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + if (c_macro_name_length(obj) > 0) + port_write_string(port) (sc, c_macro_name(obj), + c_macro_name_length(obj), port); + else + port_write_string(port) (sc, "#", 10, port); +} + +static void continuation_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + if (is_symbol(continuation_name(obj))) { + port_write_string(port) (sc, "#', port); + } else + port_write_string(port) (sc, "#", 15, port); +} + +static void goto_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ + if (is_symbol(call_exit_name(obj))) { + port_write_string(port) (sc, "#', port); + } else + port_write_string(port) (sc, "#", 7, port); +} + +static void catch_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ + port_write_string(port) (sc, "#", 8, port); +} + +static void dynamic_wind_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ + /* this can happen because (*s7* 'stack) can involve dynamic-wind markers */ + port_write_string(port) (sc, "#", 15, port); +} + +static void c_object_name_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port) +{ + port_write_string(port) (sc, + string_value(c_object_scheme_name(sc, obj)), + string_length(c_object_scheme_name(sc, obj)), + port); +} + +static void c_object_to_port(s7_scheme * sc, s7_pointer obj, + s7_pointer port, use_write_t use_write, + shared_info_t * ci) +{ +#if (!DISABLE_DEPRECATED) + if (c_object_print(sc, obj)) { + char *str; + str = ((*(c_object_print(sc, obj))) (sc, c_object_value(obj))); + port_display(port) (sc, str, port); + free(str); + return; + } +#endif + if (c_object_to_string(sc, obj)) + port_display(port) (sc, s7_string((*(c_object_to_string(sc, obj))) + (sc, + set_plist_2(sc, obj, + (use_write == + P_READABLE) ? + sc->key_readable_symbol + : sc->T))), port); + else { + if ((use_write == P_READABLE) && (c_object_to_list(sc, obj)) && /* to_list and (implicit) set are needed to reconstruct a cyclic c-object, as well as the maker (via type name) */ + (c_object_set(sc, obj))) { + s7_pointer obj_list, old_w, p; + int32_t href; + + obj_list = ((*(c_object_to_list(sc, obj))) + (sc, set_plist_1(sc, obj))); + old_w = sc->w; + sc->w = obj_list; + + if ((ci) && + (is_cyclic(obj)) && + ((href = peek_shared_ref(ci, obj)) != 0)) { + int32_t i; + if (href < 0) + href = -href; + if ((ci->defined[href]) || (port == ci->cycle_port)) { + int32_t nlen; + char buf[128]; + nlen = + catstrs_direct(buf, "<", + pos_int_to_str_direct(sc, href), + ">", (const char *) NULL); + port_write_string(port) (sc, buf, nlen, port); + return; + } + port_write_character(port) (sc, '(', port); + c_object_name_to_port(sc, obj, port); + for (i = 0, p = obj_list; is_pair(p); i++, p = cdr(p)) { + s7_pointer val; + val = car(p); + if (has_structure(val)) { + char buf[128]; + int32_t symref, len; + + port_write_string(port) (sc, " #f", 3, port); + len = + catstrs_direct(buf, " (set! (<", + pos_int_to_str_direct(sc, href), + "> ", + pos_int_to_str_direct_1(sc, i), + ") ", (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, len, + ci->cycle_port); + + symref = peek_shared_ref(ci, val); + if (symref != 0) { + if (symref < 0) + symref = -symref; + len = + catstrs_direct(buf, "<", + pos_int_to_str_direct(sc, + symref), + ">)\n", + (const char *) NULL); + port_write_string(ci->cycle_port) (sc, buf, + len, + ci->cycle_port); + } else { + object_to_port_with_circle_check(sc, val, + ci->cycle_port, + P_READABLE, + ci); + port_write_string(ci->cycle_port) (sc, ")\n", + 2, + ci->cycle_port); + } + } else { + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, val, port, + P_READABLE, ci); + } + } + } else { + port_write_character(port) (sc, '(', port); + c_object_name_to_port(sc, obj, port); + for (p = obj_list; is_pair(p); p = cdr(p)) { + s7_pointer val; + val = car(p); + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, val, port, + P_READABLE, ci); + } + } + port_write_character(port) (sc, ')', port); + sc->w = old_w; + } else { + char buf[128]; + int32_t nlen; + port_write_string(port) (sc, "#<", 2, port); + c_object_name_to_port(sc, obj, port); + nlen = snprintf(buf, 128, " %p>", obj); + port_write_string(port) (sc, buf, clamp_length(nlen, 128), + port); + }} +} + +static void slot_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ + /* the slot symbol might need (symbol...) in which case we don't want the preceding quote */ + symbol_to_port(sc, slot_symbol(obj), port, P_READABLE, ci); + port_write_character(port) (sc, ' ', port); + object_to_port_with_circle_check(sc, slot_value(obj), port, use_write, + ci); +} + +static void stack_to_port(s7_scheme * sc, s7_pointer obj, s7_pointer port, + use_write_t use_write, shared_info_t * ci) +{ + port_write_string(port) (sc, "#", 8, port); +} + +static void init_display_functions(void) +{ + int32_t i; + for (i = 0; i < 256; i++) + display_functions[i] = display_any; + display_functions[T_FLOAT_VECTOR] = float_vector_to_port; + display_functions[T_INT_VECTOR] = int_vector_to_port; + display_functions[T_BYTE_VECTOR] = byte_vector_to_port; + display_functions[T_VECTOR] = vector_to_port; + display_functions[T_PAIR] = pair_to_port; + display_functions[T_HASH_TABLE] = hash_table_to_port; + display_functions[T_ITERATOR] = iterator_to_port; + display_functions[T_LET] = let_to_port; + display_functions[T_BOOLEAN] = unique_to_port; + display_functions[T_NIL] = unique_to_port; + display_functions[T_UNUSED] = unique_to_port; + display_functions[T_UNSPECIFIED] = unique_to_port; + display_functions[T_UNDEFINED] = undefined_to_port; + display_functions[T_EOF] = eof_to_port; + display_functions[T_INPUT_PORT] = input_port_to_port; + display_functions[T_OUTPUT_PORT] = output_port_to_port; + display_functions[T_COUNTER] = counter_to_port; + display_functions[T_STACK] = stack_to_port; + display_functions[T_INTEGER] = integer_to_port; + display_functions[T_RATIO] = number_to_port; + display_functions[T_REAL] = number_to_port; + display_functions[T_COMPLEX] = number_to_port; +#if WITH_GMP + display_functions[T_BIG_INTEGER] = big_number_to_port; + display_functions[T_BIG_RATIO] = big_number_to_port; + display_functions[T_BIG_REAL] = big_number_to_port; + display_functions[T_BIG_COMPLEX] = big_number_to_port; +#endif + display_functions[T_SYMBOL] = symbol_to_port; + display_functions[T_SYNTAX] = syntax_to_port; + display_functions[T_STRING] = string_to_port; + display_functions[T_CHARACTER] = character_to_port; + display_functions[T_CLOSURE] = closure_to_port; + display_functions[T_CLOSURE_STAR] = closure_to_port; + display_functions[T_MACRO] = macro_to_port; + display_functions[T_MACRO_STAR] = macro_to_port; + display_functions[T_BACRO] = macro_to_port; + display_functions[T_BACRO_STAR] = macro_to_port; + display_functions[T_C_OPT_ARGS_FUNCTION] = c_function_to_port; + display_functions[T_C_RST_ARGS_FUNCTION] = c_function_to_port; + display_functions[T_C_ANY_ARGS_FUNCTION] = c_function_to_port; + display_functions[T_C_FUNCTION] = c_function_to_port; + display_functions[T_C_FUNCTION_STAR] = c_function_to_port; + display_functions[T_C_MACRO] = c_macro_to_port; + display_functions[T_C_POINTER] = c_pointer_to_port; + display_functions[T_RANDOM_STATE] = rng_to_port; + display_functions[T_CONTINUATION] = continuation_to_port; + display_functions[T_GOTO] = goto_to_port; + display_functions[T_CATCH] = catch_to_port; + display_functions[T_DYNAMIC_WIND] = dynamic_wind_to_port; + display_functions[T_C_OBJECT] = c_object_to_port; + display_functions[T_SLOT] = slot_to_port; +} + +static void object_to_port_with_circle_check_1(s7_scheme * sc, + s7_pointer vr, + s7_pointer port, + use_write_t use_write, + shared_info_t * ci) +{ + int32_t ref; + ref = (is_collected(vr)) ? shared_ref(ci, vr) : 0; + if (ref == 0) + object_to_port(sc, vr, port, use_write, ci); + else { + char buf[32]; + int32_t nlen; + char *p; + s7_int len; + if (ref > 0) { + if (use_write == P_READABLE) { + if (ci->defined[ref]) { + flip_ref(ci, vr); + nlen = + catstrs_direct(buf, "<", + pos_int_to_str_direct(sc, ref), ">", + (const char *) NULL); + port_write_string(port) (sc, buf, nlen, port); + return; + } + object_to_port(sc, vr, port, P_READABLE, ci); + } else { + /* "normal" printout involving #n= and #n# */ + p = pos_int_to_str(sc, (s7_int) ref, &len, '='); + *--p = '#'; + port_write_string(port) (sc, p, len, port); + object_to_port(sc, vr, port, NOT_P_DISPLAY(use_write), ci); + } + } else if (use_write == P_READABLE) { + nlen = + catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), + ">", (const char *) NULL); + port_write_string(port) (sc, buf, nlen, port); + } else { + p = pos_int_to_str(sc, (s7_int) (-ref), &len, '#'); + *--p = '#'; + port_write_string(port) (sc, p, len, port); + } + } +} + +static s7_pointer cyclic_out(s7_scheme * sc, s7_pointer obj, + s7_pointer port, shared_info_t * ci) +{ + int32_t i, ref, len; + char buf[128]; + + ci->cycle_port = s7_open_output_string(sc); + ci->cycle_loc = gc_protect_1(sc, ci->cycle_port); + + port_write_string(port) (sc, "(let (", 6, port); + for (i = 0; i < ci->top; i++) { + ref = peek_shared_ref(ci, ci->objs[i]); /* refs may be in any order */ + if (ref < 0) { + ref = -ref; + flip_ref(ci, ci->objs[i]); + } + len = + catstrs_direct(buf, (i == 0) ? "(<" : "\n (<", + pos_int_to_str_direct(sc, ref), "> ", + (const char *) NULL); + port_write_string(port) (sc, buf, len, port); + ci->defined[ref] = false; + object_to_port_with_circle_check(sc, ci->objs[i], port, P_READABLE, + ci); + port_write_character(port) (sc, ')', port); + ci->defined[ref] = true; + if (peek_shared_ref(ci, ci->objs[i]) > 0) + flip_ref(ci, ci->objs[i]); /* ref < 0 -> use <%d> in object_to_port */ + } + port_write_string(port) (sc, ")\n", 2, port); + + if (ci->init_port != sc->F) { + port_write_string(port) (sc, + (const char *) (port_data(ci->init_port)), + port_position(ci->init_port), port); + s7_close_output_port(sc, ci->init_port); + s7_gc_unprotect_at(sc, ci->init_loc); + ci->init_port = sc->F; + } + + if (port_position(ci->cycle_port) > 0) /* 0 if e.g. (object->string (object->let (rootlet)) :readable) */ + port_write_string(port) (sc, + (const char + *) (port_data(ci->cycle_port)), + port_position(ci->cycle_port), port); + s7_close_output_port(sc, ci->cycle_port); + s7_gc_unprotect_at(sc, ci->cycle_loc); + ci->cycle_port = sc->F; + + if ((is_immutable(obj)) && (!is_let(obj))) + port_write_string(port) (sc, " (immutable! ", 14, port); + else + port_write_string(port) (sc, " ", 2, port); + + ref = peek_shared_ref(ci, obj); + if (ref == 0) + object_to_port_with_circle_check(sc, obj, port, P_READABLE, ci); + else { + len = + catstrs_direct(buf, "<", + pos_int_to_str_direct(sc, + (ref < 0) ? -ref : ref), + ">", (const char *) NULL); + port_write_string(port) (sc, buf, len, port); + } + + if ((is_immutable(obj)) && (!is_let(obj))) + port_write_string(port) (sc, "))\n", 3, port); + else + port_write_string(port) (sc, ")\n", 2, port); + return (obj); +} + +static void object_out_1(s7_scheme * sc, s7_pointer obj, + s7_pointer strport, use_write_t choice) +{ + if (sc->object_out_locked) + object_to_port_with_circle_check(sc, T_Any(obj), strport, choice, + sc->circle_info); + else { + shared_info_t *ci; + ci = make_shared_info(sc, T_Any(obj), choice != P_READABLE); + if (ci) { + sc->object_out_locked = true; + if (choice == P_READABLE) + cyclic_out(sc, obj, strport, ci); + else + object_to_port_with_circle_check(sc, obj, strport, choice, + ci); + sc->object_out_locked = false; + } else + object_to_port(sc, obj, strport, choice, NULL); + } +} + +static inline s7_pointer object_out(s7_scheme * sc, s7_pointer obj, + s7_pointer strport, use_write_t choice) +{ + if ((has_structure(obj)) && (obj != sc->rootlet)) + object_out_1(sc, obj, strport, choice); + else + object_to_port(sc, obj, strport, choice, NULL); + return (obj); +} + +static s7_pointer new_format_port(s7_scheme * sc) +{ + s7_pointer x; + s7_int len = FORMAT_PORT_LENGTH; + block_t *block, *b; + + x = alloc_pointer(sc); + set_full_type(x, T_OUTPUT_PORT); + b = mallocate_port(sc); + port_block(x) = b; + port_port(x) = (port_t *) block_data(b); + port_type(x) = STRING_PORT; + port_set_closed(x, false); + port_data_size(x) = len; + port_next(x) = NULL; + block = mallocate(sc, len); + port_data(x) = (uint8_t *) (block_data(block)); + port_data_block(x) = block; + port_data(x)[0] = '\0'; + port_position(x) = 0; + port_needs_free(x) = false; + port_port(x)->pf = &output_string_functions; + return (x); +} + +static inline s7_pointer open_format_port(s7_scheme * sc) +{ + s7_pointer x; + if (!sc->format_ports) + return (new_format_port(sc)); + x = sc->format_ports; + sc->format_ports = (s7_pointer) (port_next(x)); + port_position(x) = 0; + port_data(x)[0] = '\0'; + return (x); +} + +static void close_format_port(s7_scheme * sc, s7_pointer port) +{ + port_next(port) = (struct block_t *) (sc->format_ports); + sc->format_ports = port; +} + +char *s7_object_to_c_string(s7_scheme * sc, s7_pointer obj) +{ + char *str; + s7_pointer strport; + s7_int len; + + TRACK(sc); + if ((sc->safety > NO_SAFETY) && (!s7_is_valid(sc, obj))) + s7_warn(sc, 256, "bad argument to %s: %p\n", __func__, obj); + + strport = open_format_port(sc); + object_out(sc, T_Pos(obj), strport, P_WRITE); + len = port_position(strport); + if (len == 0) { + close_format_port(sc, strport); + return (NULL); + } /* probably never happens */ + str = (char *) Malloc(len + 1); + memcpy((void *) str, (void *) port_data(strport), len); + str[len] = '\0'; + close_format_port(sc, strport); + return (str); +} + +static inline void restore_format_port(s7_scheme * sc, s7_pointer strport) +{ + block_t *block; + block = mallocate(sc, FORMAT_PORT_LENGTH); + port_data(strport) = (uint8_t *) (block_data(block)); + port_data_block(strport) = block; + port_data(strport)[0] = '\0'; + port_position(strport) = 0; + port_data_size(strport) = FORMAT_PORT_LENGTH; + port_needs_free(strport) = false; + close_format_port(sc, strport); +} + + +/* -------------------------------- object->string -------------------------------- */ +s7_pointer s7_object_to_string(s7_scheme * sc, s7_pointer obj, + bool use_write) +{ /* unavoidable backwards compatibility rigidity here */ + s7_pointer strport, res; + + if ((sc->safety > NO_SAFETY) && (!s7_is_valid(sc, obj))) + s7_warn(sc, 256, "bad argument to %s: %p\n", __func__, obj); + + strport = open_format_port(sc); + object_out(sc, obj, strport, (use_write) ? P_WRITE : P_DISPLAY); + + if (port_position(strport) >= port_data_size(strport)) + res = + block_to_string(sc, + reallocate(sc, port_data_block(strport), + port_position(strport) + 1), + port_position(strport)); + else + res = + block_to_string(sc, port_data_block(strport), + port_position(strport)); + restore_format_port(sc, strport); + return (res); +} + +static s7_pointer g_object_to_string(s7_scheme * sc, s7_pointer args) +{ +#define H_object_to_string "(object->string obj (write #t) (max-len most-positive-fixnum)) returns a string representation of obj." +#define Q_object_to_string s7_make_signature(sc, 4, sc->is_string_symbol, sc->T, s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_keyword_symbol), sc->is_integer_symbol) + + use_write_t choice; + s7_pointer obj = car(args), strport, res; + s7_int out_len, pending_max = S7_INT64_MAX; + bool old_openlets; + old_openlets = sc->has_openlets; + + if (is_not_null(cdr(args))) { + s7_pointer arg; + arg = cadr(args); + if (arg == sc->F) + choice = P_DISPLAY; + else { + if (arg == sc->T) + choice = P_WRITE; + else { + if (arg == sc->key_readable_symbol) + choice = P_READABLE; + else { + if (arg == sc->key_display_symbol) + choice = P_DISPLAY; + else { + if (arg == sc->key_write_symbol) + choice = P_WRITE; + else + return (wrong_type_argument_with_type + (sc, sc->object_to_string_symbol, 2, + arg, wrap_string(sc, + "a boolean or :readable", + 22))); + } + } + } + } + + if (is_not_null(cddr(args))) { + arg = caddr(args); + if (!s7_is_integer(arg)) { + if (choice == P_READABLE) /* (object->string #r(1 2 3) :readable "hi") */ + return (wrong_type_argument + (sc, sc->object_to_string_symbol, 3, arg, + T_INTEGER)); + return (method_or_bust + (sc, arg, sc->object_to_string_symbol, args, + T_INTEGER, 3)); + } + if (s7_integer_checked(sc, arg) < 0) + return (out_of_range + (sc, sc->object_to_string_symbol, int_three, arg, + a_non_negative_integer_string)); + pending_max = s7_integer_checked(sc, arg); + } + } else + choice = P_WRITE; + /* can't use s7_object_to_string here anymore because it assumes use_write arg is a boolean */ + + if (choice == P_READABLE) + sc->has_openlets = false; + else + check_method(sc, obj, sc->object_to_string_symbol, args); + + strport = open_format_port(sc); + sc->objstr_max_len = pending_max; + object_out(sc, obj, strport, choice); + sc->objstr_max_len = S7_INT64_MAX; + out_len = port_position(strport); + + if ((pending_max >= 0) && (out_len > pending_max)) { + s7_int i; + if (choice == P_READABLE) { /* (object->string #r(1 2 3) :readable 4) */ + close_format_port(sc, strport); + sc->has_openlets = old_openlets; + return (out_of_range + (sc, sc->object_to_string_symbol, int_three, + wrap_integer1(sc, out_len), wrap_string(sc, + "the readable string is too long", + 31))); + } + out_len = pending_max; + if (out_len < 3) { + close_format_port(sc, strport); + sc->has_openlets = old_openlets; + return (make_string_with_length(sc, "...", 3)); + } + for (i = out_len - 3; i < out_len; i++) + port_data(strport)[i] = (uint8_t) '.'; + } + if (out_len >= port_data_size(strport)) /* this can happen (but only == I think) */ + res = + block_to_string(sc, + reallocate(sc, port_data_block(strport), + out_len + 1), out_len); + else + res = block_to_string(sc, port_data_block(strport), out_len); + restore_format_port(sc, strport); + sc->has_openlets = old_openlets; + return (res); +} + + +/* -------------------------------- newline -------------------------------- */ +void s7_newline(s7_scheme * sc, s7_pointer port) +{ + if (port != sc->F) + port_write_character(port) (sc, (uint8_t) '\n', port); +} + +#define newline_char chars[(uint8_t)'\n'] + +static s7_pointer g_newline(s7_scheme * sc, s7_pointer args) +{ +#define H_newline "(newline (port (current-output-port))) writes a carriage return to the port" +#define Q_newline s7_make_signature(sc, 2, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) + + s7_pointer port; + port = (is_not_null(args)) ? car(args) : current_output_port(sc); + if (port == sc->F) + return (newline_char); + if (!is_output_port(port)) + return (method_or_bust_with_type_one_arg + (sc, port, sc->newline_symbol, args, + an_output_port_string)); + if (port_is_closed(port)) + s7_wrong_type_arg_error(sc, "newline", 1, port, + "an open output port"); + s7_newline(sc, port); + return (newline_char); /* return(sc->unspecified) until 28-Sep-17, but for example (display c) returns c */ +} + +static s7_pointer newline_p(s7_scheme * sc) +{ + s7_newline(sc, current_output_port(sc)); + return (newline_char); +} + +static s7_pointer newline_p_p(s7_scheme * sc, s7_pointer port) +{ + if (!is_output_port(port)) { + if (port == sc->F) + return (newline_char); + return (method_or_bust_with_type_one_arg_p + (sc, port, sc->newline_symbol, an_output_port_string)); + } + s7_newline(sc, port); + return (newline_char); +} + + +/* -------------------------------- write -------------------------------- */ +s7_pointer s7_write(s7_scheme * sc, s7_pointer obj, s7_pointer port) +{ + if (port != sc->F) { + if (port_is_closed(port)) + s7_wrong_type_arg_error(sc, "write", 2, port, + "an open output port"); + object_out(sc, obj, port, P_WRITE); + } + return (obj); +} + +static s7_pointer write_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer port) +{ + if (port == sc->F) + return (x); + if (!is_output_port(port)) + return (method_or_bust_with_type_pp + (sc, port, sc->write_symbol, x, port, + an_output_port_string, 2)); + if (port_is_closed(port)) + s7_wrong_type_arg_error(sc, "write", 2, port, + "an open output port"); + return (object_out(sc, x, port, P_WRITE)); +} + +static s7_pointer g_write(s7_scheme * sc, s7_pointer args) +{ +#define H_write "(write obj (port (current-output-port))) writes (object->string obj) to the output port" +#define Q_write s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) + + check_method(sc, car(args), sc->write_symbol, args); + return (write_p_pp + (sc, car(args), + (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc))); +} + +static s7_pointer write_p_p(s7_scheme * sc, s7_pointer x) +{ + return ((current_output_port(sc) == sc->F) ? x : object_out(sc, x, + current_output_port + (sc), + P_WRITE)); +} + + +/* -------------------------------- display -------------------------------- */ +s7_pointer s7_display(s7_scheme * sc, s7_pointer obj, s7_pointer port) +{ + if (port != sc->F) { + if (port_is_closed(port)) + s7_wrong_type_arg_error(sc, "display", 2, port, + "an open output port"); + object_out(sc, obj, port, P_DISPLAY); + } + return (obj); +} + +static s7_pointer display_p_pp(s7_scheme * sc, s7_pointer x, + s7_pointer port) +{ + if (port == sc->F) + return (x); + if (!is_output_port(port)) + return (method_or_bust_with_type_pp + (sc, port, sc->display_symbol, x, port, + an_output_port_string, 2)); + if (port_is_closed(port)) + s7_wrong_type_arg_error(sc, "display", 2, port, + "an open output port"); + check_method(sc, x, sc->display_symbol, set_plist_2(sc, x, port)); + return (object_out(sc, x, port, P_DISPLAY)); +} + +static s7_pointer g_display(s7_scheme * sc, s7_pointer args) +{ +#define H_display "(display obj (port (current-output-port))) prints obj" +#define Q_display s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) + return (display_p_pp + (sc, car(args), + (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc))); +} + +static s7_pointer g_display_2(s7_scheme * sc, s7_pointer args) +{ + /* calling display_p_pp here is much slower */ + s7_pointer port = cadr(args); + if (port == sc->F) + return (car(args)); + if (!is_output_port(port)) + return (method_or_bust_with_type + (sc, port, sc->display_symbol, args, an_output_port_string, + 2)); + if (port_is_closed(port)) + return (s7_wrong_type_arg_error + (sc, "display", 2, port, "an open output port")); + check_method(sc, car(args), sc->display_symbol, args); + return (object_out(sc, car(args), port, P_DISPLAY)); +} + +static s7_pointer g_display_f(s7_scheme * sc, s7_pointer args) +{ + return (car(args)); +} + +static s7_pointer display_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if (args == 2) /* not check_for_substring_temp(sc, expr) here -- display returns arg so can be immutable if substring_uncopied */ + return ((caddr(expr) == sc->F) ? sc->display_f : sc->display_2); + return (f); +} + +static s7_pointer display_p_p(s7_scheme * sc, s7_pointer x) +{ + if (current_output_port(sc) == sc->F) + return (x); + check_method(sc, x, sc->display_symbol, set_plist_1(sc, x)); + return (object_out(sc, x, current_output_port(sc), P_DISPLAY)); +} + + +/* -------------------------------- call-with-output-string -------------------------------- */ +static s7_pointer g_call_with_output_string(s7_scheme * sc, + s7_pointer args) +{ +#define H_call_with_output_string "(call-with-output-string proc) opens a string port applies proc to it, then returns the collected output" +#define Q_call_with_output_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) + + s7_pointer port, proc = car(args); + if (is_let(proc)) + check_method(sc, proc, sc->call_with_output_string_symbol, args); + if ((!is_any_procedure(proc)) || /* this disallows goto/continuation */ + (!s7_is_aritable(sc, proc, 1))) + return (method_or_bust_with_type + (sc, proc, sc->call_with_output_string_symbol, args, + wrap_string(sc, "a procedure of one argument (the port)", + 38), 1)); + + port = s7_open_output_string(sc); + push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); /* # here is a marker (needed) */ + push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port); /* args checked in call_with_exit */ + push_stack(sc, OP_APPLY, list_1_unchecked(sc, port), proc); + return (sc->F); +} + + +/* -------------------------------- call-with-output-file -------------------------------- */ +static s7_pointer g_call_with_output_file(s7_scheme * sc, s7_pointer args) +{ +#define H_call_with_output_file "(call-with-output-file filename proc) opens filename and calls proc with the output port as its argument" +#define Q_call_with_output_file sc->pl_sf + + s7_pointer port, file = car(args), proc; + if (!is_string(file)) + return (method_or_bust + (sc, file, sc->call_with_output_file_symbol, args, + T_STRING, 1)); + + proc = cadr(args); + if ((!is_any_procedure(proc)) || (!s7_is_aritable(sc, proc, 1))) + return (method_or_bust_with_type + (sc, proc, sc->call_with_output_file_symbol, args, + wrap_string(sc, "a procedure of one argument (the port)", + 38), 2)); + + port = s7_open_output_file(sc, string_value(file), "w"); + push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); /* # here is a marker (needed) */ + push_stack(sc, OP_APPLY, list_1_unchecked(sc, port), proc); + return (sc->F); +} + + +/* -------------------------------- with-output-to-string -------------------------------- */ +static s7_pointer g_with_output_to_string(s7_scheme * sc, s7_pointer args) +{ +#define H_with_output_to_string "(with-output-to-string thunk) opens a string as a temporary current-output-port, calls thunk, then returns the collected output" +#define Q_with_output_to_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) + + s7_pointer old_output_port, p = car(args); + if (!is_thunk(sc, p)) + return (method_or_bust_with_type + (sc, p, sc->with_output_to_string_symbol, args, + a_thunk_string, 1)); + + if ((is_continuation(p)) || (is_goto(p))) + return (wrong_type_argument_with_type + (sc, sc->with_output_to_string_symbol, 1, p, + a_normal_procedure_string)); + + old_output_port = current_output_port(sc); + set_current_output_port(sc, s7_open_output_string(sc)); + push_stack(sc, OP_UNWIND_OUTPUT, old_output_port, + current_output_port(sc)); + push_stack(sc, OP_GET_OUTPUT_STRING, old_output_port, + current_output_port(sc)); + push_stack(sc, OP_APPLY, sc->nil, p); + return (sc->F); +} + +/* (let () (define-macro (mac) (write "123")) (with-output-to-string mac)) + * (string-ref (with-output-to-string (lambda () (write "1234") (values (get-output-string) 1)))) + */ + + +/* -------------------------------- with-output-to-file -------------------------------- */ +static s7_pointer g_with_output_to_file(s7_scheme * sc, s7_pointer args) +{ +#define H_with_output_to_file "(with-output-to-file filename thunk) opens filename as the temporary current-output-port and calls thunk" +#define Q_with_output_to_file sc->pl_sf + + s7_pointer old_output_port, file = car(args), proc; + if (!is_string(file)) + return (method_or_bust + (sc, file, sc->with_output_to_file_symbol, args, T_STRING, + 1)); + + proc = cadr(args); + if (!is_thunk(sc, proc)) + return (method_or_bust_with_type + (sc, proc, sc->with_output_to_file_symbol, args, + a_thunk_string, 2)); + if ((is_continuation(proc)) || (is_goto(proc))) + return (wrong_type_argument_with_type + (sc, sc->with_output_to_file_symbol, 1, proc, + a_normal_procedure_string)); + + old_output_port = current_output_port(sc); + set_current_output_port(sc, + s7_open_output_file(sc, string_value(file), + "w")); + push_stack(sc, OP_UNWIND_OUTPUT, old_output_port, + current_output_port(sc)); + push_stack(sc, OP_APPLY, sc->nil, proc); + return (sc->F); +} + + +/* -------------------------------- format -------------------------------- */ +static s7_pointer format_error_1(s7_scheme * sc, s7_pointer msg, + const char *str, s7_pointer args, + format_data_t * fdat) +{ + s7_pointer x = NULL, ctrl_str; + ctrl_str = + (fdat->orig_str) ? fdat->orig_str : s7_make_string_wrapper(sc, + str); + if (fdat->loc == 0) { + if (is_pair(args)) + x = set_elist_4(sc, format_string_1, ctrl_str, args, msg); + else + x = set_elist_3(sc, format_string_2, ctrl_str, msg); + } else if (is_pair(args)) + x = set_elist_5(sc, format_string_3, ctrl_str, args, + wrap_integer1(sc, fdat->loc + 20), msg); + else + x = set_elist_4(sc, format_string_4, ctrl_str, + wrap_integer1(sc, fdat->loc + 20), msg); + if (fdat->port) { + close_format_port(sc, fdat->port); + fdat->port = NULL; + } + return (s7_error(sc, sc->format_error_symbol, x)); +} + +#define format_error(Sc, Msg, Len, Str, Args, Fdat) return(format_error_1(Sc, wrap_string(Sc, Msg, Len), Str, Args, Fdat)) +#define just_format_error(Sc, Msg, Len, Str, Args, Fdat) format_error_1(Sc, wrap_string(Sc, Msg, Len), Str, Args, Fdat) + +static void format_append_char(s7_scheme * sc, char c, s7_pointer port) +{ + port_write_character(port) (sc, c, port); + sc->format_column++; + + /* if c is #\null, is this the right thing to do? + * We used to return "1 2 3 4" because ~C was first turned into a string (empty in this case) + * (format #f "1 2~C3 4" #\null) -> "1 2" + * Clisp does this: + * (format nil "1 2~C3 4" (int-char 0)) -> "1 23 4" + * whereas sbcl says int-char is undefined, and Guile returns "1 2\x003 4" + * if -O3 compiler flag, we hit a segfault here during s7test + */ +} + +static void format_append_newline(s7_scheme * sc, s7_pointer port) +{ + port_write_character(port) (sc, '\n', port); + sc->format_column = 0; +} + +static void format_append_string(s7_scheme * sc, format_data_t * fdat, + const char *str, s7_int len, + s7_pointer port) +{ + port_write_string(port) (sc, str, len, port); + fdat->loc += len; + sc->format_column += len; +} + +static void format_append_chars(s7_scheme * sc, format_data_t * fdat, + char pad, s7_int chars, s7_pointer port) +{ + if (is_string_port(port)) { + if ((port_position(port) + chars) < port_data_size(port)) { + local_memset((char *) port_data(port) + port_position(port), + pad, chars); + port_position(port) += chars; + } else { + s7_int new_len = port_position(port) + chars; + resize_port_data(sc, port, new_len * 2); + local_memset((char *) port_data(port) + port_position(port), + pad, chars); + port_position(port) = new_len; + } + fdat->loc += chars; + sc->format_column += chars; + } else { + block_t *b; + char *str; + b = mallocate(sc, chars + 1); + str = (char *) block_data(b); + local_memset((void *) str, pad, chars); + str[chars] = '\0'; + format_append_string(sc, fdat, str, chars, port); + liberate(sc, b); + } +} + +static s7_int format_read_integer(s7_int * cur_i, s7_int str_len, + const char *str) +{ + /* we know that str[*cur_i] is a digit */ + s7_int i, lval = 0; + for (i = *cur_i; i < str_len - 1; i++) { + int32_t dig; + dig = digits[(uint8_t) str[i]]; + if (dig < 10) { +#if HAVE_OVERFLOW_CHECKS + if ((multiply_overflow(lval, 10, &lval)) || + (add_overflow(lval, dig, &lval))) + break; +#else + lval = dig + (lval * 10); +#endif + } else + break; + } + *cur_i = i; + return (lval); +} + +static void format_number(s7_scheme * sc, format_data_t * fdat, + int32_t radix, s7_int width, s7_int precision, + char float_choice, char pad, s7_pointer port) +{ + char *tmp; + block_t *b = NULL; + s7_int nlen = 0; + if (width < 0) + width = 0; + + /* precision choice depends on float_choice if it's -1 */ + if (precision < 0) { + if ((float_choice == 'e') || + (float_choice == 'f') || (float_choice == 'g')) + precision = 6; + else + /* in the "int" cases, precision depends on the arg type */ + switch (type(car(fdat->args))) { + case T_INTEGER: + case T_RATIO: + precision = 0; + break; + + default: + precision = 6; + break; + } + } + /* should (format #f "~F" 1/3) return "1/3"?? in CL it's "0.33333334" */ + + if (pad != ' ') { + char *padtmp; +#if (!WITH_GMP) + if (radix == 10) + tmp = + number_to_string_base_10(sc, car(fdat->args), width, + precision, float_choice, &nlen, + P_WRITE); + else +#endif + { + b = number_to_string_with_radix(sc, car(fdat->args), radix, + width, precision, float_choice, + &nlen); + tmp = (char *) block_data(b); + } + padtmp = tmp; + while (*padtmp == ' ') + (*(padtmp++)) = pad; + format_append_string(sc, fdat, tmp, nlen, port); + if ((WITH_GMP) || (radix != 10)) + liberate(sc, b); + } else { +#if (!WITH_GMP) + if (radix == 10) + tmp = + number_to_string_base_10(sc, car(fdat->args), width, + precision, float_choice, &nlen, + P_WRITE); + else +#endif + { + b = number_to_string_with_radix(sc, car(fdat->args), radix, + width, precision, float_choice, + &nlen); + tmp = (char *) block_data(b); + } + format_append_string(sc, fdat, tmp, nlen, port); + if ((WITH_GMP) || (radix != 10)) + liberate(sc, b); + } + fdat->args = cdr(fdat->args); + fdat->ctr++; +} + +static s7_int format_nesting(const char *str, char opener, char closer, + s7_int start, s7_int end) +{ /* start=i, end=str_len-1 */ + s7_int k, nesting = 1; + for (k = start + 2; k < end; k++) + if (str[k] == '~') { + if (str[k + 1] == closer) { + nesting--; + if (nesting == 0) + return (k - start - 1); + } else if (str[k + 1] == opener) + nesting++; + } + return (-1); +} + +static bool format_method(s7_scheme * sc, const char *str, + format_data_t * fdat, s7_pointer port) +{ + s7_pointer func, obj = car(fdat->args); + char ctrl_str[3]; + + if ((!has_active_methods(sc, obj)) || + ((func = + find_method_with_let(sc, obj, + sc->format_symbol)) == sc->undefined)) + return (false); + + ctrl_str[0] = '~'; + ctrl_str[1] = str[0]; + ctrl_str[2] = '\0'; + + if (port == obj) /* a problem! we need the openlet port for format, but that's an infinite loop when it calls format again as obj */ + call_method(sc, obj, func, + set_plist_3(sc, port, + s7_make_string_wrapper(sc, ctrl_str), + s7_make_string_wrapper(sc, + "#"))); + else + call_method(sc, obj, func, + set_plist_3(sc, port, + s7_make_string_wrapper(sc, ctrl_str), + obj)); + + fdat->args = cdr(fdat->args); + fdat->ctr++; + return (true); +} + +static s7_int format_n_arg(s7_scheme * sc, const char *str, + format_data_t * fdat, s7_pointer args) +{ + s7_int n; + + if (is_null(fdat->args)) /* (format #f "~nT") */ + just_format_error(sc, "~~N: missing argument", 21, str, args, + fdat); + if (!s7_is_integer(car(fdat->args))) + just_format_error(sc, "~~N: integer argument required", 30, str, + args, fdat); + n = s7_integer_checked(sc, car(fdat->args)); + + if (n < 0) + just_format_error(sc, "~~N value is negative?", 22, str, args, + fdat); + else if (n > sc->max_format_length) + just_format_error(sc, "~~N value is too big", 20, str, args, fdat); + + fdat->args = cdr(fdat->args); /* I don't think fdat->ctr should be incremented here -- it's for *vector-print-length* etc */ + return (n); +} + +static s7_int format_numeric_arg(s7_scheme * sc, const char *str, + s7_int str_len, format_data_t * fdat, + s7_int * i) +{ + s7_int width, old_i; + old_i = *i; + width = format_read_integer(i, str_len, str); + if (width < 0) { + if (str[old_i - 1] != ',') /* need branches here, not if-expr because just_format_error creates the permanent string */ + just_format_error(sc, "width is negative?", 18, str, + fdat->args, fdat); + else + just_format_error(sc, "precision is negative?", 22, str, + fdat->args, fdat); + } else if (width > sc->max_format_length) { + if (str[old_i - 1] != ',') + just_format_error(sc, "width is too big", 16, str, fdat->args, + fdat); + else + just_format_error(sc, "precision is too big", 20, str, + fdat->args, fdat); + } + return (width); +} + +static format_data_t *open_format_data(s7_scheme * sc) +{ + format_data_t *fdat; + sc->format_depth++; + if (sc->format_depth >= sc->num_fdats) { + int32_t k, new_num_fdats = sc->format_depth * 2; + sc->fdats = + (format_data_t **) Realloc(sc->fdats, + sizeof(format_data_t *) * + new_num_fdats); + for (k = sc->num_fdats; k < new_num_fdats; k++) + sc->fdats[k] = NULL; + sc->num_fdats = new_num_fdats; + } + fdat = sc->fdats[sc->format_depth]; + if (!fdat) { + fdat = (format_data_t *) Malloc(sizeof(format_data_t)); + sc->fdats[sc->format_depth] = fdat; + fdat->curly_len = 0; + fdat->curly_str = NULL; + fdat->ctr = 0; + } else { + if (fdat->port) + close_format_port(sc, fdat->port); + if (fdat->strport) + close_format_port(sc, fdat->strport); + } + fdat->port = NULL; + fdat->strport = NULL; + fdat->loc = 0; + fdat->curly_arg = sc->nil; + return (fdat); +} + +#if WITH_GMP +static bool is_one_or_big_one(s7_scheme * sc, s7_pointer p) +{ + if (!is_big_number(p)) + return (is_one(p)); + if (is_t_big_integer(p)) + return (mpz_cmp_ui(big_integer(p), 1) == 0); + if (is_t_big_real(p)) + return (mpfr_cmp_d(big_real(p), 1.0) == 0); + return (false); +} +#else +#define is_one_or_big_one(Sc, Num) is_one(Num) +#endif + +static s7_pointer object_to_list(s7_scheme * sc, s7_pointer obj); + +static s7_pointer format_to_port_1(s7_scheme * sc, s7_pointer port, + const char *str, s7_pointer args, + s7_pointer * next_arg, bool with_result, + bool columnized, s7_int len, + s7_pointer orig_str) +{ + s7_int i, str_len; + format_data_t *fdat; + s7_pointer deferred_port; + + if (len <= 0) { + str_len = safe_strlen(str); + if (str_len == 0) { + if (is_not_null(args)) + return (s7_error(sc, sc->format_error_symbol, + set_elist_2(sc, + wrap_string(sc, + "format control string is null, but there are arguments: ~S", + 58), args))); + return ((with_result) ? nil_string : sc->F); + } + } else + str_len = len; + + fdat = open_format_data(sc); + fdat->args = args; + fdat->orig_str = orig_str; + + if (with_result) { + deferred_port = port; + port = open_format_port(sc); + fdat->port = port; + } else + deferred_port = sc->F; + + for (i = 0; i < str_len - 1; i++) { + if ((uint8_t) (str[i]) == (uint8_t) '~') { + use_write_t use_write; + switch (str[i + 1]) { + case '%': /* -------- newline -------- */ + /* sbcl apparently accepts numeric args here (including 0) */ + if ((port_data(port)) && + (port_position(port) < port_data_size(port))) { + port_data(port)[port_position(port)++] = '\n'; + /* which is actually a bad idea, but as a desperate stopgap, I simply padded + * the string port string with 8 chars that are not in the length. + */ + sc->format_column = 0; + } else + format_append_newline(sc, port); + i++; + break; + + case '&': /* -------- conditional newline -------- */ + /* this only works if all output goes through format -- display/write for example do not update format_column */ + if (sc->format_column > 0) + format_append_newline(sc, port); + i++; + break; + + case '~': /* -------- tilde -------- */ + format_append_char(sc, '~', port); + i++; + break; + + case '\n': /* -------- trim white-space -------- so (format #f "hiho~\n") -> "hiho"! */ + for (i = i + 2; i < str_len - 1; i++) + if (!(white_space[(uint8_t) (str[i])])) { + i--; + break; + } + break; + + case '*': /* -------- ignore arg -------- */ + i++; + if (is_null(fdat->args)) /* (format #f "~*~A") */ + format_error(sc, "can't skip argument!", 20, str, args, + fdat); + fdat->args = cdr(fdat->args); + break; + + case '|': /* -------- exit if args nil or ctr > (*s7* 'print-length) -------- */ + if ((is_pair(fdat->args)) && + (fdat->ctr >= sc->print_length)) { + format_append_string(sc, fdat, " ...", 4, port); + fdat->args = sc->nil; + } + /* fall through */ + + case '^': /* -------- exit -------- */ + if (is_null(fdat->args)) { + i = str_len; + goto ALL_DONE; + } + i++; + break; + + case '@': /* -------- plural, 'y' or 'ies' -------- */ + i += 2; + if ((str[i] != 'P') && (str[i] != 'p')) + format_error(sc, "unknown '@' directive", 21, str, + args, fdat); + if (!is_pair(fdat->args)) + format_error(sc, "'@' directive argument missing", 30, + str, args, fdat); + if (!is_real(car(fdat->args))) /* CL accepts non numbers here */ + format_error(sc, + "'@P' directive argument is not a real number", + 44, str, args, fdat); + + if (!is_one_or_big_one(sc, car(fdat->args))) + format_append_string(sc, fdat, "ies", 3, port); + else + format_append_char(sc, 'y', port); + + fdat->args = cdr(fdat->args); + break; + + case 'P': + case 'p': /* -------- plural in 's' -------- */ + if (!is_pair(fdat->args)) + format_error(sc, "'P' directive argument missing", 30, + str, args, fdat); + if (!is_real(car(fdat->args))) + format_error(sc, + "'P' directive argument is not a real number", + 43, str, args, fdat); + if (!is_one_or_big_one(sc, car(fdat->args))) + format_append_char(sc, 's', port); + i++; + fdat->args = cdr(fdat->args); + break; + + case '{': /* -------- iteration -------- */ + { + s7_int curly_len; + + if (is_null(fdat->args)) + format_error(sc, "missing argument", 16, str, args, + fdat); + + if ((is_pair(car(fdat->args))) && /* any sequence is possible here */ + (s7_list_length(sc, car(fdat->args)) < 0)) /* (format #f "~{~a~e~}" (cons 1 2)) */ + format_error(sc, "~{ argument is a dotted list", + 28, str, args, fdat); + + curly_len = + format_nesting(str, '{', '}', i, str_len - 1); + + if (curly_len == -1) + format_error(sc, + "'{' directive, but no matching '}'", + 34, str, args, fdat); + if (curly_len == 1) + format_error(sc, + "~{~}' doesn't consume any arguments!", + 36, str, args, fdat); + + /* what about cons's here? I can't see any way in CL either to specify the car or cdr of a cons within the format string + * (cons 1 2) is applicable: ((cons 1 2) 0) -> 1 + * also there can be applicable objects that won't work in the map context (arg not integer etc) + */ + if (is_not_null(car(fdat->args))) { /* (format #f "~{~A ~}" ()) -> "" */ + s7_pointer curly_arg; + /* perhaps use an iterator here -- rootlet->list is expensive! */ + curly_arg = object_to_list(sc, car(fdat->args)); /* if a pair (or non-sequence), this simply returns the original */ + if (is_pair(curly_arg)) { /* (format #f "~{~A ~}" #()) -> "" */ + char *curly_str = NULL; /* this is the local (nested) format control string */ + s7_pointer orig_arg, cycle_arg; + + fdat->curly_arg = curly_arg; + orig_arg = + (curly_arg != + car(fdat->args)) ? curly_arg : sc->nil; + if (curly_len > fdat->curly_len) { + if (fdat->curly_str) + free(fdat->curly_str); + fdat->curly_len = curly_len; + fdat->curly_str = + (char *) Malloc(curly_len); + } + curly_str = fdat->curly_str; + memcpy((void *) curly_str, + (void *) (str + i + 2), curly_len - 1); + curly_str[curly_len - 1] = '\0'; + + if ((sc->format_depth < sc->num_fdats - 1) && + (sc->fdats[sc->format_depth + 1])) + sc->fdats[sc->format_depth + 1]->ctr = 0; + + /* it's not easy to use an iterator here instead of a list (so object->list isn't needed above), + * because the curly brackets may enclose multiple arguments -- we would need to use + * iterators throughout this function. + */ + cycle_arg = curly_arg; + while (is_pair(curly_arg)) { + s7_pointer new_arg = sc->nil; + format_to_port_1(sc, port, curly_str, + curly_arg, &new_arg, + false, columnized, + curly_len - 1, NULL); + if (curly_arg == new_arg) { + if (cdr(curly_arg) == curly_arg) + break; + fdat->curly_arg = sc->nil; + format_error(sc, + "'{...}' doesn't consume any arguments!", + 38, str, args, fdat); + } + curly_arg = new_arg; + if ((!is_pair(curly_arg)) + || (curly_arg == cycle_arg)) + break; + cycle_arg = cdr(cycle_arg); + format_to_port_1(sc, port, curly_str, + curly_arg, &new_arg, + false, columnized, + curly_len - 1, NULL); + curly_arg = new_arg; + } + fdat->curly_arg = sc->nil; + while (is_pair(orig_arg)) { /* free_cell below clears the type, so a circular list here is ok */ + s7_pointer p; + p = orig_arg; + orig_arg = cdr(orig_arg); + free_cell(sc, p); /* if car(fdar->args) is a hash-table, we could also free_cell(car(p)), but not in any other case */ + } + } else if (!is_null(curly_arg)) + format_error(sc, + "'{' directive argument should be a list or something we can turn into a list", + 76, str, args, fdat); + } + i += (curly_len + 2); /* jump past the ending '}' too */ + fdat->args = cdr(fdat->args); + fdat->ctr++; + } + break; + + case '}': + format_error(sc, "unmatched '}'", 13, str, args, fdat); + + case 'W': + case 'w': + use_write = P_READABLE; + goto OBJSTR; + + case 'S': + case 's': + use_write = P_WRITE; + goto OBJSTR; + + case 'A': + case 'a': + use_write = P_DISPLAY; + OBJSTR: /* object->string */ + { + s7_pointer obj, strport; + if (is_null(fdat->args)) + format_error(sc, "missing argument", 16, str, args, + fdat); + + i++; + obj = car(fdat->args); + if ((use_write == P_READABLE) || + (!has_active_methods(sc, obj)) || + (!format_method + (sc, (char *) (str + i), fdat, port))) { + bool old_openlets = sc->has_openlets; + /* for the column check, we need to know the length of the object->string output */ + if (columnized) { + strport = open_format_port(sc); + fdat->strport = strport; + } else + strport = port; + if (use_write == P_READABLE) + sc->has_openlets = false; + object_out(sc, obj, strport, use_write); + if (use_write == P_READABLE) + sc->has_openlets = old_openlets; + if (columnized) { + if (port_position(strport) >= + port_data_size(strport)) + resize_port_data(sc, strport, + port_data_size(strport) * + 2); + + port_data(strport)[port_position(strport)] = + '\0'; + if (port_position(strport) > 0) + format_append_string(sc, fdat, + (const char *) + port_data(strport), + port_position + (strport), port); + close_format_port(sc, strport); + fdat->strport = NULL; + } + fdat->args = cdr(fdat->args); + fdat->ctr++; + } + } + break; + + /* -------- numeric args -------- */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + case ',': + case 'N': + case 'n': + + case 'B': + case 'b': + case 'D': + case 'd': + case 'E': + case 'e': + case 'F': + case 'f': + case 'G': + case 'g': + case 'O': + case 'o': + case 'X': + case 'x': + + case 'T': + case 't': + case 'C': + case 'c': + { + s7_int width = -1, precision = -1; + char pad = ' '; + i++; /* str[i] == '~' */ + + if (isdigit((int32_t) (str[i]))) + width = + format_numeric_arg(sc, str, str_len, fdat, &i); + else if ((str[i] == 'N') || (str[i] == 'n')) { + i++; + width = format_n_arg(sc, str, fdat, args); + } + if (str[i] == ',') { + i++; /* is (format #f "~12,12D" 1) an error? The precision (or is it the width?) has no use here. */ + if (isdigit((int32_t) (str[i]))) + precision = + format_numeric_arg(sc, str, str_len, fdat, + &i); + else if ((str[i] == 'N') || (str[i] == 'n')) { + i++; + precision = format_n_arg(sc, str, fdat, args); + } else if (str[i] == '\'') { /* (format #f "~12,'xD" 1) -> "xxxxxxxxxxx1" */ + pad = str[i + 1]; + i += 2; + if (i >= str_len) /* (format #f "~,'") */ + format_error(sc, + "incomplete numeric argument", + 27, str, args, fdat); + } + } /* is (let ((str "~12,'xD")) (set! (str 5) #\null) (format #f str 1)) an error? */ + + switch (str[i]) { + /* -------- pad to column -------- + * are columns numbered from 1 or 0? there seems to be disagreement about this directive + * does "space over to" mean including? + */ + case 'T': + case 't': + if (width == -1) + width = 0; + if (precision == -1) + precision = 0; + if ((width > 0) || (precision > 0)) { /* (format #f "a~8Tb") */ + /* (length (substring (format #f "~%~10T.") 1)) == (length (format #f "~10T.")) + * (length (substring (format #f "~%-~10T.~%") 1)) == (length (format #f "-~10T.~%")) + */ + if (precision > 0) { + int32_t mult; + mult = (int32_t) (ceil((s7_double) (sc->format_column + 1 - width) / (s7_double) precision)); /* CLtL2 ("least positive int") */ + if (mult < 1) + mult = 1; + width += (precision * mult); + } + width -= (sc->format_column + 1); + if (width > 0) + format_append_chars(sc, fdat, pad, width, + port); + } + break; + + case 'C': + case 'c': + { + s7_pointer obj; + + if (is_null(fdat->args)) + format_error(sc, "~~C: missing argument", + 21, str, args, fdat); + /* the "~~" here and below protects against "~C" being treated as a directive */ + obj = car(fdat->args); + if (!is_character(obj)) { + if (!format_method(sc, (char *) (str + i), fdat, port)) /* i stepped forward above */ + format_error(sc, + "'C' directive requires a character argument", + 43, str, args, fdat); + } else { + /* here use_write is false, so we just add the char, not its name */ + if (width == -1) + format_append_char(sc, character(obj), + port); + else if (width > 0) + format_append_chars(sc, fdat, + character(obj), + width, port); + + fdat->args = cdr(fdat->args); + fdat->ctr++; + } + } + break; + + /* -------- numbers -------- */ + case 'F': + case 'f': + if (is_null(fdat->args)) + format_error(sc, "~~F: missing argument", 21, + str, args, fdat); + if (!(is_number(car(fdat->args)))) { + if (!format_method + (sc, (char *) (str + i), fdat, port)) + format_error(sc, + "~~F: numeric argument required", + 30, str, args, fdat); + } else + format_number(sc, fdat, 10, width, precision, + 'f', pad, port); + break; + + case 'G': + case 'g': + if (is_null(fdat->args)) + format_error(sc, "~~G: missing argument", 21, + str, args, fdat); + if (!(is_number(car(fdat->args)))) { + if (!format_method + (sc, (char *) (str + i), fdat, port)) + format_error(sc, + "~~G: numeric argument required", + 30, str, args, fdat); + } else + format_number(sc, fdat, 10, width, precision, + 'g', pad, port); + break; + + case 'E': + case 'e': + if (is_null(fdat->args)) + format_error(sc, "~~E: missing argument", 21, + str, args, fdat); + if (!(is_number(car(fdat->args)))) { + if (!format_method + (sc, (char *) (str + i), fdat, port)) + format_error(sc, + "~~E: numeric argument required", + 30, str, args, fdat); + } else + format_number(sc, fdat, 10, width, precision, + 'e', pad, port); + break; + + /* how to handle non-integer arguments in the next 4 cases? clisp just returns + * the argument: (format nil "~X" 1.25) -> "1.25" which is perverse (ClTl2 p 581: + * "if arg is not an integer, it is printed in ~A format and decimal base")!! + * I think I'll use the type of the number to choose the output format. + */ + case 'D': + case 'd': + if (is_null(fdat->args)) + format_error(sc, "~~D: missing argument", 21, + str, args, fdat); + if (!(is_number(car(fdat->args)))) { + /* (let () (require mockery.scm) (format #f "~D" ((*mock-number* 'mock-number) 123))) + * port here is a string-port, str has the width/precision data if the caller wants it, + * args is the current arg. But format_number handles fdat->args and so on, so + * I think I'll pass the format method the current control string (str), the + * current object (car(fdat->args)), and the arglist (args), and assume it will + * return a (scheme) string. + */ + if (!format_method + (sc, (char *) (str + i), fdat, port)) + format_error(sc, + "~~D: numeric argument required", + 30, str, args, fdat); + } else + format_number(sc, fdat, 10, width, precision, + 'd', pad, port); + break; + + case 'O': + case 'o': + if (is_null(fdat->args)) + format_error(sc, "~~O: missing argument", 21, + str, args, fdat); + if (!(is_number(car(fdat->args)))) { + if (!format_method + (sc, (char *) (str + i), fdat, port)) + format_error(sc, + "~~O: numeric argument required", + 30, str, args, fdat); + } else + format_number(sc, fdat, 8, width, precision, + 'o', pad, port); + break; + + case 'X': + case 'x': + if (is_null(fdat->args)) + format_error(sc, "~~X: missing argument", 21, + str, args, fdat); + if (!(is_number(car(fdat->args)))) { + if (!format_method + (sc, (char *) (str + i), fdat, port)) + format_error(sc, + "~~X: numeric argument required", + 30, str, args, fdat); + } else + format_number(sc, fdat, 16, width, precision, + 'x', pad, port); + break; + + case 'B': + case 'b': + if (is_null(fdat->args)) + format_error(sc, "~~B: missing argument", 21, + str, args, fdat); + if (!(is_number(car(fdat->args)))) { + if (!format_method + (sc, (char *) (str + i), fdat, port)) + format_error(sc, + "~~B: numeric argument required", + 30, str, args, fdat); + } else + format_number(sc, fdat, 2, width, precision, + 'b', pad, port); + break; + + default: + if (width > 0) + format_error(sc, "unused numeric argument", 23, + str, args, fdat); + format_error(sc, "unimplemented format directive", + 30, str, args, fdat); + } + } + break; + + default: + format_error(sc, "unimplemented format directive", 30, str, + args, fdat); + } + } else { /* str[i] is not #\~ */ + s7_int j, new_len; + const char *p; + + p = (char *) strchr((const char *) (str + i + 1), (int) '~'); + j = (p) ? p - str : str_len; + new_len = j - i; + + if ((port_data(port)) && + ((port_position(port) + new_len) < port_data_size(port))) { + memcpy((void *) (port_data(port) + port_position(port)), + (void *) (str + i), new_len); + port_position(port) += new_len; + } else + port_write_string(port) (sc, (char *) (str + i), new_len, + port); + fdat->loc += new_len; + sc->format_column += new_len; + i = j - 1; + }} + + ALL_DONE: + if (next_arg) + (*next_arg) = fdat->args; + else if (is_not_null(fdat->args)) + format_error(sc, "too many arguments", 18, str, args, fdat); + + if (i < str_len) { + if (str[i] == '~') + format_error(sc, "control string ends in tilde", 28, str, args, + fdat); + format_append_char(sc, str[i], port); + } + sc->format_depth--; + if (with_result) { + s7_pointer result; + if ((is_output_port(deferred_port)) && (port_position(port) > 0)) { + if (port_position(port) < port_data_size(port)) + port_data(port)[port_position(port)] = '\0'; + port_write_string(deferred_port) (sc, (const char *) + port_data(port), + port_position(port), + deferred_port); + } + if (port_position(port) < port_data_size(port)) { + block_t *block; + result = + block_to_string(sc, port_data_block(port), + port_position(port)); + port_data_size(port) = FORMAT_PORT_LENGTH; + block = mallocate(sc, FORMAT_PORT_LENGTH); + port_data_block(port) = block; + port_data(port) = (uint8_t *) (block_data(block)); + port_data(port)[0] = '\0'; + port_position(port) = 0; + } else + result = + make_string_with_length(sc, (char *) port_data(port), + port_position(port)); + close_format_port(sc, port); + fdat->port = NULL; + return (result); + } + return (sc->F); +} + +static bool is_columnizing(const char *str) +{ /* look for ~t ~,T ~,t */ + char *p; + for (p = (char *) str; (*p);) + if (*p++ == '~') { /* this is faster than strchr */ + char c; + c = *p++; + if ((c == 't') || (c == 'T')) + return (true); + if (!c) + return (false); + if ((c == ',') || ((c >= '0') && (c <= '9')) || (c == 'n') + || (c == 'N')) { + while (((c >= '0') && (c <= '9')) || (c == 'n') + || (c == 'N')) + c = *p++; + if ((c == 't') || (c == 'T')) + return (true); + if (!c) + return (false); /* ~,1 for example */ + if (c == ',') { + c = *p++; + while (((c >= '0') && (c <= '9')) || (c == 'n') + || (c == 'N')) + c = *p++; + if ((c == 't') || (c == 'T')) + return (true); + if (!c) + return (false); + } + } + } + return (false); +} + +static s7_pointer format_to_port(s7_scheme * sc, s7_pointer port, + const char *str, s7_pointer args, + bool with_result, s7_int len) +{ + if ((with_result) || (port != sc->F)) + return (format_to_port_1 + (sc, port, str, args, NULL, with_result, + true /* is_columnizing(str) */ , len, NULL)); + /* is_columnizing on every call is much slower than ignoring the issue */ + return (sc->F); +} + +static s7_pointer g_format(s7_scheme * sc, s7_pointer args) +{ +#define H_format "(format out str . args) substitutes args into str sending the result to out. Most of \ +s7's format directives are taken from CL: ~% = newline, ~& = newline if the preceding output character was \ +no a newline, ~~ = ~, ~ trims white space, ~* skips an argument, ~^ exits {} iteration if the arg list is exhausted, \ +~nT spaces over to column n, ~A prints a representation of any object, ~S is the same, but puts strings in double quotes, \ +~C prints a character, numbers are handled by ~F, ~E, ~G, ~B, ~O, ~D, and ~X with preceding numbers giving \ +spacing (and spacing character) and precision. ~{ starts an embedded format directive which is ended by ~}: \n\ +\n\ + >(format #f \"dashed: ~{~A~^-~}\" '(1 2 3))\n\ + \"dashed: 1-2-3\"\n\ +\n\ +~P inserts \"s\" if the current it is not 1 or 1.0 (use ~@P for \"ies\" or \"y\").\n\ +~B is number->string in base 2, ~O in base 8, ~D base 10, ~X base 16,\n\ +~E: (format #f \"~E\" 100.1) -> \"1.001000e+02\" (%e in C)\n\ +~F: (format #f \"~F\" 100.1) -> \"100.100000\" (%f in C)\n\ +~G: (format #f \"~G\" 100.1) -> \"100.1\" (%g in C)\n\ +\n\ +If the 'out' it is not an output port, the resultant string is returned. If it \ +is #t, the string is also sent to the current-output-port." + +#define Q_format s7_make_circular_signature(sc, 2, 3, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_boolean_symbol, sc->is_null_symbol), sc->T) + + s7_pointer pt = car(args), str; + sc->format_column = 0; + if (is_null(pt)) { + pt = current_output_port(sc); /* () -> (current-output-port) */ + if (pt == sc->F) /* otherwise () -> #f so we get a returned string, which is confusing */ + return (pt); /* but this means some error checks are skipped? */ + } + if (!((s7_is_boolean(pt)) || /* #f or #t */ + ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ + (!port_is_closed(pt))))) + return (method_or_bust_with_type + (sc, pt, sc->format_symbol, args, an_output_port_string, + 1)); + + str = cadr(args); + if (!is_string(str)) + return (method_or_bust + (sc, str, sc->format_symbol, args, T_STRING, 2)); + return (format_to_port_1 + (sc, (pt == sc->T) ? current_output_port(sc) : pt, + string_value(str), cddr(args), NULL, !is_output_port(pt), + true, string_length(str), str)); +} + +const char *s7_format(s7_scheme * sc, s7_pointer args) +{ + s7_pointer result; + result = g_format(sc, args); + return ((is_string(result)) ? string_value(result) : NULL); +} + +static s7_pointer g_format_f(s7_scheme * sc, s7_pointer args) +{ + /* port == #f, there are other args */ + s7_pointer str = cadr(args); + sc->format_column = 0; + if (!is_string(str)) + return (method_or_bust + (sc, str, sc->format_symbol, args, T_STRING, 2)); + return (format_to_port_1 + (sc, sc->F, string_value(str), cddr(args), NULL, true, true, + string_length(str), str)); +} + +static s7_pointer g_format_just_control_string(s7_scheme * sc, + s7_pointer args) +{ + s7_pointer pt = car(args), str = cadr(args); + if (pt == sc->F) + return (str); + + if (is_null(pt)) { + pt = current_output_port(sc); + if (pt == sc->F) + return (sc->F); + } + if (pt == sc->T) { + if ((current_output_port(sc) != sc->F) + && (string_length(str) != 0)) + port_write_string(sc->output_port) (sc, string_value(str), + string_length(str), + current_output_port(sc)); + return (str); + } + if ((!is_output_port(pt)) || (port_is_closed(pt))) + return (method_or_bust_with_type + (sc, pt, sc->format_symbol, args, a_format_port_string, + 1)); + + if (string_length(str) == 0) + return ((is_output_port(pt)) ? sc->F : nil_string); + + port_write_string(pt) (sc, string_value(str), string_length(str), pt); + return (sc->F); +} + +static s7_pointer g_format_as_objstr(s7_scheme * sc, s7_pointer args) +{ + s7_pointer func, obj = caddr(args); + if ((!has_active_methods(sc, obj)) || + ((func = + find_method_with_let(sc, obj, + sc->format_symbol)) == sc->undefined)) + return (s7_object_to_string(sc, obj, false)); + return (call_method + (sc, obj, func, set_plist_3(sc, sc->F, cadr(args), obj))); +} + +static s7_pointer g_format_no_column(s7_scheme * sc, s7_pointer args) +{ + s7_pointer pt = car(args), str; + if (is_null(pt)) { + pt = current_output_port(sc); + if (pt == sc->F) + return (sc->F); + } + if (!((s7_is_boolean(pt)) || ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ + (!port_is_closed(pt))))) + return (method_or_bust_with_type + (sc, pt, sc->format_symbol, args, a_format_port_string, + 1)); + + str = cadr(args); + sc->format_column = 0; + return (format_to_port_1(sc, (pt == sc->T) ? current_output_port(sc) : pt, string_value(str), cddr(args), NULL, !is_output_port(pt), /* i.e. is boolean port so we're returning a string */ + false, /* we checked in advance that it is not columnized */ + string_length(str), str)); +} + +static s7_pointer format_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if (args > 1) { + s7_pointer port = cadr(expr), str_arg = caddr(expr); + if (is_string(str_arg)) { + if ((ops) && ((args == 2) || (args == 3))) { + s7_int len; + char *orig = string_value(str_arg); + const char *p; + + + p = strchr((const char *) orig, (int) '~'); + if (!p) + return ((args == + 2) ? sc->format_just_control_string : f); + + len = string_length(str_arg); + if ((args == 2) && + (len > 1) && + (orig[len - 1] == '%') && ((p - orig) == len - 2)) { + orig[len - 2] = '\n'; + orig[len - 1] = '\0'; + string_length(str_arg) = len - 1; + return (sc->format_just_control_string); + } + + if ((args == 3) && + (len == 2) && + (port == sc->F) && + (orig[0] == '~') && + ((orig[1] == 'A') || (orig[1] == 'a'))) + return (sc->format_as_objstr); + } + /* this used to worry about optimized expr and particular cases -- why? I can't find a broken case */ + if (!is_columnizing(string_value(str_arg))) + return (sc->format_no_column); + } + if (port == sc->F) + return (sc->format_f); + } + return (f); +} + + +/* -------------------------------- system extras -------------------------------- */ + +#if WITH_SYSTEM_EXTRAS +#include + +/* -------------------------------- directory? -------------------------------- */ +static s7_pointer g_is_directory(s7_scheme * sc, s7_pointer args) +{ +#define H_is_directory "(directory? str) returns #t if str is the name of a directory" +#define Q_is_directory s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol) + + s7_pointer name = car(args); + if (!is_string(name)) + return (method_or_bust_one_arg + (sc, name, sc->is_directory_symbol, args, T_STRING)); + return (s7_make_boolean(sc, is_directory(string_value(name)))); +} + +static bool is_directory_b_7p(s7_scheme * sc, s7_pointer p) +{ + if (!is_string(p)) + simple_wrong_type_argument(sc, sc->is_directory_symbol, p, + T_STRING); + return (is_directory(string_value(p))); +} + +static bool file_probe(const char *arg) +{ +#if (!MS_WINDOWS) + return (access(arg, F_OK) == 0); +#else + int32_t fd; + fd = open(arg, O_RDONLY, 0); + if (fd == -1) + return (false); + close(fd); + return (true); +#endif +} + +/* -------------------------------- file-exists? -------------------------------- */ +static s7_pointer g_file_exists(s7_scheme * sc, s7_pointer args) +{ +#define H_file_exists "(file-exists? filename) returns #t if the file exists" +#define Q_file_exists s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol) + + s7_pointer name = car(args); + if (!is_string(name)) + return (method_or_bust_one_arg + (sc, name, sc->file_exists_symbol, args, T_STRING)); + return (s7_make_boolean(sc, file_probe(string_value(name)))); +} + +static bool file_exists_b_7p(s7_scheme * sc, s7_pointer p) +{ + if (!is_string(p)) + simple_wrong_type_argument(sc, sc->file_exists_symbol, p, + T_STRING); + return (file_probe(string_value(p))); +} + +/* -------------------------------- delete-file -------------------------------- */ +static s7_pointer g_delete_file(s7_scheme * sc, s7_pointer args) +{ +#define H_delete_file "(delete-file filename) deletes the file filename." +#define Q_delete_file s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol) + + s7_pointer name = car(args); + if (!is_string(name)) + return (method_or_bust_one_arg + (sc, name, sc->delete_file_symbol, args, T_STRING)); + return (make_integer(sc, unlink(string_value(name)))); +} + +/* -------------------------------- getenv -------------------------------- */ +static s7_pointer g_getenv(s7_scheme * sc, s7_pointer args) +{ +#define H_getenv "(getenv var) returns the value of an environment variable." +#define Q_getenv sc->pcl_s + + s7_pointer name = car(args); + if (!is_string(name)) + return (method_or_bust_one_arg + (sc, name, sc->getenv_symbol, args, T_STRING)); + return (s7_make_string(sc, getenv(string_value(name)))); +} + +/* -------------------------------- system -------------------------------- */ +static s7_pointer g_system(s7_scheme * sc, s7_pointer args) +{ +#define H_system "(system command) executes the command. If the optional second argument is #t, \ +system captures the output as a string and returns it." +#define Q_system s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol), sc->is_string_symbol, sc->is_boolean_symbol) + +#ifdef __EMSCRIPTEN__ + return s7_nil(sc); +#else + s7_pointer name = car(args); + + if (!is_string(name)) + return (method_or_bust_one_arg + (sc, name, sc->system_symbol, args, T_STRING)); + + if ((is_pair(cdr(args))) && (cadr(args) == sc->T)) { +#define BUF_SIZE 256 + char buf[BUF_SIZE]; + char *str = NULL; + int32_t cur_len = 0, full_len = 0; + FILE *fd; + + fd = popen(string_value(name), "r"); + while (fgets(buf, BUF_SIZE, fd)) { + s7_int buf_len; + buf_len = safe_strlen(buf); + if (cur_len + buf_len >= full_len) { + full_len += BUF_SIZE * 2; + str = (str) ? (char *) Realloc(str, full_len) : (char *) + Malloc(full_len); + } + memcpy((void *) (str + cur_len), (void *) buf, buf_len); + cur_len += buf_len; + } + pclose(fd); + if (str) { + block_t *b; + b = mallocate_block(sc); + block_data(b) = (void *) str; + block_set_index(b, TOP_BLOCK_LIST); + return (block_to_string(sc, b, cur_len)); + } + return (nil_string); + } + return (make_integer(sc, system(string_value(name)))); +#endif +} + + +#if (!MS_WINDOWS) +#include + +/* -------------------------------- directory->list -------------------------------- */ +static s7_pointer g_directory_to_list(s7_scheme * sc, s7_pointer args) +{ +#define H_directory_to_list "(directory->list directory) returns the contents of the directory as a list of strings (filenames)." +#define Q_directory_to_list s7_make_signature(sc, 2, sc->is_list_symbol, sc->is_string_symbol) /* can return nil */ + + s7_pointer name = car(args); + DIR *dpos; + s7_pointer result; + + if (!is_string(name)) + return (method_or_bust_one_arg_p + (sc, name, sc->directory_to_list_symbol, T_STRING)); + + sc->w = sc->nil; + if ((dpos = opendir(string_value(name)))) { + struct dirent *dirp; + while ((dirp = readdir(dpos))) + sc->w = + cons_unchecked(sc, s7_make_string(sc, dirp->d_name), + sc->w); + closedir(dpos); + } + result = sc->w; + sc->w = sc->nil; + return (result); +} + +/* -------------------------------- file-mtime -------------------------------- */ +static s7_pointer g_file_mtime(s7_scheme * sc, s7_pointer args) +{ +#define H_file_mtime "(file-mtime file): return the write date of file" +#define Q_file_mtime s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol) + + struct stat statbuf; + int32_t err; + s7_pointer name = car(args); + if (!is_string(name)) + return (method_or_bust_one_arg + (sc, name, sc->file_mtime_symbol, args, T_STRING)); + err = stat(string_value(name), &statbuf); + if (err < 0) + return (file_error + (sc, "file-mtime", strerror(errno), string_value(name))); + return (make_integer(sc, (s7_int) (statbuf.st_mtime))); +} +#endif +#endif /* with_system_extras */ + + +/* -------------------------------- lists -------------------------------- */ + +s7_pointer s7_cons(s7_scheme * sc, s7_pointer a, s7_pointer b) +{ + s7_pointer x; + new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE); + set_car(x, a); + set_cdr(x, b); + return (x); +} + +static s7_pointer cons_unchecked(s7_scheme * sc, s7_pointer a, + s7_pointer b) +{ + /* apparently slightly faster as a function? */ + s7_pointer x; + new_cell_no_check(sc, x, T_PAIR | T_SAFE_PROCEDURE); + set_car(x, a); + set_cdr(x, b); + return (x); +} + +static s7_pointer cons_unchecked_with_type(s7_scheme * sc, s7_pointer p, + s7_pointer a, s7_pointer b) +{ + /* apparently slightly faster as a function? (used only in copy_tree_with_type) */ + s7_pointer x; + new_cell_no_check(sc, x, + full_type(p) & (TYPE_MASK | T_IMMUTABLE | + T_SAFE_PROCEDURE)); + set_car(x, a); + set_cdr(x, b); + return (x); +} + +static s7_pointer permanent_cons(s7_scheme * sc, s7_pointer a, + s7_pointer b, uint64_t type) +{ + s7_pointer x; + x = alloc_pointer(sc); + set_full_type(x, type | T_UNHEAP); + set_car(x, a); + set_cdr(x, b); + return (x); +} + +static s7_pointer permanent_list(s7_scheme * sc, s7_int len) +{ + s7_int j; + s7_pointer p = sc->nil; + for (j = 0; j < len; j++) + p = permanent_cons(sc, sc->nil, p, T_PAIR | T_IMMUTABLE); + return (p); +} + +static void check_sig_entry(s7_scheme * sc, s7_pointer p, s7_int pos, + bool circle) +{ + if ((!is_normal_symbol(car(p))) && + (!s7_is_boolean(car(p))) && (!is_pair(car(p)))) { + s7_warn(sc, 512, + "s7_make_%ssignature got an invalid entry at position %" + ld64 ": (", (circle) ? "circular_" : "", pos); + set_car(p, sc->nil); + } +} + +s7_pointer s7_make_signature(s7_scheme * sc, s7_int len, ...) +{ + va_list ap; + s7_int i; + s7_pointer p, res; + + res = permanent_list(sc, len); + va_start(ap, len); + for (p = res, i = 0; is_pair(p); p = cdr(p), i++) { + set_car(p, va_arg(ap, s7_pointer)); + check_sig_entry(sc, p, i, false); + } + va_end(ap); + return ((s7_pointer) res); +} + +s7_pointer s7_make_circular_signature(s7_scheme * sc, s7_int cycle_point, + s7_int len, ...) +{ + va_list ap; + s7_int i; + s7_pointer p, res, back = NULL, end = NULL; + + res = permanent_list(sc, len); + va_start(ap, len); + for (p = res, i = 0; is_pair(p); p = cdr(p), i++) { + set_car(p, va_arg(ap, s7_pointer)); + check_sig_entry(sc, p, i, true); + if (i == cycle_point) + back = p; + if (i == (len - 1)) + end = p; + } + va_end(ap); + if (end) + set_cdr(end, back); + if (i < len) + s7_warn(sc, 256, + "s7_make_circular_signature got too few entries: %s\n", + s7_object_to_c_string(sc, res)); + return ((s7_pointer) res); +} + + +bool s7_is_pair(s7_pointer p) +{ + return (is_pair(p)); +} + +static s7_pointer is_pair_p_p(s7_scheme * sc, s7_pointer p) +{ + return ((is_pair(p)) ? sc->T : sc->F); +} + +s7_pointer s7_car(s7_pointer p) +{ + return (car(p)); +} + +s7_pointer s7_cdr(s7_pointer p) +{ + return (cdr(p)); +} + +s7_pointer s7_cadr(s7_pointer p) +{ + return (cadr(p)); +} + +s7_pointer s7_cddr(s7_pointer p) +{ + return (cddr(p)); +} + +s7_pointer s7_cdar(s7_pointer p) +{ + return (cdar(p)); +} + +s7_pointer s7_caar(s7_pointer p) +{ + return (caar(p)); +} + +s7_pointer s7_caadr(s7_pointer p) +{ + return (caadr(p)); +} + +s7_pointer s7_caddr(s7_pointer p) +{ + return (caddr(p)); +} + +s7_pointer s7_cadar(s7_pointer p) +{ + return (cadar(p)); +} + +s7_pointer s7_caaar(s7_pointer p) +{ + return (caaar(p)); +} + +s7_pointer s7_cdadr(s7_pointer p) +{ + return (cdadr(p)); +} + +s7_pointer s7_cdddr(s7_pointer p) +{ + return (cdddr(p)); +} + +s7_pointer s7_cddar(s7_pointer p) +{ + return (cddar(p)); +} + +s7_pointer s7_cdaar(s7_pointer p) +{ + return (cdaar(p)); +} + +s7_pointer s7_caaadr(s7_pointer p) +{ + return (caaadr(p)); +} + +s7_pointer s7_caaddr(s7_pointer p) +{ + return (caaddr(p)); +} + +s7_pointer s7_caadar(s7_pointer p) +{ + return (caadar(p)); +} + +s7_pointer s7_caaaar(s7_pointer p) +{ + return (caaaar(p)); +} + +s7_pointer s7_cadadr(s7_pointer p) +{ + return (cadadr(p)); +} + +s7_pointer s7_cadddr(s7_pointer p) +{ + return (cadddr(p)); +} + +s7_pointer s7_caddar(s7_pointer p) +{ + return (caddar(p)); +} + +s7_pointer s7_cadaar(s7_pointer p) +{ + return (cadaar(p)); +} + +s7_pointer s7_cdaadr(s7_pointer p) +{ + return (cdaadr(p)); +} + +s7_pointer s7_cdaddr(s7_pointer p) +{ + return (cdaddr(p)); +} + +s7_pointer s7_cdadar(s7_pointer p) +{ + return (cdadar(p)); +} + +s7_pointer s7_cdaaar(s7_pointer p) +{ + return (cdaaar(p)); +} + +s7_pointer s7_cddadr(s7_pointer p) +{ + return (cddadr(p)); +} + +s7_pointer s7_cddddr(s7_pointer p) +{ + return (cddddr(p)); +} + +s7_pointer s7_cdddar(s7_pointer p) +{ + return (cdddar(p)); +} + +s7_pointer s7_cddaar(s7_pointer p) +{ + return (cddaar(p)); +} + +s7_pointer s7_set_car(s7_pointer p, s7_pointer q) +{ + set_car(p, q); + return (q); +} + +s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q) +{ + set_cdr(p, q); + return (q); +} + + +/* -------------------------------------------------------------------------------- */ + +/* these are used in clm2xen et al under names like Xen_wrap_5_args -- they should go away! */ +s7_pointer s7_apply_1(s7_scheme * sc, s7_pointer args, + s7_pointer(*f1) (s7_pointer a1)) +{ /* not currently used */ + return (f1(car(args))); +} + +s7_pointer s7_apply_2(s7_scheme * sc, s7_pointer args, + s7_pointer(*f2) (s7_pointer a1, s7_pointer a2)) +{ + return (f2(car(args), cadr(args))); +} + +s7_pointer s7_apply_3(s7_scheme * sc, s7_pointer args, + s7_pointer(*f3) (s7_pointer a1, s7_pointer a2, + s7_pointer a3)) +{ + s7_pointer a1 = car(args); + args = cdr(args); + return (f3(a1, car(args), cadr(args))); +} + +s7_pointer s7_apply_4(s7_scheme * sc, s7_pointer args, + s7_pointer(*f4) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4)) +{ + s7_pointer a1 = car(args), a2 = cadr(args); + args = cddr(args); + return (f4(a1, a2, car(args), cadr(args))); +} + +s7_pointer s7_apply_5(s7_scheme * sc, s7_pointer args, + s7_pointer(*f5) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5)) +{ + s7_pointer a1 = car(args), a2 = cadr(args), a3, a4; + args = cddr(args); + a3 = car(args); + a4 = cadr(args); + args = cddr(args); + return (f5(a1, a2, a3, a4, car(args))); +} + +s7_pointer s7_apply_6(s7_scheme * sc, s7_pointer args, + s7_pointer(*f6) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6)) +{ + s7_pointer a1 = car(args), a2 = cadr(args), a3, a4; + args = cddr(args); + a3 = car(args); + a4 = cadr(args); + args = cddr(args); + return (f6(a1, a2, a3, a4, car(args), cadr(args))); +} + +s7_pointer s7_apply_7(s7_scheme * sc, s7_pointer args, + s7_pointer(*f7) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6, + s7_pointer a7)) +{ + s7_pointer a1 = car(args), a2 = cadr(args), a3, a4, a5, a6; + args = cddr(args); + a3 = car(args); + a4 = cadr(args); + args = cddr(args); + a5 = car(args); + a6 = cadr(args); + args = cddr(args); + return (f7(a1, a2, a3, a4, a5, a6, car(args))); +} + +s7_pointer s7_apply_8(s7_scheme * sc, s7_pointer args, + s7_pointer(*f8) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6, + s7_pointer a7, s7_pointer a8)) +{ + s7_pointer a1 = car(args), a2 = cadr(args), a3, a4, a5, a6; + args = cddr(args); + a3 = car(args); + a4 = cadr(args); + args = cddr(args); + a5 = car(args); + a6 = cadr(args); + args = cddr(args); + return (f8(a1, a2, a3, a4, a5, a6, car(args), cadr(args))); +} + +s7_pointer s7_apply_9(s7_scheme * sc, s7_pointer args, + s7_pointer(*f9) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6, + s7_pointer a7, s7_pointer a8, + s7_pointer a9)) +{ + s7_pointer a1 = car(args), a2 = cadr(args), a3, a4, a5, a6; + args = cddr(args); + a3 = car(args); + a4 = cadr(args); + args = cddr(args); + a5 = car(args); + a6 = cadr(args); + args = cddr(args); + return (f9 + (a1, a2, a3, a4, a5, a6, car(args), cadr(args), caddr(args))); +} + +s7_pointer s7_apply_n_1(s7_scheme * sc, s7_pointer args, + s7_pointer(*f1) (s7_pointer a1)) +{ + if (is_pair(args)) + return (f1(car(args))); + return (f1(sc->undefined)); +} + +s7_pointer s7_apply_n_2(s7_scheme * sc, s7_pointer args, + s7_pointer(*f2) (s7_pointer a1, s7_pointer a2)) +{ + if (is_pair(args)) + return ((is_pair(cdr(args))) ? f2(car(args), cadr(args)) : + f2(car(args), sc->undefined)); + return (f2(sc->undefined, sc->undefined)); +} + +s7_pointer s7_apply_n_3(s7_scheme * sc, s7_pointer args, + s7_pointer(*f3) (s7_pointer a1, s7_pointer a2, + s7_pointer a3)) +{ + s7_pointer a1, a2; + if (!is_pair(args)) + return (f3(sc->undefined, sc->undefined, sc->undefined)); + a1 = car(args); + args = cdr(args); + if (!is_pair(args)) + return (f3(a1, sc->undefined, sc->undefined)); + a2 = car(args); + return ((is_pair(cdr(args))) ? f3(a1, a2, cadr(args)) : + f3(a1, a2, sc->undefined)); +} + +#define apply_n_args(N) \ + do {int32_t i; s7_pointer p; for (i = 0, p = args; is_pair(p); p = cdr(p), i++) a[i] = car(p); for (; i < N; i++) a[i] = sc->undefined;} while (0) + +s7_pointer s7_apply_n_4(s7_scheme * sc, s7_pointer args, + s7_pointer(*f4) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4)) +{ + s7_pointer a[4]; + apply_n_args(4); + return (f4(a[0], a[1], a[2], a[3])); +} + +s7_pointer s7_apply_n_5(s7_scheme * sc, s7_pointer args, + s7_pointer(*f5) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5)) +{ + s7_pointer a[5]; + apply_n_args(5); + return (f5(a[0], a[1], a[2], a[3], a[4])); +} + +s7_pointer s7_apply_n_6(s7_scheme * sc, s7_pointer args, + s7_pointer(*f6) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6)) +{ + s7_pointer a[6]; + apply_n_args(6); + return (f6(a[0], a[1], a[2], a[3], a[4], a[5])); +} + +s7_pointer s7_apply_n_7(s7_scheme * sc, s7_pointer args, + s7_pointer(*f7) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6, + s7_pointer a7)) +{ + s7_pointer a[7]; + apply_n_args(7); + return (f7(a[0], a[1], a[2], a[3], a[4], a[5], a[6])); +} + +s7_pointer s7_apply_n_8(s7_scheme * sc, s7_pointer args, + s7_pointer(*f8) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6, + s7_pointer a7, s7_pointer a8)) +{ + s7_pointer a[8]; + apply_n_args(8); + return (f8(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7])); +} + +s7_pointer s7_apply_n_9(s7_scheme * sc, s7_pointer args, + s7_pointer(*f9) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6, + s7_pointer a7, s7_pointer a8, + s7_pointer a9)) +{ + s7_pointer a[9]; + apply_n_args(9); + return (f9(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], a[8])); +} + + +/* ---------------- tree-leaves ---------------- */ +static inline s7_int tree_len_1(s7_scheme * sc, s7_pointer p) +{ + s7_int sum; + for (sum = 0; is_pair(p); p = cdr(p)) { + s7_pointer cp; + cp = car(p); + if ((!is_pair(cp)) || (car(cp) == sc->quote_symbol)) + sum++; + else { + do { + s7_pointer ccp; + ccp = car(cp); + if ((!is_pair(ccp)) || (car(ccp) == sc->quote_symbol)) + sum++; + else { + do { + s7_pointer cccp; + cccp = car(ccp); + if ((!is_pair(cccp)) || + (car(cccp) == sc->quote_symbol)) + sum++; + else + sum += tree_len_1(sc, cccp); + ccp = cdr(ccp); + } while (is_pair(ccp)); + if (!is_null(ccp)) + sum++; + } + cp = cdr(cp); + } while (is_pair(cp)); + if (!is_null(cp)) + sum++; + } + } + return ((is_null(p)) ? sum : sum + 1); +} + +static inline s7_int tree_len(s7_scheme * sc, s7_pointer p) +{ + if (is_null(p)) + return (0); + if ((!is_pair(p)) || (car(p) == sc->quote_symbol)) + return (1); + return (tree_len_1(sc, p)); +} + +static s7_int tree_leaves_i_7p(s7_scheme * sc, s7_pointer p) +{ + if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, p))) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "tree-leaves: tree is cyclic: ~S", + 31), p)); + return (tree_len(sc, p)); +} + +static s7_pointer tree_leaves_p_p(s7_scheme * sc, s7_pointer tree) +{ + if ((sc->safety > NO_SAFETY) && /* repeat code to avoid extra call overhead */ + (tree_is_cyclic(sc, tree))) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "tree-leaves: tree is cyclic: ~S", + 31), tree)); + return (make_integer(sc, tree_len(sc, tree))); +} + +static s7_pointer g_tree_leaves(s7_scheme * sc, s7_pointer args) +{ +#define H_tree_leaves "(tree-leaves tree) returns the number of leaves in the tree" +#define Q_tree_leaves s7_make_signature(sc, 2, sc->is_integer_symbol, sc->T) + return (tree_leaves_p_p(sc, car(args))); +} + + +/* ---------------- tree-memq ---------------- */ +static inline bool tree_memq_1(s7_scheme * sc, s7_pointer sym, + s7_pointer tree) +{ /* sym need not be a symbol */ + if (car(tree) == sc->quote_symbol) + return ((!is_symbol(sym)) && (!is_pair(sym)) + && (is_pair(cdr(tree))) && (sym == cadr(tree))); + + do { + if (sym == car(tree)) + return (true); + + if (is_pair(car(tree))) { + s7_pointer cp = car(tree); + if (car(cp) == sc->quote_symbol) { + if ((!is_symbol(sym)) && (!is_pair(sym)) + && (is_pair(cdr(cp))) && (sym == cadr(cp))) + return (true); + } else + do { + if (sym == car(cp)) + return (true); + if ((is_pair(car(cp))) + && (tree_memq_1(sc, sym, car(cp)))) + return (true); + cp = cdr(cp); + if (sym == cp) + return (true); + } while (is_pair(cp)); + } + tree = cdr(tree); + if (sym == tree) + return (true); + } while (is_pair(tree)); + return (false); +} + +bool s7_tree_memq(s7_scheme * sc, s7_pointer sym, s7_pointer tree) +{ + if (sym == tree) + return (true); + if (!is_pair(tree)) + return (false); + if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, tree))) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "tree-memq: tree is cyclic: ~S", + 29), tree)); + return (tree_memq_1(sc, sym, tree)); +} + +static s7_pointer g_tree_memq(s7_scheme * sc, s7_pointer args) +{ +#define H_tree_memq "(tree-memq obj tree) is a tree-oriented version of memq, but returning #t if the object is in the tree." +#define Q_tree_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T) + return (make_boolean(sc, s7_tree_memq(sc, car(args), cadr(args)))); +} + + +/* ---------------- tree-set-memq ---------------- */ +static inline bool pair_set_memq(s7_scheme * sc, s7_pointer tree) +{ + while (true) { + s7_pointer p = car(tree); + if (is_symbol(p)) { + if (symbol_is_in_list(sc, p)) + return (true); + } else if ((is_unquoted_pair(p)) && (pair_set_memq(sc, p))) + return (true); + tree = cdr(tree); + if (!is_pair(tree)) + break; + } + return ((is_symbol(tree)) && (symbol_is_in_list(sc, tree))); +} + +static bool tree_set_memq(s7_scheme * sc, s7_pointer tree) +{ + if (is_symbol(tree)) + return (symbol_is_in_list(sc, tree)); + if ((!is_pair(tree)) || (car(tree) == sc->quote_symbol)) + return (false); + return (pair_set_memq(sc, tree)); +} + +static bool tree_set_memq_b_7pp(s7_scheme * sc, s7_pointer syms, + s7_pointer tree) +{ + s7_pointer p; + if (!is_pair(syms)) + return (false); + if (sc->safety > NO_SAFETY) { + if (tree_is_cyclic(sc, syms)) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "tree-set-memq: symbol list is cyclic: ~S", + 40), syms)); + if (tree_is_cyclic(sc, tree)) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "tree-set-memq: tree is cyclic: ~S", + 33), tree)); + } + clear_symbol_list(sc); + for (p = syms; is_pair(p); p = cdr(p)) + if (is_symbol(car(p))) + add_symbol_to_list(sc, car(p)); + return (tree_set_memq(sc, tree)); +} + +static s7_pointer tree_set_memq_p_pp(s7_scheme * sc, s7_pointer syms, + s7_pointer tree) +{ + return (make_boolean(sc, tree_set_memq_b_7pp(sc, syms, tree))); +} + +static s7_pointer g_tree_set_memq(s7_scheme * sc, s7_pointer args) +{ +#define H_tree_set_memq "(tree-set-memq symbols tree) returns #t if any of the list of symbols is in the tree" +#define Q_tree_set_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T) + return (make_boolean + (sc, tree_set_memq_b_7pp(sc, car(args), cadr(args)))); +} + +static s7_pointer tree_set_memq_direct(s7_scheme * sc, s7_pointer syms, + s7_pointer tree) +{ + s7_pointer p; + if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, tree))) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "tree-set-memq: tree is cyclic: ~S", + 33), tree)); + clear_symbol_list(sc); + for (p = syms; is_pair(p); p = cdr(p)) + add_symbol_to_list(sc, car(p)); + return (make_boolean(sc, tree_set_memq(sc, tree))); +} + +static s7_pointer g_tree_set_memq_1(s7_scheme * sc, s7_pointer args) +{ + return (tree_set_memq_direct(sc, car(args), cadr(args))); +} + +static s7_pointer tree_set_memq_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + if ((is_proper_quote(sc, cadr(expr))) && /* not (tree-set-memq (quote) ... */ + (is_pair(cadadr(expr)))) { + s7_pointer p; + for (p = cadadr(expr); is_pair(p); p = cdr(p)) + if (!is_symbol(car(p))) + return (f); + return (sc->tree_set_memq_syms); /* this is tree_set_memq_1 */ + } + return (f); +} + + +/* ---------------- tree-count ---------------- */ +static s7_int tree_count(s7_scheme * sc, s7_pointer x, s7_pointer p, + s7_int count) +{ + if (p == x) + return (count + 1); + if ((!is_pair(p)) || (car(p) == sc->quote_symbol)) + return (count); + return (tree_count(sc, x, cdr(p), tree_count(sc, x, car(p), count))); +} + +static inline s7_int tree_count_at_least(s7_scheme * sc, s7_pointer x, + s7_pointer p, s7_int count, + s7_int top) +{ + if (p == x) + return (count + 1); + if (!is_pair(p)) + return (count); + if (car(p) == sc->quote_symbol) + return (count); + do { + count = tree_count_at_least(sc, x, car(p), count, top); + if (count >= top) + return (count); + p = cdr(p); + if (p == x) + return (count + 1); + } while (is_pair(p)); + return (count); +} + +static s7_pointer g_tree_count(s7_scheme * sc, s7_pointer args) +{ +#define H_tree_count "(tree-count obj tree max-count) returns how many times obj is in tree (using eq?), stopping at max-count (if specified)" +#define Q_tree_count s7_make_signature(sc, 4, sc->is_integer_symbol, sc->T, sc->T, sc->is_integer_symbol) + s7_pointer obj = car(args), tree = cadr(args), count; + + if (!is_pair(tree)) { + if ((is_pair(cddr(args))) && (!s7_is_integer(caddr(args)))) + return (wrong_type_argument + (sc, sc->tree_count_symbol, 3, caddr(args), + T_INTEGER)); + /* here we need eqv? not eq? for integers: (tree-count <0-int-zero> <0-not-int-zero>) + * perhaps split tree_count|_at_least into eq?/eqv?/equal?/equivalent? cases? + * this is used primarily for symbol counts in lint.scm + */ + return ((obj == tree) ? int_one : int_zero); + } + if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, tree))) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "tree-count: tree is cyclic: ~S", + 30), tree)); + if (is_null(cddr(args))) + return (make_integer(sc, tree_count(sc, obj, tree, 0))); + count = caddr(args); + if (!s7_is_integer(count)) + return (wrong_type_argument + (sc, sc->tree_count_symbol, 3, count, T_INTEGER)); + return (make_integer + (sc, + tree_count_at_least(sc, obj, tree, 0, + s7_integer_checked(sc, count)))); +} + + +/* -------------------------------- pair? -------------------------------- */ +static s7_pointer g_is_pair(s7_scheme * sc, s7_pointer args) +{ +#define H_is_pair "(pair? obj) returns #t if obj is a pair (a non-empty list)" +#define Q_is_pair sc->pl_bt + check_boolean_method(sc, is_pair, sc->is_pair_symbol, args); +} + + +/* -------------------------------- list? -------------------------------- */ +bool s7_is_list(s7_scheme * sc, s7_pointer p) +{ + return (is_list(p)); +} + +static bool is_list_b(s7_pointer p) +{ + return ((is_pair(p)) || (type(p) == T_NIL)); +} + +static s7_pointer g_is_list(s7_scheme * sc, s7_pointer args) +{ +#define H_is_list "(list? obj) returns #t if obj is a pair or null" +#define Q_is_list sc->pl_bt +#define is_a_list(p) s7_is_list(sc, p) + check_boolean_method(sc, is_a_list, sc->is_list_symbol, args); +} + +static s7_int proper_list_length(s7_pointer a) +{ + s7_int i = 0; + s7_pointer b; + for (b = a; is_pair(b); i++, b = cdr(b)) { + }; + return (i); +} + +static s7_int proper_list_length_with_end(s7_pointer a, s7_pointer * c) +{ + s7_int i = 0; + s7_pointer b; + for (b = a; is_pair(b); i++, b = cdr(b)) { + }; + *c = b; + return (i); +} + +s7_int s7_list_length(s7_scheme * sc, s7_pointer a) +{ + /* returns -len if list is dotted, 0 if it's (directly) circular */ + s7_int i; + s7_pointer slow = a, fast = a; + + for (i = 0;; i += 2) { + if (!is_pair(fast)) + return ((is_null(fast)) ? i : -i); + + fast = cdr(fast); + if (!is_pair(fast)) + return ((is_null(fast)) ? (i + 1) : (-i - 1)); + /* if unrolled further, it's a lot slower? */ + + fast = cdr(fast); + slow = cdr(slow); + if (fast == slow) + return (0); + } + return (0); +} + +static inline s7_pointer copy_proper_list(s7_scheme * sc, s7_pointer lst) +{ + s7_pointer p, tp, np; + if (!is_pair(lst)) + return (sc->nil); + sc->u = lst; + tp = list_1(sc, car(lst)); + sc->y = tp; + for (p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np)) { + set_cdr(np, list_1_unchecked(sc, car(p))); + p = cdr(p); + if (is_pair(p)) { + np = cdr(np); + set_cdr(np, list_1_unchecked(sc, car(p))); + } else + break; + p = cdr(p); + if (is_pair(p)) { + np = cdr(np); + set_cdr(np, list_1(sc, car(p))); + } else + break; + } + sc->y = sc->nil; + sc->u = sc->nil; + return (tp); +} + +static s7_pointer copy_proper_list_with_arglist_error(s7_scheme * sc, + s7_pointer lst) +{ + s7_pointer p, tp, np; + if (is_null(lst)) + return (sc->nil); + if (!is_pair(lst)) + s7_error(sc, sc->syntax_error_symbol, + set_elist_2(sc, wrap_string(sc, "stray dot?: ~S", 14), + lst)); + sc->u = lst; + tp = list_1(sc, car(lst)); + sc->y = tp; + for (p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np)) + set_cdr(np, list_1(sc, car(p))); + sc->y = sc->nil; + sc->u = sc->nil; + if (!is_null(p)) + s7_error(sc, sc->syntax_error_symbol, + set_elist_2(sc, + wrap_string(sc, + "improper list of arguments: ~S", + 30), lst)); + return (tp); +} + +/* -------------------------------- proper-list? -------------------------------- */ +bool s7_is_proper_list(s7_scheme * sc, s7_pointer lst) +{ + /* #t if () or undotted/non-circular pair */ + s7_pointer slow = lst, fast = lst; + while (true) { + if (!is_pair(fast)) + return (is_null(fast)); /* else it's an improper list */ + LOOP_4(fast = cdr(fast); + if (!is_pair(fast)) return (is_null(fast))); + fast = cdr(fast); + slow = cdr(slow); + if (fast == slow) + return (false); + } + return (true); +} + +static s7_pointer g_is_proper_list(s7_scheme * sc, s7_pointer args) +{ +#define H_is_proper_list "(proper-list? x) returns #t is x is a list that is neither circular nor dotted." +#define Q_is_proper_list sc->pl_bt + return (make_boolean(sc, s7_is_proper_list(sc, car(args)))); +} + +static s7_pointer is_proper_list_p_p(s7_scheme * sc, s7_pointer arg) +{ + return (make_boolean(sc, s7_is_proper_list(sc, arg))); +} + +static bool is_proper_list_1(s7_scheme * sc, s7_pointer p) +{ + return ((is_pair(p)) && (is_null(cdr(p)))); +} + +static bool is_proper_list_2(s7_scheme * sc, s7_pointer p) +{ + return ((is_pair(p)) && (is_pair(cdr(p))) && (is_null(cddr(p)))); +} + +static bool is_proper_list_3(s7_scheme * sc, s7_pointer p) +{ + return ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cddr(p))) + && (is_null(cdddr(p)))); +} + +static bool is_proper_list_4(s7_scheme * sc, s7_pointer p) +{ + return (proper_list_length(p) == 4); +} + + +/* -------------------------------- make-list -------------------------------- */ +static s7_pointer make_big_list(s7_scheme * sc, s7_int len, + s7_pointer init) +{ + s7_int i; + check_free_heap_size(sc, len + 1); /* using cons_unchecked below, +1 in case we are on the trigger at the end */ + sc->value = sc->nil; + for (i = 0; i < len; i++) + sc->value = cons_unchecked(sc, init, sc->value); + return (sc->value); +} + +static inline s7_pointer make_list(s7_scheme * sc, s7_int len, + s7_pointer init) +{ + switch (len) { + case 0: + return (sc->nil); + case 1: + return (T_Pair(cons(sc, init, sc->nil))); + case 2: + return (T_Pair(cons_unchecked(sc, init, cons(sc, init, sc->nil)))); + case 3: + return (T_Pair + (cons_unchecked + (sc, init, + cons_unchecked(sc, init, cons(sc, init, sc->nil))))); + case 4: + return (T_Pair + (cons_unchecked + (sc, init, + cons_unchecked(sc, init, + cons_unchecked(sc, init, + cons(sc, init, + sc->nil)))))); + case 5: + return (T_Pair + (cons_unchecked + (sc, init, + cons_unchecked(sc, init, + cons_unchecked(sc, init, + cons_unchecked(sc, init, + cons(sc, + init, + sc->nil))))))); + case 6: + return (T_Pair + (cons_unchecked + (sc, init, + cons_unchecked(sc, init, + cons_unchecked(sc, init, + cons_unchecked(sc, init, + cons_unchecked + (sc, init, + cons(sc, + init, + sc->nil)))))))); + case 7: + return (T_Pair + (cons_unchecked + (sc, init, + cons_unchecked(sc, init, + cons_unchecked(sc, init, + cons_unchecked(sc, init, + cons_unchecked + (sc, init, + cons_unchecked + (sc, init, + cons(sc, + init, + sc->nil))))))))); + default: + return (make_big_list(sc, len, init)); + } + return (sc->nil); /* never happens, I hope */ +} + +s7_pointer s7_make_list(s7_scheme * sc, s7_int len, s7_pointer init) +{ + return (make_list(sc, len, init)); +} + +static s7_pointer protected_make_list(s7_scheme * sc, s7_int len, + s7_pointer init) +{ + sc->temp6 = make_list(sc, len, init); + return (sc->temp6); +} + +static s7_pointer make_list_p_pp(s7_scheme * sc, s7_pointer n, + s7_pointer init) +{ + s7_int len; + if (!s7_is_integer(n)) + return (method_or_bust + (sc, n, sc->make_list_symbol, set_plist_2(sc, n, init), + T_INTEGER, 1)); + + len = s7_integer_checked(sc, n); +#if WITH_GMP + if ((len == 0) && (!is_zero(sc, n))) + return (s7_out_of_range_error + (sc, "make-list", 1, n, + "big integer is too big for s7_int")); +#endif + if (len == 0) + return (sc->nil); /* what about (make-list 0 123)? */ + if ((len < 0) || (len > sc->max_list_length)) + return (out_of_range + (sc, sc->make_list_symbol, int_one, n, + (len < 0) ? its_negative_string : its_too_large_string)); + return (make_list(sc, len, init)); +} + +static s7_pointer g_make_list(s7_scheme * sc, s7_pointer args) +{ +#define H_make_list "(make-list length (initial-element #f)) returns a list of 'length' elements whose value is 'initial-element'." +#define Q_make_list s7_make_signature(sc, 3, sc->is_proper_list_symbol, sc->is_integer_symbol, sc->T) + return (make_list_p_pp + (sc, car(args), (is_pair(cdr(args))) ? cadr(args) : sc->F)); +} + + +/* -------------------------------- list-ref -------------------------------- */ +s7_pointer s7_list_ref(s7_scheme * sc, s7_pointer lst, s7_int num) +{ + s7_int i; + s7_pointer x; + for (x = lst, i = 0; (i < num) && (is_pair(x)); i++, x = cdr(x)) { + } + if ((i == num) && (is_pair(x))) + return (car(x)); + return (sc->nil); +} + +static s7_pointer list_ref_1(s7_scheme * sc, s7_pointer lst, + s7_pointer ind) +{ + s7_int i, index; + s7_pointer p; + + if (!s7_is_integer(ind)) + return (method_or_bust_pp + (sc, ind, sc->list_ref_symbol, lst, ind, T_INTEGER, 2)); + index = s7_integer_checked(sc, ind); + if ((index < 0) || (index > sc->max_list_length)) + return (out_of_range + (sc, sc->list_ref_symbol, int_two, ind, + (index < + 0) ? its_negative_string : its_too_large_string)); + + for (i = 0, p = lst; (i < index) && is_pair(p); i++, p = cdr(p)) { + } + if (is_pair(p)) + return (car(p)); + if (is_null(p)) + return (out_of_range + (sc, sc->list_ref_symbol, int_two, ind, + its_too_large_string)); + return (wrong_type_argument_with_type + (sc, sc->list_ref_symbol, 1, lst, a_proper_list_string)); +} + +static s7_pointer implicit_index(s7_scheme * sc, s7_pointer obj, + s7_pointer indices); + +static s7_pointer g_list_ref(s7_scheme * sc, s7_pointer args) +{ +#define H_list_ref "(list-ref lst i ...) returns the i-th element (0-based) of the list" +#define Q_list_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) + /* (let ((L '((1 2 3) (4 5 6)))) (list-ref L 1 2)) */ + + s7_pointer lst = car(args), inds; + if (!is_pair(lst)) + return (method_or_bust + (sc, lst, sc->list_ref_symbol, args, T_PAIR, 1)); + inds = cdr(args); + while (true) { + lst = list_ref_1(sc, lst, car(inds)); + if (is_null(cdr(inds))) + return (lst); + inds = cdr(inds); + if (!is_pair(lst)) + return (implicit_index(sc, lst, inds)); /* 9-Jan-19 */ + } +} + +static bool op_implicit_pair_ref_a(s7_scheme * sc) +{ + s7_pointer s; + s = lookup_checked(sc, car(sc->code)); + if (!is_pair(s)) { + sc->last_function = s; + return (false); + } + sc->value = list_ref_1(sc, s, fx_call(sc, cdr(sc->code))); + return (true); +} + +static bool op_implicit_pair_ref_aa(s7_scheme * sc) +{ + s7_pointer s; + s = lookup_checked(sc, car(sc->code)); + if (!is_pair(s)) { + sc->last_function = s; + return (false); + } + sc->args = fx_call(sc, cddr(sc->code)); + sc->value = + implicit_index(sc, list_ref_1(sc, s, fx_call(sc, cdr(sc->code))), + set_plist_1(sc, sc->args)); + return (true); +} + +static s7_pointer list_ref_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if (args == 2) { + s7_pointer index = caddr(expr); + if (is_t_integer(index)) { + if (integer(index) == 0) + return (sc->list_ref_at_0); + if (integer(index) == 1) + return (sc->list_ref_at_1); + if (integer(index) == 2) + return (sc->list_ref_at_2); + } + } + return (f); +} + + +/* -------------------------------- list-set! -------------------------------- */ +s7_pointer s7_list_set(s7_scheme * sc, s7_pointer lst, s7_int num, + s7_pointer val) +{ + s7_int i; + s7_pointer x; + for (x = lst, i = 0; (i < num) && (is_pair(x)); i++, x = cdr(x)) { + } + if ((i == num) && (is_pair(x))) + set_car(x, T_Pos(val)); + return (val); +} + +static s7_pointer g_list_set_1(s7_scheme * sc, s7_pointer lst, + s7_pointer args, int32_t arg_num) +{ +#define H_list_set "(list-set! lst i ... val) sets the i-th element (0-based) of the list to val" +#define Q_list_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_pair_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol) + + int32_t i; + s7_int index; + s7_pointer p, ind; + /* (let ((L '((1 2 3) (4 5 6)))) (list-set! L 1 2 32) L) */ + + if (!is_mutable_pair(lst)) + return (mutable_method_or_bust + (sc, lst, sc->list_set_symbol, set_ulist_1(sc, lst, args), + T_PAIR, 1)); + + ind = car(args); + if ((arg_num > 2) && (is_null(cdr(args)))) { + set_car(lst, ind); + return (ind); + } + if (!s7_is_integer(ind)) + return (method_or_bust + (sc, ind, sc->list_set_symbol, set_ulist_1(sc, lst, args), + T_INTEGER, 2)); + index = s7_integer_checked(sc, ind); + if ((index < 0) || (index > sc->max_list_length)) + return (out_of_range + (sc, sc->list_set_symbol, wrap_integer1(sc, arg_num), ind, + (index < + 0) ? its_negative_string : its_too_large_string)); + + for (i = 0, p = lst; (i < index) && is_pair(p); i++, p = cdr(p)) { + } + + if (!is_pair(p)) { + if (is_null(p)) + return (out_of_range + (sc, sc->list_set_symbol, wrap_integer1(sc, arg_num), + ind, its_too_large_string)); + return (wrong_type_argument_with_type + (sc, sc->list_set_symbol, 1, lst, a_proper_list_string)); + } + if (is_null(cddr(args))) + set_car(p, cadr(args)); + else { + if (!s7_is_pair(car(p))) + return (s7_wrong_number_of_args_error + (sc, "too many arguments for list-set!: ~S", args)); + return (g_list_set_1(sc, car(p), cdr(args), arg_num + 1)); + } + return (cadr(args)); +} + +static s7_pointer g_list_set(s7_scheme * sc, s7_pointer args) +{ + return (g_list_set_1(sc, car(args), cdr(args), 2)); +} + +static inline s7_pointer list_ref_p_pi_unchecked(s7_scheme * sc, + s7_pointer p1, s7_int i1) +{ + s7_pointer p; + s7_int i; + if ((i1 < 0) || (i1 > sc->max_list_length)) + out_of_range(sc, sc->list_ref_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + for (i = 0, p = p1; ((is_pair(p)) && (i < i1)); i++, p = cdr(p)); + if (!is_pair(p)) { + if (is_null(p)) + out_of_range(sc, sc->list_ref_symbol, int_two, + wrap_integer1(sc, i1), its_too_large_string); + else + simple_wrong_type_argument_with_type(sc, sc->list_ref_symbol, + p1, a_proper_list_string); + } + return (car(p)); +} + +static s7_pointer list_ref_p_pi(s7_scheme * sc, s7_pointer p1, s7_int i1) +{ + if (!is_pair(p1)) + simple_wrong_type_argument(sc, sc->list_ref_symbol, p1, T_PAIR); + return (list_ref_p_pi_unchecked(sc, p1, i1)); +} + +static inline s7_pointer list_set_p_pip_unchecked(s7_scheme * sc, + s7_pointer p1, s7_int i1, + s7_pointer p2) +{ + s7_pointer p; + s7_int i; + if ((i1 < 0) || (i1 > sc->max_list_length)) + out_of_range(sc, sc->list_set_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + for (i = 0, p = p1; ((is_pair(p)) && (i < i1)); i++, p = cdr(p)); + if (!is_pair(p)) { + if (is_null(p)) + out_of_range(sc, sc->list_set_symbol, int_two, + wrap_integer1(sc, i1), its_too_large_string); + else + simple_wrong_type_argument_with_type(sc, sc->list_set_symbol, + p1, a_proper_list_string); + } + set_car(p, p2); + return (p2); +} + +static s7_pointer list_increment_p_pip_unchecked(opt_info * o) +{ + s7_scheme *sc = opt_sc(o); + s7_pointer p = slot_value(o->v[2].p), p1, p2; + s7_int i, index; + index = integer(p); + if ((index < 0) || (index > sc->max_list_length)) + out_of_range(sc, sc->list_set_symbol, int_two, p, + (index < + 0) ? its_negative_string : its_too_large_string); + p1 = slot_value(o->v[1].p); + for (i = 0, p = p1; ((is_pair(p)) && (i < index)); i++, p = cdr(p)); + if (!is_pair(p)) { + if (is_null(p)) + out_of_range(sc, sc->list_set_symbol, int_two, + wrap_integer1(sc, index), its_too_large_string); + else + simple_wrong_type_argument_with_type(sc, sc->list_set_symbol, + p1, a_proper_list_string); + } + p2 = g_add_xi(sc, car(p), integer(o->v[3].p)); + set_car(p, p2); + return (p2); +} + +static s7_pointer list_set_p_pip(s7_scheme * sc, s7_pointer p1, s7_int i1, + s7_pointer p2) +{ + if (!is_pair(p1)) + simple_wrong_type_argument(sc, sc->list_set_symbol, p1, T_PAIR); + return (list_set_p_pip_unchecked(sc, p1, i1, p2)); +} + +static s7_pointer g_list_set_i(s7_scheme * sc, s7_pointer args) +{ + s7_pointer p, lst = car(args), val; + s7_int i, index; + if (!is_mutable_pair(lst)) + return (mutable_method_or_bust + (sc, lst, sc->list_set_symbol, args, T_PAIR, 1)); + + index = s7_integer_checked(sc, cadr(args)); + if ((index < 0) || (index > sc->max_list_length)) + return (out_of_range + (sc, sc->list_set_symbol, int_two, + wrap_integer1(sc, index), + (index < + 0) ? its_negative_string : its_too_large_string)); + + for (i = 0, p = lst; (i < index) && is_pair(p); i++, p = cdr(p)) { + } + if (!is_pair(p)) { + if (is_null(p)) + return (out_of_range + (sc, sc->list_set_symbol, int_two, + wrap_integer1(sc, index), its_too_large_string)); + return (wrong_type_argument_with_type + (sc, sc->list_set_symbol, 1, lst, a_proper_list_string)); + } + val = caddr(args); + set_car(p, val); + return (val); +} + +static s7_pointer list_set_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if ((args == 3) && + (s7_is_integer(caddr(expr))) && + (s7_integer_checked(sc, caddr(expr)) >= 0) && + (s7_integer_checked(sc, caddr(expr)) < sc->max_list_length)) + return (sc->list_set_i); + return (f); +} + + +/* -------------------------------- list-tail -------------------------------- */ +static s7_pointer list_tail_p_pp(s7_scheme * sc, s7_pointer lst, + s7_pointer p) +{ + s7_int i, index; + if (!s7_is_integer(p)) + return (method_or_bust_pp + (sc, p, sc->list_tail_symbol, lst, p, T_INTEGER, 2)); + index = s7_integer_checked(sc, p); + + if (!is_list(lst)) /* (list-tail () 0) -> () */ + return (method_or_bust_with_type_pi + (sc, lst, sc->list_tail_symbol, lst, index, + a_list_string)); + if ((index < 0) || (index > sc->max_list_length)) + return (out_of_range + (sc, sc->list_tail_symbol, int_two, + wrap_integer1(sc, index), + (index < + 0) ? its_negative_string : its_too_large_string)); + + for (i = 0; (i < index) && (is_pair(lst)); i++, lst = cdr(lst)) { + } + if (i < index) + return (out_of_range + (sc, sc->list_tail_symbol, int_two, + wrap_integer1(sc, index), its_too_large_string)); + return (lst); +} + +static s7_pointer g_list_tail(s7_scheme * sc, s7_pointer args) +{ +#define H_list_tail "(list-tail lst i) returns the list from the i-th element on" +#define Q_list_tail s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) /* #t: (list-tail '(1 . 2) 1) -> 2 */ + return (list_tail_p_pp(sc, car(args), cadr(args))); +} + + +/* -------------------------------- cons -------------------------------- */ +static s7_pointer g_cons(s7_scheme * sc, s7_pointer args) +{ +#define H_cons "(cons a b) returns a pair containing a and b" +#define Q_cons s7_make_signature(sc, 3, sc->is_pair_symbol, sc->T, sc->T) + + s7_pointer x; + new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE); + set_car(x, car(args)); + set_cdr(x, cadr(args)); + return (x); +} + +static s7_pointer cons_p_pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + s7_pointer x; + new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE); + set_car(x, p1); + set_cdr(x, p2); + return (x); +} + + +/* -------- car -------- */ + +static s7_pointer g_car(s7_scheme * sc, s7_pointer args) +{ +#define H_car "(car pair) returns the first element of the pair" +#define Q_car sc->pl_p + + s7_pointer lst = car(args); + if (is_pair(lst)) + return (car(lst)); + return (method_or_bust_one_arg(sc, lst, sc->car_symbol, args, T_PAIR)); +} + +static s7_pointer car_p_p(s7_scheme * sc, s7_pointer p) +{ + if (is_pair(p)) + return (car(p)); + return (method_or_bust_one_arg + (sc, p, sc->car_symbol, set_plist_1(sc, p), T_PAIR)); +} + +static s7_pointer g_list_ref_at_0(s7_scheme * sc, s7_pointer args) +{ + if (is_pair(car(args))) + return (caar(args)); + return (method_or_bust(sc, car(args), sc->list_ref_symbol, args, T_PAIR, 1)); /* 1=arg num if error */ +} + + +static s7_pointer g_set_car(s7_scheme * sc, s7_pointer args) +{ +#define H_set_car "(set-car! pair val) sets the pair's first element to val" +#define Q_set_car s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T) + + s7_pointer p = car(args); + if (!is_mutable_pair(p)) + return (mutable_method_or_bust + (sc, p, sc->set_car_symbol, args, T_PAIR, 1)); + set_car(p, cadr(args)); + return (car(p)); +} + +static Inline s7_pointer inline_set_car(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + if (!is_mutable_pair(p1)) + return (mutable_method_or_bust + (sc, p1, sc->set_car_symbol, set_plist_1(sc, p1), T_PAIR, + 1)); + set_car(p1, p2); + return (p2); +} + +static s7_pointer set_car_p_pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + return (inline_set_car(sc, p1, p2)); +} + + +/* -------- cdr -------- */ +static s7_pointer g_cdr(s7_scheme * sc, s7_pointer args) +{ +#define H_cdr "(cdr pair) returns the second element of the pair" +#define Q_cdr sc->pl_p + + s7_pointer lst = car(args); + if (is_pair(lst)) + return (cdr(lst)); + return (method_or_bust_one_arg(sc, lst, sc->cdr_symbol, args, T_PAIR)); +} + +static s7_pointer cdr_p_p(s7_scheme * sc, s7_pointer p) +{ + if (is_pair(p)) + return (cdr(p)); + return (method_or_bust_one_arg + (sc, p, sc->cdr_symbol, set_plist_1(sc, p), T_PAIR)); +} + + +static s7_pointer g_set_cdr(s7_scheme * sc, s7_pointer args) +{ +#define H_set_cdr "(set-cdr! pair val) sets the pair's second element to val" +#define Q_set_cdr s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T) + + s7_pointer p = car(args); + if (!is_mutable_pair(p)) + return (mutable_method_or_bust + (sc, p, sc->set_cdr_symbol, args, T_PAIR, 1)); + set_cdr(p, cadr(args)); + return (cdr(p)); +} + +static Inline s7_pointer inline_set_cdr(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + if (!is_mutable_pair(p1)) + return (mutable_method_or_bust + (sc, p1, sc->set_cdr_symbol, set_plist_1(sc, p1), T_PAIR, + 1)); + set_cdr(p1, p2); + return (p2); +} + +static s7_pointer set_cdr_p_pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + return (inline_set_cdr(sc, p1, p2)); +} + + +/* -------- caar --------*/ +static s7_pointer g_caar(s7_scheme * sc, s7_pointer args) +{ +#define H_caar "(caar lst) returns (car (car lst)): (caar '((1 2))) -> 1" +#define Q_caar sc->pl_p + + s7_pointer lst = car(args); + /* it makes no difference in timing to move lst here or below (i.e. lst=car(lst) then return(car(lst)) and so on) */ + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->caar_symbol, args, T_PAIR)); + return ((is_pair(car(lst))) ? caar(lst) : + simple_wrong_type_argument_with_type(sc, sc->caar_symbol, lst, + car_a_list_string)); +} + +static s7_pointer caar_p_p(s7_scheme * sc, s7_pointer p) +{ + if ((is_pair(p)) && (is_pair(car(p)))) + return (caar(p)); + if (!is_pair(p)) + return (method_or_bust_one_arg + (sc, p, sc->caar_symbol, set_plist_1(sc, p), T_PAIR)); + return (simple_wrong_type_argument_with_type + (sc, sc->caar_symbol, p, car_a_list_string)); +} + + +/* -------- cadr --------*/ +static s7_pointer g_cadr(s7_scheme * sc, s7_pointer args) +{ +#define H_cadr "(cadr lst) returns (car (cdr lst)): (cadr '(1 2 3)) -> 2" +#define Q_cadr sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cadr_symbol, args, T_PAIR)); + return ((is_pair(cdr(lst))) ? cadr(lst) : + simple_wrong_type_argument_with_type(sc, sc->cadr_symbol, lst, + cdr_a_list_string)); +} + +static s7_pointer cadr_p_p(s7_scheme * sc, s7_pointer p) +{ + if ((is_pair(p)) && (is_pair(cdr(p)))) + return (cadr(p)); + if (!is_pair(p)) + return (method_or_bust_one_arg + (sc, p, sc->cadr_symbol, set_plist_1(sc, p), T_PAIR)); + return (simple_wrong_type_argument_with_type + (sc, sc->cadr_symbol, p, cdr_a_list_string)); +} + +static s7_pointer g_list_ref_at_1(s7_scheme * sc, s7_pointer args) +{ + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust + (sc, lst, sc->list_ref_symbol, args, T_PAIR, 1)); + if (is_pair(cdr(lst))) + return (cadr(lst)); + return (out_of_range + (sc, sc->list_ref_symbol, int_two, cadr(args), + its_too_large_string)); +} + + +/* -------- cdar -------- */ +static s7_pointer g_cdar(s7_scheme * sc, s7_pointer args) +{ +#define H_cdar "(cdar lst) returns (cdr (car lst)): (cdar '((1 2 3))) -> '(2 3)" +#define Q_cdar sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cdar_symbol, args, T_PAIR)); + return ((is_pair(car(lst))) ? cdar(lst) : + simple_wrong_type_argument_with_type(sc, sc->cdar_symbol, lst, + car_a_list_string)); +} + +static s7_pointer cdar_p_p(s7_scheme * sc, s7_pointer p) +{ + if ((is_pair(p)) && (is_pair(car(p)))) + return (cdar(p)); + if (!is_pair(p)) + return (method_or_bust_one_arg + (sc, p, sc->cdar_symbol, set_plist_1(sc, p), T_PAIR)); + return (simple_wrong_type_argument_with_type + (sc, sc->cdar_symbol, p, car_a_list_string)); +} + + +/* -------- cddr -------- */ +static s7_pointer g_cddr(s7_scheme * sc, s7_pointer args) +{ +#define H_cddr "(cddr lst) returns (cdr (cdr lst)): (cddr '(1 2 3 4)) -> '(3 4)" +#define Q_cddr sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cddr_symbol, args, T_PAIR)); + return ((is_pair(cdr(lst))) ? cddr(lst) : + simple_wrong_type_argument_with_type(sc, sc->cddr_symbol, lst, + cdr_a_list_string)); +} + +static s7_pointer cddr_p_p(s7_scheme * sc, s7_pointer p) +{ + if ((is_pair(p)) && (is_pair(cdr(p)))) + return (cddr(p)); + if (!is_pair(p)) + return (method_or_bust_one_arg + (sc, p, sc->cddr_symbol, set_plist_1(sc, p), T_PAIR)); + return (simple_wrong_type_argument_with_type + (sc, sc->cddr_symbol, p, cdr_a_list_string)); +} + +/* -------- caaar -------- */ +static s7_pointer caaar_p_p(s7_scheme * sc, s7_pointer lst) +{ + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->caaar_symbol, set_plist_1(sc, lst), T_PAIR)); + if (!is_pair(car(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caaar_symbol, lst, car_a_list_string)); + return ((is_pair(caar(lst))) ? caaar(lst) : + simple_wrong_type_argument_with_type(sc, sc->caaar_symbol, lst, + caar_a_list_string)); +} + +static s7_pointer g_caaar(s7_scheme * sc, s7_pointer args) +{ +#define H_caaar "(caaar lst) returns (car (car (car lst))): (caaar '(((1 2)))) -> 1" +#define Q_caaar sc->pl_p + return (caaar_p_p(sc, car(args))); +} + +/* -------- caadr -------- */ +static s7_pointer caadr_p_p(s7_scheme * sc, s7_pointer p) +{ + if ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cadr(p)))) + return (caadr(p)); + if (!is_pair(p)) + return (method_or_bust_one_arg + (sc, p, sc->caadr_symbol, set_plist_1(sc, p), T_PAIR)); + if (!is_pair(cdr(p))) + return (simple_wrong_type_argument_with_type + (sc, sc->caadr_symbol, p, cdr_a_list_string)); + return (simple_wrong_type_argument_with_type + (sc, sc->caadr_symbol, p, cadr_a_list_string)); +} + +static s7_pointer g_caadr(s7_scheme * sc, s7_pointer args) +{ +#define H_caadr "(caadr lst) returns (car (car (cdr lst))): (caadr '(1 (2 3))) -> 2" +#define Q_caadr sc->pl_p + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->caadr_symbol, args, T_PAIR)); + if (!is_pair(cdr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caadr_symbol, lst, cdr_a_list_string)); + return ((is_pair(cadr(lst))) ? caadr(lst) : + simple_wrong_type_argument_with_type(sc, sc->caadr_symbol, lst, + cadr_a_list_string)); +} + +/* -------- cadar -------- */ +static s7_pointer g_cadar(s7_scheme * sc, s7_pointer args) +{ +#define H_cadar "(cadar lst) returns (car (cdr (car lst))): (cadar '((1 2 3))) -> 2" +#define Q_cadar sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cadar_symbol, args, T_PAIR)); + if (!is_pair(car(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cadar_symbol, lst, car_a_list_string)); + return ((is_pair(cdar(lst))) ? cadar(lst) : + simple_wrong_type_argument_with_type(sc, sc->cadar_symbol, lst, + cdar_a_list_string)); +} + +static s7_pointer cadar_p_p(s7_scheme * sc, s7_pointer p) +{ + if ((is_pair(p)) && (is_pair(car(p))) && (is_pair(cdar(p)))) + return (cadar(p)); + if (!is_pair(p)) + return (method_or_bust_one_arg + (sc, p, sc->cadar_symbol, set_plist_1(sc, p), T_PAIR)); + if (!is_pair(car(p))) + return (simple_wrong_type_argument_with_type + (sc, sc->cadar_symbol, p, car_a_list_string)); + return (simple_wrong_type_argument_with_type + (sc, sc->cadar_symbol, p, cdar_a_list_string)); +} + +/* -------- cdaar -------- */ +static s7_pointer cdaar_p_p(s7_scheme * sc, s7_pointer lst) +{ + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cdaar_symbol, set_plist_1(sc, lst), T_PAIR)); + if (!is_pair(car(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdaar_symbol, lst, car_a_list_string)); + return ((is_pair(caar(lst))) ? cdaar(lst) : + simple_wrong_type_argument_with_type(sc, sc->cdaar_symbol, lst, + caar_a_list_string)); +} + +static s7_pointer g_cdaar(s7_scheme * sc, s7_pointer args) +{ +#define H_cdaar "(cdaar lst) returns (cdr (car (car lst))): (cdaar '(((1 2 3)))) -> '(2 3)" +#define Q_cdaar sc->pl_p + return (cdaar_p_p(sc, car(args))); +} + +/* -------- caddr -------- */ +static s7_pointer g_caddr(s7_scheme * sc, s7_pointer args) +{ +#define H_caddr "(caddr lst) returns (car (cdr (cdr lst))): (caddr '(1 2 3 4)) -> 3" +#define Q_caddr sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->caddr_symbol, args, T_PAIR)); + if (!is_pair(cdr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caddr_symbol, lst, cdr_a_list_string)); + return ((is_pair(cddr(lst))) ? caddr(lst) : + simple_wrong_type_argument_with_type(sc, sc->caddr_symbol, lst, + cddr_a_list_string)); +} + +static s7_pointer caddr_p_p(s7_scheme * sc, s7_pointer p) +{ + if ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cddr(p)))) + return (caddr(p)); + if (!is_pair(p)) + return (method_or_bust_one_arg + (sc, p, sc->caddr_symbol, set_plist_1(sc, p), T_PAIR)); + if (!is_pair(cdr(p))) + return (simple_wrong_type_argument_with_type + (sc, sc->caddr_symbol, p, cdr_a_list_string)); + return (simple_wrong_type_argument_with_type + (sc, sc->caddr_symbol, p, cddr_a_list_string)); +} + +static s7_pointer g_list_ref_at_2(s7_scheme * sc, s7_pointer args) +{ + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust + (sc, lst, sc->list_ref_symbol, args, T_PAIR, 1)); + if ((is_pair(cdr(lst))) && (is_pair(cddr(lst)))) + return (caddr(lst)); + return (out_of_range + (sc, sc->list_ref_symbol, int_two, cadr(args), + its_too_large_string)); +} + + +/* -------- cdddr -------- */ +static s7_pointer cdddr_p_p(s7_scheme * sc, s7_pointer lst) +{ + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cdddr_symbol, set_plist_1(sc, lst), T_PAIR)); + if (!is_pair(cdr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdddr_symbol, lst, cdr_a_list_string)); + return ((is_pair(cddr(lst))) ? cdddr(lst) : + simple_wrong_type_argument_with_type(sc, sc->cdddr_symbol, lst, + cddr_a_list_string)); +} + +static s7_pointer g_cdddr(s7_scheme * sc, s7_pointer args) +{ +#define H_cdddr "(cdddr lst) returns (cdr (cdr (cdr lst))): (cdddr '(1 2 3 4)) -> '(4)" +#define Q_cdddr sc->pl_p + return (cdddr_p_p(sc, car(args))); +} + +/* -------- cdadr -------- */ +static s7_pointer cdadr_p_p(s7_scheme * sc, s7_pointer lst) +{ + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cdadr_symbol, set_plist_1(sc, lst), T_PAIR)); + if (!is_pair(cdr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdadr_symbol, lst, cdr_a_list_string)); + return ((is_pair(cadr(lst))) ? cdadr(lst) : + simple_wrong_type_argument_with_type(sc, sc->cdadr_symbol, lst, + cadr_a_list_string)); +} + +static s7_pointer g_cdadr(s7_scheme * sc, s7_pointer args) +{ +#define H_cdadr "(cdadr lst) returns (cdr (car (cdr lst))): (cdadr '(1 (2 3 4))) -> '(3 4)" +#define Q_cdadr sc->pl_p + return (cdadr_p_p(sc, car(args))); +} + +/* -------- cddar -------- */ +static s7_pointer cddar_p_p(s7_scheme * sc, s7_pointer lst) +{ + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cddar_symbol, set_plist_1(sc, lst), T_PAIR)); + if (!is_pair(car(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cddar_symbol, lst, car_a_list_string)); + return ((is_pair(cdar(lst))) ? cddar(lst) : + simple_wrong_type_argument_with_type(sc, sc->cddar_symbol, lst, + cdar_a_list_string)); +} + +static s7_pointer g_cddar(s7_scheme * sc, s7_pointer args) +{ +#define H_cddar "(cddar lst) returns (cdr (cdr (car lst))): (cddar '((1 2 3 4))) -> '(3 4)" +#define Q_cddar sc->pl_p + return (cddar_p_p(sc, car(args))); +} + +/* -------- caaaar -------- */ +static s7_pointer g_caaaar(s7_scheme * sc, s7_pointer args) +{ +#define H_caaaar "(caaaar lst) returns (car (car (car (car lst)))): (caaaar '((((1 2))))) -> 1" +#define Q_caaaar sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->caaaar_symbol, args, T_PAIR)); + if (!is_pair(car(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caaaar_symbol, lst, car_a_list_string)); + if (!is_pair(caar(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caaaar_symbol, lst, caar_a_list_string)); + return ((is_pair(caaar(lst))) ? caaaar(lst) : + simple_wrong_type_argument_with_type(sc, sc->caaaar_symbol, + lst, + caaar_a_list_string)); +} + +/* -------- caaadr -------- */ +static s7_pointer g_caaadr(s7_scheme * sc, s7_pointer args) +{ +#define H_caaadr "(caaadr lst) returns (car (car (car (cdr lst)))): (caaadr '(1 ((2 3)))) -> 2" +#define Q_caaadr sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->caaadr_symbol, args, T_PAIR)); + if (!is_pair(cdr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caaadr_symbol, lst, cdr_a_list_string)); + if (!is_pair(cadr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caaadr_symbol, lst, cadr_a_list_string)); + return ((is_pair(caadr(lst))) ? caaadr(lst) : + simple_wrong_type_argument_with_type(sc, sc->caaadr_symbol, + lst, + caadr_a_list_string)); +} + +/* -------- caadar -------- */ +static s7_pointer g_caadar(s7_scheme * sc, s7_pointer args) +{ +#define H_caadar "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2" +#define Q_caadar sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->caadar_symbol, args, T_PAIR)); + if (!is_pair(car(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caadar_symbol, lst, car_a_list_string)); + if (!is_pair(cdar(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caadar_symbol, lst, cdar_a_list_string)); + return ((is_pair(cadar(lst))) ? caadar(lst) : + simple_wrong_type_argument_with_type(sc, sc->caadar_symbol, + lst, + cadar_a_list_string)); +} + +/* -------- cadaar -------- */ +static s7_pointer g_cadaar(s7_scheme * sc, s7_pointer args) +{ +#define H_cadaar "(cadaar lst) returns (car (cdr (car (car lst)))): (cadaar '(((1 2 3)))) -> 2" +#define Q_cadaar sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cadaar_symbol, args, T_PAIR)); + if (!is_pair(car(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cadaar_symbol, lst, car_a_list_string)); + if (!is_pair(caar(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cadaar_symbol, lst, caar_a_list_string)); + return ((is_pair(cdaar(lst))) ? cadaar(lst) : + simple_wrong_type_argument_with_type(sc, sc->cadaar_symbol, + lst, + cdaar_a_list_string)); +} + +/* -------- caaddr -------- */ + +static s7_pointer caaddr_p_p(s7_scheme * sc, s7_pointer lst) +{ + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->caaddr_symbol, set_plist_1(sc, lst), + T_PAIR)); + if (!is_pair(cdr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caaddr_symbol, lst, cdr_a_list_string)); + if (!is_pair(cddr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caaddr_symbol, lst, cddr_a_list_string)); + return ((is_pair(caddr(lst))) ? caaddr(lst) : + simple_wrong_type_argument_with_type(sc, sc->caaddr_symbol, + lst, + caddr_a_list_string)); +} + +static s7_pointer g_caaddr(s7_scheme * sc, s7_pointer args) +{ +#define H_caaddr "(caaddr lst) returns (car (car (cdr (cdr lst)))): (caaddr '(1 2 (3 4))) -> 3" +#define Q_caaddr sc->pl_p + return (caaddr_p_p(sc, car(args))); +} + +/* -------- cadddr -------- */ +static s7_pointer cadddr_p_p(s7_scheme * sc, s7_pointer lst) +{ + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cadddr_symbol, set_plist_1(sc, lst), + T_PAIR)); + if (!is_pair(cdr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cadddr_symbol, lst, cdr_a_list_string)); + if (!is_pair(cddr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cadddr_symbol, lst, cddr_a_list_string)); + return ((is_pair(cdddr(lst))) ? cadddr(lst) : + simple_wrong_type_argument_with_type(sc, sc->cadddr_symbol, + lst, + cdddr_a_list_string)); +} + +static s7_pointer g_cadddr(s7_scheme * sc, s7_pointer args) +{ +#define H_cadddr "(cadddr lst) returns (car (cdr (cdr (cdr lst)))): (cadddr '(1 2 3 4 5)) -> 4" +#define Q_cadddr sc->pl_p + return (cadddr_p_p(sc, car(args))); +} + +/* -------- cadadr -------- */ +static s7_pointer cadadr_p_p(s7_scheme * sc, s7_pointer lst) +{ + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cadadr_symbol, set_plist_1(sc, lst), + T_PAIR)); + if (!is_pair(cdr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cadadr_symbol, lst, cdr_a_list_string)); + if (!is_pair(cadr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cadadr_symbol, lst, cadr_a_list_string)); + return ((is_pair(cdadr(lst))) ? cadadr(lst) : + simple_wrong_type_argument_with_type(sc, sc->cadadr_symbol, + lst, + cdadr_a_list_string)); +} + +static s7_pointer g_cadadr(s7_scheme * sc, s7_pointer args) +{ +#define H_cadadr "(cadadr lst) returns (car (cdr (car (cdr lst)))): (cadadr '(1 (2 3 4))) -> 3" +#define Q_cadadr sc->pl_p + return (cadadr_p_p(sc, car(args))); +} + +/* -------- caddar -------- */ +static s7_pointer caddar_p_p(s7_scheme * sc, s7_pointer lst) +{ + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->caddar_symbol, set_plist_1(sc, lst), + T_PAIR)); + if (!is_pair(car(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caddar_symbol, lst, car_a_list_string)); + if (!is_pair(cdar(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->caddar_symbol, lst, cdar_a_list_string)); + return ((is_pair(cddar(lst))) ? caddar(lst) : + simple_wrong_type_argument_with_type(sc, sc->caddar_symbol, + lst, + cddar_a_list_string)); +} + +static s7_pointer g_caddar(s7_scheme * sc, s7_pointer args) +{ +#define H_caddar "(caddar lst) returns (car (cdr (cdr (car lst)))): (caddar '((1 2 3 4))) -> 3" +#define Q_caddar sc->pl_p + return (caddar_p_p(sc, car(args))); +} + +/* -------- cdaaar -------- */ +static s7_pointer g_cdaaar(s7_scheme * sc, s7_pointer args) +{ +#define H_cdaaar "(cdaaar lst) returns (cdr (car (car (car lst)))): (cdaaar '((((1 2 3))))) -> '(2 3)" +#define Q_cdaaar sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cdaaar_symbol, args, T_PAIR)); + if (!is_pair(car(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdaaar_symbol, lst, car_a_list_string)); + if (!is_pair(caar(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdaaar_symbol, lst, caar_a_list_string)); + return ((is_pair(caaar(lst))) ? cdaaar(lst) : + simple_wrong_type_argument_with_type(sc, sc->cdaaar_symbol, + lst, + caaar_a_list_string)); +} + +/* -------- cdaadr -------- */ +static s7_pointer g_cdaadr(s7_scheme * sc, s7_pointer args) +{ +#define H_cdaadr "(cdaadr lst) returns (cdr (car (car (cdr lst)))): (cdaadr '(1 ((2 3 4)))) -> '(3 4)" +#define Q_cdaadr sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cdaadr_symbol, args, T_PAIR)); + if (!is_pair(cdr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdaadr_symbol, lst, cdr_a_list_string)); + if (!is_pair(cadr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdaadr_symbol, lst, cadr_a_list_string)); + return ((is_pair(caadr(lst))) ? cdaadr(lst) : + simple_wrong_type_argument_with_type(sc, sc->cdaadr_symbol, + lst, + caadr_a_list_string)); +} + +/* -------- cdadar -------- */ +static s7_pointer g_cdadar(s7_scheme * sc, s7_pointer args) +{ +#define H_cdadar "(cdadar lst) returns (cdr (car (cdr (car lst)))): (cdadar '((1 (2 3 4)))) -> '(3 4)" +#define Q_cdadar sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cdadar_symbol, args, T_PAIR)); + if (!is_pair(car(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdadar_symbol, lst, car_a_list_string)); + if (!is_pair(cdar(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdadar_symbol, lst, cdar_a_list_string)); + return ((is_pair(cadar(lst))) ? cdadar(lst) : + simple_wrong_type_argument_with_type(sc, sc->cdadar_symbol, + lst, + cadar_a_list_string)); +} + +/* -------- cddaar -------- */ +static s7_pointer g_cddaar(s7_scheme * sc, s7_pointer args) +{ +#define H_cddaar "(cddaar lst) returns (cdr (cdr (car (car lst)))): (cddaar '(((1 2 3 4)))) -> '(3 4)" +#define Q_cddaar sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cddaar_symbol, args, T_PAIR)); + if (!is_pair(car(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cddaar_symbol, lst, car_a_list_string)); + if (!is_pair(caar(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cddaar_symbol, lst, caar_a_list_string)); + return ((is_pair(cdaar(lst))) ? cddaar(lst) : + simple_wrong_type_argument_with_type(sc, sc->cddaar_symbol, + lst, + cdaar_a_list_string)); +} + +/* -------- cdaddr -------- */ +static s7_pointer g_cdaddr(s7_scheme * sc, s7_pointer args) +{ +#define H_cdaddr "(cdaddr lst) returns (cdr (car (cdr (cdr lst)))): (cdaddr '(1 2 (3 4 5))) -> '(4 5)" +#define Q_cdaddr sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cdaddr_symbol, args, T_PAIR)); + if (!is_pair(cdr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdaddr_symbol, lst, cdr_a_list_string)); + if (!is_pair(cddr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdaddr_symbol, lst, cddr_a_list_string)); + return ((is_pair(caddr(lst))) ? cdaddr(lst) : + simple_wrong_type_argument_with_type(sc, sc->cdaddr_symbol, + lst, + caddr_a_list_string)); +} + +/* -------- cddddr -------- */ +static s7_pointer g_cddddr(s7_scheme * sc, s7_pointer args) +{ +#define H_cddddr "(cddddr lst) returns (cdr (cdr (cdr (cdr lst)))): (cddddr '(1 2 3 4 5)) -> '(5)" +#define Q_cddddr sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cddddr_symbol, args, T_PAIR)); + if (!is_pair(cdr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cddddr_symbol, lst, cdr_a_list_string)); + if (!is_pair(cddr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cddddr_symbol, lst, cddr_a_list_string)); + return ((is_pair(cdddr(lst))) ? cddddr(lst) : + simple_wrong_type_argument_with_type(sc, sc->cddddr_symbol, + lst, + cdddr_a_list_string)); +} + +/* -------- cddadr -------- */ +static s7_pointer g_cddadr(s7_scheme * sc, s7_pointer args) +{ +#define H_cddadr "(cddadr lst) returns (cdr (cdr (car (cdr lst)))): (cddadr '(1 (2 3 4 5))) -> '(4 5)" +#define Q_cddadr sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cddadr_symbol, args, T_PAIR)); + if (!is_pair(cdr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cddadr_symbol, lst, cdr_a_list_string)); + if (!is_pair(cadr(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cddadr_symbol, lst, cadr_a_list_string)); + return ((is_pair(cdadr(lst))) ? cddadr(lst) : + simple_wrong_type_argument_with_type(sc, sc->cddadr_symbol, + lst, + cdadr_a_list_string)); +} + +/* -------- cdddar -------- */ +static s7_pointer g_cdddar(s7_scheme * sc, s7_pointer args) +{ +#define H_cdddar "(cdddar lst) returns (cdr (cdr (cdr (car lst)))): (cdddar '((1 2 3 4 5))) -> '(4 5)" +#define Q_cdddar sc->pl_p + + s7_pointer lst = car(args); + if (!is_pair(lst)) + return (method_or_bust_one_arg + (sc, lst, sc->cdddar_symbol, args, T_PAIR)); + if (!is_pair(car(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdddar_symbol, lst, car_a_list_string)); + if (!is_pair(cdar(lst))) + return (simple_wrong_type_argument_with_type + (sc, sc->cdddar_symbol, lst, cdar_a_list_string)); + return ((is_pair(cddar(lst))) ? cdddar(lst) : + simple_wrong_type_argument_with_type(sc, sc->cdddar_symbol, + lst, + cddar_a_list_string)); +} + + +/* -------------------------------- assoc assv assq -------------------------------- */ +s7_pointer s7_assq(s7_scheme * sc, s7_pointer obj, s7_pointer x) +{ + s7_pointer y = x; + while (true) { + /* we can blithely take the car of anything, since we're not treating it as an object, + * then if we get a bogus match, the following check that caar made sense ought to catch it. + * if car(#) = # (initialization time), then cdr(nil)->unspec + * and subsequent caar(unspec)->unspec so we could forgo half the is_pair checks below. + * This breaks if "x" is a dotted list -- the last cdr is not nil, so we lose. + */ + LOOP_8(if ((obj == unchecked_car(car(x))) && (is_pair(car(x)))) + return (car(x)); x = cdr(x); + if (!is_pair(x)) return (sc->F)); + y = cdr(y); + if (x == y) + return (sc->F); + } + return (sc->F); /* not reached */ +} + +static s7_pointer assq_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + return ((is_pair(y)) ? s7_assq(sc, x, y) : + ((is_null(y)) ? sc->F : + method_or_bust_with_type_pp(sc, y, sc->assq_symbol, x, y, + an_association_list_string, 2))); +} + +static s7_pointer g_assq(s7_scheme * sc, s7_pointer args) +{ +#define H_assq "(assq obj alist) returns the key-value pair associated (via eq?) with the key obj in the association list alist" +#define Q_assq s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol) + return (assq_p_pp(sc, car(args), cadr(args))); + /* we don't check for (pair? (car x)) here (or in assv) so we get some inconsistency with assoc: + * (assq #f '(#f 2 . 3)) -> #f, (assoc #f '(#f 2 . 3)) -> 'error + */ +} + +static s7_pointer assv_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + s7_pointer z; + if (!is_pair(y)) { + if (is_null(y)) + return (sc->F); + return (method_or_bust_with_type_pp + (sc, y, sc->assv_symbol, x, y, an_association_list_string, + 2)); + } + if (is_simple(x)) + return (s7_assq(sc, x, y)); + + z = y; + while (true) { + /* here we can't play the assq == game because s7_is_eqv thinks it's getting a legit s7 object */ + if ((is_pair(car(y))) && (s7_is_eqv(sc, x, caar(y)))) + return (car(y)); + y = cdr(y); + if (!is_pair(y)) + return (sc->F); + + if ((is_pair(car(y))) && (s7_is_eqv(sc, x, caar(y)))) + return (car(y)); + y = cdr(y); + if (!is_pair(y)) + return (sc->F); + + z = cdr(z); + if (z == y) + return (sc->F); + } + return (sc->F); /* not reached */ +} + +static s7_pointer g_assv(s7_scheme * sc, s7_pointer args) +{ /* g_assv is called by g_assoc below */ +#define H_assv "(assv obj alist) returns the key-value pair associated (via eqv?) with the key obj in the association list alist" +#define Q_assv Q_assq + return (assv_p_pp(sc, car(args), cadr(args))); +} + +s7_pointer s7_assoc(s7_scheme * sc, s7_pointer sym, s7_pointer lst) +{ + s7_pointer x, y; + + if (!is_pair(lst)) + return (sc->F); + x = lst; + y = lst; + while (true) { + if ((is_pair(car(x))) && (s7_is_equal(sc, sym, caar(x)))) + return (car(x)); + x = cdr(x); + if (!is_pair(x)) + return (sc->F); + + if ((is_pair(car(x))) && (s7_is_equal(sc, sym, caar(x)))) + return (car(x)); + x = cdr(x); + if (!is_pair(x)) + return (sc->F); + + y = cdr(y); + if (x == y) + return (sc->F); + } + return (sc->F); +} + +static s7_pointer g_is_eq(s7_scheme * sc, s7_pointer args); +static s7_pointer g_is_eqv(s7_scheme * sc, s7_pointer args); +static s7_pfunc s7_bool_optimize(s7_scheme * sc, s7_pointer expr); + +static s7_pointer g_assoc(s7_scheme * sc, s7_pointer args) +{ +#define H_assoc "(assoc obj alist (func #f)) returns the key-value pair associated (via equal?) with the key obj in the association list alist.\ +If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?" +#define Q_assoc s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T, sc->is_list_symbol, sc->is_procedure_symbol) + + s7_pointer x = cadr(args), y, obj, eq_func = NULL; + + if (!is_null(x)) { + if (!is_pair(x)) + return (method_or_bust_with_type + (sc, x, sc->assoc_symbol, args, + an_association_list_string, 2)); + if ((is_pair(x)) && (!is_pair(car(x)))) + return (wrong_type_argument_with_type(sc, sc->assoc_symbol, 2, x, an_association_list_string)); /* we're assuming caar below so it better exist */ + } + + if (is_pair(cddr(args))) { + eq_func = caddr(args); + /* here we know x is a pair, but need to protect against circular lists */ + /* I wonder if the assoc equality function should get the cons, not just caar? */ + + if ((is_c_function(eq_func)) && (is_safe_procedure(eq_func))) { + s7_function func; + s7_pointer slow; + func = c_function_call(eq_func); + if (func == g_is_eq) + return (is_null(x) ? sc->F : s7_assq(sc, car(args), x)); + if (func == g_is_eqv) + return (assv_p_pp(sc, car(args), x)); + if (!s7_is_aritable(sc, eq_func, 2)) + return (wrong_type_argument_with_type + (sc, sc->assoc_symbol, 3, eq_func, + an_eq_func_string)); + set_car(sc->t2_1, car(args)); + for (slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) { + if (!is_pair(car(x))) + return (wrong_type_argument_with_type + (sc, sc->assoc_symbol, 2, cadr(args), + an_association_list_string)); + set_car(sc->t2_2, caar(x)); + if (is_true(sc, func(sc, sc->t2_1))) + return (car(x)); + x = cdr(x); + if ((!is_pair(x)) || (x == slow)) + return (sc->F); + if (!is_pair(car(x))) + return (wrong_type_argument_with_type + (sc, sc->assoc_symbol, 2, cadr(args), + an_association_list_string)); + set_car(sc->t2_2, caar(x)); + if (is_true(sc, func(sc, sc->t2_1))) + return (car(x)); + } + return (sc->F); + } + if ((is_closure(eq_func)) && (is_pair(closure_args(eq_func))) && (is_pair(cdr(closure_args(eq_func)))) && /* not dotted arg list */ + (is_null(cddr(closure_args(eq_func))))) { /* arity == 2 */ + s7_pointer body = closure_body(eq_func); + if (is_null(x)) + return (sc->F); + if (is_null(cdr(body))) { + s7_pfunc func; + sc->curlet = + make_let_with_two_slots(sc, sc->curlet, + car(closure_args(eq_func)), + car(args), + cadr(closure_args(eq_func)), + sc->F); + func = s7_bool_optimize(sc, body); + if (func) { + s7_pointer slowx = x, b; + opt_info *o = sc->opts[0]; + b = next_slot(let_slots(sc->curlet)); + while (true) { + if (!is_pair(car(x))) + return (wrong_type_argument_with_type + (sc, sc->assoc_symbol, 2, cadr(args), + an_association_list_string)); + slot_set_value(b, caar(x)); + if (o->v[0].fb(o)) + return (car(x)); + x = cdr(x); + if (!is_pair(x)) + return (sc->F); + if (!is_pair(car(x))) + return (wrong_type_argument_with_type + (sc, sc->assoc_symbol, 2, cadr(args), + an_association_list_string)); + slot_set_value(b, caar(x)); + if (o->v[0].fb(o)) + return (car(x)); + x = cdr(x); + if (!is_pair(x)) + return (sc->F); + slowx = cdr(slowx); + if (x == slowx) + return (sc->F); + } + return (sc->F); + } + } + } + + /* member_if is similar. Do not call eval here with op_eval_done to return! An error will longjmp past the + * assoc point, leaving the op_eval_done on the stack, causing s7 to quit. + */ + if (type(eq_func) < T_CONTINUATION) + return (method_or_bust_with_type_one_arg + (sc, eq_func, sc->assoc_symbol, args, + a_procedure_string)); + if (!s7_is_aritable(sc, eq_func, 2)) + return (wrong_type_argument_with_type + (sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string)); + if (is_null(x)) + return (sc->F); + y = list_1(sc, args); + set_opt1_fast(y, x); + set_opt2_slow(y, x); + push_stack(sc, OP_ASSOC_IF, list_1_unchecked(sc, y), eq_func); + if (needs_copied_args(eq_func)) + push_stack(sc, OP_APPLY, + list_2_unchecked(sc, car(args), caar(x)), eq_func); + else { + set_car(sc->t2_1, car(args)); + set_car(sc->t2_2, caar(x)); + push_stack(sc, OP_APPLY, sc->t2_1, eq_func); + } + return (sc->unspecified); + } + + if (is_null(x)) + return (sc->F); + obj = car(args); + if (is_simple(obj)) + return (s7_assq(sc, obj, x)); + y = x; + if (is_string(obj)) { + s7_pointer val; + while (true) { + if (is_pair(car(x))) { + val = caar(x); + if ((val == obj) || + ((is_string(val)) && + (scheme_strings_are_equal(obj, val)))) + return (car(x)); + } + x = cdr(x); + if (!is_pair(x)) + return (sc->F); + + if (is_pair(car(x))) { + val = caar(x); + if ((val == obj) || + ((is_string(val)) && + (scheme_strings_are_equal(obj, val)))) + return (car(x)); + } + x = cdr(x); + if (!is_pair(x)) + return (sc->F); + y = cdr(y); + if (x == y) + return (sc->F); + } + return (sc->F); + } + while (true) { + if ((is_pair(car(x))) && (s7_is_equal(sc, obj, caar(x)))) + return (car(x)); + x = cdr(x); + if (!is_pair(x)) + return (sc->F); + + if ((is_pair(car(x))) && (s7_is_equal(sc, obj, caar(x)))) + return (car(x)); + x = cdr(x); + if (!is_pair(x)) + return (sc->F); + y = cdr(y); + if (x == y) + return (sc->F); + } + return (sc->F); /* not reached */ +} + +static s7_pointer assoc_p_pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + return (g_assoc(sc, set_plist_2(sc, p1, p2))); +} + +static bool op_assoc_if(s7_scheme * sc) +{ + s7_pointer orig_args = car(sc->args); + /* code=func, args=(list (list args)) with f/opt1_fast=list, value=result of comparison + * (assoc 3 '((1 . a) (2 . b) (3 . c) (4 . d)) =) + */ + if (sc->value != sc->F) { /* previous comparison was not #f -- return (car list) */ + sc->value = car(opt1_fast(orig_args)); + return (true); + } + if (!is_pair(cdr(opt1_fast(orig_args)))) { /* (assoc 3 '((1 . 2) . 3) =) or nil */ + sc->value = sc->F; + return (true); + } + set_opt1_fast(orig_args, cdr(opt1_fast(orig_args))); /* cdr down arg list */ + + if (sc->cur_op == OP_ASSOC_IF1) { + /* circular list check */ + if (opt1_fast(orig_args) == opt2_slow(orig_args)) { + sc->value = sc->F; + return (true); + } + set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list */ + push_stack_direct(sc, OP_ASSOC_IF); + } else + push_stack_direct(sc, OP_ASSOC_IF1); + + if (!is_pair(car(opt1_fast(orig_args)))) /* (assoc 1 '((2 . 2) 3) =) -- we access caaadr below */ + eval_error_any(sc, sc->wrong_type_arg_symbol, + "assoc: second argument is not an alist: ~S", 42, + orig_args); + /* not sure about this -- we could simply skip the entry both here and in g_assoc + * (assoc 1 '((2 . 2) 3)) -> #f + * (assoc 1 '((2 . 2) 3) =) -> error currently + */ + if (needs_copied_args(sc->code)) + sc->args = list_2(sc, caar(orig_args), caar(opt1_fast(orig_args))); + else + sc->args = + set_plist_2(sc, caar(orig_args), caar(opt1_fast(orig_args))); + return (false); +} + +static s7_pointer assoc_chooser(s7_scheme * sc, s7_pointer f, int32_t args, + s7_pointer expr, bool ops) +{ + if (!ops) + return (f); + if ((args == 3) && (is_normal_symbol(cadddr(expr)))) { + if (cadddr(expr) == sc->is_eq_symbol) + return (global_value(sc->assq_symbol)); + if (cadddr(expr) == sc->is_eqv_symbol) + return (global_value(sc->assv_symbol)); + } + return (f); +} + + +/* ---------------- member, memv, memq ---------------- */ +s7_pointer s7_memq(s7_scheme * sc, s7_pointer obj, s7_pointer x) +{ + s7_pointer y = x; + while (true) { + LOOP_4(if (obj == car(x)) return (x); x = cdr(x); + if (!is_pair(x)) return (sc->F)); + y = cdr(y); + if (x == y) + return (sc->F); + } + return (sc->F); +} + +static s7_pointer memq_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + return ((is_pair(y)) ? s7_memq(sc, x, y) : + ((is_null(y)) ? sc->F : + method_or_bust_with_type_pp(sc, y, sc->memq_symbol, x, y, + a_list_string, 2))); +} + +static s7_pointer g_memq(s7_scheme * sc, s7_pointer args) +{ +#define H_memq "(memq obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memq uses eq?" +#define Q_memq sc->pl_tl + + s7_pointer x = car(args), y = cadr(args); + if (is_pair(y)) + return (s7_memq(sc, x, y)); + if (is_null(y)) + return (sc->F); + return (method_or_bust_with_type_pp + (sc, y, sc->memq_symbol, x, y, a_list_string, 2)); +} + +/* I think (memq 'c '(a b . c)) should return #f because otherwise (memq () ...) would return the () at the end. */ +/* if memq's list is a quoted list, it won't be changing, so we can tell ahead of time that it is a proper list, and what its length is. */ + +static s7_pointer g_memq_2(s7_scheme * sc, s7_pointer args) +{ + s7_pointer x = cadr(args), obj = car(args); + if (obj == car(x)) + return (x); + return ((obj == cadr(x)) ? cdr(x) : sc->F); +} + +static s7_pointer memq_2_p_pp(s7_scheme * sc, s7_pointer obj, s7_pointer x) +{ + if (obj == car(x)) + return (x); + return ((obj == cadr(x)) ? cdr(x) : sc->F); +} + +static s7_pointer memq_3_p_pp(s7_scheme * sc, s7_pointer obj, s7_pointer x) +{ + if (obj == car(x)) + return (x); + if (obj == cadr(x)) + return (cdr(x)); + return ((obj == caddr(x)) ? cddr(x) : sc->F); +} + +static s7_pointer g_memq_3(s7_scheme * sc, s7_pointer args) +{ + s7_pointer x = cadr(args), obj = car(args); + while (true) { + if (obj == car(x)) + return (x); + x = cdr(x); + if (obj == car(x)) + return (x); + x = cdr(x); + if (obj == car(x)) + return (x); + x = cdr(x); + if (!is_pair(x)) + return (sc->F); + } + return (sc->F); +} + +static s7_pointer memq_4_p_pp(s7_scheme * sc, s7_pointer obj, s7_pointer x) +{ + while (true) { + LOOP_4(if (obj == car(x)) return (x); x = cdr(x)); + if (!is_pair(x)) + return (sc->F); + } + return (sc->F); +} + +static s7_pointer g_memq_4(s7_scheme * sc, s7_pointer args) +{ + return (memq_4_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_memq_any(s7_scheme * sc, s7_pointer args) +{ + /* no circular list check needed in this case */ + s7_pointer x = cadr(args), obj = car(args); + while (true) { + LOOP_4(if (obj == car(x)) return (x); x = cdr(x); + if (!is_pair(x)) return (sc->F)); + } + return (sc->F); +} + +static s7_pointer memq_chooser(s7_scheme * sc, s7_pointer f, int32_t args, + s7_pointer expr, bool ops) +{ + s7_pointer lst = caddr(expr); + if ((is_proper_quote(sc, lst)) && (is_pair(cadr(lst)))) { + s7_int len; + len = s7_list_length(sc, cadr(lst)); + if (len > 0) { + if (len == 2) /* this used to set opt3_any to cadr, but that doesn't survive call/cc's copy_stack */ + return (sc->memq_2); + if ((len % 4) == 0) + return (sc->memq_4); + return (((len % 3) == 0) ? sc->memq_3 : sc->memq_any); + } + } + return (f); +} + +static bool numbers_are_eqv(s7_scheme * sc, s7_pointer a, s7_pointer b) +{ +#if WITH_GMP + if ((is_big_number(a)) || (is_big_number(b))) + return (big_numbers_are_eqv(sc, a, b)); +#endif + + if (type(a) != type(b)) + return (false); /* (eqv? 1 1.0) -> #f! */ + + /* switch is apparently as expensive as 3-4 if's! so this only loses if every call involves complex numbers? */ + if (is_t_integer(a)) + return (integer(a) == integer(b)); + if (is_t_real(a)) + return ((!is_NaN(real(a))) && (real(a) == real(b))); + if (is_t_ratio(a)) + return ((numerator(a) == numerator(b)) + && (denominator(a) == denominator(b))); + if (!is_t_complex(a)) + return (false); + if ((is_NaN(real_part(a))) || (is_NaN(imag_part(a)))) + return (false); + return ((real_part(a) == real_part(b)) + && (imag_part(a) == imag_part(b))); +} + +static s7_pointer memv_number(s7_scheme * sc, s7_pointer obj, s7_pointer x) +{ + s7_pointer y = x; + while (true) { + LOOP_4(if ((is_number(car(x))) + && (numbers_are_eqv(sc, obj, car(x)))) return (x); + x = cdr(x); if (!is_pair(x)) return (sc->F)); + y = cdr(y); + if (x == y) + return (sc->F); + } + return (sc->F); +} + +static s7_pointer memv_p_pp(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + s7_pointer z; + if (!is_pair(y)) { + if (is_null(y)) + return (sc->F); + return (method_or_bust_with_type_pp + (sc, y, sc->memv_symbol, x, y, a_list_string, 2)); + } + + if (is_simple(x)) + return (s7_memq(sc, x, y)); + if (is_number(x)) + return (memv_number(sc, x, y)); + + z = y; + while (true) { + if (s7_is_eqv(sc, x, car(y))) + return (y); + y = cdr(y); + if (!is_pair(y)) + return (sc->F); + + if (s7_is_eqv(sc, x, car(y))) + return (y); + y = cdr(y); + if (!is_pair(y)) + return (sc->F); + + z = cdr(z); + if (z == y) + return (sc->F); + } + return (sc->F); /* not reached */ +} + +static s7_pointer g_memv(s7_scheme * sc, s7_pointer args) +{ +#define H_memv "(memv obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memv uses eqv?" +#define Q_memv sc->pl_tl + return (memv_p_pp(sc, car(args), cadr(args))); +} + + +s7_pointer s7_member(s7_scheme * sc, s7_pointer sym, s7_pointer lst) +{ + s7_pointer x; + for (x = lst; is_pair(x); x = cdr(x)) + if (s7_is_equal(sc, sym, car(x))) + return (x); + return (sc->F); +} + +static s7_pointer member(s7_scheme * sc, s7_pointer obj, s7_pointer x) +{ + s7_pointer y = x; + if (is_string(obj)) + while (true) { + if ((obj == car(x)) || + ((is_string(car(x))) && + (scheme_strings_are_equal(obj, car(x))))) + return (x); + x = cdr(x); + if (!is_pair(x)) + return (sc->F); + + if ((obj == car(x)) || + ((is_string(car(x))) && + (scheme_strings_are_equal(obj, car(x))))) + return (x); + x = cdr(x); + if (!is_pair(x)) + return (sc->F); + y = cdr(y); + if (x == y) + return (sc->F); + } else + while (true) { + LOOP_4(if (s7_is_equal(sc, obj, car(x))) return (x); + x = cdr(x); if (!is_pair(x)) return (sc->F)); + y = cdr(y); + if (x == y) + return (sc->F); + } + return (sc->F); +} + +static bool p_to_b(opt_info * p); + +static s7_pointer g_member(s7_scheme * sc, s7_pointer args) +{ +#define H_member "(member obj list (func #f)) looks for obj in list and returns the list from that point if it is found, otherwise #f. \ +member uses equal? If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?" +#define Q_member s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol, sc->is_procedure_symbol) + + /* this could be extended to accept sequences: + * (member #\a "123123abnfc" char=?) -> "abnfc" + * (member "abc" "123abc321" string=?) -> "abc321" but there's the string length complication + * (member 1 #(0 1 2) =) -> #(1 2) etc but what would it do for a hash-table? + * the third arg can be weird: (member #f (list #t) cons) -> (#t) -- cons returns '(#f . #t) which is true, so we get '(#t) + * should this be an error: (member '(1 2 3) () '(1 . 2)) -- the third arg is bogus, but the second is nil + * + * here as in assoc, sort, and make-hash-table we accept macros, but I can't think of a good reason to do so. + */ + + s7_pointer x = cadr(args), obj, eq_func = NULL; + + if ((!is_pair(x)) && (!is_null(x))) + return (method_or_bust_with_type + (sc, x, sc->member_symbol, args, a_list_string, 2)); + + if (is_not_null(cddr(args))) { + s7_pointer y, slow; + eq_func = caddr(args); + + if ((is_c_function(eq_func)) && (is_safe_procedure(eq_func))) { + s7_function func = c_function_call(eq_func); + if (func == g_is_eq) + return (is_null(x) ? sc->F : s7_memq(sc, car(args), x)); + if (func == g_is_eqv) + return (g_memv(sc, args)); + if (func == g_less) + func = g_less_2; + else if (func == g_greater) + func = g_greater_2; + else if (!s7_is_aritable(sc, eq_func, 2)) + return (wrong_type_argument_with_type + (sc, sc->member_symbol, 3, eq_func, + an_eq_func_string)); + set_car(sc->t2_1, car(args)); + for (slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) { + set_car(sc->t2_2, car(x)); + if (is_true(sc, func(sc, sc->t2_1))) + return (x); + if (!is_pair(cdr(x))) + return (sc->F); + x = cdr(x); + if (x == slow) + return (sc->F); + set_car(sc->t2_2, car(x)); + if (is_true(sc, func(sc, sc->t2_1))) + return (x); + } + return (sc->F); + } + + if ((is_closure(eq_func)) && (is_pair(closure_args(eq_func))) && (is_pair(cdr(closure_args(eq_func)))) && /* not dotted arg list */ + (is_null(cddr(closure_args(eq_func))))) { /* arity == 2 */ + s7_pointer body = closure_body(eq_func); + if (is_null(x)) + return (sc->F); + if ((!no_bool_opt(body)) && (is_null(cdr(body)))) { + s7_pfunc func; + sc->curlet = + make_let_with_two_slots(sc, sc->curlet, + car(closure_args(eq_func)), + car(args), + cadr(closure_args(eq_func)), + sc->F); + func = s7_bool_optimize(sc, body); + if (func) { + opt_info *o = sc->opts[0]; + s7_pointer b; + b = next_slot(let_slots(sc->curlet)); + if (o->v[0].fb == p_to_b) { + s7_pointer(*fp) (opt_info * o); + fp = o->v[O_WRAP].fp; + for (slow = x; is_pair(x); + x = cdr(x), slow = cdr(slow)) { + slot_set_value(b, car(x)); + if (fp(o) != sc->F) + return (x); + if (!is_pair(cdr(x))) + return (sc->F); + x = cdr(x); + if (x == slow) + return (sc->F); + slot_set_value(b, car(x)); + if (fp(o) != sc->F) + return (x); + } + } else + for (slow = x; is_pair(x); + x = cdr(x), slow = cdr(slow)) { + slot_set_value(b, car(x)); + if (o->v[0].fb(o)) + return (x); + if (!is_pair(cdr(x))) + return (sc->F); + x = cdr(x); + if (x == slow) + return (sc->F); + slot_set_value(b, car(x)); + if (o->v[0].fb(o)) + return (x); + } + return (sc->F); + } + set_no_bool_opt(body); + } + } + + if (type(eq_func) < T_CONTINUATION) + return (method_or_bust_with_type + (sc, eq_func, sc->member_symbol, args, + a_procedure_string, 3)); + if (!s7_is_aritable(sc, eq_func, 2)) + return (wrong_type_argument_with_type + (sc, sc->member_symbol, 3, eq_func, + an_eq_func_string)); + if (is_null(x)) + return (sc->F); + y = list_1(sc, args); /* this could probably be handled with a counter cell (cdr here is unused) */ + set_opt1_fast(y, x); + set_opt2_slow(y, x); + push_stack(sc, OP_MEMBER_IF, list_1_unchecked(sc, y), eq_func); + if (needs_copied_args(eq_func)) + push_stack(sc, OP_APPLY, + list_2_unchecked(sc, car(args), car(x)), eq_func); + else { + set_car(sc->t2_1, car(args)); + set_car(sc->t2_2, car(x)); + push_stack(sc, OP_APPLY, sc->t2_1, eq_func); + } + return (sc->unspecified); + } + if (is_null(x)) + return (sc->F); + obj = car(args); + if (is_simple(obj)) + return (s7_memq(sc, obj, x)); + /* the only things that aren't simply == here are c_object, string, number, vector, hash-table, pair, and c_pointer, but all the other cases are unlikely */ + if (is_number(obj)) + return (memv_number(sc, obj, x)); + return (member(sc, obj, x)); +} + +static s7_pointer member_p_pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + return (g_member(sc, set_plist_2(sc, p1, p2))); +} + +static s7_pointer member_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if (!ops) + return (f); + if ((args == 3) && (is_normal_symbol(cadddr(expr)))) { + if (cadddr(expr) == sc->is_eq_symbol) + return (memq_chooser + (sc, global_value(sc->memq_symbol), 2, expr, ops)); + if (cadddr(expr) == sc->is_eqv_symbol) + return (global_value(sc->memv_symbol)); + } + return (f); +} + +static bool op_member_if(s7_scheme * sc) +{ + s7_pointer orig_args = car(sc->args); + /* code=func, args = (list (list original args)) with opt1_fast->position in cadr (the list), + * the extra indirection (list (list...)) is needed because call/cc copies arg lists + * value = result of comparison + */ + if (sc->value != sc->F) { /* previous comparison was not #f -- return list */ + sc->value = opt1_fast(orig_args); + return (true); + } + if (!is_pair(cdr(opt1_fast(orig_args)))) { /* no more args -- return #f */ + sc->value = sc->F; + return (true); + } + set_opt1_fast(orig_args, cdr(opt1_fast(orig_args))); /* cdr down arg list */ + + if (sc->cur_op == OP_MEMBER_IF1) { + /* circular list check */ + if (opt1_fast(orig_args) == opt2_slow(orig_args)) { + sc->value = sc->F; + return (true); + } + set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list (check for circular list) */ + push_stack_direct(sc, OP_MEMBER_IF); + } else + push_stack_direct(sc, OP_MEMBER_IF1); + + if (needs_copied_args(sc->code)) + sc->args = list_2(sc, caar(orig_args), car(opt1_fast(orig_args))); + else + sc->args = + set_plist_2(sc, caar(orig_args), car(opt1_fast(orig_args))); + return (false); +} + + +/* -------------------------------- list -------------------------------- */ +static s7_pointer g_list(s7_scheme * sc, s7_pointer args) +{ +#define H_list "(list ...) returns its arguments in a list" +#define Q_list s7_make_circular_signature(sc, 1, 2, sc->is_proper_list_symbol, sc->T) + return (copy_proper_list(sc, args)); +} + +static s7_pointer g_list_0(s7_scheme * sc, s7_pointer args) +{ + return (sc->nil); +} + +static s7_pointer g_list_1(s7_scheme * sc, s7_pointer args) +{ + return (list_1(sc, car(args))); +} + +static s7_pointer g_list_2(s7_scheme * sc, s7_pointer args) +{ + return (list_2(sc, car(args), cadr(args))); +} + +static s7_pointer g_list_3(s7_scheme * sc, s7_pointer args) +{ + return (list_3(sc, car(args), cadr(args), caddr(args))); +} + +static s7_pointer g_list_4(s7_scheme * sc, s7_pointer args) +{ + s7_pointer p = cddr(args); + return (list_4(sc, car(args), cadr(args), car(p), cadr(p))); +} + +static s7_pointer list_chooser(s7_scheme * sc, s7_pointer f, int32_t args, + s7_pointer expr, bool ops) +{ + if (args == 0) + return (sc->list_0); + if (args == 1) + return (sc->list_1); + if (args == 2) + return (sc->list_2); + if (args == 3) + return (sc->list_3); + return ((args == 4) ? sc->list_4 : f); +} + +static s7_pointer list_p_p(s7_scheme * sc, s7_pointer p1) +{ + return (list_1(sc, p1)); +} + +static s7_pointer list_p_pp(s7_scheme * sc, s7_pointer p1, s7_pointer p2) +{ + return (list_2(sc, p1, p2)); +} + +static s7_pointer list_p_ppp(s7_scheme * sc, s7_pointer p1, s7_pointer p2, + s7_pointer p3) +{ + return (list_3(sc, p1, p2, p3)); +} + +/* these used to GC protect the args, but I think the GC protection belonged in make-list */ + +static void check_list_validity(s7_scheme * sc, const char *caller, + s7_pointer lst) +{ + s7_pointer p; + int32_t i; + for (i = 1, p = lst; is_pair(p); p = cdr(p), i++) + if (!s7_is_valid(sc, car(p))) + s7_warn(sc, 256, "bad argument (#%d) to %s: %p\n", i, caller, + car(p)); +} + +s7_pointer s7_list(s7_scheme * sc, s7_int num_values, ...) +{ + s7_int i; + va_list ap; + s7_pointer p; + + if (num_values == 0) + return (sc->nil); + + sc->w = make_list(sc, num_values, sc->nil); + va_start(ap, num_values); + for (i = 0, p = sc->w; i < num_values; i++, p = cdr(p)) + set_car(p, va_arg(ap, s7_pointer)); + va_end(ap); + + if (sc->safety > NO_SAFETY) + check_list_validity(sc, "s7_list", sc->w); + + p = sc->w; + sc->w = sc->nil; + return (p); +} + +s7_pointer s7_list_nl(s7_scheme * sc, s7_int num_values, ...) +{ /* arglist should be NULL terminated */ + s7_int i; + va_list ap; + s7_pointer p, q; + + if (num_values == 0) + return (sc->nil); + + sc->w = make_list(sc, num_values, sc->nil); + va_start(ap, num_values); + for (q = sc->w, i = 0; i < num_values; i++, q = cdr(q)) { + p = va_arg(ap, s7_pointer); + if (!p) { + va_end(ap); + return (s7_wrong_number_of_args_error(sc, "not enough arguments for s7_list_nl: ~S", sc->w)); /* ideally we'd sublist this and append extra below */ + } + set_car(q, p); + } + p = va_arg(ap, s7_pointer); + va_end(ap); + if (p) + return (s7_wrong_number_of_args_error + (sc, "too many arguments for s7_list_nl: ~S", sc->w)); + + if (sc->safety > NO_SAFETY) + check_list_validity(sc, "s7_list_nl", sc->w); + + p = sc->w; + sc->w = sc->nil; + return (p); +} + +static s7_pointer safe_list_1(s7_scheme * sc) +{ + if (!list_is_in_use(sc->safe_lists[1])) { + sc->current_safe_list = 1; + set_list_in_use(sc->safe_lists[1]); + return (sc->safe_lists[1]); + } + return (cons(sc, sc->nil, sc->nil)); +} + +static s7_pointer safe_list_2(s7_scheme * sc) +{ + if (!list_is_in_use(sc->safe_lists[2])) { + sc->current_safe_list = 2; + set_list_in_use(sc->safe_lists[2]); + return (sc->safe_lists[2]); + } + return (cons_unchecked(sc, sc->nil, list_1(sc, sc->nil))); +} + +static s7_pointer make_safe_list(s7_scheme * sc, s7_int num_args) +{ + if (num_args < NUM_SAFE_LISTS) { + sc->current_safe_list = num_args; + if (!is_pair(sc->safe_lists[num_args])) + sc->safe_lists[num_args] = permanent_list(sc, num_args); + if (!list_is_in_use(sc->safe_lists[num_args])) { + set_list_in_use(sc->safe_lists[num_args]); + return (sc->safe_lists[num_args]); + } + } + return (make_big_list(sc, num_args, sc->nil)); +} + +static inline s7_pointer safe_list_if_possible(s7_scheme * sc, + s7_int num_args) +{ + if ((num_args < NUM_SAFE_PRELISTS) && + (!list_is_in_use(sc->safe_lists[num_args]))) { + sc->current_safe_list = num_args; + set_list_in_use(sc->safe_lists[num_args]); + return (sc->safe_lists[num_args]); + } + return (make_safe_list(sc, num_args)); +} + +static s7_int sequence_length(s7_scheme * sc, s7_pointer lst); +static s7_pointer s7_copy_1(s7_scheme * sc, s7_pointer caller, + s7_pointer args); + +static s7_pointer g_list_append(s7_scheme * sc, s7_pointer args) +{ + s7_pointer y, tp = sc->nil, np = NULL, pp; + bool all_args_are_lists = true; + + /* we know here that car(args) is a list and cdr(args) is not nil; this function does not check sc->max_list_length; called only in g_append */ + s7_gc_protect_via_stack(sc, args); + for (y = args; is_pair(y); y = cdr(y)) { /* arglist so not dotted */ + s7_pointer p = car(y), func; + + if ((has_active_methods(sc, p)) && + ((func = + find_method_with_let(sc, p, + sc->append_symbol)) != sc->undefined)) { + unstack(sc); + return (call_method + (sc, p, func, + (is_null(tp)) ? y : set_ulist_1(sc, tp, y))); + } + + if (is_null(cdr(y))) { + if (is_null(tp)) { + unstack(sc); + return (p); + } + /* (append (list 1) "hi") should return '(1 . "hi") not '(1 #\h #\i) + * but this is inconsistent with (append (list 1) "hi" "hi") -> '(1 #\h #\i . "hi") ? + * Perhaps if all args but last are lists, returned dotted list? + */ + if ((all_args_are_lists) || (is_null(p))) + set_cdr(np, p); + else { + s7_int len; + len = sequence_length(sc, p); + if (len > 0) + set_cdr(np, + s7_copy_1(sc, sc->append_symbol, + set_plist_2(sc, p, + protected_make_list(sc, + len, + sc->F)))); + else if (len < 0) + set_cdr(np, p); + } + sc->y = sc->nil; + unstack(sc); + return (tp); + } + + if (!is_sequence(p)) + return (wrong_type_argument_with_type + (sc, sc->append_symbol, position_of(y, args), p, + a_sequence_string)); + + if (!is_null(p)) { + if (is_pair(p)) { + if (!s7_is_proper_list(sc, p)) { + sc->y = sc->nil; + return (wrong_type_argument_with_type + (sc, sc->append_symbol, position_of(y, args), + p, a_proper_list_string)); + } + if (is_null(tp)) { + tp = list_1(sc, car(p)); + np = tp; + sc->y = tp; /* GC protect? */ + pp = cdr(p); + } else + pp = p; + for (; is_pair(pp); pp = cdr(pp), np = cdr(np)) + set_cdr(np, list_1(sc, car(pp))); + } else { + s7_int len; + len = sequence_length(sc, p); + all_args_are_lists = false; + if (len > 0) { + if (is_null(tp)) { + tp = s7_copy_1(sc, sc->append_symbol, + set_plist_2(sc, p, + protected_make_list(sc, + len, + sc->F))); + np = tp; + sc->y = tp; + } else + set_cdr(np, + s7_copy_1(sc, sc->append_symbol, + set_plist_2(sc, p, + protected_make_list + (sc, len, sc->F)))); + for (; is_pair(cdr(np)); np = cdr(np)); + } else if (len < 0) + return (wrong_type_argument_with_type + (sc, sc->append_symbol, position_of(y, args), + p, a_sequence_string)); + } + } + } + unstack(sc); + return (tp); +} + +static s7_pointer append_in_place(s7_scheme * sc, s7_pointer a, + s7_pointer b) +{ + /* tack b onto the end of a without copying either -- 'a' is changed! */ + s7_pointer p; + if (is_null(a)) + return (b); + p = a; + while (is_not_null(cdr(p))) + p = cdr(p); + set_cdr(p, b); + return (a); +} + + +/* -------------------------------- vectors -------------------------------- */ + +bool s7_is_vector(s7_pointer p) +{ + return (is_any_vector(p)); +} + +bool s7_is_float_vector(s7_pointer p) +{ + return (is_float_vector(p)); +} + +bool s7_is_int_vector(s7_pointer p) +{ + return (is_int_vector(p)); +} + +static bool is_byte_vector_b_p(s7_pointer b) +{ + return (is_byte_vector(b)); +} + +s7_int s7_vector_length(s7_pointer vec) +{ + return (vector_length(vec)); +} + +static s7_pointer default_vector_setter(s7_scheme * sc, s7_pointer vec, + s7_int loc, s7_pointer val) +{ + vector_element(vec, loc) = val; + return (val); +} + +static s7_pointer typed_vector_typer_symbol(s7_scheme * sc, s7_pointer p) +{ + s7_pointer typer = typed_vector_typer(p); + return ((is_c_function(typer)) ? c_function_symbol(typer) : + find_closure(sc, typer, closure_let(typer))); +} + +static const char *typed_vector_typer_name(s7_scheme * sc, s7_pointer p) +{ + s7_pointer typer = typed_vector_typer(p); + return ((is_c_function(typer)) ? c_function_name(typer) : + symbol_name(typed_vector_typer_symbol(sc, p))); +} + +static const char *make_type_name(s7_scheme * sc, const char *name, + article_t article); + +static inline s7_pointer typed_vector_setter(s7_scheme * sc, + s7_pointer vec, s7_int loc, + s7_pointer val) +{ + if ((sc->safety < NO_SAFETY) || /* or == NO_SAFETY?? */ + (typed_vector_typer_call(sc, vec, set_plist_1(sc, val)) != sc->F)) { + vector_element(vec, loc) = val; + return (val); + } + return (s7_wrong_type_arg_error + (sc, "vector-set!", 3, val, + make_type_name(sc, typed_vector_typer_name(sc, vec), + INDEFINITE_ARTICLE))); +} + +static s7_pointer default_vector_getter(s7_scheme * sc, s7_pointer vec, + s7_int loc) +{ + return (vector_element(vec, loc)); +} + +static s7_pointer int_vector_getter(s7_scheme * sc, s7_pointer vec, + s7_int loc) +{ + return (make_integer(sc, int_vector(vec, loc))); +} + +static s7_pointer float_vector_getter(s7_scheme * sc, s7_pointer vec, + s7_int loc) +{ + return (make_real(sc, float_vector(vec, loc))); +} + +static s7_pointer byte_vector_getter(s7_scheme * sc, s7_pointer bv, + s7_int loc) +{ + return (make_integer(sc, (uint8_t) (byte_vector(bv, loc)))); +} + +static s7_pointer int_vector_setter(s7_scheme * sc, s7_pointer vec, + s7_int loc, s7_pointer val) +{ + if (s7_is_integer(val)) + int_vector(vec, loc) = s7_integer_checked(sc, val); + else + s7_wrong_type_arg_error(sc, "int-vector-set!", 3, val, + "an integer"); + return (val); +} + +static s7_pointer float_vector_setter(s7_scheme * sc, s7_pointer vec, + s7_int loc, s7_pointer val) +{ + float_vector(vec, loc) = real_to_double(sc, val, "float-vector-set!"); + return (val); +} + +static s7_pointer byte_vector_setter(s7_scheme * sc, s7_pointer str, + s7_int loc, s7_pointer val) +{ + s7_int byte; + if (!s7_is_integer(val)) + return (s7_wrong_type_arg_error + (sc, "byte-vector-set!", 3, val, "an integer")); + byte = s7_integer_checked(sc, val); + if ((byte >= 0) && (byte < 256)) { + byte_vector(str, loc) = (uint8_t) byte; + return (val); + } + return (s7_wrong_type_arg_error + (sc, "byte-vector-set!", 3, val, "a byte")); +} + +static Inline block_t *mallocate_vector(s7_scheme * sc, s7_int len) +{ + block_t *b; + if (len > 0) + return (mallocate(sc, len)); + b = mallocate_block(sc); + block_data(b) = NULL; + block_info(b) = NULL; + return (b); +} + +static inline s7_pointer make_simple_vector(s7_scheme * sc, s7_int len) +{ /* len >= 0 and < max */ + s7_pointer x; + block_t *b; + new_cell(sc, x, T_VECTOR | T_SAFE_PROCEDURE); + vector_length(x) = len; + b = mallocate_vector(sc, len * sizeof(s7_pointer)); + vector_block(x) = b; + vector_elements(x) = (s7_pointer *) block_data(b); + vector_set_dimension_info(x, NULL); + vector_getter(x) = default_vector_getter; + vector_setter(x) = default_vector_setter; + add_vector(sc, x); + return (x); +} + +static inline s7_pointer make_simple_float_vector(s7_scheme * sc, + s7_int len) +{ /* len >= 0 and < max */ + s7_pointer x; + block_t *b; + new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); + vector_length(x) = len; + b = mallocate_vector(sc, len * sizeof(s7_double)); + vector_block(x) = b; + float_vector_floats(x) = (s7_double *) block_data(b); + vector_set_dimension_info(x, NULL); + vector_getter(x) = float_vector_getter; + vector_setter(x) = float_vector_setter; + add_vector(sc, x); + return (x); +} + +static inline s7_pointer make_simple_int_vector(s7_scheme * sc, s7_int len) +{ /* len >= 0 and < max */ + s7_pointer x; + block_t *b; + new_cell(sc, x, T_INT_VECTOR | T_SAFE_PROCEDURE); + vector_length(x) = len; + b = mallocate_vector(sc, len * sizeof(s7_int)); + vector_block(x) = b; + int_vector_ints(x) = (s7_int *) block_data(b); + vector_set_dimension_info(x, NULL); + vector_getter(x) = int_vector_getter; + vector_setter(x) = int_vector_setter; + add_vector(sc, x); + return (x); +} + +static s7_pointer make_simple_byte_vector(s7_scheme * sc, s7_int len) +{ + s7_pointer x; + block_t *b; + new_cell(sc, x, T_BYTE_VECTOR | T_SAFE_PROCEDURE); + b = mallocate(sc, len); + vector_block(x) = b; + byte_vector_bytes(x) = (uint8_t *) block_data(b); + vector_length(x) = len; + vector_set_dimension_info(x, NULL); + vector_getter(x) = byte_vector_getter; + vector_setter(x) = byte_vector_setter; + add_vector(sc, x); + return (x); +} + +static s7_pointer make_vector_1(s7_scheme * sc, s7_int len, bool filled, + uint8_t typ) +{ + s7_pointer x; + + if (len < 0) + return (wrong_type_argument_with_type + (sc, sc->make_vector_symbol, 1, wrap_integer1(sc, len), + a_non_negative_integer_string)); + if (len > sc->max_vector_length) + return (out_of_range + (sc, sc->make_vector_symbol, int_one, + wrap_integer1(sc, len), its_too_large_string)); + + /* this has to follow the error checks! (else garbage in free_heap temps portion confuses GC when "vector" is finalized) */ + + new_cell(sc, x, typ | T_SAFE_PROCEDURE); + vector_length(x) = len; + if (len == 0) { + vector_block(x) = mallocate_vector(sc, 0); + vector_elements(x) = NULL; + if (typ == T_VECTOR) + set_has_simple_elements(x); + } else { + block_t *b; + if (typ == T_VECTOR) { + b = mallocate_vector(sc, len * sizeof(s7_pointer)); + vector_block(x) = b; + vector_elements(x) = (s7_pointer *) block_data(b); + vector_getter(x) = default_vector_getter; + vector_setter(x) = default_vector_setter; + if (filled) + s7_vector_fill(sc, x, sc->nil); + } else if (typ == T_FLOAT_VECTOR) { + b = mallocate_vector(sc, len * sizeof(s7_double)); + vector_block(x) = b; + float_vector_floats(x) = (s7_double *) block_data(b); + if (filled) { + if (STEP_8(len)) + memclr64((void *) vector_elements(x), + len * sizeof(s7_double)); + else + memclr((void *) vector_elements(x), + len * sizeof(s7_double)); + } + vector_getter(x) = float_vector_getter; + vector_setter(x) = float_vector_setter; + } else if (typ == T_INT_VECTOR) { + b = mallocate_vector(sc, len * sizeof(s7_int)); + vector_block(x) = b; + int_vector_ints(x) = (s7_int *) block_data(b); + if (filled) { + if (STEP_8(len)) + memclr64((void *) vector_elements(x), + len * sizeof(s7_int)); + else + memclr((void *) vector_elements(x), + len * sizeof(s7_int)); + } + vector_getter(x) = int_vector_getter; + vector_setter(x) = int_vector_setter; + } else { /* byte-vector */ + b = mallocate(sc, len); + vector_block(x) = b; + byte_vector_bytes(x) = (uint8_t *) block_data(b); + vector_getter(x) = byte_vector_getter; + vector_setter(x) = byte_vector_setter; + if (filled) { + if (STEP_64(len)) + memclr64((void *) (byte_vector_bytes(x)), len); + else + memclr((void *) (byte_vector_bytes(x)), len); + } + }} + vector_set_dimension_info(x, NULL); + return (x); +} + +#define FILLED true +#define NOT_FILLED false + +s7_pointer s7_make_vector(s7_scheme * sc, s7_int len) +{ + s7_pointer v; + v = make_vector_1(sc, len, FILLED, T_VECTOR); + add_vector(sc, v); + return (v); +} + +s7_pointer s7_make_and_fill_vector(s7_scheme * sc, s7_int len, + s7_pointer fill) +{ + s7_pointer vect; + vect = make_simple_vector(sc, len); + s7_vector_fill(sc, vect, fill); + return (vect); +} + +static vdims_t *make_wrap_only(s7_scheme * sc) +{ /* this makes sc->wrap_only */ + vdims_t *v; + v = (vdims_t *) mallocate_block(sc); + vdims_original(v) = sc->F; + vector_elements_should_be_freed(v) = false; + vdims_rank(v) = 1; + vdims_dims(v) = NULL; + vdims_offsets(v) = NULL; + return (v); +} + +static vdims_t *make_vdims(s7_scheme * sc, bool elements_should_be_freed, + s7_int dims, s7_int * dim_info) +{ + vdims_t *v; + + if ((dims == 1) && (!elements_should_be_freed)) + return (sc->wrap_only); + + if (dims > 1) { + s7_int i, offset = 1; + v = (vdims_t *) mallocate(sc, dims * 2 * sizeof(s7_int)); + vdims_original(v) = sc->F; + vector_elements_should_be_freed(v) = elements_should_be_freed; + vdims_rank(v) = dims; + vdims_offsets(v) = (s7_int *) (vdims_dims(v) + dims); + + for (i = 0; i < dims; i++) + vdims_dims(v)[i] = dim_info[i]; + for (i = dims - 1; i >= 0; i--) { + vdims_offsets(v)[i] = offset; + offset *= vdims_dims(v)[i]; + } + } else { + v = (vdims_t *) mallocate_block(sc); + vdims_original(v) = sc->F; + vector_elements_should_be_freed(v) = elements_should_be_freed; + vdims_rank(v) = 1; + vdims_dims(v) = NULL; + vdims_offsets(v) = NULL; + } + return (v); +} + +static s7_pointer make_any_vector(s7_scheme * sc, int32_t type, s7_int len, + s7_int dims, s7_int * dim_info) +{ + s7_pointer p; + p = make_vector_1(sc, len, FILLED, type); + if (dim_info) { + vector_set_dimension_info(p, + make_vdims(sc, false, dims, dim_info)); + add_multivector(sc, p); + } else + add_vector(sc, p); + return (p); +} + +s7_pointer s7_make_int_vector(s7_scheme * sc, s7_int len, s7_int dims, + s7_int * dim_info) +{ + return (make_any_vector(sc, T_INT_VECTOR, len, dims, dim_info)); +} + +s7_pointer s7_make_float_vector(s7_scheme * sc, s7_int len, s7_int dims, + s7_int * dim_info) +{ + return (make_any_vector(sc, T_FLOAT_VECTOR, len, dims, dim_info)); +} + +s7_pointer s7_make_normal_vector(s7_scheme * sc, s7_int len, s7_int dims, + s7_int * dim_info) +{ + return (make_any_vector(sc, T_VECTOR, len, dims, dim_info)); +} + +s7_pointer s7_make_float_vector_wrapper(s7_scheme * sc, s7_int len, + s7_double * data, s7_int dims, + s7_int * dim_info, bool free_data) +{ + /* this wraps up a C-allocated/freed double array as an s7 vector. */ + s7_pointer x; + block_t *b; + + new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); + b = mallocate_vector(sc, 0); + vector_block(x) = b; + float_vector_floats(x) = data; + vector_getter(x) = float_vector_getter; + vector_setter(x) = float_vector_setter; + vector_length(x) = len; + if (!dim_info) { + s7_int di[1]; + di[0] = len; + vector_set_dimension_info(x, make_vdims(sc, free_data, 1, di)); + } else + vector_set_dimension_info(x, + make_vdims(sc, free_data, dims, + dim_info)); + add_multivector(sc, x); + return (x); +} + + +/* -------------------------------- vector-fill! -------------------------------- */ +static Vectorized void float_vector_fill(s7_scheme * sc, s7_pointer vec, + s7_double x) +{ + s7_int len = vector_length(vec); + if (len == 0) + return; + if (x == 0.0) { + if (STEP_8(len)) + memclr64((void *) float_vector_floats(vec), + len * sizeof(s7_double)); + else + memclr((void *) float_vector_floats(vec), + len * sizeof(s7_double)); + } else { + s7_int i = 0, left = len - 8; + s7_double *orig = float_vector_floats(vec); + while (i <= left) + LOOP_8(orig[i++] = x); + for (; i < len; i++) + orig[i] = x; + } +} + +static Vectorized void int_vector_fill(s7_scheme * sc, s7_pointer vec, + s7_int k) +{ + s7_int len = vector_length(vec); + if (len == 0) + return; + if (k == 0) { + if (STEP_8(len)) + memclr64((void *) int_vector_ints(vec), len * sizeof(s7_int)); + else + memclr((void *) int_vector_ints(vec), len * sizeof(s7_int)); + } else { + s7_int i = 0, left = len - 8; + s7_int *orig = int_vector_ints(vec); + while (i <= left) + LOOP_8(orig[i++] = k); + for (; i < len; i++) + orig[i] = k; + } +} + +static void byte_vector_fill(s7_scheme * sc, s7_pointer vec, uint8_t byte) +{ + s7_int len = vector_length(vec); + if (len == 0) + return; + if (byte > 0) + local_memset((void *) (byte_vector_bytes(vec)), byte, len); + else /* byte == 0 */ if (STEP_64(len)) + memclr64((void *) (byte_vector_bytes(vec)), len); + else + memclr((void *) (byte_vector_bytes(vec)), len); +} + +static Vectorized void normal_vector_fill(s7_scheme * sc, s7_pointer vec, + s7_pointer obj) +{ + s7_pointer *orig; + s7_int len = vector_length(vec), i, left; + + if (len == 0) + return; + /* splitting out this part made no difference in speed; type check of obj is handled elsewhere */ + orig = vector_elements(vec); + left = len - 8; + i = 0; + while (i <= left) + LOOP_8(orig[i++] = obj); + for (; i < len; i++) + orig[i] = obj; +} + +void s7_vector_fill(s7_scheme * sc, s7_pointer vec, s7_pointer obj) +{ + switch (type(vec)) { + case T_FLOAT_VECTOR: + if (!is_real(obj)) + s7_wrong_type_arg_error(sc, "float-vector fill!", 2, obj, + "a real"); + else + float_vector_fill(sc, vec, s7_real(obj)); + break; + + case T_INT_VECTOR: + if (!s7_is_integer(obj)) /* possibly a bignum */ + s7_wrong_type_arg_error(sc, "int-vector fill!", 2, obj, + "an integer"); + else + int_vector_fill(sc, vec, s7_integer_checked(sc, obj)); + break; + + case T_BYTE_VECTOR: + if (!is_byte(obj)) + s7_wrong_type_arg_error(sc, "byte-vector fill!", 2, obj, + "a byte"); + else + byte_vector_fill(sc, vec, + (uint8_t) s7_integer_checked(sc, obj)); + break; + + case T_VECTOR: + default: + normal_vector_fill(sc, vec, obj); + } +} + +static s7_pointer g_vector_fill_1(s7_scheme * sc, s7_pointer caller, + s7_pointer args) +{ + s7_pointer x = car(args), fill; + s7_int start = 0, end; + + if (!is_any_vector(x)) { + check_method(sc, x, sc->vector_fill_symbol, args); + /* not two_methods (and fill!) here else we get stuff like: + * (let ((e (openlet (inlet 'fill! (lambda (obj val) (string-fill! (obj 'value) val)) 'value "01234")))) (vector-fill! e #\a) (e 'value)) -> "aaaaa" + */ + return (wrong_type_argument(sc, caller, 1, x, T_VECTOR)); + } + if (is_immutable_vector(x)) + return (immutable_object_error + (sc, set_elist_3(sc, immutable_error_string, caller, x))); + + fill = cadr(args); + + if ((is_typed_vector(x)) && + (typed_vector_typer_call(sc, x, set_plist_1(sc, fill)) == sc->F)) + s7_wrong_type_arg_error(sc, "vector fill!", 2, fill, + make_type_name(sc, + typed_vector_typer_name(sc, + x), + INDEFINITE_ARTICLE)); + + if (is_float_vector(x)) { + if (!is_real(fill)) /* possibly a bignum */ + return (method_or_bust(sc, fill, caller, args, T_REAL, 2)); + } else if ((is_int_vector(x)) || (is_byte_vector(x))) { + if (!s7_is_integer(fill)) + return (method_or_bust(sc, fill, caller, args, T_INTEGER, 2)); + if ((is_byte_vector(x)) && ((s7_integer_checked(sc, fill) < 0) + || (s7_integer_checked(sc, fill) > + 255))) + return (out_of_range + (sc, caller, int_two, fill, an_unsigned_byte_string)); + } + + end = vector_length(x); + if (!is_null(cddr(args))) { + s7_pointer p; + p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); + if (p != sc->unused) + return (p); + if (start == end) + return (fill); + } + if (end == 0) + return (fill); + + if ((start == 0) && (end == vector_length(x))) + s7_vector_fill(sc, x, fill); + else { + s7_int i; + if (is_normal_vector(x)) + for (i = start; i < end; i++) + vector_element(x, i) = fill; + else if (is_int_vector(x)) { + s7_int k = s7_integer_checked(sc, fill); + if (k == 0) + memclr((void *) (int_vector_ints(x) + start), + (end - start) * sizeof(s7_int)); + else + for (i = start; i < end; i++) + int_vector(x, i) = k; + } else if (is_float_vector(x)) { + s7_double y = s7_real(fill); + if (y == 0.0) + memclr((void *) (float_vector_floats(x) + start), + (end - start) * sizeof(s7_double)); + else { + s7_double *orig = float_vector_floats(x); + s7_int left = end - 8; + i = start; + while (i <= left) + LOOP_8(orig[i++] = y); + for (; i < end; i++) + orig[i] = y; + } + } else if (is_byte_vector(x)) { + uint8_t k = (uint8_t) s7_integer_checked(sc, fill); + if (k == 0) + memclr((void *) (byte_vector_bytes(x) + start), + end - start); + else + local_memset((void *) (byte_vector_bytes(x) + start), k, + end - start); + } + } + return (fill); +} + +#if (!WITH_PURE_S7) +/* -------------------------------- vector-fill! -------------------------------- */ +static s7_pointer g_vector_fill(s7_scheme * sc, s7_pointer args) +{ +#define H_vector_fill "(vector-fill! v val start end) sets all elements of the vector v between start and end to val" +#define Q_vector_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->T, sc->is_integer_symbol) + return (g_vector_fill_1(sc, sc->vector_fill_symbol, args)); +} +#endif + + +/* -------------------------------- vector-ref|set! -------------------------------- */ +s7_pointer s7_vector_ref(s7_scheme * sc, s7_pointer vec, s7_int index) +{ + if (index >= vector_length(vec)) + return (out_of_range + (sc, sc->vector_ref_symbol, int_two, + wrap_integer1(sc, index), its_too_large_string)); + return (vector_getter(vec) (sc, vec, index)); +} + +s7_pointer s7_vector_set(s7_scheme * sc, s7_pointer vec, s7_int index, + s7_pointer a) +{ + if (index >= vector_length(vec)) + return (out_of_range + (sc, sc->vector_set_symbol, int_two, + wrap_integer1(sc, index), its_too_large_string)); + if (is_typed_vector(vec)) + return (typed_vector_setter(sc, vec, index, a)); + vector_setter(vec) (sc, vec, index, T_Pos(a)); + return (a); +} + + +s7_pointer *s7_vector_elements(s7_pointer vec) +{ + return (vector_elements(vec)); +} + +/* these are for s7.h */ +s7_int *s7_int_vector_elements(s7_pointer vec) +{ + return (int_vector_ints(vec)); +} + +s7_int s7_int_vector_ref(s7_pointer vec, s7_int index) +{ + return (int_vector_ints(vec)[index]); +} + +s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value) +{ + int_vector_ints(vec)[index] = value; + return (value); +} + +s7_double *s7_float_vector_elements(s7_pointer vec) +{ + return (float_vector_floats(vec)); +} + +s7_double s7_float_vector_ref(s7_pointer vec, s7_int index) +{ + return (float_vector_floats(vec)[index]); +} + +s7_double s7_float_vector_set(s7_pointer vec, s7_int index, + s7_double value) +{ + float_vector_floats(vec)[index] = value; + return (value); +} + +s7_int s7_vector_dimensions(s7_pointer vec, s7_int * dims, + s7_int dims_size) +{ + if (dims_size <= 0) + return (0); + if (vector_dimension_info(vec)) { + s7_int i, lim = vector_ndims(vec); + if (lim > dims_size) + lim = dims_size; + for (i = 0; i < lim; i++) + dims[i] = vector_dimension(vec, i); + return (lim); + } + dims[0] = vector_length(vec); + return (1); +} + +s7_int s7_vector_dimension(s7_pointer vec, s7_int dim) +{ + if (vector_dimension_info(vec)) + return (vector_dimension(vec, dim)); + return ((dim == 0) ? vector_length(vec) : -1); +} + +s7_int s7_vector_offsets(s7_pointer vec, s7_int * offs, s7_int offs_size) +{ + if (offs_size <= 0) + return (0); + if (vector_dimension_info(vec)) { + s7_int i, lim = vector_ndims(vec); + if (lim > offs_size) + lim = offs_size; + for (i = 0; i < lim; i++) + offs[i] = vector_offset(vec, i); + return (lim); + } + offs[0] = 1; + return (1); +} + + +#if (!WITH_PURE_S7) +/* -------------------------------- vector-append -------------------------------- */ +static s7_pointer vector_append(s7_scheme * sc, s7_pointer args, + uint8_t typ, s7_pointer caller); +static s7_pointer copy_source_no_dest(s7_scheme * sc, s7_pointer caller, + s7_pointer source, s7_pointer args); + +static s7_pointer g_vector_append(s7_scheme * sc, s7_pointer args) +{ + /* returns a one-dimensional vector. To handle multidimensional vectors, we'd need to + * ensure all the dimensional data matches (rank, size of each dimension except the last etc), + * which is too much trouble. + */ +#define H_vector_append "(vector-append . vectors) returns a new (1-dimensional) vector containing the elements of its vector arguments." +#define Q_vector_append sc->pcl_v + + s7_pointer p; + int32_t i; + + if (is_null(args)) + return (make_simple_vector(sc, 0)); + + if ((is_null(cdr(args))) && (is_any_vector(car(args)))) + return (copy_source_no_dest + (sc, sc->vector_append_symbol, car(args), args)); + + for (i = 0, p = args; is_pair(p); p = cdr(p), i++) { + s7_pointer x = car(p); + if (!is_any_vector(x)) { + if (has_active_methods(sc, x)) { + s7_pointer func; + func = + find_method_with_let(sc, x, sc->vector_append_symbol); + if (func != sc->undefined) { + int32_t k; + s7_pointer v, y; + if (i == 0) + return (call_method(sc, x, func, args)); + /* we have to copy the arglist here */ + sc->temp9 = make_list(sc, i, sc->F); + for (k = 0, y = args, v = sc->temp9; k < i; + k++, y = cdr(y), v = cdr(v)) + set_car(v, car(y)); + v = g_vector_append(sc, sc->temp9); + y = call_method(sc, x, func, set_ulist_1(sc, v, p)); + sc->temp9 = sc->nil; + return (y); + } + } + return (wrong_type_argument + (sc, sc->vector_append_symbol, i + 1, x, T_VECTOR)); + } + } + return (vector_append + (sc, args, type(car(args)), sc->vector_append_symbol)); +} + +static s7_pointer vector_append_p_pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + s7_pointer val; + sc->temp7 = list_2(sc, p1, p2); + val = g_vector_append(sc, sc->temp7); + sc->temp7 = sc->nil; + return (val); +} + +static s7_pointer vector_append_p_ppp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2, s7_pointer p3) +{ + s7_pointer val; + sc->temp7 = list_3(sc, p1, p2, p3); + val = g_vector_append(sc, sc->temp7); + sc->temp7 = sc->nil; + return (val); +} +#endif + +static s7_int flatten_multivector_indices(s7_scheme * sc, + s7_pointer vector, + s7_int indices, va_list ap) +{ + s7_int index, rank = vector_rank(vector); + if (rank != indices) { + va_end(ap); + s7_wrong_number_of_args_error(sc, + "s7_vector_ref_n: wrong number of indices: ~A", + wrap_integer1(sc, indices)); + } + if (rank == 1) + index = va_arg(ap, s7_int); + else { + s7_int i; + s7_int *dimensions = vector_dimensions(vector), *offsets = + vector_offsets(vector); + for (i = 0, index = 0; i < indices; i++) { + s7_int ind; + ind = va_arg(ap, s7_int); + if ((ind < 0) || (ind >= dimensions[i])) { + va_end(ap); + out_of_range(sc, sc->vector_ref_symbol, + wrap_integer1(sc, i), wrap_integer1(sc, ind), + (ind < + 0) ? its_negative_string : + its_too_large_string); + return (-1); + } + index += (ind * offsets[i]); + } + } + va_end(ap); + return (index); +} + +s7_pointer s7_vector_ref_n(s7_scheme * sc, s7_pointer vector, + s7_int indices, ...) +{ + s7_int index; + va_list ap; + va_start(ap, indices); + index = flatten_multivector_indices(sc, vector, indices, ap); + return (vector_getter(vector) (sc, vector, index)); +} + +s7_pointer s7_vector_set_n(s7_scheme * sc, s7_pointer vector, + s7_pointer value, s7_int indices, ...) +{ + s7_int index; + va_list ap; + va_start(ap, indices); + index = flatten_multivector_indices(sc, vector, indices, ap); + if (is_typed_vector(vector)) + return (typed_vector_setter(sc, vector, index, value)); + return (vector_setter(vector) (sc, vector, index, value)); +} + + +/* -------------------------------- vector->list -------------------------------- */ +s7_pointer s7_vector_to_list(s7_scheme * sc, s7_pointer vect) +{ + s7_int i, len = vector_length(vect); + s7_pointer result; + if (len == 0) + return (sc->nil); + check_free_heap_size(sc, len); + sc->v = sc->nil; + gc_protect_via_stack(sc, vect); + for (i = len - 1; i >= 0; i--) + sc->v = cons_unchecked(sc, vector_getter(vect) (sc, vect, i), sc->v); /* vector_getter can cause alloction/GC (int_vector_getter -> make_integer) */ + unstack(sc); + result = sc->v; + sc->v = sc->nil; + return (result); +} + +s7_pointer s7_array_to_list(s7_scheme * sc, s7_int num_values, + s7_pointer * array) +{ + s7_int i; + s7_pointer result; + if (num_values == 0) + return (sc->nil); + sc->v = sc->nil; + for (i = num_values - 1; i >= 0; i--) + sc->v = cons(sc, array[i], sc->v); + result = sc->v; + if (sc->safety > NO_SAFETY) + check_list_validity(sc, "s7_array_to_list", result); + sc->v = sc->nil; + return (result); +} + +#if (!WITH_PURE_S7) +static s7_pointer g_vector_to_list(s7_scheme * sc, s7_pointer args) +{ +#define H_vector_to_list "(vector->list v (start 0) end) returns the elements of the vector v as a list; (map values v)" +#define Q_vector_to_list s7_make_signature(sc, 4, sc->is_proper_list_symbol, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_symbol) + + s7_int i, start = 0, end; + s7_pointer p, vec = car(args); + if (!is_any_vector(vec)) + return (method_or_bust_one_arg + (sc, vec, sc->vector_to_list_symbol, args, T_VECTOR)); + + end = vector_length(vec); + if (!is_null(cdr(args))) { + p = start_and_end(sc, sc->vector_to_list_symbol, args, 2, + cdr(args), &start, &end); + if (p != sc->unused) + return (p); + if (start == end) + return (sc->nil); + } + if ((end - start) > sc->max_list_length) + return (out_of_range + (sc, sc->vector_to_list_symbol, int_one, car(args), + its_too_large_string)); + + check_free_heap_size(sc, end - start); + sc->w = sc->nil; + gc_protect_via_stack(sc, vec); + if (is_normal_vector(vec)) + for (i = end - 1; i >= start; i--) + sc->w = cons_unchecked(sc, vector_element(vec, i), sc->w); + else + for (i = end - 1; i >= start; i--) + sc->w = + cons_unchecked(sc, vector_getter(vec) (sc, vec, i), sc->w); + unstack(sc); + p = sc->w; + sc->w = sc->nil; + return (p); +} + +static s7_pointer vector_to_list_p_p(s7_scheme * sc, s7_pointer p) +{ + if (!is_any_vector(p)) + return (method_or_bust_one_arg_p + (sc, p, sc->vector_to_list_symbol, T_VECTOR)); + return (s7_vector_to_list(sc, p)); +} +#endif + + +/* -------------------------------- string->byte-vector -------------------------------- */ +static s7_pointer g_string_to_byte_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_string_to_byte_vector "(string->byte-vector obj) turns a string into a byte-vector." +#define Q_string_to_byte_vector s7_make_signature(sc, 2, sc->is_byte_vector_symbol, sc->is_string_symbol) + s7_pointer str = car(args); + if (!is_string(str)) + return (method_or_bust_p + (sc, str, sc->string_to_byte_vector_symbol, T_STRING)); + return (s7_copy_1 + (sc, sc->string_to_byte_vector_symbol, + set_plist_2(sc, str, + make_simple_byte_vector(sc, + string_length(str))))); +} + + +/* -------------------------------- byte-vector->string -------------------------------- */ +static s7_pointer g_byte_vector_to_string(s7_scheme * sc, s7_pointer args) +{ +#define H_byte_vector_to_string "(byte-vector->string obj) turns a byte-vector into a string." +#define Q_byte_vector_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_byte_vector_symbol) + s7_pointer v = car(args); + if (!is_byte_vector(v)) + return (method_or_bust_p + (sc, v, sc->byte_vector_to_string_symbol, T_BYTE_VECTOR)); + return (s7_copy_1 + (sc, sc->byte_vector_to_string_symbol, + set_plist_2(sc, v, + make_empty_string(sc, byte_vector_length(v), + 0)))); +} + + +/* -------------------------------- vector -------------------------------- */ +static s7_pointer g_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_vector "(vector ...) returns a vector whose elements are the arguments" +#define Q_vector s7_make_circular_signature(sc, 1, 2, sc->is_vector_symbol, sc->T) + + s7_int len; + s7_pointer vec, b; + + len = proper_list_length_with_end(args, &b); + if (!is_null(b)) + return (s7_error + (sc, sc->read_error_symbol, + set_elist_1(sc, + wrap_string(sc, + "vector constant data is not a proper list", + 41)))); + vec = make_simple_vector(sc, len); + if (len > 0) { + s7_int i; + s7_pointer x; + for (x = args, i = 0; is_pair(x); x = cdr(x), i++) + vector_element(vec, i) = car(x); + } + return (vec); +} + +static inline s7_pointer vector_p_pp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2) +{ + s7_pointer vec; + vec = make_simple_vector(sc, 2); + vector_element(vec, 0) = p1; + vector_element(vec, 1) = p2; + return (vec); +} + +static s7_pointer g_vector_2(s7_scheme * sc, s7_pointer args) +{ + return (vector_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_vector_3(s7_scheme * sc, s7_pointer args) +{ + s7_pointer vec; + vec = make_simple_vector(sc, 3); + vector_element(vec, 0) = car(args); + args = cdr(args); + vector_element(vec, 1) = car(args); + vector_element(vec, 2) = cadr(args); + return (vec); +} + +static s7_pointer vector_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if (args == 2) + return (sc->vector_2); + return ((args == 3) ? sc->vector_3 : f); +} + + +/* -------------------------------- float-vector? -------------------------------- */ +static s7_pointer g_is_float_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_is_float_vector "(float-vector? obj) returns #t if obj is an homogeneous float vector" +#define Q_is_float_vector sc->pl_bt + check_boolean_method(sc, s7_is_float_vector, + sc->is_float_vector_symbol, args); +} + + +/* -------------------------------- float-vector -------------------------------- */ +static s7_pointer g_float_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_float_vector "(float-vector ...) returns an homogeneous float vector whose elements are the arguments" +#define Q_float_vector s7_make_circular_signature(sc, 1, 2, sc->is_float_vector_symbol, sc->is_real_symbol) + + s7_int len; + s7_pointer vec, b; + + len = proper_list_length_with_end(args, &b); + if (!is_null(b)) + return (s7_error + (sc, sc->read_error_symbol, + set_elist_1(sc, + wrap_string(sc, + "float-vector constant data is not a proper list", + 47)))); + + vec = make_simple_float_vector(sc, len); + if (len > 0) { + s7_int i; + s7_pointer x; + sc->w = vec; + for (x = args, i = 0; is_pair(x); x = cdr(x), i++) { + s7_pointer p = car(x); + if (is_t_real(p)) + float_vector(vec, i) = real(p); + else if (is_real(p)) /* bignum is ok here */ + float_vector(vec, i) = s7_real(p); + else { + sc->w = sc->nil; + return (method_or_bust + (sc, p, sc->float_vector_symbol, args, T_REAL, + i + 1)); + } + } + sc->w = sc->nil; + } + return (vec); +} + +static s7_pointer float_vector_p_d(s7_scheme * sc, s7_double x) +{ + s7_pointer vec; + vec = make_simple_float_vector(sc, 1); + float_vector(vec, 0) = x; + return (vec); +} + + +/* -------------------------------- int-vector? -------------------------------- */ +static s7_pointer g_is_int_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_is_int_vector "(int-vector? obj) returns #t if obj is an homogeneous s7_int vector" +#define Q_is_int_vector sc->pl_bt + check_boolean_method(sc, is_int_vector, sc->is_int_vector_symbol, + args); +} + + +/* -------------------------------- int-vector -------------------------------- */ +static s7_pointer g_int_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_int_vector "(int-vector ...) returns an homogeneous s7_int vector whose elements are the arguments" +#define Q_int_vector s7_make_circular_signature(sc, 1, 2, sc->is_int_vector_symbol, sc->is_integer_symbol) + + s7_int i, len; + s7_pointer x, vec, b; + + len = proper_list_length_with_end(args, &b); + if (!is_null(b)) + return (s7_error + (sc, sc->read_error_symbol, + set_elist_1(sc, + wrap_string(sc, + "int-vector constant data is not a proper list", + 45)))); + vec = make_simple_int_vector(sc, len); + if (len == 0) + return (vec); + for (x = args, i = 0; is_pair(x); x = cdr(x), i++) { + s7_pointer p = car(x); + if (s7_is_integer(p)) + int_vector(vec, i) = s7_integer_checked(sc, p); + else + return (method_or_bust + (sc, p, sc->int_vector_symbol, args, T_INTEGER, + i + 1)); + } + return (vec); +} + +static s7_pointer int_vector_p_i(s7_scheme * sc, s7_int x) +{ + s7_pointer vec; + vec = make_simple_int_vector(sc, 1); + int_vector(vec, 0) = x; + return (vec); +} + + +/* -------------------------------- byte-vector? -------------------------------- */ +static s7_pointer g_is_byte_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector" +#define Q_is_byte_vector sc->pl_bt + check_boolean_method(sc, is_byte_vector_b_p, sc->is_byte_vector_symbol, + args); +} + + +/* -------------------------------- byte-vector -------------------------------- */ +static s7_pointer g_byte_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_byte_vector "(byte-vector ...) returns a byte-vector whose elements are the arguments" +#define Q_byte_vector s7_make_circular_signature(sc, 1, 2, sc->is_byte_vector_symbol, sc->is_byte_symbol) + + s7_int i, len; + s7_pointer vec, x, end; + uint8_t *str; + + len = proper_list_length_with_end(args, &end); + if (!is_null(end)) + return (s7_error + (sc, sc->read_error_symbol, + set_elist_1(sc, + wrap_string(sc, + "byte-vector constant data is not a proper list", + 46)))); + + vec = make_simple_byte_vector(sc, len); + str = byte_vector_bytes(vec); + + for (i = 0, x = args; is_pair(x); i++, x = cdr(x)) { + s7_pointer byte = car(x); + s7_int b; + if (is_t_integer(byte)) + b = integer(byte); + else +#if WITH_GMP + if (is_t_big_integer(byte)) + b = big_integer_to_s7_int(sc, big_integer(byte)); + else +#endif + return (method_or_bust + (sc, byte, sc->byte_vector_symbol, args, T_INTEGER, + i + 1)); + if ((b < 0) || (b > 255)) + return (simple_wrong_type_argument_with_type + (sc, sc->byte_vector_symbol, byte, + an_unsigned_byte_string)); + str[i] = (uint8_t) b; + } + return (vec); +} + + +#if (!WITH_PURE_S7) +/* -------------------------------- list->vector -------------------------------- */ +static s7_pointer g_list_to_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_list_to_vector "(list->vector lst) returns a vector containing the elements of lst; (apply vector lst)" +#define Q_list_to_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_proper_list_symbol) + + s7_pointer p = car(args); + if (is_null(p)) + return (s7_make_vector(sc, 0)); + sc->temp3 = p; + if (!s7_is_proper_list(sc, p)) + return (method_or_bust_with_type_one_arg_p + (sc, p, sc->list_to_vector_symbol, a_proper_list_string)); + p = g_vector(sc, p); + sc->temp3 = sc->nil; + return (p); +} + +/* -------------------------------- vector-length -------------------------------- */ +static s7_pointer g_vector_length(s7_scheme * sc, s7_pointer args) +{ +#define H_vector_length "(vector-length v) returns the length of vector v" +#define Q_vector_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol) + + s7_pointer vec = car(args); + if (!is_any_vector(vec)) + return (method_or_bust_one_arg + (sc, vec, sc->vector_length_symbol, args, T_VECTOR)); + return (make_integer(sc, vector_length(vec))); +} + +static s7_int vector_length_i_7p(s7_scheme * sc, s7_pointer p) +{ + if (!is_any_vector(p)) + return (integer + (method_or_bust_one_arg_p + (sc, p, sc->vector_length_symbol, T_VECTOR))); + return (vector_length(p)); +} + +static s7_pointer vector_length_p_p(s7_scheme * sc, s7_pointer vec) +{ + if (!is_any_vector(vec)) + return (method_or_bust_one_arg_p + (sc, vec, sc->vector_length_symbol, T_VECTOR)); + return (make_integer(sc, vector_length(vec))); +} +#endif + + +/* -------------------------------- subvector subvector? subvector-vector subvector-position -------------------------------- */ +static bool s7_is_subvector(s7_pointer g) +{ + return ((is_any_vector(g)) && (is_subvector(g))); +} + +static s7_pointer g_is_subvector(s7_scheme * sc, s7_pointer args) +{ +#define H_is_subvector "(subvector? obj) returns #t if obj is a subvector" +#define Q_is_subvector sc->pl_bt + check_boolean_method(sc, s7_is_subvector, sc->is_subvector_symbol, + args); +} + +static s7_pointer g_subvector_position(s7_scheme * sc, s7_pointer args) +{ +#define H_subvector_position "(subvector-position obj) returns obj's offset" +#define Q_subvector_position s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_subvector_symbol) + + s7_pointer sv = car(args); + if (s7_is_subvector(sv)) { + /* we can't use vector_elements(sv) - vector_elements(subvector_vector(sv)) because that assumes we're looking at s7_pointer*, + * so a subvector of a byte_vector gets a bogus position (0 if position is less than 8 etc). + * Since we currently let the user reset s7_int and s7_double, all four cases have to be handled explicitly. + */ + switch (type(sv)) { + case T_VECTOR: + return (make_integer + (sc, + (s7_int) (vector_elements(sv) - + vector_elements(subvector_vector(sv))))); + case T_INT_VECTOR: + return (make_integer + (sc, + (s7_int) (int_vector_ints(sv) - + int_vector_ints(subvector_vector(sv))))); + case T_FLOAT_VECTOR: + return (make_integer + (sc, + (s7_int) (float_vector_floats(sv) - + float_vector_floats(subvector_vector + (sv))))); + case T_BYTE_VECTOR: + return (make_integer + (sc, + (s7_int) (byte_vector_bytes(sv) - + byte_vector_bytes(subvector_vector(sv))))); + } + } + return (method_or_bust_one_arg + (sc, sv, sc->subvector_position_symbol, args, T_VECTOR)); +} + +static s7_pointer g_subvector_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_subvector_vector "(subvector-vector obj) returns the vector underlying the subvector obj" +#define Q_subvector_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_subvector_symbol) + + if (s7_is_subvector(car(args))) + return (subvector_vector(car(args))); + return (method_or_bust_one_arg + (sc, car(args), sc->subvector_vector_symbol, args, T_VECTOR)); +} + +static s7_pointer subvector(s7_scheme * sc, s7_pointer vect, + s7_int skip_dims, s7_int index) +{ + s7_pointer x; + s7_int dims; + + new_cell(sc, x, + (full_type(vect) & (~T_COLLECTED)) | T_SUBVECTOR | + T_SAFE_PROCEDURE); + vector_length(x) = 0; + vector_block(x) = mallocate_vector(sc, 0); + vector_elements(x) = NULL; + vector_getter(x) = vector_getter(vect); + vector_setter(x) = vector_setter(vect); + + dims = vector_ndims(vect) - skip_dims; + if (dims > 1) { + vdims_t *v; + v = (vdims_t *) mallocate_block(sc); + vdims_rank(v) = dims; + vdims_dims(v) = (s7_int *) (vector_dimensions(vect) + skip_dims); + vdims_offsets(v) = (s7_int *) (vector_offsets(vect) + skip_dims); + vdims_original(v) = vect; + vector_elements_should_be_freed(v) = false; + vector_set_dimension_info(x, v); + } else { + vector_set_dimension_info(x, NULL); + subvector_set_vector(x, vect); + } + + if (is_normal_vector(vect)) + mark_function[T_VECTOR] = mark_vector_possibly_shared; + else + mark_function[type(vect)] = + mark_int_or_float_vector_possibly_shared; + + if (skip_dims > 0) + vector_length(x) = vector_offset(vect, skip_dims - 1); + else + vector_length(x) = vector_length(vect); + + if (is_int_vector(vect)) + int_vector_ints(x) = (s7_int *) (int_vector_ints(vect) + index); + else if (is_float_vector(vect)) + float_vector_floats(x) = + (s7_double *) (float_vector_floats(vect) + index); + else if (is_normal_vector(vect)) + vector_elements(x) = + (s7_pointer *) (vector_elements(vect) + index); + else + byte_vector_bytes(x) = + (uint8_t *) (byte_vector_bytes(vect) + index); + add_multivector(sc, x); + return (x); +} + +static inline vdims_t *list_to_dims(s7_scheme * sc, s7_pointer x) +{ + s7_int i, offset, len; + s7_pointer y; + vdims_t *v; + s7_int *ds, *os; + + len = proper_list_length(x); + v = (vdims_t *) mallocate(sc, len * 2 * sizeof(s7_int)); + vdims_rank(v) = len; + vdims_offsets(v) = (s7_int *) (vdims_dims(v) + len); + vector_elements_should_be_freed(v) = false; + ds = vdims_dims(v); + os = vdims_offsets(v); + + for (i = 0, y = x; is_not_null(y); i++, y = cdr(y)) + ds[i] = s7_integer_checked(sc, car(y)); + + for (i = len - 1, offset = 1; i >= 0; i--) { + os[i] = offset; + offset *= ds[i]; + } + return (v); +} + +static s7_pointer g_subvector(s7_scheme * sc, s7_pointer args) +{ +#define H_subvector "(subvector original-vector (start 0) (end original-vector-len) new-dimensions) returns \ +a vector that points to the same elements as the original-vector but with different starting point, end point, and dimensional info." +#define Q_subvector s7_make_signature(sc, 5, sc->is_subvector_symbol, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_pair_symbol) + + /* (let ((v1 #2d((1 2 3) (4 5 6)))) (let ((v2 (subvector v1 0 6))) v2)) -> #(1 2 3 4 5 6) + * (let ((v1 #(1 2 3 4 5 6))) (let ((v2 (subvector v1 0 6 '(3 2)))) v2)) -> #2D((1 2) (3 4) (5 6)) + */ + /* for a long time subvector was (subvector vector new-length-or-dimensions (new-start 0)) + * but that turned out to be confusing (start after end in effect, the reverse of substring and others) + * Here is a translation: + (define (old-subvector vect len (offset 0)) + (if (pair? len) + (subvector vect offset (+ offset (apply * len)) len) + (if (not len) + (subvector vect offset (vector-length vect)) + (subvector vect offset (+ offset len))))) + */ + s7_pointer orig = car(args), x; + vdims_t *v = NULL; + s7_int new_len, orig_len, offset = 0; + + /* get the vector */ + if (!is_any_vector(orig)) + return (method_or_bust + (sc, orig, sc->subvector_symbol, args, T_VECTOR, 1)); + + orig_len = vector_length(orig); + new_len = orig_len; + + if (is_pair(cdr(args))) { + /* get start point in vector */ + s7_pointer start = cadr(args); + if (!s7_is_integer(start)) + return (method_or_bust + (sc, start, sc->subvector_symbol, args, T_INTEGER, 2)); + offset = s7_integer_checked(sc, start); + if ((offset < 0) || (offset > orig_len)) /* we need this if, for example, offset == 9223372036854775807 */ + return (out_of_range + (sc, sc->subvector_symbol, int_two, start, + (offset < + 0) ? its_negative_string : its_too_large_string)); + new_len -= offset; + + if (is_pair(cddr(args))) { + /* get end point in vector */ + s7_pointer end = caddr(args); + s7_int new_end; + if (!s7_is_integer(end)) + return (method_or_bust + (sc, end, sc->subvector_symbol, args, T_INTEGER, + 3)); + new_end = s7_integer_checked(sc, end); + if ((new_end < 0) || (new_end > orig_len)) + return (out_of_range + (sc, sc->subvector_symbol, int_three, end, + (new_end < + 0) ? its_negative_string : + its_too_large_string)); + if (offset > new_end) + return (out_of_range + (sc, sc->subvector_symbol, int_two, start, + wrap_string(sc, "start point > end point", 23))); + new_len = new_end - offset; + + if (is_pair(cdddr(args))) { + s7_pointer y, dims = cadddr(args); + s7_int i; + if ((is_null(dims)) || (!s7_is_proper_list(sc, dims))) + return (method_or_bust + (sc, dims, sc->subvector_symbol, args, T_PAIR, + 4)); + + for (y = dims; is_pair(y); y = cdr(y)) + if ((!s7_is_integer(car(y))) || /* (subvector v '((1 2) (3 4))) */ + (s7_integer_checked(sc, car(y)) > orig_len) || + (s7_integer_checked(sc, car(y)) < 0)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_1(sc, + wrap_string(sc, + "a subvector must fit in the original vector", + 43)))); + + v = list_to_dims(sc, dims); + new_len = vdims_dims(v)[0]; + for (i = 1; i < vdims_rank(v); i++) + new_len *= vdims_dims(v)[i]; + if (new_len != new_end - offset) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, + wrap_string(sc, + "subvector dimensional length, ~S, does not match the start and end positions: ~S to ~S~%", + 88), + s7_make_integer(sc, new_len), + start, end)); + vdims_original(v) = orig; + } + } + } + + if (is_normal_vector(orig)) + mark_function[T_VECTOR] = mark_vector_possibly_shared; + else + mark_function[type(orig)] = mark_int_or_float_vector_possibly_shared; /* I think this works for byte-vectors also */ + + new_cell(sc, x, + (full_type(orig) & (~T_COLLECTED)) | T_SUBVECTOR | + T_SAFE_PROCEDURE); + vector_block(x) = mallocate_vector(sc, 0); + vector_set_dimension_info(x, v); + if (!v) + subvector_set_vector(x, orig); + vector_length(x) = new_len; /* might be less than original length */ + if ((new_len == 0) && (is_normal_vector(orig))) + set_has_simple_elements(x); + vector_getter(x) = vector_getter(orig); + vector_setter(x) = vector_setter(orig); + + if (is_int_vector(orig)) + int_vector_ints(x) = (s7_int *) (int_vector_ints(orig) + offset); + else if (is_float_vector(orig)) + float_vector_floats(x) = + (s7_double *) (float_vector_floats(orig) + offset); + else if (is_normal_vector(x)) + vector_elements(x) = + (s7_pointer *) (vector_elements(orig) + offset); + else + byte_vector_bytes(x) = + (uint8_t *) (byte_vector_bytes(orig) + offset); + add_multivector(sc, x); + return (x); +} + + +/* -------------------------------- vector-ref -------------------------------- */ +static s7_pointer vector_ref_1(s7_scheme * sc, s7_pointer vect, + s7_pointer indices) +{ + s7_int index = 0; + if (vector_length(vect) == 0) + return (out_of_range + (sc, sc->vector_ref_symbol, int_one, vect, + its_too_large_string)); + + if (vector_rank(vect) > 1) { + s7_int i; + s7_pointer x; + for (x = indices, i = 0; + (is_not_null(x)) && (i < vector_ndims(vect)); + x = cdr(x), i++) { + s7_int n; + s7_pointer p = car(x); + if (!s7_is_integer(p)) + return (method_or_bust + (sc, p, sc->vector_ref_symbol, + set_ulist_1(sc, vect, indices), T_INTEGER, + i + 2)); + n = s7_integer_checked(sc, p); + if ((n < 0) || (n >= vector_dimension(vect, i))) + return (out_of_range + (sc, sc->vector_ref_symbol, + wrap_integer1(sc, i + 2), p, + (n < + 0) ? its_negative_string : + its_too_large_string)); + + index += n * vector_offset(vect, i); + } + if (is_not_null(x)) { + s7_pointer nv; + if (!is_normal_vector(vect)) + return (out_of_range + (sc, sc->vector_ref_symbol, int_two, indices, + too_many_indices_string)); + nv = vector_element(vect, index); + return (implicit_index(sc, nv, x)); + } + + /* if not enough indices, return a subvector covering whatever is left */ + if (i < vector_ndims(vect)) + return (subvector(sc, vect, i, index)); + } else { + s7_pointer p = car(indices); + /* (let ((hi (make-vector 3 0.0)) (sum 0.0)) (do ((i 0 (+ i 1))) ((= i 3)) (set! sum (+ sum (hi i)))) sum) */ + + if (!s7_is_integer(p)) + return (method_or_bust + (sc, p, sc->vector_ref_symbol, + set_ulist_1(sc, vect, indices), T_INTEGER, 2)); + index = s7_integer_checked(sc, p); + + if ((index < 0) || (index >= vector_length(vect))) + return (out_of_range + (sc, sc->vector_ref_symbol, int_two, p, + (index < + 0) ? its_negative_string : its_too_large_string)); + + if (is_not_null(cdr(indices))) { /* (let ((L #(#(1 2 3) #(4 5 6)))) (vector-ref L 1 2)) */ + s7_pointer nv; + if (!is_normal_vector(vect)) + return (out_of_range + (sc, sc->vector_ref_symbol, int_two, indices, + too_many_indices_string)); + nv = vector_element(vect, index); + return (implicit_index(sc, nv, cdr(indices))); + } + } + return ((vector_getter(vect)) (sc, vect, index)); +} + +static s7_pointer g_vector_ref(s7_scheme * sc, s7_pointer args) +{ +#define H_vector_ref "(vector-ref v ... i) returns the i-th element of vector v." +#define Q_vector_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol, sc->is_integer_symbol) + + s7_pointer vec = car(args); + if (!is_any_vector(vec)) + return (method_or_bust + (sc, vec, sc->vector_ref_symbol, args, T_VECTOR, 1)); + return (vector_ref_1(sc, vec, cdr(args))); /* 19-Jan-19 */ +} + +static s7_pointer vector_ref_p_pi(s7_scheme * sc, s7_pointer v, s7_int i) +{ + if ((!is_normal_vector(v)) || + (vector_rank(v) > 1) || (i < 0) || (i >= vector_length(v))) + return (g_vector_ref(sc, set_plist_2(sc, v, make_integer(sc, i)))); + return (vector_element(v, i)); +} + +static s7_pointer vector_ref_p_pi_unchecked(s7_scheme * sc, s7_pointer v, + s7_int i) +{ + if ((i >= 0) && (i < vector_length(v))) + return (vector_getter(v) (sc, v, i)); + out_of_range(sc, sc->vector_ref_symbol, int_two, wrap_integer1(sc, i), + (i < 0) ? its_negative_string : its_too_large_string); + return (v); +} + +static s7_pointer normal_vector_ref_p_pi_unchecked(s7_scheme * sc, + s7_pointer v, s7_int i) +{ + if ((i >= 0) && (i < vector_length(v))) + return (vector_element(v, i)); + out_of_range(sc, sc->vector_ref_symbol, int_two, wrap_integer1(sc, i), + (i < 0) ? its_negative_string : its_too_large_string); + return (v); +} + +static s7_pointer vector_ref_p_pii(s7_scheme * sc, s7_pointer v, s7_int i1, + s7_int i2) +{ + if ((!is_any_vector(v)) || + (vector_rank(v) != 2) || + (i1 < 0) || (i2 < 0) || + (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) + return (g_vector_ref + (sc, + set_plist_3(sc, v, make_integer(sc, i1), + make_integer(sc, i2)))); + return (vector_getter(v) (sc, v, i2 + (i1 * vector_offset(v, 0)))); +} + +static s7_pointer vector_ref_p_pii_direct(s7_scheme * sc, s7_pointer v, + s7_int i1, s7_int i2) +{ + if ((i1 < 0) || (i2 < 0) || + (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) + return (g_vector_ref + (sc, + set_plist_3(sc, v, make_integer(sc, i1), + make_integer(sc, i2)))); + return (vector_element(v, i2 + (i1 * vector_offset(v, 0)))); +} + +/* this is specific to T_VECTOR */ +static s7_pointer vector_ref_unchecked(s7_scheme * sc, s7_pointer v, + s7_int i) +{ + if ((S7_DEBUGGING) && (!is_normal_vector(v))) + fprintf(stderr, "%s[%d]: vector is not T_VECTOR\n", __func__, + __LINE__); + return (vector_element(v, i)); +} + +static inline s7_pointer vector_ref_p_pp(s7_scheme * sc, s7_pointer vec, + s7_pointer ind) +{ + s7_int index; + if ((!is_normal_vector(vec)) || + (vector_rank(vec) != 1) || (!s7_is_integer(ind))) + return (g_vector_ref(sc, set_plist_2(sc, vec, ind))); + index = s7_integer_checked(sc, ind); + if ((index < 0) || (index >= vector_length(vec))) + return (out_of_range + (sc, sc->vector_ref_symbol, int_two, ind, + (index < + 0) ? its_negative_string : its_too_large_string)); + return (vector_element(vec, index)); +} + +static s7_pointer g_vector_ref_2(s7_scheme * sc, s7_pointer args) +{ + return (vector_ref_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_vector_ref_3(s7_scheme * sc, s7_pointer args) +{ + s7_pointer vec = car(args), i1, i2; + s7_int ix, iy; + + if (!is_any_vector(vec)) + return (g_vector_ref(sc, args)); + if (vector_rank(vec) != 2) + return (g_vector_ref(sc, args)); + + i1 = cadr(args); + if (!s7_is_integer(i1)) + return (g_vector_ref(sc, args)); + i2 = caddr(args); + if (!s7_is_integer(i2)) + return (g_vector_ref(sc, args)); + ix = s7_integer_checked(sc, i1); + iy = s7_integer_checked(sc, i2); + if ((ix >= 0) && + (iy >= 0) && + (ix < vector_dimension(vec, 0)) && + (iy < vector_dimension(vec, 1))) { + s7_int index; + index = (ix * vector_offset(vec, 0)) + iy; /* vector_offset(vec, 1) == 1 */ + return (vector_getter(vec) (sc, vec, index)); + } + return (g_vector_ref(sc, args)); +} + +static s7_pointer vector_ref_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + if (args == 2) + return (sc->vector_ref_2); + return ((args == 3) ? sc->vector_ref_3 : f); +} + + +/* -------------------------------- vector-set! -------------------------------- */ +static s7_pointer g_vector_set(s7_scheme * sc, s7_pointer args) +{ +#define H_vector_set "(vector-set! v i ... value) sets the i-th element of vector v to value." +#define Q_vector_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol) + + s7_pointer vec = car(args), val; + s7_int index; + + if (!is_any_vector(vec)) + return (method_or_bust + (sc, vec, sc->vector_set_symbol, args, T_VECTOR, 1)); + if (is_immutable_vector(vec)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->vector_set_symbol, vec))); + + if (vector_length(vec) == 0) + return (out_of_range + (sc, sc->vector_set_symbol, int_one, vec, + its_too_large_string)); + + if (vector_rank(vec) > 1) { + s7_int i; + s7_pointer x; + index = 0; + for (x = cdr(args), i = 0; + (is_not_null(cdr(x))) && (i < vector_ndims(vec)); + x = cdr(x), i++) { + s7_int n; + s7_pointer p = car(x); + if (!s7_is_integer(p)) + return (method_or_bust + (sc, p, sc->vector_set_symbol, args, T_INTEGER, + i + 2)); + n = s7_integer_checked(sc, p); + if ((n < 0) || (n >= vector_dimension(vec, i))) + return (out_of_range + (sc, sc->vector_set_symbol, + wrap_integer1(sc, i + 2), p, + (n < + 0) ? its_negative_string : + its_too_large_string)); + + index += n * vector_offset(vec, i); + } + if (is_not_null(cdr(x))) + return (s7_wrong_number_of_args_error + (sc, "too many arguments for vector-set!: ~S", args)); + if (i != vector_ndims(vec)) + return (s7_wrong_number_of_args_error + (sc, "not enough arguments for vector-set!: ~S", + args)); + + /* since vector-ref can return a subvector (if not passed enough args), it might be interesting to + * also set a complete subvector via set!, but would that introduce ambiguity? Only copy the vector + * if at least one index is missing, and the value fits. It also makes error detection harder, + * but so does the current vector-ref handling. Can't decide... + * (define v (make-vector '(2 3) 0)) (vector-set! v 0 #(1 2 3)) -> error, but (vector-ref v 0) -> #(0 0 0) + * Other possible additions: complex-vector and string-vector. + */ + + val = car(x); + } else { + s7_pointer p = cadr(args); + if (!s7_is_integer(p)) + return (method_or_bust + (sc, p, sc->vector_set_symbol, args, T_INTEGER, 2)); + index = s7_integer_checked(sc, p); + if ((index < 0) || (index >= vector_length(vec))) + return (out_of_range + (sc, sc->vector_set_symbol, int_two, p, + (index < + 0) ? its_negative_string : its_too_large_string)); + + if (is_not_null(cdddr(args))) { + set_car(sc->temp_cell_2, vector_getter(vec) (sc, vec, index)); + if (!is_any_vector(car(sc->temp_cell_2))) + return (s7_wrong_number_of_args_error + (sc, "too many arguments for vector-set!: ~S", + args)); + set_cdr(sc->temp_cell_2, cddr(args)); + return (g_vector_set(sc, sc->temp_cell_2)); + } + val = caddr(args); + } + + if (is_typed_vector(vec)) { + if ((sc->safety < NO_SAFETY) || /* or == NO_SAFETY?? */ + (typed_vector_typer_call(sc, vec, set_plist_1(sc, val)) != + sc->F)) { + vector_element(vec, index) = val; + return (val); + } + return (s7_wrong_type_arg_error + (sc, "vector-set!", 3, val, + make_type_name(sc, typed_vector_typer_name(sc, vec), + INDEFINITE_ARTICLE))); + } + + vector_setter(vec) (sc, vec, index, val); + return (val); +} + +static s7_pointer vector_set_p_pip(s7_scheme * sc, s7_pointer v, s7_int i, + s7_pointer p) +{ + if ((!is_any_vector(v)) || + (vector_rank(v) > 1) || (i < 0) || (i >= vector_length(v))) + return (g_vector_set + (sc, set_plist_3(sc, v, make_integer(sc, i), p))); + + if (is_typed_vector(v)) + return (typed_vector_setter(sc, v, i, p)); + + vector_setter(v) (sc, v, i, p); + return (p); +} + +static s7_pointer vector_set_p_pip_unchecked(s7_scheme * sc, s7_pointer v, + s7_int i, s7_pointer p) +{ + if ((i >= 0) && (i < vector_length(v))) + vector_element(v, i) = p; + else + out_of_range(sc, sc->vector_set_symbol, int_two, + wrap_integer1(sc, i), + (i < 0) ? its_negative_string : its_too_large_string); + return (p); +} + +static s7_pointer vector_set_p_piip(s7_scheme * sc, s7_pointer v, + s7_int i1, s7_int i2, s7_pointer p) +{ + if ((!is_any_vector(v)) || + (vector_rank(v) != 2) || + (i1 < 0) || (i2 < 0) || + (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) + return (g_vector_set + (sc, + set_elist_4(sc, v, make_integer(sc, i1), + make_integer(sc, i2), p))); + + if (is_typed_vector(v)) + return (typed_vector_setter + (sc, v, i2 + (i1 * vector_offset(v, 0)), p)); + + vector_setter(v) (sc, v, i2 + (i1 * vector_offset(v, 0)), p); + return (p); +} + +static s7_pointer vector_set_p_piip_direct(s7_scheme * sc, s7_pointer v, + s7_int i1, s7_int i2, + s7_pointer p) +{ + /* normal untyped vector, rank == 2 */ + if ((i1 < 0) || (i2 < 0) || + (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) + return (g_vector_set + (sc, + set_elist_4(sc, v, make_integer(sc, i1), + make_integer(sc, i2), p))); + vector_element(v, i2 + (i1 * vector_offset(v, 0))) = p; + return (p); +} + +static s7_pointer typed_vector_set_p_pip_unchecked(s7_scheme * sc, + s7_pointer v, s7_int i, + s7_pointer p) +{ + if ((i >= 0) && (i < vector_length(v))) + typed_vector_setter(sc, v, i, p); + else + out_of_range(sc, sc->vector_set_symbol, int_two, + wrap_integer1(sc, i), + (i < 0) ? its_negative_string : its_too_large_string); + return (p); +} + +static s7_pointer typed_vector_set_p_piip_direct(s7_scheme * sc, + s7_pointer v, s7_int i1, + s7_int i2, s7_pointer p) +{ + if ((i1 < 0) || (i2 < 0) || + (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) + return (g_vector_set + (sc, + set_elist_4(sc, v, make_integer(sc, i1), + make_integer(sc, i2), p))); + return (typed_vector_setter + (sc, v, i2 + (i1 * vector_offset(v, 0)), p)); +} + +static s7_pointer vector_set_unchecked(s7_scheme * sc, s7_pointer v, + s7_int i, s7_pointer p) +{ + vector_element(v, i) = p; + return (p); +} + +static s7_pointer typed_vector_set_unchecked(s7_scheme * sc, s7_pointer v, + s7_int i, s7_pointer p) +{ + typed_vector_setter(sc, v, i, p); + return (p); +} + +static s7_pointer g_vector_set_3(s7_scheme * sc, s7_pointer args) +{ + /* (vector-set! vector index value) */ + s7_pointer ind, vec = car(args), val; + s7_int index; + + if (!is_any_vector(vec)) + return (g_vector_set(sc, args)); + if (is_immutable_vector(vec)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->vector_set_symbol, vec))); + if (vector_rank(vec) > 1) + return (g_vector_set(sc, args)); + + ind = cadr(args); + if (!s7_is_integer(ind)) + return (g_vector_set(sc, args)); + index = s7_integer_checked(sc, ind); + if ((index < 0) || (index >= vector_length(vec))) + return (out_of_range + (sc, sc->vector_set_symbol, int_two, + wrap_integer1(sc, index), + (index < + 0) ? its_negative_string : its_too_large_string)); + + val = caddr(args); + if (is_typed_vector(vec)) + return (typed_vector_setter(sc, vec, index, val)); + + vector_setter(vec) (sc, vec, index, val); + return (val); +} + +static s7_pointer vector_set_p_ppp(s7_scheme * sc, s7_pointer vec, + s7_pointer ind, s7_pointer val) +{ + s7_int index; + + if ((!is_normal_vector(vec)) || (vector_rank(vec) > 1)) + return (g_vector_set(sc, set_plist_3(sc, vec, ind, val))); + if (is_immutable_vector(vec)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->vector_set_symbol, vec))); + if (!s7_is_integer(ind)) + return (g_vector_set(sc, set_plist_3(sc, vec, ind, val))); + index = s7_integer_checked(sc, ind); + if ((index < 0) || (index >= vector_length(vec))) + return (out_of_range + (sc, sc->vector_set_symbol, int_two, + wrap_integer1(sc, index), + (index < + 0) ? its_negative_string : its_too_large_string)); + + if (is_typed_vector(vec)) + return (typed_vector_setter(sc, vec, index, val)); + vector_element(vec, index) = val; + return (val); +} + +static s7_pointer g_vector_set_4(s7_scheme * sc, s7_pointer args) +{ + s7_pointer v = car(args), ip1 = cadr(args), ip2 = caddr(args), val; + s7_int i1, i2; + if ((!is_any_vector(v)) || + (vector_rank(v) != 2) || + (is_immutable(v)) || + (!s7_is_integer(ip1)) || (!s7_is_integer(ip2))) + return (g_vector_set(sc, args)); + i1 = s7_integer_checked(sc, ip1); + i2 = s7_integer_checked(sc, ip2); + if ((i1 < 0) || (i2 < 0) || + (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) + return (g_vector_set(sc, args)); + val = cadddr(args); + if (is_typed_vector(v)) + return (typed_vector_setter + (sc, v, i2 + (i1 * vector_offset(v, 0)), val)); + vector_setter(v) (sc, v, i2 + (i1 * vector_offset(v, 0)), val); + return (val); +} + +static s7_pointer vector_set_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + if (args == 3) + return (sc->vector_set_3); + return ((args == 4) ? sc->vector_set_4 : f); +} + + +/* -------------------------------- make-vector -------------------------------- */ +static s7_int multivector_length(s7_scheme * sc, s7_pointer x, + s7_pointer caller) +{ + s7_int len, dims; + s7_pointer y; + + dims = s7_list_length(sc, x); + if (dims <= 0) /* 0 if circular, negative if dotted */ + wrong_type_argument_with_type(sc, caller, 1, x, + a_proper_list_string); + if (dims > sc->max_vector_dimensions) + out_of_range(sc, caller, int_one, x, its_too_large_string); + + for (len = 1, y = x; is_pair(y); y = cdr(y)) { + if (!s7_is_integer(car(y))) + wrong_type_argument(sc, caller, position_of(y, x), car(y), + T_INTEGER); +#if HAVE_OVERFLOW_CHECKS + if (multiply_overflow(len, s7_integer_checked(sc, car(y)), &len)) /* or better perhaps len > sc->max_vector_length */ + out_of_range(sc, caller, wrap_integer1(sc, position_of(y, x)), + car(y), its_too_large_string); +#else + len *= s7_integer_checked(sc, car(y)); +#endif + if (len < 0) + wrong_type_argument_with_type(sc, caller, position_of(y, x), + car(y), + a_non_negative_integer_string); + } + return (len); +} + +static inline s7_pointer make_multivector(s7_scheme * sc, s7_pointer vec, + s7_pointer x) +{ + vdims_t *v; + v = list_to_dims(sc, x); + vdims_original(v) = sc->F; + vector_set_dimension_info(vec, v); + add_multivector(sc, vec); + return (vec); +} + +static s7_pointer g_make_vector_1(s7_scheme * sc, s7_pointer args, + s7_pointer caller) +{ + s7_int len; + s7_pointer x = car(args), fill = sc->unspecified, vec, typf = sc->T; + int32_t result_type = T_VECTOR; + + if (s7_is_integer(x)) { + len = s7_integer_checked(sc, x); + if (len < 0) + return (wrong_type_argument_with_type + (sc, caller, 1, x, a_non_negative_integer_string)); + } else { + if (!(is_pair(x))) + return (method_or_bust_with_type + (sc, x, caller, args, + wrap_string(sc, "an integer or a list of integers", + 32), 1)); + + if (!s7_is_integer(car(x))) + return (wrong_type_argument(sc, caller, 1, car(x), T_INTEGER)); + len = + (is_null(cdr(x))) ? s7_integer_checked(sc, + car(x)) : + multivector_length(sc, x, caller); + } + + if (is_pair(cdr(args))) { + fill = cadr(args); + if (caller == sc->make_int_vector_symbol) + result_type = T_INT_VECTOR; + else if (caller == sc->make_float_vector_symbol) + result_type = T_FLOAT_VECTOR; + else if (caller == sc->make_byte_vector_symbol) + result_type = T_BYTE_VECTOR; + if (is_pair(cddr(args))) { + typf = caddr(args); + if ((!is_c_function(typf)) && + (!is_any_closure(typf)) && (typf != sc->T)) + return (wrong_type_argument_with_type + (sc, caller, 3, typf, + wrap_string(sc, + "a built-in procedure, a closure or #t", + 37))); + if (is_any_closure(typf)) { + if (!is_symbol(find_closure(sc, typf, closure_let(typf)))) + return (wrong_type_argument_with_type + (sc, caller, 3, typf, + wrap_string(sc, "a named function", 16))); + /* the name is needed primarily by the error handler: "vector-set! argument 3, ..., is a ... but should be a <...>" */ + } else if (is_c_function(typf)) { + if (typf == global_value(sc->is_float_symbol)) + result_type = T_FLOAT_VECTOR; + else if (typf == global_value(sc->is_integer_symbol)) + result_type = (WITH_GMP) ? T_VECTOR : T_INT_VECTOR; + else if (typf == global_value(sc->is_byte_symbol)) + result_type = T_BYTE_VECTOR; + else { + s7_pointer sig; + if (!c_function_name(typf)) + return (wrong_type_argument_with_type + (sc, caller, 3, typf, + wrap_string(sc, "a named procedure", + 17))); + if (!c_function_marker(typf)) + c_function_set_marker(typf, mark_vector_1); + if (!c_function_symbol(typf)) + c_function_symbol(typf) = + make_symbol(sc, c_function_name(typf)); + sig = c_function_signature(typf); + if ((sig != sc->pl_bt) && + (is_pair(sig)) && + ((car(sig) != sc->is_boolean_symbol) + || (cadr(sig) != sc->T) || (!is_null(cddr(sig))))) + return (wrong_type_argument_with_type + (sc, caller, 3, typf, + wrap_string(sc, "a boolean procedure", + 19))); + } + } + } + } + /* before making the new vector, if fill is specified and the vector is typed, we have to check for a type error. + * otherwise we can end up with a vector whose elements are NULL, causing a segfault in the gc. + */ + if ((result_type == T_VECTOR) && /* don't put this after the make_vector_1! */ + (!s7_is_boolean(typf)) && + (s7_apply_function(sc, typf, set_plist_1(sc, fill)) == sc->F)) + s7_wrong_type_arg_error(sc, "make-vector", 3, fill, + (is_c_function(typf)) ? + c_function_name(typf) : + symbol_name(find_closure + (sc, typf, + closure_let(typf)))); + +#if WITH_GMP + if ((is_big_number(fill)) && (result_type == T_VECTOR)) /* see comment in s7_vector_fill, this prefills with sc->nil */ + vec = make_vector_1(sc, len, FILLED, result_type); + else +#endif + vec = make_vector_1(sc, len, NOT_FILLED, result_type); + + if ((result_type == T_VECTOR) && (!s7_is_boolean(typf))) { + set_typed_vector(vec); + typed_vector_set_typer(vec, typf); + + if ((is_c_function(typf)) && + (c_function_has_simple_elements(typf))) + set_has_simple_elements(vec); + } + + s7_vector_fill(sc, vec, fill); + if ((is_pair(x)) && (is_pair(cdr(x)))) + return (make_multivector(sc, vec, x)); + + add_vector(sc, vec); + return (vec); +} + +static s7_pointer g_make_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_make_vector "(make-vector len (value #) type) returns a vector of len elements initialized to value. \ +To create a multidimensional vector, put the dimension bounds in a list (this is to avoid ambiguities such as \ +(make-vector 1 2) where it's not clear whether the '2' is an initial value or a dimension size). (make-vector '(2 3) 1.0) \ +returns a 2 dimensional vector of 6 total elements, all initialized to 1.0." +#define Q_make_vector s7_make_signature(sc, 4, sc->is_vector_symbol, \ + s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->T, \ + s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_boolean_symbol)) + return (g_make_vector_1(sc, args, sc->make_vector_symbol)); +} + + +/* -------------------------------- make-float-vector -------------------------------- */ +static s7_pointer g_make_float_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_make_float_vector "(make-float-vector len (init 0.0)) returns a float-vector." +#define Q_make_float_vector s7_make_signature(sc, 3, sc->is_float_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_real_symbol) + s7_int len; + s7_pointer x, p = car(args); + block_t *arr; + + if ((is_pair(cdr(args))) || (!s7_is_integer(p))) { /* (make-float-vector (bignum "3")) */ + s7_pointer init; + if (is_pair(cdr(args))) { + init = cadr(args); + if (!is_real(init)) + return (method_or_bust + (sc, init, sc->make_float_vector_symbol, args, + T_REAL, 2)); +#if WITH_GMP + if (s7_is_bignum(init)) + return (g_make_vector_1 + (sc, + set_plist_2(sc, p, wrap_real2(sc, s7_real(init))), + sc->make_float_vector_symbol)); +#endif + if (is_rational(init)) + return (g_make_vector_1 + (sc, + set_plist_2(sc, p, + wrap_real2(sc, + rational_to_double(sc, + init))), + sc->make_float_vector_symbol)); + } else + init = real_zero; + if (s7_is_integer(p)) + len = s7_integer_checked(sc, p); + else { + if (!is_pair(p)) + return (method_or_bust_with_type + (sc, p, sc->make_float_vector_symbol, args, + wrap_string(sc, + "an integer or a list of integers", + 32), 1)); + len = multivector_length(sc, p, sc->make_float_vector_symbol); + } + x = make_vector_1(sc, len, NOT_FILLED, T_FLOAT_VECTOR); + float_vector_fill(sc, x, s7_real(init)); + if (!s7_is_integer(p)) + return (make_multivector(sc, x, p)); + add_vector(sc, x); + return (x); + } + + len = s7_integer_checked(sc, p); + if (len < 0) + return (wrong_type_argument_with_type + (sc, sc->make_float_vector_symbol, 1, p, + a_non_negative_integer_string)); + if (len > sc->max_vector_length) + return (out_of_range + (sc, sc->make_float_vector_symbol, int_one, p, + its_too_large_string)); + + arr = mallocate_vector(sc, len * sizeof(s7_double)); + new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); + vector_length(x) = len; + vector_block(x) = arr; + float_vector_floats(x) = (s7_double *) block_data(arr); + if (len > 0) { + if (STEP_8(len)) + memclr64((void *) float_vector_floats(x), + len * sizeof(s7_double)); + else + memclr((void *) float_vector_floats(x), + len * sizeof(s7_double)); + } + vector_set_dimension_info(x, NULL); + vector_getter(x) = float_vector_getter; + vector_setter(x) = float_vector_setter; + + add_vector(sc, x); + return (x); +} + + +/* -------------------------------- make-int-vector -------------------------------- */ +static s7_pointer g_make_int_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_make_int_vector "(make-int-vector len (init 0)) returns an int-vector." +#define Q_make_int_vector s7_make_signature(sc, 3, sc->is_int_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_integer_symbol) + + s7_int len; + s7_pointer x, p = car(args); + block_t *arr; + + if ((is_pair(cdr(args))) || (!s7_is_integer(p))) { + s7_pointer init; + if (is_pair(cdr(args))) { + init = cadr(args); + if (!s7_is_integer(init)) + return (method_or_bust + (sc, init, sc->make_int_vector_symbol, args, + T_INTEGER, 2)); + } else + init = int_zero; + if (s7_is_integer(p)) + len = s7_integer_checked(sc, p); + else { + if (!is_pair(p)) + return (method_or_bust_with_type + (sc, p, sc->make_int_vector_symbol, args, + wrap_string(sc, + "an integer or a list of integers", + 32), 1)); + len = multivector_length(sc, p, sc->make_int_vector_symbol); + } + x = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR); + int_vector_fill(sc, x, s7_integer_checked(sc, init)); + if (!s7_is_integer(p)) + return (make_multivector(sc, x, p)); + add_vector(sc, x); + return (x); + } + + len = s7_integer_checked(sc, p); + if (len < 0) + return (wrong_type_argument_with_type + (sc, sc->make_int_vector_symbol, 1, p, + a_non_negative_integer_string)); + if (len > sc->max_vector_length) + return (out_of_range + (sc, sc->make_int_vector_symbol, int_one, p, + its_too_large_string)); + + arr = mallocate_vector(sc, len * sizeof(s7_int)); + new_cell(sc, x, T_INT_VECTOR | T_SAFE_PROCEDURE); + vector_length(x) = len; + vector_block(x) = arr; + int_vector_ints(x) = (s7_int *) block_data(arr); + if (len > 0) { + if (STEP_8(len)) + memclr64((void *) int_vector_ints(x), len * sizeof(s7_int)); + else + memclr((void *) int_vector_ints(x), len * sizeof(s7_int)); + } + vector_set_dimension_info(x, NULL); + vector_getter(x) = int_vector_getter; + vector_setter(x) = int_vector_setter; + + add_vector(sc, x); + return (x); +} + +static s7_pointer make_int_vector_p_ii(s7_scheme * sc, s7_int len, + s7_int init) +{ + s7_pointer x; + x = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR); + int_vector_fill(sc, x, init); + add_vector(sc, x); + return (x); +} + + +/* -------------------------------- make-byte-vector -------------------------------- */ +static s7_pointer g_make_byte_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_make_byte_vector "(make-byte-vector len (byte 0)) makes a byte-vector of length len filled with byte." +#define Q_make_byte_vector s7_make_signature(sc, 3, sc->is_byte_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_byte_symbol) + + s7_int len = 0, ib = 0; + s7_pointer p = car(args), init; + + if (!is_pair(p)) { + if (!s7_is_integer(p)) + return (method_or_bust + (sc, p, sc->make_byte_vector_symbol, args, T_INTEGER, + 1)); + len = s7_integer_checked(sc, p); + if ((len < 0) || (len > sc->max_vector_length)) + return (out_of_range + (sc, sc->make_byte_vector_symbol, int_one, p, + (len < + 0) ? its_negative_string : its_too_large_string)); + } + if (is_pair(cdr(args))) { + init = cadr(args); + if (!s7_is_integer(init)) + return (method_or_bust + (sc, init, sc->make_byte_vector_symbol, args, + T_INTEGER, 2)); + ib = s7_integer_checked(sc, init); + if ((ib < 0) || (ib > 255)) + return (simple_wrong_type_argument_with_type + (sc, sc->make_byte_vector_symbol, init, + an_unsigned_byte_string)); + } else + init = int_zero; + + if (!s7_is_integer(p)) + return (g_make_vector_1 + (sc, set_plist_2(sc, p, init), + sc->make_byte_vector_symbol)); + + p = make_simple_byte_vector(sc, len); + if ((len > 0) && (is_pair(cdr(args)))) + local_memset((void *) (byte_vector_bytes(p)), ib, len); + return (p); +} + +static s7_pointer make_byte_vector_p_ii(s7_scheme * sc, s7_int len, + s7_int init) +{ + s7_pointer p; + if ((len < 0) || (len > sc->max_vector_length)) + return (out_of_range + (sc, sc->make_byte_vector_symbol, int_one, + wrap_integer1(sc, len), + (len < 0) ? its_negative_string : its_too_large_string)); + if ((init < 0) || (init > 255)) + return (simple_wrong_type_argument_with_type + (sc, sc->make_byte_vector_symbol, wrap_integer1(sc, init), + an_unsigned_byte_string)); + p = make_simple_byte_vector(sc, len); + if (len > 0) + local_memset((void *) (byte_vector_bytes(p)), init, len); + return (p); +} + + +/* -------------------------------- vector? -------------------------------- */ +static s7_pointer g_is_vector(s7_scheme * sc, s7_pointer args) +{ +#define H_is_vector "(vector? obj) returns #t if obj is a vector" +#define Q_is_vector sc->pl_bt + check_boolean_method(sc, is_any_vector, sc->is_vector_symbol, args); +} + + +/* -------------------------------- vector-rank -------------------------------- */ +s7_int s7_vector_rank(s7_pointer vect) +{ + return ((s7_int) (vector_rank(vect))); +} + +static s7_pointer g_vector_rank(s7_scheme * sc, s7_pointer args) +{ +#define H_vector_rank "(vector-rank vect) returns the number of dimensions in vect" +#define Q_vector_rank s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol) + s7_pointer x = car(args); + if (!is_any_vector(x)) + return (method_or_bust_one_arg + (sc, x, sc->vector_rank_symbol, args, T_VECTOR)); + return (make_integer(sc, vector_rank(x))); +} + + +/* -------------------------------- vector-dimension -------------------------------- */ +static s7_pointer g_vector_dimension(s7_scheme * sc, s7_pointer args) +{ +#define H_vector_dimension "(vector-dimension vect n) returns the size of the n-th dimension (n is 0-based)" +#define Q_vector_dimension s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_vector_symbol, sc->is_integer_symbol) + s7_pointer v = car(args), np; + s7_int n; + if (!is_any_vector(v)) + return (method_or_bust + (sc, v, sc->vector_dimension_symbol, args, T_VECTOR, 1)); + np = cadr(args); + if (!s7_is_integer(np)) + return (method_or_bust + (sc, v, sc->vector_dimension_symbol, args, T_INTEGER, 2)); + n = s7_integer_checked(sc, np); + if ((n < 0) || (n >= vector_rank(v))) + return (s7_out_of_range_error + (sc, "vector-dimension", 2, np, + "must be between 0 and the vector-rank - 1")); + if (vector_has_dimension_info(v)) + return (make_integer(sc, vector_dimension(v, n))); + return (make_integer(sc, vector_length(v))); +} + + +/* -------------------------------- vector-dimensions -------------------------------- */ +static s7_pointer g_vector_dimensions(s7_scheme * sc, s7_pointer args) +{ +#define H_vector_dimensions "(vector-dimensions vect) returns a list of vect's dimensions. In srfi-63 terms:\n\ + (define array-dimensions vector-dimensions)\n\ + (define (array-rank v) (length (vector-dimensions v)))" +#define Q_vector_dimensions s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_vector_symbol) + + s7_pointer x = car(args); + s7_int i; + if (!is_any_vector(x)) + return (method_or_bust_one_arg + (sc, x, sc->vector_dimensions_symbol, args, T_VECTOR)); + + if (vector_rank(x) == 1) + return (list_1(sc, make_integer(sc, vector_length(x)))); + + sc->w = sc->nil; + for (i = vector_ndims(x) - 1; i >= 0; i--) + sc->w = cons(sc, make_integer(sc, vector_dimension(x, i)), sc->w); + x = sc->w; + sc->w = sc->nil; + return (x); +} + + +#define MULTIVECTOR_TOO_MANY_ELEMENTS -1 +#define MULTIVECTOR_NOT_ENOUGH_ELEMENTS -2 + +static int32_t traverse_vector_data(s7_scheme * sc, s7_pointer vec, + s7_int flat_ref, s7_int dimension, + s7_int dimensions, s7_int * sizes, + s7_pointer lst) +{ + /* we're filling vec, we're currently looking for element flat_ref, + * we're at ref in dimension of dimensions, where sizes gives the bounds, and lst is our data + * #3D(((1 2 3) (4 5 6)) ((7 8 9) (10 11 12))) + */ + s7_int i; + s7_pointer x; + + for (i = 0, x = lst; i < sizes[dimension]; i++, x = cdr(x)) { + if (!is_pair(x)) + return (MULTIVECTOR_NOT_ENOUGH_ELEMENTS); + if (dimension == (dimensions - 1)) + vector_setter(vec) (sc, vec, flat_ref++, car(x)); + else { + flat_ref = + traverse_vector_data(sc, vec, flat_ref, dimension + 1, + dimensions, sizes, car(x)); + if (flat_ref < 0) + return (flat_ref); + } + } + return ((is_null(x)) ? flat_ref : MULTIVECTOR_TOO_MANY_ELEMENTS); +} + +static s7_pointer reverse_in_place_unchecked(s7_scheme * sc, + s7_pointer term, + s7_pointer list) +{ + s7_pointer p = list, result = term; + while (true) { + s7_pointer q; + LOOP_4(if (is_null(p)) return (result); q = cdr(p); set_cdr(p, result); result = p; p = q); /* return, not break because LOOP_4 is itself a do loop */ + } + return (result); +} + +static s7_pointer proper_list_reverse_in_place(s7_scheme * sc, + s7_pointer list) +{ + return (reverse_in_place_unchecked(sc, sc->nil, list)); +} + +static s7_pointer multivector_error(s7_scheme * sc, const char *message, + s7_pointer data) +{ + return (s7_error(sc, sc->read_error_symbol, + set_elist_3(sc, + wrap_string(sc, + "reading constant vector, ~A: ~A", + 31), + s7_make_string_wrapper(sc, message), + data))); +} + +static s7_pointer g_multivector(s7_scheme * sc, s7_int dims, + s7_pointer data) +{ + /* get the dimension bounds from data, make the new vector, fill it from data + * dims needs to be s7_int so we can at least give correct error messages. + */ + s7_pointer vec, x; + s7_int i, err, vec_loc; + s7_int *sizes; + + /* (#2d((1 2 3) (4 5 6)) 0 0) -> 1 + * (#2d((1 2 3) (4 5 6)) 1 1) -> 5 + * (#3d(((1 2) (3 4)) ((5 6) (7 8))) 1 1 0) -> 7 + * #3d(((1 2) (3 4)) ((5 6) (7))) -> error, #3d(((1 2) (3 4)) ((5 6) (7 8 9))), #3d(((1 2) (3 4)) (5 (7 8 9))) etc + * but a special case: #nd() is an n-dimensional empty vector + */ + + if (dims <= 0) /* #0d(...) #2147483649D() [if dims is int32_t this is negative] */ + return (s7_out_of_range_error(sc, "#nD(...) dimensions", 1, wrap_integer2(sc, dims), "must be 1 or more")); /* out_of_range uses integer1 */ + if (dims > sc->max_vector_dimensions) + return (s7_out_of_range_error + (sc, "#nD(...) dimensions", 1, wrap_integer2(sc, dims), + "must be < (*s7* 'max-vector-dimensions)")); + + sc->w = sc->nil; + if (is_null(data)) /* dims are already 0 (calloc above) */ + return (g_make_vector + (sc, + set_plist_1(sc, + protected_make_list(sc, dims, int_zero)))); + + sizes = (s7_int *) Calloc(dims, sizeof(s7_int)); + for (x = data, i = 0; i < dims; i++) { + sizes[i] = proper_list_length(x); + sc->w = cons(sc, make_integer(sc, sizes[i]), sc->w); + x = car(x); + if ((i < (dims - 1)) && (!is_pair(x))) { + free(sizes); + return (multivector_error + (sc, + "we need a list that fully specifies the vector's elements", + data)); + } + } + + vec = + g_make_vector(sc, + set_plist_1(sc, sc->w = + proper_list_reverse_in_place(sc, + sc->w))); + vec_loc = gc_protect_1(sc, vec); + sc->w = sc->nil; + + /* now fill the vector checking that all the lists match */ + err = traverse_vector_data(sc, vec, 0, 0, dims, sizes, data); + + free(sizes); + s7_gc_unprotect_at(sc, vec_loc); + if (err < 0) + return (multivector_error + (sc, + (err == + MULTIVECTOR_TOO_MANY_ELEMENTS) ? + "found too many elements" : "not enough elements found", + data)); + return (vec); +} + +static s7_pointer g_int_multivector(s7_scheme * sc, s7_int dims, + s7_pointer data) +{ + /* dims > 1, sc->value is a pair (not null) */ + s7_pointer *src; + s7_int i, len; + sc->value = g_multivector(sc, dims, data); + src = (s7_pointer *) vector_elements(sc->value); + len = vector_length(sc->value); + for (i = 0; i < len; i++) + if (!is_t_integer(src[i])) + return (s7_wrong_type_arg_error + (sc, "#i(...)", i + 1, src[i], "an integer")); + sc->args = + g_make_vector_1(sc, + set_plist_2(sc, + g_vector_dimensions(sc, + set_plist_1(sc, + sc->value)), + int_zero), sc->make_int_vector_symbol); + return (s7_copy_1 + (sc, sc->int_vector_symbol, + set_plist_2(sc, sc->value, sc->args))); +} + +static s7_pointer g_byte_multivector(s7_scheme * sc, s7_int dims, + s7_pointer data) +{ + /* dims > 1, sc->value is a pair (not null) */ + s7_pointer *src; + s7_int i, len; + sc->value = g_multivector(sc, dims, data); + src = (s7_pointer *) vector_elements(sc->value); + len = vector_length(sc->value); + for (i = 0; i < len; i++) + if (!is_byte(src[i])) + return (s7_wrong_type_arg_error + (sc, "#u(...)", i + 1, src[i], "a byte")); + sc->args = + g_make_vector_1(sc, + set_plist_2(sc, + g_vector_dimensions(sc, + set_plist_1(sc, + sc->value)), + int_zero), + sc->make_byte_vector_symbol); + return (s7_copy_1 + (sc, sc->byte_vector_symbol, + set_plist_2(sc, sc->value, sc->args))); +} + +static s7_pointer g_float_multivector(s7_scheme * sc, s7_int dims, + s7_pointer data) +{ + /* dims > 1, sc->value is a pair (not null) */ + s7_pointer *src; + s7_int i, len; + sc->value = g_multivector(sc, dims, data); + src = (s7_pointer *) vector_elements(sc->value); + len = vector_length(sc->value); + for (i = 0; i < len; i++) + if (!is_real(src[i])) + return (s7_wrong_type_arg_error + (sc, "#r(...)", i + 1, src[i], "a real")); + sc->args = + g_make_vector_1(sc, + set_plist_2(sc, + g_vector_dimensions(sc, + set_plist_1(sc, + sc->value)), + real_zero), + sc->make_float_vector_symbol); + return (s7_copy_1 + (sc, sc->float_vector_symbol, + set_plist_2(sc, sc->value, sc->args))); +} + +static Vectorized s7_pointer s7_vector_copy_1(s7_scheme * sc, + s7_pointer old_vect) +{ + s7_int i, len = vector_length(old_vect); + s7_pointer new_vect; + + if (is_normal_vector(old_vect)) { + s7_pointer *src, *dst; + if ((is_typed_vector(old_vect)) && (len > 0)) { /* preserve the type info as well */ + if (vector_rank(old_vect) > 1) + new_vect = + g_make_vector(sc, + set_plist_3(sc, + g_vector_dimensions(sc, + set_plist_1 + (sc, + old_vect)), + vector_element(old_vect, 0), + typed_vector_typer + (old_vect))); + else + new_vect = + g_make_vector(sc, + set_plist_3(sc, make_integer(sc, len), + vector_element(old_vect, 0), + typed_vector_typer + (old_vect))); + } else if (vector_rank(old_vect) > 1) + new_vect = + g_make_vector(sc, + set_plist_1(sc, + g_vector_dimensions(sc, + set_plist_1 + (sc, + old_vect)))); + else + new_vect = make_simple_vector(sc, len); + /* here and in vector-fill! we have a problem with bignums -- should new bignums be allocated? (copy_proper_list also) */ + src = (s7_pointer *) vector_elements(old_vect); + dst = (s7_pointer *) vector_elements(new_vect); + for (i = len; i > 0; i--) + *dst++ = *src++; + return (new_vect); + } + + if (is_float_vector(old_vect)) { + s7_double *src, *dst; + if (vector_rank(old_vect) > 1) + new_vect = + g_make_vector_1(sc, + set_plist_2(sc, + g_vector_dimensions(sc, + set_plist_1 + (sc, + old_vect)), + real_zero), + sc->make_float_vector_symbol); + else + new_vect = make_simple_float_vector(sc, len); + src = (s7_double *) float_vector_floats(old_vect); + dst = (s7_double *) float_vector_floats(new_vect); + for (i = len; i > 0; i--) + *dst++ = *src++; /* same speed as memcpy(dst, src, len * sizeof(s7_double)); */ + return (new_vect); + } + + if (is_int_vector(old_vect)) { + s7_int *src, *dst; + if (vector_rank(old_vect) > 1) + new_vect = + g_make_vector_1(sc, + set_plist_2(sc, + g_vector_dimensions(sc, + set_plist_1 + (sc, + old_vect)), + int_zero), + sc->make_int_vector_symbol); + else + new_vect = make_simple_int_vector(sc, len); + src = (s7_int *) int_vector_ints(old_vect); + dst = (s7_int *) int_vector_ints(new_vect); + for (i = len; i > 0; i--) + *dst++ = *src++; + return (new_vect); + } + + if (is_byte_vector(old_vect)) { + uint8_t *src, *dst; + if (vector_rank(old_vect) > 1) + new_vect = + g_make_vector_1(sc, + set_plist_2(sc, + g_vector_dimensions(sc, + set_plist_1 + (sc, + old_vect)), + int_zero), + sc->make_byte_vector_symbol); + else + new_vect = make_simple_byte_vector(sc, len); + src = (uint8_t *) byte_vector_bytes(old_vect); + dst = (uint8_t *) byte_vector_bytes(new_vect); + for (i = len; i > 0; i--) + *dst++ = *src++; + return (new_vect); + } + return (NULL); +} + +s7_pointer s7_vector_copy(s7_scheme * sc, s7_pointer old_vect) +{ + return (s7_vector_copy_1(sc, old_vect)); +} + +static s7_pointer univect_ref(s7_scheme * sc, s7_pointer args, + s7_pointer caller, int32_t typ) +{ + s7_pointer v = car(args), index; + s7_int ind; + + if (type(v) != typ) + return (method_or_bust(sc, v, caller, args, typ, 1)); + + if (vector_rank(v) == 1) { + index = cadr(args); + if (!s7_is_integer(index)) + return (method_or_bust(sc, index, caller, args, T_INTEGER, 2)); + ind = s7_integer_checked(sc, index); + if ((ind < 0) || (ind >= vector_length(v))) + return (simple_out_of_range + (sc, caller, index, + (ind < + 0) ? its_negative_string : its_too_large_string)); + if (!is_null(cddr(args))) + return (out_of_range + (sc, caller, int_two, cdr(args), + too_many_indices_string)); + } else { + s7_int i; + s7_pointer x; + ind = 0; + for (x = cdr(args), i = 0; + (is_not_null(x)) && (i < vector_ndims(v)); x = cdr(x), i++) { + s7_int n; + index = car(x); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, caller, args, T_INTEGER, i + 2)); + n = s7_integer_checked(sc, index); + if ((n < 0) || (n >= vector_dimension(v, i))) + return (out_of_range + (sc, caller, wrap_integer1(sc, i + 2), index, + (n < + 0) ? its_negative_string : + its_too_large_string)); + ind += n * vector_offset(v, i); + } + if (is_not_null(x)) + return (out_of_range + (sc, caller, int_two, cdr(args), + too_many_indices_string)); + + /* if not enough indices, return a subvector covering whatever is left */ + if (i < vector_ndims(v)) + return (subvector(sc, v, i, ind)); + } + if (typ == T_FLOAT_VECTOR) + return (make_real(sc, float_vector(v, ind))); + return ((typ == T_INT_VECTOR) ? make_integer(sc, + int_vector(v, + ind)) : + small_int(byte_vector(v, ind))); +} + +static s7_pointer univect_set(s7_scheme * sc, s7_pointer args, + s7_pointer caller, int32_t typ) +{ + s7_pointer vec = car(args), val, index; + s7_int ind; + + if (type(vec) != typ) + return (method_or_bust(sc, vec, caller, args, typ, 1)); + if (is_immutable_vector(vec)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, caller, vec))); + + if (vector_rank(vec) > 1) { + s7_int i; + s7_pointer x; + ind = 0; + for (x = cdr(args), i = 0; + (is_not_null(cdr(x))) && (i < vector_ndims(vec)); + x = cdr(x), i++) { + s7_int n; + index = car(x); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, caller, args, T_INTEGER, i + 2)); + n = s7_integer_checked(sc, index); + if ((n < 0) || (n >= vector_dimension(vec, i))) + return (out_of_range + (sc, caller, wrap_integer1(sc, i + 2), index, + (n < + 0) ? its_negative_string : + its_too_large_string)); + ind += n * vector_offset(vec, i); + } + if (is_not_null(cdr(x))) + return (s7_wrong_number_of_args_error + (sc, "too many arguments: ~S", args)); + if (i != vector_ndims(vec)) + return (s7_wrong_number_of_args_error + (sc, "not enough arguments: ~S", args)); + val = car(x); + } else { + s7_pointer p = cdr(args); + index = car(p); + if (!s7_is_integer(index)) + return (method_or_bust(sc, index, caller, args, T_INTEGER, 2)); + ind = s7_integer_checked(sc, index); + if ((ind < 0) || (ind >= vector_length(vec))) + return (out_of_range + (sc, caller, int_two, index, + (ind < + 0) ? its_negative_string : its_too_large_string)); + if (is_not_null(cddr(p))) + return (s7_wrong_number_of_args_error + (sc, "too many arguments: ~S", args)); + val = cadr(p); + } + + if (typ == T_FLOAT_VECTOR) { + if (!is_real(val)) + return (method_or_bust(sc, val, caller, args, T_REAL, 3)); + float_vector(vec, ind) = s7_real(val); + } else if (typ == T_INT_VECTOR) { + if (!s7_is_integer(val)) + return (method_or_bust(sc, val, caller, args, T_INTEGER, 3)); + int_vector(vec, ind) = s7_integer_checked(sc, val); + } else { + if (!is_byte(val)) + return (method_or_bust(sc, val, caller, args, T_INTEGER, 3)); + byte_vector(vec, ind) = (uint8_t) s7_integer_checked(sc, val); + } + return (val); +} + + +/* -------------------------------- float-vector-ref -------------------------------- */ +static s7_pointer g_float_vector_ref(s7_scheme * sc, s7_pointer args) +{ +#define H_float_vector_ref "(float-vector-ref v ...) returns an element of the float-vector v." +#define Q_float_vector_ref s7_make_circular_signature(sc, 2, 3, s7_make_signature(sc, 2, sc->is_float_symbol, sc->is_float_vector_symbol), sc->is_float_vector_symbol, sc->is_integer_symbol) + return (univect_ref + (sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR)); +} + +static inline s7_pointer float_vector_ref_p_pp(s7_scheme * sc, + s7_pointer v, + s7_pointer index) +{ + s7_int ind; + if (!is_float_vector(v)) + return (method_or_bust_pp + (sc, v, sc->float_vector_ref_symbol, v, index, + T_FLOAT_VECTOR, 1)); + if (vector_rank(v) != 1) + return (univect_ref + (sc, set_plist_2(sc, v, index), + sc->float_vector_ref_symbol, T_FLOAT_VECTOR)); + if (!s7_is_integer(index)) + return (method_or_bust_pp + (sc, index, sc->float_vector_ref_symbol, v, index, + T_INTEGER, 2)); + ind = s7_integer_checked(sc, index); + if ((ind < 0) || (ind >= vector_length(v))) + return (simple_out_of_range + (sc, sc->float_vector_ref_symbol, index, + (ind < 0) ? its_negative_string : its_too_large_string)); + return (make_real(sc, float_vector(v, ind))); +} + +static s7_pointer g_fv_ref_2(s7_scheme * sc, s7_pointer args) +{ + return (float_vector_ref_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_fv_ref_3(s7_scheme * sc, s7_pointer args) +{ + s7_pointer fv = car(args), index; + s7_int ind1, ind2; + if (!is_float_vector(fv)) + return (method_or_bust + (sc, fv, sc->float_vector_ref_symbol, args, T_FLOAT_VECTOR, + 1)); + if (vector_rank(fv) != 2) + return (univect_ref + (sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR)); + index = cadr(args); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, sc->float_vector_ref_symbol, args, T_INTEGER, + 2)); + ind1 = s7_integer_checked(sc, index); + if ((ind1 < 0) || (ind1 >= vector_dimension(fv, 0))) + return (simple_out_of_range + (sc, sc->float_vector_ref_symbol, index, + (ind1 < 0) ? its_negative_string : its_too_large_string)); + index = caddr(args); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, sc->float_vector_ref_symbol, args, T_INTEGER, + 3)); + ind2 = s7_integer_checked(sc, index); + if ((ind2 < 0) || (ind2 >= vector_dimension(fv, 1))) + return (simple_out_of_range + (sc, sc->float_vector_ref_symbol, index, + (ind2 < 0) ? its_negative_string : its_too_large_string)); + ind1 = ind1 * vector_offset(fv, 0) + ind2; + return (make_real(sc, float_vector(fv, ind1))); +} + +static inline s7_int ref_check_index(s7_scheme * sc, s7_pointer v, + s7_int i) +{ + /* according to callgrind, it is faster to split out the bounds check */ + if ((i < 0) || (i >= vector_length(v))) + out_of_range(sc, sc->float_vector_ref_symbol, int_two, + wrap_integer1(sc, i), + (i < 0) ? its_negative_string : its_too_large_string); + return (i); +} + +static inline s7_double float_vector_ref_d_7pi(s7_scheme * sc, + s7_pointer v, s7_int i) +{ + return (float_vector(v, ref_check_index(sc, v, i))); +} + +static s7_pointer float_vector_ref_unchecked_p(s7_scheme * sc, + s7_pointer v, s7_int i) +{ + return (make_real(sc, float_vector(v, i))); +} + +static inline s7_double float_vector_ref_d_7pii(s7_scheme * sc, + s7_pointer v, s7_int i1, + s7_int i2) +{ + if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) + out_of_range(sc, sc->float_vector_ref_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + else if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) + out_of_range(sc, sc->float_vector_ref_symbol, int_three, + wrap_integer1(sc, i2), + (i2 < + 0) ? its_negative_string : its_too_large_string); + else + return (float_vector(v, i2 + (i1 * vector_offset(v, 0)))); + return (0.0); /* I know... callgrind oddity */ +} + +static s7_double float_vector_ref_d_7piii(s7_scheme * sc, s7_pointer v, + s7_int i1, s7_int i2, s7_int i3) +{ + if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) + out_of_range(sc, sc->float_vector_ref_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + else if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) + out_of_range(sc, sc->float_vector_ref_symbol, int_three, + wrap_integer1(sc, i2), + (i2 < + 0) ? its_negative_string : its_too_large_string); + else if ((i3 < 0) || (i3 >= vector_dimension(v, 2))) + out_of_range(sc, sc->float_vector_ref_symbol, small_int(4), + wrap_integer1(sc, i3), + (i3 < + 0) ? its_negative_string : its_too_large_string); + else + return (float_vector + (v, + i3 + (i2 * vector_offset(v, 1)) + + (i1 * vector_offset(v, 0)))); + return (0.0); +} + +static s7_pointer float_vector_ref_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + return ((args == 2) ? sc->fv_ref_2 : ((args == 3) ? sc->fv_ref_3 : f)); +} + + +/* -------------------------------- float-vector-set! -------------------------------- */ +static s7_pointer g_float_vector_set(s7_scheme * sc, s7_pointer args) +{ +#define H_float_vector_set "(float-vector-set! v i ... value) sets the i-th element of the float-vector v to value." +#define Q_float_vector_set s7_make_circular_signature(sc, 3, 4, sc->is_real_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_real_at_end_symbol) + return (univect_set + (sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR)); +} + +static s7_pointer g_fv_set_3(s7_scheme * sc, s7_pointer args) +{ + s7_pointer fv = car(args), index, value; + s7_int ind; + if (!is_float_vector(fv)) + return (method_or_bust + (sc, fv, sc->float_vector_set_symbol, args, T_FLOAT_VECTOR, + 1)); + if (vector_rank(fv) != 1) + return (univect_set + (sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR)); + index = cadr(args); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, sc->float_vector_set_symbol, args, T_INTEGER, + 2)); + ind = s7_integer_checked(sc, index); + if ((ind < 0) || (ind >= vector_length(fv))) + return (simple_out_of_range + (sc, sc->float_vector_set_symbol, index, + (ind < 0) ? its_negative_string : its_too_large_string)); + value = caddr(args); + if (!is_real(value)) + return (method_or_bust + (sc, value, sc->float_vector_set_symbol, args, T_REAL, 3)); + if (is_immutable_vector(fv)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->float_vector_set_symbol, fv))); + float_vector(fv, ind) = s7_real(value); + return (value); +} + +static s7_pointer g_fv_set_unchecked(s7_scheme * sc, s7_pointer args) +{ + s7_pointer fv, value = caddr(args); + s7_int ind; + if (!is_real(value)) + return (wrong_type_argument + (sc, sc->float_vector_set_symbol, 3, value, T_REAL)); + fv = car(args); + if (is_immutable_vector(fv)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->float_vector_set_symbol, fv))); + ind = s7_integer_checked(sc, cadr(args)); + float_vector(fv, ind) = s7_real(value); + return (value); +} + +static bool find_matching_ref(s7_scheme * sc, s7_pointer getter, + s7_pointer expr) +{ + /* expr: (*set! v i val), val exists (i.e. args=3, so cddddr is null) */ + s7_pointer v = cadr(expr), ind = caddr(expr); + if ((is_symbol(v)) && (!is_pair(ind))) { + s7_pointer val = cadddr(expr); + if (is_optimized(val)) { /* includes is_pair */ + s7_pointer p; + for (p = val; is_pair(p); p = cdr(p)) + if (is_pair(car(p))) { + s7_pointer ref = car(p); + if (((car(ref) == getter) && + (is_proper_list_2(sc, cdr(ref))) && + (cadr(ref) == v) && + (caddr(ref) == ind)) || + ((car(ref) == v) && + (is_proper_list_1(sc, cdr(ref))) && + (cadr(ref) == ind))) + return (true); + } + } + } + return (false); +} + +static s7_pointer float_vector_set_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + if (args == 3) + return ((find_matching_ref(sc, sc->float_vector_ref_symbol, expr)) + ? sc->fv_set_unchecked : sc->fv_set_3); + return (f); +} + +static s7_double float_vector_set_unchecked(s7_scheme * sc, s7_pointer v, + s7_int i, s7_double x) +{ + float_vector(v, i) = x; + return (x); +} + +static s7_int set_check_index(s7_scheme * sc, s7_pointer v, s7_int i) +{ + if ((i < 0) || (i >= vector_length(v))) + out_of_range(sc, sc->float_vector_set_symbol, int_two, + wrap_integer1(sc, i), + (i < 0) ? its_negative_string : its_too_large_string); + return (i); +} + +static s7_double float_vector_set_d_7pid(s7_scheme * sc, s7_pointer v, + s7_int i, s7_double x) +{ + float_vector(v, (set_check_index(sc, v, i))) = x; + return (x); +} + +static s7_double float_vector_set_d_7piid(s7_scheme * sc, s7_pointer v, + s7_int i1, s7_int i2, + s7_double x) +{ + if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) + out_of_range(sc, sc->float_vector_set_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + else /* this looks dumb, but it makes callgrind much happier */ + if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) + out_of_range(sc, sc->float_vector_set_symbol, int_three, + wrap_integer1(sc, i2), + (i2 < + 0) ? its_negative_string : its_too_large_string); + else + float_vector(v, i2 + (i1 * vector_offset(v, 0))) = x; + return (x); +} + +static s7_double float_vector_set_d_7piiid(s7_scheme * sc, s7_pointer v, + s7_int i1, s7_int i2, s7_int i3, + s7_double x) +{ + if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) + out_of_range(sc, sc->float_vector_set_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + else if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) + out_of_range(sc, sc->float_vector_set_symbol, int_three, + wrap_integer1(sc, i2), + (i2 < + 0) ? its_negative_string : its_too_large_string); + else if ((i3 < 0) || (i3 >= vector_dimension(v, 2))) + out_of_range(sc, sc->float_vector_set_symbol, small_int(4), + wrap_integer1(sc, i3), + (i3 < + 0) ? its_negative_string : its_too_large_string); + else + float_vector(v, + i3 + (i2 * vector_offset(v, 1)) + + (i1 * vector_offset(v, 0))) = x; + return (x); +} + +static s7_pointer float_vector_set_unchecked_p(s7_scheme * sc, + s7_pointer v, s7_int i, + s7_pointer p) +{ + float_vector(v, i) = real_to_double(sc, p, "float-vector-set!"); + return (p); +} + + +/* -------------------------------- int-vector-ref -------------------------------- */ +static s7_pointer g_int_vector_ref(s7_scheme * sc, s7_pointer args) +{ +#define H_int_vector_ref "(int-vector-ref v ...) returns an element of the int-vector v." +#define Q_int_vector_ref s7_make_circular_signature(sc, 2, 3, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_int_vector_symbol), sc->is_int_vector_symbol, sc->is_integer_symbol) + return (univect_ref + (sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR)); +} + +static s7_int int_vector_ref_unchecked(s7_scheme * sc, s7_pointer v, + s7_int i) +{ + return (int_vector(v, i)); +} + +static s7_int int_vector_ref_i_7pi(s7_scheme * sc, s7_pointer v, s7_int i) +{ + if ((i < 0) || (i >= vector_length(v))) + out_of_range(sc, sc->int_vector_ref_symbol, int_two, + wrap_integer1(sc, i), + (i < 0) ? its_negative_string : its_too_large_string); + else + return (int_vector(v, i)); + return (0); +} + +static s7_pointer int_vector_ref_unchecked_p(s7_scheme * sc, s7_pointer v, + s7_int i) +{ + return (make_integer(sc, int_vector(v, i))); +} + +static s7_int int_vector_ref_i_7pii(s7_scheme * sc, s7_pointer v, + s7_int i1, s7_int i2) +{ + if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) + out_of_range(sc, sc->int_vector_ref_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + else if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) + out_of_range(sc, sc->int_vector_ref_symbol, int_three, + wrap_integer1(sc, i2), + (i2 < + 0) ? its_negative_string : its_too_large_string); + else + return (int_vector(v, i2 + (i1 * vector_offset(v, 0)))); + return (0); +} + +static s7_int int_vector_ref_i_7piii(s7_scheme * sc, s7_pointer v, + s7_int i1, s7_int i2, s7_int i3) +{ + if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) + out_of_range(sc, sc->int_vector_ref_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + else if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) + out_of_range(sc, sc->int_vector_ref_symbol, int_three, + wrap_integer1(sc, i2), + (i2 < + 0) ? its_negative_string : its_too_large_string); + else if ((i3 < 0) || (i3 >= vector_dimension(v, 2))) + out_of_range(sc, sc->int_vector_ref_symbol, small_int(4), + wrap_integer1(sc, i3), + (i3 < + 0) ? its_negative_string : its_too_large_string); + else + return (int_vector + (v, + i3 + (i2 * vector_offset(v, 1)) + + (i1 * vector_offset(v, 0)))); + return (0); +} + +static inline s7_pointer int_vector_ref_p_pp(s7_scheme * sc, s7_pointer v, + s7_pointer index) +{ + s7_int ind; + if (!is_int_vector(v)) + return (method_or_bust_pp + (sc, v, sc->int_vector_ref_symbol, v, index, T_INT_VECTOR, + 1)); + if (vector_rank(v) != 1) + return (univect_ref + (sc, set_plist_2(sc, v, index), sc->int_vector_ref_symbol, + T_INT_VECTOR)); + if (!s7_is_integer(index)) + return (method_or_bust_pp + (sc, index, sc->int_vector_ref_symbol, v, index, T_INTEGER, + 2)); + ind = s7_integer_checked(sc, index); + if ((ind < 0) || (ind >= vector_length(v))) + return (simple_out_of_range + (sc, sc->int_vector_ref_symbol, index, + (ind < 0) ? its_negative_string : its_too_large_string)); + return (make_integer(sc, int_vector(v, ind))); +} + +static s7_pointer g_iv_ref_2(s7_scheme * sc, s7_pointer args) +{ + return (int_vector_ref_p_pp(sc, car(args), cadr(args))); +} + +static s7_pointer g_iv_ref_3(s7_scheme * sc, s7_pointer args) +{ + s7_pointer iv = car(args), index; + s7_int ind1, ind2; + if (!is_int_vector(iv)) + return (method_or_bust + (sc, iv, sc->int_vector_ref_symbol, args, T_INT_VECTOR, + 1)); + if (vector_rank(iv) != 2) + return (univect_ref + (sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR)); + index = cadr(args); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, sc->int_vector_ref_symbol, args, T_INTEGER, + 2)); + ind1 = s7_integer_checked(sc, index); + if ((ind1 < 0) || (ind1 >= vector_dimension(iv, 0))) + return (simple_out_of_range + (sc, sc->int_vector_ref_symbol, index, + (ind1 < 0) ? its_negative_string : its_too_large_string)); + index = caddr(args); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, sc->int_vector_ref_symbol, args, T_INTEGER, + 3)); + ind2 = s7_integer_checked(sc, index); + if ((ind2 < 0) || (ind2 >= vector_dimension(iv, 1))) + return (simple_out_of_range + (sc, sc->int_vector_ref_symbol, index, + (ind2 < 0) ? its_negative_string : its_too_large_string)); + ind1 = ind1 * vector_offset(iv, 0) + ind2; + return (make_integer(sc, int_vector(iv, ind1))); +} + +static s7_pointer int_vector_ref_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + return ((args == 2) ? sc->iv_ref_2 : ((args == 3) ? sc->iv_ref_3 : f)); +} + + +/* -------------------------------- int-vector-set! -------------------------------- */ +static s7_pointer g_int_vector_set(s7_scheme * sc, s7_pointer args) +{ +#define H_int_vector_set "(int-vector-set! v i ... value) sets the i-th element of the int-vector v to value." +#define Q_int_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol) + return (univect_set + (sc, args, sc->int_vector_set_symbol, T_INT_VECTOR)); +} + +static s7_int int_vector_set_unchecked(s7_scheme * sc, s7_pointer v, + s7_int i, s7_int x) +{ + int_vector(v, i) = x; + return (x); +} + +static s7_int int_vector_set_i_7pii(s7_scheme * sc, s7_pointer v, s7_int i, + s7_int x) +{ + if ((i < 0) || (i >= vector_length(v))) + out_of_range(sc, sc->int_vector_set_symbol, int_two, + wrap_integer1(sc, i), + (i < 0) ? its_negative_string : its_too_large_string); + else + int_vector(v, i) = x; + return (x); +} + +static s7_int int_vector_set_i_7piii(s7_scheme * sc, s7_pointer v, + s7_int i1, s7_int i2, s7_int i3) +{ + if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) + out_of_range(sc, sc->int_vector_set_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + else if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) + out_of_range(sc, sc->int_vector_set_symbol, int_three, + wrap_integer1(sc, i2), + (i2 < + 0) ? its_negative_string : its_too_large_string); + else + int_vector(v, i2 + (i1 * vector_offset(v, 0))) = i3; + return (i3); +} + +static s7_pointer int_vector_set_p_ppp(s7_scheme * sc, s7_pointer v, + s7_pointer index, s7_pointer val) +{ + if ((is_int_vector(v)) && (vector_rank(v) == 1) + && (!is_immutable_vector(v)) && (is_t_integer(index)) + && (is_t_integer(val))) { + s7_int i = integer(index); + if ((i < 0) || (i >= vector_length(v))) + out_of_range(sc, sc->int_vector_set_symbol, int_two, index, + (i < + 0) ? its_negative_string : its_too_large_string); + else + int_vector(v, i) = integer(val); + } else { + if (!is_int_vector(v)) + return (method_or_bust_ppp + (sc, v, sc->int_vector_set_symbol, v, index, val, + T_INT_VECTOR, 1)); + if (vector_rank(v) != 1) + return (univect_set + (sc, set_plist_3(sc, v, index, val), + sc->int_vector_set_symbol, T_INT_VECTOR)); + if (is_immutable_vector(v)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->int_vector_set_symbol, v))); + if (!s7_is_integer(index)) + return (method_or_bust_ppp + (sc, index, sc->int_vector_set_symbol, v, index, val, + T_INTEGER, 2)); + if (!s7_is_integer(val)) + return (method_or_bust_ppp + (sc, val, sc->int_vector_set_symbol, v, index, val, + T_INTEGER, 3)); +#if WITH_GMP + { + s7_int i = s7_integer_checked(sc, index); + if ((i < 0) || (i >= vector_length(v))) + out_of_range(sc, sc->int_vector_set_symbol, int_two, index, + (i < + 0) ? its_negative_string : + its_too_large_string); + else + int_vector(v, i) = s7_integer_checked(sc, val); + } +#else + if (S7_DEBUGGING) + fprintf(stderr, "fell through %s[%d]\n", __func__, __LINE__); +#endif + } + return (val); +} + +static s7_pointer int_vector_set_unchecked_p(s7_scheme * sc, s7_pointer v, + s7_int i, s7_pointer p) +{ + if (!s7_is_integer(p)) + s7_wrong_type_arg_error(sc, "int-vector-set!", 3, p, "an integer"); + int_vector(v, i) = s7_integer_checked(sc, p); + return (p); +} + +static s7_pointer g_iv_set_3(s7_scheme * sc, s7_pointer args) +{ + s7_pointer v = car(args), index, value; + s7_int ind; + if (!is_int_vector(v)) + return (method_or_bust + (sc, v, sc->int_vector_set_symbol, args, T_INT_VECTOR, 1)); + if (vector_rank(v) != 1) + return (univect_set + (sc, args, sc->int_vector_set_symbol, T_INT_VECTOR)); + index = cadr(args); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, sc->int_vector_set_symbol, args, T_INTEGER, + 2)); + ind = s7_integer_checked(sc, index); + if ((ind < 0) || (ind >= vector_length(v))) + return (simple_out_of_range + (sc, sc->int_vector_set_symbol, index, + (ind < 0) ? its_negative_string : its_too_large_string)); + value = caddr(args); + if (!s7_is_integer(value)) + return (method_or_bust + (sc, value, sc->int_vector_set_symbol, args, T_INTEGER, + 3)); + if (is_immutable_vector(v)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->int_vector_set_symbol, v))); + int_vector(v, ind) = s7_integer_checked(sc, value); + return (value); +} + +static s7_pointer int_vector_set_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + return ((args == 3) ? sc->iv_set_3 : f); +} + + +/* -------------------------------- byte-vector-ref -------------------------------- */ +static s7_pointer g_byte_vector_ref(s7_scheme * sc, s7_pointer args) +{ +#define H_byte_vector_ref "(byte-vector-ref vect index) returns the byte at the index-th element of the byte-vector vect" +#define Q_byte_vector_ref s7_make_circular_signature(sc, 2, 3, s7_make_signature(sc, 2, sc->is_byte_symbol, sc->is_byte_vector_symbol), sc->is_byte_vector_symbol, sc->is_integer_symbol) + return (univect_ref + (sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR)); +} + +static s7_int byte_vector_ref_i_7pi(s7_scheme * sc, s7_pointer p1, + s7_int i1) +{ + if ((i1 < 0) || (i1 >= byte_vector_length(p1))) + out_of_range(sc, sc->byte_vector_ref_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + else + return ((s7_int) ((byte_vector(p1, i1)))); + return (0); +} + +static s7_int byte_vector_ref_i_7pii(s7_scheme * sc, s7_pointer v, + s7_int i1, s7_int i2) +{ + if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) + out_of_range(sc, sc->byte_vector_ref_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + else if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) + out_of_range(sc, sc->byte_vector_ref_symbol, int_three, + wrap_integer1(sc, i2), + (i2 < + 0) ? its_negative_string : its_too_large_string); + else + return ((s7_int) byte_vector(v, i2 + (i1 * vector_offset(v, 0)))); + return (0); +} + +static s7_pointer byte_vector_ref_unchecked_p(s7_scheme * sc, + s7_pointer p1, s7_int i1) +{ + return (small_int((byte_vector(p1, i1)))); +} + +static s7_int byte_vector_ref_unchecked(s7_scheme * sc, s7_pointer p1, + s7_int i1) +{ + return (byte_vector(p1, i1)); +} + +static s7_pointer g_bv_ref_2(s7_scheme * sc, s7_pointer args) +{ + s7_pointer v = car(args), index; + s7_int ind; + if (!is_byte_vector(v)) + return (method_or_bust + (sc, v, sc->byte_vector_ref_symbol, args, T_BYTE_VECTOR, + 1)); + if (vector_rank(v) != 1) + return (univect_ref + (sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR)); + index = cadr(args); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, sc->byte_vector_ref_symbol, args, T_INTEGER, + 2)); + ind = s7_integer_checked(sc, index); + if ((ind < 0) || (ind >= vector_length(v))) + return (simple_out_of_range + (sc, sc->byte_vector_ref_symbol, index, + (ind < 0) ? its_negative_string : its_too_large_string)); + return (make_integer(sc, byte_vector(v, ind))); +} + +static s7_pointer g_bv_ref_3(s7_scheme * sc, s7_pointer args) +{ + s7_pointer iv = car(args), index; + s7_int ind1, ind2; + if (!is_byte_vector(iv)) + return (method_or_bust + (sc, iv, sc->byte_vector_ref_symbol, args, T_BYTE_VECTOR, + 1)); + if (vector_rank(iv) != 2) + return (univect_ref + (sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR)); + index = cadr(args); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, sc->byte_vector_ref_symbol, args, T_INTEGER, + 2)); + ind1 = s7_integer_checked(sc, index); + if ((ind1 < 0) || (ind1 >= vector_dimension(iv, 0))) + return (simple_out_of_range + (sc, sc->byte_vector_ref_symbol, index, + (ind1 < 0) ? its_negative_string : its_too_large_string)); + index = caddr(args); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, sc->byte_vector_ref_symbol, args, T_INTEGER, + 3)); + ind2 = s7_integer_checked(sc, index); + if ((ind2 < 0) || (ind2 >= vector_dimension(iv, 1))) + return (simple_out_of_range + (sc, sc->byte_vector_ref_symbol, index, + (ind2 < 0) ? its_negative_string : its_too_large_string)); + ind1 = ind1 * vector_offset(iv, 0) + ind2; + return (make_integer(sc, byte_vector(iv, ind1))); +} + +static s7_pointer byte_vector_ref_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + return ((args == 2) ? sc->bv_ref_2 : ((args == 3) ? sc->bv_ref_3 : f)); +} + + +/* -------------------------------- byte-vector-set -------------------------------- */ +static s7_pointer g_byte_vector_set(s7_scheme * sc, s7_pointer args) +{ +#define H_byte_vector_set "(byte-vector-set! vect index byte) sets the index-th element of the byte-vector vect to the integer byte" +#define Q_byte_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_byte_symbol, sc->is_byte_vector_symbol, sc->is_integer_symbol) + return (univect_set + (sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR)); +} + +static s7_int byte_vector_set_i_7pii(s7_scheme * sc, s7_pointer p1, + s7_int i1, s7_int i2) +{ + if (!is_byte_vector(p1)) + simple_wrong_type_argument_with_type(sc, + sc->byte_vector_set_symbol, + p1, a_byte_vector_string); + else if ((i2 < 0) || (i2 > 255)) + simple_wrong_type_argument_with_type(sc, + sc->byte_vector_set_symbol, + wrap_integer1(sc, i2), + an_unsigned_byte_string); + else if ((i1 < 0) || (i1 >= byte_vector_length(p1))) + simple_out_of_range(sc, sc->byte_vector_set_symbol, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : + its_too_large_string); + byte_vector(p1, i1) = (uint8_t) i2; + return (i2); +} + +static s7_int byte_vector_set_unchecked(s7_scheme * sc, s7_pointer p1, + s7_int i1, s7_int i2) +{ + byte_vector(p1, i1) = (uint8_t) i2; + return (i2); +} + +static s7_pointer byte_vector_set_unchecked_p(s7_scheme * sc, + s7_pointer p1, s7_int i1, + s7_pointer p2) +{ + byte_vector(p1, i1) = (uint8_t) s7_integer_checked(sc, p2); + return (p2); +} + +static s7_int byte_vector_set_i_7piii(s7_scheme * sc, s7_pointer v, + s7_int i1, s7_int i2, s7_int i3) +{ + if ((i3 < 0) || (i3 > 255)) + simple_wrong_type_argument_with_type(sc, + sc->byte_vector_set_symbol, + wrap_integer1(sc, i3), + an_unsigned_byte_string); + else if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) + out_of_range(sc, sc->int_vector_set_symbol, int_two, + wrap_integer1(sc, i1), + (i1 < + 0) ? its_negative_string : its_too_large_string); + else if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) + out_of_range(sc, sc->int_vector_set_symbol, int_three, + wrap_integer1(sc, i2), + (i2 < + 0) ? its_negative_string : its_too_large_string); + byte_vector(v, i2 + (i1 * vector_offset(v, 0))) = i3; + return (i3); +} + +static s7_pointer g_bv_set_3(s7_scheme * sc, s7_pointer args) +{ + s7_pointer v = car(args), index, value; + s7_int ind, uval; + if (!is_byte_vector(v)) + return (method_or_bust + (sc, v, sc->byte_vector_set_symbol, args, T_BYTE_VECTOR, + 1)); + if (vector_rank(v) != 1) + return (univect_set + (sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR)); + index = cadr(args); + if (!s7_is_integer(index)) + return (method_or_bust + (sc, index, sc->byte_vector_set_symbol, args, T_INTEGER, + 2)); + ind = s7_integer_checked(sc, index); + if ((ind < 0) || (ind >= vector_length(v))) + return (simple_out_of_range + (sc, sc->byte_vector_set_symbol, index, + (ind < 0) ? its_negative_string : its_too_large_string)); + value = caddr(args); + if (!s7_is_integer(value)) + return (method_or_bust + (sc, value, sc->byte_vector_set_symbol, args, T_INTEGER, + 3)); + uval = s7_integer_checked(sc, value); + if ((uval < 0) || (uval > 255)) + simple_wrong_type_argument_with_type(sc, + sc->byte_vector_set_symbol, + value, + an_unsigned_byte_string); + if (is_immutable_vector(v)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->byte_vector_set_symbol, v))); + byte_vector(v, ind) = (uint8_t) uval; + return (value); +} + +static s7_pointer byte_vector_set_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + return ((args == 3) ? sc->bv_set_3 : f); +} + + +/* -------------------------------------------------------------------------------- */ +static bool c_function_is_ok(s7_scheme * sc, s7_pointer x) +{ + s7_pointer p; + p = lookup_unexamined(sc, car(x)); /* lookup_global is usually slower (faster in Snd) */ + if ((p == opt1_cfunc(x)) || ((p) && (is_any_c_function(p)) + && (c_function_class(p) == + c_function_class(opt1_cfunc(x))))) + return (true); + sc->last_function = p; + return (false); +} + +static bool cl_function_is_ok(s7_scheme * sc, s7_pointer x) +{ + sc->last_function = lookup_unexamined(sc, car(x)); + return (sc->last_function == opt1_cfunc(x)); +} + +static bool arglist_has_rest(s7_scheme * sc, s7_pointer args) +{ + s7_pointer p; + for (p = args; is_pair(p); p = cdr(p)) + if (car(p) == sc->key_rest_symbol) + return (true); + return (!is_null(p)); +} + + +/* -------------------------------- sort! -------------------------------- */ +static bool bool_optimize(s7_scheme * sc, s7_pointer expr); +static bool bool_optimize_nw(s7_scheme * sc, s7_pointer expr); +static bool cell_optimize(s7_scheme * sc, s7_pointer expr); +static void pc_fallback(s7_scheme * sc, int32_t new_pc) +{ + sc->pc = new_pc; +} + +static int32_t dbl_less(const void *f1, const void *f2) +{ + if ((*((s7_double *) f1)) < (*((s7_double *) f2))) + return (-1); + return (((*((s7_double *) f1)) > (*((s7_double *) f2))) ? 1 : 0); +} + +static int32_t int_less(const void *f1, const void *f2) +{ + if ((*((s7_int *) f1)) < (*((s7_int *) f2))) + return (-1); + return (((*((s7_int *) f1)) > (*((s7_int *) f2))) ? 1 : 0); +} + +static int32_t dbl_greater(const void *f1, const void *f2) +{ + return (-dbl_less(f1, f2)); +} + +static int32_t int_greater(const void *f1, const void *f2) +{ + return (-int_less(f1, f2)); +} + +static int32_t byte_less(const void *f1, const void *f2) +{ + if ((*((uint8_t *) f1)) < (*((uint8_t *) f2))) + return (-1); + return (((*((uint8_t *) f1)) > (*((uint8_t *) f2))) ? 1 : 0); +} + +static int32_t byte_greater(const void *f1, const void *f2) +{ + return (-byte_less(f1, f2)); +} + +static int32_t dbl_less_2(const void *f1, const void *f2) +{ + s7_double p1 = real(*((s7_pointer *) f1)), p2 = + real(*((s7_pointer *) f2)); + if (p1 < p2) + return (-1); + return ((p1 > p2) ? 1 : 0); +} + +static int32_t int_less_2(const void *f1, const void *f2) +{ + s7_int p1 = integer(*((s7_pointer *) f1)), p2 = + integer(*((s7_pointer *) f2)); + if (p1 < p2) + return (-1); + return ((p1 > p2) ? 1 : 0); +} + +static int32_t dbl_greater_2(const void *f1, const void *f2) +{ + return (-dbl_less_2(f1, f2)); +} + +static int32_t int_greater_2(const void *f1, const void *f2) +{ + return (-int_less_2(f1, f2)); +} + +static int32_t str_less_2(const void *f1, const void *f2) +{ + s7_pointer p1 = (*((s7_pointer *) f1)), p2 = (*((s7_pointer *) f2)); + return (scheme_strcmp(p1, p2)); +} + +static int32_t str_greater_2(const void *f1, const void *f2) +{ + return (-str_less_2(f1, f2)); +} + +static int32_t chr_less_2(const void *f1, const void *f2) +{ + uint8_t p1 = character(*((s7_pointer *) f1)), p2 = + character(*((s7_pointer *) f2)); + if (p1 < p2) + return (-1); + return ((p1 > p2) ? 1 : 0); +} + +static int32_t chr_greater_2(const void *f1, const void *f2) +{ + return (-chr_less_2(f1, f2)); +} + +#if MS_WINDOWS || defined(__APPLE__) || defined(__FreeBSD__) +struct sort_r_data { + void *arg; + int (*compar)(const void *a1, const void *a2, void *aarg); +}; + +static int sort_r_arg_swap(void *s, const void *aa, const void *bb) +{ + struct sort_r_data *ss = (struct sort_r_data *) s; + return (ss->compar) (aa, bb, ss->arg); +} +#endif + +/* qsort_r in Linux requires _GNU_SOURCE and is different from q_sort_r in FreeBSD, neither matches qsort_s in Windows + * this code tested only in Linux and the mac -- my virtualbox freebsd died, netbsd and openbsd run using fallback code. + */ +static void local_qsort_r(void *base, size_t nmemb, size_t size, + int (*compar)(const void *, const void *, + void *), void *arg) +{ +#if (defined(__linux__)) && (defined(__GLIBC__)) /* __GLIBC__ because musl does not have qsort_r and has no way to detect it */ + qsort_r(base, nmemb, size, compar, arg); +#else +#if defined(__APPLE__) || defined(__FreeBSD__) /* not in OpenBSD or NetBSD as far as I can tell */ + struct sort_r_data tmp = { arg, compar }; + qsort_r(base, nmemb, size, &tmp, &sort_r_arg_swap); +#else +#if MS_WINDOWS + struct sort_r_data tmp = { arg, compar }; + qsort_s(base, nmemb, size, sort_r_arg_swap, &tmp); +#else + /* from the Net somewhere, by "Pete", about 25 times slower than libc's qsort_r in this context */ + if (nmemb > 1) { + uint8_t *array, *i, *j, *k, *after; + size_t h, t; + array = (uint8_t *) base; + after = (uint8_t *) (nmemb * size + array); + nmemb /= 4; + h = nmemb + 1; + for (t = 1; nmemb != 0; nmemb /= 4) + t *= 2; + do { + size_t bytes = h * size; + i = bytes + array; + do { + j = i - bytes; + if (compar(j, i, arg) > 0) { + k = i; + do { + uint8_t *end, *p1 = j, *p2 = k; + end = p2 + size; + do { + uint8_t swap = *p1; + *p1++ = *p2; + *p2++ = swap; + } while (p2 != end); + if (bytes + array > j) + break; + k = j; + j -= bytes; + } while (compar(j, k, arg) > 0); + } + i += size; + } while (i != after); + t /= 2; + h = t * t - t * 3 / 2 + 1; + } while (t != 0); + } +#endif +#endif +#endif +} + +static int32_t vector_sort(const void *v1, const void *v2, void *arg) +{ + s7_scheme *sc = (s7_scheme *) arg; + return (((*(sc->sort_f)) + (sc, (*(s7_pointer *) v1), (*(s7_pointer *) v2))) ? -1 : 1); +} + +static int32_t vector_sort_lt(const void *v1, const void *v2, void *arg) +{ /* for qsort_r */ + s7_pointer s1 = (*(s7_pointer *) v1), s2 = (*(s7_pointer *) v2); + if ((is_t_integer(s1)) && (is_t_integer(s2))) + return ((integer(s1) < integer(s2)) ? -1 : 1); + return ((lt_b_7pp((s7_scheme *) arg, s1, s2)) ? -1 : 1); +} + +static int32_t vector_car_sort(const void *v1, const void *v2, void *arg) +{ + s7_scheme *sc = (s7_scheme *) arg; + s7_pointer a = (*(s7_pointer *) v1), b = (*(s7_pointer *) v2); + a = (is_pair(a)) ? car(a) : g_car(sc, set_plist_1(sc, a)); + b = (is_pair(b)) ? car(b) : g_car(sc, set_plist_1(sc, b)); + return (((*(sc->sort_f)) (sc, a, b)) ? -1 : 1); +} + +static int32_t vector_cdr_sort(const void *v1, const void *v2, void *arg) +{ + s7_scheme *sc = (s7_scheme *) arg; + s7_pointer a = (*(s7_pointer *) v1), b = (*(s7_pointer *) v2); + a = (is_pair(a)) ? cdr(a) : g_cdr(sc, set_plist_1(sc, a)); + b = (is_pair(b)) ? cdr(b) : g_cdr(sc, set_plist_1(sc, b)); + return (((*(sc->sort_f)) (sc, a, b)) ? -1 : 1); +} + +static int32_t opt_bool_sort(const void *v1, const void *v2, void *arg) +{ + s7_scheme *sc = (s7_scheme *) arg; + slot_set_value(sc->sort_v1, (*(s7_pointer *) v1)); /* first slot in curlet */ + slot_set_value(sc->sort_v2, (*(s7_pointer *) v2)); /* second slot in curlet */ + return ((sc->sort_fb(sc->sort_o)) ? -1 : 1); +} + +static int32_t opt_bool_sort_0(const void *v1, const void *v2, void *arg) +{ + s7_scheme *sc = (s7_scheme *) arg; + slot_set_value(sc->sort_v1, (*(s7_pointer *) v1)); /* first slot in curlet */ + slot_set_value(sc->sort_v2, (*(s7_pointer *) v2)); /* second slot in curlet */ + return ((sc->sort_fb(sc->sort_o)) ? -1 : 1); +} + +static int32_t opt_bool_sort_p(const void *v1, const void *v2, void *arg) +{ + s7_scheme *sc = (s7_scheme *) arg; + slot_set_value(sc->sort_v1, (*(s7_pointer *) v1)); + slot_set_value(sc->sort_v2, (*(s7_pointer *) v2)); + return ((sc->opts[0]->v[O_WRAP].fp(sc->opts[0]) == sc->F) ? 1 : -1); +} + +#define SORT_O1 1 +static inline int32_t begin_bool_sort_bp(s7_scheme * sc, const void *v1, + const void *v2, bool int_expr) +{ + s7_int i; + opt_info *top = sc->opts[0], *o; + slot_set_value(sc->sort_v1, (*(s7_pointer *) v1)); + slot_set_value(sc->sort_v2, (*(s7_pointer *) v2)); + for (i = 0; i < sc->sort_body_len - 1; i++) { + o = top->v[SORT_O1 + i].o1; + o->v[0].fp(o); + } + o = top->v[SORT_O1 + i].o1; + if (int_expr) + return ((o->v[0].fb(o)) ? -1 : 1); + return ((o->v[0].fp(o) != sc->F) ? -1 : 1); +} + +static int32_t opt_begin_bool_sort_b(const void *v1, const void *v2, + void *arg) +{ + return (begin_bool_sort_bp((s7_scheme *) arg, v1, v2, true)); +} + +static int32_t opt_begin_bool_sort_p(const void *v1, const void *v2, + void *arg) +{ + return (begin_bool_sort_bp((s7_scheme *) arg, v1, v2, false)); +} + +static int32_t opt_begin_bool_sort_b2(const void *v1, const void *v2, + void *arg) +{ + s7_scheme *sc = (s7_scheme *) arg; + opt_info *top = sc->opts[0], *o; + slot_set_value(sc->sort_v1, (*(s7_pointer *) v1)); + slot_set_value(sc->sort_v2, (*(s7_pointer *) v2)); + o = top->v[SORT_O1].o1; + o->v[0].fp(o); + o = top->v[SORT_O1 + 1].o1; + return ((o->v[0].fb(o)) ? -1 : 1); +} + +static int32_t closure_sort(const void *v1, const void *v2, void *arg) +{ + s7_scheme *sc = (s7_scheme *) arg; + slot_set_value(sc->sort_v1, (*(s7_pointer *) v1)); + slot_set_value(sc->sort_v2, (*(s7_pointer *) v2)); + push_stack(sc, OP_EVAL_DONE, sc->sort_body, sc->code); + sc->code = sc->sort_body; /* this should be ok because we checked in advance that it is a safe closure (no sort! for example) */ + eval(sc, sc->sort_op); + return ((sc->value != sc->F) ? -1 : 1); +} + +static int32_t closure_sort_begin(const void *v1, const void *v2, + void *arg) +{ + s7_scheme *sc = (s7_scheme *) arg; + slot_set_value(sc->sort_v1, (*(s7_pointer *) v1)); + slot_set_value(sc->sort_v2, (*(s7_pointer *) v2)); + push_stack(sc, OP_EVAL_DONE, sc->sort_body, sc->code); + push_stack_no_args(sc, OP_BEGIN_NO_HOOK, T_Pair(sc->sort_begin)); + sc->code = sc->sort_body; + eval(sc, sc->sort_op); + return ((sc->value != sc->F) ? -1 : 1); +} + +static s7_b_7pp_t s7_b_7pp_function(s7_pointer f); +static opt_info *alloc_opo(s7_scheme * sc); + +static s7_pointer g_sort(s7_scheme * sc, s7_pointer args) +{ +#define H_sort "(sort! sequence less?) sorts a sequence using the function 'less?' to compare elements." +#define Q_sort s7_make_signature(sc, 3, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_procedure_symbol) + + s7_pointer data = car(args), lessp, lx; + s7_int len = 0, n, k; + int32_t(*sort_func) (const void *v1, const void *v2, void *arg); + s7_pointer *elements; + + /* both the intermediate vector (if any) and the current args pointer need GC protection, + * but it is a real bother to unprotect args at every return statement, so I'll use temp3 + */ + sc->temp3 = args; /* this is needed but maybe insufficient... if sort is semisafe, we should protect the args, not the list: use OP_GC_PROTECT? */ + if (is_null(data)) { + /* (apply sort! () #f) should be an error I think */ + lessp = cadr(args); + if (type(lessp) < T_CONTINUATION) + return (method_or_bust_with_type + (sc, lessp, sc->sort_symbol, args, a_procedure_string, + 2)); + if (!s7_is_aritable(sc, lessp, 2)) + return (wrong_type_argument_with_type + (sc, sc->sort_symbol, 2, lessp, an_eq_func_string)); + return (sc->nil); + } + + if (is_immutable(data)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, sc->sort_symbol, + data))); + if (!is_sequence(data)) + return (wrong_type_argument_with_type + (sc, sc->sort_symbol, 1, data, a_sequence_string)); + + lessp = cadr(args); + if (type(lessp) <= T_GOTO) + return (wrong_type_argument_with_type + (sc, sc->sort_symbol, 2, lessp, + a_normal_procedure_string)); + if (!s7_is_aritable(sc, lessp, 2)) + return (wrong_type_argument_with_type + (sc, sc->sort_symbol, 2, lessp, an_eq_func_string)); + + sort_func = NULL; + sc->sort_f = NULL; + + if ((is_c_function(lessp)) && (is_safe_procedure(lessp))) { /* (sort! a <) */ + s7_pointer sig = c_function_signature(lessp); + if ((sig) && (is_pair(sig)) && (car(sig) != sc->is_boolean_symbol)) + return (wrong_type_argument_with_type + (sc, sc->sort_symbol, 2, lessp, + wrap_string(sc, + "sort! function should return a boolean", + 38))); + sc->sort_f = s7_b_7pp_function(lessp); + if (sc->sort_f) + sort_func = + (sc->sort_f == lt_b_7pp) ? vector_sort_lt : vector_sort; + } else { + if (is_closure(lessp)) { + s7_pointer expr = car(closure_body(lessp)), largs = + closure_args(lessp); + + if ((is_pair(largs)) && /* closure args not a symbol, etc */ + (!arglist_has_rest(sc, largs))) { + if ((is_null(cdr(closure_body(lessp)))) && + (is_optimized(expr)) && + (is_safe_c_op(optimize_op(expr))) && + /* since (sort seq (lambda (a b) ...)) can't return a "safe closure" (the hop bit is off in + * optimize in this case, for some arcane reason), the optimized expression won't be hop_safe, + * but that is irrelevant at this point -- if c_function_is_ok, we're good to go. + */ + ((op_has_hop(expr)) || ((is_global(car(expr))) && /* (sort! x (lambda (car y) (car x)...))! */ + (c_function_is_ok(sc, expr))))) { + int32_t orig_data = optimize_op(expr); + s7_pointer lp; + set_optimize_op(expr, optimize_op(expr) | 1); + if ((optimize_op(expr) == HOP_SAFE_C_SS) && + (car(largs) == cadr(expr)) && + (cadr(largs) == caddr(expr))) { + lp = lookup(sc, car(expr)); + sc->sort_f = s7_b_7pp_function(lp); + if (sc->sort_f) { + sort_func = + (sc->sort_f == + lt_b_7pp) ? vector_sort_lt : vector_sort; + lessp = lp; + } + } else + if ((optimize_op(expr) == HOP_SAFE_C_opSq_opSq) && + ((caadr(expr) == sc->car_symbol) + || (caadr(expr) == sc->cdr_symbol)) + && (caadr(expr) == caaddr(expr)) + && (car(largs) == cadadr(expr)) + && (cadr(largs) == cadaddr(expr))) { + lp = lookup(sc, car(expr)); + sc->sort_f = s7_b_7pp_function(lp); + if (sc->sort_f) { + sort_func = + ((caadr(expr) == + sc->car_symbol) ? vector_car_sort : + vector_cdr_sort); + lessp = lp; + } + } + set_optimize_op(expr, orig_data); + } + + if (!sort_func) { + s7_pointer init_val, old_e = sc->curlet; + if (is_float_vector(data)) + init_val = real_zero; + else + init_val = ((is_int_vector(data)) + || (is_byte_vector(data))) ? int_zero : + sc->F; + sc->curlet = + make_let_with_two_slots(sc, closure_let(lessp), + car(largs), init_val, + cadr(largs), init_val); + sc->sort_body = expr; + sc->sort_v1 = let_slots(sc->curlet); + sc->sort_v2 = next_slot(let_slots(sc->curlet)); + if (is_null(cdr(closure_body(lessp)))) { + if (!no_bool_opt(closure_body(lessp))) { + s7_pfunc sf1; + sf1 = + s7_bool_optimize(sc, closure_body(lessp)); + if (sf1) { + if (sc->opts[0]->v[0].fb == p_to_b) + sort_func = opt_bool_sort_p; + else { + sc->sort_o = sc->opts[0]; + sc->sort_fb = sc->sort_o->v[0].fb; + sort_func = + (sc->pc == + 1) ? opt_bool_sort_0 : + opt_bool_sort; + } + } else + set_no_bool_opt(closure_body(lessp)); + } + } else { + sc->sort_body_len = + s7_list_length(sc, closure_body(lessp)); + if (sc->sort_body_len < (NUM_VUNIONS - SORT_O1)) { + s7_pointer p; + int32_t ctr; + opt_info *top; + sc->pc = 0; + top = alloc_opo(sc); + for (ctr = SORT_O1, p = closure_body(lessp); + is_pair(cdr(p)); ctr++, p = cdr(p)) { + top->v[ctr].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } + if (is_null(cdr(p))) { + int32_t start = sc->pc; + top->v[ctr].o1 = sc->opts[start]; + if (bool_optimize_nw(sc, p)) + sort_func = + (sc->sort_body_len == + 2) ? opt_begin_bool_sort_b2 : + opt_begin_bool_sort_b; + else { + pc_fallback(sc, start); + if (cell_optimize(sc, p)) + sort_func = opt_begin_bool_sort_p; + } + } + } + } + if (!sort_func) + set_curlet(sc, old_e); + } + if ((!sort_func) && (is_safe_closure(lessp))) { /* no embedded sort! or call/cc, etc */ + sc->curlet = + make_let_with_two_slots(sc, closure_let(lessp), + car(largs), sc->F, + cadr(largs), sc->F); + sc->sort_body = car(closure_body(lessp)); + sc->sort_begin = cdr(closure_body(lessp)); + sort_func = + (is_null(sc->sort_begin)) ? closure_sort : + closure_sort_begin; + sc->sort_op = + (is_syntactic_pair(sc->sort_body)) ? (opcode_t) + optimize_op(sc->sort_body) : (opcode_t) OP_EVAL; + sc->sort_v1 = let_slots(sc->curlet); + sc->sort_v2 = next_slot(let_slots(sc->curlet)); + } + } + } + } + + switch (type(data)) { + case T_PAIR: + len = s7_list_length(sc, data); /* 0 here == infinite */ + if (len <= 0) + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "sort! argument 1 should be a proper list: ~S", + 44), data))); + if (len < 2) + return (data); + if (sort_func) { + s7_int i; + s7_pointer vec, p; + vec = g_vector(sc, data); + s7_gc_protect_via_stack(sc, vec); + elements = s7_vector_elements(vec); + sc->v = vec; + local_qsort_r((void *) elements, len, sizeof(s7_pointer), + sort_func, (void *) sc); + for (p = data, i = 0; i < len; i++, p = cdr(p)) { + if (is_immutable(p)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->sort_symbol, data))); + set_car(p, elements[i]); + } + sc->v = sc->nil; + unstack(sc); /* not pop_stack! */ + return (data); + } + push_stack(sc, OP_SORT_PAIR_END, cons(sc, data, lessp), sc->code); /* save and gc protect the original list and func */ + set_car(args, g_vector(sc, data)); + break; + + case T_BYTE_VECTOR: + case T_STRING: + { + s7_int i; + s7_pointer vec; + uint8_t *chrs; + if (is_string(data)) { + len = string_length(data); + chrs = (uint8_t *) string_value(data); + } else { + len = byte_vector_length(data); + chrs = byte_vector_bytes(data); + } + if (len < 2) + return (data); + if (is_c_function(lessp)) { + if (((is_string(data)) && (sc->sort_f == char_lt_b_7pp)) || + ((is_byte_vector(data)) && (sc->sort_f == lt_b_7pp))) { + qsort((void *) chrs, len, sizeof(uint8_t), byte_less); + return (data); + } + if (((is_string(data)) && (sc->sort_f == char_gt_b_7pp)) || + ((is_byte_vector(data)) && (sc->sort_f == gt_b_7pp))) { + qsort((void *) chrs, len, sizeof(uint8_t), + byte_greater); + return (data); + } + } + vec = make_simple_vector(sc, len); + s7_gc_protect_via_stack(sc, vec); + elements = s7_vector_elements(vec); + if (is_byte_vector(data)) + for (i = 0; i < len; i++) + elements[i] = small_int(chrs[i]); + else + for (i = 0; i < len; i++) + elements[i] = chars[chrs[i]]; + if (sort_func) { + sc->v = vec; + local_qsort_r((void *) elements, len, sizeof(s7_pointer), + sort_func, (void *) sc); + if (is_byte_vector(data)) + for (i = 0; i < len; i++) + chrs[i] = (char) integer(elements[i]); + else + for (i = 0; i < len; i++) + chrs[i] = character(elements[i]); + sc->v = sc->nil; + unstack(sc); /* not pop_stack! */ + return (data); + } + unstack(sc); /* not pop_stack! */ + push_stack(sc, OP_SORT_STRING_END, + cons_unchecked(sc, data, lessp), sc->code); + set_car(args, vec); + } + break; + + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + { + s7_int i; + s7_pointer vec; + len = vector_length(data); + if (len < 2) + return (data); + if (is_c_function(lessp)) { + if (sc->sort_f == lt_b_7pp) { + if (is_float_vector(data)) + qsort((void *) vector_elements(data), len, + sizeof(s7_double), dbl_less); + else + qsort((void *) vector_elements(data), len, + sizeof(s7_int), int_less); + return (data); + } + if (sc->sort_f == gt_b_7pp) { + if (is_float_vector(data)) + qsort((void *) vector_elements(data), len, + sizeof(s7_double), dbl_greater); + else + qsort((void *) vector_elements(data), len, + sizeof(s7_int), int_greater); + return (data); + } + } + /* currently we have to make the ordinary vector here even if not sf1 + * because the sorter uses vector_element to access sort args (see SORT_DATA in eval). + * This is probably better than passing down getter/setter (fewer allocations). + * get/set macro in eval is SORT_DATA(k) then s7_vector_to_list if pair at start (sort_*_end) + */ + vec = make_vector_1(sc, len, FILLED, T_VECTOR); + /* we need this vector prefilled because make_real|integer below can cause a GC at any time during that loop, + * and the GC mark process expects the vector to have an s7_pointer at every element. + */ + add_vector(sc, vec); + s7_gc_protect_via_stack(sc, vec); + elements = s7_vector_elements(vec); + if (is_float_vector(data)) + for (i = 0; i < len; i++) + elements[i] = make_real(sc, float_vector(data, i)); + else + for (i = 0; i < len; i++) + elements[i] = make_integer(sc, int_vector(data, i)); + if (sort_func) { + sc->v = vec; + local_qsort_r((void *) elements, len, sizeof(s7_pointer), + sort_func, (void *) sc); + if (is_float_vector(data)) + for (i = 0; i < len; i++) + float_vector(data, i) = real(elements[i]); + else + for (i = 0; i < len; i++) + int_vector(data, i) = integer(elements[i]); + sc->v = sc->nil; + unstack(sc); + return (data); + } + unstack(sc); + set_car(args, vec); + push_stack(sc, OP_SORT_VECTOR_END, cons_unchecked(sc, data, lessp), sc->code); /* save and gc protect the original homogeneous vector and func */ + } + break; + + case T_VECTOR: + len = vector_length(data); + if (len < 2) + return (data); + if (sort_func) { + int32_t typ; + s7_pointer *els = s7_vector_elements(data); + typ = type(els[0]); + if ((typ == T_INTEGER) || (typ == T_REAL) || (typ == T_STRING) + || (typ == T_CHARACTER)) { + s7_int i; + for (i = 1; i < len; i++) + if (type(els[i]) != typ) { + typ = T_FREE; + break; + } + } + if ((sc->sort_f == lt_b_7pp) || (sc->sort_f == gt_b_7pp)) { + if (typ == T_INTEGER) { + qsort((void *) els, len, sizeof(s7_pointer), + ((sc->sort_f == + lt_b_7pp) ? int_less_2 : int_greater_2)); + return (data); + } + if (typ == T_REAL) { + qsort((void *) els, len, sizeof(s7_pointer), + ((sc->sort_f == + lt_b_7pp) ? dbl_less_2 : dbl_greater_2)); + return (data); + } + } + if ((typ == T_STRING) && ((sc->sort_f == string_lt_b_7pp) + || (sc->sort_f == string_gt_b_7pp))) { + qsort((void *) els, len, sizeof(s7_pointer), + ((sc->sort_f == + string_lt_b_7pp) ? str_less_2 : str_greater_2)); + return (data); + } + if ((typ == T_CHARACTER) && ((sc->sort_f == char_lt_b_7pp) + || (sc->sort_f == char_gt_b_7pp))) { + qsort((void *) els, len, sizeof(s7_pointer), + ((sc->sort_f = + char_lt_b_7pp) ? chr_less_2 : chr_greater_2)); + return (data); + } + local_qsort_r((void *) s7_vector_elements(data), len, + sizeof(s7_pointer), sort_func, (void *) sc); + return (data); + } + break; + + default: + return (method_or_bust_with_type + (sc, data, sc->sort_symbol, args, a_sequence_string, 1)); + } + + n = len - 1; + k = (n / 2) + 1; + + lx = s7_make_vector(sc, (sc->safety == NO_SAFETY) ? 4 : 6); + sc->v = lx; + vector_element(lx, 0) = make_mutable_integer(sc, n); + vector_element(lx, 1) = make_mutable_integer(sc, k); + vector_element(lx, 2) = make_mutable_integer(sc, 0); + vector_element(lx, 3) = make_mutable_integer(sc, 0); + if (sc->safety > NO_SAFETY) { + vector_element(lx, 4) = make_mutable_integer(sc, 0); + vector_element(lx, 5) = make_integer(sc, n * n); + } + push_stack(sc, OP_SORT, args, lx); + sc->v = sc->nil; + return (sc->F); + /* if the comparison function waffles, sort! can hang: (sort! '(1 2 3) (lambda (a b) (= a b))) + * set 'safety to 1 to add a check for this loop, but the "safe" procedures are direct, so unchecked. + */ +} + +/* these are for the eval sort -- sort a vector, then if necessary put that data into the original sequence */ +static s7_pointer vector_into_list(s7_scheme * sc, s7_pointer vect, + s7_pointer lst) +{ + s7_pointer p; + s7_pointer *elements = vector_elements(vect); + s7_int i, len = vector_length(vect); + for (i = 0, p = lst; i < len; i++, p = cdr(p)) { + if (is_immutable(p)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->sort_symbol, lst))); + set_car(p, elements[i]); + } + return (lst); +} + +static s7_pointer vector_into_fi_vector(s7_pointer source, s7_pointer dest) +{ + s7_pointer *elements = vector_elements(source); + s7_int i, len = vector_length(source); + if (is_float_vector(dest)) { + s7_double *flts = float_vector_floats(dest); + for (i = 0; i < len; i++) + flts[i] = real(elements[i]); + } else { + s7_int *ints = int_vector_ints(dest); + for (i = 0; i < len; i++) + ints[i] = integer(elements[i]); + } + return (dest); +} + +static s7_pointer vector_into_string(s7_pointer vect, s7_pointer dest) +{ + s7_pointer *elements = vector_elements(vect); + s7_int i, len = vector_length(vect); + uint8_t *str; + if (is_byte_vector(dest)) { + str = (uint8_t *) byte_vector_bytes(dest); + for (i = 0; i < len; i++) + str[i] = (uint8_t) integer(elements[i]); + } else { + str = (uint8_t *) string_value(dest); + for (i = 0; i < len; i++) + str[i] = character(elements[i]); + } + return (dest); +} + +#define SORT_N integer(vector_element(sc->code, 0)) +#define SORT_K integer(vector_element(sc->code, 1)) +#define SORT_J integer(vector_element(sc->code, 2)) +#define SORT_K1 integer(vector_element(sc->code, 3)) +#define SORT_CALLS integer(vector_element(sc->code, 4)) +#define SORT_STOP integer(vector_element(sc->code, 5)) +#define SORT_DATA(K) vector_element(car(sc->args), K) +#define SORT_LESSP cadr(sc->args) + +static s7_pointer op_heapsort(s7_scheme * sc) +{ + s7_int n = SORT_N, j, k = SORT_K1; + s7_pointer lx; + + if ((n == k) || (k > ((s7_int) (n / 2)))) /* k == n == 0 is the first case */ + return (sc->code); + + if (sc->safety > NO_SAFETY) { + SORT_CALLS++; + if (SORT_CALLS > SORT_STOP) + eval_error_any(sc, sc->out_of_range_symbol, + "sort! is caught in an infinite loop, comparison: ~S", + 51, SORT_LESSP); + } + j = 2 * k; + SORT_J = j; + if (j < n) { + push_stack_direct(sc, OP_SORT1); + lx = SORT_LESSP; /* cadr of sc->args */ + if (needs_copied_args(lx)) + sc->args = list_2(sc, SORT_DATA(j), SORT_DATA(j + 1)); + else { + set_car(sc->t2_1, SORT_DATA(j)); + set_car(sc->t2_2, SORT_DATA(j + 1)); + sc->args = sc->t2_1; + } + sc->code = lx; + sc->value = sc->T; /* for eval */ + } else + sc->value = sc->F; + return (NULL); +} + +static bool op_sort1(s7_scheme * sc) +{ + s7_int j = SORT_J, k = SORT_K1; + s7_pointer lx; + if (is_true(sc, sc->value)) { + j = j + 1; + SORT_J = j; + } + push_stack_direct(sc, OP_SORT2); + lx = SORT_LESSP; + if (needs_copied_args(lx)) + sc->args = list_2(sc, SORT_DATA(k), SORT_DATA(j)); + else { + set_car(sc->t2_1, SORT_DATA(k)); + set_car(sc->t2_2, SORT_DATA(j)); + sc->args = sc->t2_1; + } + sc->code = lx; + return (false); +} + +static bool op_sort2(s7_scheme * sc) +{ + s7_int j = SORT_J, k = SORT_K1; + if (is_true(sc, sc->value)) { + s7_pointer lx; + lx = SORT_DATA(j); + SORT_DATA(j) = SORT_DATA(k); + SORT_DATA(k) = lx; + } else + return (true); + SORT_K1 = SORT_J; + return (false); +} + +static bool op_sort(s7_scheme * sc) +{ + /* coming in sc->args is sort args (data less?), sc->code = #(n k 0 ...) + * here we call the inner loop until k <= 0 [the local k! -- this is tricky because scheme passes args by value] + */ + s7_int k = SORT_K; + if (k > 0) { + SORT_K = k - 1; + SORT_K1 = k - 1; + push_stack_direct(sc, OP_SORT); + return (false); + } + return (true); +} + +static bool op_sort3(s7_scheme * sc) +{ + s7_int n = SORT_N; + s7_pointer lx; + if (n <= 0) { + sc->value = car(sc->args); + return (true); + } + lx = SORT_DATA(0); + SORT_DATA(0) = SORT_DATA(n); + SORT_DATA(n) = lx; + SORT_N = n - 1; + SORT_K1 = 0; + push_stack_direct(sc, OP_SORT3); + return (false); +} + + +/* -------- hash tables -------- */ + +static void free_hash_table(s7_scheme * sc, s7_pointer table) +{ + hash_entry_t **entries = hash_table_elements(table); + if (hash_table_entries(table) > 0) { + s7_int i, len = hash_table_mask(table) + 1; + for (i = 0; i < len; i++) { + hash_entry_t *p, *n; + for (p = entries[i++]; p; p = n) { + n = hash_entry_next(p); + liberate_block(sc, p); + } + for (p = entries[i]; p; p = n) { + n = hash_entry_next(p); + liberate_block(sc, p); + } + } + } + liberate(sc, hash_table_block(table)); +} + +static hash_entry_t *make_hash_entry(s7_scheme * sc, s7_pointer key, + s7_pointer value, s7_int raw_hash) +{ + hash_entry_t *p; + p = (hash_entry_t *) mallocate_block(sc); + hash_entry_key(p) = key; + hash_entry_set_value(p, value); + hash_entry_set_raw_hash(p, raw_hash); + return (p); +} + + +/* -------------------------------- hash-table? -------------------------------- */ +bool s7_is_hash_table(s7_pointer p) +{ + return (is_hash_table(p)); +} + +static s7_pointer g_is_hash_table(s7_scheme * sc, s7_pointer args) +{ +#define H_is_hash_table "(hash-table? obj) returns #t if obj is a hash-table" +#define Q_is_hash_table sc->pl_bt + check_boolean_method(sc, is_hash_table, sc->is_hash_table_symbol, + args); +} + + +/* -------------------------------- hash-table-entries -------------------------------- */ +static s7_pointer g_hash_table_entries(s7_scheme * sc, s7_pointer args) +{ +#define H_hash_table_entries "(hash-table-entries obj) returns the number of entries in the hash-table obj" +#define Q_hash_table_entries s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_hash_table_symbol) + + if (!is_hash_table(car(args))) + return (method_or_bust_one_arg + (sc, car(args), sc->hash_table_entries_symbol, args, + T_HASH_TABLE)); + return (make_integer(sc, hash_table_entries(car(args)))); +} + +static s7_int hash_table_entries_i_7p(s7_scheme * sc, s7_pointer p) +{ + if (!is_hash_table(p)) + return (integer + (method_or_bust_one_arg_p + (sc, p, sc->hash_table_entries_symbol, T_HASH_TABLE))); + return (hash_table_entries(p)); +} + + +/* ---------------- hash map and equality tables ---------------- */ +/* built in hash loc tables for eq? eqv? equal? equivalent? = string=? string-ci=? char=? char-ci=? (default=equal?) */ +#define hash_loc(Sc, Table, Key) (*(hash_table_mapper(Table)[type(Key)]))(Sc, Table, Key) + +static hash_map_t eq_hash_map[NUM_TYPES]; +static hash_map_t string_eq_hash_map[NUM_TYPES]; +static hash_map_t char_eq_hash_map[NUM_TYPES]; +static hash_map_t closure_hash_map[NUM_TYPES]; +static hash_map_t equivalent_hash_map[NUM_TYPES]; +static hash_map_t c_function_hash_map[NUM_TYPES]; +#if (!WITH_PURE_S7) +static hash_map_t string_ci_eq_hash_map[NUM_TYPES]; +static hash_map_t char_ci_eq_hash_map[NUM_TYPES]; +#endif +/* also default_hash_map */ + + +/* ---------------- hash-code ---------------- */ +/* eqfunc handling which will require other dummy tables */ + +static s7_pointer make_dummy_hash_table(s7_scheme * sc) +{ + s7_pointer table; /* make the absolute minimal hash-table that can support hash-code */ + table = (s7_pointer) Calloc(1, sizeof(s7_cell)); + set_type_bit(table, T_IMMUTABLE | T_HASH_TABLE | T_UNHEAP); + hash_table_mapper(table) = default_hash_map; + return (table); +} + +s7_int s7_hash_code(s7_scheme * sc, s7_pointer obj, s7_pointer eqfunc) +{ + return (default_hash_map[type(obj)] + (sc, sc->dummy_equal_hash_table, obj)); +} + +static s7_pointer g_hash_code(s7_scheme * sc, s7_pointer args) +{ +#define H_hash_code "(hash-code obj (eqfunc)) returns an integer suitable for use as a hash code for obj." +#define Q_hash_code s7_make_signature(sc, 3, sc->is_integer_symbol, sc->T, sc->T) + s7_pointer obj = car(args); + return (make_integer + (sc, + default_hash_map[type(obj)] (sc, sc->dummy_equal_hash_table, + obj))); +} + + +static bool (*equals[NUM_TYPES])(s7_scheme * sc, s7_pointer x, + s7_pointer y, shared_info_t * ci); +static bool (*equivalents[NUM_TYPES])(s7_scheme * sc, s7_pointer x, + s7_pointer y, shared_info_t * ci); + +static hash_entry_t *(*default_hash_checks[NUM_TYPES])(s7_scheme * sc, + s7_pointer table, + s7_pointer key); +static hash_entry_t *(*equal_hash_checks[NUM_TYPES])(s7_scheme * sc, + s7_pointer table, + s7_pointer key); + + +/* ---------------- hash empty ---------------- */ +static hash_entry_t *hash_empty(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return (sc->unentry); +} + +/* ---------------- hash syntax ---------------- */ +static s7_int hash_map_syntax(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return (pointer_map(syntax_symbol(key))); +} + +static hash_entry_t *hash_equal_syntax(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + s7_int loc; + loc = hash_loc(sc, table, key) & hash_table_mask(table); + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if ((is_syntax(hash_entry_key(x))) && (syntax_symbol(hash_entry_key(x)) == syntax_symbol(key))) /* the opcodes might differ, but the symbols should not */ + return (x); + return (sc->unentry); +} + +/* ---------------- hash symbols ---------------- */ +static s7_int hash_map_symbol(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return (pointer_map(key)); +} + +static hash_entry_t *hash_symbol(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + for (x = + hash_table_element(table, + pointer_map(key) & hash_table_mask(table)); x; + x = hash_entry_next(x)) + if (key == hash_entry_key(x)) + return (x); + return (sc->unentry); +} + + +/* ---------------- hash numbers ---------------- */ + +static s7_int hash_float_location(s7_double x) +{ + return (((is_NaN(x)) || (is_inf(x))) ? 0 : (s7_int) floor(fabs(x))); +} + +static s7_int hash_map_int(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return (s7_int_abs(integer(key))); +} + +static s7_int hash_map_real(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return (hash_float_location(real(key))); +} + +static s7_int hash_map_complex(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return (hash_float_location(real_part(key))); +} + +static s7_int hash_map_ratio(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + /* if numerator is -9223372036854775808, s7_int_abs overflows -- need to divide, then abs: -9223372036854775808/3: -3074457345618258602 3074457345618258602 + * (s7_int)floorl(fabsl(fraction(key))) is no good here, 3441313796169221281/1720656898084610641: 1 2 (in valgrind), + * floor ratio is 1: (- (* 2 1720656898084610641) 3441313796169221281) -> 1 + * or (gmp:) 1.999999999999999999418826611445214136431E0, so the floorl(fabsl) version is wrong + */ + return (s7_int_abs(numerator(key) / denominator(key))); +} + +#if WITH_GMP +static s7_int hash_map_big_int(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + /* may need to use quotient here */ + mpz_abs(sc->mpz_1, big_integer(key)); + return (mpz_get_si(sc->mpz_1)); /* returns the bits that fit */ +} + +static s7_int hash_map_big_ratio(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + mpq_abs(sc->mpq_1, big_ratio(key)); + mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_1), mpq_denref(sc->mpq_1)); + return (mpz_get_si(sc->mpz_1)); +} + +static s7_int hash_map_big_real_1(s7_scheme * sc, s7_pointer table, + mpfr_t key) +{ + if ((mpfr_nan_p(key)) || (mpfr_inf_p(key))) + return (0); + mpfr_abs(sc->mpfr_1, key, MPFR_RNDN); + /* mpfr_get_si returns most-positive-int if > 2^63! luckily there aren't any more of these */ + mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD); /* floor not round */ + return (mpz_get_si(sc->mpz_1)); +} + +static s7_int hash_map_big_real(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return (hash_map_big_real_1(sc, table, big_real(key))); +} + +static s7_int hash_map_big_complex(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return (hash_map_big_real_1(sc, table, mpc_realref(big_complex(key)))); +} +#endif + +static hash_entry_t *find_number_in_bin(s7_scheme * sc, hash_entry_t * bin, + s7_pointer key) +{ + s7_double old_eps; + bool (*equiv)(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci); + old_eps = sc->equivalent_float_epsilon; + equiv = equivalents[type(key)]; + sc->equivalent_float_epsilon = sc->hash_table_float_epsilon; + for (; bin; bin = hash_entry_next(bin)) + if (equiv(sc, key, hash_entry_key(bin), NULL)) { + sc->equivalent_float_epsilon = old_eps; + return (bin); + } + sc->equivalent_float_epsilon = old_eps; + return (NULL); +} + +static hash_entry_t *hash_number_equivalent(s7_scheme * sc, + s7_pointer table, + s7_pointer key) +{ + /* for equivalent? and =, kind of complicated because two bins can be involved if the key is close to an integer */ +#if WITH_GMP + /* first try loc from hash_loc, then get key-floor(key) [with abs], and check against + * epsilon: diff < eps call find big in bin-1, diff > 1.0-eps call same in bin+1 + */ + s7_int loc, loc1, hash_mask = hash_table_mask(table), hash_loc; + hash_entry_t *i1; + + loc = hash_loc(sc, table, key); + hash_loc = loc & hash_mask; + + i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key); + if (i1) + return (i1); + + if (is_real(key)) { + s7_pointer res; + res = any_real_to_mpfr(sc, key, sc->mpfr_1); + if (res) + return (sc->unentry); + } else if (is_t_complex(key)) + mpfr_set_d(sc->mpfr_1, real_part(key), MPFR_RNDN); + else + mpfr_set(sc->mpfr_1, mpc_realref(big_complex(key)), MPFR_RNDN); + + /* mpfr_1 is big_real, so we can use hash_loc of big_real (and can ignore NaN's): */ + mpfr_abs(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + mpfr_add_d(sc->mpfr_2, sc->mpfr_1, sc->hash_table_float_epsilon, + MPFR_RNDN); + mpfr_get_z(sc->mpz_1, sc->mpfr_2, MPFR_RNDD); + loc1 = mpz_get_si(sc->mpz_1); + if (loc1 != loc) { + if (loc1 == hash_table_mask(table)) + loc1 = 0; + hash_loc = loc1 & hash_mask; + i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), + key); + return ((i1) ? i1 : sc->unentry); + } + mpfr_sub_d(sc->mpfr_2, sc->mpfr_1, sc->hash_table_float_epsilon, + MPFR_RNDN); + mpfr_get_z(sc->mpz_1, sc->mpfr_2, MPFR_RNDD); + loc1 = mpz_get_si(sc->mpz_1); + if (loc1 != loc) { + if (loc1 < 0) + loc1 = hash_table_mask(table); + hash_loc = loc1 & hash_mask; + i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), + key); + if (i1) + return (i1); + } + return (sc->unentry); +#else + s7_int iprobe, loc; + s7_double bin_dist, fprobe, keyval; + hash_entry_t *i1; + + keyval = (is_real(key)) ? s7_real(key) : real_part(key); + fprobe = fabs(keyval); + iprobe = (s7_int) floor(fprobe); + loc = iprobe & hash_table_mask(table); + + i1 = find_number_in_bin(sc, hash_table_element(table, loc), key); + if (i1) + return (i1); + + bin_dist = fprobe - iprobe; + if (bin_dist <= sc->hash_table_float_epsilon) /* maybe closest is below iprobe, key+eps>iprobe but key maps to iprobe-1 */ + i1 = find_number_in_bin(sc, + hash_table_element(table, + (loc > + 0) ? loc - + 1 : + hash_table_mask(table)), + key); + else if (bin_dist >= (1.0 - sc->hash_table_float_epsilon)) + i1 = find_number_in_bin(sc, + hash_table_element(table, + (loc < + hash_table_mask(table)) + ? loc + 1 : 0), key); + return ((i1) ? i1 : sc->unentry); +#endif +} + +static hash_entry_t *hash_int(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ +#if WITH_GMP + if ((is_t_integer(key)) || (is_t_big_integer(key))) +#else + if (is_t_integer(key)) +#endif + { + s7_int loc, hash_mask = hash_table_mask(table), kv; + hash_entry_t *x; +#if WITH_GMP + kv = (is_t_integer(key)) ? integer(key) : + mpz_get_si(big_integer(key)); +#else + kv = integer(key); +#endif + loc = s7_int_abs(kv) & hash_mask; + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) +#if WITH_GMP + if (is_t_integer(hash_entry_key(x))) { + if (integer(hash_entry_key(x)) == kv) + return (x); + } else + if ((is_t_big_integer(hash_entry_key(x))) && + (mpz_get_si(big_integer(hash_entry_key(x))) == kv)) + return (x); +#else + if (integer(hash_entry_key(x)) == kv) + return (x); +#endif + } + return (sc->unentry); +} + +static hash_entry_t *hash_float(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + /* if a hash-table has only t_real keys, its checker is hash_float, but we might use a t_big_real key */ +#if WITH_GMP + if ((is_t_real(key)) || (is_t_big_real(key))) +#else + if (is_t_real(key)) +#endif + { + s7_double keyval; + s7_int loc, hash_mask; + hash_entry_t *x; +#if WITH_GMP + if (is_t_real(key)) { + keyval = real(key); + if (is_NaN(keyval)) + return (sc->unentry); + } else { + if (mpfr_nan_p(big_real(key))) + return (sc->unentry); + keyval = mpfr_get_d(big_real(key), MPFR_RNDN); + } +#else + keyval = real(key); + if (is_NaN(keyval)) + return (sc->unentry); +#endif + hash_mask = hash_table_mask(table); + loc = hash_float_location(keyval) & hash_mask; + + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) { + if ((is_t_real(hash_entry_key(x))) && + (keyval == real(hash_entry_key(x)))) + return (x); +#if WITH_GMP + if ((is_t_big_real(hash_entry_key(x))) && + (mpfr_cmp_d(big_real(hash_entry_key(x)), keyval) == 0) && + (!mpfr_nan_p(big_real(hash_entry_key(x))))) + return (x); +#endif + } + } + return (sc->unentry); +} + +static hash_entry_t *hash_num_eq(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + s7_int hash_mask = hash_table_mask(table), loc; + loc = hash_loc(sc, table, key) & hash_mask; + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if (num_eq_b_7pp(sc, key, hash_entry_key(x))) + return (x); + return (sc->unentry); +} + +static hash_entry_t *hash_real_num_eq(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ +#if WITH_GMP + if ((is_t_real(key)) && (is_NaN(real(key)))) + return (sc->unentry); + if ((is_t_big_real(key)) && (mpfr_nan_p(big_real(key)))) + return (sc->unentry); + return (hash_num_eq(sc, table, key)); +#else + return ((is_NaN(s7_real(key))) ? sc->unentry : + hash_num_eq(sc, table, key)); +#endif +} + +static hash_entry_t *hash_complex_num_eq(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ +#if WITH_GMP + if ((is_t_complex(key)) + && ((is_NaN(real_part(key))) || (is_NaN(imag_part(key))))) + return (sc->unentry); + if ((is_t_big_complex(key)) + && ((mpfr_nan_p(mpc_realref(big_complex(key)))) + || (mpfr_nan_p(mpc_imagref(big_complex(key)))))) + return (sc->unentry); + return (hash_num_eq(sc, table, key)); +#else + return (((is_NaN(real_part(key))) + || (is_NaN(imag_part(key)))) ? sc->unentry : hash_num_eq(sc, + table, + key)); +#endif +} + +static hash_entry_t *hash_number_num_eq(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + if (is_number(key)) { +#if (!WITH_GMP) + hash_entry_t *x; + s7_int hash_mask = hash_table_mask(table); + hash_map_t map; + map = hash_table_mapper(table)[type(key)]; + if (hash_table_checker(table) == hash_int) { /* surely by far the most common case? only ints */ + s7_int keyi = integer(key), loc; + loc = map(sc, table, key) & hash_mask; + for (x = hash_table_element(table, loc); x; + x = hash_entry_next(x)) + if (keyi == integer(hash_entry_key(x))) /* not in gmp, hash_int as eq_func, what else can key be but t_integer? */ + return (x); + } else +#endif + return ((is_real(key)) ? hash_real_num_eq(sc, table, key) : + hash_complex_num_eq(sc, table, key)); + } + return (sc->unentry); +} + + +/* ---------------- hash characters ---------------- */ +static s7_int hash_map_char(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return (character(key)); +} + +static hash_entry_t *hash_char(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + if (is_character(key)) { + /* return(hash_eq(sc, table, key)); + * but I think if we get here at all, we have to be using default_hash_checks|maps -- see hash_symbol above. + */ + hash_entry_t *x; + s7_int loc; + loc = character(key) & hash_table_mask(table); + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if (key == hash_entry_key(x)) + return (x); + } + return (sc->unentry); +} + +#if (!WITH_PURE_S7) +static s7_int hash_map_ci_char(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return (upper_character(key)); +} + +static hash_entry_t *hash_ci_char(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + if (is_character(key)) { + hash_entry_t *x; + s7_int hash_mask = hash_table_mask(table), loc; + loc = hash_loc(sc, table, key) & hash_mask; + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if (upper_character(key) == upper_character(hash_entry_key(x))) + return (x); + } + return (sc->unentry); +} +#endif + + +/* ---------------- hash strings ---------------- */ +static s7_int hash_map_string(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + if (string_hash(key) == 0) + string_hash(key) = + raw_string_hash((const uint8_t *) string_value(key), + string_length(key)); + return (string_hash(key)); +} + +static hash_entry_t *hash_string(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + if (is_string(key)) { + hash_entry_t *x; + s7_int key_len = string_length(key), hash_mask; + uint64_t hash; + const char *key_str = string_value(key); + if (string_hash(key) == 0) + string_hash(key) = + raw_string_hash((const uint8_t *) string_value(key), + string_length(key)); + hash = string_hash(key); + hash_mask = hash_table_mask(table); + + if (key_len <= 8) { + for (x = hash_table_element(table, hash & hash_mask); x; + x = hash_entry_next(x)) + if ((hash == string_hash(hash_entry_key(x))) + && (key_len == string_length(hash_entry_key(x)))) + return (x); + } else + for (x = hash_table_element(table, hash & hash_mask); x; + x = hash_entry_next(x)) + if ((hash == string_hash(hash_entry_key(x))) && (key_len == string_length(hash_entry_key(x))) && /* these are scheme strings, so we can't assume 0=end of string */ + (strings_are_equal_with_length + (key_str, string_value(hash_entry_key(x)), key_len))) + return (x); + } + return (sc->unentry); +} + +#if (!WITH_PURE_S7) +static s7_int hash_map_ci_string(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + s7_int len = string_length(key); + return ((len == + 0) ? 0 : (len + + (uppers[(int32_t) (string_value(key)[0])] << 4))); +} + +static hash_entry_t *hash_ci_string(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + if (is_string(key)) { + hash_entry_t *x; + s7_int hash, hash_mask = hash_table_mask(table); + hash = hash_map_ci_string(sc, table, key); + for (x = hash_table_element(table, hash & hash_mask); x; + x = hash_entry_next(x)) + if (scheme_strequal_ci(key, hash_entry_key(x))) + return (x); + } + return (sc->unentry); +} +#endif + + +/* ---------------- hash eq? ---------------- */ +static s7_int hash_map_nil(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return (type(key)); +} + +static s7_int hash_map_eq(s7_scheme * sc, s7_pointer table, s7_pointer key) +{ + return (pointer_map(key)); +} + +static hash_entry_t *hash_eq(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + /* explicit eq? as hash equality func or (for example) symbols as keys */ + hash_entry_t *x; + s7_int loc, hash_mask = hash_table_mask(table); + loc = pointer_map(key) & hash_mask; /* hash_map_eq */ + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if (key == hash_entry_key(x)) + return (x); + return (sc->unentry); +} + +/* ---------------- hash eqv? ---------------- */ + +static hash_entry_t *hash_eqv(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + s7_int loc, hash_mask = hash_table_mask(table); + loc = hash_loc(sc, table, key) & hash_mask; + if (is_number(key)) { + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if (numbers_are_eqv(sc, key, hash_entry_key(x))) + return (x); + } else + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if (s7_is_eqv(sc, key, hash_entry_key(x))) + return (x); + return (sc->unentry); +} + +/* ---------------- hash equal? ---------------- */ + +static s7_int hash_map_hash_table(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + /* hash-tables are equal if key/values match independent of table size and entry order. + * if not using equivalent?, hash_table_checker|mapper must also be the same. + * Keys are supposed to be constant while keys, so a hash-table shouldn't be a key of itself. + */ + return (hash_table_entries(key)); +} + +static s7_int hash_map_int_vector(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + if (vector_length(key) == 0) + return (0); + if (vector_length(key) == 1) + return (s7_int_abs(int_vector(key, 0))); + return (vector_length(key) + s7_int_abs(int_vector(key, 0)) + s7_int_abs(int_vector(key, 1))); /* overflow is ok here (in + or abs), I guess (as long as it's consistent) */ +} + +static s7_int hash_map_byte_vector(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + if (byte_vector_length(key) == 0) + return (0); + if (byte_vector_length(key) == 1) + return ((s7_int) byte_vector(key, 0)); + return (byte_vector_length(key) + byte_vector(key, 0) + + byte_vector(key, 1)); +} + +static s7_int hash_map_float_vector(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + if (vector_length(key) == 0) + return (0); + if (vector_length(key) == 1) + return (hash_float_location(float_vector(key, 0))); + return (vector_length(key) + + hash_float_location(float_vector(key, 0)) + + hash_float_location(float_vector(key, 1))); +} + +static s7_int hash_map_vector(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + if ((vector_length(key) == 0) || (is_sequence(vector_element(key, 0)))) + return (vector_length(key)); + if ((vector_length(key) == 1) || (is_sequence(vector_element(key, 1)))) + return (hash_loc(sc, table, vector_element(key, 0))); + return (vector_length(key) + hash_loc(sc, table, vector_element(key, 0)) + hash_loc(sc, table, vector_element(key, 1))); /* see above */ +} + + +static s7_int hash_map_closure(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + s7_pointer old_e, args, body, f = hash_table_procedures_mapper(table); + if (f == sc->unused) + s7_error(sc, make_symbol(sc, "hash-map-recursion"), + set_elist_1(sc, + wrap_string(sc, + "hash-table map function called recursively", + 42))); + gc_protect_via_stack(sc, f); + hash_table_set_procedures_mapper(table, sc->unused); + old_e = sc->curlet; + args = closure_args(f); + body = closure_body(f); + sc->curlet = + make_let_with_slot(sc, closure_let(f), + (is_symbol(car(args))) ? car(args) : caar(args), + key); + push_stack_direct(sc, OP_EVAL_DONE); + if (is_pair(cdr(body))) + push_stack_no_args(sc, sc->begin_op, cdr(body)); + sc->code = car(body); + eval(sc, OP_EVAL); + unstack(sc); + hash_table_set_procedures_mapper(table, f); + set_curlet(sc, old_e); + if (!s7_is_integer(sc->value)) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "hash-table map function should return an integer: ~S", + 52), sc->value)); + return (integer(sc->value)); +} + +static s7_int hash_map_let(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + /* lets are equal if same symbol/value pairs, independent of order, taking into account shadowing + * (length (inlet 'a 1 'a 2)) = 2 + * but this counts as just one entry from equal?'s point of view, so if more than one entry, we have a problem. + * (equal? (inlet 'a 1) (inlet 'a 3 'a 2 'a 1)) = #t + * also currently equal? follows outlet, but that is ridiculous here, so in this case hash equal? + * is not the same as equal? Surely anyone using lets as keys wants eq? + */ + s7_pointer slot; + s7_int slots; + + if ((key == sc->rootlet) || (!tis_slot(let_slots(key)))) + return (0); + slot = let_slots(key); + if (!tis_slot(next_slot(slot))) { + if (is_sequence(slot_value(slot))) /* avoid loop if cycles */ + return (pointer_map(slot_symbol(slot))); + return (pointer_map(slot_symbol(slot)) + + hash_loc(sc, table, slot_value(slot))); + } + slots = 0; + for (; tis_slot(slot); slot = next_slot(slot)) + if (!is_matched_symbol(slot_symbol(slot))) { + set_match_symbol(slot_symbol(slot)); + slots++; + } + for (slot = let_slots(key); tis_slot(slot); slot = next_slot(slot)) + clear_match_symbol(slot_symbol(slot)); + + if (slots != 1) + return (slots); + slot = let_slots(key); + if (is_sequence(slot_value(slot))) /* avoid loop if cycles */ + return (pointer_map(slot_symbol(slot))); + return (pointer_map(slot_symbol(slot)) + + hash_loc(sc, table, slot_value(slot))); +} + +static hash_entry_t *hash_equal_eq(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + s7_int loc; + loc = hash_loc(sc, table, key) & hash_table_mask(table); + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if (hash_entry_key(x) == key) + return (x); + return (sc->unentry); +} + +static hash_entry_t *hash_equal_integer(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + s7_int loc, keyint = integer(key); + loc = s7_int_abs(keyint) & hash_table_mask(table); /* hash_loc -> hash_map_integer */ + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) { + if ((is_t_integer(hash_entry_key(x))) && + (keyint == integer(hash_entry_key(x)))) + return (x); +#if WITH_GMP + if ((is_t_big_integer(hash_entry_key(x))) && + (mpz_cmp_si(big_integer(hash_entry_key(x)), keyint) == 0)) + return (x); +#endif + } + return (sc->unentry); +} + +static hash_entry_t *hash_equal_ratio(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + s7_int loc, keynum = numerator(key), keyden = denominator(key); + loc = s7_int_abs(keynum / keyden) & hash_table_mask(table); /* hash_loc -> hash_map_ratio */ + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) { + if ((is_t_ratio(hash_entry_key(x))) && + (keynum == numerator(hash_entry_key(x))) && + (keyden == denominator(hash_entry_key(x)))) + return (x); +#if WITH_GMP + if ((is_t_big_ratio(hash_entry_key(x))) && + (keynum == + mpz_get_si(mpq_numref(big_ratio(hash_entry_key(x))))) + && (keyden == + mpz_get_si(mpq_denref(big_ratio(hash_entry_key(x)))))) + return (x); +#endif + } + return (sc->unentry); +} + +static hash_entry_t *hash_equal_real(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + s7_int loc; + s7_double keydbl = real(key); + if (is_NaN(keydbl)) + return (sc->unentry); + loc = hash_float_location(keydbl) & hash_table_mask(table); + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) { + if ((is_t_real(hash_entry_key(x))) && + (keydbl == real(hash_entry_key(x)))) + return (x); +#if WITH_GMP + if ((is_t_big_real(hash_entry_key(x))) && + (mpfr_cmp_d(big_real(hash_entry_key(x)), keydbl) == 0) && + (!mpfr_nan_p(big_real(hash_entry_key(x))))) + return (x); +#endif + } + return (sc->unentry); +} + +static hash_entry_t *hash_equal_complex(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + s7_int loc; + s7_double keyrl = real_part(key), keyim = imag_part(key); +#if WITH_GMP + if ((is_NaN(keyrl)) || (is_NaN(keyim))) + return (sc->unentry); +#endif + loc = hash_float_location(keyrl) & hash_table_mask(table); + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) { + if ((is_t_complex(hash_entry_key(x))) && + (keyrl == real_part(hash_entry_key(x))) && + (keyim == imag_part(hash_entry_key(x)))) + return (x); +#if WITH_GMP + if ((is_t_big_complex(hash_entry_key(x))) && + (mpfr_cmp_d(mpc_realref(big_complex(hash_entry_key(x))), keyrl) + == 0) + && + (mpfr_cmp_d(mpc_imagref(big_complex(hash_entry_key(x))), keyim) + == 0) + && (!mpfr_nan_p(mpc_realref(big_complex(hash_entry_key(x))))) + && (!mpfr_nan_p(mpc_imagref(big_complex(hash_entry_key(x)))))) + return (x); +#endif + } + return (sc->unentry); +} + +static hash_entry_t *hash_equal_any(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + s7_int hash, loc; + bool (*equal)(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci); + + equal = equals[type(key)]; + hash = hash_loc(sc, table, key); + loc = hash & hash_table_mask(table); + + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if (hash_entry_raw_hash(x) == hash) + if (equal(sc, key, hash_entry_key(x), NULL)) + return (x); + return (sc->unentry); +} + + +/* ---------------- hash c_functions ---------------- */ +static s7_int hash_map_c_function(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + s7_function f = c_function_call(hash_table_procedures_mapper(table)); + set_car(sc->t1_1, key); + return (integer(f(sc, sc->t1_1))); +} + +static hash_entry_t *hash_c_function(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + s7_int hash, loc, hash_mask = hash_table_mask(table); + s7_function f = c_function_call(hash_table_procedures_checker(table)); + hash = hash_loc(sc, table, key); + loc = hash & hash_mask; + set_car(sc->t2_1, key); + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if (hash_entry_raw_hash(x) == hash) { + set_car(sc->t2_2, hash_entry_key(x)); + if (is_true(sc, f(sc, sc->t2_1))) + return (x); + } + return (sc->unentry); +} + +static int32_t len_upto_8(s7_pointer p) +{ + s7_pointer x; + int32_t i; /* unrolling this loop saves 10-15% */ + for (i = 0, x = p; (is_pair(x)) && (i < 8); i++, x = cdr(x)); + return (i); +} + +static s7_int hash_map_pair(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + /* len+loc(car) is not horrible, but it means (for example) every list '(set! ...) is hashed to the same location, + * so at least we need to take cadr into account if possible. Better would combine the list_length + * with stats like symbols/pairs/constants at top level, then use those to spread it out over all the locs. + */ + s7_pointer p1; + s7_int loc = 0; + + if (!is_sequence(car(key))) + loc = hash_loc(sc, table, car(key)) + 1; + else if ((is_pair(car(key))) && (!is_sequence(caar(key)))) + loc = hash_loc(sc, table, caar(key)) + 1; + p1 = cdr(key); + if (is_pair(p1)) { + if (!is_sequence(car(p1))) + loc += hash_loc(sc, table, car(p1)) + 1; + else if ((is_pair(car(p1))) && (!is_sequence(caar(p1)))) + loc += hash_loc(sc, table, caar(p1)) + 1; + } + loc = (loc << 3) | len_upto_8(key); + return (loc); +} + + +static hash_entry_t *hash_closure(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + s7_int hash, loc, hash_mask = hash_table_mask(table); + s7_pointer args, body, old_e = sc->curlet, f = + hash_table_procedures_checker(table); + hash = hash_loc(sc, table, key); + loc = hash & hash_mask; + args = closure_args(f); /* in lambda* case, car/cadr(args) can be lists */ + body = closure_body(f); + sc->curlet = make_let_with_two_slots(sc, closure_let(f), + (is_symbol(car(args))) ? car(args) + : caar(args), key, + (is_symbol(cadr(args))) ? + cadr(args) : caadr(args), sc->F); + + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if (hash_entry_raw_hash(x) == hash) { + slot_set_value(next_slot(let_slots(sc->curlet)), + hash_entry_key(x)); + push_stack_direct(sc, OP_EVAL_DONE); + if (is_pair(cdr(body))) + push_stack_no_args(sc, sc->begin_op, cdr(body)); + sc->code = car(body); + eval(sc, OP_EVAL); + if (is_true(sc, sc->value)) { + set_curlet(sc, old_e); + return (x); + } + } + set_curlet(sc, old_e); + return (sc->unentry); +} + +static hash_entry_t *hash_equal(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return ((*(equal_hash_checks[type(key)])) (sc, table, key)); +} + +/* ---------------- hash equivalent? ---------------- */ +static hash_entry_t *hash_equivalent(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + hash_entry_t *x; + s7_int hash, loc; + + if (is_number(key)) { + if (!is_nan_b_7p(sc, key)) + return (hash_number_equivalent(sc, table, key)); + for (x = hash_table_element(table, 0); x; x = hash_entry_next(x)) /* NaN is mapped to 0 */ + if (is_nan_b_7p(sc, hash_entry_key(x))) /* all NaN's are the same to equivalent? */ + return (x); + return (sc->unentry); + } + hash = hash_loc(sc, table, key); + loc = hash & hash_table_mask(table); + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if (hash_entry_key(x) == key) + return (x); + + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if ((hash_entry_raw_hash(x) == hash) && + (s7_is_equivalent(sc, hash_entry_key(x), key))) + return (x); + return (sc->unentry); +} + + + +/* -------------------------------- make-hash-table -------------------------------- */ +s7_pointer s7_make_hash_table(s7_scheme * sc, s7_int size) +{ + s7_pointer table; + block_t *els; + /* size is rounded up to the next power of 2 */ + + if (size < 2) + size = 2; + else if ((size & (size - 1)) != 0) { /* already 2^n ? */ + if ((size & (size + 1)) != 0) { /* already 2^n - 1 ? */ + size--; + size |= (size >> 1); + size |= (size >> 2); + size |= (size >> 4); + size |= (size >> 8); + size |= (size >> 16); + size |= (size >> 32); + } + size++; + } + + els = (block_t *) callocate(sc, size * sizeof(hash_entry_t *)); + new_cell(sc, table, T_HASH_TABLE | T_SAFE_PROCEDURE); + hash_table_mask(table) = size - 1; + hash_table_set_block(table, els); + hash_table_elements(table) = (hash_entry_t **) (block_data(els)); + if (!hash_table_elements(table)) + s7_error(sc, make_symbol(sc, "memory-error"), + set_elist_2(sc, + wrap_string(sc, + "hash-table not allocated! size: ~D bytes", + 40), wrap_integer1(sc, + size * + sizeof + (hash_entry_t + *)))); + hash_table_checker(table) = hash_empty; + hash_table_mapper(table) = default_hash_map; + hash_table_entries(table) = 0; + hash_table_set_procedures(table, sc->nil); + add_hash_table(sc, table); + return (table); +} + +static bool compatible_types(s7_scheme * sc, s7_pointer eq_type, + s7_pointer value_type) +{ + if (eq_type == sc->T) + return (true); + if (eq_type == value_type) + return (true); + if (eq_type == sc->is_number_symbol) /* only = among built-ins, so other cases aren't needed */ + return ((value_type == sc->is_integer_symbol) || + (value_type == sc->is_real_symbol) || + (value_type == sc->is_complex_symbol) || + (value_type == sc->is_rational_symbol)); + return (false); +} + +static s7_pointer g_is_equal(s7_scheme * sc, s7_pointer args); +static s7_pointer g_is_equivalent(s7_scheme * sc, s7_pointer args); +static s7_pointer type_name_string(s7_scheme * sc, s7_pointer arg); + +static s7_pointer g_make_hash_table_1(s7_scheme * sc, s7_pointer args, + s7_pointer caller) +{ +#define H_make_hash_table "(make-hash-table (size 8) eq-func typer) returns a new hash table. eq-func is the function \ +used to check equality of keys; it usually defaults to equal?. typer sets the types of the keys and values that are allowed \ +in the table; it is a cons, defaulting to (cons #t #t) which means any types are allowed.\n" +#define Q_make_hash_table s7_make_signature(sc, 4, sc->is_hash_table_symbol, sc->is_integer_symbol, \ + s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \ + s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol)) + s7_int size = sc->default_hash_table_length; + + if (is_not_null(args)) { + s7_pointer p = car(args); + if (!s7_is_integer(p)) + return (method_or_bust(sc, p, caller, args, T_INTEGER, 1)); + size = s7_integer_checked(sc, p); + if (size <= 0) /* we need s7_int here to catch (make-hash-table most-negative-fixnum) etc */ + return (simple_out_of_range + (sc, caller, p, + wrap_string(sc, "should be a positive integer", 28))); + if ((size > sc->max_vector_length) || (size >= (1LL << 32LL))) + return (simple_out_of_range + (sc, caller, p, its_too_large_string)); + + if (is_not_null(cdr(args))) { + s7_pointer ht, proc, dproc = sc->nil; + + ht = s7_make_hash_table(sc, size); + /* check for typers */ + if (is_pair(cddr(args))) { + s7_pointer typers = caddr(args); + if (is_pair(typers)) { + s7_pointer keyp = car(typers), valp = cdr(typers); + if ((keyp != sc->T) || (valp != sc->T)) { /* one of them is a type checker */ + if (((keyp != sc->T) && (!is_c_function(keyp)) + && (!is_any_closure(keyp))) + || ((valp != sc->T) && (!is_c_function(valp)) + && (!is_any_closure(valp)))) + return (wrong_type_argument_with_type + (sc, caller, 3, typers, + wrap_string(sc, + "(key-type . value-type)", + 23))); + if ((keyp != sc->T) + && (!s7_is_aritable(sc, keyp, 1))) + return (wrong_type_argument_with_type + (sc, caller, 3, keyp, + wrap_string(sc, + "a function of 1 argument", + 24))); + dproc = cons_unchecked(sc, sc->T, sc->T); + hash_table_set_procedures(ht, dproc); + hash_table_set_key_typer(dproc, keyp); + hash_table_set_value_typer(dproc, valp); + if (is_c_function(keyp)) { + if (!c_function_name(keyp)) + return (wrong_type_argument_with_type + (sc, caller, 3, keyp, + wrap_string(sc, + "a named procedure", + 17))); + if (c_function_has_simple_elements(keyp)) + set_has_simple_keys(ht); + if (!c_function_symbol(keyp)) + c_function_symbol(keyp) = + make_symbol(sc, c_function_name(keyp)); + if (symbol_type(c_function_symbol(keyp)) != + T_FREE) + set_has_hash_key_type(ht); + /* c_function_marker is not currently used in this context */ + + /* now a consistency check for eq-func and key type */ + proc = cadr(args); + if (is_c_function(proc)) { + s7_pointer eq_sig; + eq_sig = c_function_signature(proc); + if ((eq_sig) && + (is_pair(eq_sig)) && + (is_pair(cdr(eq_sig))) && + (!compatible_types + (sc, cadr(eq_sig), + c_function_symbol(keyp)))) + return (wrong_type_argument_with_type + (sc, caller, 2, proc, + wrap_string(sc, + "a function that matches the key type function", + 45))); + } + } else + if ((is_any_closure(keyp)) && + (!is_symbol + (find_closure + (sc, keyp, closure_let(keyp))))) + return (wrong_type_argument_with_type + (sc, caller, 3, keyp, + wrap_string(sc, "a named function", + 16))); + if ((valp != sc->T) + && (!s7_is_aritable(sc, valp, 1))) + return (wrong_type_argument_with_type + (sc, caller, 3, valp, + wrap_string(sc, + "a function of 1 argument", + 24))); + if (is_c_function(valp)) { + if (!c_function_name(valp)) + return (wrong_type_argument_with_type + (sc, caller, 3, valp, + wrap_string(sc, + "a named procedure", + 17))); + if (c_function_has_simple_elements(valp)) + set_has_simple_values(ht); + if (!c_function_symbol(valp)) + c_function_symbol(valp) = + make_symbol(sc, c_function_name(valp)); + if (symbol_type(c_function_symbol(valp)) != + T_FREE) + set_has_hash_value_type(ht); + } else + if ((is_any_closure(valp)) && + (!is_symbol + (find_closure + (sc, valp, closure_let(valp))))) + return (wrong_type_argument_with_type + (sc, caller, 3, valp, + wrap_string(sc, "a named function", + 16))); + set_typed_hash_table(ht); + } + } else if (typers != sc->F) + return (wrong_type_argument_with_type + (sc, caller, 3, typers, + wrap_string(sc, "(key-type . value-type)", + 23))); + } + + /* check eq_func */ + proc = cadr(args); + + if (is_c_function(proc)) { + hash_set_chosen(ht); + + if (!s7_is_aritable(sc, proc, 2)) + return (wrong_type_argument_with_type + (sc, caller, 2, proc, an_eq_func_string)); + + if (c_function_call(proc) == g_is_equal) { + hash_table_checker(ht) = hash_equal; + return (ht); + } + if (c_function_call(proc) == g_is_equivalent) { + hash_table_checker(ht) = hash_equivalent; + hash_table_mapper(ht) = equivalent_hash_map; /* needed only by hash_table_equal_1 (checker_locked looks at mapper?!) */ + return (ht); + } + if (c_function_call(proc) == g_is_eq) { + hash_table_checker(ht) = hash_eq; + hash_table_mapper(ht) = eq_hash_map; + return (ht); + } + if (c_function_call(proc) == g_strings_are_equal) { + hash_table_checker(ht) = hash_string; + hash_table_mapper(ht) = string_eq_hash_map; + return (ht); + } +#if (!WITH_PURE_S7) + if (c_function_call(proc) == g_strings_are_ci_equal) { + hash_table_checker(ht) = hash_ci_string; + hash_table_mapper(ht) = string_ci_eq_hash_map; + return (ht); + } + if (c_function_call(proc) == g_chars_are_ci_equal) { + hash_table_checker(ht) = hash_ci_char; + hash_table_mapper(ht) = char_ci_eq_hash_map; + return (ht); + } +#endif + if (c_function_call(proc) == g_chars_are_equal) { + hash_table_checker(ht) = hash_char; + hash_table_mapper(ht) = char_eq_hash_map; + return (ht); + } + if (c_function_call(proc) == g_num_eq) { + if ((is_typed_hash_table(ht)) && + (hash_table_key_typer(ht) == + global_value(sc->is_integer_symbol))) + hash_table_checker(ht) = hash_int; + else + hash_table_checker(ht) = hash_number_num_eq; + return (ht); + } + if (c_function_call(proc) == g_is_eqv) { + hash_table_checker(ht) = hash_eqv; + return (ht); + } + return (s7_error(sc, sc->out_of_range_symbol, + set_elist_2(sc, + wrap_string(sc, + "make-hash-table argument 2, ~S, is not a built-in function it can handle", + 72), proc))); + } + /* proc not c_function */ + else { + if (is_pair(proc)) { + s7_pointer checker = car(proc), mapper = + cdr(proc), sig; + + hash_set_chosen(ht); + if (!((is_any_c_function(checker)) || + (is_any_closure(checker)))) + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, + wrap_string(sc, + "~A: first entry of type info, ~A, is ~A, but should be a function", + 65), + caller, checker, + type_name_string(sc, + checker)))); + if (!((is_any_c_function(mapper)) + || (is_any_closure(mapper)))) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, + wrap_string(sc, + "~A: second entry of type info, ~A, is ~A, but should be a function", + 66), caller, + mapper, type_name_string(sc, + mapper)))); + + if (!(s7_is_aritable(sc, checker, 2))) + return (wrong_type_argument_with_type + (sc, caller, 2, checker, + wrap_string(sc, + "a function of 2 arguments", + 25))); + if (!(s7_is_aritable(sc, mapper, 1))) + return (wrong_type_argument_with_type + (sc, caller, 2, mapper, + wrap_string(sc, + "a function of 1 argument", + 24))); + + if (is_any_c_function(checker)) { + sig = c_function_signature(checker); + if ((sig) && + (is_pair(sig)) && + (car(sig) != sc->is_boolean_symbol)) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "make-hash-table checker function, ~S, should return a boolean value", + 67), + checker)); + hash_table_checker(ht) = hash_c_function; + } else + hash_table_checker(ht) = hash_closure; + + if (is_any_c_function(mapper)) { + sig = c_function_signature(mapper); + if ((sig) && + (is_pair(sig)) && + (car(sig) != sc->is_integer_symbol)) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "make-hash-table mapper function, ~S, should return an integer", + 61), mapper)); + hash_table_mapper(ht) = c_function_hash_map; + } else + hash_table_mapper(ht) = closure_hash_map; + + if (is_null(dproc)) + hash_table_set_procedures(ht, proc); /* only place this is newly set (as opposed to preserved in copy) */ + else { + set_car(dproc, car(proc)); + set_cdr(dproc, cdr(proc)); + } + return (ht); + } + return ((proc == + sc->F) ? ht : wrong_type_argument_with_type(sc, + caller, + 2, + proc, + wrap_string + (sc, + "a cons of two functions", + 23))); + } + } + } + return (s7_make_hash_table(sc, size)); +} + +static s7_pointer g_make_hash_table(s7_scheme * sc, s7_pointer args) +{ + return (g_make_hash_table_1(sc, args, sc->make_hash_table_symbol)); +} + + +/* -------------------------------- make-weak-hash-table -------------------------------- */ +static s7_pointer g_make_weak_hash_table(s7_scheme * sc, s7_pointer args) +{ +#define H_make_weak_hash_table "(make-weak-hash-table (size 8) eq-func typers) returns a new weak hash table" +#define Q_make_weak_hash_table s7_make_signature(sc, 4, sc->is_weak_hash_table_symbol, sc->is_integer_symbol, \ + s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \ + s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol)) + s7_pointer table; + table = g_make_hash_table_1(sc, args, sc->make_weak_hash_table_symbol); + set_weak_hash_table(table); + weak_hash_iters(table) = 0; + return (table); +} + + +/* -------------------------------- weak-hash-table? -------------------------------- */ +static s7_pointer g_is_weak_hash_table(s7_scheme * sc, s7_pointer args) +{ +#define H_is_weak_hash_table "(weak-hash-table? obj) returns #t if obj is a weak hash-table" +#define Q_is_weak_hash_table sc->pl_bt +#define is_weak_hash(p) ((is_hash_table(p)) && (is_weak_hash_table(p))) + check_boolean_method(sc, is_weak_hash, sc->is_weak_hash_table_symbol, + args); +} + +static void init_hash_maps(void) +{ + int32_t i; + for (i = 0; i < NUM_TYPES; i++) { + default_hash_map[i] = hash_map_nil; + string_eq_hash_map[i] = hash_map_nil; + char_eq_hash_map[i] = hash_map_nil; +#if (!WITH_PURE_S7) + string_ci_eq_hash_map[i] = hash_map_nil; + char_ci_eq_hash_map[i] = hash_map_nil; +#endif + closure_hash_map[i] = hash_map_closure; + c_function_hash_map[i] = hash_map_c_function; + eq_hash_map[i] = hash_map_eq; + + equal_hash_checks[i] = hash_equal_any; + default_hash_checks[i] = hash_equal; + } + default_hash_map[T_CHARACTER] = hash_map_char; + default_hash_map[T_SYMBOL] = hash_map_symbol; + default_hash_map[T_SYNTAX] = hash_map_syntax; + default_hash_map[T_STRING] = hash_map_string; + default_hash_map[T_BYTE_VECTOR] = hash_map_byte_vector; + default_hash_map[T_HASH_TABLE] = hash_map_hash_table; + default_hash_map[T_VECTOR] = hash_map_vector; + default_hash_map[T_INT_VECTOR] = hash_map_int_vector; + default_hash_map[T_FLOAT_VECTOR] = hash_map_float_vector; + default_hash_map[T_LET] = hash_map_let; + default_hash_map[T_PAIR] = hash_map_pair; + + default_hash_map[T_INTEGER] = hash_map_int; + default_hash_map[T_RATIO] = hash_map_ratio; + default_hash_map[T_REAL] = hash_map_real; + default_hash_map[T_COMPLEX] = hash_map_complex; +#if WITH_GMP + default_hash_map[T_BIG_INTEGER] = hash_map_big_int; + default_hash_map[T_BIG_RATIO] = hash_map_big_ratio; + default_hash_map[T_BIG_REAL] = hash_map_big_real; + default_hash_map[T_BIG_COMPLEX] = hash_map_big_complex; +#endif + + string_eq_hash_map[T_STRING] = hash_map_string; + string_eq_hash_map[T_BYTE_VECTOR] = hash_map_byte_vector; + char_eq_hash_map[T_CHARACTER] = hash_map_char; +#if (!WITH_PURE_S7) + string_ci_eq_hash_map[T_STRING] = hash_map_ci_string; + char_ci_eq_hash_map[T_CHARACTER] = hash_map_ci_char; +#endif + + for (i = 0; i < NUM_TYPES; i++) + equivalent_hash_map[i] = default_hash_map[i]; + + equal_hash_checks[T_SYNTAX] = hash_equal_syntax; + equal_hash_checks[T_SYMBOL] = hash_equal_eq; + equal_hash_checks[T_CHARACTER] = hash_equal_eq; + equal_hash_checks[T_INTEGER] = hash_equal_integer; + equal_hash_checks[T_RATIO] = hash_equal_ratio; + equal_hash_checks[T_REAL] = hash_equal_real; + equal_hash_checks[T_COMPLEX] = hash_equal_complex; + + default_hash_checks[T_STRING] = hash_string; + default_hash_checks[T_INTEGER] = hash_int; + default_hash_checks[T_REAL] = hash_float; + default_hash_checks[T_SYMBOL] = hash_symbol; + default_hash_checks[T_CHARACTER] = hash_char; +} + +static void resize_hash_table(s7_scheme * sc, s7_pointer table) +{ + s7_int hash_mask, loc, i, old_size, new_size; + hash_entry_t **new_els, **old_els; + block_t *np; + s7_pointer dproc = hash_table_procedures(table); /* new block_t so we need to pass this across */ + s7_int entries = hash_table_entries(table); + + old_size = hash_table_mask(table) + 1; + new_size = old_size * 4; + hash_mask = new_size - 1; + np = (block_t *) callocate(sc, new_size * sizeof(hash_entry_t *)); + new_els = (hash_entry_t **) (block_data(np)); + old_els = hash_table_elements(table); + + for (i = 0; i < old_size; i++) { + hash_entry_t *x, *n; + for (x = old_els[i]; x; x = n) { + n = hash_entry_next(x); + loc = hash_entry_raw_hash(x) & hash_mask; + hash_entry_next(x) = new_els[loc]; + new_els[loc] = x; + } + } + liberate(sc, hash_table_block(table)); + hash_table_set_block(table, np); + hash_table_elements(table) = new_els; + hash_table_mask(table) = hash_mask; /* was new_size - 1 14-Jun-21 */ + hash_table_set_procedures(table, dproc); + hash_table_entries(table) = entries; +} + + +/* -------------------------------- hash-table-ref -------------------------------- */ +s7_pointer s7_hash_table_ref(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return (hash_entry_value + ((*hash_table_checker(table)) (sc, table, key))); +} + +static s7_pointer g_hash_table_ref(s7_scheme * sc, s7_pointer args) +{ +#define H_hash_table_ref "(hash-table-ref table key) returns the value associated with key in the hash table" +#define Q_hash_table_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_hash_table_symbol, sc->T) + + s7_pointer table = car(args), nt; + if (!is_hash_table(table)) + return (method_or_bust + (sc, table, sc->hash_table_ref_symbol, args, T_HASH_TABLE, + 1)); + nt = s7_hash_table_ref(sc, table, cadr(args)); + if (is_null(cddr(args))) /* implicit args */ + return (nt); + if (nt == sc->F) /* need the error here, not in implicit_index because table should be in the error message, not nt */ + return (s7_error + (sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, table, args))); + return (implicit_index(sc, nt, cddr(args))); /* 9-Jan-19 */ +} + +static s7_pointer g_hash_table_ref_2(s7_scheme * sc, s7_pointer args) +{ + s7_pointer table = car(args); + if (!is_hash_table(table)) + return (method_or_bust + (sc, table, sc->hash_table_ref_symbol, args, T_HASH_TABLE, + 1)); + return (hash_entry_value + ((*hash_table_checker(table)) (sc, table, cadr(args)))); +} + +static s7_pointer hash_table_ref_p_pp(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + if (!is_hash_table(table)) + return (method_or_bust + (sc, table, sc->hash_table_ref_symbol, + set_plist_2(sc, table, key), T_HASH_TABLE, 1)); + return (hash_entry_value + ((*hash_table_checker(table)) (sc, table, key))); +} + +static bool op_implicit_hash_table_ref_a(s7_scheme * sc) +{ + s7_pointer s; + s = lookup_checked(sc, car(sc->code)); + if (!is_hash_table(s)) { + sc->last_function = s; + return (false); + } + sc->value = s7_hash_table_ref(sc, s, fx_call(sc, cdr(sc->code))); + return (true); +} + +static s7_pointer hash_table_ref_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + if (args == 2) { + s7_pointer key = caddr(expr); + if ((is_pair(key)) && (car(key) == sc->substring_symbol) + && (is_global(sc->substring_symbol))) + set_c_function(key, sc->substring_uncopied); + return (sc->hash_table_ref_2); + } + return (f); +} + + +/* -------------------------------- hash-table-set! -------------------------------- */ +static s7_pointer remove_from_hash_table(s7_scheme * sc, s7_pointer table, + s7_pointer key, hash_entry_t * p) +{ + hash_entry_t *x; + s7_int hash_mask, loc; + + if (p == sc->unentry) + return (sc->F); + hash_mask = hash_table_mask(table); + loc = hash_entry_raw_hash(p) & hash_mask; + x = hash_table_element(table, loc); + if (x == p) + hash_table_element(table, loc) = hash_entry_next(x); + else { + hash_entry_t *y; + for (y = x, x = hash_entry_next(x); x; + y = x, x = hash_entry_next(x)) + if (x == p) { + hash_entry_next(y) = hash_entry_next(x); + break; + } + } + hash_table_entries(table)--; + if ((hash_table_entries(table) == 0) && + (!hash_table_checker_locked(table))) { + hash_table_checker(table) = hash_empty; + hash_clear_chosen(table); + } + liberate_block(sc, x); + return (sc->F); +} + +static void cull_weak_hash_table(s7_scheme * sc, s7_pointer table) +{ + if (hash_table_entries(table) > 0) { + s7_int i, len = hash_table_mask(table) + 1; + hash_entry_t **entries = hash_table_elements(table); + for (i = 0; i < len; i++) { + hash_entry_t *xp, *nxp, *lxp = entries[i]; + for (xp = entries[i]; xp; xp = nxp) { + nxp = hash_entry_next(xp); + if (is_free_and_clear(hash_entry_key(xp))) { + if (xp == entries[i]) { + entries[i] = nxp; + lxp = nxp; + } else + hash_entry_next(lxp) = nxp; + liberate_block(sc, xp); + hash_table_entries(table)--; + if (hash_table_entries(table) == 0) { + if (!hash_table_checker_locked(table)) { + hash_table_checker(table) = hash_empty; + hash_clear_chosen(table); + } + return; + } + } else + lxp = xp; + } + } + } +} + +static void hash_table_set_checker(s7_pointer table, uint8_t typ) +{ + if (hash_table_checker(table) != default_hash_checks[typ]) { + if (hash_table_checker(table) == hash_empty) + hash_table_checker(table) = default_hash_checks[typ]; + else { + hash_table_checker(table) = hash_equal; + hash_set_chosen(table); + } + } +} + +static s7_pointer hash_table_typer_symbol(s7_scheme * sc, s7_pointer typer) +{ + if (typer == sc->T) + return (sc->T); + return ((is_c_function(typer)) ? c_function_symbol(typer) : + find_closure(sc, typer, closure_let(typer))); +} + +static const char *hash_table_typer_name(s7_scheme * sc, s7_pointer typer) +{ + return ((is_c_function(typer)) ? c_function_name(typer) : + symbol_name(find_closure(sc, typer, closure_let(typer)))); +} + +static void check_hash_types(s7_scheme * sc, s7_pointer table, + s7_pointer key, s7_pointer value) +{ + if (has_hash_key_type(table)) { /* symbol_type and c_function_symbol exist and symbol_type is not T_FREE */ + if ((uint8_t) + symbol_type(c_function_symbol(hash_table_key_typer(table))) != + type(key)) + s7_wrong_type_arg_error(sc, "hash-table-set! key", 2, key, + make_type_name(sc, + hash_table_typer_name + (sc, + hash_table_key_typer + (table)), + INDEFINITE_ARTICLE)); + } else { + s7_pointer kf = hash_table_key_typer(table); + if (kf != sc->T) { + s7_pointer type_ok; + if (is_c_function(kf)) + type_ok = c_function_call(kf) (sc, set_plist_1(sc, key)); + else + type_ok = s7_apply_function(sc, kf, set_plist_1(sc, key)); + if (type_ok == sc->F) + s7_wrong_type_arg_error(sc, "hash-table-set! key", 2, key, + make_type_name(sc, + hash_table_typer_name + (sc, + hash_table_key_typer + (table)), + INDEFINITE_ARTICLE)); + } + } + if (has_hash_value_type(table)) { + if ((uint8_t) + symbol_type(c_function_symbol(hash_table_value_typer(table))) + != type(value)) + s7_wrong_type_arg_error(sc, "hash-table-set! value", 3, value, + make_type_name(sc, + hash_table_typer_name + (sc, + hash_table_value_typer + (table)), + INDEFINITE_ARTICLE)); + } else { + s7_pointer vf = hash_table_value_typer(table); + if (vf != sc->T) { + s7_pointer type_ok; + if (is_c_function(vf)) + type_ok = c_function_call(vf) (sc, set_plist_1(sc, value)); + else + type_ok = + s7_apply_function(sc, vf, set_plist_1(sc, value)); + if (type_ok == sc->F) + s7_wrong_type_arg_error(sc, "hash-table-set! value", 3, + value, make_type_name(sc, + hash_table_typer_name + (sc, + hash_table_value_typer + (table)), + INDEFINITE_ARTICLE)); + } + } +} + +s7_pointer s7_hash_table_set(s7_scheme * sc, s7_pointer table, + s7_pointer key, s7_pointer value) +{ + s7_int hash_mask, loc; + hash_entry_t *p, *x; + + if (value == sc->F) + return (remove_from_hash_table + (sc, table, key, + (*hash_table_checker(table)) (sc, table, key))); + + if ((is_typed_hash_table(table)) && (sc->safety >= NO_SAFETY)) + check_hash_types(sc, table, key, value); + + x = (*hash_table_checker(table)) (sc, table, key); + if (x != sc->unentry) { + hash_entry_set_value(x, T_Pos(value)); + return (value); + } + /* hash_entry_raw_hash(x) can save the hash_loc from the lookup operations, but at some added complexity in + * all the preceding code. This saves about 5% compute time best case in this function. + */ + + if (!hash_chosen(table)) + hash_table_set_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_checker etc */ + else + /* check type -- raise error if incompatible with eq func set by make-hash-table */ + if (hash_table_checker(table) == hash_number_num_eq) { + if (!is_number(key)) + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, + wrap_string(sc, + "hash-table-set! key ~S, is ~A, but the hash-table's key function is =", + 69), key, + type_name_string(sc, key)))); + } else if (hash_table_checker(table) == hash_eq) { + if (is_number(key)) /* (((type(key) >= T_INTEGER) && (type(key) < T_C_MACRO)) || (type(key) == T_PAIR)), but we might want eq? */ + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, + wrap_string(sc, + "hash-table-set! key ~S, is ~A, but the hash-table's key function is eq?", + 71), key, + type_name_string(sc, key)))); + } else +#if WITH_PURE_S7 + if (((hash_table_checker(table) == hash_string) + && (!is_string(key))) + || ((hash_table_checker(table) == hash_char) + && (!is_character(key)))) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, + wrap_string(sc, + "hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A", + 70), key, type_name_string(sc, + key), + (hash_table_checker(table) == + hash_string) ? sc-> + string_eq_symbol : sc->char_eq_symbol))); +#else + if ((((hash_table_checker(table) == hash_string) + || (hash_table_checker(table) == hash_ci_string)) + && (!is_string(key))) + || (((hash_table_checker(table) == hash_char) + || (hash_table_checker(table) == hash_ci_char)) + && (!is_character(key)))) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, + wrap_string(sc, + "hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A", + 70), key, type_name_string(sc, + key), + (hash_table_checker(table) == + hash_string) ? sc->string_eq_symbol + : ((hash_table_checker(table) == + hash_ci_string) ? sc->string_ci_eq_symbol + : ((hash_table_checker(table) == + hash_char) ? sc-> + char_eq_symbol : + sc->char_ci_eq_symbol))))); +#endif + p = mallocate_block(sc); + hash_entry_key(p) = key; + hash_entry_set_value(p, T_Pos(value)); + hash_entry_set_raw_hash(p, hash_loc(sc, table, key)); + hash_mask = hash_table_mask(table); + loc = hash_entry_raw_hash(p) & hash_mask; + hash_entry_next(p) = hash_table_element(table, loc); + hash_table_element(table, loc) = p; + hash_table_entries(table)++; + if (hash_table_entries(table) > hash_mask) + resize_hash_table(sc, table); + return (value); +} + +static s7_pointer g_hash_table_set(s7_scheme * sc, s7_pointer args) +{ +#define H_hash_table_set "(hash-table-set! table key value) sets the value associated with key in the hash table to value" +#define Q_hash_table_set s7_make_signature(sc, 4, sc->T, sc->is_hash_table_symbol, sc->T, sc->T) + + s7_pointer table = car(args); + if (!is_mutable_hash_table(table)) + return (mutable_method_or_bust + (sc, table, sc->hash_table_set_symbol, args, T_HASH_TABLE, + 1)); + return (s7_hash_table_set(sc, table, cadr(args), caddr(args))); +} + +static s7_pointer hash_table_set_p_ppp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2, s7_pointer p3) +{ + if (!is_mutable_hash_table(p1)) /* is_hash_table(p1) is here */ + return (mutable_method_or_bust_ppp + (sc, p1, sc->hash_table_set_symbol, p1, p2, p3, + T_HASH_TABLE, 1)); + return (s7_hash_table_set(sc, p1, p2, p3)); +} + +static s7_pointer hash_table_set_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + if ((args == 3) && (optimize_op(expr) == HOP_SSA_DIRECT)) { /* a tedious experiment... */ + /* this could be HOP_FX_C_SSA if no SSA_DIRECT */ + s7_pointer val = cadddr(expr); + if ((is_pair(val)) && (car(val) == sc->add_symbol) + && (is_proper_list_3(sc, val)) && ((cadr(val) == int_one) + || (caddr(val) == int_one))) { + s7_pointer add1; + add1 = (cadr(val) == int_one) ? caddr(val) : cadr(val); + if ((is_pair(add1)) && (car(add1) == sc->or_symbol) + && (is_proper_list_3(sc, add1)) + && (caddr(add1) == int_zero)) { + s7_pointer or1 = cadr(add1); + if ((is_pair(or1)) + && (car(or1) == sc->hash_table_ref_symbol) + && (is_proper_list_3(sc, or1)) + && (cadr(or1) == cadr(expr)) + && (caddr(or1) == caddr(expr))) + /* (hash-table-set! counts p (+ (or (hash-table-ref counts p) 0) 1)) -- ssa_direct and hop_safe_c_ss */ + set_optimize_op(expr, HOP_HASH_TABLE_INCREMENT); + } + } + } + return (f); +} + + +/* -------------------------------- hash-table -------------------------------- */ + +static inline s7_pointer hash_table_add(s7_scheme * sc, s7_pointer table, + s7_pointer key, s7_pointer value) +{ + s7_int hash, hash_mask, loc; + hash_entry_t *x, *p; + + if (!hash_chosen(table)) + hash_table_set_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_checker etc */ + + hash_mask = hash_table_mask(table); + hash = hash_loc(sc, table, key); + loc = hash & hash_mask; + + for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if ((hash_entry_raw_hash(x) == hash) && + (s7_is_equal(sc, hash_entry_key(x), key))) + return (value); + + p = mallocate_block(sc); + hash_entry_key(p) = key; + hash_entry_set_value(p, T_Pos(value)); + hash_entry_set_raw_hash(p, hash); + hash_entry_next(p) = hash_table_element(table, loc); + hash_table_element(table, loc) = p; + + hash_table_entries(table)++; + if (hash_table_entries(table) > hash_mask) + resize_hash_table(sc, table); + return (value); +} + +static s7_pointer g_hash_table(s7_scheme * sc, s7_pointer args) +{ +#define H_hash_table "(hash-table ...) returns a hash-table containing the symbol/value pairs passed as its arguments. \ +That is, (hash-table 'a 1 'b 2) returns a new hash-table with the two key/value pairs preinstalled." +#define Q_hash_table s7_make_circular_signature(sc, 1, 2, sc->is_hash_table_symbol, sc->T) + + s7_int len; + s7_pointer ht; + + len = proper_list_length(args); + if (len & 1) + return (s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_2(sc, + wrap_string(sc, + "hash-table got an odd number of arguments: ~S", + 45), args))); + len /= 2; + ht = s7_make_hash_table(sc, + (len > + sc-> + default_hash_table_length) ? len : + sc->default_hash_table_length); + if (len > 0) { + s7_pointer x, y; + for (x = args, y = cdr(args); is_pair(x); + x = cddr(x), y = unchecked_cdr(cdr(y))) + if (car(y) != sc->F) + hash_table_add(sc, ht, car(x), car(y)); + } + return (ht); +} + +static s7_pointer g_hash_table_2(s7_scheme * sc, s7_pointer args) +{ + s7_pointer ht; + ht = s7_make_hash_table(sc, sc->default_hash_table_length); + if (cadr(args) != sc->F) + hash_table_add(sc, ht, car(args), cadr(args)); + return (ht); +} + + +/* -------------------------------- weak-hash-table -------------------------------- */ +static s7_pointer g_weak_hash_table(s7_scheme * sc, s7_pointer args) +{ +#define H_weak_hash_table "(weak-hash-table ...) returns a weak-hash-table containing the symbol/value pairs passed as its arguments. \ +That is, (weak-hash-table 'a 1 'b 2) returns a new weak-hash-table with the two key/value pairs preinstalled." +#define Q_weak_hash_table Q_hash_table + + s7_pointer table; + table = g_hash_table(sc, args); + set_weak_hash_table(table); + weak_hash_iters(table) = 0; + return (table); +} + +static s7_pointer hash_table_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + return ((args == 2) ? sc->hash_table_2 : f); +} + +static void check_old_hash(s7_scheme * sc, s7_pointer old_hash, + s7_pointer new_hash, s7_int start, s7_int end) +{ + s7_int i, count = 0, old_len = hash_table_mask(old_hash) + 1; + hash_entry_t **old_lists = hash_table_elements(old_hash); + hash_entry_t *x; + for (i = 0; i < old_len; i++) + for (x = old_lists[i]; x; x = hash_entry_next(x)) { + if (count >= end) + return; + if (count >= start) + check_hash_types(sc, new_hash, hash_entry_key(x), + hash_entry_value(x)); + } +} + +static s7_pointer hash_table_copy(s7_scheme * sc, s7_pointer old_hash, + s7_pointer new_hash, s7_int start, + s7_int end) +{ + s7_int i, old_len, new_mask, count = 0; + hash_entry_t **old_lists, **new_lists; + hash_entry_t *x, *p; + + if ((is_typed_hash_table(new_hash)) && + (sc->safety >= NO_SAFETY) && + ((!is_typed_hash_table(old_hash)) || + (hash_table_key_typer(old_hash) != hash_table_key_typer(new_hash)) + || (hash_table_value_typer(old_hash) != + hash_table_value_typer(new_hash)))) + check_old_hash(sc, old_hash, new_hash, start, end); + + old_len = hash_table_mask(old_hash) + 1; + new_mask = hash_table_mask(new_hash); + old_lists = hash_table_elements(old_hash); + new_lists = hash_table_elements(new_hash); + + if (hash_table_entries(new_hash) == 0) { + hash_table_checker(new_hash) = hash_table_checker(old_hash); + if (hash_chosen(old_hash)) + hash_set_chosen(new_hash); + if ((start == 0) && (end >= hash_table_entries(old_hash))) { + for (i = 0; i < old_len; i++) + for (x = old_lists[i]; x; x = hash_entry_next(x)) { + s7_int loc; + loc = hash_entry_raw_hash(x) & new_mask; + p = make_hash_entry(sc, hash_entry_key(x), + hash_entry_value(x), + hash_entry_raw_hash(x)); + hash_entry_next(p) = new_lists[loc]; + new_lists[loc] = p; + } + hash_table_entries(new_hash) = hash_table_entries(old_hash); + return (new_hash); + } + for (i = 0; i < old_len; i++) + for (x = old_lists[i]; x; x = hash_entry_next(x)) { + if (count >= end) { + hash_table_entries(new_hash) = end - start; + return (new_hash); + } + if (count >= start) { + s7_int loc; + loc = hash_entry_raw_hash(x) & new_mask; + p = make_hash_entry(sc, hash_entry_key(x), + hash_entry_value(x), + hash_entry_raw_hash(x)); + hash_entry_next(p) = new_lists[loc]; + new_lists[loc] = p; + } + count++; + } + hash_table_entries(new_hash) = count - start; + return (new_hash); + } + + /* this can't be optimized much because we have to look for key matches (we're copying old_hash into the existing, non-empty new_hash) */ + for (i = 0; i < old_len; i++) + for (x = old_lists[i]; x; x = hash_entry_next(x)) { + if (count >= end) + return (new_hash); + if (count >= start) { + hash_entry_t *y; + y = (*hash_table_checker(new_hash)) (sc, new_hash, + hash_entry_key(x)); + if (y != sc->unentry) + hash_entry_set_value(y, hash_entry_value(x)); + else { + s7_int loc; + loc = hash_entry_raw_hash(x) & new_mask; + p = make_hash_entry(sc, hash_entry_key(x), + hash_entry_value(x), + hash_entry_raw_hash(x)); + hash_entry_next(p) = new_lists[loc]; + new_lists[loc] = p; + hash_table_entries(new_hash)++; + if (!hash_chosen(new_hash)) + hash_table_set_checker(new_hash, + type(hash_entry_key(x))); + } + } + count++; + } + return (new_hash); +} + +static s7_pointer hash_table_fill(s7_scheme * sc, s7_pointer args) +{ + s7_pointer val, table = car(args); + if (is_immutable(table)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, sc->fill_symbol, + table))); + + val = cadr(args); + if (hash_table_entries(table) > 0) { + s7_int len; + hash_entry_t **entries = hash_table_elements(table); + len = hash_table_mask(table) + 1; /* minimum len is 2 (see s7_make_hash_table) */ + if (val == sc->F) { /* hash-table-ref returns #f if it can't find a key, so val == #f here means empty the table */ + hash_entry_t **hp = entries, **hn; + hash_entry_t *p; + hn = (hash_entry_t **) (hp + len); + for (; hp < hn; hp++) { + if (*hp) { + p = *hp; + while (hash_entry_next(p)) + p = hash_entry_next(p); + hash_entry_next(p) = sc->block_lists[BLOCK_LIST]; + sc->block_lists[BLOCK_LIST] = *hp; + } + hp++; + if (*hp) { + p = *hp; + while (hash_entry_next(p)) + p = hash_entry_next(p); + hash_entry_next(p) = sc->block_lists[BLOCK_LIST]; + sc->block_lists[BLOCK_LIST] = *hp; + } + } + if (len >= 8) + memclr64(entries, len * sizeof(hash_entry_t *)); + else + memclr(entries, len * sizeof(hash_entry_t *)); + if (!hash_table_checker_locked(table)) { + hash_table_checker(table) = hash_empty; + hash_clear_chosen(table); + } + hash_table_entries(table) = 0; + } else { + s7_int i; + hash_entry_t *x; + + if ((is_typed_hash_table(table)) && + (((is_c_function(hash_table_value_typer(table))) && + (c_function_call(hash_table_value_typer(table)) + (sc, set_plist_1(sc, val)) == sc->F)) + || ((is_any_closure(hash_table_value_typer(table))) + && + (s7_apply_function + (sc, hash_table_value_typer(table), + set_plist_1(sc, val)) == sc->F)))) + s7_wrong_type_arg_error(sc, "fill!", 2, val, + make_type_name(sc, + hash_table_typer_name + (sc, + hash_table_value_typer + (table)), + INDEFINITE_ARTICLE)); + for (i = 0; i < len; i++) + for (x = entries[i]; x; x = hash_entry_next(x)) + hash_entry_set_value(x, val); + /* keys haven't changed, so no need to mess with hash_table_checker */ + } + } + return (val); +} + +static s7_pointer hash_table_reverse(s7_scheme * sc, s7_pointer old_hash) +{ + s7_int i, len = hash_table_mask(old_hash) + 1; + s7_pointer new_hash; + hash_entry_t **old_lists = hash_table_elements(old_hash); + s7_int gc_loc; + + new_hash = s7_make_hash_table(sc, len); + gc_loc = gc_protect_1(sc, new_hash); + + /* I don't think the original hash functions can make any sense in general, so ignore them */ + for (i = 0; i < len; i++) { + hash_entry_t *x; + for (x = old_lists[i]; x; x = hash_entry_next(x)) + s7_hash_table_set(sc, new_hash, hash_entry_value(x), + hash_entry_key(x)); + } + s7_gc_unprotect_at(sc, gc_loc); + return (new_hash); +} + + +/* -------------------------------- functions -------------------------------- */ + +bool s7_is_function(s7_pointer p) +{ + return (is_c_function(p)); +} + +static s7_pointer fallback_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + return (f); +} + +static void s7_function_set_class(s7_scheme * sc, s7_pointer f, + s7_pointer base_f) +{ + c_function_class(f) = c_function_class(base_f); + c_function_set_base(f, base_f); +} + +static s7_pointer make_function(s7_scheme * sc, const char *name, + s7_function f, s7_int req, s7_int opt, + bool rst, const char *doc, s7_pointer x, + c_proc_t * ptr) +{ + uint32_t ftype = T_C_FUNCTION; + if (req == 0) { + if (rst) + ftype = T_C_ANY_ARGS_FUNCTION; + else if (opt != 0) + ftype = T_C_OPT_ARGS_FUNCTION; + } else if (rst) + ftype = T_C_RST_ARGS_FUNCTION; + + set_full_type(x, ftype); + + c_function_data(x) = ptr; + c_function_call(x) = f; /* f is T_App but needs cast */ + c_function_set_base(x, x); + c_function_set_setter(x, sc->F); + c_function_name(x) = name; /* (procedure-name proc) => (format #f "~A" proc) */ + c_function_name_length(x) = safe_strlen(name); + c_function_documentation(x) = + (doc) ? make_permanent_c_string(sc, doc) : NULL; + c_function_signature(x) = sc->F; + + c_function_required_args(x) = req; + c_function_optional_args(x) = opt; /* T_C_FUNCTION_STAR type may be set later, so T_Fst not usable here */ + c_function_all_args(x) = (rst) ? MAX_ARITY : req + opt; + + c_function_class(x) = ++sc->f_class; + c_function_chooser(x) = fallback_chooser; + c_function_opt_data(x) = NULL; + c_function_marker(x) = NULL; + c_function_symbol(x) = NULL; + return (x); +} + +static s7_pointer s7_lambda(s7_scheme * sc, s7_function f, + s7_int required_args, s7_int optional_args, + bool rest_arg) +{ + /* same as s7_make_function but the new function is not global and permanent; it can be GC'd */ + s7_pointer fnc; + block_t *block; + new_cell(sc, fnc, T_PAIR); /* just a place-holder, make_function will set its type and return it */ + block = mallocate(sc, sizeof(c_proc_t)); + fnc = + make_function(sc, "#", f, required_args, optional_args, + rest_arg, NULL, fnc, (c_proc_t *) block_data(block)); + c_function_block(fnc) = block; + add_lambda(sc, fnc); + return (fnc); +} + +static c_proc_t *alloc_permanent_function(s7_scheme * sc) +{ +#define ALLOC_FUNCTION_SIZE 128 + if (sc->alloc_function_k == ALLOC_FUNCTION_SIZE) { + sc->alloc_function_cells = + (c_proc_t *) malloc(ALLOC_FUNCTION_SIZE * sizeof(c_proc_t)); + add_saved_pointer(sc, sc->alloc_function_cells); + sc->alloc_function_k = 0; + } + return (&(sc->alloc_function_cells[sc->alloc_function_k++])); +} + +s7_pointer s7_make_function(s7_scheme * sc, const char *name, + s7_function f, s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc) +{ + s7_pointer x; + x = alloc_pointer(sc); + x = make_function(sc, name, f, required_args, optional_args, rest_arg, + doc, x, alloc_permanent_function(sc)); + unheap(sc, x); + return (x); +} + +s7_pointer s7_make_safe_function(s7_scheme * sc, const char *name, + s7_function f, s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc) +{ + s7_pointer p; + p = s7_make_function(sc, name, f, required_args, optional_args, + rest_arg, doc); + set_type_bit(p, T_SAFE_PROCEDURE); + return (p); +} + +s7_pointer s7_make_typed_function(s7_scheme * sc, const char *name, + s7_function f, s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc, s7_pointer signature) +{ + s7_pointer func; + func = + s7_make_function(sc, name, f, required_args, optional_args, + rest_arg, doc); + set_type_bit(func, T_SAFE_PROCEDURE); + if (signature) + c_function_signature(func) = signature; + return (func); +} + + +/* -------------------------------- procedure? -------------------------------- */ +bool s7_is_procedure(s7_pointer x) +{ + return (is_procedure(x)); +} + +static s7_pointer g_is_procedure(s7_scheme * sc, s7_pointer args) +{ +#define H_is_procedure "(procedure? obj) returns #t if obj is a procedure" +#define Q_is_procedure sc->pl_bt + return (make_boolean(sc, is_procedure(car(args)))); +} + + +static void s7_function_set_setter(s7_scheme * sc, const char *getter, + const char *setter) +{ + /* this is internal, used only with c_function setters, so we don't need to worry about the GC mark choice */ + c_function_set_setter(s7_name_to_value(sc, getter), + s7_name_to_value(sc, setter)); +} + +s7_pointer s7_closure_body(s7_scheme * sc, s7_pointer p) +{ + return ((has_closure_let(p)) ? closure_body(p) : sc->nil); +} + +s7_pointer s7_closure_let(s7_scheme * sc, s7_pointer p) +{ + return ((has_closure_let(p)) ? closure_let(p) : sc->nil); +} + +s7_pointer s7_closure_args(s7_scheme * sc, s7_pointer p) +{ + return ((has_closure_let(p)) ? closure_args(p) : sc->nil); +} + + +/* -------------------------------- procedure-source -------------------------------- */ +static s7_pointer procedure_type_to_symbol(s7_scheme * sc, int32_t type) +{ + switch (type) { + case T_CLOSURE: + return (sc->lambda_symbol); + case T_CLOSURE_STAR: + return (sc->lambda_star_symbol); + case T_MACRO: + return (sc->macro_symbol); + case T_MACRO_STAR: + return (sc->macro_star_symbol); + case T_BACRO: + return (sc->bacro_symbol); + case T_BACRO_STAR: + return (sc->bacro_star_symbol); + default: + if (S7_DEBUGGING) + fprintf(stderr, "%s[%d] wants %d symbol\n", __func__, __LINE__, + type); + } + return (sc->lambda_symbol); +} + +static s7_pointer g_procedure_source(s7_scheme * sc, s7_pointer args) +{ +#define H_procedure_source "(procedure-source func) tries to return the definition of func" +#define Q_procedure_source s7_make_signature(sc, 2, sc->is_list_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) + /* make it look like a scheme-level lambda */ + s7_pointer p = car(args); + + if (is_symbol(p)) { + if ((symbol_ctr(p) == 0) + || ((p = s7_symbol_value(sc, p)) == sc->undefined)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "procedure-source arg, '~S, is unbound", + 37), car(args)))); + } + if ((is_c_function(p)) || (is_c_macro(p))) + return (sc->nil); + + check_method(sc, p, sc->procedure_source_symbol, set_plist_1(sc, p)); + if (has_closure_let(p)) { + s7_pointer body = closure_body(p); + /* perhaps if this function has been removed from the heap, it would be better to use copy_body (as in s7_copy)? */ + if (is_safe_closure_body(body)) + clear_safe_closure_body(body); + return (append_in_place + (sc, + list_2(sc, procedure_type_to_symbol(sc, type(p)), + closure_args(p)), body)); + } + + if (!is_procedure(p)) + return (simple_wrong_type_argument_with_type + (sc, sc->procedure_source_symbol, p, + a_procedure_or_a_macro_string)); + return (sc->nil); +} + + +/* -------------------------------- *current-function* -------------------------------- */ + +static s7_pointer g_function(s7_scheme * sc, s7_pointer args) +{ +#define H_function "(*function* e) returns the current function in e" +#define Q_function s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol) + + s7_pointer e, sym, fname, fval; + if (is_null(args)) { + for (e = sc->curlet; is_let(e); e = let_outlet(e)) + if ((is_funclet(e)) || (is_maclet(e))) + break; + } else { + e = car(args); + if (!is_let(e)) + return (simple_wrong_type_argument + (sc, sc->_function__symbol, e, T_LET)); + if (e == sc->rootlet) + return (sc->F); + if (!((is_funclet(e)) || (is_maclet(e)))) + e = let_outlet(e); + } + if ((e == sc->rootlet) || (!is_let(e))) + return (sc->F); + if (!((is_funclet(e)) || (is_maclet(e)))) + return (sc->F); + + /* for C-defined things like hooks and dilambda, let_file and let_line are 0 */ + if ((is_null(args)) || (is_null(cdr(args)))) { + if ((has_let_file(e)) && + (let_file(e) <= (s7_int) sc->file_names_top) && + (let_line(e) > 0)) + return (list_3 + (sc, funclet_function(e), sc->file_names[let_file(e)], + make_integer(sc, let_line(e)))); + return (funclet_function(e)); + } + + sym = cadr(args); + if (!is_symbol(sym)) + return (simple_wrong_type_argument + (sc, sc->_function__symbol, sym, T_SYMBOL)); + if (is_keyword(sym)) + sym = keyword_symbol(sym); + fname = funclet_function(e); + fval = s7_symbol_local_value(sc, fname, e); + + if (sym == sc->name_symbol) + return (fname); + if (sym == sc->signature_symbol) + return (s7_signature(sc, fval)); + if (sym == sc->arity_symbol) + return (s7_arity(sc, fval)); + if (sym == sc->documentation_symbol) + return (s7_make_string(sc, s7_documentation(sc, fval))); + if (sym == sc->value_symbol) + return (fval); + if ((sym == sc->line_symbol) && (has_let_file(e))) + return (make_integer(sc, let_line(e))); + if ((sym == sc->file_symbol) && (has_let_file(e))) + return (sc->file_names[let_file(e)]); + if (sym == make_symbol(sc, "funclet")) + return (e); + if (sym == make_symbol(sc, "source")) + return (g_procedure_source(sc, set_plist_1(sc, fval))); + if ((sym == make_symbol(sc, "arglist")) + && ((is_any_closure(fval)) || (is_any_macro(fval)))) + return (closure_args(fval)); + return (sc->F); +} + + +/* -------------------------------- funclet -------------------------------- */ +s7_pointer s7_funclet(s7_scheme * sc, s7_pointer p) +{ + return ((has_closure_let(p)) ? closure_let(p) : sc->rootlet); +} + +static s7_pointer g_funclet(s7_scheme * sc, s7_pointer args) +{ +#define H_funclet "(funclet func) tries to return a function's definition environment" +#define Q_funclet s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), \ + s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_macro_symbol, sc->is_symbol_symbol)) + s7_pointer p = car(args), e; + if (is_symbol(p)) { + if ((symbol_ctr(p) == 0) + || ((p = s7_symbol_value(sc, p)) == sc->undefined)) + return (s7_error(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "funclet argument, '~S, is unbound", 33), car(args)))); /* not p here */ + } + check_method(sc, p, sc->funclet_symbol, args); + + if (!((is_any_procedure(p)) || (is_c_object(p)))) + return (simple_wrong_type_argument_with_type + (sc, sc->funclet_symbol, p, + a_procedure_or_a_macro_string)); + e = find_let(sc, p); + if ((is_null(e)) && (!is_c_object(p))) /* why this complication? */ + return (sc->rootlet); + return (e); +} + +s7_pointer s7_define_function(s7_scheme * sc, const char *name, + s7_function fnc, s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc) +{ + s7_pointer func, sym; + func = + s7_make_function(sc, name, fnc, required_args, optional_args, + rest_arg, doc); + sym = make_symbol(sc, name); + s7_define(sc, sc->nil, sym, func); + return (sym); +} + +s7_pointer s7_define_safe_function(s7_scheme * sc, const char *name, + s7_function fnc, s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc) +{ + /* returns (string->symbol name), not the c_proc_t func */ + s7_pointer func, sym; + func = + s7_make_safe_function(sc, name, fnc, required_args, optional_args, + rest_arg, doc); + sym = make_symbol(sc, name); + s7_define(sc, sc->nil, sym, func); + return (sym); +} + +s7_pointer s7_define_typed_function(s7_scheme * sc, const char *name, + s7_function fnc, s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc, s7_pointer signature) +{ + /* returns (string->symbol name), not the c_proc_t func */ + s7_pointer func, sym; + func = + s7_make_typed_function(sc, name, fnc, required_args, optional_args, + rest_arg, doc, signature); + sym = make_symbol(sc, name); + s7_define(sc, sc->nil, sym, func); + c_function_set_marker(func, NULL); + return (sym); +} + +static s7_pointer define_bool_function(s7_scheme * sc, const char *name, + s7_function fnc, + s7_int optional_args, + const char *doc, + s7_pointer signature, + int32_t sym_to_type, + void (*marker)(s7_pointer p, + s7_int top), + bool simple, + s7_function bool_setter) +{ + s7_pointer func, sym, bfunc; + func = + s7_make_typed_function(sc, name, fnc, 1, optional_args, false, doc, + signature); + sym = make_symbol(sc, name); + s7_define(sc, sc->nil, sym, func); + if (sym_to_type != T_FREE) + symbol_set_type(sym, sym_to_type); + c_function_symbol(func) = sym; + c_function_set_marker(func, marker); + if (simple) + c_function_set_has_simple_elements(func); + c_function_set_bool_setter(func, bfunc = + s7_make_function(sc, name, bool_setter, 2, + 0, false, NULL)); + c_function_set_has_bool_setter(func); + c_function_set_setter(bfunc, func); + set_is_bool_function(bfunc); + return (sym); +} + +s7_pointer s7_define_unsafe_typed_function(s7_scheme * sc, + const char *name, + s7_function fnc, + s7_int required_args, + s7_int optional_args, + bool rest_arg, const char *doc, + s7_pointer signature) +{ + /* returns (string->symbol name), not the c_proc_t func */ + s7_pointer func, sym; + func = + s7_make_function(sc, name, fnc, required_args, optional_args, + rest_arg, doc); + if (signature) + c_function_signature(func) = signature; + sym = make_symbol(sc, name); + s7_define(sc, sc->nil, sym, func); + return (sym); +} + +s7_pointer s7_define_semisafe_typed_function(s7_scheme * sc, + const char *name, + s7_function fnc, + s7_int required_args, + s7_int optional_args, + bool rest_arg, + const char *doc, + s7_pointer signature) +{ + s7_pointer func, sym; + func = + s7_make_function(sc, name, fnc, required_args, optional_args, + rest_arg, doc); + if (signature) + c_function_signature(func) = signature; + set_is_semisafe(func); + sym = make_symbol(sc, name); + s7_define(sc, sc->nil, sym, func); + return (sym); +} + +s7_pointer s7_make_function_star(s7_scheme * sc, const char *name, + s7_function fnc, const char *arglist, + const char *doc) +{ + s7_pointer func, local_args; + char *internal_arglist; + s7_int len, n_args; + s7_int gc_loc; + s7_pointer *names, *defaults; + block_t *b; + + len = safe_strlen(arglist); + b = mallocate(sc, len + 4); + internal_arglist = (char *) block_data(b); + internal_arglist[0] = '\''; + internal_arglist[1] = '('; + memcpy((void *) (internal_arglist + 2), (void *) arglist, len); + internal_arglist[len + 2] = ')'; + internal_arglist[len + 3] = '\0'; + /* catstrs_direct(internal_arglist, "'(", arglist, ")", (const char *)NULL); */ + local_args = s7_eval_c_string(sc, internal_arglist); + gc_loc = gc_protect_1(sc, local_args); + liberate(sc, b); + n_args = s7_list_length(sc, local_args); + if (n_args < 0) { + s7_warn(sc, 256, + "%s rest argument is not supported in C-side define*: %s\n", + name, arglist); + n_args = -n_args; + } + func = s7_make_function(sc, name, fnc, 0, n_args, false, doc); + + if (n_args > 0) { + s7_pointer p; + s7_int i; + set_full_type(func, T_C_FUNCTION_STAR | T_UNHEAP); /* unheap from s7_make_function */ + c_function_call_args(func) = NULL; + + names = (s7_pointer *) Malloc(n_args * sizeof(s7_pointer)); + add_saved_pointer(sc, names); + c_function_arg_names(func) = names; + + defaults = (s7_pointer *) Malloc(n_args * sizeof(s7_pointer)); + add_saved_pointer(sc, defaults); + c_function_arg_defaults(func) = defaults; + c_func_set_simple_defaults(func); + /* (define* (f :allow-other-keys) 32) -> :allow-other-keys can't be the only parameter: (:allow-other-keys) */ + + for (p = local_args, i = 0; i < n_args; p = cdr(p), i++) { + s7_pointer arg = car(p); + if (arg == sc->key_allow_other_keys_symbol) { + if (is_not_null(cdr(p))) + s7_warn(sc, 256, + "%s :allow-other-keys should be the last parameter: %s\n", + name, arglist); + if (p == local_args) + s7_warn(sc, 256, + "%s :allow-other-keys can't be the only parameter: %s\n", + name, arglist); + c_function_set_allow_other_keys(func); /* local_args is local, so it can't carry the bit */ + n_args--; + c_function_optional_args(func) = n_args; + c_function_all_args(func) = n_args; /* apparently not counting keywords */ + } else if (is_pair(arg)) { /* there is a default */ + names[i] = symbol_to_keyword(sc, car(arg)); + defaults[i] = cadr(arg); + s7_remove_from_heap(sc, cadr(arg)); + if ((is_pair(defaults[i])) || + (is_normal_symbol(defaults[i]))) { + c_func_clear_simple_defaults(func); + mark_function[T_C_FUNCTION_STAR] = mark_c_proc_star; + } + } else { + if (arg == sc->key_rest_symbol) + s7_warn(sc, 256, + "%s :rest is not supported in C-side define*: %s\n", + name, arglist); + names[i] = symbol_to_keyword(sc, arg); + defaults[i] = sc->F; + } + } + } else + set_full_type(func, T_C_FUNCTION | T_UNHEAP); + + s7_gc_unprotect_at(sc, gc_loc); + return (func); +} + +s7_pointer s7_make_safe_function_star(s7_scheme * sc, const char *name, + s7_function fnc, const char *arglist, + const char *doc) +{ + s7_pointer func; + func = s7_make_function_star(sc, name, fnc, arglist, doc); + set_full_type(func, full_type(func) | T_SAFE_PROCEDURE); /* don't step on the c_func_has_simple_defaults flag */ + if (is_c_function_star(func)) /* thunk -> c_function */ + c_function_call_args(func) = + permanent_list(sc, c_function_optional_args(func)); + return (func); +} + +static void define_function_star_1(s7_scheme * sc, const char *name, + s7_function fnc, const char *arglist, + const char *doc, bool safe, + s7_pointer signature) +{ + s7_pointer func, sym; + if (safe) + func = s7_make_safe_function_star(sc, name, fnc, arglist, doc); + else + func = s7_make_function_star(sc, name, fnc, arglist, doc); + sym = make_symbol(sc, name); + s7_define(sc, sc->nil, sym, func); + if (signature) + c_function_signature(func) = signature; +} + +void s7_define_function_star(s7_scheme * sc, const char *name, + s7_function fnc, const char *arglist, + const char *doc) +{ + define_function_star_1(sc, name, fnc, arglist, doc, false, NULL); +} + +void s7_define_safe_function_star(s7_scheme * sc, const char *name, + s7_function fnc, const char *arglist, + const char *doc) +{ + define_function_star_1(sc, name, fnc, arglist, doc, true, NULL); +} + +void s7_define_typed_function_star(s7_scheme * sc, const char *name, + s7_function fnc, const char *arglist, + const char *doc, s7_pointer signature) +{ + define_function_star_1(sc, name, fnc, arglist, doc, true, signature); +} + + +s7_pointer s7_define_macro(s7_scheme * sc, const char *name, + s7_function fnc, s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc) +{ + s7_pointer func, sym; + func = + s7_make_function(sc, name, fnc, required_args, optional_args, + rest_arg, doc); + set_full_type(func, T_C_MACRO | T_DONT_EVAL_ARGS | T_UNHEAP); /* s7_make_function includes T_UNHEAP */ + sym = make_symbol(sc, name); + s7_define(sc, sc->nil, sym, func); + return (sym); +} + + +/* -------------------------------- macro? -------------------------------- */ +bool s7_is_macro(s7_scheme * sc, s7_pointer x) +{ + return (is_any_macro(x)); +} + +static bool is_macro_b(s7_pointer x) +{ + return (is_any_macro(x)); +} + +static s7_pointer g_is_macro(s7_scheme * sc, s7_pointer args) +{ +#define H_is_macro "(macro? arg) returns #t if 'arg' is a macro or a bacro" +#define Q_is_macro sc->pl_bt + check_boolean_method(sc, is_any_macro, sc->is_macro_symbol, args); +} + +static s7_pointer s7_macroexpand(s7_scheme * sc, s7_pointer mac, + s7_pointer args) +{ + if (!s7_is_proper_list(sc, args)) + s7_error(sc, sc->syntax_error_symbol, + set_elist_2(sc, + wrap_string(sc, + "improper list of arguments: ~S", + 30), args)); + push_stack_direct(sc, OP_FLUSH_VALUES); + sc->code = mac; + sc->args = args; + sc->curlet = make_let(sc, closure_let(sc->code)); + eval(sc, OP_APPLY_LAMBDA); + return (sc->value); +} + + +/* -------------------------------- documentation -------------------------------- */ +const char *s7_documentation(s7_scheme * sc, s7_pointer x) +{ + s7_pointer val; + if (is_symbol(x)) { + if (is_keyword(x)) + return (NULL); + if (symbol_has_help(x)) + return (symbol_help(x)); + x = s7_symbol_value(sc, x); /* this is needed by Snd */ + } + + if ((is_any_c_function(x)) || (is_c_macro(x))) + return ((char *) c_function_documentation(x)); + + if (is_syntax(x)) + return (syntax_documentation(x)); + + val = funclet_entry(sc, x, sc->local_documentation_symbol); + if ((val) && (is_string(val))) + return (string_value(val)); + return (NULL); +} + +static s7_pointer g_documentation(s7_scheme * sc, s7_pointer args) +{ +#define H_documentation "(documentation obj) returns obj's documentation string" +#define Q_documentation s7_make_signature(sc, 2, sc->is_string_symbol, sc->T) /* should (documentation 1) be an error? */ + + s7_pointer p = car(args); + if (is_symbol(p)) { + if ((symbol_has_help(p)) && (is_global(p))) + return (s7_make_string(sc, symbol_help(p))); + p = s7_symbol_value(sc, p); + } + + /* (documentation func) should act like (documentation abs) -- available without (openlet (funclet func)) or (openlet func) + * so we check that case ahead of time here, rather than going through check_method which does not + * call find_let unless has_active_methods(sc, func). Adding T_HAS_METHODS to all closures causes other troubles. + */ + if (has_closure_let(p)) { + s7_pointer func; + func = funclet_entry(sc, p, sc->documentation_symbol); + if (func) + return (call_method(sc, p, func, args)); + } + + /* it would be neat if this would work (define x (let ((+documentation+ "hio")) (vector 1 2 3))) (documentation x) */ + check_method(sc, p, sc->documentation_symbol, args); + return (s7_make_string(sc, s7_documentation(sc, p))); +} + +const char *s7_set_documentation(s7_scheme * sc, s7_pointer sym, + const char *new_doc) +{ + if (is_keyword(sym)) + return (NULL); + if (is_symbol(sym)) { + symbol_set_has_help(sym); + symbol_set_help(sym, copy_string(new_doc)); + } + return (new_doc); +} + + +/* -------------------------------- help -------------------------------- */ +const char *s7_help(s7_scheme * sc, s7_pointer obj) +{ + if (is_syntax(obj)) + return (syntax_documentation(obj)); + + if (is_symbol(obj)) { + /* here look for name */ + if (s7_documentation(sc, obj)) + return (s7_documentation(sc, obj)); + obj = s7_symbol_value(sc, obj); + } + + if (is_any_procedure(obj)) + return (s7_documentation(sc, obj)); + + if (obj == sc->s7_let) + return + ("*s7* is a let that gives access to s7's internal state: e.g. (*s7* 'print-length)"); + + /* if is string, apropos? (can scan symbol table) */ + return (NULL); +} + +static s7_pointer g_help(s7_scheme * sc, s7_pointer args) +{ +#define H_help "(help obj) returns obj's documentation" +#define Q_help s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_boolean_symbol), sc->T) + + const char *doc; + check_method(sc, car(args), sc->help_symbol, args); + doc = s7_help(sc, car(args)); + return ((doc) ? s7_make_string(sc, doc) : sc->F); +} + + +/* -------------------------------- signature -------------------------------- */ +static void init_signatures(s7_scheme * sc) +{ + sc->string_signature = + s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, + sc->is_integer_symbol); + sc->byte_vector_signature = + s7_make_circular_signature(sc, 2, 3, sc->is_byte_symbol, + sc->is_byte_vector_symbol, + sc->is_integer_symbol); + sc->vector_signature = + s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol, + sc->is_integer_symbol); + sc->float_vector_signature = + s7_make_circular_signature(sc, 2, 3, sc->is_float_symbol, + sc->is_float_vector_symbol, + sc->is_integer_symbol); + sc->int_vector_signature = + s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, + sc->is_int_vector_symbol, + sc->is_integer_symbol); + sc->c_object_signature = + s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_c_object_symbol, + sc->T); + sc->let_signature = + s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_let_symbol, + sc->is_symbol_symbol); + sc->hash_table_signature = + s7_make_circular_signature(sc, 2, 3, sc->T, + sc->is_hash_table_symbol, sc->T); + sc->pair_signature = + s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, + sc->is_integer_symbol); +} + +static s7_pointer g_signature(s7_scheme * sc, s7_pointer args) +{ +#define H_signature "(signature obj) returns obj's signature" +#define Q_signature s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T) + + s7_pointer p = car(args); + switch (type(p)) { + case T_C_FUNCTION: + case T_C_FUNCTION_STAR: + case T_C_ANY_ARGS_FUNCTION: + case T_C_OPT_ARGS_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + case T_C_MACRO: + return ((s7_pointer) c_function_signature(p)); + + case T_MACRO: + case T_MACRO_STAR: + case T_BACRO: + case T_BACRO_STAR: + case T_CLOSURE: + case T_CLOSURE_STAR: + { + s7_pointer func; + func = funclet_entry(sc, p, sc->local_signature_symbol); + if (func) + return (func); + func = funclet_entry(sc, p, sc->signature_symbol); + return ((func) ? call_method(sc, p, func, args) : sc->F); + } + + case T_VECTOR: + if (vector_length(p) == 0) + return (sc->F); /* sig () is #f so sig #() should be #f */ + if (!is_typed_vector(p)) + return (sc->vector_signature); + { + s7_pointer lst; + lst = + list_3(sc, typed_vector_typer_symbol(sc, p), + sc->is_vector_symbol, sc->is_integer_symbol); + set_cdddr(lst, cddr(lst)); + return (lst); + } + + case T_FLOAT_VECTOR: + return ((vector_length(p) == + 0) ? sc->F : sc->float_vector_signature); + case T_INT_VECTOR: + return ((vector_length(p) == + 0) ? sc->F : sc->int_vector_signature); + case T_BYTE_VECTOR: + return ((vector_length(p) == + 0) ? sc->F : sc->byte_vector_signature); + case T_PAIR: + return (sc->pair_signature); + case T_STRING: + return (sc->string_signature); + + case T_HASH_TABLE: + if (is_typed_hash_table(p)) + return (list_3(sc, + hash_table_typer_symbol(sc, + hash_table_value_typer + (p)), + sc->is_hash_table_symbol, + hash_table_typer_symbol(sc, + hash_table_key_typer + (p)))); + return (sc->hash_table_signature); + + case T_ITERATOR: + p = iterator_sequence(p); + if ((is_hash_table(p)) || (is_let(p))) /* cons returned -- would be nice to include the car/cdr types if known */ + return (list_1(sc, sc->is_pair_symbol)); + p = g_signature(sc, set_plist_1(sc, p)); + return (list_1(sc, (is_pair(p)) ? car(p) : sc->T)); + + case T_C_OBJECT: + check_method(sc, p, sc->signature_symbol, args); + return (sc->c_object_signature); + + case T_LET: + check_method(sc, p, sc->signature_symbol, args); + return (sc->let_signature); + + case T_SYMBOL: + /* this used to get the symbol's value and call g_signature on that */ + { + s7_pointer slot; + slot = lookup_slot_from(p, sc->curlet); + if ((is_slot(slot)) && (slot_has_setter(slot))) { + s7_pointer setter; + setter = slot_setter(slot); + p = g_signature(sc, set_plist_1(sc, setter)); + if (is_pair(p)) + return (list_1(sc, car(p))); + } + } + break; + + default: + break; + } + return (sc->F); +} + +s7_pointer s7_signature(s7_scheme * sc, s7_pointer func) +{ + return (g_signature(sc, set_plist_1(sc, func))); +} + + +/* -------------------------------- dynamic-wind -------------------------------- */ +static s7_pointer closure_or_f(s7_scheme * sc, s7_pointer p) +{ + s7_pointer body; + if (!is_closure(p)) + return (p); + body = closure_body(p); + if (is_pair(cdr(body))) + return (p); + if (!is_pair(car(body))) + return (sc->F); + return ((caar(body) == sc->quote_symbol) ? sc->F : p); +} + +static s7_pointer make_baffled_closure(s7_scheme * sc, s7_pointer inp) +{ + /* for dynamic-wind to protect initial and final functions from call/cc */ + s7_pointer nclo, let; + nclo = make_closure(sc, sc->nil, closure_body(inp), type(inp), 0); + let = make_let_slowly(sc, closure_let(inp)); /* let_outlet(let) = closure_let(inp) */ + set_baffle_let(let); + set_let_baffle_key(let, sc->baffle_ctr++); + closure_set_let(nclo, let); + return (nclo); +} + +static bool is_dwind_thunk(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_MACRO: + case T_BACRO: + case T_CLOSURE: + case T_MACRO_STAR: + case T_BACRO_STAR: + case T_CLOSURE_STAR: + return (is_null(closure_args(x))); /* this is the case that does not match is_aritable -- it could be loosened -- arity=0 below would need fixup */ + case T_C_RST_ARGS_FUNCTION: + case T_C_FUNCTION: + return ((c_function_required_args(x) <= 0) + && (c_function_all_args(x) >= 0)); + case T_C_OPT_ARGS_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + case T_C_FUNCTION_STAR: + return (c_function_all_args(x) >= 0); + case T_C_MACRO: + return ((c_macro_required_args(x) <= 0) + && (c_macro_all_args(x) >= 0)); + case T_GOTO: + case T_CONTINUATION: + return (true); + } + return (x == sc->F); /* (dynamic-wind #f (lambda () 3) #f) */ +} + +static s7_pointer g_dynamic_wind_unchecked(s7_scheme * sc, s7_pointer args) +{ + s7_pointer p, inp, outp; + + new_cell(sc, p, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */ + dynamic_wind_in(p) = closure_or_f(sc, car(args)); + dynamic_wind_body(p) = cadr(args); + dynamic_wind_out(p) = closure_or_f(sc, caddr(args)); + + inp = dynamic_wind_in(p); + if ((is_any_closure(inp)) && (!is_safe_closure(inp))) /* wrap this use of inp in a with-baffle */ + dynamic_wind_in(p) = make_baffled_closure(sc, inp); + + outp = dynamic_wind_out(p); + if ((is_any_closure(outp)) && (!is_safe_closure(outp))) + dynamic_wind_out(p) = make_baffled_closure(sc, outp); + + /* since we don't care about the in and out results, and they are thunks, if the body is not a pair, + * or is a quoted thing, we just ignore that function. + */ + push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p); /* args will be the saved result, code = s7_dynwind_t obj */ + if (inp != sc->F) { + dynamic_wind_state(p) = DWIND_INIT; + push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(p)); + } else { + dynamic_wind_state(p) = DWIND_BODY; + push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_body(p)); + } + return (sc->F); +} + +static s7_pointer g_dynamic_wind(s7_scheme * sc, s7_pointer args) +{ +#define H_dynamic_wind "(dynamic-wind init body finish) calls init, then body, then finish, \ +each a function of no arguments, guaranteeing that finish is called even if body is exited" +#define Q_dynamic_wind s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->is_procedure_symbol) + + if (!is_dwind_thunk(sc, car(args))) + return (method_or_bust_with_type + (sc, car(args), sc->dynamic_wind_symbol, args, + a_thunk_string, 1)); + if (!is_thunk(sc, cadr(args))) + return (method_or_bust_with_type + (sc, cadr(args), sc->dynamic_wind_symbol, args, + a_thunk_string, 2)); + if (!is_dwind_thunk(sc, caddr(args))) + return (method_or_bust_with_type + (sc, caddr(args), sc->dynamic_wind_symbol, args, + a_thunk_string, 3)); + + /* this won't work: + (let ((final (lambda (a b c) (list a b c)))) + (dynamic-wind + (lambda () #f) + (lambda () (set! final (lambda () (display "in final")))) + final)) + * but why not? 'final' is a thunk by the time it is evaluated. catch (the error handler) is similar. + * It can't work here because we set up the dynamic_wind_out slot below and + * even if the thunk check was removed, we'd still be trying to apply the original function. + */ + return (g_dynamic_wind_unchecked(sc, args)); +} + +static bool is_lambda(s7_scheme * sc, s7_pointer sym) +{ + return ((sym == sc->lambda_symbol) && (symbol_id(sym) == 0)); /* do we need (!sc->in_with_let) ? */ + /* symbol_id=0 means it has never been rebound (T_GLOBAL might not be set for initial stuff) */ +} + +static bool is_ok_thunk(s7_scheme * sc, s7_pointer arg) +{ + return ((is_pair(arg)) && + (is_lambda(sc, car(arg))) && + (is_pair(cdr(arg))) && + (is_null(cadr(arg))) && + (is_pair(cddr(arg))) && (s7_is_proper_list(sc, cddr(arg)))); +} + +static s7_pointer dynamic_wind_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, + bool ops) +{ + if ((args == 3) && + ((is_ok_thunk(sc, cadr(expr))) || (cadr(expr) == sc->F)) && + (is_ok_thunk(sc, caddr(expr))) && + ((is_ok_thunk(sc, cadddr(expr))) || (cadddr(expr) == sc->F))) + return (sc->dynamic_wind_unchecked); + return (f); +} + +s7_pointer s7_dynamic_wind(s7_scheme * sc, s7_pointer init, + s7_pointer body, s7_pointer finish) +{ + /* this is essentially s7_call with a dynamic-wind wrapper around "body" */ + s7_pointer p; + declare_jump_info(); + + store_jump_info(sc); + set_jump_info(sc, DYNAMIC_WIND_SET_JUMP); + if (jump_loc != NO_JUMP) { + if (jump_loc != ERROR_JUMP) + eval(sc, sc->cur_op); + } else { + push_stack_direct(sc, OP_EVAL_DONE); + sc->args = sc->nil; + + new_cell(sc, p, T_DYNAMIC_WIND); + dynamic_wind_in(p) = T_Pos(init); + dynamic_wind_body(p) = T_Pos(body); + dynamic_wind_out(p) = T_Pos(finish); + push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p); + if (init != sc->F) { + dynamic_wind_state(p) = DWIND_INIT; + sc->code = init; + } else { + dynamic_wind_state(p) = DWIND_BODY; + sc->code = body; + } + eval(sc, OP_APPLY); + } + restore_jump_info(sc); + + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return (sc->value); +} + + +/* -------------------------------- c-object? -------------------------------- */ +bool s7_is_c_object(s7_pointer p) +{ + return (is_c_object(p)); +} + +static s7_pointer g_is_c_object(s7_scheme * sc, s7_pointer args) +{ +#define H_is_c_object "(c-object? obj) returns #t is obj is a c-object." +#define Q_is_c_object sc->pl_bt + s7_pointer obj = car(args); + if (is_c_object(obj)) + return (sc->T); + if (!has_active_methods(sc, obj)) + return (sc->F); + return (apply_boolean_method(sc, obj, sc->is_c_object_symbol)); +} + + +/* -------------------------------- c-object-type -------------------------------- */ +static void fallback_free(void *value) +{ +} + +static void fallback_mark(void *value) +{ +} + +static s7_pointer apply_error(s7_scheme * sc, s7_pointer obj, + s7_pointer args); + +static s7_pointer fallback_ref(s7_scheme * sc, s7_pointer args) +{ + return (apply_error(sc, car(args), cdr(args))); +} + +static s7_pointer fallback_set(s7_scheme * sc, s7_pointer args) +{ + return (eval_error(sc, "attempt to set ~S?", 18, car(args))); +} + +static s7_pointer fallback_length(s7_scheme * sc, s7_pointer obj) +{ + return (sc->F); +} + +s7_int s7_c_object_type(s7_pointer obj) +{ + return ((is_c_object(obj)) ? c_object_type(obj) : -1); +} + +static s7_pointer g_c_object_type(s7_scheme * sc, s7_pointer args) +{ +#define H_c_object_type "(c-object-type obj) returns the c_object's type tag." +#define Q_c_object_type s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_c_object_symbol) + + s7_pointer p = car(args); + if (is_c_object(p)) + return (make_integer(sc, c_object_type(p))); /* this is the c_object_types table index = tag */ + return (method_or_bust + (sc, p, sc->c_object_type_symbol, args, T_C_OBJECT, 0)); +} + +static s7_pointer g_c_object_set(s7_scheme * sc, s7_pointer args) +{ /* called in c_object_set_function */ + s7_pointer obj = car(args); + if (!is_c_object(obj)) + return (simple_wrong_type_argument + (sc, make_symbol(sc, "c-object-set!"), obj, T_C_OBJECT)); + return ((*(c_object_set(sc, obj))) (sc, args)); +} + +s7_int s7_make_c_type(s7_scheme * sc, const char *name) +{ + s7_int tag; + c_object_t *c_type; + tag = sc->num_c_object_types++; + if (tag >= sc->c_object_types_size) { + if (sc->c_object_types_size == 0) { + sc->c_object_types_size = 8; + sc->c_object_types = + (c_object_t **) Calloc(sc->c_object_types_size, + sizeof(c_object_t *)); + } else { + sc->c_object_types_size = tag + 8; + sc->c_object_types = + (c_object_t **) Realloc((void *) (sc->c_object_types), + sc->c_object_types_size * + sizeof(c_object_t *)); + } + } + c_type = (c_object_t *) Calloc(1, sizeof(c_object_t)); + sc->c_object_types[tag] = c_type; + c_type->type = tag; + c_type->scheme_name = s7_make_permanent_string(sc, name); + c_type->getter = sc->F; + c_type->setter = sc->F; + c_type->free = fallback_free; + c_type->mark = fallback_mark; + c_type->ref = fallback_ref; + c_type->set = fallback_set; + c_type->outer_type = T_C_OBJECT; + c_type->length = fallback_length; + /* all other fields are NULL */ + return (tag); +} + +void s7_c_type_set_free(s7_scheme * sc, s7_int tag, + void (*gc_free)(void *value)) +{ + sc->c_object_types[tag]->free = gc_free; +} + +void s7_c_type_set_mark(s7_scheme * sc, s7_int tag, + void (*mark)(void *value)) +{ + sc->c_object_types[tag]->mark = mark; +} + +void s7_c_type_set_equal(s7_scheme * sc, s7_int tag, + bool (*equal)(void *value1, void *value2)) +{ + sc->c_object_types[tag]->eql = equal; +} + +void s7_c_type_set_gc_free(s7_scheme * sc, s7_int tag, + s7_pointer(*gc_free) (s7_scheme * sc, + s7_pointer obj)) +{ + sc->c_object_types[tag]->gc_free = gc_free; +} + +void s7_c_type_set_gc_mark(s7_scheme * sc, s7_int tag, + s7_pointer(*gc_mark) (s7_scheme * sc, + s7_pointer obj)) +{ + sc->c_object_types[tag]->gc_mark = gc_mark; +} + +void s7_c_type_set_is_equal(s7_scheme * sc, s7_int tag, + s7_pointer(*is_equal) (s7_scheme * sc, + s7_pointer args)) +{ + sc->c_object_types[tag]->equal = is_equal; +} + +void s7_c_type_set_set(s7_scheme * sc, s7_int tag, + s7_pointer(*set) (s7_scheme * sc, s7_pointer args)) +{ + sc->c_object_types[tag]->set = set; +} + +void s7_c_type_set_length(s7_scheme * sc, s7_int tag, + s7_pointer(*length) (s7_scheme * sc, + s7_pointer args)) +{ + sc->c_object_types[tag]->length = length; +} + +void s7_c_type_set_copy(s7_scheme * sc, s7_int tag, + s7_pointer(*copy) (s7_scheme * sc, + s7_pointer args)) +{ + sc->c_object_types[tag]->copy = copy; +} + +void s7_c_type_set_fill(s7_scheme * sc, s7_int tag, + s7_pointer(*fill) (s7_scheme * sc, + s7_pointer args)) +{ + sc->c_object_types[tag]->fill = fill; +} + +void s7_c_type_set_reverse(s7_scheme * sc, s7_int tag, + s7_pointer(*reverse) (s7_scheme * sc, + s7_pointer args)) +{ + sc->c_object_types[tag]->reverse = reverse; +} + +void s7_c_type_set_to_list(s7_scheme * sc, s7_int tag, + s7_pointer(*to_list) (s7_scheme * sc, + s7_pointer args)) +{ + sc->c_object_types[tag]->to_list = to_list; +} + +void s7_c_type_set_to_string(s7_scheme * sc, s7_int tag, + s7_pointer(*to_string) (s7_scheme * sc, + s7_pointer args)) +{ + sc->c_object_types[tag]->to_string = to_string; +} + +void s7_c_type_set_is_equivalent(s7_scheme * sc, s7_int tag, + s7_pointer(*is_equivalent) (s7_scheme * + sc, + s7_pointer + args)) +{ + sc->c_object_types[tag]->equivalent = is_equivalent; +} + +void s7_c_type_set_ref(s7_scheme * sc, s7_int tag, + s7_pointer(*ref) (s7_scheme * sc, s7_pointer args)) +{ + sc->c_object_types[tag]->ref = ref; + if (sc->c_object_types[tag]->ref != fallback_ref) + sc->c_object_types[tag]->outer_type = + (T_C_OBJECT | T_SAFE_PROCEDURE); +} + +void s7_c_type_set_getter(s7_scheme * sc, s7_int tag, s7_pointer getter) +{ + if ((S7_DEBUGGING) && (!is_c_function(getter))) + fprintf(stderr, "%s[%d]: %p is not a c_function\n", __func__, + __LINE__, getter); + sc->c_object_types[tag]->getter = getter; +} + +void s7_c_type_set_setter(s7_scheme * sc, s7_int tag, s7_pointer setter) +{ + if ((S7_DEBUGGING) && (!is_c_function(setter))) + fprintf(stderr, "%s[%d]: %p is not a c_function\n", __func__, + __LINE__, setter); + sc->c_object_types[tag]->setter = setter; +} + +void *s7_c_object_value(s7_pointer obj) +{ + return (c_object_value(obj)); +} + +void *s7_c_object_value_checked(s7_pointer obj, s7_int type) +{ + if ((is_c_object(obj)) && (c_object_type(obj) == type)) + return (c_object_value(obj)); + return (NULL); +} + +static s7_pointer make_c_object_with_let(s7_scheme * sc, s7_int type, + void *value, s7_pointer let, + bool with_gc) +{ + s7_pointer x; + new_cell(sc, x, sc->c_object_types[type]->outer_type); + + /* c_object_info(x) = &(sc->c_object_types[type]); */ + /* that won't work because c_object_types can move when it is realloc'd and the old stuff is freed by realloc + * and since we're checking (for example) ref_2 existence as not null, we can't use a table of c_object_t's! + * Using mallocate (s7_make_c_object_with_data) is faster, but not enough to warrant the code. + */ + c_object_type(x) = type; + c_object_value(x) = value; + c_object_set_let(x, (let == sc->rootlet) ? sc->nil : let); + c_object_s7(x) = sc; + if (with_gc) + add_c_object(sc, x); + return (x); +} + +s7_pointer s7_make_c_object_with_let(s7_scheme * sc, s7_int type, + void *value, s7_pointer let) +{ + return (make_c_object_with_let(sc, type, value, let, true)); +} + +s7_pointer s7_make_c_object(s7_scheme * sc, s7_int type, void *value) +{ + return (make_c_object_with_let(sc, type, value, sc->nil, true)); +} + +s7_pointer s7_make_c_object_without_gc(s7_scheme * sc, s7_int type, + void *value) +{ + return (make_c_object_with_let(sc, type, value, sc->nil, false)); +} + +s7_pointer s7_c_object_let(s7_pointer obj) +{ + return (c_object_let(obj)); +} + +s7_pointer s7_c_object_set_let(s7_scheme * sc, s7_pointer obj, + s7_pointer e) +{ + if ((!is_immutable(obj)) && (is_let(e))) + c_object_set_let(obj, (e == sc->rootlet) ? sc->nil : e); + return (e); +} + +static s7_pointer c_object_length(s7_scheme * sc, s7_pointer obj) +{ + if (c_object_len(sc, obj)) + return ((*(c_object_len(sc, obj))) (sc, set_clist_1(sc, obj))); + return (eval_error(sc, "attempt to get length of ~S?", 28, obj)); +} + +static s7_int c_object_length_to_int(s7_scheme * sc, s7_pointer obj) +{ + if (c_object_len(sc, obj)) { + s7_pointer res; + res = (*(c_object_len(sc, obj))) (sc, set_clist_1(sc, obj)); + if (s7_is_integer(res)) + return (s7_integer_checked(sc, res)); + } + return (-1); +} + +static s7_pointer copy_c_object(s7_scheme * sc, s7_pointer args) +{ + s7_pointer obj = car(args); + check_method(sc, obj, sc->copy_symbol, args); + if (c_object_copy(sc, obj)) + return ((*(c_object_copy(sc, obj))) (sc, args)); + return (eval_error(sc, "attempt to copy ~S?", 19, obj)); +} + +static s7_pointer c_object_type_to_let(s7_scheme * sc, s7_pointer cobj) +{ + return (g_local_inlet(sc, 4, + sc->name_symbol, c_object_scheme_name(sc, cobj), + sc->setter_symbol, + (c_object_set(sc, cobj) != + fallback_set) ? sc-> + c_object_set_function : sc->F)); + /* should we make new wrappers every time this is called? or save the let somewhere and reuse it? */ +} + +static void apply_c_object(s7_scheme * sc) +{ /* -------- applicable c_object -------- */ + sc->value = + (*(c_object_ref(sc, sc->code))) (sc, + set_ulist_1(sc, sc->code, + sc->args)); + set_car(sc->u1_1, sc->F); +} + +static bool op_implicit_c_object_ref_a(s7_scheme * sc) +{ + s7_pointer c; + c = lookup_checked(sc, car(sc->code)); + if (!is_c_object(c)) { + sc->last_function = c; + return (false); + } + set_car(sc->t2_2, fx_call(sc, cdr(sc->code))); + set_car(sc->t2_1, c); /* fx_call above might use sc->t2* */ + sc->value = (*(c_object_ref(sc, c))) (sc, sc->t2_1); + return (true); +} + + +/* -------- dilambda -------- */ + +s7_pointer s7_dilambda_with_environment(s7_scheme * sc, s7_pointer envir, + const char *name, + s7_pointer(*getter) (s7_scheme * + sc, + s7_pointer + args), + s7_int get_req_args, + s7_int get_opt_args, + s7_pointer(*setter) (s7_scheme * + sc, + s7_pointer + args), + s7_int set_req_args, + s7_int set_opt_args, + const char *documentation) +{ + s7_pointer get_func, set_func; + char *internal_set_name; + s7_int len; + + if (!name) + return (sc->F); + len = 16 + safe_strlen(name); + internal_set_name = (char *) Malloc(len); + internal_set_name[0] = '\0'; + catstrs_direct(internal_set_name, "[set-", name, "]", + (const char *) NULL); + add_saved_pointer(sc, internal_set_name); + get_func = + s7_make_safe_function(sc, name, getter, get_req_args, get_opt_args, + false, documentation); + s7_define(sc, envir, make_symbol(sc, name), get_func); + set_func = + s7_make_function(sc, internal_set_name, setter, set_req_args, + set_opt_args, false, documentation); + c_function_set_setter(get_func, set_func); + return (get_func); +} + +s7_pointer s7_dilambda(s7_scheme * sc, + const char *name, + s7_pointer(*getter) (s7_scheme * sc, + s7_pointer args), + s7_int get_req_args, s7_int get_opt_args, + s7_pointer(*setter) (s7_scheme * sc, + s7_pointer args), + s7_int set_req_args, s7_int set_opt_args, + const char *documentation) +{ + return (s7_dilambda_with_environment + (sc, sc->nil, name, getter, get_req_args, get_opt_args, setter, + set_req_args, set_opt_args, documentation)); +} + +s7_pointer s7_typed_dilambda(s7_scheme * sc, + const char *name, + s7_pointer(*getter) (s7_scheme * sc, + s7_pointer args), + s7_int get_req_args, s7_int get_opt_args, + s7_pointer(*setter) (s7_scheme * sc, + s7_pointer args), + s7_int set_req_args, s7_int set_opt_args, + const char *documentation, s7_pointer get_sig, + s7_pointer set_sig) +{ + s7_pointer get_func, set_func; + get_func = + s7_dilambda(sc, name, getter, get_req_args, get_opt_args, setter, + set_req_args, set_opt_args, documentation); + set_func = c_function_setter(get_func); + if (get_sig) + c_function_signature(get_func) = get_sig; + if (set_sig) + c_function_signature(set_func) = set_sig; + return (get_func); +} + +static void op_set_dilambda_p(s7_scheme * sc) +{ + push_stack_no_args(sc, OP_SET_DILAMBDA_P_1, cdr(sc->code)); + sc->code = caddr(sc->code); +} + +static void op_set_dilambda(s7_scheme * sc) +{ /* ([set!] (dilambda-setter g) s) */ + sc->code = cdr(sc->code); + sc->value = cadr(sc->code); + if (is_symbol(sc->value)) + sc->value = lookup_checked(sc, sc->value); +} + +static void op_set_dilambda_sa_a(s7_scheme * sc) +{ + s7_pointer code = cdr(sc->code), obj, func, setter; + func = lookup(sc, caar(code)); + obj = lookup(sc, cadar(code)); + setter = closure_setter(func); + sc->curlet = + update_let_with_two_slots(sc, closure_let(setter), obj, + fx_call(sc, cdr(code))); + sc->value = fx_call(sc, closure_body(setter)); +} + + +/* -------------------------------- dilambda? -------------------------------- */ +bool s7_is_dilambda(s7_pointer obj) +{ + switch (type(obj)) { + case T_MACRO: + case T_MACRO_STAR: + case T_BACRO: + case T_BACRO_STAR: + case T_CLOSURE: + case T_CLOSURE_STAR: + return (is_any_procedure(closure_setter_or_map_list(obj))); /* type >= T_CLOSURE (excludes goto/continuation) */ + + case T_C_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + case T_C_OPT_ARGS_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + case T_C_FUNCTION_STAR: + return (is_any_procedure(c_function_setter(obj))); + + case T_C_MACRO: + return (is_any_procedure(c_macro_setter(obj))); + } + return (false); +} + +static s7_pointer g_is_dilambda(s7_scheme * sc, s7_pointer args) +{ +#define H_is_dilambda "(dilambda? obj) returns #t if obj is a procedure with setter." +#define Q_is_dilambda sc->pl_bt + check_boolean_method(sc, s7_is_dilambda, sc->is_dilambda_symbol, args); +} + + +/* -------------------------------- dilambda -------------------------------- */ +static s7_pointer g_dilambda(s7_scheme * sc, s7_pointer args) +{ +#define H_dilambda "(dilambda getter setter) sets getter's setter to be setter." +#define Q_dilambda s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->is_procedure_symbol) + + s7_pointer getter = car(args), setter; + if (!is_any_procedure(getter)) + return (wrong_type_argument_with_type + (sc, sc->dilambda_symbol, 1, getter, + a_procedure_or_a_macro_string)); + + setter = cadr(args); + if (!is_any_procedure(setter)) + return (wrong_type_argument_with_type + (sc, sc->dilambda_symbol, 2, setter, + a_procedure_or_a_macro_string)); + + s7_set_setter(sc, getter, setter); + return (getter); +} + + +/* -------------------------------- arity -------------------------------- */ +static s7_pointer closure_arity_to_cons(s7_scheme * sc, s7_pointer x, + s7_pointer x_args) +{ + /* x_args is unprocessed -- it is exactly the list as used in the closure[*] definition */ + int32_t len; + + if (is_symbol(x_args)) /* any number of args is ok */ + return (cons(sc, int_zero, max_arity)); + if (closure_arity_unknown(x)) + closure_set_arity(x, s7_list_length(sc, x_args)); + len = closure_arity(x); + if (len < 0) /* dotted list => rest arg, (length '(a b . c)) is -2 */ + return (cons(sc, make_integer(sc, -len), max_arity)); + return (cons(sc, make_integer(sc, len), make_integer(sc, len))); +} + +static void closure_star_arity_1(s7_scheme * sc, s7_pointer x, + s7_pointer args) +{ + if (closure_arity_unknown(x)) { + if (is_null(args)) + closure_set_arity(x, 0); + else if ((is_symbol(args)) || (allows_other_keys(args))) + closure_set_arity(x, -1); + else { + s7_pointer p; + int32_t i; + for (i = 0, p = args; is_pair(p); i++, p = cdr(p)) { /* is_pair(p) so (f1 a . b) will end with b not null */ + s7_pointer arg = car(p); + if (arg == sc->key_rest_symbol) + break; + } + closure_set_arity(x, ((is_null(p)) ? i : -1)); /* see below */ + } + } +} + +static s7_pointer closure_star_arity_to_cons(s7_scheme * sc, s7_pointer x, + s7_pointer x_args) +{ + closure_star_arity_1(sc, x, x_args); + return ((closure_arity(x) == -1) ? cons(sc, int_zero, + max_arity) : cons(sc, int_zero, + make_integer + (sc, + closure_arity + (x)))); +} + +static int32_t closure_arity_to_int(s7_scheme * sc, s7_pointer x) +{ + /* not lambda* here */ + if (closure_arity_unknown(x)) { + int32_t i; + s7_pointer b; + for (i = 0, b = closure_args(x); is_pair(b); i++, b = cdr(b)) { + }; + if (is_null(b)) + closure_set_arity(x, i); + else { + if (i == 0) + return (-1); + closure_set_arity(x, -i); + } + } + return (closure_arity(x)); +} + +static int32_t closure_star_arity_to_int(s7_scheme * sc, s7_pointer x) +{ + /* not lambda here */ + closure_star_arity_1(sc, x, closure_args(x)); + return (closure_arity(x)); +} + +s7_pointer s7_arity(s7_scheme * sc, s7_pointer x) +{ + switch (type(x)) { + case T_C_OPT_ARGS_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + case T_C_FUNCTION: + return (cons + (sc, make_integer(sc, c_function_required_args(x)), + make_integer(sc, c_function_all_args(x)))); + + case T_C_ANY_ARGS_FUNCTION: + case T_C_FUNCTION_STAR: + return (cons + (sc, int_zero, make_integer(sc, c_function_all_args(x)))); + + case T_MACRO: + case T_BACRO: + case T_CLOSURE: + return (closure_arity_to_cons(sc, x, closure_args(x))); + + case T_MACRO_STAR: + case T_BACRO_STAR: + case T_CLOSURE_STAR: + return (closure_star_arity_to_cons(sc, x, closure_args(x))); + + case T_C_MACRO: + return (cons + (sc, make_integer(sc, c_macro_required_args(x)), + make_integer(sc, c_macro_all_args(x)))); + + case T_GOTO: + case T_CONTINUATION: + return (cons(sc, int_zero, max_arity)); + + case T_STRING: + return ((string_length(x) == 0) ? sc->F : cons(sc, int_one, + int_one)); + + case T_LET: + return (cons(sc, int_one, int_one)); + + case T_C_OBJECT: + check_method(sc, x, sc->arity_symbol, set_plist_1(sc, x)); + return ((is_safe_procedure(x)) ? cons(sc, int_zero, max_arity) : + sc->F); + + case T_VECTOR: + if (vector_length(x) == 0) + return (sc->F); + if (has_simple_elements(x)) + return (cons(sc, int_one, make_integer(sc, vector_rank(x)))); + return (cons(sc, int_one, max_arity)); + + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_BYTE_VECTOR: + return ((vector_length(x) == 0) ? sc->F : cons(sc, int_one, + make_integer(sc, + vector_rank + (x)))); + + case T_PAIR: + case T_HASH_TABLE: + return (cons(sc, int_one, max_arity)); + + case T_ITERATOR: + return (cons(sc, int_zero, int_zero)); + + case T_SYNTAX: + return (cons + (sc, small_int(syntax_min_args(x)), + (syntax_max_args(x) == + -1) ? max_arity : small_int(syntax_max_args(x)))); + } + return (sc->F); +} + +static s7_pointer g_arity(s7_scheme * sc, s7_pointer args) +{ +#define H_arity "(arity obj) the min and max acceptable args for obj if it is applicable, otherwise #f." +#define Q_arity s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T) + /* check_method(sc, p, sc->arity_symbol, args); */ + return (s7_arity(sc, car(args))); +} + + +/* -------------------------------- aritable? -------------------------------- */ +static bool closure_is_aritable(s7_scheme * sc, s7_pointer x, + s7_pointer x_args, int32_t args) +{ + /* x_args is unprocessed -- it is exactly the list as used in the closure definition */ + s7_int len; + + if (args == 0) + return (!is_pair(x_args)); + if (is_symbol(x_args)) /* any number of args is ok */ + return (true); + + len = closure_arity(x); + if (len == CLOSURE_ARITY_NOT_SET) { + len = s7_list_length(sc, x_args); + closure_set_arity(x, len); + } + if (len < 0) /* dotted list => rest arg, (length '(a b . c)) is -2 */ + return ((-len) <= args); /* so we have enough to take care of the required args */ + return (args == len); /* in a normal lambda list, there are no other possibilities */ +} + +static bool closure_star_is_aritable(s7_scheme * sc, s7_pointer x, + s7_pointer x_args, int32_t args) +{ + if (is_symbol(x_args)) + return (true); + closure_star_arity_1(sc, x, x_args); + return ((closure_arity(x) == -1) || (args <= closure_arity(x))); +} + +bool s7_is_aritable(s7_scheme * sc, s7_pointer x, s7_int args) +{ + switch (type(x)) { + case T_C_RST_ARGS_FUNCTION: + case T_C_FUNCTION: + return ((c_function_required_args(x) <= args) && + (c_function_all_args(x) >= args)); + + case T_C_OPT_ARGS_FUNCTION: /* any/opt req args == 0 */ + case T_C_ANY_ARGS_FUNCTION: + case T_C_FUNCTION_STAR: + return (c_function_all_args(x) >= args); + + case T_MACRO: + case T_BACRO: + case T_CLOSURE: + return (closure_is_aritable(sc, x, closure_args(x), args)); + + case T_MACRO_STAR: + case T_BACRO_STAR: + case T_CLOSURE_STAR: + return (closure_star_is_aritable(sc, x, closure_args(x), args)); + + case T_C_MACRO: + return ((c_macro_required_args(x) <= args) && + (c_macro_all_args(x) >= args)); + + case T_GOTO: + case T_CONTINUATION: + return (true); + + case T_STRING: + return ((args == 1) && (string_length(x) > 0)); /* ("" 0) -> error */ + + case T_C_OBJECT: + { + s7_pointer func; + if ((has_active_methods(sc, x)) && + ((func = + find_method_with_let(sc, x, + sc->is_aritable_symbol)) != + sc->undefined)) + return (call_method + (sc, x, func, + set_plist_2(sc, x, + make_integer(sc, args))) != sc->F); + return (is_safe_procedure(x)); + } + + case T_VECTOR: + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_BYTE_VECTOR: + return ((args > 0) && (vector_length(x) > 0) && /* (#() 0) -> error */ + (args <= vector_rank(x))); + + case T_LET: + case T_HASH_TABLE: + case T_PAIR: + return (args == 1); + + case T_ITERATOR: + return (args == 0); + + case T_SYNTAX: + return ((args >= syntax_min_args(x)) + && ((args <= syntax_max_args(x)) + || (syntax_max_args(x) == -1))); + } + return (false); +} + +static s7_pointer g_is_aritable(s7_scheme * sc, s7_pointer args) +{ +#define H_is_aritable "(aritable? obj num-args) returns #t if 'obj can be applied to 'num-args arguments." +#define Q_is_aritable s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->is_integer_symbol) + + s7_pointer n = cadr(args); + s7_int num; + + if (!s7_is_integer(n)) /* remember gmp case! */ + return (method_or_bust + (sc, n, sc->is_aritable_symbol, args, T_INTEGER, 2)); + + num = s7_integer_checked(sc, n); + if (num < 0) + return (out_of_range + (sc, sc->is_aritable_symbol, int_two, n, + its_negative_string)); + if (num > MAX_ARITY) + num = MAX_ARITY; + return (make_boolean(sc, s7_is_aritable(sc, car(args), num))); +} + +static bool is_aritable_b_7pp(s7_scheme * sc, s7_pointer f, s7_pointer i) +{ + return (g_is_aritable(sc, set_plist_2(sc, f, i)) != sc->F); +} + +static int32_t arity_to_int(s7_scheme * sc, s7_pointer x) +{ + int32_t args; + switch (type(x)) { + case T_C_OPT_ARGS_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + case T_C_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + case T_C_FUNCTION_STAR: + return (c_function_all_args(x)); + + case T_MACRO: + case T_BACRO: + case T_CLOSURE: + args = closure_arity_to_int(sc, x); + return ((args < 0) ? MAX_ARITY : args); + + case T_MACRO_STAR: + case T_BACRO_STAR: + case T_CLOSURE_STAR: + args = closure_star_arity_to_int(sc, x); + return ((args < 0) ? MAX_ARITY : args); + + case T_C_MACRO: + return (c_macro_all_args(x)); + case T_C_OBJECT: + return (MAX_ARITY); + /* do vectors et al make sense here? */ + } + return (-1); +} + + +/* -------------------------------- sequence? -------------------------------- */ +static s7_pointer g_is_sequence(s7_scheme * sc, s7_pointer args) +{ +#define H_is_sequence "(sequence? obj) returns #t if obj is a sequence (vector, string, pair, etc)" +#define Q_is_sequence sc->pl_bt + check_boolean_method(sc, is_simple_sequence, sc->is_sequence_symbol, + args); +} + +static bool is_sequence_b(s7_pointer p) +{ + return (is_simple_sequence(p)); +} + + +/* -------------------------------- setter ------------------------------------------------ */ +static s7_pointer b_simple_setter(s7_scheme * sc, int typer, + s7_pointer args) +{ + if (type(cadr(args)) == typer) + return (cadr(args)); + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_5(sc, + wrap_string(sc, + "set! ~S, ~S is ~A but should be ~A", + 34), car(args), cadr(args), + sc->prepackaged_type_names[type + (cadr(args))], + sc->prepackaged_type_names[typer]))); +} + +static s7_pointer b_is_symbol_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_SYMBOL, args)); +} + +static s7_pointer b_is_syntax_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_SYNTAX, args)); +} + +static s7_pointer b_is_let_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_LET, args)); +} + +static s7_pointer b_is_iterator_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_ITERATOR, args)); +} + +static s7_pointer b_is_c_pointer_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_C_POINTER, args)); +} + +static s7_pointer b_is_input_port_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_INPUT_PORT, args)); +} + +static s7_pointer b_is_output_port_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_OUTPUT_PORT, args)); +} + +static s7_pointer b_is_eof_object_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_EOF, args)); +} + +static s7_pointer b_is_random_state_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_RANDOM_STATE, args)); +} + +static s7_pointer b_is_char_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_CHARACTER, args)); +} + +static s7_pointer b_is_string_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_STRING, args)); +} + +static s7_pointer b_is_float_vector_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_FLOAT_VECTOR, args)); +} + +static s7_pointer b_is_int_vector_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_INT_VECTOR, args)); +} + +static s7_pointer b_is_byte_vector_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_BYTE_VECTOR, args)); +} + +static s7_pointer b_is_hash_table_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_HASH_TABLE, args)); +} + +static s7_pointer b_is_continuation_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_CONTINUATION, args)); +} + +static s7_pointer b_is_null_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_NIL, args)); +} + +static s7_pointer b_is_pair_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_PAIR, args)); +} + +static s7_pointer b_is_boolean_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_BOOLEAN, args)); +} + +static s7_pointer b_is_undefined_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_UNDEFINED, args)); +} + +static s7_pointer b_is_unspecified_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_UNSPECIFIED, args)); +} + +static s7_pointer b_is_c_object_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_C_OBJECT, args)); +} + +static s7_pointer b_is_goto_setter(s7_scheme * sc, s7_pointer args) +{ + return (b_simple_setter(sc, T_GOTO, args)); +} + +#define b_setter(sc, typer, args, str, len) \ + do { \ + if (typer(cadr(args))) \ + return(cadr(args)); \ + return(s7_error(sc, sc->wrong_type_arg_symbol, \ + set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), \ + car(args), cadr(args), sc->prepackaged_type_names[type(cadr(args))], wrap_string(sc, str, len)))); \ + } while (0) + +static s7_pointer b_is_number_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, s7_is_complex, args, "a number", 8); +} + +static s7_pointer b_is_complex_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, s7_is_complex, args, "a number", 8); +} + +static s7_pointer b_is_gensym_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, is_gensym, args, "a gensym", 8); +} + +static s7_pointer b_is_keyword_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, is_keyword, args, "a keyword", 9); +} + +static s7_pointer b_is_openlet_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, has_methods, args, "an open let", 11); +} + +static s7_pointer b_is_macro_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, is_any_macro, args, "a macro", 7); +} + +static s7_pointer b_is_integer_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, s7_is_integer, args, "an integer", 10); +} + +static s7_pointer b_is_byte_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, is_byte, args, "an unsigned byte", 16); +} + +static s7_pointer b_is_real_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, is_real, args, "a real", 6); +} + +static s7_pointer b_is_float_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, is_t_real, args, "a float", 7); +} + +static s7_pointer b_is_rational_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, is_rational, args, "a rational", 10); +} + +static s7_pointer b_is_list_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, is_list, args, "a list", 6); +} + +static s7_pointer b_is_vector_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, is_any_vector, args, "a vector", 8); +} + +static s7_pointer b_is_procedure_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, is_any_procedure, args, "a procedure", 11); +} + +static s7_pointer b_is_dilambda_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, s7_is_dilambda, args, "a dilambda", 10); +} + +static s7_pointer b_is_sequence_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, is_sequence, args, "a sequence", 10); +} + +static s7_pointer b_is_subvector_setter(s7_scheme * sc, s7_pointer args) +{ + b_setter(sc, is_subvector, args, "a subvector", 11); +} + +static s7_pointer b_is_weak_hash_table_setter(s7_scheme * sc, + s7_pointer args) +{ + b_setter(sc, is_weak_hash_table, args, "a weak hash-table", 17); +} + +static s7_pointer b_is_proper_list_setter(s7_scheme * sc, s7_pointer args) +{ + if (s7_is_proper_list(sc, car(args))) + return (cadr(args)); + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_5(sc, + wrap_string(sc, + "set! ~S, ~S is ~A but should be ~A", + 34), car(args), cadr(args), + sc->prepackaged_type_names[type + (cadr(args))], + wrap_string(sc, "a proper list", 13)))); +} + +static s7_pointer g_setter(s7_scheme * sc, s7_pointer args) +{ +#define H_setter "(setter obj let) returns the setter associated with obj" +#define Q_setter s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->T, sc->is_let_symbol) + + s7_pointer p = car(args), e; + if (is_pair(cdr(args))) { + e = cadr(args); + if (!((is_let(e)) || (e == sc->rootlet) || (e == sc->nil))) + return (wrong_type_argument + (sc, sc->setter_symbol, 2, e, T_LET)); + } else + e = sc->curlet; + + switch (type(p)) { + case T_MACRO: + case T_MACRO_STAR: + case T_BACRO: + case T_BACRO_STAR: + case T_CLOSURE: + case T_CLOSURE_STAR: + if (is_any_procedure(closure_setter(p))) /* setter already known */ + return (closure_setter(p)); + if (!closure_no_setter(p)) { + s7_pointer f; + f = funclet_entry(sc, p, sc->local_setter_symbol); /* look for +setter+, save value as closure_setter(p) */ + if (f) { + if (f == sc->F) { + closure_set_no_setter(p); + return (sc->F); + } + if (!is_any_procedure(f)) + return (s7_wrong_type_arg_error + (sc, "setter", 0, p, + "a procedure or a reasonable facsimile thereof")); + closure_set_setter(p, f); + return (f); + } + /* we used to search for setter here, but that can find the built-in setter causing an infinite loop (maybe check for that??) */ + closure_set_no_setter(p); + } + return (sc->F); + + case T_C_FUNCTION: + case T_C_FUNCTION_STAR: + case T_C_ANY_ARGS_FUNCTION: + case T_C_OPT_ARGS_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + return (c_function_setter(p)); + + case T_C_MACRO: + return (c_macro_setter(p)); + + case T_GOTO: + case T_CONTINUATION: + return (sc->F); + + case T_C_OBJECT: + check_method(sc, p, sc->setter_symbol, args); + return ((c_object_set(sc, p) == fallback_set) ? sc->F : sc->c_object_set_function); /* for example ((setter obj) obj 0 1.0) if s7test block */ + /* this could wrap the setter as an s7_function giving p's class-name etc */ + + case T_LET: + check_method(sc, p, sc->setter_symbol, args); + return (global_value(sc->let_set_symbol)); + + case T_ITERATOR: /* (set! (iter) val) doesn't fit the other setters */ + return ((is_any_closure(iterator_sequence(p))) ? + closure_setter(iterator_sequence(p)) : sc->F); + + case T_PAIR: + return (global_value(sc->list_set_symbol)); + case T_HASH_TABLE: + return (global_value(sc->hash_table_set_symbol)); + case T_STRING: + return (global_value(sc->string_set_symbol)); + case T_BYTE_VECTOR: + return (global_value(sc->byte_vector_set_symbol)); + case T_VECTOR: + return (global_value(sc->vector_set_symbol)); + case T_INT_VECTOR: + return (global_value(sc->int_vector_set_symbol)); + case T_FLOAT_VECTOR: + return (global_value(sc->float_vector_set_symbol)); + case T_SLOT: + return ((slot_has_setter(p)) ? slot_setter(p) : sc->F); + + case T_SYMBOL: /* (setter symbol let) */ + { + s7_pointer sym = car(args), slot, setter; + if (is_keyword(sym)) + return (sc->F); + + if ((e == sc->rootlet) || (e == sc->nil)) + slot = global_slot(sym); + else { + s7_pointer old_e = sc->curlet; + set_curlet(sc, e); + slot = lookup_slot_from(sym, sc->curlet); + set_curlet(sc, old_e); + } + if ((!is_slot(slot)) || (!slot_has_setter(slot))) + return (sc->F); + setter = slot_setter(slot); + if (is_bool_function(setter)) + return (c_function_setter(setter)); + return (setter); + } + } + return (s7_wrong_type_arg_error + (sc, "setter", 0, p, "something that might have a setter")); +} + +s7_pointer s7_setter(s7_scheme * sc, s7_pointer obj) +{ + return (g_setter(sc, set_plist_1(sc, obj))); +} + + +/* -------------------------------- set-setter -------------------------------- */ +static void protect_setter(s7_scheme * sc, s7_pointer sym, s7_pointer acc) +{ + s7_int loc; + if (sc->protected_setters_size == sc->protected_setters_loc) { + s7_int i, new_size, size = sc->protected_setters_size; + block_t *ob, *nb; + new_size = 2 * size; + + ob = vector_block(sc->protected_setters); + nb = reallocate(sc, ob, new_size * sizeof(s7_pointer)); + block_info(nb) = NULL; + vector_block(sc->protected_setters) = nb; + vector_elements(sc->protected_setters) = + (s7_pointer *) block_data(nb); + vector_length(sc->protected_setters) = new_size; + + ob = vector_block(sc->protected_setter_symbols); + nb = reallocate(sc, ob, new_size * sizeof(s7_pointer)); + vector_block(sc->protected_setter_symbols) = nb; + vector_elements(sc->protected_setter_symbols) = + (s7_pointer *) block_data(nb); + vector_length(sc->protected_setter_symbols) = new_size; + + for (i = size; i < new_size; i++) { + vector_element(sc->protected_setters, i) = sc->unused; + vector_element(sc->protected_setter_symbols, i) = sc->unused; + } + sc->protected_setters_size = new_size; + } + loc = sc->protected_setters_loc++; + vector_element(sc->protected_setters, loc) = acc; + vector_element(sc->protected_setter_symbols, loc) = sym; +} + +static s7_pointer g_set_setter(s7_scheme * sc, s7_pointer args) +{ + s7_pointer p = car(args), setter; + if (is_symbol(p)) { + s7_pointer sym = p, func, slot; + if (is_keyword(sym)) + return (s7_wrong_type_arg_error + (sc, "set! setter", 1, sym, + "a normal symbol (a keyword can't be set)")); + + if (is_pair(cddr(args))) { + s7_pointer e = cadr(args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) ...))) */ + func = caddr(args); + if ((e == sc->rootlet) || (e == sc->nil)) + slot = global_slot(sym); + else { + if (!is_let(e)) + return (s7_wrong_type_arg_error + (sc, "set! setter", 2, e, "a let")); + slot = lookup_slot_from(sym, e); + } + } else { + slot = lookup_slot_from(sym, sc->curlet); /* (set! (setter 'x) (lambda (s v) ...)) */ + func = cadr(args); + } + if (!is_slot(slot)) + return (sc->F); + + if (func != sc->F) { + if (sym == sc->setter_symbol) + return (immutable_object_error + (sc, + set_elist_2(sc, + wrap_string(sc, + "can't set (setter setter) to ~S", + 31), func))); + + if (!is_any_procedure(func)) /* disallow continuation/goto here */ + return (s7_wrong_type_arg_error + (sc, "set! setter", 3, func, "a function or #f")); + + if ((!is_c_function(func)) + || (!c_function_has_bool_setter(func))) { + if (s7_is_aritable(sc, func, 3)) + set_has_let_arg(func); + else if (!s7_is_aritable(sc, func, 2)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "setter function, ~A, should take 2 or 3 arguments", + 49), func))); + } + } + + if (slot == global_slot(sym)) + s7_set_setter(sc, sym, func); /* special GC protection for global vars */ + else + slot_set_setter(slot, func); /* func might be #f */ + if (func != sc->F) { + slot_set_has_setter(slot); + symbol_set_has_setter(sym); + } + return (func); + } + + if (p == sc->s7_let) + return (s7_wrong_type_arg_error + (sc, "set! setter", 1, p, "something other than *s7*")); + + setter = cadr(args); + if (setter != sc->F) { + if (!is_any_procedure(setter)) + return (s7_wrong_type_arg_error + (sc, "set! setter", 2, setter, "a procedure or #f")); + if (arity_to_int(sc, setter) < 1) /* we need at least an arg for the set! value */ + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "setter function, ~A, should take at least 1 argument", + 52), setter))); + } + + switch (type(p)) { + case T_MACRO: + case T_MACRO_STAR: + case T_BACRO: + case T_BACRO_STAR: + case T_CLOSURE: + case T_CLOSURE_STAR: + closure_set_setter(p, setter); + if (setter == sc->F) + closure_set_no_setter(p); + break; + + case T_C_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + case T_C_OPT_ARGS_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + case T_C_FUNCTION_STAR: + if (p == global_value(sc->setter_symbol)) + return (immutable_object_error + (sc, + set_elist_2(sc, + wrap_string(sc, + "can't set (setter setter) to ~S", + 31), setter))); + c_function_set_setter(p, setter); + if ((is_any_closure(setter)) || (is_any_macro(setter))) + add_setter(sc, p, setter); + break; + + case T_C_MACRO: + c_macro_set_setter(p, setter); + if ((is_any_closure(setter)) || (is_any_macro(setter))) + add_setter(sc, p, setter); + break; + + default: /* (set! (setter 4) ...) or p==continuation etc */ + return (s7_wrong_type_arg_error + (sc, "set! setter", 1, p, + "a normal procedure or a macro")); + } + return (setter); +} + +s7_pointer s7_set_setter(s7_scheme * sc, s7_pointer p, s7_pointer setter) +{ + if (is_symbol(p)) { + if (slot_has_setter(global_slot(p))) { + s7_int index; + for (index = 0; index < sc->protected_setters_loc; index++) + if (vector_element(sc->protected_setter_symbols, index) == + p) { + s7_pointer old_func; + old_func = + vector_element(sc->protected_setters, index); + if ((is_any_procedure(old_func)) && /* i.e. not #f! */ + (is_immutable(old_func))) + return (setter); + vector_element(sc->protected_setters, index) = setter; + slot_set_setter(global_slot(p), setter); + if ((setter != sc->F) + && (s7_is_aritable(sc, setter, 3))) + set_has_let_arg(setter); + return (setter); + } + } + if (setter != sc->F) { + slot_set_has_setter(global_slot(p)); + symbol_set_has_setter(p); + protect_setter(sc, p, setter); + slot_set_setter(global_slot(p), setter); + if (s7_is_aritable(sc, setter, 3)) + set_has_let_arg(setter); + return (setter); + } + slot_set_setter(global_slot(p), setter); + return (setter); + } + return (g_set_setter(sc, set_plist_2(sc, p, setter))); +} + +/* (let () (define xxx 23) (define (hix) (set! xxx 24)) (hix) (set! (setter 'xxx) (lambda (sym val) (format *stderr* "val: ~A~%" val) val)) (hix)) + * so set setter before use! + */ + +static s7_pointer call_c_function_setter(s7_scheme * sc, s7_pointer func, + s7_pointer symbol, + s7_pointer new_value) +{ + if (has_let_arg(func)) { + set_car(sc->t3_1, symbol); + set_car(sc->t3_2, new_value); + set_car(sc->t3_3, sc->curlet); + return (c_function_call(func) (sc, sc->t3_1)); + } + set_car(sc->t2_1, symbol); + set_car(sc->t2_2, new_value); + return (c_function_call(func) (sc, sc->t2_1)); +} + +static s7_pointer call_setter(s7_scheme * sc, s7_pointer slot, + s7_pointer new_value) +{ /* see also op_set1 */ + s7_pointer func = slot_setter(slot); + if (!is_any_procedure(func)) + return (new_value); + + if (is_c_function(func)) + return (call_c_function_setter + (sc, func, slot_symbol(slot), new_value)); + + push_stack_direct(sc, OP_EVAL_DONE); + sc->args = + (has_let_arg(func)) ? list_3(sc, slot_symbol(slot), new_value, + sc->curlet) : list_2(sc, + slot_symbol + (slot), + new_value); + /* safe lists here are much slower -- the setters are called more often for some reason (see tset.scm) */ + sc->code = func; + eval(sc, OP_APPLY); + return (sc->value); +} + +static s7_pointer bind_symbol_with_setter(s7_scheme * sc, opcode_t op, + s7_pointer symbol, + s7_pointer new_value) +{ + s7_pointer func; + func = g_setter(sc, set_plist_2(sc, symbol, sc->curlet)); + if (!is_any_procedure(func)) + return (new_value); + + if (is_c_function(func)) + return (call_c_function_setter(sc, func, symbol, new_value)); + + sc->args = + (has_let_arg(func)) ? list_3(sc, symbol, new_value, + sc->curlet) : list_2(sc, symbol, + new_value); + push_stack_direct(sc, op); + sc->code = func; + return (sc->no_value); /* this means the setter in set! needs to goto APPLY to get the new value */ +} + + +/* -------------------------------- hooks -------------------------------- */ +s7_pointer s7_hook_functions(s7_scheme * sc, s7_pointer hook) +{ + return (s7_symbol_local_value(sc, sc->body_symbol, closure_let(hook))); +} + +s7_pointer s7_hook_set_functions(s7_scheme * sc, s7_pointer hook, + s7_pointer functions) +{ + if (is_list(functions)) + s7_let_set(sc, closure_let(hook), sc->body_symbol, functions); + return (functions); +} + + +/* -------------------------------- eq? eqv? equal? equivalent? -------------------------------- */ +bool s7_is_eq(s7_pointer obj1, s7_pointer obj2) +{ + return ((obj1 == obj2) || /* so floats and NaNs might be eq? but not eqv? */ + ((is_unspecified(obj1)) && (is_unspecified(obj2)))); /* this is needed because this function is used by s7_b_pp */ +} + +static s7_pointer is_eq_p_pp(s7_scheme * sc, s7_pointer obj1, + s7_pointer obj2) +{ + return (make_boolean(sc, ((obj1 == obj2) + || ((is_unspecified(obj1)) + && (is_unspecified(obj2)))))); +} + +static s7_pointer g_is_eq(s7_scheme * sc, s7_pointer args) +{ +#define H_is_eq "(eq? obj1 obj2) returns #t if obj1 is eq to (the same object as) obj2" +#define Q_is_eq sc->pcl_bt + return (make_boolean(sc, ((car(args) == cadr(args)) || + ((is_unspecified(car(args))) + && (is_unspecified(cadr(args))))))); + /* (eq? (apply apply apply values '(())) #) should return #t */ +} + +bool s7_is_eqv(s7_scheme * sc, s7_pointer a, s7_pointer b) +{ +#if WITH_GMP + if ((is_big_number(a)) || (is_big_number(b))) + return (big_numbers_are_eqv(sc, a, b)); +#endif + if (type(a) != type(b)) + return (false); + if ((a == b) && (!is_number(a))) /* if a is NaN, a == b doesn't mean (eqv? a b) */ + return (true); /* a == b means (let ((x "a")) (let ((y x)) (eqv? x y))) is #t */ + if (is_number(a)) + return (numbers_are_eqv(sc, a, b)); + if (is_unspecified(a)) /* types are the same so we know b is also unspecified */ + return (true); + return (false); +} + +static s7_pointer g_is_eqv(s7_scheme * sc, s7_pointer args) +{ +#define H_is_eqv "(eqv? obj1 obj2) returns #t if obj1 is equivalent to obj2" +#define Q_is_eqv sc->pcl_bt + return (make_boolean(sc, s7_is_eqv(sc, car(args), cadr(args)))); +} + +static s7_pointer is_eqv_p_pp(s7_scheme * sc, s7_pointer obj1, + s7_pointer obj2) +{ + return (make_boolean(sc, s7_is_eqv(sc, obj1, obj2))); +} + +static bool floats_are_equivalent_1(s7_scheme * sc, s7_double x, + s7_double y, s7_double eps) +{ + s7_double diff; + if (x == y) + return (true); + diff = fabs(x - y); + if (diff <= eps) + return (true); + return (((is_NaN(x)) || (is_NaN(y))) && ((is_NaN(x)) && (is_NaN(y)))); +} + +static bool floats_are_equivalent(s7_scheme * sc, s7_double x, s7_double y) +{ + return (floats_are_equivalent_1 + (sc, x, y, sc->equivalent_float_epsilon)); +} + +#if WITH_GMP +static bool big_floats_are_equivalent(s7_scheme * sc, mpfr_t x, mpfr_t y) +{ + /* protect mpfr_1 */ + if ((mpfr_nan_p(x)) || (mpfr_nan_p(y))) + return ((mpfr_nan_p(x)) && (mpfr_nan_p(y))); + mpfr_sub(sc->mpfr_3, x, y, MPFR_RNDN); + mpfr_abs(sc->mpfr_3, sc->mpfr_3, MPFR_RNDN); + return (mpfr_cmp_d(sc->mpfr_3, sc->equivalent_float_epsilon) <= 0); +} +#endif + +static bool eq_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + return (x == y); +} + +static bool symbol_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if (x == y) + return (true); + if (!is_normal_symbol(y)) + return (false); /* (equivalent? ''(1) '(1)) */ + return ((is_slot(global_slot(x))) && /* the optimizer can replace the original symbol with its own */ + (is_syntax(global_value(x))) && + (is_slot(global_slot(y))) && + (is_syntax(global_value(y))) && + (syntax_symbol(global_value(x)) == + syntax_symbol(global_value(y)))); +} + +static bool unspecified_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + return (is_unspecified(y)); +} + +static bool undefined_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if (x == y) + return (true); + if ((!is_undefined(y)) + || (undefined_name_length(x) != undefined_name_length(y))) + return (false); + return (safe_strcmp(undefined_name(x), undefined_name(y))); +} + +static bool is_equal_1(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + return ((*(equals[type(x)])) (sc, x, y, ci)); +} + +static bool is_equivalent_1(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + return ((*(equivalents[type(x)])) (sc, x, y, ci)); +} + +static bool c_pointer_equivalent(s7_scheme * sc, s7_pointer x, + s7_pointer y, shared_info_t * ci) +{ + shared_info_t *nci = ci; + if (x == y) + return (true); + if (!s7_is_c_pointer(y)) + return (false); + if (c_pointer(x) != c_pointer(y)) + return (false); + if (c_pointer_type(x) != c_pointer_type(y)) { + if (!nci) + nci = new_shared_info(sc); + if (!is_equivalent_1 + (sc, c_pointer_type(x), c_pointer_type(y), nci)) + return (false); + } + if (c_pointer_info(x) != c_pointer_info(y)) { + if (!nci) + nci = new_shared_info(sc); + if (!is_equivalent_1 + (sc, c_pointer_info(x), c_pointer_info(y), nci)) + return (false); + } + return (true); +} + +static bool c_pointer_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + shared_info_t *nci = ci; + if (x == y) + return (true); + if (!s7_is_c_pointer(y)) + return (false); + if (c_pointer(x) != c_pointer(y)) + return (false); + if (c_pointer_type(x) != c_pointer_type(y)) { + if (!nci) + nci = new_shared_info(sc); + if (!is_equal_1(sc, c_pointer_type(x), c_pointer_type(y), nci)) + return (false); + } + if (c_pointer_info(x) != c_pointer_info(y)) { + if (!nci) + nci = new_shared_info(sc); + if (!is_equal_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) + return (false); + } + return (true); +} + +static bool string_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + return ((is_string(y)) && (scheme_strings_are_equal(x, y))); +} + +static bool syntax_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + return ((is_syntax(y)) && (syntax_symbol(x) == syntax_symbol(y))); +} + +static bool port_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + return (x == y); +} + +static bool port_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if (x == y) + return (true); + if (type(x) != type(y)) + return (false); + if ((port_is_closed(x)) && (port_is_closed(y))) + return (true); + if ((port_is_closed(x)) || (port_is_closed(y))) + return (false); /* if either is closed, port_port (below) might be null */ + if (port_type(x) != port_type(y)) + return (false); + switch (port_type(x)) { + case STRING_PORT: + return ((port_position(x) == port_position(y)) && + (port_data_size(x) == port_data_size(y)) && + (local_strncmp + ((const char *) port_data(x), (const char *) port_data(y), + (is_input_port(x)) ? port_data_size(x) : + port_position(x)))); + case FILE_PORT: + return ((is_input_port(x)) && + (port_position(x) == port_position(y)) && + (local_strncmp + ((const char *) port_filename(x), + (const char *) port_filename(y), + port_filename_length(x)))); + case FUNCTION_PORT: + if (is_input_port(x)) + return (port_input_function(x) == port_input_function(y)); + return (port_output_function(x) == port_output_function(y)); + } + return (false); +} + +static void add_shared_ref(shared_info_t * ci, s7_pointer x, int32_t ref_x) +{ + /* called only in equality check, not printer */ + if (ci->top == ci->size) + enlarge_shared_info(ci); + set_collected(x); + ci->objs[ci->top] = x; + ci->refs[ci->top++] = ref_x; +} + +static Inline bool equal_ref(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + /* here we know x and y are pointers to the same type of structure */ + int32_t ref_y; + ref_y = (is_collected(y)) ? peek_shared_ref_1(ci, y) : 0; + if (is_collected(x)) { + int32_t ref_x; + ref_x = peek_shared_ref_1(ci, x); + if (ref_y != 0) + return (ref_x == ref_y); /* this is a change from the macro version 16-Jan-20 -- only true returns from the caller */ + /* try to harmonize the new guy -- there can be more than one structure equal to the current one */ + if (ref_x != 0) + add_shared_ref(ci, y, ref_x); + } else if (ref_y != 0) + add_shared_ref(ci, x, ref_y); + else { + /* assume neither x nor y is in the table, and that they should share a ref value, called only in equality check, not printer. */ + if (ci->top >= ci->size2) + enlarge_shared_info(ci); + set_collected(x); + set_collected(y); + ci->objs[ci->top] = x; + ci->refs[ci->top++] = ++ci->ref; + ci->objs[ci->top] = y; + ci->refs[ci->top++] = ci->ref; + } + return (false); +} + +static bool c_objects_are_equal(s7_scheme * sc, s7_pointer a, s7_pointer b, + shared_info_t * ci) +{ + s7_pointer(*to_list) (s7_scheme * sc, s7_pointer args); + shared_info_t *nci = ci; + s7_pointer pa, pb; + + if (a == b) + return (true); + if (!is_c_object(b)) + return (false); + if (c_object_type(a) != c_object_type(b)) + return (false); + + if (c_object_equal(sc, a)) + return (((*(c_object_equal(sc, a))) (sc, set_plist_2(sc, a, b))) != + sc->F); + if (c_object_eql(sc, a)) + return ((*(c_object_eql(sc, a))) + (c_object_value(a), c_object_value(b))); + + to_list = c_object_to_list(sc, a); + if (!to_list) + return (false); + if (ci) { + if (equal_ref(sc, a, b, ci)) + return (true); /* and nci == ci above */ + } else + nci = new_shared_info(sc); + + for (pa = to_list(sc, set_plist_1(sc, a)), pb = + to_list(sc, set_plist_1(sc, b)); is_pair(pa) && (is_pair(pb)); + pa = cdr(pa), pb = cdr(pb)) + if (!(is_equal_1(sc, car(pa), car(pb), nci))) + return (false); + return (pa == pb); /* presumably both are nil if successful */ +} + +#define check_equivalent_method(Sc, X, Y) \ + do { \ + if (has_active_methods(sc, X)) \ + { \ + s7_pointer equal_func; \ + equal_func = find_method_with_let(Sc, X, Sc->is_equivalent_symbol); \ + if (equal_func != Sc->undefined) \ + return(s7_boolean(Sc, call_method(Sc, X, equal_func, set_plist_2(Sc, X, Y)))); \ + }} \ + while (0) + +static bool c_objects_are_equivalent(s7_scheme * sc, s7_pointer x, + s7_pointer y, shared_info_t * ci) +{ + check_equivalent_method(sc, x, y); + if (c_object_equivalent(sc, x)) + return (((*(c_object_equivalent(sc, x))) + (sc, set_plist_2(sc, x, y))) != sc->F); + return (c_objects_are_equal(sc, x, y, ci)); +} + +static bool hash_table_equal_1(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci, bool equivalent) +{ + hash_entry_t **lists; + s7_int i, len; + shared_info_t *nci = ci; + hash_check_t hf; + bool (*eqf)(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci); + + if (x == y) + return (true); + if (!is_hash_table(y)) { + if (equivalent) + check_equivalent_method(sc, y, x); + return (false); + } + if ((ci) && (equal_ref(sc, x, y, ci))) + return (true); + + if (hash_table_entries(x) != hash_table_entries(y)) + return (false); + if (hash_table_entries(x) == 0) + return (true); + if ((!equivalent) + && ((hash_table_checker_locked(x)) + || (hash_table_checker_locked(y)))) { + if (hash_table_checker(x) != hash_table_checker(y)) + return (false); + if (hash_table_mapper(x) != hash_table_mapper(y)) + return (false); + } + + len = hash_table_mask(x) + 1; + lists = hash_table_elements(x); + if (!nci) + nci = new_shared_info(sc); + eqf = (equivalent) ? is_equivalent_1 : is_equal_1; + + hf = hash_table_checker(y); + if ((hf != hash_equal) && (hf != hash_equivalent)) { + for (i = 0; i < len; i++) { + hash_entry_t *p; + for (p = lists[i]; p; p = hash_entry_next(p)) { + hash_entry_t *y_val; + y_val = hf(sc, y, hash_entry_key(p)); + if (y_val == sc->unentry) + return (false); + if (!eqf + (sc, hash_entry_value(p), hash_entry_value(y_val), + nci)) + return (false); + } + } + /* if we get here, every key/value in x has a corresponding key/value in y, and the number of entries match, + * so surely the tables are equal?? + * if ci not null or hash-table-checker is equal/eqivalent, can't use hf? + */ + return (true); + } + + /* we need to protect the current shared_info data (nci) here so the current hash_table_checker won't work -- + * outside equal?/eqivalent? they can safely assume that they can start a new shared_info process. + */ + for (i = 0; i < len; i++) { + hash_entry_t *p; + for (p = lists[i]; p; p = hash_entry_next(p)) { + hash_entry_t *xe; + s7_int hash, loc; + s7_pointer key = hash_entry_key(p); + + hash = hash_loc(sc, y, key); + loc = hash & hash_table_mask(y); + + for (xe = hash_table_element(y, loc); xe; + xe = hash_entry_next(xe)) + if (hash_entry_raw_hash(xe) == hash) + if (eqf(sc, hash_entry_key(xe), key, nci)) + break; + if (!xe) + return (false); + if (!eqf(sc, hash_entry_value(p), hash_entry_value(xe), nci)) + return (false); + } + } + return (true); +} + +static bool hash_table_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + return (hash_table_equal_1(sc, x, y, ci, false)); +} + +static bool hash_table_equivalent(s7_scheme * sc, s7_pointer x, + s7_pointer y, shared_info_t * ci) +{ + return (hash_table_equal_1(sc, x, y, ci, true)); +} + +static bool slots_match(s7_scheme * sc, s7_pointer px, s7_pointer y, + shared_info_t * nci) +{ + s7_pointer ey, py; + for (ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) + for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) + if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */ + return (is_equal_1 + (sc, slot_value(px), slot_value(py), nci)); + return (false); +} + +static bool slots_equivalent_match(s7_scheme * sc, s7_pointer px, + s7_pointer y, shared_info_t * nci) +{ + s7_pointer ey, py; + for (ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) + for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) + if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */ + return (is_equivalent_1 + (sc, slot_value(px), slot_value(py), nci)); + return (false); +} + +static bool let_equal_1(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci, bool equivalent) +{ + s7_pointer ex, ey, px, py; + shared_info_t *nci = ci; + int32_t x_len, y_len; + + if (!is_let(y)) + return (false); + + if ((x == sc->rootlet) || (y == sc->rootlet)) + return (false); + + if ((ci) && (equal_ref(sc, x, y, ci))) + return (true); + + clear_symbol_list(sc); + for (x_len = 0, ex = x; is_let(T_Lid(ex)); ex = let_outlet(ex)) + for (px = let_slots(ex); tis_slot(px); px = next_slot(px)) + if (!symbol_is_in_list(sc, slot_symbol(px))) { + add_symbol_to_list(sc, slot_symbol(px)); + x_len++; + } + + for (ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) + for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) + if (!symbol_is_in_list(sc, slot_symbol(py))) /* symbol in y, not in x */ + return (false); + + for (y_len = 0, ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) + for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) + if (symbol_tag(slot_symbol(py)) != 0) { + y_len++; + symbol_set_tag(slot_symbol(py), 0); + } + + if (x_len != y_len) /* symbol in x, not in y */ + return (false); + + if (!nci) + nci = new_shared_info(sc); + + for (ex = x; is_let(T_Lid(ex)); ex = let_outlet(ex)) + for (px = let_slots(ex); tis_slot(px); px = next_slot(px)) + if (symbol_tag(slot_symbol(px)) == 0) { /* unshadowed */ + symbol_set_tag(slot_symbol(px), sc->syms_tag); /* values don't match */ + if (((!equivalent) && (!slots_match(sc, px, y, nci))) || + ((equivalent) + && (!slots_equivalent_match(sc, px, y, nci)))) + return (false); + } + return (true); +} + +static bool let_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + /* x == y if all unshadowed vars match, leaving aside the rootlet, so that for any local variable, we get the same value in either x or y. */ + return ((x == y) || (let_equal_1(sc, x, y, ci, false))); +} + +/* what should these do if there are setters? */ +static bool let_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if (x == y) + return (true); + if (!is_global(sc->is_equivalent_symbol)) { + check_equivalent_method(sc, x, y); + check_equivalent_method(sc, y, x); + } + return (let_equal_1(sc, x, y, ci, true)); +} + +static bool closure_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if (x == y) + return (true); + if (type(x) != type(y)) + return (false); + if ((has_active_methods(sc, x)) && (has_active_methods(sc, y))) { + s7_pointer equal_func; + equal_func = find_method(sc, closure_let(x), sc->is_equal_symbol); + if (equal_func != sc->undefined) + return (s7_boolean + (sc, + call_method(sc, x, equal_func, + set_plist_2(sc, x, y)))); + } + return (false); +} + +static bool closure_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if (x == y) + return (true); + if (type(x) != type(y)) + return (false); + if (has_active_methods(sc, y)) + check_equivalent_method(sc, x, y); + /* not sure about this -- we can't simply check let_equal(closure_let(x), closure_let(y)) + * because locally defined constant functions on the second pass find the outer let. + */ + return ((is_equivalent_1(sc, closure_args(x), closure_args(y), ci)) && + (is_equivalent_1(sc, closure_body(x), closure_body(y), ci))); +} + +static bool pair_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + s7_pointer px, py; + if (x == y) + return (true); + if (!is_pair(y)) + return (false); + if (!ci) + ci = new_shared_info(sc); + else if (equal_ref(sc, x, y, ci)) + return (true); + + if (!is_equal_1(sc, car(x), car(y), ci)) + return (false); + for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); + px = cdr(px), py = cdr(py)) { + if (!is_equal_1(sc, car(px), car(py), ci)) + return (false); + if (equal_ref(sc, px, py, ci)) + return (true); + } + return ((px == py) || (is_equal_1(sc, px, py, ci))); +} + +static bool pair_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + s7_pointer px, py; + if (x == y) + return (true); + if (!is_pair(y)) { + check_equivalent_method(sc, y, x); + return (false); + } + if (!ci) + ci = new_shared_info(sc); + else if (equal_ref(sc, x, y, ci)) + return (true); + + if (!is_equivalent_1(sc, car(x), car(y), ci)) + return (false); + for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); + px = cdr(px), py = cdr(py)) { + if (!is_equivalent_1(sc, car(px), car(py), ci)) + return (false); + if (equal_ref(sc, px, py, ci)) + return (true); + } + return ((px == py) || ((is_equivalent_1(sc, px, py, ci)))); +} + +static bool vector_rank_match(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + s7_int x_dims; + s7_int j; + + if (!vector_has_dimension_info(x)) + return ((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1)); + x_dims = vector_ndims(x); + if (x_dims == 1) + return ((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1)); + + if ((!vector_has_dimension_info(y)) || (x_dims != vector_ndims(y))) + return (false); + + for (j = 0; j < x_dims; j++) + if (vector_dimension(x, j) != vector_dimension(y, j)) + return (false); + return (true); +} + +static bool iv_meq(s7_int * ex, s7_int * ey, s7_int len) +{ + s7_int i = 0, left = len - 8; + while (i <= left) + LOOP_8(if (ex[i] != ey[i]) return (false); i++); + for (; i < len; i++) + if (ex[i] != ey[i]) + return (false); + return (true); +} + +static bool byte_vector_equal_1(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + s7_int i, len = vector_length(x); + uint8_t *xp = byte_vector_bytes(x), *yp = byte_vector_bytes(y); + for (i = 0; i < len; i++) + if (xp[i] != yp[i]) + return (false); + return (true); +} + +static bool biv_meq(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + s7_int i, len = vector_length(x); + uint8_t *xp; + s7_int *yp; + if (len != vector_length(y)) + return (false); + xp = byte_vector_bytes(x); + yp = int_vector_ints(y); + for (i = 0; i < len; i++) + if ((s7_int) (xp[i]) != yp[i]) + return (false); + return (true); +} + +#define base_vector_equal(sc, x, y) \ + do { \ + if (x == y) return(true); \ + len = vector_length(x); \ + if (len != vector_length(y)) return(false); \ + if (!vector_rank_match(sc, x, y)) return(false); \ + if (len == 0) return(true); \ + } while (0) + +static bool vector_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + s7_int i, len; + shared_info_t *nci = ci; + + if (!is_any_vector(y)) + return (false); + base_vector_equal(sc, x, y); + if (type(x) != type(y)) { + if ((is_int_vector(x)) && (is_byte_vector(y))) + return (biv_meq(sc, y, x, NULL)); + if ((is_byte_vector(x)) && (is_int_vector(y))) + return (biv_meq(sc, x, y, NULL)); + for (i = 0; i < len; i++) + if (!is_equal_1(sc, vector_getter(x) (sc, x, i), vector_getter(y) (sc, y, i), NULL)) /* this could be greatly optimized */ + return (false); + return (true); + } + if (!has_simple_elements(x)) { + if (ci) { + if (equal_ref(sc, x, y, ci)) + return (true); + } else + nci = new_shared_info(sc); + } + for (i = 0; i < len; i++) + if (! + (is_equal_1 + (sc, vector_element(x, i), vector_element(y, i), nci))) + return (false); + return (true); +} + +static bool byte_vector_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + s7_int len; + if (!is_byte_vector(y)) + return (vector_equal(sc, x, y, ci)); + base_vector_equal(sc, x, y); + return (byte_vector_equal_1(sc, x, y)); +} + +static bool int_vector_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + s7_int len; + if (!is_int_vector(y)) + return (vector_equal(sc, x, y, ci)); + base_vector_equal(sc, x, y); + return (iv_meq(int_vector_ints(x), int_vector_ints(y), len)); +} + +static bool float_vector_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + s7_int i, len; + if (!is_float_vector(y)) + return (vector_equal(sc, x, y, ci)); + base_vector_equal(sc, x, y); + for (i = 0; i < len; i++) { + s7_double z; + z = float_vector(x, i); + if ((is_NaN(z)) || (z != float_vector(y, i))) + return (false); + } + return (true); +} + +static bool vector_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + /* if this is split like vector_equal above, remember it is called by iterator_equal_1 below */ + s7_int i, len; + shared_info_t *nci = ci; + + if (x == y) + return (true); + if (!is_any_vector(y)) { + check_equivalent_method(sc, y, x); + return (false); + } + len = vector_length(x); + if (len != vector_length(y)) + return (false); + if (len == 0) + return (true); + if (!vector_rank_match(sc, x, y)) + return (false); + + if (type(x) != type(y)) { + /* (equivalent? (make-int-vector 3 0) (make-vector 3 0)) -> #t + * (equivalent? (make-float-vector 3 1.0) (vector 1 1 1)) -> #t + */ + if ((is_int_vector(x)) && (is_byte_vector(y))) + return (biv_meq(sc, y, x, NULL)); + if ((is_byte_vector(x)) && (is_int_vector(y))) + return (biv_meq(sc, x, y, NULL)); + for (i = 0; i < len; i++) + if (!is_equivalent_1(sc, vector_getter(x) (sc, x, i), vector_getter(y) (sc, y, i), NULL)) /* this could be greatly optimized */ + return (false); + return (true); + } + + if (is_float_vector(x)) { + s7_double *arr1 = float_vector_floats(x), *arr2 = + float_vector_floats(y); + s7_double fudge = sc->equivalent_float_epsilon; + if (fudge == 0.0) { + for (i = 0; i < len; i++) + if ((arr1[i] != arr2[i]) && + ((!is_NaN(arr1[i])) || (!is_NaN(arr2[i])))) + return (false); + } else + for (i = 0; i < len; i++) + if (!floats_are_equivalent(sc, arr1[i], arr2[i])) + return (false); + return (true); + } + if (is_int_vector(x)) + return (iv_meq(int_vector_ints(x), int_vector_ints(y), len)); + if (is_byte_vector(x)) + return (byte_vector_equal_1(sc, x, y)); + + if (!has_simple_elements(x)) { + if (ci) { + if (equal_ref(sc, x, y, ci)) + return (true); + } else + nci = new_shared_info(sc); + } + for (i = 0; i < len; i++) + if (! + (is_equivalent_1 + (sc, vector_element(x, i), vector_element(y, i), nci))) + return (false); + return (true); +} + +static bool iterator_equal_1(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci, bool equivalent) +{ + s7_pointer x_seq, y_seq, xs, ys; + + if (x == y) + return (true); + if (!is_iterator(y)) + return (false); + + x_seq = iterator_sequence(x); + y_seq = iterator_sequence(y); + + switch (type(x_seq)) { + case T_STRING: + return ((is_string(y_seq)) && + (iterator_position(x) == iterator_position(y)) && + (iterator_length(x) == iterator_length(y)) && + (string_equal(sc, x_seq, y_seq, ci))); + + case T_VECTOR: + case T_INT_VECTOR: + case T_BYTE_VECTOR: + case T_FLOAT_VECTOR: + return ((is_any_vector(y_seq)) && + (iterator_position(x) == iterator_position(y)) && + (iterator_length(x) == iterator_length(y)) && + ((equivalent) ? (vector_equivalent(sc, x_seq, y_seq, ci)) : + ((is_normal_vector(x_seq)) + ? (vector_equal(sc, x_seq, y_seq, ci)) + : ((is_float_vector(x_seq)) + ? (float_vector_equal(sc, x_seq, y_seq, ci)) + : ((is_int_vector(x_seq)) + ? (int_vector_equal(sc, x_seq, y_seq, ci)) + : (byte_vector_equal(sc, x_seq, y_seq, ci))))))); + + /* iterator_next is a function (pair_iterate, iterator_finished etc) */ + case T_PAIR: + if (iterator_next(x) != iterator_next(y)) + return (false); /* even if seqs are equal, one might be at end */ + if (equivalent) { + if (!pair_equivalent(sc, x_seq, y_seq, ci)) + return (false); + } else if (!pair_equal(sc, x_seq, y_seq, ci)) + return (false); + + for (xs = x_seq, ys = y_seq; is_pair(xs) && is_pair(ys); + xs = cdr(xs), ys = cdr(ys)) + if (xs == iterator_current(x)) + return (ys == iterator_current(y)); + return (is_null(xs) && is_null(ys)); + + case T_NIL: /* (make-iterator #()) works, so () should too */ + return (is_null(y_seq)); /* perhaps for equivalent case, check position in y as well as pair(seq(y))? */ + + case T_C_OBJECT: + if ((is_c_object(y_seq)) && + (iterator_position(x) == iterator_position(y)) && + (iterator_length(x) == iterator_length(y))) { + if (equivalent) + return (c_objects_are_equivalent(sc, x_seq, y_seq, ci)); + return (c_objects_are_equal(sc, x_seq, y_seq, ci)); + } + return (false); + + case T_LET: + if (!is_let(y_seq)) + return (false); + if (iterator_next(x) != iterator_next(y)) + return (false); + if (x_seq == sc->rootlet) + return (iterator_position(x) == iterator_position(y)); /* y_seq must also be sc->rootlet since nexts are the same (rootlet_iterate) */ + if (equivalent) { + if (!let_equivalent(sc, x_seq, y_seq, ci)) + return (false); + } else if (!let_equal(sc, x_seq, y_seq, ci)) + return (false); + + for (xs = let_slots(x_seq), ys = let_slots(y_seq); + tis_slot(xs) && tis_slot(ys); + xs = next_slot(xs), ys = next_slot(ys)) + if (xs == iterator_current_slot(x)) + return (ys == iterator_current_slot(y)); + return (is_slot_end(xs) && is_slot_end(ys)); + + case T_HASH_TABLE: + if (!is_hash_table(y_seq)) + return (false); + if (hash_table_entries(x_seq) != hash_table_entries(y_seq)) + return (false); + if (hash_table_entries(x_seq) == 0) + return (true); + if (iterator_position(x) != iterator_position(y)) + return (false); + if (!equivalent) + return (hash_table_equal(sc, x_seq, y_seq, ci)); + return (hash_table_equivalent(sc, x_seq, y_seq, ci)); + + case T_CLOSURE: + case T_CLOSURE_STAR: + return (x_seq == y_seq); /* or closure_equal/equivalent? */ + + default: + break; + } + return (false); +} + +static bool iterator_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + return (iterator_equal_1(sc, x, y, ci, false)); +} + +static bool iterator_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + return (iterator_equal_1(sc, x, y, ci, true)); +} + +#if WITH_GMP +static bool big_integer_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + /* (equal? 1 1.0) -> #f */ + if (is_t_big_integer(y)) + return (mpz_cmp(big_integer(x), big_integer(y)) == 0); + return ((is_t_integer(y)) + && (mpz_cmp_si(big_integer(x), integer(y)) == 0)); +} + +static bool big_ratio_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if (is_t_big_ratio(y)) + return (mpq_equal(big_ratio(x), big_ratio(y))); + if (is_t_ratio(y)) + return ((numerator(y) == mpz_get_si(mpq_numref(big_ratio(x)))) && + (denominator(y) == mpz_get_si(mpq_denref(big_ratio(x))))); + return (false); +} + +static bool big_real_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if (is_t_big_real(y)) + return (mpfr_equal_p(big_real(x), big_real(y))); + if (is_t_real(y)) { + if (mpfr_nan_p(big_real(x))) + return (false); + return ((!is_NaN(real(y))) && + (mpfr_cmp_d(big_real(x), real(y)) == 0)); + } + return (false); +} + +static bool big_complex_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if ((mpfr_nan_p(mpc_realref(big_complex(x)))) + || (mpfr_nan_p(mpc_imagref(big_complex(x))))) + return (false); + if (is_t_big_complex(y)) + return ((!mpfr_nan_p(mpc_realref(big_complex(y)))) && + (!mpfr_nan_p(mpc_imagref(big_complex(y)))) && + (mpc_cmp(big_complex(x), big_complex(y)) == 0)); + if (is_t_complex(y)) + return ((!is_NaN(real_part(y))) && + (!is_NaN(imag_part(y))) && + (mpfr_cmp_d(mpc_realref(big_complex(x)), real_part(y)) == + 0) + && (mpfr_cmp_d(mpc_imagref(big_complex(x)), imag_part(y)) + == 0)); + return (false); +} +#endif + +static bool integer_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if (is_t_integer(y)) + return (integer(x) == integer(y)); +#if WITH_GMP + if (is_t_big_integer(y)) + return (mpz_cmp_si(big_integer(y), integer(x)) == 0); +#endif + return (false); +} + +/* apparently ratio_equal is predefined in g++ -- name collision on mac */ +static bool fraction_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if (is_t_ratio(y)) + return ((numerator(x) == numerator(y)) && + (denominator(x) == denominator(y))); +#if WITH_GMP + if (is_t_big_ratio(y)) + return ((numerator(x) == mpz_get_si(mpq_numref(big_ratio(y)))) && + (denominator(x) == mpz_get_si(mpq_denref(big_ratio(y))))); +#endif + return (false); +} + +static bool real_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if (is_t_real(y)) + return (real(x) == real(y)); +#if WITH_GMP + if (is_t_big_real(y)) + return ((!is_NaN(real(x))) && + (!mpfr_nan_p(big_real(y))) && + (mpfr_cmp_d(big_real(y), real(x)) == 0)); +#endif + return (false); +} + +static bool complex_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + if (is_t_complex(y)) + return ((real_part(x) == real_part(y)) && + (imag_part(x) == imag_part(y))); +#if WITH_GMP + if (is_t_big_complex(y)) { + if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) || + (mpfr_nan_p(mpc_realref(big_complex(y)))) + || (mpfr_nan_p(mpc_imagref(big_complex(y))))) + return (false); + return ((mpfr_cmp_d(mpc_realref(big_complex(y)), real_part(x)) == + 0) + && (mpfr_cmp_d(mpc_imagref(big_complex(y)), imag_part(x)) + == 0)); + } +#endif + return (false); +} + +#if WITH_GMP +static bool big_integer_or_ratio_equivalent(s7_scheme * sc, s7_pointer x, + s7_pointer y, + shared_info_t * ci, + bool int_case) +{ + if (int_case) + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + else + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + + switch (type(y)) { + case T_INTEGER: + if (int_case) + return (mpz_cmp_si(big_integer(x), integer(y)) == 0); + mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); + case T_RATIO: + mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); + case T_REAL: + mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); + case T_COMPLEX: + mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN); + if (!big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) + return (false); + if (is_NaN(imag_part(y))) + return (false); + mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, imag_part(y), MPFR_RNDN); + return (mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) <= 0); + case T_BIG_INTEGER: + if (int_case) + return (mpz_cmp(big_integer(x), big_integer(y)) == 0); + mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); + case T_BIG_REAL: + return (big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); + case T_BIG_COMPLEX: + if (big_floats_are_equivalent + (sc, sc->mpfr_1, mpc_realref(big_complex(y)))) { + if (mpfr_nan_p(mpc_imagref(big_complex(y)))) + return (false); + mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, + MPFR_RNDN); + return (mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= + 0); + } + } + return (false); +} + +static bool big_integer_equivalent(s7_scheme * sc, s7_pointer x, + s7_pointer y, shared_info_t * ci) +{ + return (big_integer_or_ratio_equivalent(sc, x, y, ci, true)); +} + +static bool big_ratio_equivalent(s7_scheme * sc, s7_pointer x, + s7_pointer y, shared_info_t * ci) +{ + return (big_integer_or_ratio_equivalent(sc, x, y, ci, false)); +} + + +static bool big_real_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + switch (type(y)) { + case T_INTEGER: + mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); + case T_RATIO: + mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); + case T_REAL: + mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); + case T_COMPLEX: + mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN); + if (!big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)) + return (false); + if (is_NaN(imag_part(y))) + return (false); + mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, imag_part(y), MPFR_RNDN); + return (mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) <= 0); + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); + case T_BIG_REAL: + return (big_floats_are_equivalent(sc, big_real(x), big_real(y))); + case T_BIG_COMPLEX: + if (big_floats_are_equivalent + (sc, big_real(x), mpc_realref(big_complex(y)))) { + if (mpfr_nan_p(mpc_imagref(big_complex(y)))) + return (false); + mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, + MPFR_RNDN); + return (mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= + 0); + } + } + return (false); +} + +static bool big_complex_equivalent(s7_scheme * sc, s7_pointer x, + s7_pointer y, shared_info_t * ci) +{ + mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); + switch (type(y)) { + case T_INTEGER: + mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN); + return ((big_floats_are_equivalent + (sc, mpc_realref(big_complex(x)), sc->mpfr_2)) + && + (big_floats_are_equivalent + (sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + case T_RATIO: + mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN); + return ((big_floats_are_equivalent + (sc, mpc_realref(big_complex(x)), sc->mpfr_2)) + && + (big_floats_are_equivalent + (sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + case T_REAL: + mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); + return ((big_floats_are_equivalent + (sc, mpc_realref(big_complex(x)), sc->mpfr_2)) + && + (big_floats_are_equivalent + (sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + case T_COMPLEX: + mpfr_set_d(sc->mpfr_1, imag_part(y), MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN); + return ((big_floats_are_equivalent + (sc, mpc_realref(big_complex(x)), sc->mpfr_2)) + && + (big_floats_are_equivalent + (sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); + return ((big_floats_are_equivalent + (sc, mpc_realref(big_complex(x)), sc->mpfr_2)) + && + (big_floats_are_equivalent + (sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); + return ((big_floats_are_equivalent + (sc, mpc_realref(big_complex(x)), sc->mpfr_2)) + && + (big_floats_are_equivalent + (sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + case T_BIG_REAL: + return ((big_floats_are_equivalent + (sc, mpc_realref(big_complex(x)), big_real(y))) + && + (big_floats_are_equivalent + (sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + case T_BIG_COMPLEX: + return ((big_floats_are_equivalent + (sc, mpc_realref(big_complex(x)), + mpc_realref(big_complex(y)))) + && + (big_floats_are_equivalent + (sc, mpc_imagref(big_complex(x)), + mpc_imagref(big_complex(y))))); + } + return (false); +} + +static bool both_floats_are_equivalent(s7_scheme * sc, s7_pointer y) +{ + if (!big_floats_are_equivalent + (sc, sc->mpfr_1, mpc_realref(big_complex(y)))) + return (false); + if (mpfr_nan_p(mpc_imagref(big_complex(y)))) + return (false); + mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); + return (mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0); +} +#endif + +static bool integer_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + switch (type(y)) { + case T_INTEGER: + return (integer(x) == integer(y)); + case T_RATIO: + return (floats_are_equivalent + (sc, (double) integer(x), fraction(y))); + case T_REAL: + return (floats_are_equivalent(sc, (double) integer(x), real(y))); + case T_COMPLEX: + return ((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) && + (floats_are_equivalent + (sc, (double) integer(x), real_part(y)))); +#if WITH_GMP + case T_BIG_INTEGER: + return (mpz_cmp_si(big_integer(y), integer(x)) == 0); + case T_BIG_RATIO: + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); + case T_BIG_REAL: + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); + case T_BIG_COMPLEX: + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + return (both_floats_are_equivalent(sc, y)); +#endif + } + return (false); +} + +static bool fraction_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + switch (type(y)) { + case T_INTEGER: + return (floats_are_equivalent + (sc, (double) fraction(x), integer(y))); + case T_RATIO: + return (floats_are_equivalent + (sc, (double) fraction(x), fraction(y))); + case T_REAL: + return (floats_are_equivalent(sc, (double) fraction(x), real(y))); + case T_COMPLEX: + return ((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) && + (floats_are_equivalent(sc, fraction(x), real_part(y)))); +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, fraction(x), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN); + mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); + case T_BIG_REAL: + mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); + case T_BIG_COMPLEX: + mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN); + return (both_floats_are_equivalent(sc, y)); +#endif + } + return (false); +} + +static bool real_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + switch (type(y)) { + case T_INTEGER: + return (floats_are_equivalent(sc, real(x), integer(y))); + case T_RATIO: + return (floats_are_equivalent(sc, real(x), fraction(y))); + case T_REAL: + return (floats_are_equivalent(sc, real(x), real(y))); + case T_COMPLEX: + return ((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) && + (floats_are_equivalent(sc, real(x), real_part(y)))); +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, real(x), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); + case T_BIG_REAL: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return (big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); + case T_BIG_COMPLEX: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return (both_floats_are_equivalent(sc, y)); +#endif + } + return (false); +} + +static bool complex_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ + switch (type(y)) { + case T_INTEGER: + return ((floats_are_equivalent(sc, real_part(x), integer(y))) && + (floats_are_equivalent(sc, imag_part(x), 0.0))); + case T_RATIO: + return ((floats_are_equivalent(sc, real_part(x), fraction(y))) && + (floats_are_equivalent(sc, imag_part(x), 0.0))); + case T_REAL: + return ((floats_are_equivalent(sc, real_part(x), real(y))) && + (floats_are_equivalent(sc, imag_part(x), 0.0))); + case T_COMPLEX: + return ((floats_are_equivalent(sc, real_part(x), real_part(y))) && + (floats_are_equivalent(sc, imag_part(x), imag_part(y)))); +#if WITH_GMP + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, real_part(x), MPFR_RNDN); + return ((big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) && + (floats_are_equivalent(sc, imag_part(x), 0.0))); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN); + mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); + return ((big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) && + (floats_are_equivalent(sc, imag_part(x), 0.0))); + case T_BIG_REAL: + mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN); + return ((big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))) && + (floats_are_equivalent(sc, imag_part(x), 0.0))); + case T_BIG_COMPLEX: + mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, imag_part(x), MPFR_RNDN); + return ((big_floats_are_equivalent + (sc, sc->mpfr_1, mpc_realref(big_complex(y)))) + && + (big_floats_are_equivalent + (sc, sc->mpfr_2, mpc_imagref(big_complex(y))))); +#endif + } + return (false); +} + +static bool rng_equal(s7_scheme * sc, s7_pointer x, s7_pointer y, + shared_info_t * ci) +{ +#if WITH_GMP + return (x == y); +#else + return ((x == y) || + ((is_random_state(y)) && + (random_seed(x) == random_seed(y)) && + (random_carry(x) == random_carry(y)))); +#endif +} + +static void init_equals(void) +{ + int32_t i; + for (i = 0; i < NUM_TYPES; i++) { + equals[i] = eq_equal; + equivalents[i] = eq_equal; + } + equals[T_SYMBOL] = eq_equal; + equals[T_C_POINTER] = c_pointer_equal; + equals[T_UNSPECIFIED] = unspecified_equal; + equals[T_UNDEFINED] = undefined_equal; + equals[T_STRING] = string_equal; + equals[T_SYNTAX] = syntax_equal; + equals[T_C_OBJECT] = c_objects_are_equal; + equals[T_RANDOM_STATE] = rng_equal; + equals[T_ITERATOR] = iterator_equal; + equals[T_INPUT_PORT] = port_equal; + equals[T_OUTPUT_PORT] = port_equal; + equals[T_MACRO] = closure_equal; + equals[T_MACRO_STAR] = closure_equal; + equals[T_BACRO] = closure_equal; + equals[T_BACRO_STAR] = closure_equal; + equals[T_CLOSURE] = closure_equal; + equals[T_CLOSURE_STAR] = closure_equal; + equals[T_HASH_TABLE] = hash_table_equal; + equals[T_LET] = let_equal; + equals[T_PAIR] = pair_equal; + equals[T_VECTOR] = vector_equal; + equals[T_INT_VECTOR] = int_vector_equal; + equals[T_BYTE_VECTOR] = byte_vector_equal; + equals[T_FLOAT_VECTOR] = float_vector_equal; + equals[T_INTEGER] = integer_equal; + equals[T_RATIO] = fraction_equal; + equals[T_REAL] = real_equal; + equals[T_COMPLEX] = complex_equal; +#if WITH_GMP + equals[T_BIG_INTEGER] = big_integer_equal; + equals[T_BIG_RATIO] = big_ratio_equal; + equals[T_BIG_REAL] = big_real_equal; + equals[T_BIG_COMPLEX] = big_complex_equal; +#endif + equivalents[T_SYMBOL] = symbol_equivalent; + equivalents[T_C_POINTER] = c_pointer_equivalent; + equivalents[T_UNSPECIFIED] = unspecified_equal; + equivalents[T_UNDEFINED] = undefined_equal; + equivalents[T_STRING] = string_equal; + equivalents[T_SYNTAX] = syntax_equal; + equivalents[T_C_OBJECT] = c_objects_are_equivalent; + equivalents[T_RANDOM_STATE] = rng_equal; + equivalents[T_ITERATOR] = iterator_equivalent; + equivalents[T_INPUT_PORT] = port_equivalent; + equivalents[T_OUTPUT_PORT] = port_equivalent; + equivalents[T_MACRO] = closure_equivalent; + equivalents[T_MACRO_STAR] = closure_equivalent; + equivalents[T_BACRO] = closure_equivalent; + equivalents[T_BACRO_STAR] = closure_equivalent; + equivalents[T_CLOSURE] = closure_equivalent; + equivalents[T_CLOSURE_STAR] = closure_equivalent; + equivalents[T_HASH_TABLE] = hash_table_equivalent; + equivalents[T_LET] = let_equivalent; + equivalents[T_PAIR] = pair_equivalent; + equivalents[T_VECTOR] = vector_equivalent; + equivalents[T_INT_VECTOR] = vector_equivalent; + equivalents[T_FLOAT_VECTOR] = vector_equivalent; + equivalents[T_BYTE_VECTOR] = vector_equivalent; + equivalents[T_INTEGER] = integer_equivalent; + equivalents[T_RATIO] = fraction_equivalent; + equivalents[T_REAL] = real_equivalent; + equivalents[T_COMPLEX] = complex_equivalent; +#if WITH_GMP + equivalents[T_BIG_INTEGER] = big_integer_equivalent; + equivalents[T_BIG_RATIO] = big_ratio_equivalent; + equivalents[T_BIG_REAL] = big_real_equivalent; + equivalents[T_BIG_COMPLEX] = big_complex_equivalent; +#endif +} + +bool s7_is_equal(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + return ((*(equals[type(x)])) (sc, x, y, NULL)); +} + +bool s7_is_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + return ((*(equivalents[type(x)])) (sc, x, y, NULL)); +} + +static s7_pointer g_is_equal(s7_scheme * sc, s7_pointer args) +{ +#define H_is_equal "(equal? obj1 obj2) returns #t if obj1 is equal to obj2" +#define Q_is_equal sc->pcl_bt + return (make_boolean(sc, is_equal_1(sc, car(args), cadr(args), NULL))); +} + +static s7_pointer g_is_equivalent(s7_scheme * sc, s7_pointer args) +{ +#define H_is_equivalent "(equivalent? obj1 obj2) returns #t if obj1 is close enough to obj2." +#define Q_is_equivalent sc->pcl_bt + return (make_boolean + (sc, is_equivalent_1(sc, car(args), cadr(args), NULL))); +} + +static s7_pointer is_equal_p_pp(s7_scheme * sc, s7_pointer a, s7_pointer b) +{ + return ((is_equal_1(sc, a, b, NULL)) ? sc->T : sc->F); +} + +static s7_pointer is_equivalent_p_pp(s7_scheme * sc, s7_pointer a, + s7_pointer b) +{ + return ((is_equivalent_1(sc, a, b, NULL)) ? sc->T : sc->F); +} + + +/* ---------------------------------------- length, copy, fill ---------------------------------------- */ +static s7_pointer s7_length(s7_scheme * sc, s7_pointer lst); + +static s7_pointer(*length_functions[256]) (s7_scheme * sc, s7_pointer obj); +static s7_pointer any_length(s7_scheme * sc, s7_pointer obj) +{ + return (sc->F); +} + +static s7_pointer pair_length(s7_scheme * sc, s7_pointer a) +{ + s7_int i = 0; + s7_pointer slow = a, fast = a; /* we know a is a pair, don't start with fast = cdr(a)! else if a len = 3, we never match */ + while (true) { + LOOP_4(fast = cdr(fast); i++; if (!is_pair(fast)) + return (make_integer(sc, (is_null(fast)) ? i : -i))); + slow = cdr(slow); + if (fast == slow) + return (real_infinity); + } + return (real_infinity); +} + +static s7_pointer nil_length(s7_scheme * sc, s7_pointer lst) +{ + return (int_zero); +} + +static s7_pointer v_length(s7_scheme * sc, s7_pointer v) +{ + return (make_integer(sc, vector_length(v))); +} + +static s7_pointer str_length(s7_scheme * sc, s7_pointer v) +{ + return (make_integer(sc, string_length(v))); +} + +static s7_pointer bv_length(s7_scheme * sc, s7_pointer v) +{ + return (make_integer(sc, byte_vector_length(v))); +} + +static s7_pointer h_length(s7_scheme * sc, s7_pointer lst) +{ + return (make_integer(sc, hash_table_mask(lst) + 1)); +} + +static s7_pointer iter_length(s7_scheme * sc, s7_pointer lst) +{ + return (s7_length(sc, iterator_sequence(lst))); +} + +static s7_pointer c_obj_length(s7_scheme * sc, s7_pointer lst) +{ + if (!is_global(sc->length_symbol)) + check_method(sc, lst, sc->length_symbol, set_plist_1(sc, lst)); + return (c_object_length(sc, lst)); +} + +static s7_pointer lt_length(s7_scheme * sc, s7_pointer lst) +{ + if (!is_global(sc->length_symbol)) + check_method(sc, lst, sc->length_symbol, set_plist_1(sc, lst)); + return (make_integer(sc, let_length(sc, lst))); +} + +static s7_pointer fnc_length(s7_scheme * sc, s7_pointer lst) +{ + return ((has_active_methods(sc, lst)) ? + make_integer(sc, closure_length(sc, lst)) : sc->F); +} + +static s7_pointer ip_length(s7_scheme * sc, s7_pointer port) +{ + if (port_is_closed(port)) + return (sc->F); /* or 0? */ + if (is_string_port(port)) + return (make_integer(sc, port_data_size(port))); /* length of string we're reading */ +#if (!MS_WINDOWS) + if (is_file_port(port)) { + long cur_pos, len; + cur_pos = ftell(port_file(port)); + fseek(port_file(port), 0, SEEK_END); + len = ftell(port_file(port)); + rewind(port_file(port)); + fseek(port_file(port), cur_pos, SEEK_SET); + return (make_integer(sc, len)); + } +#endif + return (sc->F); +} + +static s7_pointer op_length(s7_scheme * sc, s7_pointer port) +{ + if (port_is_closed(port)) + return (sc->F); /* or 0? */ + return ((is_string_port(port)) ? make_integer(sc, port_position(port)) : sc->F); /* length of string we've written */ +} + +static void init_length_functions(void) +{ + int32_t i; + for (i = 0; i < 256; i++) + length_functions[i] = any_length; + length_functions[T_NIL] = nil_length; + length_functions[T_PAIR] = pair_length; + length_functions[T_VECTOR] = v_length; + length_functions[T_FLOAT_VECTOR] = v_length; + length_functions[T_INT_VECTOR] = v_length; + length_functions[T_STRING] = str_length; + length_functions[T_BYTE_VECTOR] = bv_length; + length_functions[T_ITERATOR] = iter_length; + length_functions[T_HASH_TABLE] = h_length; + length_functions[T_C_OBJECT] = c_obj_length; + length_functions[T_LET] = lt_length; + length_functions[T_CLOSURE] = fnc_length; + length_functions[T_CLOSURE_STAR] = fnc_length; + length_functions[T_INPUT_PORT] = ip_length; + length_functions[T_OUTPUT_PORT] = op_length; +} + +static s7_pointer s7_length(s7_scheme * sc, s7_pointer lst) +{ + return ((*length_functions[unchecked_type(lst)]) (sc, lst)); +} + +static s7_pointer g_length(s7_scheme * sc, s7_pointer args) +{ +#define H_length "(length obj) returns the length of obj, which can be a list, vector, string, input-port, or hash-table. \ +The length of a dotted list does not include the final cdr, and is returned as a negative number. A circular \ +list has infinite length. Length of anything else returns #f." +#define Q_length s7_make_signature(sc, 2, s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_infinite_symbol, sc->not_symbol), sc->T) + return ((*length_functions[unchecked_type(car(args))]) + (sc, car(args))); +} + + +/* -------------------------------- copy -------------------------------- */ +static s7_pointer string_setter(s7_scheme * sc, s7_pointer str, s7_int loc, + s7_pointer val) +{ + if (is_character(val)) { + string_value(str)[loc] = s7_character(val); + return (val); + } + set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not a character", 25)); + set_caddr(sc->elist_3, val); + return (s7_error(sc, sc->wrong_type_arg_symbol, sc->elist_3)); +} + +static s7_pointer string_getter(s7_scheme * sc, s7_pointer str, s7_int loc) +{ + return (chars[(uint8_t) (string_value(str)[loc])]); /* cast needed else (copy (string (integer->char 255))...) is trouble */ +} + +static s7_pointer c_object_setter(s7_scheme * sc, s7_pointer obj, + s7_int loc, s7_pointer val) +{ + set_car(sc->t3_1, obj); + set_car(sc->t3_2, make_integer(sc, loc)); + set_car(sc->t3_3, val); + return ((*(c_object_set(sc, obj))) (sc, sc->t3_1)); +} + +static s7_pointer c_object_getter(s7_scheme * sc, s7_pointer obj, + s7_int loc) +{ + return ((*(c_object_ref(sc, obj))) + (sc, set_plist_2(sc, obj, make_integer(sc, loc)))); +} + +static s7_pointer let_setter(s7_scheme * sc, s7_pointer e, s7_int loc, + s7_pointer val) +{ + /* loc is irrelevant here, val has to be of the form (cons symbol value) + * if symbol is already in e, its value is changed, otherwise a new slot is added to e + */ + if (is_pair(val)) { + s7_pointer sym = car(val); + if (is_symbol(sym)) { + s7_pointer slot; + if (is_keyword(sym)) + sym = keyword_symbol(sym); /* else make_slot will mark the keyword as local confusing odd_bits etc */ + slot = slot_in_let(sc, e, sym); + if (is_slot(slot)) + checked_slot_set_value(sc, slot, cdr(val)); + else + add_slot_checked_with_id(sc, e, sym, cdr(val)); + return (cdr(val)); + } + } + set_car(sc->elist_3, + wrap_string(sc, "~S: ~S is not (cons symbol value)", 33)); + set_caddr(sc->elist_3, val); + return (s7_error(sc, sc->wrong_type_arg_symbol, sc->elist_3)); +} + +static s7_pointer hash_table_setter(s7_scheme * sc, s7_pointer e, + s7_int loc, s7_pointer val) +{ + /* loc is irrelevant here, e is the hash-table, val has to be of the form (cons key value) + * if key is already in e, its value is changed, otherwise a new slot is added to e + */ + if (is_pair(val)) + return (s7_hash_table_set(sc, e, car(val), cdr(val))); + + set_car(sc->elist_3, + wrap_string(sc, "~S: ~S is not (cons key value)", 30)); + set_caddr(sc->elist_3, val); + return (s7_error(sc, sc->wrong_type_arg_symbol, sc->elist_3)); +} + + +static s7_pointer copy_source_no_dest(s7_scheme * sc, s7_pointer caller, + s7_pointer source, s7_pointer args) +{ + s7_pointer dest; + switch (type(source)) { + case T_STRING: + return (make_string_with_length + (sc, string_value(source), string_length(source))); + + case T_C_OBJECT: + return (copy_c_object(sc, args)); + + case T_RANDOM_STATE: + return (rng_copy(sc, args)); + + case T_HASH_TABLE: /* this has to copy nearly everything */ + { + s7_int gc_loc; + s7_pointer new_hash; + new_hash = s7_make_hash_table(sc, hash_table_mask(source) + 1); + gc_loc = gc_protect_1(sc, new_hash); + hash_table_checker(new_hash) = hash_table_checker(source); + if (hash_chosen(source)) + hash_set_chosen(new_hash); + hash_table_mapper(new_hash) = hash_table_mapper(source); + hash_table_set_procedures(new_hash, + hash_table_procedures(source)); + hash_table_copy(sc, source, new_hash, 0, + hash_table_entries(source)); + if (is_typed_hash_table(source)) { + set_typed_hash_table(new_hash); + if (has_simple_keys(source)) + set_has_simple_keys(new_hash); + if (has_simple_values(source)) + set_has_simple_values(new_hash); + } + s7_gc_unprotect_at(sc, gc_loc); + return (new_hash); + } + + case T_ITERATOR: + return (iterator_copy(sc, source)); + + case T_LET: + check_method(sc, source, sc->copy_symbol, args); + return (let_copy(sc, source)); /* this copies only the local let and points to outer lets */ + + case T_CLOSURE: + case T_CLOSURE_STAR: + case T_MACRO: + case T_MACRO_STAR: + case T_BACRO: + case T_BACRO_STAR: + check_method(sc, source, sc->copy_symbol, args); + return (copy_closure(sc, source)); + + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + case T_BYTE_VECTOR: + return (s7_vector_copy(sc, source)); /* "shallow" copy */ + + case T_PAIR: /* top level only, as in the other cases, checks for circles */ + return (copy_any_list(sc, source)); + + case T_INTEGER: + new_cell(sc, dest, T_INTEGER); + integer(dest) = integer(source); + return (dest); + + case T_RATIO: + new_cell(sc, dest, T_RATIO); + numerator(dest) = numerator(source); + denominator(dest) = denominator(source); + return (dest); + + case T_REAL: + new_cell(sc, dest, T_REAL); + set_real(dest, real(source)); + return (dest); + + case T_COMPLEX: + new_cell(sc, dest, T_COMPLEX); + set_real_part(dest, real_part(source)); + set_imag_part(dest, imag_part(source)); + return (dest); + +#if WITH_GMP + case T_BIG_INTEGER: + return (mpz_to_big_integer(sc, big_integer(source))); + case T_BIG_RATIO: + return (mpq_to_big_ratio(sc, big_ratio(source))); + case T_BIG_REAL: + return (mpfr_to_big_real(sc, big_real(source))); + case T_BIG_COMPLEX: + return (mpc_to_number(sc, big_complex(source))); +#endif + + case T_C_POINTER: + dest = + s7_make_c_pointer_with_type(sc, c_pointer(source), + c_pointer_type(source), + c_pointer_info(source)); + c_pointer_weak1(dest) = c_pointer_weak1(source); + c_pointer_weak2(dest) = c_pointer_weak2(source); + return (dest); + } + return (source); +} + +static s7_pointer copy_p_p(s7_scheme * sc, s7_pointer source) +{ + return (copy_source_no_dest + (sc, sc->copy_symbol, source, set_plist_1(sc, source))); +} + +static s7_pointer copy_to_same_type(s7_scheme * sc, s7_pointer dest, + s7_pointer source, s7_int dest_start, + s7_int dest_end, s7_int source_start) +{ + /* types equal, but not a let (handled in s7_copy_1), returns NULL if not copied here */ + s7_int i, j, source_len = dest_end - dest_start; + switch (type(source)) { + case T_PAIR: + { + s7_pointer pd, ps; + for (ps = source, i = 0; i < source_start; i++) + ps = cdr(ps); + for (pd = dest, i = 0; i < dest_start; i++) + pd = cdr(pd); + for (; (i < dest_end) && is_pair(ps) && is_pair(pd); + i++, ps = cdr(ps), pd = cdr(pd)) + set_car(pd, car(ps)); + return (dest); + } + + case T_VECTOR: + if (is_typed_vector(dest)) { + s7_pointer *els = vector_elements(source); + for (i = source_start, j = dest_start; j < dest_end; i++, j++) + typed_vector_setter(sc, dest, j, els[i]); /* types are equal, so source is a normal vector */ + } else + memcpy((void *) ((vector_elements(dest)) + dest_start), + (void *) ((vector_elements(source)) + source_start), + source_len * sizeof(s7_pointer)); + return (dest); + + case T_INT_VECTOR: + memcpy((void *) ((int_vector_ints(dest)) + dest_start), + (void *) ((int_vector_ints(source)) + source_start), + source_len * sizeof(s7_int)); + return (dest); + + case T_FLOAT_VECTOR: + memcpy((void *) ((float_vector_floats(dest)) + dest_start), + (void *) ((float_vector_floats(source)) + source_start), + source_len * sizeof(s7_double)); + return (dest); + + case T_BYTE_VECTOR: + if (is_string(dest)) + memcpy((void *) (string_value(dest) + dest_start), + (void *) ((byte_vector_bytes(source)) + source_start), + source_len * sizeof(uint8_t)); + else + memcpy((void *) (byte_vector_bytes(dest) + dest_start), + (void *) ((byte_vector_bytes(source)) + source_start), + source_len * sizeof(uint8_t)); + return (dest); + + case T_STRING: + if (is_string(dest)) + memcpy((void *) (string_value(dest) + dest_start), + (void *) ((string_value(source)) + source_start), + source_len); + else + memcpy((void *) (byte_vector_bytes(dest) + dest_start), + (void *) ((string_value(source)) + source_start), + source_len); + return (dest); + + case T_C_OBJECT: + { + s7_pointer mi, mj; + s7_int gc_loc1, gc_loc2; + s7_pointer(*cref) (s7_scheme * sc, s7_pointer args); + s7_pointer(*cset) (s7_scheme * sc, s7_pointer args); + + mi = make_mutable_integer(sc, 0); + mj = make_mutable_integer(sc, 0); + gc_loc1 = gc_protect_1(sc, mi); + gc_loc2 = gc_protect_1(sc, mj); + cref = c_object_ref(sc, source); + cset = c_object_set(sc, dest); + + for (i = source_start, j = dest_start; i < dest_end; i++, j++) { + integer(mi) = i; + integer(mj) = j; + set_car(sc->t2_1, source); + set_car(sc->t2_2, mi); + set_car(sc->t3_3, cref(sc, sc->t2_1)); + set_car(sc->t3_1, dest); + set_car(sc->t3_2, mj); + cset(sc, sc->t3_1); + } + s7_gc_unprotect_at(sc, gc_loc1); + s7_gc_unprotect_at(sc, gc_loc2); + free_cell(sc, mi); + free_cell(sc, mj); + return (dest); + } + + case T_LET: + return (NULL); + + case T_HASH_TABLE: + { + s7_pointer p; + p = hash_table_copy(sc, source, dest, source_start, + source_start + source_len); + if ((hash_table_checker(source) != hash_table_checker(dest)) + && (!hash_table_checker_locked(dest))) { + if (hash_table_checker(dest) == hash_empty) + hash_table_checker(dest) = hash_table_checker(source); + else { + hash_table_checker(dest) = hash_equal; + hash_set_chosen(dest); + } + } + return (p); + } + + default: + return (dest); + } + return (NULL); +} + +static s7_pointer s7_copy_1(s7_scheme * sc, s7_pointer caller, + s7_pointer args) +{ +#define H_copy "(copy obj) returns a copy of obj, (copy src dest) copies src into dest, (copy src dest start end) copies src from start to end." + /* #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_integer_symbol) */ + /* this is not right when c-object types are handled in lint -- a generator or Snd object need not consider itself a sequence, + * but it can provide a copy method. So, I think I'll just use #t + */ +#define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->T, sc->T, sc->is_integer_symbol) + + s7_pointer source = car(args), dest; + s7_int i, j, dest_len, start, end, source_len; + s7_pointer(*set) (s7_scheme * sc, s7_pointer obj, s7_int loc, + s7_pointer val) = NULL; + s7_pointer(*get) (s7_scheme * sc, s7_pointer obj, s7_int loc) = NULL; + bool have_indices; + + if (is_null(cdr(args))) /* (copy obj) */ + return (copy_source_no_dest(sc, caller, source, args)); + + dest = T_Pos(cadr(args)); + if ((dest == sc->key_readable_symbol) && (!is_pair(source))) + return (s7_error + (sc, sc->out_of_range_symbol, + set_elist_1(sc, + wrap_string(sc, + "copy argument 2, :readable, only works if the source is a pair", + 62)))); + + if ((is_immutable(dest)) && (dest != sc->key_readable_symbol) && (dest != sc->nil)) /* error_hook copies with cadr(args) :readable, so it's currently NULL */ + return (s7_wrong_type_arg_error(sc, symbol_name(caller), 2, dest, "a mutable object")); /* so this segfaults if not checking for :readable */ + + have_indices = (is_pair(cddr(args))); + if ((source == dest) && (!have_indices)) + return (dest); + + switch (type(source)) { + case T_PAIR: + if (dest == sc->key_readable_symbol) { /* a kludge, but I can't think of anything less stupid */ + if (have_indices) /* it seems to me that the start/end args here don't make any sense so... */ + return (s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, + wrap_string(sc, + "~S: start/end indices make no sense with :readable: ~S", + 54), caller, + args))); + return (copy_body(sc, source)); + } + end = s7_list_length(sc, source); + if (end == 0) + end = circular_list_entries(source); + else if (end < 0) + end = -end; + break; + + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + case T_BYTE_VECTOR: + get = vector_getter(source); + end = vector_length(source); + break; + + case T_STRING: + get = string_getter; + end = string_length(source); + break; + + case T_HASH_TABLE: + if (source == dest) + return (dest); + end = hash_table_entries(source); + break; + + case T_C_OBJECT: + if (c_object_copy(sc, source)) { + s7_pointer x; + x = (*(c_object_copy(sc, source))) (sc, args); + if (x == dest) + return (dest); + } + check_method(sc, source, sc->copy_symbol, args); + get = c_object_getter; + end = c_object_length_to_int(sc, source); + break; + + case T_LET: + if (source == dest) + return (dest); + check_method(sc, source, sc->copy_symbol, args); + if (source == sc->rootlet) + return (wrong_type_argument_with_type + (sc, caller, 1, source, + wrap_string(sc, "a sequence other than the rootlet", + 33))); + if ((!have_indices) && (is_let(dest)) && (dest != sc->s7_let)) { + s7_pointer slot; + if (dest == sc->rootlet) /* (copy (inlet 'a 1) (rootlet)) */ + for (slot = let_slots(source); tis_slot(slot); + slot = next_slot(slot)) + s7_make_slot(sc, dest, slot_symbol(slot), + slot_value(slot)); + else if ((has_let_fallback(source)) + && (has_let_fallback(dest))) { + for (slot = let_slots(source); tis_slot(slot); + slot = next_slot(slot)) + if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) + && (slot_symbol(slot) != + sc->let_set_fallback_symbol)) + add_slot_checked_with_id(sc, dest, + slot_symbol(slot), + slot_value(slot)); + } else + for (slot = let_slots(source); tis_slot(slot); + slot = next_slot(slot)) + add_slot_checked_with_id(sc, dest, slot_symbol(slot), + slot_value(slot)); + return (dest); + } + end = let_length(sc, source); + break; + + case T_NIL: + end = 0; + if (is_sequence(dest)) + break; + + default: + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17), + caller, source, dest))); + } + + start = 0; + if (have_indices) { + s7_pointer p; + p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); + if (p != sc->unused) + return (p); + } + if ((start == 0) && (source == dest)) + return (dest); + source_len = end - start; + if (source_len == 0) { + if (!is_sequence(dest)) + return (wrong_type_argument_with_type + (sc, caller, 2, dest, a_sequence_string)); + return (dest); + } + + switch (type(dest)) { + case T_PAIR: + dest_len = source_len; + break; + + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_BYTE_VECTOR: + set = vector_setter(dest); + dest_len = vector_length(dest); + break; + + case T_VECTOR: + set = + (is_typed_vector(dest)) ? typed_vector_setter : + vector_setter(dest); + dest_len = vector_length(dest); + break; + + case T_STRING: + set = string_setter; + dest_len = string_length(dest); + set_cadr(sc->elist_3, caller); /* for possible error handling in string_setter */ + break; + + case T_HASH_TABLE: + set = hash_table_setter; + dest_len = source_len; + set_cadr(sc->elist_3, caller); /* for possible error handling in hash_table_setter */ + break; + + case T_C_OBJECT: + /* if source or dest is c_object, call its copy function before falling back on the get/set functions */ + if (c_object_copy(sc, dest)) { + s7_pointer x; + x = (*(c_object_copy(sc, dest))) (sc, args); + if (x == dest) + return (dest); + } + set = c_object_setter; + dest_len = c_object_length_to_int(sc, dest); + break; + + case T_LET: + if ((dest == sc->rootlet) || (dest == sc->s7_let)) + return (wrong_type_argument_with_type + (sc, caller, 2, dest, + wrap_string(sc, + "a sequence other than the rootlet or *s7*", + 41))); + set = let_setter; + dest_len = source_len; /* grows via set, so dest_len isn't relevant */ + set_cadr(sc->elist_3, caller); /* for possible error handling in let_setter */ + break; + + case T_NIL: + return (sc->nil); + + default: + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17), + caller, source, dest))); + } + + if (dest_len == 0) + return (dest); + + /* end is source_len if not set explicitly */ + if (dest_len < source_len) { + end = dest_len + start; + source_len = dest_len; + } + + if ((source != dest) && + ((type(source) == type(dest)) || + ((is_string_or_byte_vector(source)) && + (is_string_or_byte_vector(dest))))) { + s7_pointer res; + res = copy_to_same_type(sc, dest, source, 0, source_len, start); + if (res) + return (res); + } + + switch (type(source)) { + case T_PAIR: + { + s7_pointer p = source; + if (start > 0) + for (i = 0; i < start; i++) + p = cdr(p); + /* dest won't be a pair here if source != dest -- the pair->pair case was caught above */ + if (source == dest) { /* here start != 0 (see above) */ + s7_pointer dp; + for (dp = source, i = start; i < end; + i++, p = cdr(p), dp = cdr(dp)) + set_car(dp, car(p)); + } else if (is_string(dest)) { + char *dst = string_value(dest); + for (i = start, j = 0; i < end; i++, j++, p = cdr(p)) { + if (!is_character(car(p))) + return (simple_wrong_type_argument + (sc, caller, car(p), T_CHARACTER)); + dst[j] = character(car(p)); + } + } else + for (i = start, j = 0; i < end; i++, j++, p = cdr(p)) + set(sc, dest, j, car(p)); + return (dest); + } + + case T_LET: + /* implicit index can give n-way reality check (ht growth by new entries) + * if shadowed entries are they unshadowed by reversal? + */ + if (source == sc->s7_let) { /* *s7* */ + s7_pointer iter; + s7_int gc_loc; + iter = s7_make_iterator(sc, sc->s7_let); + gc_loc = s7_gc_protect(sc, iter); + for (i = 0; i < start; i++) { + s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) { + s7_gc_unprotect_at(sc, gc_loc); + return (dest); + } + } + if (is_pair(dest)) { /* (append '(1) *s7* ()) */ + s7_pointer p; + for (i = start, p = dest; (i < end) && (is_pair(p)); + i++, p = cdr(p)) { + s7_pointer val; + val = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) + break; + set_car(p, val); + } + } else + for (i = start, j = 0; i < end; i++, j++) { + s7_pointer val; + val = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) + break; + set(sc, dest, j, val); + } + s7_gc_unprotect_at(sc, gc_loc); + } else { + /* source and dest can't be rootlet (checked above), dest also can't be *s7* */ + s7_pointer slot = let_slots(source); + for (i = 0; i < start; i++) + slot = next_slot(slot); + if (is_pair(dest)) { + s7_pointer p; + for (i = start, p = dest; (i < end) && (is_pair(p)); + i++, p = cdr(p), slot = next_slot(slot)) + set_car(p, + cons(sc, slot_symbol(slot), slot_value(slot))); + } else if (is_let(dest)) { + if ((has_let_fallback(source)) && (has_let_fallback(dest))) { + for (slot = let_slots(source); tis_slot(slot); + slot = next_slot(slot)) + if ((slot_symbol(slot) != + sc->let_ref_fallback_symbol) + && (slot_symbol(slot) != + sc->let_set_fallback_symbol)) + add_slot_checked_with_id(sc, dest, + slot_symbol(slot), + slot_value(slot)); + } else + for (i = start; i < end; i++, slot = next_slot(slot)) + add_slot_checked_with_id(sc, dest, + slot_symbol(slot), + slot_value(slot)); + } else if (is_hash_table(dest)) + for (i = start; i < end; i++, slot = next_slot(slot)) + s7_hash_table_set(sc, dest, slot_symbol(slot), + slot_value(slot)); + else + for (i = start, j = 0; i < end; + i++, j++, slot = next_slot(slot)) + set(sc, dest, j, + cons(sc, slot_symbol(slot), slot_value(slot))); + } + return (dest); + + case T_HASH_TABLE: + { + s7_int loc = -1, skip = start; + hash_entry_t **elements = hash_table_elements(source); + hash_entry_t *x = NULL; + + while (skip > 0) { + while (!x) + x = elements[++loc]; + skip--; + x = hash_entry_next(x); + } + + if (is_pair(dest)) { + s7_pointer p; + for (i = start, p = dest; (i < end) && (is_pair(p)); + i++, p = cdr(p)) { + while (!x) + x = elements[++loc]; + set_car(p, + cons(sc, hash_entry_key(x), + hash_entry_value(x))); + x = hash_entry_next(x); + } + } else if (is_let(dest)) { + for (i = start; i < end; i++) { + s7_pointer symbol; + while (!x) + x = elements[++loc]; + symbol = hash_entry_key(x); + if (!is_symbol(symbol)) + return (simple_wrong_type_argument + (sc, caller, symbol, T_SYMBOL)); + if (is_constant_symbol(sc, symbol)) + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, + wrap_string(sc, + "~A into ~A: ~A is a constant", + 28), + caller, dest, + symbol))); + if ((symbol != sc->let_ref_fallback_symbol) + && (symbol != sc->let_set_fallback_symbol)) + add_slot_checked_with_id(sc, dest, symbol, + hash_entry_value(x)); + x = hash_entry_next(x); + } + } else + for (i = start, j = 0; i < end; i++, j++) { + while (!x) + x = elements[++loc]; + set(sc, dest, j, + cons(sc, hash_entry_key(x), hash_entry_value(x))); + x = hash_entry_next(x); + } + return (dest); + } + + case T_VECTOR: + { + s7_pointer *vals = vector_elements(source); + if (is_float_vector(dest)) { + s7_double *dst = float_vector_floats(dest); + for (i = start, j = 0; i < end; i++, j++) + dst[j] = real_to_double(sc, vals[i], "copy"); + return (dest); + } + if (is_int_vector(dest)) { + s7_int *dst = int_vector_ints(dest); + for (i = start, j = 0; i < end; i++, j++) { + if (!s7_is_integer(vals[i])) + return (simple_wrong_type_argument + (sc, caller, vals[i], T_INTEGER)); + dst[j] = s7_integer_checked(sc, vals[i]); + } + return (dest); + } + if (is_string(dest)) { + char *dst = string_value(dest); + for (i = start, j = 0; i < end; i++, j++) { + if (!is_character(vals[i])) + return (simple_wrong_type_argument + (sc, caller, vals[i], T_CHARACTER)); + dst[j] = character(vals[i]); + } + return (dest); + } + if (is_byte_vector(dest)) { + uint8_t *dst = (uint8_t *) byte_vector_bytes(dest); + for (i = start, j = 0; i < end; i++, j++) { + s7_int byte; + if (!s7_is_integer(vals[i])) + return (simple_wrong_type_argument_with_type + (sc, caller, vals[i], + an_unsigned_byte_string)); + byte = s7_integer_checked(sc, vals[i]); + if ((byte >= 0) && (byte < 256)) + dst[j] = (uint8_t) byte; + else + return (simple_wrong_type_argument_with_type + (sc, caller, vals[i], + an_unsigned_byte_string)); + } + return (dest); + } + } + break; + + case T_FLOAT_VECTOR: + { + s7_double *src = float_vector_floats(source); + if (is_int_vector(dest)) { + s7_int *dst = int_vector_ints(dest); + for (i = start, j = 0; i < end; i++, j++) + dst[j] = (s7_int) (src[i]); + return (dest); + } + if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) { + s7_pointer *dst = vector_elements(dest); + for (i = start, j = 0; i < end; i++, j++) { + dst[j++] = make_real(sc, src[i++]); + if (i == end) + break; + dst[j] = make_real_unchecked(sc, src[i]); + } + return (dest); + } + } + break; + + case T_INT_VECTOR: + { + s7_int *src = int_vector_ints(source); + if (is_float_vector(dest)) { + s7_double *dst = float_vector_floats(dest); + for (i = start, j = 0; i < end; i++, j++) + dst[j] = (s7_double) (src[i]); + return (dest); + } + if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) + /* this could check that the typer is integer? (similarly elsewhere): + * (typed_vector_typer(dest) != global_value(sc->is_integer_symbol)) ? + */ + { + s7_pointer *dst = vector_elements(dest); + for (i = start, j = 0; i < end; i++, j++) + dst[j] = make_integer(sc, src[i]); + return (dest); + } + if (is_string(dest)) { + for (i = start, j = 0; i < end; i++, j++) { + if ((src[i] < 0) || (src[i] > 255)) + return (out_of_range + (sc, caller, int_one, + wrap_integer1(sc, src[i]), + an_unsigned_byte_string)); + string_value(dest)[j] = (uint8_t) (src[i]); + } + return (dest); + } + if (is_byte_vector(dest)) { + for (i = start, j = 0; i < end; i++, j++) { + if ((src[i] < 0) || (src[i] > 255)) + return (out_of_range + (sc, caller, int_one, + wrap_integer1(sc, src[i]), + an_unsigned_byte_string)); + byte_vector(dest, j) = (uint8_t) (src[i]); + } + return (dest); + } + } + break; + + case T_BYTE_VECTOR: + if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) { + s7_pointer *dst = vector_elements(dest); + for (i = start, j = 0; i < end; i++, j++) + dst[j] = + make_integer(sc, (s7_int) (byte_vector(source, i))); + return (dest); + } + if (is_int_vector(dest)) { + s7_int *els = int_vector_ints(dest); + for (i = start, j = 0; i < end; i++, j++) + els[j] = (s7_int) ((uint8_t) (byte_vector(source, i))); + return (dest); + } + if (is_float_vector(dest)) { + s7_double *els = float_vector_floats(dest); + for (i = start, j = 0; i < end; i++, j++) + els[j] = (s7_double) ((uint8_t) (byte_vector(source, i))); + return (dest); + } + break; + + case T_STRING: + if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) { + s7_pointer *dst = vector_elements(dest); + for (i = start, j = 0; i < end; i++, j++) + dst[j] = chars[(uint8_t) string_value(source)[i]]; + return (dest); + } + if (is_int_vector(dest)) { + s7_int *els = int_vector_ints(dest); + for (i = start, j = 0; i < end; i++, j++) + els[j] = (s7_int) ((uint8_t) (string_value(source)[i])); + return (dest); + } + if (is_float_vector(dest)) { + s7_double *els = float_vector_floats(dest); + for (i = start, j = 0; i < end; i++, j++) + els[j] = (s7_double) ((uint8_t) (string_value(source)[i])); + return (dest); + } + break; + } + + if (is_pair(dest)) { + s7_pointer p; + if (is_float_vector(source)) { + s7_double *els = float_vector_floats(source); + for (i = start, p = dest; (i < end) && (is_pair(p)); + i++, p = cdr(p)) + set_car(p, make_real(sc, els[i])); + } else if (is_int_vector(source)) { + s7_int *els = int_vector_ints(source); + for (i = start, p = dest; (i < end) && (is_pair(p)); + i++, p = cdr(p)) + set_car(p, make_integer(sc, els[i])); + } else + for (i = start, p = dest; (i < end) && (is_pair(p)); + i++, p = cdr(p)) + set_car(p, get(sc, source, i)); + } else /* if source == dest here, we're moving data backwards, so this is safe in either case */ + for (i = start, j = 0; i < end; i++, j++) + set(sc, dest, j, get(sc, source, i)); + + /* some choices probably should raise an error, but don't: + * (copy (make-hash-table) "1") ; nothing to copy (empty hash table), so no error + */ + return (dest); +} + +s7_pointer s7_copy(s7_scheme * sc, s7_pointer args) +{ + return (s7_copy_1(sc, sc->copy_symbol, args)); +} + +#define g_copy s7_copy + + +/* -------------------------------- reverse -------------------------------- */ +s7_pointer s7_reverse(s7_scheme * sc, s7_pointer a) +{ /* just pairs */ + /* reverse list -- produce new list (other code assumes this function does not return the original!) */ + s7_pointer x, p; + + if (is_null(a)) + return (a); + if (!is_pair(cdr(a))) + return ((is_null(cdr(a))) ? list_1(sc, car(a)) : cons(sc, cdr(a), car(a))); /* don't return 'a' itself */ + sc->w = list_1(sc, car(a)); + for (x = cdr(a), p = a; is_pair(x); x = cdr(x), p = cdr(p)) { + sc->w = cons(sc, car(x), sc->w); + if (is_pair(cdr(x))) { + x = cdr(x); + sc->w = cons_unchecked(sc, car(x), sc->w); + } + if (x == p) /* this can take awhile to notice there's a cycle, but what does the caller expect? */ + break; + } + if (is_not_null(x)) + p = cons(sc, x, sc->w); /* ?? this means that (reverse '(1 2 . 3)) returns '(3 2 1) -- we used to return () here */ + else + p = sc->w; + sc->w = sc->nil; + return (p); +} + +/* s7_reverse sometimes tacks extra nodes on the end of a reversed circular list (it detects the cycle too late) + * (let ((lst (list 0))) (set! (cdr lst) lst) (reverse lst)) -> (#1=(0 . #1#) 0 0 0) + */ + +static s7_pointer g_reverse(s7_scheme * sc, s7_pointer args) +{ +#define H_reverse "(reverse lst) returns a list with the elements of lst in reverse order. reverse \ +also accepts a string or vector argument." +#define Q_reverse s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_sequence_symbol) + + s7_pointer p = car(args), np = sc->nil; + sc->temp3 = p; + + switch (type(p)) { + case T_NIL: + return (sc->nil); + + case T_PAIR: + return (s7_reverse(sc, p)); + + case T_STRING: + { + char *dest, *end, *source = string_value(p); + s7_int len = string_length(p); + end = (char *) (source + len); + np = make_empty_string(sc, len, '\0'); + dest = (char *) (string_value(np) + len); + while (source < end) + *(--dest) = *source++; + } + break; + + case T_BYTE_VECTOR: + { + uint8_t *dest, *end, *source = byte_vector_bytes(p); + s7_int len = byte_vector_length(p); + end = (uint8_t *) (source + len); + np = make_simple_byte_vector(sc, len); + dest = (uint8_t *) (byte_vector_bytes(np) + len); + while (source < end) + *(--dest) = *source++; + } + break; + + case T_INT_VECTOR: + { + s7_int *dest, *end, *source = int_vector_ints(p); + s7_int len = vector_length(p); + end = (s7_int *) (source + len); + if (vector_rank(p) > 1) + np = g_make_vector_1(sc, + set_plist_2(sc, + g_vector_dimensions(sc, + set_plist_1 + (sc, + p)), + int_zero), + sc->make_int_vector_symbol); + else + np = make_simple_int_vector(sc, len); + dest = (s7_int *) (int_vector_ints(np) + len); + while (source < end) + *(--dest) = *source++; + } + break; + + case T_FLOAT_VECTOR: + { + s7_double *dest, *end, *source = float_vector_floats(p); + s7_int len = vector_length(p); + end = (s7_double *) (source + len); + if (vector_rank(p) > 1) + np = g_make_vector_1(sc, + set_plist_2(sc, + g_vector_dimensions(sc, + set_plist_1 + (sc, + p)), + real_zero), + sc->make_float_vector_symbol); + else + np = make_simple_float_vector(sc, len); + dest = (s7_double *) (float_vector_floats(np) + len); + while (source < end) + *(--dest) = *source++; + } + break; + + case T_VECTOR: + { + s7_pointer *dest, *end, *source = vector_elements(p); + s7_int len = vector_length(p); + end = (s7_pointer *) (source + len); + if (vector_rank(p) > 1) + np = g_make_vector(sc, + set_plist_1(sc, + g_vector_dimensions(sc, + set_plist_1 + (sc, + p)))); + else + np = make_simple_vector(sc, len); + dest = (s7_pointer *) (vector_elements(np) + len); + while (source < end) + *(--dest) = *source++; + } + break; + + case T_HASH_TABLE: + return (hash_table_reverse(sc, p)); + + case T_C_OBJECT: + check_method(sc, p, sc->reverse_symbol, args); + if (c_object_reverse(sc, p)) + return ((*(c_object_reverse(sc, p))) (sc, args)); + eval_error(sc, "attempt to reverse ~S?", 22, p); + + case T_LET: + check_method(sc, p, sc->reverse_symbol, args); + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, "can't reverse let: ~S", 21), + p))); + + default: + return (method_or_bust_with_type_one_arg + (sc, p, sc->reverse_symbol, args, a_sequence_string)); + } + return (np); +} + +static s7_pointer any_list_reverse_in_place(s7_scheme * sc, + s7_pointer term, + s7_pointer list) +{ + s7_pointer p, result; + if (is_null(list)) + return (term); + p = list; + result = term; + while (true) { + s7_pointer q = cdr(p); + if (is_null(q)) { + set_cdr(p, result); + return (p); + } + if ((is_pair(q)) && (!is_immutable_pair(q))) { + set_cdr(p, result); + result = p; + p = q; + } else + return (sc->nil); /* improper or immutable */ + } + return (result); +} + +static s7_pointer g_reverse_in_place(s7_scheme * sc, s7_pointer args) +{ +#define H_reverse_in_place "(reverse! lst) reverses lst in place" +#define Q_reverse_in_place Q_reverse + + s7_pointer p = car(args); + switch (type(p)) { + case T_NIL: + return (sc->nil); + + case T_PAIR: + { + s7_pointer np; + if (is_immutable_pair(p)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->reverseb_symbol, p))); + np = any_list_reverse_in_place(sc, sc->nil, p); + if (is_null(np)) + return (s7_wrong_type_arg_error + (sc, "reverse!", 1, car(args), + "a mutable, proper list")); + return (np); + } + /* (reverse! p) is supposed to change p directly and lisp programmers expect reverse! to be fast + * so in a sense this is different from the other cases: it assumes (set! p (reverse! p)) + * To make (reverse! p) direct: + * for (l = p, r = cdr(p); is_pair(r); l = r, r = cdr(r)) opt1(r) = l; + * if (!is_null(r)) return(simple_wrong_type_argument_with_type(sc, sc->reverseb_symbol, p, a_proper_list_string)); + * for (r = l, l = p; l != r; l = cdr(l)) {t = car(l); set_car(l, car(r)); set_car(r, t); if (cdr(l) != r) r = opt1(r);} + * immutable check is needed else (reverse! (catch #t 1 cons)) clobbers sc->wrong_type_arg_info + */ + + case T_BYTE_VECTOR: + case T_STRING: + { + s7_int len; + uint8_t *bytes; + if (is_immutable(p)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->reverseb_symbol, p))); + if (is_string(p)) { + len = string_length(p); + bytes = (uint8_t *) string_value(p); + } else { + len = byte_vector_length(p); + bytes = byte_vector_bytes(p); + } + if (len < 2) + return (p); + +#if (defined(__linux__)) && (defined(__GLIBC__)) /* need byteswp.h */ + /* this code (from StackOverflow) is much faster: */ + if ((len & 0x1f) == 0) { +#include + uint32_t *dst = (uint32_t *) (bytes + len - 4); + uint32_t *src = (uint32_t *) bytes; + while (src < dst) { + uint32_t a, b; + LOOP_4(a = *src; + b = *dst; + *src++ = bswap_32(b); *dst-- = bswap_32(a)); + } + } else +#endif + { + char *s1 = (char *) bytes, *s2; + s2 = (char *) (s1 + len - 1); + while (s1 < s2) { + char c; + c = *s1; + *s1++ = *s2; + *s2-- = c; + } + }} + break; + + case T_INT_VECTOR: + { + s7_int len = vector_length(p); + s7_int *s1, *s2; + if (is_immutable_vector(p)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->reverseb_symbol, p))); + if (len < 2) + return (p); + s1 = int_vector_ints(p); + s2 = (s7_int *) (s1 + len - 1); + if ((len & 0xf) == 0) /* not 0x7 -- odd multiple of 8 will leave center ints unreversed */ + while (s1 < s2) { + s7_int c; + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + } else + while (s1 < s2) { + s7_int c; + c = *s1; + *s1++ = *s2; + *s2-- = c; + } + } + break; + + case T_FLOAT_VECTOR: + { + s7_int len = vector_length(p); + s7_double *s1, *s2; + if (is_immutable_vector(p)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->reverseb_symbol, p))); + if (len < 2) + return (p); + s1 = float_vector_floats(p); + s2 = (s7_double *) (s1 + len - 1); + if ((len & 0xf) == 0) + while (s1 < s2) { + s7_double c; + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + } else + while (s1 < s2) { + s7_double c; + c = *s1; + *s1++ = *s2; + *s2-- = c; + } + } + break; + + case T_VECTOR: + { + s7_int len = vector_length(p); + s7_pointer *s1, *s2; + if (is_immutable_vector(p)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->reverseb_symbol, p))); + if (len < 2) + return (p); + s1 = vector_elements(p); + s2 = (s7_pointer *) (s1 + len - 1); + if ((len & 0xf) == 0) + while (s1 < s2) { + s7_pointer c; + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + } else + while (s1 < s2) { + s7_pointer c; + c = *s1; + *s1++ = *s2; + *s2-- = c; + } + } + break; + + default: + if (is_immutable(p)) { + if (is_simple_sequence(p)) + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, + sc->reverseb_symbol, p))); + return (simple_wrong_type_argument_with_type + (sc, sc->reverseb_symbol, p, a_sequence_string)); + } + if ((is_simple_sequence(p)) && (!has_active_methods(sc, p))) + return (simple_wrong_type_argument_with_type + (sc, sc->reverseb_symbol, p, + wrap_string(sc, "a vector, string, or list", 25))); + return (method_or_bust_with_type_one_arg_p + (sc, p, sc->reverseb_symbol, a_sequence_string)); + } + return (p); +} + + +/* -------------------------------- fill! -------------------------------- */ +static s7_pointer pair_fill(s7_scheme * sc, s7_pointer args) +{ + /* ambiguous ("tree-fill"?) but if it's like vector-fill, we just stomp on the top level */ + s7_pointer x, y, obj = car(args), val, p; + s7_int i, start = 0, end, len; + +#if WITH_HISTORY + if ((is_immutable_pair(obj)) && (obj != sc->eval_history1) + && (obj != sc->eval_history2)) +#else + if (is_immutable_pair(obj)) +#endif + return (immutable_object_error + (sc, + set_elist_3(sc, immutable_error_string, sc->fill_symbol, + obj))); + if (obj == global_value(sc->features_symbol)) + return (s7_error + (sc, sc->out_of_range_symbol, + set_elist_1(sc, + wrap_string(sc, "can't fill! *features*", + 22)))); + if (obj == global_value(sc->libraries_symbol)) + return (s7_error + (sc, sc->out_of_range_symbol, + set_elist_1(sc, + wrap_string(sc, "can't fill! *libraries*", + 23)))); + + val = cadr(args); + len = s7_list_length(sc, obj); + end = len; + if (end < 0) + end = -end; + else { + if (end == 0) + end = 123123123; + } + if (!is_null(cddr(args))) { + p = start_and_end(sc, sc->fill_symbol, args, 3, cddr(args), &start, + &end); + if (p != sc->unused) + return (p); + if (start == end) + return (val); + } + if (len > 0) { + if (end < len) + len = end; + for (i = 0, p = obj; i < start; p = cdr(p), i++); + for (; i < len; p = cdr(p), i++) + set_car(p, val); + return (val); + } + for (x = obj, y = obj, i = 0;; i++) { + if ((end > 0) && (i >= end)) + return (val); + if (i >= start) + set_car(x, val); + if (!is_pair(cdr(x))) { + if (!is_null(cdr(x))) + set_cdr(x, val); + return (val); + } + x = cdr(x); + if ((i & 1) != 0) + y = cdr(y); + if (x == y) + return (val); + } + return (val); +} + +s7_pointer s7_fill(s7_scheme * sc, s7_pointer args) +{ +#define H_fill "(fill! obj val (start 0) end) fills obj with val" +#define Q_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->T, sc->is_integer_symbol) + + s7_pointer p = car(args); + switch (type(p)) { + case T_STRING: + return (g_string_fill_1(sc, sc->fill_symbol, args)); /* redundant type check here and below */ + + case T_BYTE_VECTOR: + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + return (g_vector_fill_1(sc, sc->fill_symbol, args)); + + case T_PAIR: + return (pair_fill(sc, args)); + + case T_NIL: + if (!is_null(cddr(args))) /* (fill! () 1 21 #\a)? */ + eval_error(sc, "fill! () ... includes indices: ~S?", 34, + cddr(args)); + return (cadr(args)); /* this parallels the empty vector case */ + + case T_HASH_TABLE: + return (hash_table_fill(sc, args)); + + case T_LET: + check_method(sc, p, sc->fill_symbol, args); + return (let_fill(sc, args)); + + case T_C_OBJECT: + check_method(sc, p, sc->fill_symbol, args); + if (c_object_fill(sc, p)) /* default is NULL (s7_make_c_type) */ + return ((*(c_object_fill(sc, p))) (sc, args)); + eval_error(sc, "attempt to fill ~S?", 19, p); + + default: + check_method(sc, p, sc->fill_symbol, args); + } + return (wrong_type_argument_with_type(sc, sc->fill_symbol, 1, p, a_sequence_string)); /* (fill! 1 0) */ +} + +#define g_fill s7_fill +/* perhaps (fill iterator obj) could fill the underlying sequence (if any) -- not let/closure + * similarly for length, reverse etc + */ + + +/* -------------------------------- append -------------------------------- */ +static s7_int sequence_length(s7_scheme * sc, s7_pointer lst) +{ + switch (type(lst)) { + case T_PAIR: + { + s7_int len; + len = s7_list_length(sc, lst); + return ((len == 0) ? -1 : len); + } + case T_NIL: + return (0); + case T_BYTE_VECTOR: + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + return (vector_length(lst)); + case T_STRING: + return (string_length(lst)); + case T_HASH_TABLE: + return (hash_table_entries(lst)); + case T_LET: + return (let_length(sc, lst)); + case T_C_OBJECT: + { + s7_pointer x; + x = c_object_length(sc, lst); + if (s7_is_integer(x)) + return (s7_integer_checked(sc, x)); + } + } + return (-1); +} + +static s7_int total_sequence_length(s7_scheme * sc, s7_pointer args, + s7_pointer caller, uint8_t typ) +{ + s7_pointer p; + s7_int i, len = 0; + + for (i = 1, p = args; is_pair(p); p = cdr(p), i++) { + s7_pointer seq = car(p); + s7_int n; + n = sequence_length(sc, seq); + if ((n > 0) && (typ != T_FREE) && ((type(seq) == T_HASH_TABLE) || /* can't append hash-tables (no obvious meaning to the operation) */ + ((type(seq) == T_LET) && /* similarly for lets, unless this is a mock-string or something similar */ + ((!has_active_methods(sc, seq)) + || + (find_method(sc, seq, caller) + == sc->undefined))))) { + wrong_type_argument(sc, caller, i, seq, typ); + return (0); + } + if (n < 0) { + wrong_type_argument_with_type(sc, caller, i, seq, + (is_pair(seq)) ? + a_proper_list_string : + a_sequence_string); + return (0); + } + len += n; + } + return (len); +} + +static s7_pointer vector_append(s7_scheme * sc, s7_pointer args, + uint8_t typ, s7_pointer caller) +{ + s7_pointer new_vec, p, pargs; + s7_pointer *v_elements = NULL; + s7_double *fv_elements = NULL; + s7_int *iv_elements = NULL; + uint8_t *byte_elements = NULL; + s7_int i, len; + + s7_gc_protect_via_stack(sc, args); + len = + total_sequence_length(sc, args, caller, + (typ == + T_VECTOR) ? T_FREE : ((typ == + T_FLOAT_VECTOR) ? + T_REAL : T_INTEGER)); + if (len > sc->max_vector_length) { + unstack(sc); + return (s7_error(sc, sc->out_of_range_symbol, + set_elist_4(sc, + wrap_string(sc, + "~S new vector length, ~D, is larger than (*s7* 'max-vector-length): ~D", + 70), caller, + wrap_integer1(sc, len), + wrap_integer2(sc, + sc->max_vector_length)))); + } + new_vec = make_vector_1(sc, len, (typ == T_VECTOR) ? FILLED : NOT_FILLED, typ); /* might hit GC in loop below so we can't use NOT_FILLED here (??) */ + add_vector(sc, new_vec); + if (len == 0) { + unstack(sc); + return (new_vec); + } + if (typ == T_VECTOR) + v_elements = vector_elements(new_vec); + else if (typ == T_FLOAT_VECTOR) + fv_elements = float_vector_floats(new_vec); + else if (typ == T_INT_VECTOR) + iv_elements = int_vector_ints(new_vec); + else + byte_elements = byte_vector_bytes(new_vec); + + pargs = list_2(sc, sc->F, new_vec); /* car set below */ + push_stack_no_let(sc, OP_GC_PROTECT, new_vec, pargs); + + for (i = 0, p = args; is_pair(p); p = cdr(p)) { /* in-place copy by goofing with new_vec's elements pointer */ + s7_int n; + s7_pointer x = car(p); + n = sequence_length(sc, x); + if (n > 0) { + vector_length(new_vec) = n; + set_car(pargs, x); + s7_copy_1(sc, caller, pargs); /* not set_plist_2 here! */ + vector_length(new_vec) = 0; /* so GC doesn't march off the end */ + i += n; + if (typ == T_VECTOR) + vector_elements(new_vec) = (s7_pointer *) (v_elements + i); + else if (typ == T_FLOAT_VECTOR) + float_vector_floats(new_vec) = + (s7_double *) (fv_elements + i); + else if (typ == T_INT_VECTOR) + int_vector_ints(new_vec) = (s7_int *) (iv_elements + i); + else + byte_vector_bytes(new_vec) = + (uint8_t *) (byte_elements + i); + } + } + unstack(sc); + /* free_cell(sc, pargs); *//* this is trouble if any arg is openlet with append method -- e.g. block */ + + if (typ == T_VECTOR) + vector_elements(new_vec) = v_elements; + else if (typ == T_FLOAT_VECTOR) + float_vector_floats(new_vec) = fv_elements; + else if (typ == T_INT_VECTOR) + int_vector_ints(new_vec) = iv_elements; + else + byte_vector_bytes(new_vec) = byte_elements; + vector_length(new_vec) = len; + + unstack(sc); + return (new_vec); +} + +static s7_pointer hash_table_append(s7_scheme * sc, s7_pointer args) +{ + s7_pointer new_hash, p; + new_hash = s7_make_hash_table(sc, sc->default_hash_table_length); + push_stack_no_let(sc, OP_GC_PROTECT, args, new_hash); + for (p = args; is_pair(p); p = cdr(p)) + s7_copy_1(sc, sc->append_symbol, + set_plist_2(sc, car(p), new_hash)); + set_plist_2(sc, sc->nil, sc->nil); + unstack(sc); + return (new_hash); +} + +static s7_pointer let_append(s7_scheme * sc, s7_pointer args) +{ + s7_pointer new_let, p, e = car(args); + check_method(sc, e, sc->append_symbol, args); + s7_gc_protect_via_stack(sc, args); + new_let = make_let_slowly(sc, sc->nil); + for (p = args; is_pair(p); p = cdr(p)) + s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, car(p), new_let)); + set_plist_2(sc, sc->nil, sc->nil); + unstack(sc); + return (new_let); +} + +static s7_pointer g_append(s7_scheme * sc, s7_pointer args) +{ +#define H_append "(append ...) returns its argument sequences appended into one sequence" +#define Q_append s7_make_circular_signature(sc, 0, 1, sc->T) + + if (is_null(args)) + return (sc->nil); /* (append) -> () */ + if (is_null(cdr(args))) + return (car(args)); /* (append ) -> */ + sc->value = args; + args = copy_proper_list(sc, args); /* copied since other args might invoke methods */ + sc->value = args; + switch (type(car(args))) { + case T_NIL: + case T_PAIR: + return (g_list_append(sc, args)); + case T_STRING: + return (g_string_append_1(sc, args, sc->append_symbol)); + case T_HASH_TABLE: + return (hash_table_append(sc, args)); + case T_LET: + return (let_append(sc, args)); + case T_VECTOR: + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_BYTE_VECTOR: + return (vector_append + (sc, args, type(car(args)), sc->append_symbol)); + default: + check_method(sc, car(args), sc->append_symbol, args); + } + return (wrong_type_argument_with_type(sc, sc->append_symbol, 1, car(args), a_sequence_string)); /* (append 1 0) */ +} + +static s7_pointer append_p_ppp(s7_scheme * sc, s7_pointer p1, + s7_pointer p2, s7_pointer p3) +{ + return (g_append(sc, set_plist_3(sc, p1, p2, p3))); +} + +s7_pointer s7_append(s7_scheme * sc, s7_pointer a, s7_pointer b) +{ + if (is_pair(a)) { + s7_pointer q, p, np, op; + if ((!is_pair(b)) && (!is_null(b))) + return (g_list_append(sc, list_2(sc, a, b))); + q = list_1(sc, car(a)); + sc->y = q; + for (op = a, p = cdr(a), np = q; (is_pair(p)) && (p != op); + p = cdr(p), np = cdr(np), op = cdr(op)) { + set_cdr(np, list_1_unchecked(sc, car(p))); + p = cdr(p); + np = cdr(np); + if (!is_pair(p)) + break; + set_cdr(np, list_1(sc, car(p))); + } + if (!is_null(p)) + return (wrong_type_argument_with_type + (sc, sc->append_symbol, 1, a, a_proper_list_string)); + set_cdr(np, b); + sc->y = sc->nil; + return (q); + } + if (is_null(a)) + return (b); + return (g_append(sc, set_plist_2(sc, a, b))); +} + +static s7_pointer g_append_2(s7_scheme * sc, s7_pointer args) +{ + return (s7_append(sc, car(args), cadr(args))); +} + +static s7_pointer append_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if (args == 2) + return (sc->append_2); + return (f); +} + + +/* -------------------------------- object->let -------------------------------- */ +static s7_pointer byte_vector_to_list(s7_scheme * sc, const uint8_t * str, + s7_int len) +{ + s7_int i; + s7_pointer p; + if (len == 0) + return (sc->nil); + check_free_heap_size(sc, len); + sc->w = sc->nil; + for (i = len - 1; i >= 0; i--) + sc->w = cons_unchecked(sc, small_int((uint32_t) (str[i])), sc->w); + p = sc->w; + sc->w = sc->nil; + return (p); +} + +static s7_pointer hash_table_to_list(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer x, iterator; + if (hash_table_entries(obj) <= 0) + return (sc->nil); + iterator = s7_make_iterator(sc, obj); + sc->temp8 = iterator; + sc->w = sc->nil; + while (true) { + x = s7_iterate(sc, iterator); + if (iterator_is_at_end(iterator)) + break; + sc->w = cons(sc, x, sc->w); + } + x = sc->w; + sc->w = sc->nil; + sc->temp8 = sc->nil; /* free_cell(sc, iterator); *//* 16-Nov-18 but then 18-Dec-18 got free cell that was iterator */ + return (x); +} + +static s7_pointer iterator_to_list(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer result = sc->nil, p = NULL; + s7_int results = 0; + while (true) { + s7_pointer val; + val = s7_iterate(sc, obj); + if ((val == ITERATOR_END) && (iterator_is_at_end(obj))) { + sc->temp8 = sc->nil; + return (result); + } + if (sc->safety > NO_SAFETY) { + results++; + if (results > 10000) { + s7_warn(sc, 256, + "iterator is creating a very long list!\n"); + results = S7_INT32_MIN; + } + } + if (val != sc->no_value) { + if (is_null(result)) { + if (is_multiple_value(val)) { + result = multiple_value(val); + clear_multiple_value(val); + for (p = result; is_pair(cdr(p)); p = cdr(p)); + } else { + result = list_1(sc, val); + p = result; + } + sc->temp8 = result; + } else if (is_multiple_value(val)) { + set_cdr(p, multiple_value(val)); + clear_multiple_value(val); + for (; is_pair(cdr(p)); p = cdr(p)); + } else { + set_cdr(p, list_1(sc, val)); + p = cdr(p); + } + } + } +} + +static s7_pointer c_obj_to_list(s7_scheme * sc, s7_pointer obj) +{ /* "c_object_to_list" is the ->list method mentioned below */ + int64_t i, len; + s7_pointer x, z, zc, result; + s7_int gc_z; + + if (c_object_to_list(sc, obj)) + return ((*(c_object_to_list(sc, obj))) (sc, set_plist_1(sc, obj))); + + x = c_object_length(sc, obj); + if (s7_is_integer(x)) + len = s7_integer_checked(sc, x); + else + return (sc->F); + + if (len < 0) + return (sc->F); + if (len == 0) + return (sc->nil); + + result = make_list(sc, len, sc->nil); + sc->temp8 = result; + z = list_2_unchecked(sc, obj, zc = make_mutable_integer(sc, 0)); + gc_z = gc_protect_1(sc, z); + set_car(sc->z2_1, sc->x); + set_car(sc->z2_2, sc->z); + for (i = 0, x = result; i < len; i++, x = cdr(x)) { + integer(zc) = i; + set_car(x, (*(c_object_ref(sc, obj))) (sc, z)); + } + sc->x = car(sc->z2_1); + sc->z = car(sc->z2_2); + s7_gc_unprotect_at(sc, gc_z); + sc->temp8 = sc->nil; + return (result); +} + +static s7_pointer object_to_list(s7_scheme * sc, s7_pointer obj) +{ + /* used only in format_to_port_1 and (map values ...) */ + switch (type(obj)) { + case T_STRING: + return (string_to_list(sc, string_value(obj), string_length(obj))); + case T_BYTE_VECTOR: + return (byte_vector_to_list + (sc, byte_vector_bytes(obj), byte_vector_length(obj))); + case T_HASH_TABLE: + return (hash_table_to_list(sc, obj)); + case T_ITERATOR: + return (iterator_to_list(sc, obj)); + case T_C_OBJECT: + return (c_obj_to_list(sc, obj)); + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + return (s7_vector_to_list(sc, obj)); + case T_LET: +#if (!WITH_PURE_S7) + check_method(sc, obj, sc->let_to_list_symbol, + set_plist_1(sc, obj)); +#endif + return (s7_let_to_list(sc, obj)); + } + return (obj); +} + +static s7_pointer symbol_to_let(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer let; + let = g_local_inlet(sc, 4, sc->value_symbol, obj, + sc->type_symbol, + (is_keyword(obj)) ? sc->is_keyword_symbol + : ((is_gensym(obj)) ? sc->is_gensym_symbol : + sc->is_symbol_symbol)); + if (!is_keyword(obj)) { + s7_pointer val; + s7_int gc_loc; + gc_loc = gc_protect_1(sc, let); + if (!sc->current_value_symbol) + sc->current_value_symbol = make_symbol(sc, "current-value"); + val = s7_symbol_value(sc, obj); + s7_varlet(sc, let, sc->current_value_symbol, val); + s7_varlet(sc, let, sc->setter_symbol, + g_setter(sc, set_plist_1(sc, obj))); + s7_varlet(sc, let, sc->mutable_symbol, + s7_make_boolean(sc, !is_immutable_symbol(obj))); + if (!is_undefined(val)) { + const char *doc; + doc = s7_documentation(sc, obj); + if (doc) + s7_varlet(sc, let, sc->local_documentation_symbol, + s7_make_string(sc, doc)); + } + s7_gc_unprotect_at(sc, gc_loc); + } + return (let); +} + +static s7_pointer random_state_to_let(s7_scheme * sc, s7_pointer obj) +{ +#if WITH_GMP + return (g_local_inlet + (sc, 4, sc->value_symbol, obj, sc->type_symbol, + sc->is_random_state_symbol)); +#else + if (!sc->seed_symbol) { + sc->seed_symbol = make_symbol(sc, "seed"); + sc->carry_symbol = make_symbol(sc, "carry"); + } + return (g_local_inlet(sc, 8, sc->value_symbol, obj, + sc->type_symbol, sc->is_random_state_symbol, + sc->seed_symbol, make_integer(sc, + random_seed(obj)), + sc->carry_symbol, make_integer(sc, + random_carry + (obj)))); +#endif +} + +static s7_pointer vector_to_let(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer let; + s7_int gc_loc; + + if (!sc->dimensions_symbol) + sc->dimensions_symbol = make_symbol(sc, "dimensions"); + if (!sc->original_vector_symbol) + sc->original_vector_symbol = make_symbol(sc, "original-vector"); + let = g_local_inlet(sc, 10, sc->value_symbol, obj, + sc->type_symbol, (is_subvector(obj)) ? cons(sc, + sc->is_subvector_symbol, + s7_type_of + (sc, + subvector_vector + (obj))) + : s7_type_of(sc, obj), sc->size_symbol, + s7_length(sc, obj), sc->dimensions_symbol, + g_vector_dimensions(sc, set_plist_1(sc, obj)), + sc->mutable_symbol, s7_make_boolean(sc, + !is_immutable_vector + (obj))); + gc_loc = gc_protect_1(sc, let); + if (is_subvector(obj)) { + s7_int pos = 0; + switch (type(obj)) { /* correct type matters here: gcc 10.2 with -O2 segfaults otherwise, cast to intptr_t has a similar role in earlier gcc's */ + case T_VECTOR: + pos = (s7_int) ((intptr_t) + (vector_elements(obj) - + vector_elements(subvector_vector(obj)))); + break; + case T_INT_VECTOR: + pos = (s7_int) ((intptr_t) + (int_vector_ints(obj) - + int_vector_ints(subvector_vector(obj)))); + break; + case T_FLOAT_VECTOR: + pos = (s7_int) ((intptr_t) + (float_vector_floats(obj) - + float_vector_floats(subvector_vector(obj)))); + break; + case T_BYTE_VECTOR: + pos = (s7_int) ((intptr_t) + (byte_vector_bytes(obj) - + byte_vector_bytes(subvector_vector(obj)))); + break; + } + s7_varlet(sc, let, sc->position_symbol, make_integer(sc, pos)); + s7_varlet(sc, let, sc->original_vector_symbol, + subvector_vector(obj)); + } + if (is_typed_vector(obj)) + s7_varlet(sc, let, sc->signature_symbol, + g_signature(sc, set_plist_1(sc, obj))); + s7_gc_unprotect_at(sc, gc_loc); + return (let); +} + +static s7_pointer hash_table_to_let(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer let; + s7_int gc_loc; + if (!sc->entries_symbol) { + sc->entries_symbol = make_symbol(sc, "entries"); + sc->locked_symbol = make_symbol(sc, "locked"); + sc->weak_symbol = make_symbol(sc, "weak"); + } + let = g_local_inlet(sc, 12, sc->value_symbol, obj, + sc->type_symbol, sc->is_hash_table_symbol, + sc->size_symbol, s7_length(sc, obj), + sc->entries_symbol, make_integer(sc, + hash_table_entries + (obj)), + sc->locked_symbol, s7_make_boolean(sc, + hash_table_checker_locked + (obj)), + sc->mutable_symbol, s7_make_boolean(sc, + !is_immutable + (obj))); + gc_loc = gc_protect_1(sc, let); + if (is_weak_hash_table(obj)) + s7_varlet(sc, let, sc->weak_symbol, sc->T); + if ((hash_table_checker(obj) == hash_eq) || + (hash_table_checker(obj) == hash_c_function) || + (hash_table_checker(obj) == hash_closure) || + (hash_table_checker(obj) == hash_equal_eq) || + (hash_table_checker(obj) == hash_equal_syntax) || + (hash_table_checker(obj) == hash_symbol)) + s7_varlet(sc, let, sc->function_symbol, sc->is_eq_symbol); + else if (hash_table_checker(obj) == hash_eqv) + s7_varlet(sc, let, sc->function_symbol, sc->is_eqv_symbol); + else if ((hash_table_checker(obj) == hash_equal) || + (hash_table_checker(obj) == hash_empty)) + s7_varlet(sc, let, sc->function_symbol, sc->is_equal_symbol); + else if (hash_table_checker(obj) == hash_equivalent) + s7_varlet(sc, let, sc->function_symbol, sc->is_equivalent_symbol); + else if ((hash_table_checker(obj) == hash_number_num_eq) || + (hash_table_checker(obj) == hash_int) || + (hash_table_checker(obj) == hash_float)) + s7_varlet(sc, let, sc->function_symbol, sc->num_eq_symbol); + else if (hash_table_checker(obj) == hash_string) + s7_varlet(sc, let, sc->function_symbol, sc->string_eq_symbol); + else if (hash_table_checker(obj) == hash_char) + s7_varlet(sc, let, sc->function_symbol, sc->char_eq_symbol); +#if (!WITH_PURE_S7) + else if (hash_table_checker(obj) == hash_ci_char) + s7_varlet(sc, let, sc->function_symbol, sc->char_ci_eq_symbol); + else if (hash_table_checker(obj) == hash_ci_string) + s7_varlet(sc, let, sc->function_symbol, sc->string_ci_eq_symbol); +#endif + if (is_typed_hash_table(obj)) + s7_varlet(sc, let, sc->signature_symbol, + g_signature(sc, set_plist_1(sc, obj))); + s7_gc_unprotect_at(sc, gc_loc); + return (let); +} + +static s7_pointer iterator_to_let(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer let, seq; + s7_int gc_loc; + if (!sc->at_end_symbol) { + sc->at_end_symbol = make_symbol(sc, "at-end"); + sc->sequence_symbol = make_symbol(sc, "sequence"); + } + seq = iterator_sequence(obj); + let = g_local_inlet(sc, 8, sc->value_symbol, obj, + sc->type_symbol, sc->is_iterator_symbol, + sc->at_end_symbol, s7_make_boolean(sc, + iterator_is_at_end + (obj)), + sc->sequence_symbol, iterator_sequence(obj)); + gc_loc = gc_protect_1(sc, let); + if (is_pair(seq)) + s7_varlet(sc, let, sc->size_symbol, s7_length(sc, seq)); + else if (is_hash_table(seq)) + s7_varlet(sc, let, sc->size_symbol, + make_integer(sc, hash_table_entries(seq))); + else + s7_varlet(sc, let, sc->size_symbol, s7_length(sc, obj)); + if ((is_string(seq)) || + (is_any_vector(seq)) || + (seq == sc->rootlet) || (is_c_object(seq)) || (is_hash_table(seq))) + s7_varlet(sc, let, sc->position_symbol, + make_integer(sc, iterator_position(obj))); + else if (is_pair(seq)) + s7_varlet(sc, let, sc->position_symbol, iterator_current(obj)); + s7_gc_unprotect_at(sc, gc_loc); + return (let); +} + +static s7_pointer let_to_let(s7_scheme * sc, s7_pointer obj) +{ + /* how to handle setters? + * (display (let ((e (let ((i 0)) (set! (setter 'i) integer?) (curlet)))) (object->let e))): + * "(inlet 'value (inlet 'i 0) 'type let? 'length 1 'open #f 'outlet () 'immutable? #f)" + */ + s7_pointer let; + s7_int gc_loc; + if (!sc->open_symbol) { + sc->open_symbol = make_symbol(sc, "open"); + sc->alias_symbol = make_symbol(sc, "alias"); + } + let = g_local_inlet(sc, 12, sc->value_symbol, obj, + sc->type_symbol, sc->is_let_symbol, + sc->size_symbol, s7_length(sc, obj), + sc->open_symbol, s7_make_boolean(sc, + has_methods(obj)), + sc->outlet_symbol, + (obj == sc->rootlet) ? sc->nil : let_outlet(obj), + sc->mutable_symbol, s7_make_boolean(sc, + !is_immutable + (obj))); + gc_loc = gc_protect_1(sc, let); + if (obj == sc->rootlet) + s7_varlet(sc, let, sc->alias_symbol, sc->rootlet_symbol); + else if (obj == sc->owlet) /* this can't happen, I think -- owlet is always copied first */ + s7_varlet(sc, let, sc->alias_symbol, sc->owlet_symbol); + else if (is_funclet(obj)) { + s7_varlet(sc, let, sc->function_symbol, funclet_function(obj)); + if ((has_let_file(obj)) && + (let_file(obj) <= (s7_int) sc->file_names_top) && + (let_line(obj) > 0) && (let_line(obj) < 1000000)) { + s7_varlet(sc, let, sc->file_symbol, + sc->file_names[let_file(obj)]); + s7_varlet(sc, let, sc->line_symbol, + make_integer(sc, let_line(obj))); + } + } else if (obj == sc->s7_let) { + s7_pointer iter; + s7_int gc_loc1; + iter = s7_make_iterator(sc, obj); + gc_loc1 = s7_gc_protect(sc, iter); + while (true) { + s7_pointer x; + x = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) + break; + s7_varlet(sc, let, car(x), cdr(x)); + } + s7_gc_unprotect_at(sc, gc_loc1); + } + if (has_active_methods(sc, obj)) { + s7_pointer func; + func = find_method(sc, obj, sc->object_to_let_symbol); + if (func != sc->undefined) + call_method(sc, obj, func, set_plist_2(sc, obj, let)); + } + s7_gc_unprotect_at(sc, gc_loc); + return (let); +} + +static s7_pointer c_object_to_let(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer let, clet; + s7_int gc_loc; + if (!sc->class_symbol) { + sc->class_symbol = make_symbol(sc, "class"); + sc->c_object_length_symbol = make_symbol(sc, "c-object-length"); + sc->c_object_ref_symbol = make_symbol(sc, "c-object-ref"); + sc->c_object_let_symbol = make_symbol(sc, "c-object-let"); + sc->c_object_set_symbol = make_symbol(sc, "c-object-set!"); + sc->c_object_copy_symbol = make_symbol(sc, "c-object-copy"); + sc->c_object_fill_symbol = make_symbol(sc, "c-object-fill!"); + sc->c_object_reverse_symbol = make_symbol(sc, "c-object-reverse"); + sc->c_object_to_list_symbol = make_symbol(sc, "c-object->list"); + sc->c_object_to_string_symbol = + make_symbol(sc, "c-object->string"); + } + clet = c_object_let(obj); + let = g_local_inlet(sc, 10, sc->value_symbol, obj, + sc->type_symbol, sc->is_c_object_symbol, + sc->c_object_type_symbol, make_integer(sc, + c_object_type + (obj)), + sc->c_object_let_symbol, clet, sc->class_symbol, + c_object_type_to_let(sc, obj)); + gc_loc = gc_protect_1(sc, let); + /* not sure these are useful */ + if (c_object_len(sc, obj)) /* c_object_length is the object length, not the procedure */ + s7_varlet(sc, let, sc->c_object_length_symbol, + s7_lambda(sc, c_object_len(sc, obj), 1, 0, false)); + if (c_object_ref(sc, obj)) + s7_varlet(sc, let, sc->c_object_ref_symbol, + s7_lambda(sc, c_object_ref(sc, obj), 1, 0, true)); + if (c_object_set(sc, obj)) + s7_varlet(sc, let, sc->c_object_set_symbol, + s7_lambda(sc, c_object_set(sc, obj), 2, 0, true)); + if (c_object_copy(sc, obj)) + s7_varlet(sc, let, sc->c_object_copy_symbol, + s7_lambda(sc, c_object_copy(sc, obj), 1, 0, true)); + if (c_object_fill(sc, obj)) + s7_varlet(sc, let, sc->c_object_fill_symbol, + s7_lambda(sc, c_object_fill(sc, obj), 1, 0, true)); + if (c_object_reverse(sc, obj)) + s7_varlet(sc, let, sc->c_object_reverse_symbol, + s7_lambda(sc, c_object_reverse(sc, obj), 1, 0, true)); + if (c_object_to_list(sc, obj)) + s7_varlet(sc, let, sc->c_object_to_list_symbol, + s7_lambda(sc, c_object_to_list(sc, obj), 1, 0, true)); + if (c_object_to_string(sc, obj)) + s7_varlet(sc, let, sc->c_object_to_string_symbol, + s7_lambda(sc, c_object_to_string(sc, obj), 1, 1, false)); + + if ((is_let(clet)) && + ((has_active_methods(sc, clet)) || (has_active_methods(sc, obj)))) + { + s7_pointer func; + func = find_method(sc, clet, sc->object_to_let_symbol); + if (func != sc->undefined) + call_method(sc, clet, func, set_plist_2(sc, obj, let)); + } + s7_gc_unprotect_at(sc, gc_loc); + return (let); +} + +static s7_pointer port_to_let(s7_scheme * sc, s7_pointer obj) +{ /* note the underbars! */ + s7_pointer let; + s7_int gc_loc; + if (!sc->data_symbol) { + sc->data_symbol = make_symbol(sc, "data"); + sc->port_type_symbol = make_symbol(sc, "port-type"); + sc->closed_symbol = make_symbol(sc, "closed"); + sc->file_info_symbol = make_symbol(sc, "file-info"); + } + let = g_local_inlet(sc, 10, sc->value_symbol, obj, + /* obj as 'value means it will say "(closed)" when subsequently the let is displayed */ + sc->type_symbol, + (is_input_port(obj)) ? sc->is_input_port_symbol : + sc->is_output_port_symbol, sc->port_type_symbol, + (is_string_port(obj)) ? sc->string_symbol + : ((is_file_port(obj)) ? sc->file_symbol : + sc->function_symbol), sc->closed_symbol, + s7_make_boolean(sc, port_is_closed(obj)), + sc->mutable_symbol, s7_make_boolean(sc, + !is_immutable_port + (obj))); + gc_loc = gc_protect_1(sc, let); + if (is_file_port(obj)) { + s7_varlet(sc, let, sc->file_symbol, + g_port_filename(sc, set_plist_1(sc, obj))); + if (is_input_port(obj)) + s7_varlet(sc, let, sc->line_symbol, + g_port_line_number(sc, set_plist_1(sc, obj))); +#if (!MS_WINDOWS) + if ((!port_is_closed(obj)) && (obj != sc->standard_error) + && (obj != sc->standard_input) + && (obj != sc->standard_output)) { + struct stat sb; + s7_varlet(sc, let, sc->file_symbol, + make_integer(sc, fileno(port_file(obj)))); + if (fstat(fileno(port_file(obj)), &sb) != -1) { + char c1[64], c2[64], str[512]; + int bytes; + strftime(c1, 64, "%a %d-%b-%Y %H:%M", + localtime(&sb.st_atime)); + strftime(c2, 64, "%a %d-%b-%Y %H:%M", + localtime(&sb.st_mtime)); + bytes = + snprintf(str, 512, + "mode: #o%d, links: %ld, owner uid: %d gid: %d, size: %ld bytes, last file access: %s, last file modification: %s", + sb.st_mode, (long) sb.st_nlink, + (int) sb.st_uid, (int) sb.st_gid, + (long) sb.st_size, c1, c2); + s7_varlet(sc, let, sc->file_info_symbol, + make_string_with_length(sc, (const char *) str, + bytes)); + } + } +#endif + } + if ((is_string_port(obj)) && /* file port might not have a data buffer */ + (port_data(obj)) && (port_data_size(obj) > 0)) { + s7_varlet(sc, let, sc->size_symbol, + make_integer(sc, port_data_size(obj))); + s7_varlet(sc, let, sc->position_symbol, + make_integer(sc, port_position(obj))); + /* I think port_data need not be null-terminated, but s7_make_string assumes it is: + * both valgrind and lib*san complain about the uninitialized data during strlen. + */ + s7_varlet(sc, let, sc->data_symbol, + make_string_with_length(sc, + (const char *) port_data(obj), + ((port_position(obj)) > + 16) ? 16 : port_position(obj))); + } + if (is_function_port(obj)) + s7_varlet(sc, let, sc->function_symbol, + (is_input_port(obj)) ? port_input_scheme_function(obj) : + port_output_scheme_function(obj)); + s7_gc_unprotect_at(sc, gc_loc); + return (let); +} + +static s7_pointer closure_to_let(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer let, sig; + const char *doc; + s7_int gc_loc; + if (!sc->source_symbol) + sc->source_symbol = make_symbol(sc, "source"); + let = g_local_inlet(sc, 8, sc->value_symbol, obj, + sc->type_symbol, + (is_t_procedure(obj)) ? sc->is_procedure_symbol : + sc->is_macro_symbol, sc->arity_symbol, s7_arity(sc, + obj), + sc->mutable_symbol, s7_make_boolean(sc, + !is_immutable + (obj))); + gc_loc = gc_protect_1(sc, let); + + sig = s7_signature(sc, obj); + if (is_pair(sig)) + s7_varlet(sc, let, sc->local_signature_symbol, sig); + + doc = s7_documentation(sc, obj); + if (doc) + s7_varlet(sc, let, sc->local_documentation_symbol, + s7_make_string(sc, doc)); + + if (is_let(closure_let(obj))) { + s7_pointer flet; + flet = closure_let(obj); + if ((has_let_file(flet)) && + (let_file(flet) <= (s7_int) sc->file_names_top) && + (let_line(flet) > 0)) { + s7_varlet(sc, let, sc->file_symbol, + sc->file_names[let_file(flet)]); + s7_varlet(sc, let, sc->line_symbol, + make_integer(sc, let_line(flet))); + } + } + + if (closure_setter(obj) != sc->F) + s7_varlet(sc, let, sc->local_setter_symbol, closure_setter(obj)); + + s7_varlet(sc, let, sc->source_symbol, + append_in_place(sc, + list_2(sc, + procedure_type_to_symbol(sc, + type(obj)), + closure_args(obj)), + closure_body(obj))); + s7_gc_unprotect_at(sc, gc_loc); + return (let); +} + +static s7_pointer c_pointer_to_let(s7_scheme * sc, s7_pointer obj) +{ + /* c_pointer_info can be a let and might have an object->let method (see c_object below) */ + if (!sc->c_type_symbol) { + sc->c_type_symbol = make_symbol(sc, "c-type"); + sc->info_symbol = make_symbol(sc, "info"); + } + if (!sc->pointer_symbol) + sc->pointer_symbol = make_symbol(sc, "pointer"); + return (g_local_inlet(sc, 10, sc->value_symbol, obj, + sc->type_symbol, sc->is_c_pointer_symbol, + sc->pointer_symbol, make_integer(sc, + (s7_int) ((intptr_t) c_pointer(obj))), sc->c_type_symbol, c_pointer_type(obj), sc->info_symbol, c_pointer_info(obj))); +} + +static s7_pointer c_function_to_let(s7_scheme * sc, s7_pointer obj) +{ + s7_pointer let, sig; + const char *doc; + s7_int gc_loc; + let = g_local_inlet(sc, 8, sc->value_symbol, obj, + sc->type_symbol, + (is_t_procedure(obj)) ? sc->is_procedure_symbol : + sc->is_macro_symbol, sc->arity_symbol, s7_arity(sc, + obj), + sc->mutable_symbol, s7_make_boolean(sc, + !is_immutable + (obj))); + gc_loc = gc_protect_1(sc, let); + sig = c_function_signature(obj); + if (is_pair(sig)) + s7_varlet(sc, let, sc->local_signature_symbol, sig); + + doc = s7_documentation(sc, obj); + if (doc) + s7_varlet(sc, let, sc->local_documentation_symbol, + s7_make_string(sc, doc)); + + if (c_function_setter(obj) != sc->F) /* c_macro_setter is the same underlying field */ + s7_varlet(sc, let, sc->local_setter_symbol, + c_function_setter(obj)); + s7_gc_unprotect_at(sc, gc_loc); + return (let); +} + +static s7_pointer goto_to_let(s7_scheme * sc, s7_pointer obj) +{ + /* there's room in s7_cell to store the procedure, but we would have to mark it (goto escapes, context GC'd) */ + if (!sc->active_symbol) { + sc->active_symbol = make_symbol(sc, "active"); + sc->goto_symbol = make_symbol(sc, "goto?"); + } + if (is_symbol(call_exit_name(obj))) + return (g_local_inlet + (sc, 8, sc->value_symbol, obj, sc->type_symbol, + sc->goto_symbol, sc->active_symbol, s7_make_boolean(sc, + call_exit_active + (obj)), + sc->name_symbol, call_exit_name(obj))); + return (g_local_inlet + (sc, 6, sc->value_symbol, obj, sc->type_symbol, + sc->goto_symbol, sc->active_symbol, s7_make_boolean(sc, + call_exit_active + (obj)))); +} + +static s7_pointer object_to_let_p_p(s7_scheme * sc, s7_pointer obj) +{ + switch (type(obj)) { + case T_NIL: + return (g_local_inlet + (sc, 4, sc->value_symbol, obj, sc->type_symbol, + sc->is_null_symbol)); + case T_UNSPECIFIED: + return (g_local_inlet + (sc, 4, sc->value_symbol, obj, sc->type_symbol, + sc->is_unspecified_symbol)); + case T_UNDEFINED: + return (g_local_inlet + (sc, 4, sc->value_symbol, obj, sc->type_symbol, + sc->is_undefined_symbol)); + case T_EOF: + return (g_local_inlet + (sc, 4, sc->value_symbol, obj, sc->type_symbol, + sc->is_eof_object_symbol)); + case T_BOOLEAN: + return (g_local_inlet + (sc, 4, sc->value_symbol, obj, sc->type_symbol, + sc->is_boolean_symbol)); + case T_CHARACTER: + return (g_local_inlet + (sc, 4, sc->value_symbol, obj, sc->type_symbol, + sc->is_char_symbol)); + case T_SYMBOL: + return (symbol_to_let(sc, obj)); + case T_RANDOM_STATE: + return (random_state_to_let(sc, obj)); + case T_GOTO: + return (goto_to_let(sc, obj)); + case T_C_POINTER: + return (c_pointer_to_let(sc, obj)); + case T_ITERATOR: + return (iterator_to_let(sc, obj)); + case T_HASH_TABLE: + return (hash_table_to_let(sc, obj)); + case T_LET: + return (let_to_let(sc, obj)); + case T_C_OBJECT: + return (c_object_to_let(sc, obj)); + + case T_INTEGER: + case T_BIG_INTEGER: + return (g_local_inlet + (sc, 4, sc->value_symbol, obj, sc->type_symbol, + sc->is_integer_symbol)); + case T_RATIO: + case T_BIG_RATIO: + return (g_local_inlet + (sc, 4, sc->value_symbol, obj, sc->type_symbol, + sc->is_rational_symbol)); + case T_REAL: + case T_BIG_REAL: + return (g_local_inlet + (sc, 4, sc->value_symbol, obj, sc->type_symbol, + sc->is_real_symbol)); + case T_COMPLEX: + case T_BIG_COMPLEX: + return (g_local_inlet + (sc, 4, sc->value_symbol, obj, sc->type_symbol, + sc->is_complex_symbol)); + + case T_STRING: + return (g_local_inlet(sc, 8, sc->value_symbol, obj, + sc->type_symbol, sc->is_string_symbol, + sc->size_symbol, str_length(sc, obj), + sc->mutable_symbol, s7_make_boolean(sc, + !is_immutable_string + (obj)))); + + case T_PAIR: + return (g_local_inlet(sc, 6, sc->value_symbol, obj, + sc->type_symbol, sc->is_pair_symbol, + sc->size_symbol, pair_length(sc, obj))); + + case T_SYNTAX: + return (g_local_inlet(sc, 6, sc->value_symbol, obj, + sc->type_symbol, sc->is_syntax_symbol, + sc->documentation_symbol, s7_make_string(sc, + syntax_documentation + (obj)))); + + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_BYTE_VECTOR: + case T_VECTOR: + return (vector_to_let(sc, obj)); + + case T_CONTINUATION: /* perhaps include the continuation-key */ + if (is_symbol(continuation_name(obj))) + return (g_local_inlet + (sc, 6, sc->value_symbol, obj, sc->type_symbol, + sc->is_continuation_symbol, sc->name_symbol, + continuation_name(obj))); + return (g_local_inlet + (sc, 4, sc->value_symbol, obj, sc->type_symbol, + sc->is_continuation_symbol)); + + case T_INPUT_PORT: + case T_OUTPUT_PORT: + return (port_to_let(sc, obj)); + + case T_CLOSURE: + case T_CLOSURE_STAR: + case T_MACRO: + case T_MACRO_STAR: + case T_BACRO: + case T_BACRO_STAR: + return (closure_to_let(sc, obj)); + + case T_C_MACRO: + case T_C_FUNCTION_STAR: + case T_C_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + case T_C_OPT_ARGS_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + return (c_function_to_let(sc, obj)); + + default: + return (sc->F); + } + return (sc->F); +} + +static s7_pointer g_object_to_let(s7_scheme * sc, s7_pointer args) +{ +#define H_object_to_let "(object->let obj) returns a let (namespace) describing obj." +#define Q_object_to_let s7_make_signature(sc, 2, sc->is_let_symbol, sc->T) + return (object_to_let_p_p(sc, car(args))); +} + + +/* ---------------- stacktrace ---------------- */ +static s7_pointer stacktrace_find_caller(s7_scheme * sc, s7_pointer e) +{ + if ((is_let(e)) && (e != sc->rootlet)) + return (((is_funclet(e)) + || (is_maclet(e))) ? funclet_function(e) : + stacktrace_find_caller(sc, let_outlet(e))); + return (sc->F); +} + +static bool stacktrace_find_let(s7_scheme * sc, int64_t loc, s7_pointer e) +{ + return ((loc > 0) && + ((stack_let(sc->stack, loc) == e) || + (stacktrace_find_let(sc, loc - 4, e)))); +} + +static int64_t stacktrace_find_error_hook_quit(s7_scheme * sc) +{ + int64_t i; + for (i = current_stack_top(sc) - 1; i >= 3; i -= 4) + if (stack_op(sc->stack, i) == OP_ERROR_HOOK_QUIT) + return (i); + return (-1); +} + +static bool stacktrace_in_error_handler(s7_scheme * sc, int64_t loc) +{ + return ((let_outlet(sc->owlet) == sc->curlet) || + (stacktrace_find_let(sc, loc * 4, let_outlet(sc->owlet))) || + (stacktrace_find_error_hook_quit(sc) > 0)); +} + +static bool stacktrace_error_hook_function(s7_scheme * sc, s7_pointer sym) +{ + if (is_symbol(sym)) { + s7_pointer f; + f = s7_symbol_value(sc, sym); + return ((is_procedure(f)) && + (is_procedure(sc->error_hook)) && + (hook_has_functions(sc->error_hook)) && + (direct_memq(f, s7_hook_functions(sc, sc->error_hook)))); + } + return (false); +} + +static char *stacktrace_walker(s7_scheme * sc, s7_pointer code, + s7_pointer e, char *notes, s7_int code_cols, + s7_int total_cols, s7_int notes_start_col, + bool as_comment, int32_t depth) +{ + if (is_symbol(code)) { + if ((!symbol_is_in_list(sc, code)) && + (!is_slot(global_slot(code)))) { + s7_pointer val; + + add_symbol_to_list(sc, code); + val = s7_symbol_local_value(sc, code, e); + if ((val) && (val != sc->undefined) && (!is_any_macro(val))) { + int32_t typ; + + typ = type(val); + if (typ < T_CONTINUATION) { + char *objstr, *str; + s7_pointer objp; + const char *spaces; + s7_int new_note_len, notes_max, spaces_len; + bool new_notes_line = false, old_short_print = + sc->short_print; + s7_int old_len = sc->print_length, objlen; + + spaces = + " "; + spaces_len = 80; + if (notes_start_col < 0) + notes_start_col = 50; + if (notes_start_col > total_cols) + notes_start_col = 0; + notes_max = total_cols - notes_start_col; + sc->short_print = true; + if (sc->print_length > 4) + sc->print_length = 4; + objp = s7_object_to_string(sc, val, true); + objstr = string_value(objp); + objlen = string_length(objp); + if ((objlen > notes_max) && (notes_max > 5)) { + objstr[notes_max - 4] = '.'; + objstr[notes_max - 3] = '.'; + objstr[notes_max - 2] = '.'; + objstr[notes_max - 1] = '\0'; + objlen = notes_max; + } + sc->short_print = old_short_print; + sc->print_length = old_len; + + new_note_len = symbol_name_length(code) + 3 + objlen; + /* we want to append this much info to the notes, but does it need a new line? */ + if (notes_start_col < code_cols) + new_notes_line = true; + else if (notes) { + char *last_newline; + s7_int cur_line_len; + last_newline = strrchr(notes, (int) '\n'); /* returns ptr to end if none = nil if not found? */ + cur_line_len = + (last_newline) ? (strlen(notes) - + strlen(last_newline)) : + strlen(notes); + new_notes_line = + ((cur_line_len + new_note_len) > notes_max); + } + if (new_notes_line) { + new_note_len += + (4 + notes_start_col + + ((notes) ? strlen(notes) : 0)); + str = (char *) Malloc(new_note_len); /* str[0] = '\0'; */ + catstrs_direct(str, + (notes) ? notes : "", + "\n", + (as_comment) ? "; " : "", + (spaces_len >= + notes_start_col) ? (char *) (spaces + + + spaces_len + - + notes_start_col) + : "", (as_comment) ? "" : " ; ", + symbol_name(code), ": ", objstr, + (const char *) NULL); + } else { + new_note_len += ((notes) ? strlen(notes) : 0) + 4; + str = (char *) Malloc(new_note_len); /* str[0] = '\0'; */ + catstrs_direct(str, + (notes) ? notes : "", + (notes) ? ", " : " ; ", + symbol_name(code), + ": ", objstr, (const char *) NULL); + } + if (notes) + free(notes); + return (str); + } + } + } + return (notes); + } + if ((is_pair(code)) && (s7_list_length(sc, code) > 0) && (depth < 32)) { + notes = + stacktrace_walker(sc, car(code), e, notes, code_cols, + total_cols, notes_start_col, as_comment, + depth + 1); + return (stacktrace_walker + (sc, cdr(code), e, notes, code_cols, total_cols, + notes_start_col, as_comment, depth + 2)); + } + return (notes); +} + +static block_t *stacktrace_add_func(s7_scheme * sc, s7_pointer f, + s7_pointer code, char *errstr, + char *notes, s7_int code_max, + bool as_comment) +{ + s7_int newlen, errlen; + char *newstr, *str; + block_t *newp, *b; + + errlen = strlen(errstr); + if ((is_symbol(f)) && (f != car(code))) { + newlen = symbol_name_length(f) + errlen + 10; + newp = mallocate(sc, newlen); + newstr = (char *) block_data(newp); + /* newstr[0] = '\0'; */ + errlen = + catstrs_direct(newstr, symbol_name(f), ": ", errstr, + (const char *) NULL); + } else { + newlen = errlen + 8; + newp = mallocate(sc, newlen); + newstr = (char *) block_data(newp); + /* newstr[0] = '\0'; */ + if ((errlen > 2) && (errstr[2] == '(')) + errlen = + catstrs_direct(newstr, " ", errstr, (const char *) NULL); + else { + memcpy((void *) newstr, (void *) errstr, errlen); + newstr[errlen] = '\0'; + }} + newlen = code_max + 8 + ((notes) ? strlen(notes) : 0); + b = mallocate(sc, newlen); + str = (char *) block_data(b); + /* str[0] = '\0'; */ + + if (errlen >= code_max) { + newstr[code_max - 4] = '.'; + newstr[code_max - 3] = '.'; + newstr[code_max - 2] = '.'; + newstr[code_max - 1] = '\0'; + catstrs_direct(str, (as_comment) ? "; " : "", newstr, + (notes) ? notes : "", "\n", (const char *) NULL); + } else { + /* send out newstr, pad with spaces to code_max, then notes */ + s7_int len; + len = + catstrs_direct(str, (as_comment) ? "; " : "", newstr, + (const char *) NULL); + if (notes) { + s7_int i; + for (i = len; i < code_max - 1; i++) + str[i] = ' '; + str[i] = '\0'; + catstrs(str, newlen, notes, "\n", (char *) NULL); + } else + catstrs(str, newlen, "\n", (char *) NULL); + } + liberate(sc, newp); + return (b); +} + +static s7_pointer stacktrace_1(s7_scheme * sc, s7_int frames_max, + s7_int code_cols, s7_int total_cols, + s7_int notes_start_col, bool as_comment) +{ + char *str = NULL; + block_t *strp = NULL; + int64_t loc, top, frames = 0; + + clear_symbol_list(sc); + top = (sc->stack_end - sc->stack_start) / 4; /* (*s7* 'stack_top), not current_stack_top! */ + + if (stacktrace_in_error_handler(sc, top)) { + s7_pointer err_code; + err_code = slot_value(sc->error_code); + if ((is_pair(err_code)) && (!tree_is_cyclic(sc, err_code))) { + char *notes = NULL; + s7_pointer current_let, f, errstr; + + errstr = s7_object_to_string(sc, err_code, false); + current_let = let_outlet(sc->owlet); + f = stacktrace_find_caller(sc, current_let); /* this is a symbol */ + if ((is_let(current_let)) && (current_let != sc->rootlet)) + notes = + stacktrace_walker(sc, err_code, current_let, NULL, + code_cols, total_cols, + notes_start_col, as_comment, 0); + strp = + stacktrace_add_func(sc, f, err_code, string_value(errstr), + notes, code_cols, as_comment); + str = (char *) block_data(strp); + } + /* now if OP_ERROR_HOOK_QUIT is in the stack, jump past it! */ + loc = stacktrace_find_error_hook_quit(sc); + if (loc > 0) + top = (loc + 1) / 4; + } + for (loc = top - 1; loc > 0; loc--) { + s7_pointer code; + s7_int true_loc = (loc + 1) * 4 - 1; + code = stack_code(sc->stack, true_loc); + if ((is_pair(code)) && (!tree_is_cyclic(sc, code))) { + s7_pointer codep; + codep = s7_object_to_string(sc, code, false); + if (string_length(codep) > 0) { + char *codestr = string_value(codep); + if ((!local_strcmp(codestr, "(result)")) && + (!local_strcmp(codestr, "(#f)")) && + (!strstr(codestr, "(stacktrace)")) && + (!strstr(codestr, "(stacktrace "))) { + s7_pointer e, f; + e = stack_let(sc->stack, true_loc); + f = stacktrace_find_caller(sc, e); + if (!stacktrace_error_hook_function(sc, f)) { + char *notes = NULL, *newstr, *catstr; + block_t *newp, *catp; + s7_int newlen; + + frames++; + if (frames > frames_max) + return (block_to_string + (sc, strp, safe_strlen((char *) + block_data + (strp)))); + + if ((is_let(e)) && (e != sc->rootlet)) + notes = + stacktrace_walker(sc, code, e, NULL, + code_cols, total_cols, + notes_start_col, + as_comment, 0); + newp = + stacktrace_add_func(sc, f, code, codestr, + notes, code_cols, + as_comment); + newstr = (char *) block_data(newp); + + if ((notes) && (notes != newstr) && (is_let(e)) + && (e != sc->rootlet)) + free(notes); + + newlen = + strlen(newstr) + 1 + ((str) ? strlen(str) : 0); + catp = mallocate(sc, newlen); + catstr = (char *) block_data(catp); + catstrs_direct(catstr, (str) ? str : "", newstr, + (const char *) NULL); + liberate(sc, newp); + if (strp) + liberate(sc, strp); + strp = catp; + str = (char *) block_data(strp); + } + } + } + } + } + return ((strp) ? + block_to_string(sc, strp, + safe_strlen((char *) block_data(strp))) : + nil_string); +} + +s7_pointer s7_stacktrace(s7_scheme * sc) +{ + return (stacktrace_1(sc, 30, 45, 80, 45, false)); +} + +static s7_pointer g_stacktrace(s7_scheme * sc, s7_pointer args) +{ +#define H_stacktrace "(stacktrace (max-frames 30) (code-cols 50) (total-cols 80) (note-col 50) as-comment) returns \ +a stacktrace as a string. Each line has two portions, the code being evaluated and a note giving \ +the value of local variables in that code. The first argument sets how many lines are displayed. \ +The next three arguments set the length and layout of those lines. 'as-comment' if #t causes each \ +line to be preceded by a semicolon." +#define Q_stacktrace s7_make_signature(sc, 6, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_boolean_symbol) + + s7_int max_frames = 30, code_cols = 50, total_cols = + 80, notes_start_col = 50; + bool as_comment = false; + + if (!is_null(args)) { + if (!s7_is_integer(car(args))) + return (method_or_bust + (sc, car(args), sc->stacktrace_symbol, args, T_INTEGER, + 1)); + max_frames = s7_integer_checked(sc, car(args)); + if ((max_frames <= 0) || (max_frames > S7_INT32_MAX)) + max_frames = 30; + args = cdr(args); + if (!is_null(args)) { + if (!s7_is_integer(car(args))) + return (wrong_type_argument + (sc, sc->stacktrace_symbol, 2, car(args), + T_INTEGER)); + code_cols = s7_integer_checked(sc, car(args)); + if ((code_cols <= 8) || (code_cols > 1024)) + code_cols = 50; + args = cdr(args); + if (!is_null(args)) { + if (!s7_is_integer(car(args))) + return (wrong_type_argument + (sc, sc->stacktrace_symbol, 3, car(args), + T_INTEGER)); + total_cols = s7_integer_checked(sc, car(args)); + if ((total_cols <= code_cols) + || (total_cols > S7_INT32_MAX)) + total_cols = 80; + args = cdr(args); + if (!is_null(args)) { + if (!s7_is_integer(car(args))) + return (wrong_type_argument + (sc, sc->stacktrace_symbol, 4, car(args), + T_INTEGER)); + notes_start_col = s7_integer_checked(sc, car(args)); + if ((notes_start_col <= 0) + || (notes_start_col > S7_INT32_MAX)) + notes_start_col = 50; + args = cdr(args); + if (!is_null(args)) { + if (!s7_is_boolean(car(args))) + return (wrong_type_argument + (sc, sc->stacktrace_symbol, 5, + car(args), T_BOOLEAN)); + as_comment = s7_boolean(sc, car(args)); + } + } + } + } + } + return (stacktrace_1 + (sc, max_frames, code_cols, total_cols, notes_start_col, + as_comment)); +} + + +/* -------- s7_history, s7_add_to_history, s7_history_enabled -------- */ + +s7_pointer s7_add_to_history(s7_scheme * sc, s7_pointer entry) +{ +#if WITH_HISTORY + set_current_code(sc, entry); +#endif + return (entry); +} + +s7_pointer s7_history(s7_scheme * sc) +{ +#if WITH_HISTORY + if (sc->cur_code == sc->history_sink) + return (sc->old_cur_code); +#endif + return (sc->cur_code); +} + +bool s7_history_enabled(s7_scheme * sc) +{ +#if WITH_HISTORY + return (sc->cur_code != sc->history_sink); +#else + return (false); +#endif +} + +bool s7_set_history_enabled(s7_scheme * sc, bool enabled) +{ +#if WITH_HISTORY + bool old_enabled; + old_enabled = (sc->cur_code == sc->history_sink); + if (enabled) /* this needs to restore the old cur_code (saving its position in the history_buffer) */ + sc->cur_code = sc->old_cur_code; + else if (sc->cur_code != sc->history_sink) { + sc->old_cur_code = sc->cur_code; + sc->cur_code = sc->history_sink; + } + return (old_enabled); +#else + return (false); +#endif +} + +#if WITH_HISTORY +static s7_pointer history_cons(s7_scheme * sc, s7_pointer code, + s7_pointer args) +{ + s7_pointer p = car(sc->history_pairs); + sc->history_pairs = cdr(sc->history_pairs); + set_car(p, code); + set_cdr(p, args); + return (p); +} +#else +#define history_cons(Sc, Code, Args) Code +#endif + + +/* -------- error handlers -------- */ + +static const char *make_type_name(s7_scheme * sc, const char *name, + article_t article) +{ + s7_int i, slen, len; + slen = safe_strlen(name); + len = slen + 8; + if (len > sc->typnam_len) { + if (sc->typnam) + free(sc->typnam); + sc->typnam = (char *) Malloc(len); + sc->typnam_len = len; + } + if (article == INDEFINITE_ARTICLE) { + i = 1; + sc->typnam[0] = 'a'; + if ((name[0] == 'a') || (name[0] == 'e') || (name[0] == 'i') + || (name[0] == 'o') || (name[0] == 'u')) + sc->typnam[i++] = 'n'; + sc->typnam[i++] = ' '; + } else + i = 0; + memcpy((void *) (sc->typnam + i), (void *) name, slen); + sc->typnam[i + slen] = '\0'; + return (sc->typnam); +} + +static const char *type_name_from_type(int32_t typ, article_t article) +{ + switch (typ) { + case T_FREE: + return ((article == NO_ARTICLE) ? "free-cell" : "a free cell"); + case T_NIL: + return ("nil"); + case T_UNUSED: + return ((article == + NO_ARTICLE) ? "#" : "the unused object"); + case T_EOF: + return ((article == + NO_ARTICLE) ? "#" : "the end-of-file object"); + case T_UNSPECIFIED: + return ((article == + NO_ARTICLE) ? "#" : + "the unspecified object"); + case T_UNDEFINED: + return ((article == + NO_ARTICLE) ? "undefined" : "an undefined object"); + case T_BOOLEAN: + return ("boolean"); + case T_STRING: + return ((article == NO_ARTICLE) ? "string" : "a string"); + case T_BYTE_VECTOR: + return ((article == NO_ARTICLE) ? "byte-vector" : "a byte-vector"); + case T_SYMBOL: + return ((article == NO_ARTICLE) ? "symbol" : "a symbol"); + case T_SYNTAX: + return ((article == NO_ARTICLE) ? "syntax" : "syntactic"); + case T_PAIR: + return ((article == NO_ARTICLE) ? "pair" : "a pair"); + case T_GOTO: + return ((article == + NO_ARTICLE) ? "goto" : "a goto (from call-with-exit)"); + case T_CONTINUATION: + return ((article == + NO_ARTICLE) ? "continuation" : "a continuation"); + case T_C_OPT_ARGS_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + case T_C_FUNCTION: + return ((article == NO_ARTICLE) ? "c-function" : "a c-function"); + case T_C_FUNCTION_STAR: + return ((article == NO_ARTICLE) ? "c-function*" : "a c-function*"); + case T_CLOSURE: + return ((article == NO_ARTICLE) ? "function" : "a function"); + case T_CLOSURE_STAR: + return ((article == NO_ARTICLE) ? "function*" : "a function*"); + case T_C_MACRO: + return ((article == NO_ARTICLE) ? "c-macro" : "a c-macro"); + case T_C_POINTER: + return ((article == NO_ARTICLE) ? "c-pointer" : "a c-pointer"); + case T_CHARACTER: + return ((article == NO_ARTICLE) ? "character" : "a character"); + case T_VECTOR: + return ((article == NO_ARTICLE) ? "vector" : "a vector"); + case T_INT_VECTOR: + return ((article == NO_ARTICLE) ? "int-vector" : "an int-vector"); + case T_FLOAT_VECTOR: + return ((article == + NO_ARTICLE) ? "float-vector" : "a float-vector"); + case T_MACRO_STAR: + return ((article == NO_ARTICLE) ? "macro*" : "a macro*"); + case T_MACRO: + return ((article == NO_ARTICLE) ? "macro" : "a macro"); + case T_BACRO_STAR: + return ((article == NO_ARTICLE) ? "bacro*" : "a bacro*"); + case T_BACRO: + return ((article == NO_ARTICLE) ? "bacro" : "a bacro"); + case T_CATCH: + return ((article == NO_ARTICLE) ? "catch" : "a catch"); + case T_STACK: + return ((article == NO_ARTICLE) ? "stack" : "a stack"); + case T_DYNAMIC_WIND: + return ((article == + NO_ARTICLE) ? "dynamic-wind" : "a dynamic-wind"); + case T_HASH_TABLE: + return ((article == NO_ARTICLE) ? "hash-table" : "a hash-table"); + case T_ITERATOR: + return ((article == NO_ARTICLE) ? "iterator" : "an iterator"); + case T_LET: + return ((article == NO_ARTICLE) ? "let" : "a let"); + case T_COUNTER: + return ((article == + NO_ARTICLE) ? "internal-counter" : "an internal counter"); + case T_RANDOM_STATE: + return ((article == + NO_ARTICLE) ? "random-state" : "a random-state"); + case T_SLOT: + return ((article == + NO_ARTICLE) ? "slot" : "a slot (variable binding)"); + case T_INTEGER: + return ((article == NO_ARTICLE) ? "integer" : "an integer"); + case T_RATIO: + return ((article == NO_ARTICLE) ? "ratio" : "a ratio"); + case T_REAL: + return ((article == NO_ARTICLE) ? "real" : "a real"); + case T_COMPLEX: + return ((article == + NO_ARTICLE) ? "complex-number" : "a complex number"); + case T_BIG_INTEGER: + return ((article == NO_ARTICLE) ? "big-integer" : "a big integer"); + case T_BIG_RATIO: + return ((article == NO_ARTICLE) ? "big-ratio" : "a big ratio"); + case T_BIG_REAL: + return ((article == NO_ARTICLE) ? "big-real" : "a big real"); + case T_BIG_COMPLEX: + return ((article == + NO_ARTICLE) ? "big-complex-number" : + "a big complex number"); + case T_INPUT_PORT: + return ((article == NO_ARTICLE) ? "input-port" : "an input port"); + case T_OUTPUT_PORT: + return ((article == + NO_ARTICLE) ? "output-port" : "an output port"); + case T_C_OBJECT: + return ((article == NO_ARTICLE) ? "c-object" : "a c_object"); + } + return (NULL); +} + +static const char *type_name(s7_scheme * sc, s7_pointer arg, + article_t article) +{ + switch (unchecked_type(arg)) { + case T_C_OBJECT: + return (make_type_name + (sc, string_value(c_object_scheme_name(sc, arg)), + article)); + case T_INPUT_PORT: + return (make_type_name + (sc, + (is_file_port(arg)) ? "input file port" + : ((is_string_port(arg)) ? "input string port" : + "input port"), article)); + case T_OUTPUT_PORT: + return (make_type_name + (sc, + (is_file_port(arg)) ? "output file port" + : ((is_string_port(arg)) ? "output string port" : + "output port"), article)); + case T_LET: + if (has_active_methods(sc, arg)) { + s7_pointer class_name; + class_name = find_method(sc, arg, sc->class_name_symbol); + if (is_symbol(class_name)) + return (make_type_name + (sc, symbol_name(class_name), article)); + } + default: + { + const char *str; + str = type_name_from_type(unchecked_type(arg), article); + if (str) + return (str); + } + } + return ("messed up object"); +} + +static s7_pointer prepackaged_type_name(s7_scheme * sc, s7_pointer x) +{ + s7_pointer p; + uint8_t typ; + if (has_active_methods(sc, x)) { + p = find_method_with_let(sc, x, sc->class_name_symbol); + if (is_symbol(p)) + return (symbol_name_cell(p)); + } + typ = type(x); + switch (typ) { + case T_C_OBJECT: + return (c_object_scheme_name(sc, x)); + case T_INPUT_PORT: + return ((is_file_port(x)) ? an_input_file_port_string + : ((is_string_port(x)) ? an_input_string_port_string : + an_input_port_string)); + case T_OUTPUT_PORT: + return ((is_file_port(x)) ? an_output_file_port_string + : ((is_string_port(x)) ? an_output_string_port_string : + an_output_port_string)); + default: + p = sc->prepackaged_type_names[type(x)]; + if (is_string(p)) + return (p); + } + return (wrap_string(sc, "unknown type!", 13)); +} + +static s7_pointer type_name_string(s7_scheme * sc, s7_pointer arg) +{ + if (type(arg) < NUM_TYPES) { + s7_pointer p; + p = sc->prepackaged_type_names[type(arg)]; /* these use INDEFINITE_ARTICLE */ + if (is_string(p)) + return (p); + } + return (s7_make_string_wrapper + (sc, type_name(sc, arg, INDEFINITE_ARTICLE))); +} + +static s7_pointer wrong_type_arg_error_prepackaged(s7_scheme * sc, + s7_pointer caller, + s7_pointer arg_n, + s7_pointer arg, + s7_pointer typnam, + s7_pointer descr) +{ + s7_pointer p = cdr(sc->wrong_type_arg_info); /* info list is '(format_string caller arg_n arg type_name descr) */ + set_car(p, caller); + p = cdr(p); + set_car(p, arg_n); + p = cdr(p); + set_car(p, arg); + p = cdr(p); + set_car(p, + (typnam == sc->unused) ? prepackaged_type_name(sc, + arg) : typnam); + p = cdr(p); + set_car(p, descr); + return (s7_error + (sc, sc->wrong_type_arg_symbol, sc->wrong_type_arg_info)); +} + +static s7_pointer simple_wrong_type_arg_error_prepackaged(s7_scheme * sc, + s7_pointer + caller, + s7_pointer arg, + s7_pointer + typnam, + s7_pointer descr) +{ + set_wlist_4(cdr(sc->simple_wrong_type_arg_info), caller, arg, + (typnam == sc->unused) ? prepackaged_type_name(sc, + arg) : + typnam, descr); + return (s7_error + (sc, sc->wrong_type_arg_symbol, + sc->simple_wrong_type_arg_info)); +} + +s7_pointer s7_wrong_type_arg_error(s7_scheme * sc, const char *caller, + s7_int arg_n, s7_pointer arg, + const char *descr) +{ + if (arg_n > 0) + return (wrong_type_arg_error_prepackaged + (sc, wrap_string(sc, caller, safe_strlen(caller)), + wrap_integer1(sc, arg_n), arg, type_name_string(sc, arg), + wrap_string(sc, descr, safe_strlen(descr)))); + return (simple_wrong_type_arg_error_prepackaged + (sc, wrap_string(sc, caller, safe_strlen(caller)), arg, + type_name_string(sc, arg), wrap_string(sc, descr, + safe_strlen(descr)))); +} + +static s7_pointer out_of_range_error_prepackaged(s7_scheme * sc, + s7_pointer caller, + s7_pointer arg_n, + s7_pointer arg, + s7_pointer descr) +{ + set_wlist_4(cdr(sc->out_of_range_info), caller, arg_n, arg, descr); + return (s7_error(sc, sc->out_of_range_symbol, sc->out_of_range_info)); +} + +static s7_pointer simple_out_of_range_error_prepackaged(s7_scheme * sc, + s7_pointer caller, + s7_pointer arg, + s7_pointer descr) +{ + set_wlist_3(cdr(sc->simple_out_of_range_info), caller, arg, descr); + return (s7_error + (sc, sc->out_of_range_symbol, sc->simple_out_of_range_info)); +} + +s7_pointer s7_out_of_range_error(s7_scheme * sc, const char *caller, + s7_int arg_n, s7_pointer arg, + const char *descr) +{ + if (arg_n > 0) + return (out_of_range_error_prepackaged + (sc, wrap_string(sc, caller, safe_strlen(caller)), + wrap_integer1(sc, arg_n), arg, wrap_string(sc, descr, + safe_strlen + (descr)))); + return (simple_out_of_range_error_prepackaged + (sc, wrap_string(sc, caller, safe_strlen(caller)), arg, + wrap_string(sc, descr, safe_strlen(descr)))); +} + +s7_pointer s7_wrong_number_of_args_error(s7_scheme * sc, + const char *caller, + s7_pointer args) +{ + return (s7_error(sc, sc->wrong_number_of_args_symbol, set_elist_2(sc, s7_make_string_wrapper(sc, caller), args))); /* "caller" includes the format directives */ +} + +static s7_pointer division_by_zero_error(s7_scheme * sc, s7_pointer caller, + s7_pointer arg) +{ + return (s7_error + (sc, sc->division_by_zero_symbol, + set_elist_3(sc, + wrap_string(sc, "~A: division by zero, ~S", 24), + caller, arg))); +} + +static s7_pointer file_error(s7_scheme * sc, const char *caller, + const char *descr, const char *name) +{ + return (s7_error(sc, sc->io_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A: ~A ~S", 9), + s7_make_string_wrapper(sc, caller), + s7_make_string_wrapper(sc, descr), + s7_make_string_wrapper(sc, name)))); +} + + +/* -------------------------------- profile -------------------------------- */ +static void swap_stack(s7_scheme * sc, opcode_t new_op, + s7_pointer new_code, s7_pointer new_args) +{ + s7_pointer code, args, e; + opcode_t op; + + sc->stack_end -= 4; + code = sc->stack_end[0]; + e = sc->stack_end[1]; + args = sc->stack_end[2]; + op = (opcode_t) (sc->stack_end[3]); /* this should be begin1 */ + if ((S7_DEBUGGING) && (op != OP_BEGIN_NO_HOOK) + && (op != OP_BEGIN_HOOK)) + fprintf(stderr, "swap %s\n", op_names[op]); + push_stack(sc, new_op, new_args, new_code); + sc->stack_end[0] = code; + sc->stack_end[1] = e; + sc->stack_end[2] = args; + sc->stack_end[3] = (s7_pointer) op; + sc->stack_end += 4; +} + +static s7_pointer find_funclet(s7_scheme * sc, s7_pointer e) +{ + if ((e == sc->rootlet) || (!is_let(e))) + return (sc->F); + if (!((is_funclet(e)) || (is_maclet(e)))) + e = let_outlet(e); + if ((e == sc->rootlet) || (!is_let(e))) + return (sc->F); + return (((is_funclet(e)) || (is_maclet(e))) ? e : sc->F); +} + +#define PD_INITIAL_SIZE 16 +enum { PD_CALLS = + 0, PD_RECUR, PD_START, PD_ITOTAL, PD_ETOTAL, PD_BLOCK_SIZE +}; + +static s7_pointer g_profile_out(s7_scheme * sc, s7_pointer args) +{ + s7_int pos; + s7_int *v; + profile_data_t *pd = sc->profile_data; + pos = symbol_position(car(args)); + v = (s7_int *) (pd->data + pos); + v[PD_RECUR]--; + if (v[PD_RECUR] == 0) { + s7_int cur_time; + cur_time = (my_clock() - v[PD_START]); + v[PD_ITOTAL] += cur_time; + v[PD_ETOTAL] += (cur_time - pd->excl[pd->excl_top]); + pd->excl_top--; + pd->excl[pd->excl_top] += cur_time; + } + return (sc->F); +} + +static s7_pointer g_profile_in(s7_scheme * sc, s7_pointer args) +{ /* only external func -- added to each profiled func by add_profile above */ +#define H_profile_in "(profile-in e) is the profiler's hook into closures" +#define Q_profile_in s7_make_signature(sc, 2, sc->T, sc->is_let_symbol) + + s7_pointer e; + if (sc->profile == 0) + return (sc->F); + + e = find_funclet(sc, car(args)); + if ((is_let(e)) && (is_symbol(funclet_function(e)))) { + s7_pointer func_name; + s7_int pos; + s7_int *v; + profile_data_t *pd = sc->profile_data; + func_name = funclet_function(e); + pos = symbol_position(func_name); + if (pos == PD_POSITION_UNSET) { + if (pd->top == pd->size) { + s7_int i; + pd->size *= 2; + pd->funcs = + (s7_pointer *) Realloc(pd->funcs, + pd->size * sizeof(s7_pointer)); + pd->data = + (s7_int *) Realloc(pd->data, + pd->size * PD_BLOCK_SIZE * + sizeof(s7_int)); + for (i = pd->top * PD_BLOCK_SIZE; + i < pd->size * PD_BLOCK_SIZE; i++) + pd->data[i] = 0; + } + pos = pd->top * PD_BLOCK_SIZE; + symbol_set_position(func_name, pos); + pd->funcs[pd->top] = func_name; + pd->top++; + if (is_gensym(func_name)) + sc->profiling_gensyms = true; + } + + v = (s7_int *) (sc->profile_data->data + pos); + v[PD_CALLS]++; + if (v[PD_RECUR] == 0) { + v[PD_START] = my_clock(); + pd->excl_top++; + if (pd->excl_top == pd->excl_size) { + pd->excl_size *= 2; + pd->excl = + (s7_int *) Realloc(pd->excl, + pd->excl_size * sizeof(s7_int)); + } + pd->excl[pd->excl_top] = 0; + } + v[PD_RECUR]++; + + /* this doesn't work in "continuation passing" code (e.g. cpstak.scm in the so-called standard benchmarks). + * swap_stack pushes dynamic_unwind, but we don't pop back to it, so the stack grows to the recursion depth. + */ + if (sc->stack_end >= sc->stack_resize_trigger) { +#define PROFILE_MAX_STACK_SIZE 10000000 /* around 5G counting lets/arglists/slots, maybe an *s7* field for this? */ + if (sc->stack_size > PROFILE_MAX_STACK_SIZE) + s7_error(sc, make_symbol(sc, "stack-too-big"), + set_elist_2(sc, + wrap_string(sc, + "profiling stack size has grown past ~D", + 38), make_integer(sc, + PROFILE_MAX_STACK_SIZE))); + /* rather than raise an error, we could unwind the stack here, popping off all unwind entries, but this is + * a very rare problem, and the results will be confusing anyway. + */ + resize_stack(sc); + } + swap_stack(sc, OP_DYNAMIC_UNWIND_PROFILE, sc->profile_out, + func_name); + } + return (sc->F); +} + +static s7_pointer profile_info_out(s7_scheme * sc) +{ + s7_pointer p, vs, vi; + profile_data_t *pd = sc->profile_data; + if ((!pd) || (pd->top == 0)) + return (sc->F); + + p = list_3(sc, sc->F, sc->F, make_integer(sc, ticks_per_second())); + sc->w = p; + set_car(p, vs = make_simple_vector(sc, pd->top)); + memcpy((void *) (vector_elements(vs)), (void *) (pd->funcs), + pd->top * sizeof(s7_pointer)); + set_car(cdr(p), vi = + make_simple_int_vector(sc, pd->top * PD_BLOCK_SIZE)); + memcpy((void *) int_vector_ints(vi), (void *) pd->data, + pd->top * PD_BLOCK_SIZE * sizeof(s7_int)); + sc->w = sc->nil; + return (p); +} + +static s7_pointer clear_profile_info(s7_scheme * sc) +{ + if (sc->profile_data) { + profile_data_t *pd = sc->profile_data; + int32_t i; + for (i = 0; i < pd->top; i++) + symbol_set_position(pd->funcs[i], PD_POSITION_UNSET); + memclr64(pd->data, pd->top * PD_BLOCK_SIZE * sizeof(s7_int)); /* memclr64 ok because init_size is 16 and we double when resizing */ + pd->top = 0; + for (i = 0; i < pd->excl_top; i++) + pd->excl[i] = 0; + pd->excl_top = 0; + sc->profiling_gensyms = false; + } + return (sc->F); +} + +static s7_pointer make_profile_info(s7_scheme * sc) +{ + if (!sc->profile_data) { + profile_data_t *pd; + pd = (profile_data_t *) Malloc(sizeof(profile_data_t)); + pd->size = PD_INITIAL_SIZE; + pd->excl_size = PD_INITIAL_SIZE; + pd->top = 0; + pd->excl_top = 0; + pd->funcs = (s7_pointer *) Calloc(pd->size, sizeof(s7_pointer)); + pd->excl = (s7_int *) Calloc(pd->excl_size, sizeof(s7_int)); + pd->data = + (s7_int *) Calloc(pd->size * PD_BLOCK_SIZE, sizeof(s7_int)); + sc->profile_data = pd; + } + return (sc->F); +} + + +/* -------------------------------- dynamic-unwind -------------------------------- */ +static s7_pointer dynamic_unwind(s7_scheme * sc, s7_pointer func, + s7_pointer e) +{ + if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) + fprintf(stderr, "%s[%d]: unexpected multiple-value! %s %s %s\n", + __func__, __LINE__, display(func), display(e), + display(sc->value)); + return (s7_apply_function(sc, func, set_plist_2(sc, e, sc->value))); /* s7_apply_function returns sc->value */ +} + +static s7_pointer g_dynamic_unwind(s7_scheme * sc, s7_pointer args) +{ +#define H_dynamic_unwind "(dynamic-unwind func arg) pushes func and arg on the stack, then (func arg) is called when the stack unwinds." +#define Q_dynamic_unwind s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->T) + swap_stack(sc, OP_DYNAMIC_UNWIND, car(args), cadr(args)); + return (cadr(args)); +} + + +/* -------------------------------- catch -------------------------------- */ +static s7_pointer g_catch(s7_scheme * sc, s7_pointer args) +{ +#define H_catch "(catch tag thunk handler) evaluates thunk; if an error occurs that matches the tag (#t matches all), the handler is called" +#define Q_catch s7_make_signature(sc, 4, sc->values_symbol, s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_boolean_symbol), sc->is_procedure_symbol, sc->is_procedure_symbol) + + s7_pointer p, proc = cadr(args), err = caddr(args); + + /* Guile sets up the catch before looking for arg errors: + * (catch #t log (lambda args "hiho")) -> "hiho" + * which is consistent in that (catch #t (lambda () (log))...) should probably be the same as (catch #t log ...) + * but what if the error handler arg is messed up? Seems weird to handle args in reverse order with an intervening let etc. + */ + /* if (is_let(err)) check_method(sc, err, sc->catch_symbol, args); *//* causes exit from s7! */ + + new_cell(sc, p, T_CATCH); + catch_tag(p) = car(args); + catch_goto_loc(p) = current_stack_top(sc); + catch_op_loc(p) = (int32_t) (sc->op_stack_now - sc->op_stack); + catch_set_handler(p, err); + + if (is_any_macro(err)) + push_stack(sc, OP_CATCH_2, args, p); + else + push_stack(sc, OP_CATCH, args, p); /* args ignored but maybe safer for GC? */ + + /* not sure about these error checks -- they can be omitted */ + if (!is_thunk(sc, proc)) + return (wrong_type_argument_with_type + (sc, sc->catch_symbol, 2, proc, a_thunk_string)); + if (!is_applicable(err)) + return (wrong_type_argument_with_type + (sc, sc->catch_symbol, 3, err, + something_applicable_string)); + + /* should we check here for (aritable? err 2)? + * (catch #t (lambda () 1) "hiho") -> 1 + * currently this is checked only if the error handler is called + */ + + if (is_closure(proc)) { /* not also lambda* here because we need to handle the arg defaults */ + /* is_thunk above checks is_aritable(proc, 0), but if it's (lambda args ...) we have to set up the let with args=() + * the case that caught this: (catch #t make-hook ...) + */ + sc->code = closure_body(proc); + if (is_symbol(closure_args(proc))) + sc->curlet = + make_let_with_slot(sc, closure_let(proc), + closure_args(proc), sc->nil); + else + sc->curlet = make_let(sc, closure_let(proc)); + push_stack_no_args_direct(sc, sc->begin_op); + } else + push_stack(sc, OP_APPLY, sc->nil, proc); + return (sc->F); +} + +s7_pointer s7_call_with_catch(s7_scheme * sc, s7_pointer tag, + s7_pointer body, s7_pointer error_handler) +{ + s7_pointer p, result; + new_cell(sc, p, T_CATCH); + catch_tag(p) = tag; + catch_goto_loc(p) = current_stack_top(sc); + catch_op_loc(p) = (int32_t) (sc->op_stack_now - sc->op_stack); + catch_set_handler(p, error_handler); + if (!sc->longjmp_ok) { + declare_jump_info(); + TRACK(sc); + store_jump_info(sc); + set_jump_info(sc, S7_CALL_SET_JUMP); + if (jump_loc != NO_JUMP) { + if (jump_loc != ERROR_JUMP) + eval(sc, sc->cur_op); + if ((jump_loc == CATCH_JUMP) && /* we're returning (back to eval) from an error in catch */ + (sc->stack_end == sc->stack_start)) + push_stack_op(sc, OP_ERROR_QUIT); + result = sc->value; + } else { + push_stack(sc, OP_CATCH, error_handler, p); + result = s7_call(sc, body, sc->nil); + } + restore_jump_info(sc); + } else { + push_stack(sc, OP_CATCH, error_handler, p); + result = s7_call(sc, body, sc->nil); + } + return (result); +} + +static void op_c_catch(s7_scheme * sc) +{ + /* (catch #t (lambda () (set! ("hi") #\a)) (lambda args args)) + * code is (catch #t (lambda () ....) (lambda args ....)) + */ + s7_pointer p, f = cadr(sc->code), args = cddr(sc->code), tag; + + /* defer making the error lambda */ + if (!is_pair(f)) /* (catch #t ...) or (catch sym ...) */ + tag = (is_symbol(f)) ? lookup_checked(sc, f) : f; + else + tag = cadr(f); /* (catch 'sym ...) */ + + new_cell(sc, p, T_CATCH); /* the catch object sitting on the stack */ + catch_tag(p) = tag; + catch_goto_loc(p) = current_stack_top(sc); + catch_op_loc(p) = sc->op_stack_now - sc->op_stack; + catch_set_handler(p, cdadr(args)); /* not yet a closure... */ + + push_stack(sc, OP_CATCH_1, sc->code, p); /* code ignored here, except by GC */ + sc->curlet = make_let(sc, sc->curlet); + sc->code = T_Pair(cddar(args)); +} + +static void op_c_catch_all(s7_scheme * sc) +{ + sc->curlet = make_let(sc, sc->curlet); + catch_all_set_goto_loc(sc->curlet, current_stack_top(sc)); + catch_all_set_op_loc(sc->curlet, sc->op_stack_now - sc->op_stack); + push_stack_no_args_direct(sc, OP_CATCH_ALL); /* used to GC protect sc->args here and below, 14-Jul-21 */ + sc->code = T_Pair(opt1_pair(cdr(sc->code))); /* the body of the first lambda (or car of it if catch_all_o) */ +} + +static Inline void op_c_catch_all_a(s7_scheme * sc) +{ + sc->curlet = make_let(sc, sc->curlet); + catch_all_set_goto_loc(sc->curlet, current_stack_top(sc)); + catch_all_set_op_loc(sc->curlet, sc->op_stack_now - sc->op_stack); + push_stack_no_args_direct(sc, OP_CATCH_ALL); + sc->value = fx_call(sc, opt1_pair(cdr(sc->code))); +} + + +/* -------------------------------- owlet -------------------------------- */ +/* error reporting info -- save filename and line number */ + +static s7_pointer init_owlet(s7_scheme * sc) +{ + s7_pointer e, p; + e = make_let_slowly(sc, sc->nil); + sc->temp3 = e; + sc->error_type = add_slot_checked_with_id(sc, e, make_symbol(sc, "error-type"), sc->F); /* the error type or tag ('division-by-zero) */ + sc->error_data = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-data"), sc->F); /* the message or information passed by the error function */ + sc->error_code = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-code"), sc->F); /* the code that s7 thinks triggered the error */ + sc->error_line = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-line"), p = make_permanent_integer_unchecked(0)); /* the line number of that code */ + add_saved_pointer(sc, p); + sc->error_file = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-file"), sc->F); /* the file name of that code */ + sc->error_position = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-position"), p = make_permanent_integer_unchecked(0)); /* the file-byte position of that code */ + add_saved_pointer(sc, p); +#if WITH_HISTORY + sc->error_history = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-history"), sc->F); /* buffer of previous evaluations */ +#endif + sc->temp3 = sc->nil; + return (e); +} + +#if WITH_HISTORY +static s7_pointer cull_history(s7_scheme * sc, s7_pointer code) +{ + s7_pointer p; + clear_symbol_list(sc); /* make a list of words banned from the history */ + add_symbol_to_list(sc, sc->s7_let_symbol); + add_symbol_to_list(sc, sc->eval_symbol); + add_symbol_to_list(sc, make_symbol(sc, "debug")); + add_symbol_to_list(sc, make_symbol(sc, "trace-in")); + add_symbol_to_list(sc, make_symbol(sc, "trace-out")); + add_symbol_to_list(sc, sc->dynamic_unwind_symbol); + add_symbol_to_list(sc, make_symbol(sc, "history-enabled")); + for (p = code; is_pair(p); p = cdr(p)) { + if (tree_set_memq(sc, car(p))) + set_car(p, sc->nil); + if (cdr(p) == code) + break; + } + return (code); +} +#endif + +static s7_pointer g_owlet(s7_scheme * sc, s7_pointer args) +{ +#if WITH_HISTORY +#define H_owlet "(owlet) returns the environment at the point of the last error. \ +It has the additional local variables: error-type, error-data, error-code, error-line, error-file, and error-history." +#else +#define H_owlet "(owlet) returns the environment at the point of the last error. \ +It has the additional local variables: error-type, error-data, error-code, error-line, and error-file." +#endif +#define Q_owlet s7_make_signature(sc, 1, sc->is_let_symbol) + /* if owlet is not copied, (define e (owlet)), e changes as owlet does! */ + + s7_pointer e, x; + s7_int gc_loc; + +#if WITH_HISTORY + slot_set_value(sc->error_history, + cull_history(sc, slot_value(sc->error_history))); +#endif + + e = let_copy(sc, sc->owlet); + gc_loc = gc_protect_1(sc, e); + + /* make sure the pairs/reals/strings/integers are copied: should be error-data, error-code, and error-history */ + sc->gc_off = true; + + for (x = let_slots(e); tis_slot(x); x = next_slot(x)) + if (is_pair(slot_value(x))) { + s7_pointer new_list, p, sp; + new_list = copy_any_list(sc, slot_value(x)); + slot_set_value(x, new_list); + for (p = new_list, sp = p; is_pair(p); + p = cdr(p), sp = cdr(sp)) { + s7_pointer val = car(p); + if (is_t_real(val)) + set_car(p, make_real(sc, real(val))); + else if (is_string(val)) + set_car(p, + make_string_with_length(sc, string_value(val), + string_length(val))); + else if (is_t_integer(val)) + set_car(p, make_integer(sc, integer(val))); + p = cdr(p); + if ((!is_pair(p)) || (p == sp)) + break; + val = car(p); + if (is_t_real(val)) + set_car(p, make_real(sc, real(val))); + else if (is_string(val)) + set_car(p, + make_string_with_length(sc, string_value(val), + string_length(val))); + } + } + sc->gc_off = false; + s7_gc_unprotect_at(sc, gc_loc); + return (e); +} + + +/* -------- catch handlers -------- (don't free the catcher) */ +static bool catch_all_function(s7_scheme * sc, s7_int i, s7_pointer type, + s7_pointer info, bool *reset_hook) +{ + s7_pointer catcher = stack_let(sc->stack, i); + sc->value = opt2_con(stack_code(sc->stack, i)); + sc->op_stack_now = + (s7_pointer *) (sc->op_stack + catch_all_op_loc(catcher)); + sc->stack_end = + (s7_pointer *) (sc->stack_start + catch_all_goto_loc(catcher)); + pop_stack(sc); + if (is_pair(sc->value)) + sc->value = + (car(sc->value) == sc->quote_symbol) ? cadr(sc->value) : type; + else if (is_symbol(sc->value)) + sc->value = type; + return (true); +} + +static bool catch_2_function(s7_scheme * sc, s7_int i, s7_pointer type, + s7_pointer info, bool *reset_hook) +{ + /* this is the macro-error-handler case from g_catch + * (let () (define-macro (m . args) (apply (car args) (cadr args))) (catch #t (lambda () (error abs -1)) m)) + */ + s7_pointer x = stack_code(sc->stack, i); + if ((catch_tag(x) == sc->T) || + (catch_tag(x) == type) || (type == sc->T)) { + int64_t loc = catch_goto_loc(x); + sc->op_stack_now = (s7_pointer *) (sc->op_stack + catch_op_loc(x)); + sc->stack_end = (s7_pointer *) (sc->stack_start + loc); + sc->code = catch_handler(x); + + if (needs_copied_args(sc->code)) + sc->args = list_2(sc, type, info); + else { /* very unlikely: need c_macro as error catcher: (catch #t (lambda () (error 'oops)) require) */ + set_car(sc->t2_1, type); + set_car(sc->t2_2, info); + sc->args = sc->t2_1; + } + sc->cur_op = OP_APPLY; + return (true); + } + return (false); +} + +static bool catch_1_function(s7_scheme * sc, s7_int i, s7_pointer type, + s7_pointer info, bool *reset_hook) +{ + s7_pointer x = stack_code(sc->stack, i); + if ((catch_tag(x) == sc->T) || + (catch_tag(x) == type) || (type == sc->T)) { + uint64_t loc; + opcode_t op = stack_op(sc->stack, i); + s7_pointer catcher = x, error_func, error_body, error_args; + + sc->temp4 = stack_let(sc->stack, i); /* GC protect this, since we're moving the stack top below */ + loc = catch_goto_loc(catcher); + sc->op_stack_now = + (s7_pointer *) (sc->op_stack + catch_op_loc(catcher)); + sc->stack_end = (s7_pointer *) (sc->stack_start + loc); + error_func = catch_handler(catcher); + + /* very often the error handler just returns either a constant ('error or #f), or + * the args passed to it, so there's no need to laboriously make a closure, + * and apply it -- just set sc->value to the closure body (or the args) and return. + * so first examine closure_body(error_func) + * if it is a constant, or quoted symbol, return that, + * if it is the args symbol, return (list type info) + */ + + /* if OP_CATCH_1, we deferred making the error handler until it is actually needed */ + if (op == OP_CATCH_1) { + error_body = cdr(error_func); + error_args = car(error_func); + } else if (is_closure(error_func)) { + error_body = closure_body(error_func); + error_args = closure_args(error_func); + } else { + error_body = NULL; + error_args = NULL; + } + if ((error_body) && (is_null(cdr(error_body)))) { + s7_pointer y = NULL; + error_body = car(error_body); + if (is_pair(error_body)) { + if (car(error_body) == sc->quote_symbol) + y = cadr(error_body); + else if ((car(error_body) == sc->car_symbol) && + (cadr(error_body) == error_args)) + y = type; + } else if (!is_symbol(error_body)) + y = error_body; /* not pair or symbol */ + else if (error_body == error_args) + y = list_2(sc, type, info); + else if (is_keyword(error_body)) + y = error_body; + else if ((is_pair(error_args)) && + (error_body == car(error_args))) + y = type; + if (y) { + if (loc > 4) + pop_stack(sc); + /* we're at OP_CATCH, normally we want to pop that away, but (handwaving...) if we're coming + * from s7_eval (indirectly perhaps through s7_eval_c_string), we might push the OP_EVAL_DONE + * to end that call, but it's pushed at the precatch stack end (far beyond the catch loc). + * If we catch an error, catch unwinds to its starting point, and the pop_stack above + * puts us at the bottom of the stack (i.e. stack_end == stack_start), OP_EVAL_DONE. + * Now we return true, ending up back in eval, because the error handler jumped out of eval, + * back to wherever we were in eval when we hit the error. eval jumps back to the start + * of its loop, and pops the stack to see what to do next! So the (loc > 4) at least + * protects against stack underflow, but ideally we'd know we came from OP_CATCH+s7_eval. + * We can't do anything fancy here because we have to unwind the C stack as well as s7's stack. + * s7_eval doesn't know anything about the catches on the stack. We can't look back for + * OP_EVAL_DONE -- segfault in OP_BEGIN. Hmmmm. Perhaps catch should not unwind until the + * end? But we want the error handler to run as a part of the calling expression, and + * in any case the OP_EVAL_DONE is not useful (it marks the end of the no-error case). + */ + sc->value = y; + sc->temp4 = sc->nil; + if (loc == 4) + sc->code = cons(sc, sc->value, sc->nil); /* if we end up at op_begin, give it something it can handle */ + return (true); + } + } + if (op == OP_CATCH_1) { + s7_pointer p; + new_cell(sc, p, T_CLOSURE); + closure_set_args(p, car(error_func)); + closure_set_body(p, cdr(error_func)); + closure_set_setter(p, sc->F); + closure_set_arity(p, CLOSURE_ARITY_NOT_SET); + closure_set_let(p, sc->temp4); + sc->code = p; + } else + sc->code = error_func; + sc->temp4 = sc->nil; + + /* if user (i.e. yers truly!) copies/pastes the preceding lambda () into the + * error handler portion of the catch, he gets the inexplicable message: + * ;(): too many arguments: (a1 ()) + * when this apply tries to call the handler. So, we need a special case error check here! + */ + + if (!s7_is_aritable(sc, sc->code, 2)) + s7_wrong_number_of_args_error(sc, + "catch error handler should accept 2 arguments: ~S", + sc->code); + + sc->args = list_2(sc, type, info); /* almost never able to skip this -- costs more to check! */ + sc->cur_op = OP_APPLY; + /* explicit eval needed if s7_call called into scheme where a caught error occurred (ex6 in exs7.c) + * but putting it here (via eval(sc, OP_APPLY)) means the C stack is not cleared correctly in non-s7-call cases, + * so defer it until s7_call + */ + return (true); + } + return (false); +} + +static bool catch_dynamic_wind_function(s7_scheme * sc, s7_int i, + s7_pointer type, s7_pointer info, + bool *reset_hook) +{ + s7_pointer x = stack_code(sc->stack, i); + if (dynamic_wind_state(x) == DWIND_BODY) { + dynamic_wind_state(x) = DWIND_FINISH; /* make sure an uncaught error in the exit thunk doesn't cause us to loop */ + if (dynamic_wind_out(x) != sc->F) { + push_stack_direct(sc, OP_EVAL_DONE); + sc->code = dynamic_wind_out(x); + sc->args = sc->nil; + eval(sc, OP_APPLY); /* I guess this means no call/cc out of the exit thunk in an error-catching context */ + } + } + return (false); +} + +static bool catch_out_function(s7_scheme * sc, s7_int i, s7_pointer type, + s7_pointer info, bool *reset_hook) +{ + s7_pointer x = stack_code(sc->stack, i); /* "code" = port that we opened */ + s7_close_output_port(sc, x); + x = stack_args(sc->stack, i); /* "args" = port that we shadowed, if not # */ + if (x != sc->unused) + set_current_output_port(sc, x); + return (false); +} + +static bool catch_in_function(s7_scheme * sc, s7_int i, s7_pointer type, + s7_pointer info, bool *reset_hook) +{ + s7_close_input_port(sc, stack_code(sc->stack, i)); /* "code" = port that we opened */ + if (stack_args(sc->stack, i) != sc->unused) + set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ + return (false); +} + +static bool catch_read_function(s7_scheme * sc, s7_int i, s7_pointer type, + s7_pointer info, bool *reset_hook) +{ + pop_input_port(sc); + return (false); +} + +static bool catch_eval_function(s7_scheme * sc, s7_int i, s7_pointer type, + s7_pointer info, bool *reset_hook) +{ + s7_close_input_port(sc, current_input_port(sc)); + pop_input_port(sc); + return (false); +} + +static bool catch_barrier_function(s7_scheme * sc, s7_int i, + s7_pointer type, s7_pointer info, + bool *reset_hook) +{ + if (is_input_port(stack_args(sc->stack, i))) { /* (eval-string "'(1 .)") */ + if (current_input_port(sc) == stack_args(sc->stack, i)) + pop_input_port(sc); + s7_close_input_port(sc, stack_args(sc->stack, i)); + } + return (false); +} + +static bool catch_hook_function(s7_scheme * sc, s7_int i, s7_pointer type, + s7_pointer info, bool *reset_hook) +{ + sc->error_hook = stack_code(sc->stack, i); + /* apparently there was an error during *error-hook* evaluation, but Rick wants the hook re-established anyway */ + (*reset_hook) = true; + /* avoid infinite loop -- don't try to (re-)evaluate (buggy) *error-hook*! */ + return (false); +} + +static bool catch_goto_function(s7_scheme * sc, s7_int i, s7_pointer type, + s7_pointer info, bool *reset_hook) +{ + call_exit_active(stack_args(sc->stack, i)) = false; + return (false); +} + +static bool catch_let_temporarily_function(s7_scheme * sc, s7_int i, + s7_pointer type, + s7_pointer info, + bool *reset_hook) +{ + let_temp_done(sc, stack_args(sc->stack, i), stack_code(sc->stack, i), + stack_let(sc->stack, i)); + return (false); +} + +static bool catch_let_temp_unwind_function(s7_scheme * sc, s7_int i, + s7_pointer type, + s7_pointer info, + bool *reset_hook) +{ + slot_set_value(stack_code(sc->stack, i), stack_args(sc->stack, i)); + return (false); +} + +static bool catch_let_temp_s7_unwind_function(s7_scheme * sc, s7_int i, + s7_pointer type, + s7_pointer info, + bool *reset_hook) +{ + g_s7_let_set_fallback(sc, + set_plist_3(sc, sc->s7_let, + stack_code(sc->stack, i), + stack_args(sc->stack, i))); + return (false); +} + +static bool catch_dynamic_unwind_function(s7_scheme * sc, s7_int i, + s7_pointer type, s7_pointer info, + bool *reset_hook) +{ + /* if func has an error, s7_error will call it as it unwinds the stack -- an infinite loop. So, cancel the unwind first. */ + stack_element(sc->stack, i) = (s7_pointer) OP_GC_PROTECT; + + /* we're in an error or throw, so there is no return value to report, but we need to decrement *debug-spaces* (if in debug) + * stack_let is the trace-in let at the point of the dynamic_unwind call + */ + if (sc->debug > 0) { + s7_pointer spaces; + spaces = + lookup_slot_from(make_symbol(sc, "*debug-spaces*"), + stack_let(sc->stack, i)); + if (is_slot(spaces)) + slot_set_value(spaces, make_integer(sc, max_i_ii(0LL, integer(slot_value(spaces)) - 2))); /* should involve only small_ints */ + } + return (false); +} + +typedef bool (*catch_function_t)(s7_scheme * sc, s7_int i, s7_pointer type, + s7_pointer info, bool *reset_hook); +static catch_function_t catchers[NUM_OPS]; + +static void init_catchers(void) +{ + int32_t i; + for (i = 0; i < NUM_OPS; i++) + catchers[i] = NULL; + catchers[OP_CATCH_ALL] = catch_all_function; + catchers[OP_CATCH_2] = catch_2_function; + catchers[OP_CATCH_1] = catch_1_function; + catchers[OP_CATCH] = catch_1_function; + catchers[OP_DYNAMIC_WIND] = catch_dynamic_wind_function; + catchers[OP_DYNAMIC_UNWIND] = catch_dynamic_unwind_function; + catchers[OP_GET_OUTPUT_STRING] = catch_out_function; + catchers[OP_UNWIND_OUTPUT] = catch_out_function; + catchers[OP_UNWIND_INPUT] = catch_in_function; + catchers[OP_READ_DONE] = catch_read_function; /* perhaps an error during (read) */ + catchers[OP_EVAL_STRING] = catch_eval_function; + catchers[OP_BARRIER] = catch_barrier_function; + catchers[OP_DEACTIVATE_GOTO] = catch_goto_function; + catchers[OP_LET_TEMP_DONE] = catch_let_temporarily_function; + catchers[OP_LET_TEMP_UNWIND] = catch_let_temp_unwind_function; + catchers[OP_LET_TEMP_S7_UNWIND] = catch_let_temp_s7_unwind_function; + catchers[OP_ERROR_HOOK_QUIT] = catch_hook_function; +} + +/* -------------------------------- throw -------------------------------- */ +static s7_pointer g_throw(s7_scheme * sc, s7_pointer args) +{ +#define H_throw "(throw tag . info) is like (error ...) but it does not affect the owlet. \ +It looks for an existing catch with a matching tag, and jumps to it if found. Otherwise it raises an error." +#define Q_throw s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T) + + bool ignored_flag = false; + int64_t i; + s7_pointer type = car(args), info = cdr(args); + + /* look for a catcher */ + for (i = current_stack_top(sc) - 1; i >= 3; i -= 4) { + catch_function_t catcher; + catcher = catchers[stack_op(sc->stack, i)]; + if ((catcher) && (catcher(sc, i, type, info, &ignored_flag))) { + if (sc->longjmp_ok) + LongJmp(sc->goto_start, THROW_JUMP); + return (sc->value); + } + } + if (is_let(car(args))) + check_method(sc, car(args), sc->throw_symbol, args); + return (s7_error(sc, make_symbol(sc, "uncaught-throw"), + set_elist_3(sc, + wrap_string(sc, + "no catch found for (throw ~W~{~^ ~S~})", + 38), type, info))); +} + +static void s7_warn(s7_scheme * sc, s7_int len, const char *ctrl, ...) +{ /* len = max size of output string (for vsnprintf) */ + if ((sc->error_port != sc->F) && (!sc->muffle_warnings)) { + int bytes; + va_list ap; + block_t *b; + char *str; + b = mallocate(sc, len); + str = (char *) block_data(b); + str[0] = '\0'; + va_start(ap, ctrl); + bytes = vsnprintf(str, len, ctrl, ap); + va_end(ap); + if (port_is_closed(sc->error_port)) + sc->error_port = sc->standard_error; + if ((bytes > 0) && (sc->error_port != sc->F)) + port_write_string(sc->error_port) (sc, str, bytes, + sc->error_port); + liberate(sc, b); + } +} + +static void fill_error_location(s7_scheme * sc) +{ + if (((is_input_port(current_input_port(sc))) + && (is_loader_port(current_input_port(sc)))) + || + (((sc->cur_op >= OP_READ_LIST) && (sc->cur_op <= OP_READ_DONE)))) { + integer(slot_value(sc->error_line)) = + port_line_number(current_input_port(sc)); + integer(slot_value(sc->error_position)) = + port_position(current_input_port(sc)); + slot_set_value(sc->error_file, + wrap_string(sc, + port_filename(current_input_port(sc)), + port_filename_length(current_input_port + (sc)))); + } else { + integer(slot_value(sc->error_line)) = 0; + integer(slot_value(sc->error_position)) = 0; + slot_set_value(sc->error_file, sc->F); + } +} + +s7_pointer s7_error(s7_scheme * sc, s7_pointer type, s7_pointer info) +{ + bool reset_error_hook = false; + s7_pointer cur_code; + + /* type is a symbol normally, and info is compatible with format: (apply format #f info) -- + * car(info) is the control string, cdr(info) its args + * type/range errors have cadr(info)=caller, caddr(info)=offending arg number + * null info can mean symbol table is locked so make-symbol uses s7_error to get out + * + * set up (owlet), look for a catch that matches 'type', if found + * call its error-handler, else if *error-hook* is bound, call it, + * else send out the error info ourselves. + */ + sc->format_depth = -1; + sc->gc_off = false; /* this is in case we were triggered from the sort function -- clumsy! */ + sc->object_out_locked = false; /* possible error in obj->str method after object_out has set this flag */ + sc->has_openlets = true; /* same problem -- we need a cleaner way to handle this */ + + if (sc->current_safe_list > 0) + clear_list_in_use(sc->safe_lists[sc->current_safe_list]); + slot_set_value(sc->error_type, type); + slot_set_value(sc->error_data, info); + + if (unchecked_type(sc->curlet) != T_LET) + sc->curlet = sc->nil; /* in the reader, the sc->curlet stack entry is mostly ignored, so it can be (and usually is) garbage */ + let_set_outlet(sc->owlet, sc->curlet); + + cur_code = current_code(sc); + slot_set_value(sc->error_code, cur_code); + +#if WITH_HISTORY + slot_set_value(sc->error_history, sc->cur_code); + if (sc->cur_code != sc->history_sink) { + sc->cur_code = + (sc->using_history1) ? sc->eval_history2 : sc->eval_history1; + sc->using_history1 = (!sc->using_history1); + pair_fill(sc, set_plist_2(sc, sc->cur_code, sc->nil)); + } +#endif + + if (is_pair(cur_code)) { + int32_t line = -1, file, position; + if (has_location(cur_code)) { + line = (int32_t) pair_line_number(cur_code); /* cast to int32_t (from uint32_t) for sc->last_error_line */ + file = (int32_t) pair_file_number(cur_code); + position = (int32_t) pair_position(cur_code); + } else { /* try to find a plausible line number! */ + s7_pointer p, sp; + for (p = cur_code, sp = cur_code; is_pair(p); + p = cdr(p), sp = cdr(sp)) { + if ((is_pair(car(p))) && /* what about p itself? */ + (has_location(car(p)))) { + line = (int32_t) pair_line_number(car(p)); + file = (int32_t) pair_file_number(car(p)); + position = (int32_t) pair_position(car(p)); + break; + } + p = cdr(p); + if ((!is_pair(p)) || (p == sp)) + break; + if ((is_pair(car(p))) && (has_location(car(p)))) { + line = (int32_t) pair_line_number(car(p)); + file = (int32_t) pair_file_number(car(p)); + position = (int32_t) pair_position(car(p)); + break; + } + } + } + if ((line > 0) && (line != sc->last_error_line)) { + sc->last_error_line = line; + if (file < 0) + fill_error_location(sc); + else { + integer(slot_value(sc->error_line)) = line; + integer(slot_value(sc->error_position)) = position; + slot_set_value(sc->error_file, sc->file_names[file]); + } + } else + fill_error_location(sc); + } else + fill_error_location(sc); + + { /* look for a catcher, call catch*function in the error context (before unwinding the stack), outlet(owlet) is curlet */ + int64_t i; + /* top is 1 past actual top, top - 1 is op, if op = OP_CATCH, top - 4 is the cell containing the catch struct */ + for (i = current_stack_top(sc) - 1; i >= 3; i -= 4) { + catch_function_t catcher; + catcher = catchers[stack_op(sc->stack, i)]; + if ((catcher) && + (catcher(sc, i, type, info, &reset_error_hook))) { + if ((S7_DEBUGGING) && (!sc->longjmp_ok)) + fprintf(stderr, "s7_error jump not available?\n"); + LongJmp(sc->goto_start, CATCH_JUMP); + } + } + } + /* error not caught */ + /* (set! *error-hook* (list (lambda (hook) (apply format #t (hook 'args))))) */ + + if ((!reset_error_hook) && + (is_procedure(sc->error_hook)) && + (hook_has_functions(sc->error_hook))) { + s7_pointer error_hook_func; + /* (set! (hook-functions *error-hook*) (list (lambda (h) (format *stderr* "got error ~A~%" (h 'args))))) */ + error_hook_func = sc->error_hook; + sc->error_hook = sc->nil; + /* if the *error-hook* functions trigger an error, we had better not have *error-hook* still set! */ + + push_stack(sc, OP_ERROR_HOOK_QUIT, sc->nil, error_hook_func); /* restore *error-hook* upon successful (or any!) evaluation */ + sc->code = error_hook_func; + sc->args = list_2(sc, type, info); + /* if we drop into the longjmp below, the hook functions are not called! + * OP_ERROR_HOOK_QUIT performs the longjmp, so it should be safe to go to eval. + */ + eval(sc, OP_APPLY); + } else { + s7_int op = sc->print_length; + if (op < 32) + sc->print_length = 32; + + if ((!is_output_port(sc->error_port)) || /* error-port can be #f */ + (port_is_closed(sc->error_port))) + sc->error_port = sc->standard_error; + /* if info is not a list, send object->string to current error port, + * else assume car(info) is a format control string, and cdr(info) are its args + * if at all possible, get some indication of where we are! + */ + + if ((!is_pair(info)) || (!is_string(car(info)))) + format_to_port(sc, sc->error_port, "\n;~S ~S", + set_plist_2(sc, type, info), false, 7); + else { + /* it's possible that the error string is just a string -- not intended for format */ + if ((type != sc->format_error_symbol) && /* avoid an infinite loop of format errors */ + (strchr(string_value(car(info)), '~'))) { + char *errstr; + block_t *b; + s7_int len, str_len; + len = string_length(car(info)) + 8; + b = mallocate(sc, len); + errstr = (char *) block_data(b); + str_len = + catstrs_direct(errstr, "\n;", string_value(car(info)), + (const char *) NULL); + format_to_port(sc, sc->error_port, errstr, cdr(info), + false, str_len); + liberate(sc, b); + } else + format_to_port(sc, sc->error_port, "\n;~S ~S", set_plist_2(sc, type, info), false, 7); /* 7 = ctrl str len */ + } + if (op < 32) + sc->print_length = op; + + /* now display location at end */ + if (is_string(slot_value(sc->error_file))) { + s7_newline(sc, sc->error_port); + format_to_port(sc, sc->error_port, "; ~A\n", + set_plist_1(sc, + object_to_truncated_string(sc, + cur_code, + 40)), + false, 8); + format_to_port(sc, sc->error_port, + "; ~A, line ~D, position: ~D\n", + set_plist_3(sc, slot_value(sc->error_file), + slot_value(sc->error_line), + slot_value(sc->error_position)), + false, 31); + } else { + if ((is_input_port(current_input_port(sc))) && + (port_file(current_input_port(sc)) != stdin) && + (!port_is_closed(current_input_port(sc)))) { + const char *filename = + port_filename(current_input_port(sc)); + int32_t line = port_line_number(current_input_port(sc)); + + if (filename) + format_to_port(sc, sc->error_port, "\n; ~A[~D]", + set_plist_2(sc, + wrap_string(sc, filename, + port_filename_length + (current_input_port + (sc))), + wrap_integer3(sc, line)), + false, 10); + else if ((line > 0) + && (integer(slot_value(sc->error_line)) > 0)) + format_to_port(sc, sc->error_port, "\n; line ~D", + set_plist_1(sc, + wrap_integer3(sc, line)), + false, 11); + else if (sc->input_port_stack_loc > 0) { + s7_pointer p; + p = sc->input_port_stack[sc->input_port_stack_loc - 1]; + if ((is_input_port(p)) && + (port_file(p) != stdin) && (!port_is_closed(p))) { + filename = port_filename(p); + line = port_line_number(p); + if (filename) + format_to_port(sc, sc->error_port, + "\n; ~A[~D]", set_plist_2(sc, + wrap_string + (sc, + filename, + port_filename_length + (current_input_port + (sc))), + wrap_integer3 + (sc, + line)), + false, 10); + } + } + } else { + const char *call_name = sc->s7_call_name; + if (call_name) { + sc->s7_call_name = NULL; + if ((sc->s7_call_file) && (sc->s7_call_line >= 0)) + format_to_port(sc, sc->error_port, + "\n; ~A ~A[~D]", set_plist_3(sc, + s7_make_string_wrapper + (sc, + call_name), + s7_make_string_wrapper + (sc, + sc->s7_call_file), + wrap_integer1 + (sc, + sc->s7_call_line)), + false, 13); + } + } + s7_newline(sc, sc->error_port); + } + /* look for __func__ in the error environment etc */ + if (sc->error_port != sc->F) { + s7_pointer errp; + errp = stacktrace_1(sc, + s7_integer_checked(sc, + car + (sc->stacktrace_defaults)), + s7_integer_checked(sc, + cadr + (sc->stacktrace_defaults)), + s7_integer_checked(sc, + caddr + (sc->stacktrace_defaults)), + s7_integer_checked(sc, + cadddr + (sc->stacktrace_defaults)), + s7_boolean(sc, + s7_list_ref(sc, + sc->stacktrace_defaults, + 4))); + if (string_length(errp) > 0) { + port_write_string(sc->error_port) (sc, string_value(errp), + string_length(errp), + sc->error_port); + port_write_character(sc->error_port) (sc, '\n', + sc->error_port); + } + } else if (is_pair(slot_value(sc->error_code))) { + format_to_port(sc, sc->error_port, "; ~S", + set_plist_1(sc, slot_value(sc->error_code)), + false, 7); + s7_newline(sc, sc->error_port); + } + /* if (is_continuation(type)) + * go into repl here with access to continuation? Or expect *error-handler* to deal with it? + */ + sc->value = type; + sc->cur_op = OP_ERROR_QUIT; + } + if (sc->longjmp_ok) + LongJmp(sc->goto_start, ERROR_JUMP); + return (type); +} + +static s7_pointer apply_error(s7_scheme * sc, s7_pointer obj, + s7_pointer args) +{ + /* the operator type is needed here else the error message is confusing: + * (apply '+ (list 1 2))) -> ;attempt to apply + to (1 2)? + */ + if (is_null(obj)) + return (s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, + wrap_string(sc, + "attempt to apply nil to ~S in ~S?", + 33), args, + current_code(sc)))); + return (s7_error + (sc, sc->syntax_error_symbol, + set_elist_5(sc, + wrap_string(sc, + "attempt to apply ~A ~S to ~S in ~S?", + 35), type_name_string(sc, obj), obj, + args, current_code(sc)))); +} + +static s7_pointer read_error_1(s7_scheme * sc, const char *errmsg, + bool string_error) +{ + /* reader errors happen before the evaluator gets involved, so forms such as: + * (catch #t (lambda () (car '( . ))) (lambda arg 'error)) + * do not catch the error if we simply signal an error when we encounter it. + */ + char *msg; + s7_int len; + s7_pointer pt = current_input_port(sc); + + if (!string_error) { + /* make an heroic effort to find where we slid off the tracks */ + if (is_string_port(current_input_port(sc))) { +#define QUOTE_SIZE 40 + s7_int i, j, start = 0, end, slen, size, nlen; + char *recent_input = NULL; + s7_pointer p; + + /* we can run off the end in cases like (eval-string "(. . ,.)") or (eval-string " (@ . ,.)") */ + if (port_position(pt) >= port_data_size(pt)) + port_position(pt) = port_data_size(pt) - 1; + + /* start at current position and look back a few chars */ + for (i = port_position(pt), j = 0; (i > 0) && (j < QUOTE_SIZE); + i--, j++) + if ((port_data(pt)[i] == '\0') + || (port_data(pt)[i] == '\n') + || (port_data(pt)[i] == '\r')) + break; + start = i; + + /* start at current position and look ahead a few chars */ + size = port_data_size(pt); + for (i = port_position(pt), j = 0; + (i < size) && (j < QUOTE_SIZE); i++, j++) + if ((port_data(pt)[i] == '\0') + || (port_data(pt)[i] == '\n') + || (port_data(pt)[i] == '\r')) + break; + + end = i; + slen = end - start; + /* hopefully this is more or less the current line where the read error happened */ + + if (slen > 0) { + recent_input = (char *) Calloc(slen + 9, 1); + for (i = 0; i < (slen + 8); i++) + recent_input[i] = '.'; + recent_input[3] = ' '; + recent_input[slen + 4] = ' '; + for (i = 0; i < slen; i++) + recent_input[i + 4] = port_data(pt)[start + i]; + } + + nlen = 0; + if ((port_line_number(pt) > 0) && (port_filename(pt))) { + len = + safe_strlen(recent_input) + safe_strlen(errmsg) + + port_filename_length(pt) + + safe_strlen(sc->current_file) + 64; + p = make_empty_string(sc, len, '\0'); + msg = string_value(p); + nlen = + snprintf(msg, len, + "%s: %s %s[%u], last top-level form at: %s[%" + ld64 "]", errmsg, + (recent_input) ? recent_input : "", + port_filename(pt), port_line_number(pt), + sc->current_file, sc->current_line); + } else { + len = + safe_strlen(recent_input) + safe_strlen(errmsg) + + safe_strlen(sc->current_file) + 64; + p = make_empty_string(sc, len, '\0'); + msg = string_value(p); + if ((sc->current_file) && (sc->current_line >= 0)) + nlen = + snprintf(msg, len, + "%s: %s, last top-level form at %s[%" ld64 + "]", errmsg, + (recent_input) ? recent_input : "", + sc->current_file, sc->current_line); + else + nlen = + snprintf(msg, len, "%s: %s", errmsg, + (recent_input) ? recent_input : ""); + } + string_length(p) = nlen; + if (recent_input) + free(recent_input); + return (s7_error + (sc, sc->read_error_symbol, set_elist_1(sc, p))); + } + } + + if ((port_line_number(pt) > 0) && (port_filename(pt))) { + s7_pointer p; + s7_int nlen = 0; + len = + safe_strlen(errmsg) + port_filename_length(pt) + + safe_strlen(sc->current_file) + 128; + p = make_empty_string(sc, len, '\0'); + msg = string_value(p); + if (string_error) + nlen = + snprintf(msg, len, + "%s %s[%u],\n; possible culprit: \"%s...\"\n; last top-level form at %s[%" + ld64 "]", errmsg, port_filename(pt), + port_line_number(pt), sc->strbuf, + sc->current_file, sc->current_line); + else + nlen = + snprintf(msg, len, + "%s %s[%u], last top-level form at %s[%" ld64 "]", + errmsg, port_filename(pt), port_line_number(pt), + sc->current_file, sc->current_line); + string_length(p) = nlen; + return (s7_error(sc, sc->read_error_symbol, set_elist_1(sc, p))); + } + return (s7_error + (sc, + (string_error) ? sc-> + string_read_error_symbol : sc->read_error_symbol, + set_elist_1(sc, s7_make_string_wrapper(sc, (char *) + errmsg)))); +} + +static s7_pointer read_error(s7_scheme * sc, const char *errmsg) +{ + return (read_error_1(sc, errmsg, false)); +} + +static s7_pointer string_read_error(s7_scheme * sc, const char *errmsg) +{ + return (read_error_1(sc, errmsg, true)); +} + +static s7_pointer g_error(s7_scheme * sc, s7_pointer args) +{ +#define H_error "(error type ...) signals an error. The 'type' can be used with catch to trap \ +particular errors. If the error is not caught, s7 treats the second argument as a format control string, \ +and applies it to the rest of the arguments." +#define Q_error s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T) + + if (is_null(args)) + return (s7_error(sc, sc->nil, sc->nil)); + if (!is_string(car(args))) /* else a CL-style error? -- use tag = 'no-catch */ + return (s7_error(sc, car(args), cdr(args))); + s7_error(sc, sc->no_catch_symbol, args); /* this can have trailing args (implicit format) */ + return (sc->unspecified); +} + +static char *truncate_string(char *form, s7_int len, use_write_t use_write) +{ + uint8_t *f = (uint8_t *) form; + if (use_write != P_DISPLAY) { + /* I guess we need to protect the outer double quotes in this case */ + s7_int i; + for (i = len - 5; i >= (len / 2); i--) + if (is_white_space((int32_t) f[i])) { + form[i] = '.'; + form[i + 1] = '.'; + form[i + 2] = '.'; + form[i + 3] = '"'; + form[i + 4] = '\0'; + return (form); + } + i = len - 5; + if (i > 0) { + form[i] = '.'; + form[i + 1] = '.'; + form[i + 2] = '.'; + form[i + 3] = '"'; + form[i + 4] = '\0'; + } else if (len >= 2) { + form[len - 1] = '"'; + form[len] = '\0'; + } + } else { + s7_int i; + for (i = len - 4; i >= (len / 2); i--) + if (is_white_space((int32_t) f[i])) { + form[i] = '.'; + form[i + 1] = '.'; + form[i + 2] = '.'; + form[i + 3] = '\0'; + return (form); + } + i = len - 4; + if (i >= 0) { + form[i] = '.'; + form[i + 1] = '.'; + form[i + 2] = '.'; + form[i + 3] = '\0'; + } else + form[len] = '\0'; + } + return (form); +} + +static s7_pointer object_to_truncated_string(s7_scheme * sc, s7_pointer p, + s7_int len) +{ + char *s; + s7_int s_len; + s7_pointer strp; + sc->objstr_max_len = len + 2; + strp = s7_object_to_string(sc, p, false); + s = string_value(strp); + sc->objstr_max_len = S7_INT64_MAX; + s_len = string_length(strp); + if (s_len > len) + truncate_string(s, len, P_DISPLAY); + return (strp); +} + +static s7_pointer tree_descend(s7_scheme * sc, s7_pointer p, uint32_t line) +{ + s7_pointer tp; + if (!is_pair(p)) + return (NULL); + if (has_location(p)) { + uint32_t x = (uint32_t) pair_line_number(p); + if (x > 0) { + if (line == 0) /* first line number we encounter will be the current reader location (i.e. the end of the form) */ + line = x; + else if (x < line) + return (p); + } + } + tp = tree_descend(sc, car(p), line); + return ((tp) ? tp : tree_descend(sc, cdr(p), line)); +} + +static s7_pointer missing_close_paren_error(s7_scheme * sc) +{ + s7_int len; + char *msg, *syntax_msg = NULL; + s7_pointer pt; + + if ((unchecked_type(sc->curlet) != T_LET) && (sc->curlet != sc->nil)) + sc->curlet = sc->nil; + pt = current_input_port(sc); + + /* check *missing-close-paren-hook* */ + if (hook_has_functions(sc->missing_close_paren_hook)) { + s7_pointer result; + if ((port_line_number(pt) > 0) && (port_filename(pt))) { + integer(slot_value(sc->error_line)) = port_line_number(pt); + integer(slot_value(sc->error_position)) = port_position(pt); + slot_set_value(sc->error_file, + wrap_string(sc, port_filename(pt), + port_filename_length(pt))); + } + result = s7_call(sc, sc->missing_close_paren_hook, sc->nil); + if (result != sc->unspecified) + return (g_throw(sc, list_1(sc, result))); + } + + if (is_pair(sc->args)) { + s7_pointer p; + p = tree_descend(sc, sc->args, 0); + if ((p) && (is_pair(p)) && (has_location(p))) { + s7_int msg_len, form_len; + s7_pointer strp; + char *form; + strp = object_to_truncated_string(sc, p, 40); + form = string_value(strp); + form_len = string_length(strp); + msg_len = form_len + 128; + syntax_msg = (char *) Malloc(msg_len); + snprintf(syntax_msg, msg_len, + "; current form awaiting a close paren starts around line %u: %s", + (uint32_t) pair_line_number(p), form); + } + } + + if ((port_line_number(pt) > 0) && (port_filename(pt))) { + s7_pointer p; + s7_int nlen; + len = + port_filename_length(pt) + safe_strlen(sc->current_file) + + safe_strlen(syntax_msg) + 128; + p = make_empty_string(sc, len, '\0'); + msg = string_value(p); + if (syntax_msg) { + nlen = + snprintf(msg, len, + "missing close paren, %s[%u], last top-level form at %s[%" + ld64 "]\n%s", port_filename(pt), + port_line_number(pt), sc->current_file, + sc->current_line, syntax_msg); + free(syntax_msg); + } else + nlen = + snprintf(msg, len, + "missing close paren, %s[%u], last top-level form at %s[%" + ld64 "]", port_filename(pt), port_line_number(pt), + sc->current_file, sc->current_line); + string_length(p) = nlen; + return (s7_error(sc, sc->read_error_symbol, set_elist_1(sc, p))); + } + + if (syntax_msg) { + s7_pointer p; + len = safe_strlen(syntax_msg) + 128; + p = make_empty_string(sc, len, '\0'); + msg = string_value(p); + len = + catstrs(msg, len, "missing close paren\n", syntax_msg, "\n", + (char *) NULL); + free(syntax_msg); + string_length(p) = len; + return (s7_error(sc, sc->read_error_symbol, set_elist_1(sc, p))); + } + if ((is_input_port(pt)) && + (!port_is_closed(pt)) && + (port_data(pt)) && (port_position(pt) > 0)) { + s7_pointer p; + s7_int start, pos; + + p = make_empty_string(sc, 128, '\0'); + msg = string_value(p); + memcpy((void *) msg, (void *) "missing close paren: ", 21); + + pos = port_position(pt); + start = pos - 40; + if (start < 0) + start = 0; + memcpy((void *) (msg + 21), (void *) (port_data(pt) + start), + pos - start); + string_length(p) = 21 + pos - start; + return (s7_error(sc, sc->read_error_symbol, set_elist_1(sc, p))); + } + return (s7_error + (sc, sc->read_error_symbol, + set_elist_1(sc, wrap_string(sc, "missing close paren", 19)))); +} + +static void improper_arglist_error(s7_scheme * sc) +{ + /* sc->code is the last (dotted) arg, sc->args is the arglist reversed not including sc->code + * the original was `(func ,@(reverse args) . ,code) essentially where func is sc->value or pop_op_stack(sc) + */ + s7_pointer func; + func = pop_op_stack(sc); + if (sc->args == sc->nil) /* (abs . 1) */ + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, + wrap_string(sc, + "attempt to evaluate (~S . ~S)?", + 30), func, sc->code)); + else + s7_error(sc, sc->syntax_error_symbol, + set_elist_4(sc, + wrap_string(sc, + "attempt to evaluate (~S ~S . ~S)?", + 33), func, sc->args = + proper_list_reverse_in_place(sc, sc->args), + sc->code)); +} + +static void op_error_hook_quit(s7_scheme * sc) +{ + sc->error_hook = sc->code; /* restore old value */ + /* now mimic the end of the normal error handler. Since this error hook evaluation can happen + * in an arbitrary s7_call nesting, we can't just return from the current evaluation -- + * we have to jump to the original (top-level) call. Otherwise '# or whatever + * is simply treated as the (non-error) return value, and the higher level evaluations + * get confused. + */ + stack_reset(sc); /* is this necessary? is it a good idea?? */ + push_stack_op(sc, OP_ERROR_QUIT); /* added 3-Dec-16: try to make sure we actually exit! */ + sc->cur_op = OP_ERROR_QUIT; + if (sc->longjmp_ok) + LongJmp(sc->goto_start, ERROR_QUIT_JUMP); +} + + +/* -------------------------------- leftovers -------------------------------- */ + +void (*s7_begin_hook(s7_scheme * sc))(s7_scheme * sc, + bool *val) { return(sc->begin_hook); +} + +void s7_set_begin_hook(s7_scheme * sc, + void (*hook)(s7_scheme * sc, bool *val)) +{ + sc->begin_hook = hook; + sc->begin_op = (hook) ? OP_BEGIN_HOOK : OP_BEGIN_NO_HOOK; +} + +static bool call_begin_hook(s7_scheme * sc) +{ + bool result = false; + /* originally begin_hook was bool (*hook)(s7_scheme *sc): the value was returned directly, + * rather than going through a *bool arg (&result below). That works in gcc (Linux/OSX), + * but does not work in MS Visual C++. In the latter, the compiler apparently completely + * eliminates any local, returning (for example) a thread-relative stack-allocated value + * directly, but then by the time we get here, that variable has vanished, and we get + * garbage. We had to thwart the optimization by adding if ((flag) && (!flag)) fprintf(...); + * So, in the new form (26-Jun-13), the value is passed directly into an s7 variable + * that I hope can't be optimized out of existence. + * + * cm/src/Scheme.cpp, used in Snd (listener looking for C-g I think) + * originally this facility was aimed at interrupting infinite loops, and the expected usage was: + * set begin_hook, eval-string(...), unset begin_hook + */ + opcode_t op = sc->cur_op; + s7_pointer cur_code; + + push_stack_direct(sc, OP_BARRIER); + sc->begin_hook(sc, &result); + if (result) { + /* set (owlet) in case we were interrupted and need to see why something was hung */ + slot_set_value(sc->error_type, sc->F); + slot_set_value(sc->error_data, sc->value); /* was sc->F but we now clobber this below */ + cur_code = current_code(sc); + slot_set_value(sc->error_code, cur_code); + + if (has_location(cur_code)) { + integer(slot_value(sc->error_line)) = + (s7_int) pair_line_number(cur_code); + slot_set_value(sc->error_file, + sc->file_names[pair_file_number(cur_code)]); + integer(slot_value(sc->error_position)) = + (s7_int) pair_position(cur_code); + } else { + integer(slot_value(sc->error_line)) = 0; + integer(slot_value(sc->error_position)) = 0; + slot_set_value(sc->error_file, sc->F); + } +#if WITH_HISTORY + slot_set_value(sc->error_history, sc->F); +#endif + let_set_outlet(sc->owlet, sc->curlet); + + sc->value = make_symbol(sc, "begin-hook-interrupt"); + /* otherwise the evaluator returns whatever random thing is in sc->value (normally #) + * which makes debugging unnecessarily difficult. ?? why not return something useful? make return s7_pointer*, not bool* + */ + s7_quit(sc); /* don't call gc here -- eval_c_string is the context -- allows interrupt of infinite loop */ + return (true); + } + pop_stack_no_op(sc); + sc->cur_op = op; /* for better error handling. otherwise we get "barrier" as the offending function name in eval_error */ + return (false); +} + + +/* -------------------------------- apply -------------------------------- */ +static s7_pointer apply_list_star(s7_scheme * sc, s7_pointer d) +{ + s7_pointer p; + /* we check this ahead of time: if (is_null(cdr(d))) return(car(d)); */ + p = cons(sc, car(d), cdr(d)); + sc->w = p; + while (is_not_null(cddr(p))) { + d = cdr(d); + set_cdr(p, cons(sc, car(d), cdr(d))); + if (is_not_null(cdr(d))) + p = cdr(p); + } + set_cdr(p, cadr(p)); + return (sc->w); +} + +static s7_pointer apply_list_error(s7_scheme * sc, s7_pointer lst) +{ + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "apply's last argument should be a proper list: ~S", + 49), lst))); +} + +static s7_pointer g_apply(s7_scheme * sc, s7_pointer args) +{ +#define H_apply "(apply func ...) applies func to the rest of the arguments" +#define Q_apply s7_make_circular_signature(sc, 2, 3, sc->values_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_sequence_symbol), sc->T) + + /* can apply always be replaced with apply values? + * (apply + '(1 2 3)) is the same as (+ (apply values '(1 2 3))) + * not if apply* in disguise, I think: + * (apply + 1 2 ()) -> 3 + * (apply + 1 2 (apply values ())) -> error + */ + sc->code = car(args); + if (!is_applicable(sc->code)) + apply_error(sc, sc->code, sc->args); + + if (is_null(cdr(args))) { + sc->args = sc->nil; + push_stack_direct(sc, OP_APPLY); + return (sc->nil); + } + if (is_safe_procedure(sc->code)) { + s7_pointer p, q; + + for (q = args, p = cdr(args); is_not_null(cdr(p)); + q = p, p = cdr(p)); + /* the last arg is supposed to be a list, it will be spliced onto the end of the previous arg list (if any) below */ + + if (!s7_is_proper_list(sc, car(p))) /* (apply + #f) etc */ + return (apply_list_error(sc, args)); + set_cdr(q, car(p)); + /* this would work: if (is_c_function(sc->code)) return(c_function_call(sc->code)(sc, cdr(args))); + * but it omits the arg number check, but if we copy the APPLY table here (returning sc->value) + * the overhead from the now non-inline function calls is greater than the fewer-eval-jumps savings. + */ + push_stack(sc, OP_APPLY, cdr(args), sc->code); + return (sc->nil); + } + + /* here we may have to copy the arg list */ + sc->args = + (is_null(cddr(args))) ? cadr(args) : apply_list_star(sc, + cdr(args)); + if (!s7_is_proper_list(sc, sc->args)) + return (apply_list_error(sc, args)); + + sc->args = + (needs_copied_args(sc->code)) ? copy_proper_list(sc, + sc-> + args) : sc->args; + push_stack_direct(sc, OP_APPLY); + return (sc->nil); +} + +s7_pointer s7_apply_function(s7_scheme * sc, s7_pointer fnc, + s7_pointer args) +{ + TRACK(sc); + if (is_c_function(fnc)) + return (c_function_call(fnc) (sc, args)); + /* if [if (!is_applicable(fnc)) apply_error(sc, fnc, sc->args);] here, needs_copied_args can be T_App */ + push_stack_direct(sc, OP_EVAL_DONE); + sc->code = fnc; + sc->args = + (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args; + eval(sc, OP_APPLY); + /* we're limited in choices here -- the caller might be (say) car(sc->t1_1) = fn_proc(...) where the fn_proc + * happens to fallback on a method -- we can't just push OP_APPLY and drop back into the evaluator normally. + */ + return (sc->value); +} + + +static s7_pointer implicit_index(s7_scheme * sc, s7_pointer obj, + s7_pointer indices) +{ + s7_pointer res; + /* (let ((lst '("12" "34"))) (lst 0 1)) -> #\2 + * (let ((lst (list #(1 2) #(3 4)))) (lst 0 1)) -> 2 + * this can get tricky: + * ((list (lambda (a) (+ a 1)) (lambda (b) (* b 2))) 1 2) -> 4 + * but what if func takes rest/optional args, etc? + * ((list (lambda args (car args))) 0 "hi" 0) + * should this return #\h or "hi"?? currently it is "hi" which is consistent with ((lambda args (car args)) "hi" 0) + * but ((lambda (arg) arg) "hi" 0) is currently an error (too many arguments) + * maybe it should be (((lambda (arg) arg) "hi") 0) -> #\h + */ + switch (type(obj)) { + case T_VECTOR: /* (#(#(1 2) #(3 4)) 1 1) -> 4 */ + return (vector_ref_1(sc, obj, indices)); + + case T_FLOAT_VECTOR: + res = + univect_ref(sc, set_ulist_1(sc, obj, indices), + sc->float_vector_ref_symbol, T_FLOAT_VECTOR); + set_car(sc->u1_1, sc->F); + return (res); + + case T_INT_VECTOR: + res = + univect_ref(sc, set_ulist_1(sc, obj, indices), + sc->int_vector_ref_symbol, T_INT_VECTOR); + set_car(sc->u1_1, sc->F); + return (res); + + case T_BYTE_VECTOR: + res = + univect_ref(sc, set_ulist_1(sc, obj, indices), + sc->byte_vector_ref_symbol, T_BYTE_VECTOR); + set_car(sc->u1_1, sc->F); + return (res); + + case T_STRING: /* (#("12" "34") 0 1) -> #\2 */ + if (!is_null(cdr(indices))) + return (s7_error + (sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, obj, + indices))); + if (!is_t_integer(car(indices))) + return (wrong_type_argument + (sc, sc->string_ref_symbol, 2, car(indices), + T_INTEGER)); + return (string_ref_p_pi_unchecked(sc, obj, integer(car(indices)))); + + case T_PAIR: /* (#((1 2) (3 4)) 1 0) -> 3, (#((1 (2 3))) 0 1 0) -> 2 */ + obj = list_ref_1(sc, obj, car(indices)); + return ((is_pair(cdr(indices))) ? + implicit_index(sc, obj, cdr(indices)) : obj); + + case T_HASH_TABLE: /* ((vector (hash-table '(a . 1) '(b . 2))) 0 'a) -> 1 */ + obj = s7_hash_table_ref(sc, obj, car(indices)); + return ((is_pair(cdr(indices))) ? + implicit_index(sc, obj, cdr(indices)) : obj); + + case T_C_OBJECT: + res = + (*(c_object_ref(sc, obj))) (sc, set_ulist_1(sc, obj, indices)); + set_car(sc->u1_1, sc->F); + return (res); + + case T_LET: + obj = s7_let_ref(sc, obj, car(indices)); + return ((is_pair(cdr(indices))) ? + implicit_index(sc, obj, cdr(indices)) : obj); + + case T_ITERATOR: /* indices is not nil, so this is an error */ + return (s7_error + (sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, obj, + indices))); + + default: /* (#(a b c) 0 1) -> error, but ((list (lambda (x) x)) 0 "hi") -> "hi" */ + if (!is_applicable(obj)) /* (apply (list cons cons) (list 1 2)) needs the argnum check mentioned below */ + return (apply_error(sc, obj, indices)); + if ((is_c_function(obj)) && (is_safe_procedure(obj))) { + s7_int len; + len = proper_list_length(indices); + if ((c_function_required_args(obj) <= len) && + (c_function_all_args(obj) >= len)) + return (c_function_call(obj) (sc, indices)); + } + push_stack_direct(sc, OP_EVAL_DONE); + sc->code = obj; + sc->args = + (needs_copied_args(obj)) ? copy_proper_list(sc, + indices) : indices; + eval(sc, OP_APPLY); + /* here sc->values can be multiple-values: (list (list-ref (list (lambda (a) (values a (+ a 1)))) 0 1)) -> '((values 1 2)), but should be '(1 2) */ + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return (sc->value); + /* return(s7_apply_function(sc, obj, indices)); -- needs argnum check *//* was g_apply 23-Jan-19 which assumes we're not in map */ + } +} + +static inline void fill_star_defaults(s7_scheme * sc, s7_pointer func, + int32_t start_arg, int32_t n_args, + s7_pointer par) +{ + int32_t i; + s7_pointer *df; + df = c_function_arg_defaults(func); + if (c_func_has_simple_defaults(func)) { + for (i = start_arg; i < n_args; i++, par = cdr(par)) + set_car(par, df[i]); + } else + for (i = start_arg; i < n_args; i++, par = cdr(par)) { + s7_pointer defval = df[i]; + if (is_symbol(defval)) + set_car(par, lookup_checked(sc, defval)); + else if (is_pair(defval)) + set_car(par, s7_eval(sc, defval, sc->nil)); + else + set_car(par, defval); + } +} + +static s7_pointer set_c_function_star_args(s7_scheme * sc) +{ + int32_t i, j, n_args; + s7_pointer arg, par, call_args, func = sc->code; + s7_pointer *df; + + n_args = c_function_all_args(func); /* not counting keywords, I think */ + call_args = + (is_safe_procedure(func)) ? c_function_call_args(func) : + protected_make_list(sc, c_function_optional_args(func), sc->F); + + /* assume at the start that there are no keywords */ + for (i = 0, arg = sc->args, par = call_args; + (i < n_args) && (is_pair(arg)); + i++, arg = cdr(arg), par = cdr(par)) { + if (!is_keyword(car(arg))) + set_car(par, car(arg)); + else { + s7_pointer kpar, karg; + int32_t ki; + /* oops -- there are keywords, change scanners (much duplicated code...) + * setting checked on the call_args here rather than parsing the parameters to use add_symbol_to_list + */ + for (kpar = call_args; kpar != par; kpar = cdr(kpar)) + set_checked(kpar); + for (; is_pair(kpar); kpar = cdr(kpar)) + clear_checked(kpar); + df = c_function_arg_names(func); + for (ki = i, karg = arg, kpar = par; + (ki < n_args) && (is_pair(karg)); ki++, karg = cdr(karg)) + if (!is_keyword(car(karg))) { + if (is_checked(kpar)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, + parameter_set_twice_string, + car(kpar), sc->args))); + set_checked(kpar); + set_car(kpar, car(karg)); + kpar = cdr(kpar); + } else { + s7_pointer p; + for (j = 0, p = call_args; j < n_args; j++, p = cdr(p)) + if (df[j] == car(karg)) + break; + if (j == n_args) { + if (c_function_allows_other_keys(func)) { + karg = cdr(karg); + if (is_null(karg)) /* (f* :x) where f* arglist includes :allow-other-keys */ + return (s7_error + (sc, sc->syntax_error_symbol, + set_elist_3(sc, + value_is_missing_string, + func, car(arg)))); + ki--; + } else + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, + "~A: not a parameter name?", + 25), + car(karg)))); + } else { + if (is_checked(p)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, + parameter_set_twice_string, + car(p), sc->args))); + if (!is_pair(cdr(karg))) + return (s7_error + (sc, sc->syntax_error_symbol, + set_elist_3(sc, + value_is_missing_string, + func, car(karg)))); + set_checked(p); + karg = cdr(karg); + set_car(p, car(karg)); + kpar = cdr(kpar); + } + } + if ((!is_null(karg)) && (!c_function_allows_other_keys(func))) + return (s7_error + (sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, func, + sc->args))); + if (ki < n_args) { + df = c_function_arg_defaults(func); + if (c_func_has_simple_defaults(func)) { + for (ki = i, kpar = par; ki < n_args; + ki++, kpar = cdr(kpar)) + if (!is_checked(kpar)) + set_car(kpar, df[ki]); + } else + for (ki = i, kpar = par; ki < n_args; + ki++, kpar = cdr(kpar)) + if (!is_checked(kpar)) { + s7_pointer defval = df[ki]; + if (is_symbol(defval)) + set_car(kpar, lookup_checked(sc, defval)); + else if (is_pair(defval)) + set_car(kpar, + s7_eval(sc, defval, sc->nil)); + else + set_car(kpar, defval); + } + } + return (call_args); + } + } + if (!is_null(arg)) + return (s7_error + (sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, func, + sc->args))); + if (i < n_args) + fill_star_defaults(sc, func, i, n_args, par); + return (call_args); +} + +static s7_pointer set_c_function_star_defaults(s7_scheme * sc, int32_t num) +{ + s7_pointer call_args, func = sc->code, par; + int32_t n_args = c_function_all_args(func); + + call_args = + (is_safe_procedure(func)) ? c_function_call_args(func) : + protected_make_list(sc, n_args, sc->F); + par = call_args; + if (num == 1) { + set_car(par, car(sc->args)); + par = cdr(par); + } + fill_star_defaults(sc, func, num, n_args, par); + return (call_args); +} + +#define apply_c_function_star(Sc) Sc->value = c_function_call(Sc->code)(Sc, set_c_function_star_args(Sc)) +#define apply_c_function_star_fill_defaults(Sc, Num) Sc->value = c_function_call(Sc->code)(Sc, set_c_function_star_defaults(Sc, Num)) + +s7_pointer s7_apply_function_star(s7_scheme * sc, s7_pointer fnc, + s7_pointer args) +{ + TRACK(sc); + if (is_c_function_star(fnc)) { + sc->w = sc->args; + sc->z = sc->code; + sc->args = T_Pos(args); + sc->code = fnc; + apply_c_function_star(sc); + sc->args = sc->w; + sc->code = sc->z; + return (sc->value); + } + push_stack_direct(sc, OP_EVAL_DONE); + sc->code = fnc; + sc->args = + (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args; + eval(sc, OP_APPLY); + return (sc->value); +} + +/* -------------------------------- eval -------------------------------- */ +s7_pointer s7_eval(s7_scheme * sc, s7_pointer code, s7_pointer e) +{ + declare_jump_info(); + TRACK(sc); + + if (sc->safety > NO_SAFETY) { + if (!s7_is_valid(sc, code)) + s7_warn(sc, 256, "bad code argument to %s: %p\n", __func__, + code); + if (!s7_is_valid(sc, e)) + s7_warn(sc, 256, "bad environment argument to %s: %p\n", + __func__, e); + } + + store_jump_info(sc); + set_jump_info(sc, EVAL_SET_JUMP); + if (jump_loc != NO_JUMP) { + if (jump_loc != ERROR_JUMP) + eval(sc, sc->cur_op); + } else { + push_stack_direct(sc, OP_EVAL_DONE); + sc->code = code; + if ((e != sc->rootlet) && (is_let(e))) + set_curlet(sc, e); + else + sc->curlet = sc->nil; + eval(sc, OP_EVAL); + } + restore_jump_info(sc); + + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return (sc->value); +} + + +static s7_pointer g_eval(s7_scheme * sc, s7_pointer args) +{ +#define H_eval "(eval code (let (curlet))) evaluates code in the environment let. 'let' \ +defaults to the curlet; to evaluate something in the top-level environment instead, \ +pass (rootlet):\n\ +\n\ + (define x 32) \n\ + (let ((x 3))\n\ + (eval 'x (rootlet)))\n\ +\n\ + returns 32" +#define Q_eval s7_make_signature(sc, 3, sc->values_symbol, sc->T, sc->is_let_symbol) + + if (is_not_null(cdr(args))) { + s7_pointer e = cadr(args); + if (!is_let(e)) + return (wrong_type_argument_with_type + (sc, sc->eval_symbol, 2, e, a_let_string)); + set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); + } + sc->code = car(args); + + if ((sc->safety > NO_SAFETY) && (is_pair(sc->code))) { + check_free_heap_size(sc, 8192); + sc->code = copy_body(sc, sc->code); + } else if (is_optimized(sc->code)) + clear_all_optimizations(sc, sc->code); + + set_current_code(sc, sc->code); + if (current_stack_top(sc) < 12) + push_stack_op(sc, OP_BARRIER); + push_stack_direct(sc, OP_EVAL); + return (sc->nil); +} + +s7_pointer s7_call(s7_scheme * sc, s7_pointer func, s7_pointer args) +{ + declare_jump_info(); + TRACK(sc); + set_current_code(sc, history_cons(sc, func, args)); + if (SHOW_EVAL_OPS) + safe_print(fprintf + (stderr, "%s: %s %s\n", __func__, display(func), + display_80(args))); + + if (is_c_function(func)) + return (c_function_call(func) (sc, args)); /* no check for wrong-number-of-args -- is that reasonable? */ + + sc->temp4 = T_App(func); /* this is feeble GC protection */ + sc->temp2 = T_Lst(args); + + store_jump_info(sc); + set_jump_info(sc, S7_CALL_SET_JUMP); + if (jump_loc != NO_JUMP) { + if (jump_loc != ERROR_JUMP) + eval(sc, sc->cur_op); + + if ((jump_loc == CATCH_JUMP) && /* we're returning (back to eval) from an error in catch */ + (sc->stack_end == sc->stack_start)) + push_stack_op(sc, OP_ERROR_QUIT); + } else { + if (sc->safety > NO_SAFETY) + check_list_validity(sc, "s7_call", args); + push_stack_direct(sc, OP_EVAL_DONE); /* this saves the current evaluation and will eventually finish this (possibly) nested call */ + sc->code = func; + sc->args = + (needs_copied_args(func)) ? copy_proper_list(sc, args) : args; + /* besides a closure, "func" can also be an object (T_C_OBJECT) -- in Snd, a generator for example */ + eval(sc, OP_APPLY); + } + restore_jump_info(sc); + /* don't clear temp4 or temp2 here -- lots of (Snd) code calls s7_call repeatedly and assumes the "func" arg is protected between calls. */ + return (sc->value); +} + +s7_pointer s7_call_with_location(s7_scheme * sc, s7_pointer func, + s7_pointer args, const char *caller, + const char *file, s7_int line) +{ + s7_pointer result; + if (caller) { + sc->s7_call_name = caller; + sc->s7_call_file = file; + sc->s7_call_line = line; + } + result = s7_call(sc, func, args); + if (caller) { + sc->s7_call_name = NULL; + sc->s7_call_file = NULL; + sc->s7_call_line = -1; + } + return (result); +} + + +/* -------------------------------- type-of -------------------------------- */ +#if (!WITH_GCC) +static inline bool gen_type_match(s7_scheme * sc, s7_pointer val, + uint8_t typ) +{ /* opt3_byte = uint8_t */ + return ((type(val) == typ) || + ((has_active_methods(sc, val)) && + (apply_boolean_method(sc, val, sc->type_to_typers[typ]) != + sc->F))); +} +#else +#define gen_type_match(Sc, Val, Typ) ({s7_pointer _val_ = Val; ((type(_val_) == Typ) || ((has_active_methods(Sc, _val_)) && (apply_boolean_method(Sc, _val_, Sc->type_to_typers[Typ]) != Sc->F)));}) +#endif + +static void init_typers(s7_scheme * sc) +{ + sc->type_to_typers[T_FREE] = sc->F; + sc->type_to_typers[T_PAIR] = sc->is_pair_symbol; + sc->type_to_typers[T_NIL] = sc->is_null_symbol; + sc->type_to_typers[T_EOF] = sc->is_eof_object_symbol; + sc->type_to_typers[T_UNDEFINED] = sc->is_undefined_symbol; + sc->type_to_typers[T_UNSPECIFIED] = sc->is_unspecified_symbol; + sc->type_to_typers[T_BOOLEAN] = sc->is_boolean_symbol; + sc->type_to_typers[T_CHARACTER] = sc->is_char_symbol; + sc->type_to_typers[T_SYMBOL] = sc->is_symbol_symbol; /* and keyword? */ + sc->type_to_typers[T_SYNTAX] = sc->is_syntax_symbol; + sc->type_to_typers[T_INTEGER] = sc->is_integer_symbol; + sc->type_to_typers[T_RATIO] = sc->is_rational_symbol; + sc->type_to_typers[T_REAL] = sc->is_float_symbol; + sc->type_to_typers[T_COMPLEX] = sc->is_complex_symbol; + sc->type_to_typers[T_BIG_INTEGER] = sc->is_integer_symbol; + sc->type_to_typers[T_BIG_RATIO] = sc->is_rational_symbol; + sc->type_to_typers[T_BIG_REAL] = sc->is_float_symbol; + sc->type_to_typers[T_BIG_COMPLEX] = sc->is_complex_symbol; + sc->type_to_typers[T_STRING] = sc->is_string_symbol; + sc->type_to_typers[T_BYTE_VECTOR] = sc->is_byte_vector_symbol; + sc->type_to_typers[T_C_OBJECT] = sc->is_c_object_symbol; + sc->type_to_typers[T_VECTOR] = sc->is_vector_symbol; + sc->type_to_typers[T_INT_VECTOR] = sc->is_int_vector_symbol; + sc->type_to_typers[T_FLOAT_VECTOR] = sc->is_float_vector_symbol; + sc->type_to_typers[T_CATCH] = sc->F; + sc->type_to_typers[T_DYNAMIC_WIND] = sc->F; + sc->type_to_typers[T_HASH_TABLE] = sc->is_hash_table_symbol; + sc->type_to_typers[T_LET] = sc->is_let_symbol; + sc->type_to_typers[T_ITERATOR] = sc->is_iterator_symbol; + sc->type_to_typers[T_STACK] = sc->F; + sc->type_to_typers[T_COUNTER] = sc->F; + sc->type_to_typers[T_SLOT] = sc->F; + sc->type_to_typers[T_C_POINTER] = sc->is_c_pointer_symbol; + sc->type_to_typers[T_OUTPUT_PORT] = sc->is_output_port_symbol; + sc->type_to_typers[T_INPUT_PORT] = sc->is_input_port_symbol; + sc->type_to_typers[T_RANDOM_STATE] = sc->is_random_state_symbol; + sc->type_to_typers[T_GOTO] = sc->is_goto_symbol; + sc->type_to_typers[T_CONTINUATION] = sc->is_continuation_symbol; + sc->type_to_typers[T_CLOSURE] = sc->is_procedure_symbol; + sc->type_to_typers[T_CLOSURE_STAR] = sc->is_procedure_symbol; + sc->type_to_typers[T_C_MACRO] = sc->is_macro_symbol; + sc->type_to_typers[T_MACRO] = sc->is_macro_symbol; + sc->type_to_typers[T_MACRO_STAR] = sc->is_macro_symbol; + sc->type_to_typers[T_BACRO] = sc->is_macro_symbol; + sc->type_to_typers[T_BACRO_STAR] = sc->is_macro_symbol; + sc->type_to_typers[T_C_FUNCTION] = sc->is_procedure_symbol; + sc->type_to_typers[T_C_FUNCTION_STAR] = sc->is_procedure_symbol; + sc->type_to_typers[T_C_ANY_ARGS_FUNCTION] = sc->is_procedure_symbol; + sc->type_to_typers[T_C_OPT_ARGS_FUNCTION] = sc->is_procedure_symbol; + sc->type_to_typers[T_C_RST_ARGS_FUNCTION] = sc->is_procedure_symbol; +} + +s7_pointer s7_type_of(s7_scheme * sc, s7_pointer arg) +{ + return (sc->type_to_typers[type(arg)]); +} + +static s7_pointer g_type_of(s7_scheme * sc, s7_pointer args) +{ +#define H_type_of "(type-of obj) returns a symbol describing obj's type" +#define Q_type_of s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->not_symbol), sc->T) + return (sc->type_to_typers[type(car(args))]); +} + + +/* -------------------------------- exit emergency-exit -------------------------------- */ +void s7_quit(s7_scheme * sc) +{ + sc->longjmp_ok = false; + pop_input_port(sc); + stack_reset(sc); + push_stack_op_let(sc, OP_EVAL_DONE); +} + +static s7_pointer g_emergency_exit(s7_scheme * sc, s7_pointer args) +{ +#define H_emergency_exit "(emergency-exit obj) exits s7 immediately" +#define Q_emergency_exit s7_make_signature(sc, 2, sc->T, sc->T) + + s7_pointer obj; +#ifndef EXIT_SUCCESS +#define EXIT_SUCCESS 0 +#define EXIT_FAILURE 1 +#endif + + if (is_null(args)) + _exit(EXIT_SUCCESS); /* r7rs spec says use _exit here */ + obj = car(args); + if (obj == sc->F) + _exit(EXIT_FAILURE); + if ((obj == sc->T) || (!s7_is_integer(obj))) + _exit(EXIT_SUCCESS); + _exit((int) s7_integer_checked(sc, obj)); + return (sc->F); +} + +static s7_pointer g_exit(s7_scheme * sc, s7_pointer args) +{ +#define H_exit "(exit obj) exits s7" +#define Q_exit s7_make_signature(sc, 2, sc->T, sc->T) + /* calling s7_eval_c_string in an atexit function seems to be problematic -- it works, but args can be changed? longjmp perhaps? */ + + s7_quit(sc); + if (show_gc_stats(sc)) + s7_warn(sc, 256, "gc calls %" ld64 " total time: %f\n", + sc->gc_calls, + (double) (sc->gc_total_time) / ticks_per_second()); + return (g_emergency_exit(sc, args)); +} + +#if WITH_GCC +static s7_pointer g_abort(s7_scheme * sc, s7_pointer args) +{ + abort(); +} +#endif + + +/* -------------------------------- optimizer stuff -------------------------------- */ + +/* There is a problem with cache misses: a bigger cache reduces one test from 24 seconds to 17 (cachegrind agrees). + * But how to optimize s7 for cache hits? The culprits are eval and gc. Looking at the numbers, + * I think the least affected tests are able to use opt_info optimization which makes everything local? + */ + +#if S7_DEBUGGING +static void check_t_1(s7_scheme * sc, s7_pointer e, const char *func, + s7_pointer expr, s7_pointer var) +{ + if (let_slots(e) != lookup_slot_from(var, sc->curlet)) { + fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func, + display(expr), display(var), display(sc->curlet), + (tis_slot(let_slots(e))) ? display(let_slots(e)) : + "no slots"); + if (sc->stop_at_error) + abort(); + } +} + +static s7_pointer t_lookup_1(s7_scheme * sc, s7_pointer symbol, + const char *func, s7_pointer expr) +{ + check_t_1(sc, sc->curlet, func, expr, symbol); + return (slot_value(let_slots(sc->curlet))); +} + +static s7_pointer T_lookup_1(s7_scheme * sc, s7_pointer symbol, + const char *func, s7_pointer expr) +{ + check_t_1(sc, let_outlet(sc->curlet), func, expr, symbol); + return (slot_value(let_slots(let_outlet(sc->curlet)))); +} + +static void check_u_1(s7_scheme * sc, s7_pointer e, const char *func, + s7_pointer expr, s7_pointer var) +{ + if (next_slot(let_slots(e)) != lookup_slot_from(var, sc->curlet)) { + fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func, + display(expr), display(var), display(e), + (tis_slot(next_slot(let_slots(e)))) ? + display(next_slot(let_slots(e))) : "no next slot"); + if (sc->stop_at_error) + abort(); + } +} + +static s7_pointer u_lookup_1(s7_scheme * sc, s7_pointer symbol, + const char *func, s7_pointer expr) +{ + check_u_1(sc, sc->curlet, func, expr, symbol); + return (slot_value(next_slot(let_slots(sc->curlet)))); +} + +static s7_pointer U_lookup_1(s7_scheme * sc, s7_pointer symbol, + const char *func, s7_pointer expr) +{ + check_u_1(sc, let_outlet(sc->curlet), func, expr, symbol); + return (slot_value(next_slot(let_slots(let_outlet(sc->curlet))))); +} + +static void check_v_1(s7_scheme * sc, s7_pointer e, const char *func, + s7_pointer expr, s7_pointer var) +{ + if (next_slot(next_slot(let_slots(e))) != + lookup_slot_from(var, sc->curlet)) { + fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func, + display(expr), display(var), display(e), + (tis_slot(next_slot(next_slot(let_slots(e))))) ? + display(next_slot(next_slot(let_slots(e)))) : + "no next slot"); + if (sc->stop_at_error) + abort(); + } +} + +static s7_pointer v_lookup_1(s7_scheme * sc, s7_pointer symbol, + const char *func, s7_pointer expr) +{ + check_v_1(sc, sc->curlet, func, expr, symbol); + return (slot_value(next_slot(next_slot(let_slots(sc->curlet))))); +} + +static s7_pointer V_lookup_1(s7_scheme * sc, s7_pointer symbol, + const char *func, s7_pointer expr) +{ + check_v_1(sc, let_outlet(sc->curlet), func, expr, symbol); + return (slot_value + (next_slot(next_slot(let_slots(let_outlet(sc->curlet)))))); +} + +static void check_o_1(s7_scheme * sc, s7_pointer e, const char *func, + s7_pointer expr, s7_pointer var) +{ + s7_pointer slot; + slot = lookup_slot_from(var, sc->curlet); + if (lookup_slot_from(var, e) != slot) { + fprintf(stderr, "%s %s is out of date (%s in %s -> %s)\n", func, + display(expr), display(var), display(e), + (tis_slot(slot)) ? display(slot) : "undefined"); + if (sc->stop_at_error) + abort(); + } +} + +static s7_pointer o_lookup_1(s7_scheme * sc, s7_pointer symbol, + const char *func, s7_pointer expr) +{ + check_o_1(sc, let_outlet(sc->curlet), func, expr, symbol); + return (lookup_from(sc, symbol, let_outlet(sc->curlet))); +} + +static s7_pointer O_lookup_1(s7_scheme * sc, s7_pointer symbol, + const char *func, s7_pointer expr) +{ + check_o_1(sc, let_outlet(let_outlet(sc->curlet)), func, expr, symbol); + return (lookup_from(sc, symbol, let_outlet(sc->curlet))); +} + + +#define t_lookup(Sc, Symbol, Expr) t_lookup_1(Sc, Symbol, __func__, Expr) +#define u_lookup(Sc, Symbol, Expr) u_lookup_1(Sc, Symbol, __func__, Expr) +#define v_lookup(Sc, Symbol, Expr) v_lookup_1(Sc, Symbol, __func__, Expr) +#define T_lookup(Sc, Symbol, Expr) T_lookup_1(Sc, Symbol, __func__, Expr) +#define U_lookup(Sc, Symbol, Expr) U_lookup_1(Sc, Symbol, __func__, Expr) +#define V_lookup(Sc, Symbol, Expr) V_lookup_1(Sc, Symbol, __func__, Expr) +#define o_lookup(Sc, Symbol, Expr) o_lookup_1(Sc, Symbol, __func__, Expr) +#define O_lookup(Sc, Symbol, Expr) O_lookup_1(Sc, Symbol, __func__, Expr) +#else +#define t_lookup(Sc, Symbol, Expr) slot_value(let_slots(sc->curlet)) +#define u_lookup(Sc, Symbol, Expr) slot_value(next_slot(let_slots(sc->curlet))) +#define v_lookup(Sc, Symbol, Expr) slot_value(next_slot(next_slot(let_slots(sc->curlet)))) +#define T_lookup(Sc, Symbol, Expr) slot_value(let_slots(let_outlet(sc->curlet))) +#define U_lookup(Sc, Symbol, Expr) slot_value(next_slot(let_slots(let_outlet(sc->curlet)))) +#define V_lookup(Sc, Symbol, Expr) slot_value(next_slot(next_slot(let_slots(let_outlet(sc->curlet))))) +#define o_lookup(Sc, Symbol, Expr) lookup_from(Sc, Symbol, let_outlet(Sc->curlet)) +#define O_lookup(Sc, Symbol, Expr) lookup_from(Sc, Symbol, let_outlet(let_outlet(Sc->curlet))) +#endif + +#define s_lookup(Sc, Sym, Expr) lookup(Sc, Sym) +#define g_lookup(Sc, Sym, Expr) lookup_global(Sc, Sym) + +/* arg here is the full expression */ +static s7_pointer fx_c(s7_scheme * sc, s7_pointer arg) +{ + return (arg); +} + +static s7_pointer fx_q(s7_scheme * sc, s7_pointer arg) +{ + return (cadr(arg)); +} + +static s7_pointer fx_unsafe_s(s7_scheme * sc, s7_pointer arg) +{ + return (lookup_checked(sc, T_Sym(arg))); +} + +static s7_pointer fx_s(s7_scheme * sc, s7_pointer arg) +{ + return (lookup(sc, T_Sym(arg))); +} + +static s7_pointer fx_g(s7_scheme * sc, s7_pointer arg) +{ + return ((is_global(arg)) ? global_value(arg) : lookup(sc, arg)); +} + +static s7_pointer fx_o(s7_scheme * sc, s7_pointer arg) +{ + return (o_lookup(sc, T_Sym(arg), arg)); +} + +static s7_pointer fx_t(s7_scheme * sc, s7_pointer arg) +{ + return (t_lookup(sc, T_Sym(arg), arg)); +} + +static s7_pointer fx_u(s7_scheme * sc, s7_pointer arg) +{ + return (u_lookup(sc, T_Sym(arg), arg)); +} + +static s7_pointer fx_v(s7_scheme * sc, s7_pointer arg) +{ + return (v_lookup(sc, T_Sym(arg), arg)); +} + +static s7_pointer fx_T(s7_scheme * sc, s7_pointer arg) +{ + return (T_lookup(sc, T_Sym(arg), arg)); +} + +static s7_pointer fx_U(s7_scheme * sc, s7_pointer arg) +{ + return (U_lookup(sc, T_Sym(arg), arg)); +} + +static s7_pointer fx_c_nc(s7_scheme * sc, s7_pointer arg) +{ + return (fc_call(sc, arg)); +} + +#define fx_c_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t1_1, Lookup(sc, cadr(arg), arg)); \ + return(fn_proc(arg)(sc, sc->t1_1)); \ + } + +fx_c_any(fx_c_s, s_lookup) + fx_c_any(fx_c_g, g_lookup) + fx_c_any(fx_c_t, t_lookup) + fx_c_any(fx_c_u, u_lookup) + fx_c_any(fx_c_v, v_lookup) + fx_c_any(fx_c_o, o_lookup) + fx_c_any(fx_c_T, T_lookup) +static s7_pointer fx_c_g_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc, + lookup_global(sc, + cadr(arg)))); +} + +static s7_pointer fx_c_s_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc, + lookup(sc, cadr(arg)))); +} + +static s7_pointer fx_c_o_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc, + o_lookup(sc, cadr(arg), + arg))); +} + +static s7_pointer fx_c_t_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc, + t_lookup(sc, cadr(arg), + arg))); +} + +static s7_pointer fx_c_u_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc, + u_lookup(sc, cadr(arg), + arg))); +} + +static s7_pointer fx_c_v_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc, + v_lookup(sc, cadr(arg), + arg))); +} + + +#define fx_car_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer val; \ + val = Lookup(sc, cadr(arg), arg); \ + return((is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \ + } + +fx_car_any(fx_car_s, s_lookup) + fx_car_any(fx_car_t, t_lookup) + fx_car_any(fx_car_u, u_lookup) + fx_car_any(fx_car_o, o_lookup) +#define fx_cdr_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer val; \ + val = Lookup(sc, cadr(arg), arg); \ + return((is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val))); \ + } + fx_cdr_any(fx_cdr_s, s_lookup) + fx_cdr_any(fx_cdr_t, t_lookup) + fx_cdr_any(fx_cdr_u, u_lookup) + fx_cdr_any(fx_cdr_v, v_lookup) + fx_cdr_any(fx_cdr_o, o_lookup) +#define fx_cadr_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg)\ + { \ + s7_pointer val; \ + val = Lookup(sc, cadr(arg), arg); \ + return(((is_pair(val)) && (is_pair(cdr(val)))) ? cadr(val) : g_cadr(sc, set_plist_1(sc, val))); \ + } + fx_cadr_any(fx_cadr_s, s_lookup) + fx_cadr_any(fx_cadr_t, t_lookup) + fx_cadr_any(fx_cadr_u, u_lookup) + fx_cadr_any(fx_cadr_o, o_lookup) +#define fx_cddr_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg)\ + { \ + s7_pointer val; \ + val = Lookup(sc, cadr(arg), arg); \ + return(((is_pair(val)) && (is_pair(cdr(val)))) ? cddr(val) : g_cddr(sc, set_plist_1(sc, val))); \ + } + fx_cddr_any(fx_cddr_s, s_lookup) + fx_cddr_any(fx_cddr_t, t_lookup) + fx_cddr_any(fx_cddr_u, u_lookup) + fx_cddr_any(fx_cddr_o, o_lookup) +#define fx_add_s1_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x; \ + x = Lookup(sc, cadr(arg), arg); \ + if ((!WITH_GMP) && (is_t_integer(x))) return(make_integer(sc, integer(x) + 1)); \ + return(g_add_x1_1(sc, x, 1)); /* arg=(+ x 1) */ \ + } + fx_add_s1_any(fx_add_s1, s_lookup) + fx_add_s1_any(fx_add_t1, t_lookup) + fx_add_s1_any(fx_add_u1, u_lookup) + fx_add_s1_any(fx_add_T1, T_lookup) + fx_add_s1_any(fx_add_U1, U_lookup) + fx_add_s1_any(fx_add_V1, V_lookup) +static s7_pointer fx_num_eq_xi_1(s7_scheme * sc, s7_pointer args, + s7_pointer val, s7_int y) +{ + if ((S7_DEBUGGING) && (is_t_integer(val))) + fprintf(stderr, "%s[%d]: %s is an integer\n", __func__, __LINE__, + display(val)); + switch (type(val)) { + case T_REAL: + return (make_boolean(sc, real(val) == y)); + case T_RATIO: + case T_COMPLEX: + return (sc->F); +#if WITH_GMP + case T_BIG_INTEGER: + return (make_boolean(sc, mpz_cmp_si(big_integer(val), y) == 0)); + case T_BIG_REAL: + return (make_boolean(sc, mpfr_cmp_si(big_real(val), y) == 0)); + case T_BIG_RATIO: + case T_BIG_COMPLEX: + return (sc->F); +#endif + default: + return (method_or_bust_with_type_pp + (sc, val, sc->num_eq_symbol, val, cadr(args), + a_number_string, 1)); + } + return (sc->T); +} + +static s7_pointer fx_num_eq_s0f(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer val; + val = lookup(sc, cadr(arg)); + if (is_t_real(val)) + return (make_boolean(sc, real(val) == 0.0)); + return (make_boolean(sc, num_eq_b_7pp(sc, val, real_zero))); +} + +#define fx_num_eq_si_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_int y; \ + s7_pointer val, args = cdr(arg); \ + val = Lookup(sc, car(args), arg); \ + y = integer(cadr(args)); \ + return((is_t_integer(val)) ? make_boolean(sc, integer(val) == y) : \ + ((is_t_real(val)) ? make_boolean(sc, real(val) == y) : fx_num_eq_xi_1(sc, args, val, y))); \ +} + +fx_num_eq_si_any(fx_num_eq_si, s_lookup) + fx_num_eq_si_any(fx_num_eq_ti, t_lookup) + fx_num_eq_si_any(fx_num_eq_ui, u_lookup) + fx_num_eq_si_any(fx_num_eq_vi, v_lookup) + fx_num_eq_si_any(fx_num_eq_Ti, T_lookup) +#define fx_num_eq_s0_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer val; \ + val = Lookup(sc, cadr(arg), arg); \ + return((is_t_integer(val)) ? make_boolean(sc, integer(val) == 0) : fx_num_eq_xi_1(sc, cdr(arg), val, 0)); \ + } + fx_num_eq_s0_any(fx_num_eq_s0, s_lookup) + fx_num_eq_s0_any(fx_num_eq_t0, t_lookup) + fx_num_eq_s0_any(fx_num_eq_u0, u_lookup) + fx_num_eq_s0_any(fx_num_eq_v0, v_lookup) +static s7_pointer fx_num_eq_0s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer val; + val = lookup(sc, caddr(arg)); + return ((is_t_integer(val)) ? make_boolean(sc, integer(val) == 0) : + g_num_eq(sc, set_plist_2(sc, val, int_zero))); +} + + +static s7_pointer fx_random_i(s7_scheme * sc, s7_pointer arg) +{ +#if WITH_GMP + return (g_random_i(sc, cdr(arg))); +#else + return (make_integer + (sc, + (s7_int) (integer(cadr(arg)) * + next_random(sc->default_rng)))); +#endif +} + +static s7_pointer fx_add_i_random(s7_scheme * sc, s7_pointer arg) +{ +#if WITH_GMP + return (add_p_pp(sc, cadr(arg), random_p_p(sc, opt3_int(cdr(arg))))); +#else + s7_int x = integer(cadr(arg)), y = integer(opt3_int(cdr(arg))); /* cadadr */ + return (make_integer(sc, x + (s7_int) (y * next_random(sc->default_rng)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */ +#endif +} + +static s7_pointer fx_add_sf(s7_scheme * sc, s7_pointer arg) +{ + return (g_add_xf(sc, lookup(sc, cadr(arg)), real(opt2_con(cdr(arg))))); +} + +static s7_pointer fx_add_fs(s7_scheme * sc, s7_pointer arg) +{ + return (g_add_xf(sc, lookup(sc, opt2_sym(cdr(arg))), real(cadr(arg)))); +} + +static s7_pointer fx_add_tf(s7_scheme * sc, s7_pointer arg) +{ + return (g_add_xf + (sc, t_lookup(sc, cadr(arg), arg), real(opt2_con(cdr(arg))))); +} + +static s7_pointer fx_add_si(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = lookup(sc, cadr(arg)); +#if (!WITH_GMP) + if (is_t_integer(x)) { +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if (!add_overflow(integer(x), integer(opt2_con(cdr(arg))), &val)) + return (make_integer(sc, val)); + /* else fall into add_p_pp below */ +#else + return (make_integer + (sc, integer(x) + integer(opt2_con(cdr(arg))))); +#endif + /* return(add_if_overflow_to_real_or_big_integer(sc, integer(x), integer(opt2_con(cdr(arg))))); -- slightly slower than the add_overflow code above */ + } +#endif + return (add_p_pp(sc, x, opt2_con(cdr(arg)))); /* caddr(arg) */ +} + +static s7_pointer fx_add_ss(s7_scheme * sc, s7_pointer arg) +{ + return (add_p_pp + (sc, s_lookup(sc, cadr(arg), arg), + s_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_add_ts(s7_scheme * sc, s7_pointer arg) +{ + return (add_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + s_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_add_tu(s7_scheme * sc, s7_pointer arg) +{ + return (add_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + u_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_add_ut(s7_scheme * sc, s7_pointer arg) +{ + return (add_p_pp + (sc, u_lookup(sc, cadr(arg), arg), + t_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_add_us(s7_scheme * sc, s7_pointer arg) +{ + return (add_p_pp + (sc, u_lookup(sc, cadr(arg), arg), + s_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_add_vu(s7_scheme * sc, s7_pointer arg) +{ + return (add_p_pp + (sc, v_lookup(sc, cadr(arg), arg), + u_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + + +#define fx_subtract_s1_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x; \ + x = Lookup(sc, cadr(arg), arg); \ + if ((!WITH_GMP) && (is_t_integer(x))) return(make_integer(sc, integer(x) - 1)); \ + return(minus_c1(sc, x)); \ + } + +fx_subtract_s1_any(fx_subtract_s1, s_lookup) + fx_subtract_s1_any(fx_subtract_t1, t_lookup) + fx_subtract_s1_any(fx_subtract_u1, u_lookup) + fx_subtract_s1_any(fx_subtract_T1, T_lookup) + fx_subtract_s1_any(fx_subtract_U1, U_lookup) +#define fx_subtract_si_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x; \ + x = Lookup(sc, cadr(arg), arg); \ + if ((!WITH_GMP) && (is_t_integer(x))) \ + { \ + if (HAVE_OVERFLOW_CHECKS) \ + { \ + s7_int val; \ + if (!subtract_overflow(integer(x), integer(opt2_con(cdr(arg))), &val)) \ + return(make_integer(sc, val)); \ + } \ + else return(make_integer(sc, integer(x) - integer(opt2_con(cdr(arg))))); \ + } \ + return(subtract_p_pp(sc, x, opt2_con(cdr(arg)))); /* caddr(arg) */ \ + } + fx_subtract_si_any(fx_subtract_si, s_lookup) + fx_subtract_si_any(fx_subtract_ti, t_lookup) +#define fx_subtract_sf_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x; \ + x = Lookup(sc, cadr(arg), arg); \ + if (is_t_real(x)) \ + return(make_real(sc, real(x) - real(opt2_con(cdr(arg))))); /* caddr(arg) */ \ + return(g_subtract_2f(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ + } + fx_subtract_sf_any(fx_subtract_sf, s_lookup) + fx_subtract_sf_any(fx_subtract_tf, t_lookup) +#define fx_subtract_ss_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) {return(subtract_p_pp(sc, Lookup1(sc, cadr(arg), arg), Lookup2(sc, opt2_sym(cdr(arg)), arg)));} + fx_subtract_ss_any(fx_subtract_ss, s_lookup, s_lookup) + fx_subtract_ss_any(fx_subtract_ts, t_lookup, s_lookup) + fx_subtract_ss_any(fx_subtract_tu, t_lookup, u_lookup) + fx_subtract_ss_any(fx_subtract_ut, u_lookup, t_lookup) + fx_subtract_ss_any(fx_subtract_us, u_lookup, s_lookup) +static s7_pointer fx_subtract_fs(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + s7_double n = real(cadr(arg)); + x = lookup(sc, opt2_sym(cdr(arg))); /* caddr(arg) */ + switch (type(x)) { + case T_INTEGER: + return (make_real(sc, n - integer(x))); + case T_RATIO: + return (make_real(sc, n - fraction(x))); + case T_REAL: + return (make_real(sc, n - real(x))); + case T_COMPLEX: + return (make_complex_not_0i(sc, n - real_part(x), -imag_part(x))); +#if WITH_GMP + case T_BIG_INTEGER: + case T_BIG_RATIO: + case T_BIG_REAL: + case T_BIG_COMPLEX: + return (subtract_p_pp(sc, cadr(arg), x)); +#endif + default: + return (method_or_bust_with_type_pp + (sc, x, sc->subtract_symbol, cadr(arg), x, a_number_string, + 2)); + } + return (x); +} + +#define fx_is_eq_sc_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + return(make_boolean(sc, Lookup(sc, cadr(arg), arg) == opt2_con(cdr(arg)))); /* fx_choose checks that the second arg is not unspecified */ \ + } + +fx_is_eq_sc_any(fx_is_eq_sc, s_lookup) + fx_is_eq_sc_any(fx_is_eq_tc, t_lookup) +#define fx_is_eq_car_sq_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer lst, a = cdr(arg); \ + lst = Lookup(sc, opt3_sym(a), arg); \ + return(make_boolean(sc, (is_pair(lst)) ? (car(lst) == opt2_con(a)) : s7_is_eq(g_car(sc, set_plist_1(sc, lst)), opt2_con(a)))); \ + } + fx_is_eq_car_sq_any(fx_is_eq_car_sq, s_lookup) + fx_is_eq_car_sq_any(fx_is_eq_car_tq, t_lookup) +static s7_pointer fx_is_eq_caar_sq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer lst, a = cdr(arg); + lst = lookup(sc, opt3_sym(a)); + if ((is_pair(lst)) && (is_pair(car(lst)))) + return (make_boolean(sc, caar(lst) == opt2_con(a))); + return (make_boolean + (sc, s7_is_eq(g_caar(sc, set_plist_1(sc, lst)), opt2_con(a)))); +} + +static s7_pointer fx_not_is_eq_car_sq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer lst; + lst = lookup(sc, opt1_sym(cdr(arg))); + if (is_pair(lst)) + return (make_boolean(sc, car(lst) != opt3_con(cdr(arg)))); + return (make_boolean + (sc, + !s7_is_eq(g_car(sc, set_plist_1(sc, lst)), + opt3_con(cdr(arg))))); +} + +#define fx_is_pair_car_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p; \ + p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ + return((is_pair(p)) ? make_boolean(sc, is_pair(car(p))) : g_is_pair(sc, set_plist_1(sc, g_car(sc, set_plist_1(sc, p))))); \ + } + +fx_is_pair_car_s_any(fx_is_pair_car_s, s_lookup) + fx_is_pair_car_s_any(fx_is_pair_car_t, t_lookup) +#define fx_is_pair_cdr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p; \ + p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ + return((is_pair(p)) ? make_boolean(sc, is_pair(cdr(p))) : g_is_pair(sc, set_plist_1(sc, g_cdr(sc, set_plist_1(sc, p))))); \ + } + fx_is_pair_cdr_s_any(fx_is_pair_cdr_s, s_lookup) + fx_is_pair_cdr_s_any(fx_is_pair_cdr_t, t_lookup) + fx_is_pair_cdr_s_any(fx_is_pair_cdr_u, u_lookup) +#define fx_is_pair_cadr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p; \ + p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ + return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_pair(cadr(p))) : g_is_pair(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \ + } + fx_is_pair_cadr_s_any(fx_is_pair_cadr_s, s_lookup) + fx_is_pair_cadr_s_any(fx_is_pair_cadr_t, t_lookup) +#define fx_is_pair_cddr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p; \ + p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ + return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_pair(cddr(p))) : g_is_pair(sc, set_plist_1(sc, g_cddr(sc, set_plist_1(sc, p))))); \ + } + fx_is_pair_cddr_s_any(fx_is_pair_cddr_s, s_lookup) + fx_is_pair_cddr_s_any(fx_is_pair_cddr_t, t_lookup) +#define fx_is_null_cdr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p; \ + p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ + return((is_pair(p)) ? make_boolean(sc, is_null(cdr(p))) : g_is_null(sc, set_plist_1(sc, g_cdr(sc, set_plist_1(sc, p))))); \ + } + fx_is_null_cdr_s_any(fx_is_null_cdr_s, s_lookup) + fx_is_null_cdr_s_any(fx_is_null_cdr_t, t_lookup) +#define fx_is_null_cadr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p; \ + p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ + return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_null(cadr(p))) : g_is_null(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \ + } + fx_is_null_cadr_s_any(fx_is_null_cadr_s, s_lookup) + fx_is_null_cadr_s_any(fx_is_null_cadr_t, t_lookup) +#define fx_is_null_cddr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p; \ + p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ + return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_null(cddr(p))) : g_is_null(sc, set_plist_1(sc, g_cddr(sc, set_plist_1(sc, p))))); \ + } + fx_is_null_cddr_s_any(fx_is_null_cddr_s, s_lookup) + fx_is_null_cddr_s_any(fx_is_null_cddr_t, t_lookup) +#define fx_is_symbol_cadr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p; \ + p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ + return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_symbol(cadr(p))) : g_is_symbol(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \ + } + fx_is_symbol_cadr_s_any(fx_is_symbol_cadr_s, s_lookup) + fx_is_symbol_cadr_s_any(fx_is_symbol_cadr_t, t_lookup) +static s7_pointer fx_is_symbol_car_t(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer val; + val = t_lookup(sc, opt2_sym(cdr(arg)), arg); + return (make_boolean + (sc, + (is_pair(val)) ? is_symbol(car(val)) : + is_symbol(g_car(sc, set_plist_1(sc, val))))); +} + +static s7_pointer fx_floor_sqrt_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p; + p = lookup(sc, opt2_sym(cdr(arg))); +#if WITH_GMP + if ((is_t_big_integer(p)) && (mpz_cmp_ui(big_integer(p), 0) >= 0)) { /* p >= 0 */ + mpz_sqrt(sc->mpz_1, big_integer(p)); + return (mpz_to_integer(sc, sc->mpz_1)); + } +#else + if (!is_negative_b_7p(sc, p)) + return (make_integer(sc, (s7_int) + floor(sqrt + (s7_number_to_real_with_caller + (sc, p, "sqrt"))))); +#endif + return (floor_p_p(sc, sqrt_p_p(sc, p))); +} + + +static s7_pointer fx_is_positive_u(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p1; + p1 = u_lookup(sc, cadr(arg), arg); + if (is_t_integer(p1)) + return (make_boolean(sc, integer(p1) > 0)); + return (make_boolean(sc, is_positive_b_7p(sc, p1))); +} + +static s7_pointer fx_is_zero_u(s7_scheme * sc, s7_pointer arg) +{ + return (make_boolean + (sc, is_zero_b_7p(sc, u_lookup(sc, cadr(arg), arg)))); +} + +#define fx_real_part_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer z; \ + z = Lookup(sc, cadr(arg), arg); \ + return((is_t_complex(z)) ? make_real(sc, real_part(z)) : real_part_p_p(sc, z)); \ + } + +fx_real_part_s_any(fx_real_part_s, s_lookup) + fx_real_part_s_any(fx_real_part_t, t_lookup) +#define fx_imag_part_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer z; \ + z = Lookup(sc, cadr(arg), arg); \ + return((is_t_complex(z)) ? make_real(sc, imag_part(z)) : imag_part_p_p(sc, z)); \ + } + fx_imag_part_s_any(fx_imag_part_s, s_lookup) + fx_imag_part_s_any(fx_imag_part_t, t_lookup) /* not used in current timing tests */ +#define fx_iterate_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer iter; \ + iter = Lookup(sc, cadr(arg), arg); \ + if (is_iterator(iter)) \ + return((iterator_next(iter))(sc, iter)); \ + return(method_or_bust_one_arg_p(sc, iter, sc->iterate_symbol, T_ITERATOR)); \ + } + fx_iterate_s_any(fx_iterate_s, s_lookup) + fx_iterate_s_any(fx_iterate_o, o_lookup) +static s7_pointer fx_length_s(s7_scheme * sc, s7_pointer arg) +{ + return (s7_length(sc, lookup(sc, cadr(arg)))); +} + +static s7_pointer fx_length_t(s7_scheme * sc, s7_pointer arg) +{ + return (s7_length(sc, t_lookup(sc, cadr(arg), arg))); +} + +static s7_pointer fx_num_eq_length_i(s7_scheme * sc, s7_pointer arg) +{ + /* avoid make_integer (and telescope opts), we get here with car=length expr, cadr=int */ + s7_int ilen = integer(opt2_con(cdr(arg))); /* is_t_integer checked in fx_choose */ + s7_pointer val; + val = lookup(sc, opt3_sym(cdr(arg))); + + switch (type(val)) { + case T_PAIR: + return (make_boolean(sc, s7_list_length(sc, val) == ilen)); + case T_NIL: + return (make_boolean(sc, ilen == 0)); + case T_STRING: + return (make_boolean(sc, string_length(val) == ilen)); + case T_HASH_TABLE: + return (make_boolean(sc, (hash_table_mask(val) + 1) == ilen)); + case T_C_OBJECT: + return (make_boolean(sc, c_object_length_to_int(sc, val) == ilen)); + case T_LET: + return (make_boolean(sc, let_length(sc, val) == ilen)); + + case T_BYTE_VECTOR: + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + return (make_boolean(sc, vector_length(val) == ilen)); + + case T_ITERATOR: + { + s7_pointer len; + len = s7_length(sc, iterator_sequence(val)); + return (make_boolean + (sc, (is_t_integer(len)) && (integer(len) == ilen))); + } + + case T_CLOSURE: + case T_CLOSURE_STAR: + if (has_active_methods(sc, val)) + return (make_boolean(sc, closure_length(sc, val) == ilen)); + /* fall through */ + + default: + return (simple_wrong_type_argument_with_type + (sc, sc->length_symbol, val, a_sequence_string)); + /* here we already lost because we checked for the length above */ + } + return (sc->F); +} + +static s7_pointer fx_less_length_i(s7_scheme * sc, s7_pointer arg) +{ + s7_int ilen = integer(opt2_con(cdr(arg))); /* caddr(arg) */ + s7_pointer val; + val = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg) */ + + switch (type(val)) { + case T_PAIR: + return (make_boolean(sc, s7_list_length(sc, val) < ilen)); + case T_NIL: + return (make_boolean(sc, ilen > 0)); + case T_STRING: + return (make_boolean(sc, string_length(val) < ilen)); + case T_HASH_TABLE: + return (make_boolean(sc, (hash_table_mask(val) + 1) < ilen)); /* was <=? -- changed 15-Dec-15, then again 6-Jan-17: mask is len-1 */ + case T_C_OBJECT: + return (make_boolean(sc, c_object_length_to_int(sc, val) < ilen)); + case T_LET: + return (make_boolean(sc, let_length(sc, val) < ilen)); /* this works because let_length handles the length method itself! */ + + case T_BYTE_VECTOR: + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + return (make_boolean(sc, vector_length(val) < ilen)); + + case T_ITERATOR: + { + s7_pointer len; + len = s7_length(sc, iterator_sequence(val)); + return (make_boolean + (sc, (is_t_integer(len)) && (integer(len) < ilen))); + } + + case T_CLOSURE: + case T_CLOSURE_STAR: + if (has_active_methods(sc, val)) + return (make_boolean(sc, closure_length(sc, val) < ilen)); + /* fall through */ + + default: + return (simple_wrong_type_argument_with_type(sc, sc->length_symbol, val, a_sequence_string)); /* no check method here because we checked above */ + } + return (sc->F); +} + +static s7_pointer fx_is_null_s(s7_scheme * sc, s7_pointer arg) +{ + return ((is_null(lookup(sc, cadr(arg)))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_null_o(s7_scheme * sc, s7_pointer arg) +{ + return ((is_null(o_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} /* very few hits */ + +static s7_pointer fx_is_null_t(s7_scheme * sc, s7_pointer arg) +{ + return ((is_null(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_null_u(s7_scheme * sc, s7_pointer arg) +{ + return ((is_null(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_null_v(s7_scheme * sc, s7_pointer arg) +{ + return ((is_null(v_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_null_T(s7_scheme * sc, s7_pointer arg) +{ + return ((is_null(T_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_symbol_s(s7_scheme * sc, s7_pointer arg) +{ + return ((is_symbol(lookup(sc, cadr(arg)))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_symbol_t(s7_scheme * sc, s7_pointer arg) +{ + return ((is_symbol(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_symbol_u(s7_scheme * sc, s7_pointer arg) +{ + return ((is_symbol(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_eof_s(s7_scheme * sc, s7_pointer arg) +{ + return ((lookup(sc, cadr(arg)) == eof_object) ? sc->T : sc->F); +} + +static s7_pointer fx_is_eof_t(s7_scheme * sc, s7_pointer arg) +{ + return ((t_lookup(sc, cadr(arg), arg) == eof_object) ? sc->T : sc->F); +} + +static s7_pointer fx_is_eof_u(s7_scheme * sc, s7_pointer arg) +{ + return ((u_lookup(sc, cadr(arg), arg) == eof_object) ? sc->T : sc->F); +} + +static s7_pointer fx_is_type_s(s7_scheme * sc, s7_pointer arg) +{ + return (make_boolean + (sc, + (uint8_t) (opt3_byte(cdr(arg))) == + type(lookup(sc, cadr(arg))))); +} + +static s7_pointer fx_is_type_t(s7_scheme * sc, s7_pointer arg) +{ + return (make_boolean + (sc, + (uint8_t) (opt3_byte(cdr(arg))) == + type(t_lookup(sc, cadr(arg), arg)))); +} + +static s7_pointer fx_is_type_u(s7_scheme * sc, s7_pointer arg) +{ + return (make_boolean + (sc, + (uint8_t) (opt3_byte(cdr(arg))) == + type(u_lookup(sc, cadr(arg), arg)))); +} + +#if WITH_GMP +static s7_pointer fx_is_integer_s(s7_scheme * sc, s7_pointer arg) +{ + return ((s7_is_integer(lookup(sc, cadr(arg)))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_integer_t(s7_scheme * sc, s7_pointer arg) +{ + return ((s7_is_integer(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} +#else +static s7_pointer fx_is_integer_s(s7_scheme * sc, s7_pointer arg) +{ + return ((is_t_integer(lookup(sc, cadr(arg)))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_integer_t(s7_scheme * sc, s7_pointer arg) +{ + return ((is_t_integer(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} +#endif +static s7_pointer fx_is_string_s(s7_scheme * sc, s7_pointer arg) +{ + return ((is_string(lookup(sc, cadr(arg)))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_string_t(s7_scheme * sc, s7_pointer arg) +{ + return ((is_string(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_procedure_s(s7_scheme * sc, s7_pointer arg) +{ + return ((is_procedure(lookup(sc, cadr(arg)))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_procedure_t(s7_scheme * sc, s7_pointer arg) +{ + return ((is_procedure(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_pair_s(s7_scheme * sc, s7_pointer arg) +{ + return ((is_pair(lookup(sc, cadr(arg)))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_pair_t(s7_scheme * sc, s7_pointer arg) +{ + return ((is_pair(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_pair_u(s7_scheme * sc, s7_pointer arg) +{ + return ((is_pair(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_pair_v(s7_scheme * sc, s7_pointer arg) +{ + return ((is_pair(v_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_keyword_s(s7_scheme * sc, s7_pointer arg) +{ + return ((is_keyword(lookup(sc, cadr(arg)))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_vector_s(s7_scheme * sc, s7_pointer arg) +{ + return ((is_any_vector(lookup(sc, cadr(arg)))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_vector_t(s7_scheme * sc, s7_pointer arg) +{ + return ((is_any_vector(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F); +} + +static s7_pointer fx_is_proper_list_s(s7_scheme * sc, s7_pointer arg) +{ + return ((s7_is_proper_list(sc, lookup(sc, cadr(arg)))) ? sc-> + T : sc->F); +} + +static s7_pointer fx_not_s(s7_scheme * sc, s7_pointer arg) +{ + return (make_boolean(sc, is_false(sc, lookup(sc, cadr(arg))))); +} + +static s7_pointer fx_not_t(s7_scheme * sc, s7_pointer arg) +{ + return (make_boolean(sc, is_false(sc, t_lookup(sc, cadr(arg), arg)))); +} + +static s7_pointer fx_not_o(s7_scheme * sc, s7_pointer arg) +{ + return (make_boolean(sc, is_false(sc, o_lookup(sc, cadr(arg), arg)))); +} + +static s7_pointer fx_not_is_pair_s(s7_scheme * sc, s7_pointer arg) +{ + return ((is_pair(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T); +} + +static s7_pointer fx_not_is_pair_t(s7_scheme * sc, s7_pointer arg) +{ + return ((is_pair(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T); +} + +static s7_pointer fx_not_is_pair_u(s7_scheme * sc, s7_pointer arg) +{ + return ((is_pair(u_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T); +} + +static s7_pointer fx_not_is_pair_v(s7_scheme * sc, s7_pointer arg) +{ + return ((is_pair(v_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T); +} + +static s7_pointer fx_not_is_null_s(s7_scheme * sc, s7_pointer arg) +{ + return ((is_null(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T); +} + +static s7_pointer fx_not_is_null_t(s7_scheme * sc, s7_pointer arg) +{ + return ((is_null(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T); +} + +static s7_pointer fx_not_is_null_u(s7_scheme * sc, s7_pointer arg) +{ + return ((is_null(u_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T); +} + +static s7_pointer fx_not_is_symbol_s(s7_scheme * sc, s7_pointer arg) +{ + return ((is_symbol(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T); +} + +static s7_pointer fx_not_is_symbol_t(s7_scheme * sc, s7_pointer arg) +{ + return ((is_symbol(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T); +} + +#define fx_c_sc_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t2_1, Lookup(sc, cadr(arg), arg)); \ + set_car(sc->t2_2, opt2_con(cdr(arg))); \ + return(fn_proc(arg)(sc, sc->t2_1)); \ + } + +fx_c_sc_any(fx_c_sc, s_lookup) + fx_c_sc_any(fx_c_tc, t_lookup) + fx_c_sc_any(fx_c_uc, u_lookup) /* few hits */ + fx_c_sc_any(fx_c_vc, v_lookup) +static s7_pointer fx_c_sc_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pp_t) opt3_direct(cdr(arg))) (sc, lookup(sc, cadr(arg)), + opt2_con(cdr(arg)))); +} + +static s7_pointer fx_c_si_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pi_t) opt3_direct(cdr(arg))) (sc, lookup(sc, cadr(arg)), + integer(opt2_con + (cdr(arg))))); +} + +static s7_pointer fx_c_ti_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pi_t) opt3_direct(cdr(arg))) (sc, + t_lookup(sc, cadr(arg), + arg), + integer(opt2_con + (cdr(arg))))); +} + +static s7_pointer fx_c_tc_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pp_t) opt3_direct(cdr(arg))) (sc, + t_lookup(sc, cadr(arg), + arg), + opt2_con(cdr(arg)))); +} + +static s7_pointer fx_vector_ref_tc(s7_scheme * sc, s7_pointer arg) +{ + return (vector_ref_p_pi + (sc, t_lookup(sc, cadr(arg), arg), + integer(opt2_con(cdr(arg))))); +} + +static s7_pointer fx_memq_sc(s7_scheme * sc, s7_pointer arg) +{ + return (memq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg)))); +} + +static s7_pointer fx_memq_sc_3(s7_scheme * sc, s7_pointer arg) +{ + return (memq_3_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg)))); +} + +static s7_pointer fx_memq_tc(s7_scheme * sc, s7_pointer arg) +{ + return (memq_p_pp + (sc, t_lookup(sc, cadr(arg), arg), opt2_con(cdr(arg)))); +} + +static s7_pointer fx_leq_sc(s7_scheme * sc, s7_pointer arg) +{ + return (leq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg)))); +} + +static s7_pointer fx_lt_sc(s7_scheme * sc, s7_pointer arg) +{ + return (lt_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg)))); +} + +static s7_pointer fx_gt_sc(s7_scheme * sc, s7_pointer arg) +{ + return (gt_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg)))); +} + +static s7_pointer fx_geq_sc(s7_scheme * sc, s7_pointer arg) +{ + return (geq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg)))); +} + +#define fx_char_eq_sc_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer c; \ + c = Lookup(sc, cadr(arg), arg); \ + if (c == opt2_con(cdr(arg))) return(sc->T); \ + if (is_character(c)) return(sc->F); \ + return(method_or_bust(sc, cadr(arg), sc->char_eq_symbol, cdr(arg), T_CHARACTER, 1)); \ + } + +fx_char_eq_sc_any(fx_char_eq_sc, s_lookup) + fx_char_eq_sc_any(fx_char_eq_tc, t_lookup) +#define fx_c_cs_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t2_1, opt1_con(cdr(arg))); /* cadr(arg) or cadadr */ \ + set_car(sc->t2_2, Lookup(sc, opt2_sym(cdr(arg)), arg)); /* caddr(arg) */ \ + return(fn_proc(arg)(sc, sc->t2_1)); \ + } + fx_c_cs_any(fx_c_cs, s_lookup) + fx_c_cs_any(fx_c_ct, t_lookup) + fx_c_cs_any(fx_c_cu, u_lookup) +static s7_pointer fx_c_ct_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pp_t) opt3_direct(cdr(arg))) (sc, opt1_con(cdr(arg)), + t_lookup(sc, + opt2_sym(cdr + (arg)), + arg))); +} + +static s7_pointer fx_cons_cs(s7_scheme * sc, s7_pointer arg) +{ + return (cons(sc, opt1_con(cdr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_cons_ct(s7_scheme * sc, s7_pointer arg) +{ + return (cons + (sc, opt1_con(cdr(arg)), + t_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + + +#define fx_c_ss_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \ + set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(arg)), arg)); \ + return(fn_proc(arg)(sc, sc->t2_1)); \ +} + +fx_c_ss_any(fx_c_ss, s_lookup, s_lookup) + fx_c_ss_any(fx_c_st, s_lookup, t_lookup) + fx_c_ss_any(fx_c_ts, t_lookup, s_lookup) + fx_c_ss_any(fx_c_tu, t_lookup, u_lookup) + fx_c_ss_any(fx_c_uv, u_lookup, v_lookup) + fx_c_ss_any(fx_c_tU, t_lookup, U_lookup) +static s7_pointer fx_memq_ss(s7_scheme * sc, s7_pointer arg) +{ + return (memq_p_pp + (sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_memq_tu(s7_scheme * sc, s7_pointer arg) +{ + return (memq_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + u_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_assq_ss(s7_scheme * sc, s7_pointer arg) +{ + return (assq_p_pp + (sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_vref_ss(s7_scheme * sc, s7_pointer arg) +{ + return (vector_ref_p_pp + (sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_vref_st(s7_scheme * sc, s7_pointer arg) +{ + return (vector_ref_p_pp + (sc, lookup(sc, cadr(arg)), + t_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_vref_ts(s7_scheme * sc, s7_pointer arg) +{ + return (vector_ref_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + s_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_vref_tu(s7_scheme * sc, s7_pointer arg) +{ + return (vector_ref_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + u_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_vref_ot(s7_scheme * sc, s7_pointer arg) +{ + return (vector_ref_p_pp + (sc, o_lookup(sc, cadr(arg), arg), + t_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_vref_gt(s7_scheme * sc, s7_pointer arg) +{ + return (vector_ref_p_pp + (sc, lookup_global(sc, cadr(arg)), + t_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_string_ref_ss(s7_scheme * sc, s7_pointer arg) +{ + return (string_ref_p_pp + (sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_cons_ss(s7_scheme * sc, s7_pointer arg) +{ + return (cons + (sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_cons_st(s7_scheme * sc, s7_pointer arg) +{ + return (cons + (sc, s_lookup(sc, cadr(arg), arg), + t_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_cons_ts(s7_scheme * sc, s7_pointer arg) +{ + return (cons + (sc, t_lookup(sc, cadr(arg), arg), + lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_cons_tU(s7_scheme * sc, s7_pointer arg) +{ + return (cons + (sc, t_lookup(sc, cadr(arg), arg), + U_lookup(sc, caddr(arg), arg))); +} + +#define fx_c_ss_direct_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, cadr(arg), arg), Lookup2(sc, opt2_sym(cdr(arg)), arg))); \ + } + +fx_c_ss_direct_any(fx_c_ss_direct, s_lookup, s_lookup) + fx_c_ss_direct_any(fx_c_ts_direct, t_lookup, s_lookup) + fx_c_ss_direct_any(fx_c_st_direct, s_lookup, t_lookup) + fx_c_ss_direct_any(fx_c_gt_direct, g_lookup, t_lookup) + fx_c_ss_direct_any(fx_c_tU_direct, t_lookup, U_lookup) +static s7_pointer fx_multiply_ss(s7_scheme * sc, s7_pointer arg) +{ + return (multiply_p_pp + (sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_multiply_ts(s7_scheme * sc, s7_pointer arg) +{ + return (multiply_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_multiply_Ts(s7_scheme * sc, s7_pointer arg) +{ + return (multiply_p_pp + (sc, T_lookup(sc, cadr(arg), arg), + lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_multiply_fs(s7_scheme * sc, s7_pointer arg) +{ + return (g_mul_xf(sc, lookup(sc, opt2_sym(cdr(arg))), real(cadr(arg)))); +} + +static s7_pointer fx_multiply_sf(s7_scheme * sc, s7_pointer arg) +{ + return (g_mul_xf(sc, lookup(sc, cadr(arg)), real(opt2_con(cdr(arg))))); +} + +static s7_pointer fx_multiply_tf(s7_scheme * sc, s7_pointer arg) +{ + return (g_mul_xf + (sc, t_lookup(sc, cadr(arg), arg), real(opt2_con(cdr(arg))))); +} + +static s7_pointer fx_multiply_si(s7_scheme * sc, s7_pointer arg) +{ + return (g_mul_xi + (sc, lookup(sc, cadr(arg)), integer(opt2_con(cdr(arg))))); +} + +static s7_pointer fx_multiply_is(s7_scheme * sc, s7_pointer arg) +{ + return (g_mul_xi + (sc, lookup(sc, opt2_sym(cdr(arg))), integer(cadr(arg)))); +} + +static s7_pointer fx_multiply_tu(s7_scheme * sc, s7_pointer arg) +{ + return (multiply_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + u_lookup(sc, caddr(arg), arg))); +} + +static inline s7_pointer fx_sqr_1(s7_scheme * sc, s7_pointer x) +{ + if (is_t_real(x)) + return (make_real(sc, real(x) * real(x))); + +#if WITH_GMP + return (multiply_p_pp(sc, x, x)); +#else + switch (type(x)) { +#if HAVE_OVERFLOW_CHECKS + case T_INTEGER: + { + s7_int val; + if (multiply_overflow(integer(x), integer(x), &val)) { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "integer sqr overflow: (* %" ld64 " %" ld64 + ")\n", integer(x), integer(x)); + return (make_real + (sc, + (long_double) integer(x) * + (long_double) integer(x))); + } + return (make_integer(sc, val)); + } + case T_RATIO: + { + s7_int num, den; + if ((multiply_overflow(numerator(x), numerator(x), &num)) || + (multiply_overflow(denominator(x), denominator(x), &den))) + return (make_real(sc, fraction(x) * fraction(x))); + return (s7_make_ratio(sc, num, den)); + } +#else + case T_INTEGER: + return (make_integer(sc, integer(x) * integer(x))); + case T_RATIO: + return (make_ratio + (sc, numerator(x) * numerator(x), + denominator(x) * denominator(x))); +#endif + case T_REAL: + return (make_real(sc, real(x) * real(x))); + case T_COMPLEX: + return (s7_make_complex + (sc, + real_part(x) * real_part(x) - imag_part(x) * imag_part(x), + 2.0 * real_part(x) * imag_part(x))); + default: + return (method_or_bust_with_type_pp + (sc, x, sc->multiply_symbol, x, x, a_number_string, 1)); + } + return (x); +#endif +} + +static s7_pointer fx_sqr_s(s7_scheme * sc, s7_pointer arg) +{ + return (fx_sqr_1(sc, lookup(sc, cadr(arg)))); +} + +static s7_pointer fx_sqr_t(s7_scheme * sc, s7_pointer arg) +{ + return (fx_sqr_1(sc, t_lookup(sc, cadr(arg), arg))); +} + +static s7_pointer fx_add_sqr_sqr(s7_scheme * sc, s7_pointer arg) +{ /* tbig -- need t case here */ + sc->u = fx_sqr_1(sc, lookup(sc, car(opt1_pair(cdr(arg))))); /* cadadr(arg) */ + return (add_p_pp(sc, sc->u, fx_sqr_1(sc, lookup(sc, car(opt3_pair(arg)))))); /* cadaddr(arg) */ +} + +static s7_pointer fx_c_s_sqr(s7_scheme * sc, s7_pointer arg) +{ /* call */ + set_car(sc->t2_1, lookup(sc, cadr(arg))); + set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, opt2_sym(cdr(arg))))); /* cadaddr(arg) */ + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_c_sqr(s7_scheme * sc, s7_pointer arg) +{ /* fb */ + set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, opt1_sym(cdr(arg))))); /* cadaddr(arg) */ + set_car(sc->t2_1, cadr(arg)); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_geq_ss(s7_scheme * sc, s7_pointer arg) +{ + return (geq_p_pp + (sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_geq_ts(s7_scheme * sc, s7_pointer arg) +{ + return (geq_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_geq_st(s7_scheme * sc, s7_pointer arg) +{ + return (geq_p_pp + (sc, lookup(sc, cadr(arg)), + t_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_geq_us(s7_scheme * sc, s7_pointer arg) +{ + return (geq_p_pp + (sc, u_lookup(sc, cadr(arg), arg), + lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_geq_vs(s7_scheme * sc, s7_pointer arg) +{ + return (geq_p_pp + (sc, v_lookup(sc, cadr(arg), arg), + lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_geq_tT(s7_scheme * sc, s7_pointer arg) +{ + return (geq_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + T_lookup(sc, caddr(arg), arg))); +} + +static s7_pointer fx_geq_tu(s7_scheme * sc, s7_pointer arg) +{ + return (geq_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + u_lookup(sc, caddr(arg), arg))); +} + +static s7_pointer fx_geq_to(s7_scheme * sc, s7_pointer arg) +{ + return (geq_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + o_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_geq_ot(s7_scheme * sc, s7_pointer arg) +{ + return (geq_p_pp + (sc, o_lookup(sc, cadr(arg), arg), + t_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_gt_ss(s7_scheme * sc, s7_pointer arg) +{ + return (gt_p_pp + (sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_gt_ts(s7_scheme * sc, s7_pointer arg) +{ + return (gt_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_gt_to(s7_scheme * sc, s7_pointer arg) +{ + return (gt_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + o_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_gt_tu(s7_scheme * sc, s7_pointer arg) +{ + return (gt_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + u_lookup(sc, caddr(arg), arg))); +} + +static s7_pointer fx_gt_ut(s7_scheme * sc, s7_pointer arg) +{ + return (gt_p_pp + (sc, u_lookup(sc, cadr(arg), arg), + t_lookup(sc, caddr(arg), arg))); +} + +static s7_pointer fx_gt_tg(s7_scheme * sc, s7_pointer arg) +{ + return (gt_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + global_value(opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_gt_tT(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p1, p2; + p1 = t_lookup(sc, cadr(arg), arg); + p2 = T_lookup(sc, caddr(arg), arg); + return (((is_t_integer(p1)) + && (is_t_integer(p2))) ? make_boolean(sc, + integer(p1) > + integer(p2)) : + gt_p_pp(sc, p1, p2)); +} + +static s7_pointer fx_gt_si(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = lookup(sc, cadr(arg)); + if (is_t_integer(x)) + return (make_boolean + (sc, integer(x) > integer(opt2_con(cdr(arg))))); + if (is_t_real(x)) + return (make_boolean(sc, real(x) > integer(opt2_con(cdr(arg))))); + return (g_greater_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ +} + +static s7_pointer fx_gt_ti(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = t_lookup(sc, cadr(arg), arg); + if (is_t_integer(x)) + return (make_boolean + (sc, integer(x) > integer(opt2_con(cdr(arg))))); + return (g_greater_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ +} + +static s7_pointer fx_leq_ss(s7_scheme * sc, s7_pointer arg) +{ + return (leq_p_pp + (sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_leq_ts(s7_scheme * sc, s7_pointer arg) +{ + return (leq_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_leq_tu(s7_scheme * sc, s7_pointer arg) +{ + return (leq_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + u_lookup(sc, caddr(arg), arg))); +} + +static s7_pointer fx_leq_si(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = lookup(sc, cadr(arg)); + if (is_t_integer(x)) + return (make_boolean + (sc, integer(x) <= integer(opt2_con(cdr(arg))))); + return (g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ +} + +static s7_pointer fx_leq_ti(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = t_lookup(sc, cadr(arg), arg); + if (is_t_integer(x)) + return (make_boolean + (sc, integer(x) <= integer(opt2_con(cdr(arg))))); + return (g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ +} + +static s7_pointer fx_lt_ss(s7_scheme * sc, s7_pointer arg) +{ + return (lt_p_pp + (sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_lt_sg(s7_scheme * sc, s7_pointer arg) +{ + return (lt_p_pp + (sc, lookup(sc, cadr(arg)), + lookup_global(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_lt_tg(s7_scheme * sc, s7_pointer arg) +{ + return (lt_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + lookup_global(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_lt_gsg(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer v1, v2, v3; + v1 = lookup_global(sc, cadr(arg)); + v2 = lookup(sc, opt1_sym(cdr(arg))); /* caddr(arg) */ + v3 = lookup_global(sc, opt2_sym(cdr(arg))); /* cadddr(arg) */ + if ((is_t_integer(v1)) && (is_t_integer(v2)) && (is_t_integer(v3))) + return (make_boolean(sc, ((v1 < v2) && (v2 < v3)))); + if (!is_real(v3)) + wrong_type_argument(sc, sc->lt_symbol, 3, v3, T_REAL); /* else (< 2 1 1+i) returns #f */ + return (make_boolean + (sc, (lt_b_7pp(sc, v1, v2)) && (lt_b_7pp(sc, v2, v3)))); +} + +static s7_pointer fx_lt_ts(s7_scheme * sc, s7_pointer arg) +{ + return (lt_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_lt_tT(s7_scheme * sc, s7_pointer arg) +{ + return (lt_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + T_lookup(sc, opt2_sym(cdr(arg)), cadr(arg)))); +} + +static s7_pointer fx_lt_tu(s7_scheme * sc, s7_pointer arg) +{ + return (lt_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + u_lookup(sc, caddr(arg), arg))); +} + +static s7_pointer fx_lt_tU(s7_scheme * sc, s7_pointer arg) +{ + return (lt_p_pp + (sc, t_lookup(sc, cadr(arg), arg), + U_lookup(sc, caddr(arg), arg))); +} + +static s7_pointer fx_lt_ut(s7_scheme * sc, s7_pointer arg) +{ + return (lt_p_pp + (sc, u_lookup(sc, cadr(arg), arg), + t_lookup(sc, caddr(arg), arg))); +} + +static s7_pointer fx_lt_tf(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = t_lookup(sc, cadr(arg), arg); + if (is_t_real(x)) + return (make_boolean(sc, real(x) < real(opt2_con(cdr(arg))))); + return (g_less_xf(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ +} + +#define fx_lt_si_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x; \ + x = Lookup(sc, cadr(arg), arg); \ + if (is_t_integer(x)) return(make_boolean(sc, integer(x) < integer(opt2_con(cdr(arg))))); \ + return(g_less_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ + } + +fx_lt_si_any(fx_lt_si, s_lookup) + fx_lt_si_any(fx_lt_ti, t_lookup) +static s7_pointer fx_lt_t0(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = t_lookup(sc, cadr(arg), arg); + if (is_t_integer(x)) + return (make_boolean(sc, integer(x) < 0)); + return (g_less_xi(sc, set_plist_2(sc, x, int_zero))); +} + +static s7_pointer fx_lt_t1(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = t_lookup(sc, cadr(arg), arg); + if (is_t_integer(x)) + return (make_boolean(sc, integer(x) < 1)); + return (g_less_xi(sc, set_plist_2(sc, x, int_one))); +} + +static s7_pointer fx_lt_t2(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = t_lookup(sc, cadr(arg), arg); + if (is_t_integer(x)) + return (make_boolean(sc, integer(x) < 2)); + return (g_less_xi(sc, set_plist_2(sc, x, int_two))); +} + +static s7_pointer fx_geq_tf(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = t_lookup(sc, cadr(arg), arg); + if (is_t_real(x)) + return (make_boolean(sc, real(x) >= real(opt2_con(cdr(arg))))); + return (g_geq_xf(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ +} + +#define fx_geq_si_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x; \ + x = Lookup(sc, cadr(arg), arg); \ + if (is_t_integer(x)) return(make_boolean(sc, integer(x) >= integer(opt2_con(cdr(arg))))); \ + return(g_geq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ + } + +fx_geq_si_any(fx_geq_si, s_lookup) + fx_geq_si_any(fx_geq_ti, t_lookup) +static s7_pointer fx_geq_t0(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = t_lookup(sc, cadr(arg), arg); + if (is_t_integer(x)) + return (make_boolean(sc, integer(x) >= 0)); + return (g_geq_xi(sc, set_plist_2(sc, x, int_zero))); +} + +#define fx_num_eq_ss_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x, y; \ + x = Lookup1(sc, cadr(arg), arg); \ + y = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ + return(make_boolean(sc, ((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) == integer(y)) : num_eq_b_7pp(sc, x, y))); \ + } + +fx_num_eq_ss_any(fx_num_eq_ss, s_lookup, s_lookup) + fx_num_eq_ss_any(fx_num_eq_ts, t_lookup, s_lookup) + fx_num_eq_ss_any(fx_num_eq_to, t_lookup, o_lookup) + fx_num_eq_ss_any(fx_num_eq_tO, t_lookup, O_lookup) + fx_num_eq_ss_any(fx_num_eq_tg, t_lookup, g_lookup) + fx_num_eq_ss_any(fx_num_eq_tT, t_lookup, T_lookup) + fx_num_eq_ss_any(fx_num_eq_tu, t_lookup, u_lookup) + fx_num_eq_ss_any(fx_num_eq_ut, u_lookup, t_lookup) + fx_num_eq_ss_any(fx_num_eq_us, u_lookup, s_lookup) + fx_num_eq_ss_any(fx_num_eq_vs, v_lookup, s_lookup) +#define fx_is_eq_ss_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x, y; \ + x = Lookup1(sc, cadr(arg), arg); \ + y = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ + return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y))))); \ + } + fx_is_eq_ss_any(fx_is_eq_ss, s_lookup, s_lookup) + fx_is_eq_ss_any(fx_is_eq_ts, t_lookup, s_lookup) + fx_is_eq_ss_any(fx_is_eq_tu, t_lookup, u_lookup) + fx_is_eq_ss_any(fx_is_eq_to, t_lookup, o_lookup) +static s7_pointer fx_not_is_eq_ss(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x, y; + x = lookup(sc, opt3_sym(arg)); + y = lookup(sc, opt1_sym(cdr(arg))); + return (make_boolean(sc, (x != y) + && ((!is_unspecified(x)) + || (!is_unspecified(y))))); +} + +static s7_pointer fx_not_is_eq_sq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x, y = opt3_con(cdr(arg)); + x = lookup(sc, opt2_sym(cdr(arg))); + return (make_boolean(sc, (x != y) + && ((!is_unspecified(x)) + || (!is_unspecified(y))))); +} + +static s7_pointer x_hash_table_ref_ss(s7_scheme * sc, s7_pointer table, + s7_pointer key) +{ + return ((is_hash_table(table)) ? + hash_entry_value((*hash_table_checker(table)) (sc, table, key)) + : g_hash_table_ref(sc, set_plist_2(sc, table, key))); +} + +static s7_pointer fx_hash_table_ref_ss(s7_scheme * sc, s7_pointer arg) +{ + return (x_hash_table_ref_ss + (sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg))))); +} + +static s7_pointer fx_hash_table_ref_st(s7_scheme * sc, s7_pointer arg) +{ + return (x_hash_table_ref_ss + (sc, lookup(sc, cadr(arg)), + t_lookup(sc, opt2_sym(cdr(arg)), arg))); +} + +static s7_pointer fx_hash_table_ref_car(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer table, lst; + table = lookup(sc, cadr(arg)); + lst = lookup(sc, opt2_sym(cdr(arg))); + if (!is_pair(lst)) + return (simple_wrong_type_argument + (sc, sc->car_symbol, lst, T_PAIR)); + return ((is_hash_table(table)) ? + hash_entry_value((*hash_table_checker(table)) + (sc, table, car(lst))) : g_hash_table_ref(sc, + set_plist_2 + (sc, + table, + car + (lst)))); +} + +static inline s7_pointer fx_hash_table_increment_1(s7_scheme * sc, + s7_pointer table, + s7_pointer key, + s7_pointer arg) +{ + hash_entry_t *val; + if (!is_hash_table(table)) + return (mutable_method_or_bust_ppp + (sc, table, sc->hash_table_set_symbol, table, key, + fx_call(sc, cdddr(arg)), T_HASH_TABLE, 1)); + val = (*hash_table_checker(table)) (sc, table, key); + if (val != sc->unentry) { + if (!is_t_integer(hash_entry_value(val))) + simple_wrong_type_argument(sc, sc->add_symbol, cadddr(arg), + T_INTEGER); + hash_entry_set_value(val, + make_integer(sc, + integer(hash_entry_value(val)) + + 1)); + return (hash_entry_value(val)); + } + s7_hash_table_set(sc, table, key, int_one); + return (int_one); +} + +static s7_pointer fx_hash_table_increment(s7_scheme * sc, s7_pointer arg) +{ + return (fx_hash_table_increment_1 + (sc, lookup(sc, cadr(arg)), lookup(sc, caddr(arg)), arg)); +} + +static s7_pointer fx_lint_let_ref_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer lt, sym, y; + lt = cdr(s_lookup(sc, opt2_sym(arg), arg)); /* (var-ref local-var) -> local-var, opt_sym2(arg) == cadr(arg) */ + if (!is_let(lt)) + return (wrong_type_argument_with_type + (sc, sc->let_ref_symbol, 1, lt, a_let_string)); + sym = opt2_sym(cdr(arg)); /* (let-ref (cdr v) 'ref) -> ref == opt3_sym(cdar(closure_body(opt1_lambda(arg)))); */ + for (y = let_slots(lt); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == sym) + return (slot_value(y)); + return (lint_let_ref_p_pp(sc, let_outlet(lt), sym)); +} + +static s7_pointer fx_memq_sq_2(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer obj, p = opt2_con(cdr(arg)); + obj = lookup(sc, cadr(arg)); + if (obj == car(p)) + return (p); + return ((obj == cadr(p)) ? cdr(p) : sc->F); +} + +static s7_pointer fx_c_cq(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t2_1, cadr(arg)); + set_car(sc->t2_2, opt2_con(cdr(arg))); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +#define fx_c_sss_any(Name, Lookup1, Lookup2, Lookup3) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \ + set_car(sc->t3_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \ + set_car(sc->t3_3, Lookup3(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \ + return(fn_proc(arg)(sc, sc->t3_1)); \ + } + +fx_c_sss_any(fx_c_sss, s_lookup, s_lookup, s_lookup) + fx_c_sss_any(fx_c_sts, s_lookup, t_lookup, s_lookup) + fx_c_sss_any(fx_c_tus, t_lookup, u_lookup, s_lookup) + fx_c_sss_any(fx_c_tuv, t_lookup, u_lookup, v_lookup) +static s7_pointer fx_c_sss_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_ppp_t) opt3_direct(cdr(arg))) (sc, + lookup(sc, cadr(arg)), + lookup(sc, + opt1_sym(cdr + (arg))), + lookup(sc, + opt2_sym(cdr + (arg))))); +} + +static s7_pointer fx_vset_sts(s7_scheme * sc, s7_pointer arg) +{ + return (vector_set_p_ppp + (sc, lookup(sc, cadr(arg)), + t_lookup(sc, opt1_sym(cdr(arg)), arg), lookup(sc, + opt2_sym(cdr + (arg))))); +} + +static s7_pointer fx_vset_oto(s7_scheme * sc, s7_pointer arg) +{ + return (vector_set_p_ppp + (sc, o_lookup(sc, cadr(arg), arg), + t_lookup(sc, opt1_sym(cdr(arg)), arg), o_lookup(sc, + opt2_sym(cdr + (arg)), + arg))); +} + +#define fx_c_scs_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \ + set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \ + set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) */ \ + return(fn_proc(arg)(sc, sc->t3_1)); \ + } + +fx_c_scs_any(fx_c_scs, s_lookup, s_lookup) + fx_c_scs_any(fx_c_tcs, t_lookup, s_lookup) +#define fx_c_scs_direct_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, cadr(arg), arg), opt1_con(cdr(arg)), Lookup2(sc, opt2_sym(cdr(arg)), arg))); \ + } + fx_c_scs_direct_any(fx_c_scs_direct, s_lookup, s_lookup) + fx_c_scs_direct_any(fx_c_tcu_direct, t_lookup, u_lookup) + fx_c_scs_direct_any(fx_c_tcs_direct, t_lookup, s_lookup) + fx_c_scs_direct_any(fx_c_TcU_direct, T_lookup, U_lookup) +static s7_pointer fx_c_scc(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_1, lookup(sc, cadr(arg))); + set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) */ + set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */ + return (fn_proc(arg) (sc, sc->t3_1)); +} + +#define fx_c_css_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t3_2, Lookup1(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \ + set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \ + set_car(sc->t3_1, cadr(arg)); \ + return(fn_proc(arg)(sc, sc->t3_1)); \ + } + +fx_c_css_any(fx_c_css, s_lookup, s_lookup) + fx_c_css_any(fx_c_ctv, t_lookup, v_lookup) +static s7_pointer fx_c_csc(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_2, lookup(sc, opt1_sym(cdr(arg)))); /* caddr(arg) */ + set_car(sc->t3_1, opt3_con(cdr(arg))); /* cadr(arg) or maybe cadadr if quoted? */ + set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */ + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_ccs(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_3, lookup(sc, opt1_sym(cdr(arg)))); /* cadddr(arg) */ + set_car(sc->t3_1, cadr(arg)); /* maybe opt3_con? */ + set_car(sc->t3_2, opt2_con(cdr(arg))); /* caddr(arg) */ + return (fn_proc(arg) (sc, sc->t3_1)); +} + +#define fx_c_ssc_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \ + set_car(sc->t3_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \ + set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */ \ + return(fn_proc(arg)(sc, sc->t3_1)); \ + } + +fx_c_ssc_any(fx_c_ssc, s_lookup, s_lookup) + fx_c_ssc_any(fx_c_tuc, t_lookup, u_lookup) +static s7_pointer fx_c_opncq(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t1_1, fc_call(sc, cadr(arg))); + return (fn_proc(arg) (sc, sc->t1_1)); +} + +#define fx_c_opsq_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer largs = cadr(arg); \ + set_car(sc->t1_1, Lookup(sc, cadr(largs), largs)); \ + set_car(sc->t1_1, fn_proc(largs)(sc, sc->t1_1)); \ + return(fn_proc(arg)(sc, sc->t1_1)); \ + } + +fx_c_opsq_any(fx_c_opsq, s_lookup) + fx_c_opsq_any(fx_c_optq, t_lookup) +static s7_pointer fx_c_optq_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_p_t) opt2_direct(cdr(arg))) (sc, ((s7_p_p_t) + opt3_direct(cdr(arg))) + (sc, + t_lookup(sc, + opt1_sym(cdr + (arg)), + arg)))); +} + +#define fx_c_car_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer val; \ + val = Lookup(sc, opt2_sym(cdr(arg)), arg); \ + set_car(sc->t1_1, (is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \ + return(fn_proc(arg)(sc, sc->t1_1)); \ + } + +fx_c_car_s_any(fx_c_car_s, s_lookup) + fx_c_car_s_any(fx_c_car_t, t_lookup) + fx_c_car_s_any(fx_c_car_u, u_lookup) +#define fx_c_cdr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer val; \ + val = Lookup(sc, opt2_sym(cdr(arg)), arg); \ + set_car(sc->t1_1, (is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val))); \ + return(fn_proc(arg)(sc, sc->t1_1)); \ + } + fx_c_cdr_s_any(fx_c_cdr_s, s_lookup) + fx_c_cdr_s_any(fx_c_cdr_t, t_lookup) +#define fx_is_type_opsq_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t1_1, Lookup(sc, opt2_sym(cdr(arg)), arg)); \ + return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(fn_proc(cadr(arg))(sc, sc->t1_1)))); \ + } + fx_is_type_opsq_any(fx_is_type_opsq, s_lookup) + fx_is_type_opsq_any(fx_is_type_optq, t_lookup) +static s7_pointer fx_is_type_car_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer val; + val = lookup(sc, opt2_sym(cdr(arg))); + return (make_boolean(sc, (is_pair(val)) ? + ((uint8_t) (opt3_byte(cdr(arg))) == + type(car(val))) + : ((uint8_t) (opt3_byte(cdr(arg))) == + type(g_car(sc, set_plist_1(sc, val)))))); +} + +static s7_pointer fx_is_type_car_t(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer val; + val = t_lookup(sc, opt2_sym(cdr(arg)), arg); + if (is_pair(val)) + return (make_boolean + (sc, (uint8_t) (opt3_byte(cdr(arg))) == type(car(val)))); + if (has_active_methods(sc, val)) { /* this verbosity saves 1/3 total compute time (overhead!) */ + s7_pointer func; + func = find_method_with_let(sc, val, sc->car_symbol); + if (func != sc->undefined) + return (make_boolean + (sc, + type(call_method(sc, val, func, set_plist_1(sc, val))) + == (uint8_t) opt3_byte(cdr(arg)))); + } + return (wrong_type_argument(sc, sc->car_symbol, 1, val, T_PAIR)); +} + +static s7_pointer fx_eq_weak1_type_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer val; + val = lookup(sc, opt2_sym(cdr(arg))); + if (is_c_pointer(val)) /* (let? (c-pointer-weak1 val)) etc */ + return (make_boolean + (sc, + (uint8_t) (opt3_byte(cdr(arg))) == + type(c_pointer_weak1(val)))); + if (has_active_methods(sc, val)) { /* calling g_c_pointer_weak1 here instead is much slower, error by itself is much faster! splitting out does not help */ + s7_pointer func; + func = find_method_with_let(sc, val, sc->c_pointer_weak1_symbol); + if (func != sc->undefined) + return (make_boolean + (sc, + type(call_method(sc, val, func, set_plist_1(sc, val))) + == (uint8_t) opt3_byte(cdr(arg)))); + } + return (wrong_type_argument + (sc, sc->c_pointer_weak1_symbol, 1, val, T_C_POINTER)); +} + +static s7_pointer fx_not_opsq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cadr(arg); + set_car(sc->t1_1, lookup(sc, cadr(largs))); + return ((fn_proc(largs) (sc, sc->t1_1) == sc->F) ? sc->T : sc->F); +} + +#define fx_c_opssq_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t2_1, Lookup1(sc, opt3_sym(arg), arg)); \ + set_car(sc->t2_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* or opt2_sym */ \ + set_car(sc->t1_1, fn_proc(cadr(arg))(sc, sc->t2_1)); \ + return(fn_proc(arg)(sc, sc->t1_1)); \ + } + +fx_c_opssq_any(fx_c_opssq, s_lookup, s_lookup) + fx_c_opssq_any(fx_c_optuq, t_lookup, u_lookup) + fx_c_opssq_any(fx_c_opstq, s_lookup, t_lookup) +#define fx_c_opssq_direct_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, opt3_sym(arg), arg), Lookup2(sc, opt1_sym(cdr(arg)), arg)))); \ + } + fx_c_opssq_direct_any(fx_c_opssq_direct, s_lookup, s_lookup) + fx_c_opssq_direct_any(fx_c_opstq_direct, s_lookup, t_lookup) + fx_c_opssq_direct_any(fx_c_optuq_direct, t_lookup, u_lookup) +#define fx_not_opssq_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer larg = cadr(arg); \ + set_car(sc->t2_1, Lookup1(sc, cadr(larg), larg)); \ + set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(larg)), larg)); \ + return((fn_proc(larg)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); \ + } + fx_not_opssq_any(fx_not_opssq, s_lookup, s_lookup) + fx_not_opssq_any(fx_not_oputq, u_lookup, t_lookup) +static s7_pointer fx_not_lt_ut(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x, y; + y = u_lookup(sc, opt3_sym(arg), arg); + x = t_lookup(sc, opt1_sym(cdr(arg)), arg); + return (make_boolean(sc, ((is_t_integer(x)) + && (is_t_integer(y))) ? (integer(y) >= + integer(x)) : + geq_b_7pp(sc, y, x))); +} + +static s7_pointer fx_is_zero_remainder_car(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer u, t; + u = u_lookup(sc, opt3_sym(arg), arg); + u = (is_pair(u)) ? car(u) : g_car(sc, set_plist_1(sc, u)); /* g_car much less overhead than car_p_p or simple_error(?) */ + t = t_lookup(sc, opt1_sym(cdr(arg)), arg); + if ((is_t_integer(u)) && (is_t_integer(t))) + return (make_boolean + (sc, remainder_i_7ii(sc, integer(u), integer(t)) == 0)); + return (make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, u, t)))); +} + +static s7_pointer fx_is_zero_remainder_o(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer s, t; + s = o_lookup(sc, opt3_sym(arg), arg); + t = t_lookup(sc, opt1_sym(cdr(arg)), arg); + if ((is_t_integer(s)) && (is_t_integer(t))) + return (make_boolean + (sc, remainder_i_7ii(sc, integer(s), integer(t)) == 0)); + return (make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, s, t)))); +} + +#define fx_c_opscq_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer largs = cadr(arg); \ + set_car(sc->t2_1, Lookup(sc, cadr(largs), largs)); \ + set_car(sc->t2_2, opt2_con(cdr(largs))); \ + set_car(sc->t1_1, fn_proc(largs)(sc, sc->t2_1)); \ + return(fn_proc(arg)(sc, sc->t1_1)); \ + } + +fx_c_opscq_any(fx_c_opscq, s_lookup) + fx_c_opscq_any(fx_c_optcq, t_lookup) +static s7_pointer fx_not_opscq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cadr(arg); + set_car(sc->t2_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, opt2_con(cdr(largs))); + return ((fn_proc(largs) (sc, sc->t2_1) == sc->F) ? sc->T : sc->F); +} + +static s7_pointer fx_c_opcsq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cadr(arg); + set_car(sc->t2_2, lookup(sc, caddr(largs))); + set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ + set_car(sc->t1_1, fn_proc(largs) (sc, sc->t2_1)); + return (fn_proc(arg) (sc, sc->t1_1)); +} + +static s7_pointer fx_c_opcsq_c(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cadr(arg); + set_car(sc->t2_2, lookup(sc, caddr(largs))); + set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ + set_car(sc->t2_1, fn_proc(largs) (sc, sc->t2_1)); + set_car(sc->t2_2, caddr(arg)); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_opcsq_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cadr(arg); + set_car(sc->t2_2, lookup(sc, caddr(largs))); + set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ + set_car(sc->t2_1, fn_proc(largs) (sc, sc->t2_1)); + set_car(sc->t2_2, lookup(sc, caddr(arg))); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_opssq_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cadr(arg); + set_car(sc->t2_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); + set_car(sc->t2_1, fn_proc(largs) (sc, sc->t2_1)); + set_car(sc->t2_2, lookup(sc, caddr(arg))); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_opssq_s_direct(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */ + return (((s7_p_pp_t) opt2_direct(cdr(arg))) (sc, ((s7_p_pp_t) + opt3_direct(cdr + (arg))) + (sc, + lookup(sc, car(largs)), + lookup(sc, + opt2_sym(largs))), + lookup(sc, caddr(arg)))); +} + +static s7_pointer fx_add_mul_opssq_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = opt3_pair(arg), a, b, c; /* cdadr(arg) */ + a = lookup(sc, car(largs)); + b = lookup(sc, opt2_sym(largs)); + c = lookup(sc, caddr(arg)); + if ((is_t_integer(a)) && (is_t_integer(b)) && (is_t_integer(c))) +#if HAVE_OVERFLOW_CHECKS + { + s7_int val; + if ((multiply_overflow(integer(a), integer(b), &val)) || + (add_overflow(val, integer(c), &val))) { + if (WITH_WARNINGS) + s7_warn(sc, 128, + "integer multiply/add overflow: (+ (* %" ld64 " %" + ld64 ") %" ld64 ")\n", integer(a), integer(b), + integer(c)); + return (make_real + (sc, + ((long_double) integer(a) * + (long_double) integer(b)) + + (long_double) integer(c))); + } + return (make_integer(sc, val)); + } +#else + return (make_integer(sc, (integer(a) * integer(b)) + integer(c))); +#endif + return (add_p_pp(sc, multiply_p_pp(sc, a, b), c)); +} + +static s7_pointer fx_add_vref_s(s7_scheme * sc, s7_pointer arg) +{ + return (add_p_pp + (sc, + vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), + lookup(sc, opt2_sym(opt3_pair(arg)))), + lookup(sc, caddr(arg)))); +} + +static s7_pointer fx_add_s_vref(s7_scheme * sc, s7_pointer arg) +{ + return (add_p_pp + (sc, lookup(sc, cadr(arg)), + vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), + lookup(sc, opt2_sym(opt3_pair(arg)))))); +} + +static s7_pointer fx_subtract_vref_s(s7_scheme * sc, s7_pointer arg) +{ + return (subtract_p_pp + (sc, + vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), + lookup(sc, opt2_sym(opt3_pair(arg)))), + lookup(sc, caddr(arg)))); +} + +static s7_pointer fx_subtract_s_vref(s7_scheme * sc, s7_pointer arg) +{ + return (subtract_p_pp + (sc, lookup(sc, cadr(arg)), + vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), + lookup(sc, opt2_sym(opt3_pair(arg)))))); +} + +static s7_pointer fx_multiply_s_vref(s7_scheme * sc, s7_pointer arg) +{ + return (multiply_p_pp + (sc, lookup(sc, cadr(arg)), + vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), + lookup(sc, opt2_sym(opt3_pair(arg)))))); +} + +static s7_pointer fx_cons_cons_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */ + return (cons_unchecked + (sc, + cons(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), + lookup(sc, caddr(arg)))); +} + +#define fx_add_sqr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p1, p3; \ + p1 = Lookup(sc, car(opt3_pair(arg)), arg); \ + p3 = lookup(sc, caddr(arg)); \ + if ((is_t_complex(p1)) && (is_t_complex(p3))) \ + { \ + s7_double r = real_part(p1), i = imag_part(p1); \ + return(make_complex(sc, real_part(p3) + r * r - i * i, imag_part(p3) + 2.0 * r * i)); \ + } \ + return(add_p_pp(sc, fx_sqr_1(sc, p1), p3)); \ + } + +fx_add_sqr_s_any(fx_add_sqr_s, s_lookup) + fx_add_sqr_s_any(fx_add_sqr_T, T_lookup) +static s7_pointer fx_add_sub_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p1, p2, p3, largs = opt3_pair(arg); /* cdadr(arg) */ + p1 = lookup(sc, car(largs)); + p2 = lookup(sc, opt2_sym(largs)); + p3 = lookup(sc, caddr(arg)); + if ((is_t_real(p1)) && (is_t_real(p2)) && (is_t_real(p3))) + return (make_real(sc, real(p3) + real(p1) - real(p2))); + return (add_p_pp(sc, subtract_p_pp(sc, p1, p2), p3)); +} + +static s7_pointer fx_gt_add_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x1, x2, x3, largs = opt3_pair(arg); /* cdadr(arg) */ + x1 = lookup(sc, car(largs)); + x2 = lookup(sc, opt2_sym(largs)); + x3 = lookup(sc, caddr(arg)); + if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3))) + return (make_boolean(sc, (real(x1) + real(x2)) > real(x3))); + return (gt_p_pp(sc, add_p_pp(sc, x1, x2), x3)); +} + +static s7_pointer fx_gt_vref_s(s7_scheme * sc, s7_pointer arg) +{ + return (gt_p_pp + (sc, + vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), + lookup(sc, opt2_sym(opt3_pair(arg)))), + lookup(sc, caddr(arg)))); +} + +static s7_pointer fx_geq_s_vref(s7_scheme * sc, s7_pointer arg) +{ + return (geq_p_pp + (sc, lookup(sc, cadr(arg)), + vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), + lookup(sc, opt2_sym(opt3_pair(arg)))))); +} + +static s7_pointer fx_is_eq_s_vref(s7_scheme * sc, s7_pointer arg) +{ + return (make_boolean + (sc, + lookup(sc, cadr(arg)) == vector_ref_p_pp(sc, + lookup(sc, + car(opt3_pair + (arg))), + lookup(sc, + opt2_sym + (opt3_pair + (arg)))))); +} + +static s7_pointer fx_href_s_vref(s7_scheme * sc, s7_pointer arg) +{ + return (hash_table_ref_p_pp + (sc, lookup(sc, cadr(arg)), + vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), + lookup(sc, opt2_sym(opt3_pair(arg)))))); +} + +static s7_pointer fx_lref_s_vref(s7_scheme * sc, s7_pointer arg) +{ + return (s7_let_ref + (sc, lookup(sc, cadr(arg)), + vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), + lookup(sc, opt2_sym(opt3_pair(arg)))))); +} + +static s7_pointer fx_vref_s_add(s7_scheme * sc, s7_pointer arg) +{ + return (vector_ref_p_pp + (sc, lookup(sc, cadr(arg)), + add_p_pp(sc, lookup(sc, car(opt3_pair(arg))), + lookup(sc, opt2_sym(opt3_pair(arg)))))); +} + +static inline s7_pointer fx_vref_vref_3(s7_scheme * sc, s7_pointer v1, + s7_pointer p1, s7_pointer p2) +{ + if ((is_t_integer(p1)) && (is_t_integer(p2)) + && ((is_normal_vector(v1)) && (vector_rank(v1) == 1))) { + s7_int i1 = integer(p1), i2 = integer(p2); + if ((i1 >= 0) && (i2 >= 0) && (i1 < vector_length(v1))) { + s7_pointer v2 = vector_element(v1, i1); + if ((is_normal_vector(v2)) && (vector_rank(v2) == 1) + && (i2 < vector_length(v2))) + return (vector_element(v2, i2)); + } + } + return (vector_ref_p_pp(sc, vector_ref_p_pp(sc, v1, p1), p2)); +} + +#define fx_vref_vref_ss_s_any(Name, Lookup1, Lookup2, Lookup3) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + return(fx_vref_vref_3(sc, Lookup1(sc, car(opt3_pair(arg)), arg), Lookup2(sc, opt2_sym(opt3_pair(arg)), arg), Lookup3(sc, caddr(arg), arg))); \ + } + +fx_vref_vref_ss_s_any(fx_vref_vref_ss_s, s_lookup, s_lookup, s_lookup) + fx_vref_vref_ss_s_any(fx_vref_vref_gs_t, g_lookup, s_lookup, t_lookup) + fx_vref_vref_ss_s_any(fx_vref_vref_go_t, g_lookup, o_lookup, t_lookup) + fx_vref_vref_ss_s_any(fx_vref_vref_tu_v, t_lookup, u_lookup, v_lookup) +static s7_pointer fx_vref_vref_3_no_let(s7_scheme * sc, s7_pointer code) +{ /* out one level from vref_vref_tu_v */ + return (fx_vref_vref_3 + (sc, lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), + lookup(sc, opt3_sym(code)))); +} + +static s7_pointer fx_c_opscq_c(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cadr(arg); + set_car(sc->t2_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, opt2_con(cdr(largs))); + set_car(sc->t2_1, fn_proc(largs) (sc, sc->t2_1)); + set_car(sc->t2_2, caddr(arg)); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +#define fx_c_opssq_c_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer largs = cadr(arg); \ + set_car(sc->t2_1, Lookup1(sc, cadr(largs), largs)); \ + set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(largs)), largs)); \ + set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); \ + set_car(sc->t2_2, opt3_con(cdr(arg))); /* caddr */ \ + return(fn_proc(arg)(sc, sc->t2_1)); \ + } + +fx_c_opssq_c_any(fx_c_opssq_c, s_lookup, s_lookup) + fx_c_opssq_c_any(fx_c_opstq_c, s_lookup, t_lookup) +static s7_pointer fx_c_opstq_c_direct(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cadr(arg); + return (((s7_p_pp_t) opt3_direct(arg)) (sc, + fn_proc(largs) (sc, + set_plist_2(sc, + lookup + (sc, + cadr + (largs)), + t_lookup + (sc, + caddr + (largs), + arg))), + opt3_con(cdr(arg)))); +} + +static s7_pointer fx_is_eq_vref_opotq_c(s7_scheme * sc, s7_pointer arg) +{ /* experiment, (eqv? <> char) is <>==char without error checks? */ + s7_pointer largs = cdadr(arg); + return (make_boolean + (sc, + vector_ref_p_pp(sc, o_lookup(sc, car(largs), largs), + t_lookup(sc, cadr(largs), + arg)) == opt3_con(cdr(arg)))); +} + +#define fx_c_opsq_s_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer largs = cadr(arg); \ + set_car(sc->t1_1, Lookup1(sc, cadr(largs), arg)); /* also opt1_sym(cdr(arg)) */ \ + set_car(sc->t2_1, fn_proc(largs)(sc, sc->t1_1)); \ + set_car(sc->t2_2, Lookup2(sc, opt3_sym(arg), arg)); /* caddr(arg) */ \ + return(fn_proc(arg)(sc, sc->t2_1)); \ + } + +fx_c_opsq_s_any(fx_c_opsq_s, s_lookup, s_lookup) + fx_c_opsq_s_any(fx_c_optq_s, t_lookup, s_lookup) + fx_c_opsq_s_any(fx_c_opuq_t, u_lookup, t_lookup) +#define fx_c_opsq_s_direct_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, \ + ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, opt1_sym(cdr(arg)), arg)), \ + Lookup2(sc, opt3_sym(arg), arg))); \ + } + fx_c_opsq_s_direct_any(fx_c_opsq_s_direct, s_lookup, s_lookup) + fx_c_opsq_s_direct_any(fx_c_optq_s_direct, t_lookup, s_lookup) + fx_c_opsq_s_direct_any(fx_c_opuq_t_direct, u_lookup, t_lookup) +#define fx_cons_car_s_s_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p; \ + p = Lookup1(sc, opt1_sym(cdr(arg)), arg); \ + if (is_pair(p)) return(cons(sc, car(p), Lookup2(sc, opt3_sym(arg), arg))); \ + return(cons(sc, car_p_p(sc, p), Lookup2(sc, opt3_sym(arg), arg))); \ + } + fx_cons_car_s_s_any(fx_cons_car_s_s, s_lookup, s_lookup) + fx_cons_car_s_s_any(fx_cons_car_t_s, t_lookup, s_lookup) + fx_cons_car_s_s_any(fx_cons_car_t_v, t_lookup, v_lookup) + fx_cons_car_s_s_any(fx_cons_car_u_t, u_lookup, t_lookup) +static s7_pointer fx_cons_opuq_t(s7_scheme * sc, s7_pointer arg) +{ + return (cons + (sc, + ((s7_p_p_t) opt3_direct(cdr(arg))) (sc, + u_lookup(sc, + opt1_sym(cdr + (arg)), + arg)), + t_lookup(sc, opt3_sym(arg), arg))); +} + +#define fx_c_opsq_cs_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t1_1, Lookup1(sc, opt3_sym(cdr(arg)), arg)); /* cadadr(arg); */ \ + set_car(sc->t3_1, fn_proc(cadr(arg))(sc, sc->t1_1)); \ + set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) or cadaddr(arg) */ \ + set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg); */ \ + return(fn_proc(arg)(sc, sc->t3_1)); \ + } + +fx_c_opsq_cs_any(fx_c_opsq_cs, s_lookup, s_lookup) + fx_c_opsq_cs_any(fx_c_optq_cu, t_lookup, u_lookup) +#define fx_c_opsq_c_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t1_1, Lookup(sc, opt1_sym(cdr(arg)), arg)); /* cadadr */ \ + set_car(sc->t2_1, fn_proc(cadr(arg))(sc, sc->t1_1)); \ + set_car(sc->t2_2, opt2_con(cdr(arg))); \ + return(fn_proc(arg)(sc, sc->t2_1)); \ + } + fx_c_opsq_c_any(fx_c_opsq_c, s_lookup) + fx_c_opsq_c_any(fx_c_optq_c, t_lookup) +static s7_pointer fx_c_optq_c_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pp_t) opt3_direct(arg)) (sc, ((s7_p_p_t) + opt3_direct(cdr(arg))) + (sc, + t_lookup(sc, + opt1_sym(cdr(arg)), + arg)), + opt2_con(cdr(arg)))); +} + +static s7_pointer fx_c_optq_i_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_ii_t) opt3_direct(arg)) (sc, ((s7_i_7p_t) + opt3_direct(cdr(arg))) + (sc, + t_lookup(sc, + opt1_sym(cdr(arg)), + arg)), + integer(opt2_con(cdr(arg))))); +} + +static s7_pointer fx_memq_car_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x, obj; + obj = lookup(sc, opt1_sym(cdr(arg))); + obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj)); + x = opt2_con(cdr(arg)); + while (true) { + LOOP_4(if (obj == car(x)) return (x); x = cdr(x); + if (!is_pair(x)) return (sc->F)); + } + return (sc->F); +} + +static s7_pointer fx_memq_car_s_2(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x, obj; + obj = lookup(sc, opt1_sym(cdr(arg))); + obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj)); + x = opt2_con(cdr(arg)); + if (obj == car(x)) + return (x); + return ((obj == cadr(x)) ? cdr(x) : sc->F); +} + +static s7_pointer fx_c_s_opssq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = caddr(arg); + set_car(sc->t2_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); + set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1)); + set_car(sc->t2_1, lookup(sc, cadr(arg))); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +#define fx_c_s_opssq_direct_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer largs = opt3_pair(arg); /* cdaddr(arg) */ \ + arg = cdr(arg); \ + return(((s7_p_pp_t)opt2_direct(arg))(sc, Lookup1(sc, car(arg), arg), ((s7_p_pp_t)opt3_direct(arg))(sc, lookup(sc, car(largs)), Lookup2(sc, opt2_sym(largs), largs)))); \ + } + +fx_c_s_opssq_direct_any(fx_c_s_opssq_direct, s_lookup, s_lookup) + fx_c_s_opssq_direct_any(fx_c_s_opstq_direct, s_lookup, t_lookup) + fx_c_s_opssq_direct_any(fx_c_t_opsuq_direct, t_lookup, u_lookup) +static s7_pointer fx_vref_g_vref_gs(s7_scheme * sc, s7_pointer arg) +{ + return (vector_ref_p_pp + (sc, lookup_global(sc, cadr(arg)), + vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), + lookup(sc, opt2_sym(opt3_pair(arg)))))); +} + +static s7_pointer fx_vref_g_vref_gt(s7_scheme * sc, s7_pointer arg) +{ + return (vector_ref_p_pp + (sc, lookup_global(sc, cadr(arg)), + vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), + t_lookup(sc, opt2_sym(opt3_pair(arg)), + arg)))); +} + +static s7_pointer fx_c_c_opssq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = caddr(arg); + set_car(sc->t2_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); + set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1)); + set_car(sc->t2_1, cadr(arg)); /* currently ( 'a ) goes to safe_c_ca so this works by inadvertence */ + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_c_opssq_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pp_t) opt2_direct(cdr(arg))) (sc, cadr(arg), /* see above */ + ((s7_p_pp_t) + opt3_direct(cdr(arg))) + (sc, + lookup(sc, + opt3_sym(arg)), + lookup(sc, + opt1_sym(cdr + (arg)))))); +} + +static s7_pointer fx_c_nc_opssq_direct(s7_scheme * sc, s7_pointer arg) +{ /* clm2xen (* 1.0 (oscil g2 x2)) */ + s7_double x2; + x2 = ((s7_d_pd_t) opt3_direct(cdr(arg))) (lookup(sc, opt3_sym(arg)), + real_to_double(sc, + lookup(sc, + opt1_sym + (cdr + (arg))), + "number_to_double")); + return (((s7_p_dd_t) opt2_direct(cdr(arg))) (sc, + real_to_double(sc, + cadr(arg), + "*"), x2)); +} + +static s7_pointer fx_multiply_c_opssq(s7_scheme * sc, s7_pointer arg) +{ /* (* c=float (* x1 x2))! */ + s7_pointer x1, x2; + x1 = lookup(sc, opt3_sym(arg)); + x2 = lookup(sc, opt1_sym(cdr(arg))); + if ((is_t_real(x1)) && (is_t_real(x2))) + return (make_real(sc, real(cadr(arg)) * real(x1) * real(x2))); + return (multiply_p_pp(sc, cadr(arg), multiply_p_pp(sc, x1, x2))); +} + +static s7_pointer fx_c_s_opscq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = caddr(arg); + set_car(sc->t2_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, opt2_con(cdr(largs))); + set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1)); + set_car(sc->t2_1, lookup(sc, cadr(arg))); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_s_opscq_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pp_t) opt2_direct(cdr(arg))) (sc, lookup(sc, cadr(arg)), + ((s7_p_pp_t) + opt3_direct(cdr(arg))) + (sc, + lookup(sc, + opt3_sym(arg)), + opt1_con(cdr(arg))))); +} + +static s7_pointer fx_c_s_opsiq_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pp_t) opt2_direct(cdr(arg))) (sc, lookup(sc, cadr(arg)), + ((s7_p_pi_t) + opt3_direct(cdr(arg))) + (sc, + lookup(sc, + opt3_sym(arg)), + integer(opt1_con + (cdr(arg)))))); +} + +static s7_pointer fx_c_t_opoiq_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pp_t) opt2_direct(cdr(arg))) (sc, + t_lookup(sc, cadr(arg), + arg), + ((s7_p_pi_t) + opt3_direct(cdr(arg))) + (sc, + o_lookup(sc, + opt3_sym(arg), + arg), + integer(opt1_con + (cdr(arg)))))); +} + +static s7_pointer fx_vref_p1(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer v, i; + i = lookup(sc, opt3_sym(arg)); + v = lookup(sc, cadr(arg)); + if ((is_t_integer(i)) && (is_normal_vector(v)) + && (vector_rank(v) == 1)) { + s7_int index = integer(i) + 1; + if ((index >= 0) && (vector_length(v) > index)) + return (vector_element(v, index)); + } + return (vector_ref_p_pp(sc, v, g_add_xi(sc, i, 1))); +} + +static s7_pointer fx_num_eq_add_s_si(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer i1, i2; + i1 = lookup(sc, cadr(arg)); + i2 = lookup(sc, opt3_sym(arg)); + if ((is_t_integer(i1)) && (is_t_integer(i2))) + return (make_boolean + (sc, + integer(i1) == + (integer(i2) + integer(opt1_con(cdr(arg)))))); + return (make_boolean + (sc, + num_eq_b_7pp(sc, i1, + g_add_xi(sc, i2, integer(opt1_con(cdr(arg))))))); +} + +static s7_pointer fx_num_eq_subtract_s_si(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer i1, i2; + i1 = lookup(sc, cadr(arg)); + i2 = lookup(sc, opt3_sym(arg)); + if ((is_t_integer(i1)) && (is_t_integer(i2))) + return (make_boolean + (sc, + integer(i1) == + (integer(i2) - integer(opt1_con(cdr(arg)))))); + return (make_boolean + (sc, + num_eq_b_7pp(sc, i1, + g_sub_xi(sc, i2, integer(opt1_con(cdr(arg))))))); +} + +#define fx_c_t_opscq_direct_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), \ + ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup(sc, opt3_sym(arg), arg), opt1_con(cdr(arg))))); \ + } + +fx_c_t_opscq_direct_any(fx_c_t_opscq_direct, s_lookup) + fx_c_t_opscq_direct_any(fx_c_t_opucq_direct, u_lookup) +static s7_pointer fx_c_s_opsq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = caddr(arg); + set_car(sc->t1_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, fn_proc(largs) (sc, sc->t1_1)); + set_car(sc->t2_1, lookup(sc, cadr(arg))); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +#define fx_c_s_opsq_direct_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + arg = cdr(arg); \ + return(((s7_p_pp_t)opt2_direct(arg))(sc, Lookup1(sc, car(arg), arg), ((s7_p_p_t)opt3_direct(arg))(sc, Lookup2(sc, opt1_sym(arg), arg)))); /* cadadr */ \ + } + +fx_c_s_opsq_direct_any(fx_c_s_opsq_direct, s_lookup, s_lookup) + fx_c_s_opsq_direct_any(fx_c_t_opuq_direct, t_lookup, u_lookup) + fx_c_s_opsq_direct_any(fx_c_u_opvq_direct, u_lookup, v_lookup) +#define fx_c_s_car_s_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer val; \ + val = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ + set_car(sc->t2_2, (is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \ + set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \ + return(fn_proc(arg)(sc, sc->t2_1)); \ + } + fx_c_s_car_s_any(fx_c_s_car_s, s_lookup, s_lookup) + fx_c_s_car_s_any(fx_c_s_car_t, s_lookup, t_lookup) + fx_c_s_car_s_any(fx_c_t_car_u, t_lookup, u_lookup) + fx_c_s_car_s_any(fx_c_t_car_v, t_lookup, v_lookup) +#define fx_add_s_car_s_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer val1, val2; \ + val2 = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ + val2 = (is_pair(val2)) ? car(val2) : g_car(sc, set_plist_1(sc, val2)); \ + val1 = Lookup1(sc, cadr(arg), arg); \ + return(((is_t_integer(val1)) && (is_t_integer(val2))) ? make_integer(sc, integer(val1) + integer(val2)) : add_p_pp(sc, val1, val2)); \ + } + fx_add_s_car_s_any(fx_add_s_car_s, s_lookup, s_lookup) + fx_add_s_car_s_any(fx_add_u_car_t, u_lookup, t_lookup) + fx_add_s_car_s_any(fx_add_t_car_v, t_lookup, v_lookup) +static s7_pointer fx_cons_s_cdr_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer val; + val = lookup(sc, opt2_sym(cdr(arg))); + val = (is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val)); + return (cons(sc, lookup(sc, cadr(arg)), val)); +} + +static s7_pointer fx_c_op_s_opsqq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer outer = cadr(arg), args; + args = caddr(outer); + set_car(sc->t1_1, lookup(sc, cadr(args))); + set_car(sc->t2_2, fn_proc(args) (sc, sc->t1_1)); + set_car(sc->t2_1, lookup(sc, cadr(outer))); + set_car(sc->t1_1, fn_proc(outer) (sc, sc->t2_1)); + return (fn_proc(arg) (sc, sc->t1_1)); +} + +static s7_pointer fx_not_op_s_opsqq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer outer = cadr(arg), args; + args = caddr(outer); + set_car(sc->t1_1, lookup(sc, cadr(args))); + set_car(sc->t2_2, fn_proc(args) (sc, sc->t1_1)); + set_car(sc->t2_1, lookup(sc, cadr(outer))); + return (((fn_proc(outer) (sc, sc->t2_1)) == sc->F) ? sc->T : sc->F); +} + +static s7_pointer fx_c_op_opsq_sq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer outer = cadr(arg), args; + args = cadr(outer); + set_car(sc->t1_1, lookup(sc, cadr(args))); + set_car(sc->t2_1, fn_proc(args) (sc, sc->t1_1)); + set_car(sc->t2_2, lookup(sc, caddr(outer))); + set_car(sc->t1_1, fn_proc(outer) (sc, sc->t2_1)); + return (fn_proc(arg) (sc, sc->t1_1)); +} + +static s7_pointer fx_not_op_optq_sq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer outer = cadr(arg), args; + args = cadr(outer); + set_car(sc->t1_1, t_lookup(sc, cadr(args), arg)); + set_car(sc->t2_1, fn_proc(args) (sc, sc->t1_1)); + set_car(sc->t2_2, lookup(sc, caddr(outer))); + return ((fn_proc(outer) (sc, sc->t2_1) == sc->F) ? sc->T : sc->F); +} + +static s7_pointer fx_c_c_opsq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = opt3_pair(arg); /* caddr(arg); */ + set_car(sc->t1_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, fn_proc(largs) (sc, sc->t1_1)); + set_car(sc->t2_1, cadr(arg)); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_c_opsq_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pp_t) opt2_direct(cdr(arg))) (sc, cadr(arg), ((s7_p_p_t) + opt3_direct + (cdr + (arg))) + (sc, + lookup(sc, + opt1_sym(cdr + (arg)))))); +} + +static s7_pointer fx_c_opsq_opsq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cdr(arg); + set_car(sc->t1_1, lookup(sc, cadar(largs))); + gc_protect_via_stack(sc, fn_proc(car(largs)) (sc, sc->t1_1)); + largs = cadr(largs); + set_car(sc->t1_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, fn_proc(largs) (sc, sc->t1_1)); + set_car(sc->t2_1, stack_protected1(sc)); + unstack(sc); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_opsq_opsq_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pp_t) opt3_direct(arg)) (sc, ((s7_p_p_t) opt2_direct(cdr(arg))) (sc, lookup(sc, cadadr(arg))), /* no free field in arg or cdr(arg) */ + ((s7_p_p_t) opt3_direct(cdr(arg))) (sc, lookup(sc, opt1_sym(cdr(arg)))))); /* cadaddr(arg) */ +} + +static s7_pointer fx_c_optq_optq_direct(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* cadadr and cadaddr */ + return (((s7_p_pp_t) opt3_direct(arg)) (sc, ((s7_p_p_t) + opt2_direct(cdr(arg))) + (sc, x), ((s7_p_p_t) + opt3_direct(cdr + (arg))) + (sc, x))); +} + +#define fx_car_s_car_s_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer p1, p2; \ + p1 = Lookup1(sc, opt1_sym(cdr(arg)), arg); \ + p2 = Lookup2(sc, opt2_sym(cdr(arg)), arg); /* cadaddr(arg) */ \ + return(((s7_p_pp_t)opt3_direct(arg))(sc, (is_pair(p1)) ? car(p1) : g_car(sc, set_plist_1(sc, p1)), (is_pair(p2)) ? car(p2) : g_car(sc, set_plist_1(sc, p2)))); \ + } + +fx_car_s_car_s_any(fx_car_s_car_s, s_lookup, s_lookup) + fx_car_s_car_s_any(fx_car_t_car_u, t_lookup, u_lookup) +static s7_pointer fx_cdr_s_cdr_s(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p1, p2; + p1 = lookup(sc, opt1_sym(cdr(arg))); + p2 = lookup(sc, opt2_sym(cdr(arg))); /* cadaddr(arg) */ + return (((s7_p_pp_t) opt3_direct(arg)) (sc, + (is_pair(p1)) ? cdr(p1) : + g_cdr(sc, set_plist_1(sc, p1)), + (is_pair(p2)) ? cdr(p2) : + g_cdr(sc, + set_plist_1(sc, p2)))); +} + +static s7_pointer fx_is_eq_car_car_tu(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p1, p2; + p1 = t_lookup(sc, opt1_sym(cdr(arg)), arg); + p1 = (is_pair(p1)) ? car(p1) : g_car(sc, set_plist_1(sc, p1)); + p2 = u_lookup(sc, opt2_sym(cdr(arg)), arg); + p2 = (is_pair(p2)) ? car(p2) : g_car(sc, set_plist_1(sc, p2)); + return (make_boolean(sc, (p1 == p2) + || ((is_unspecified(p1)) + && (is_unspecified(p2))))); +} + +static s7_pointer fx_c_opsq_opssq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cdr(arg); + set_car(sc->t1_1, lookup(sc, cadar(largs))); + gc_protect_via_stack(sc, fn_proc(car(largs)) (sc, sc->t1_1)); + largs = cadr(largs); + set_car(sc->t2_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); /* caddr(largs) */ + set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1)); + set_car(sc->t2_1, stack_protected1(sc)); + unstack(sc); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_opsq_optuq_direct(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cdr(arg); + return (((s7_p_pp_t) opt3_direct(arg)) (sc, ((s7_p_p_t) + opt2_direct(largs)) (sc, + lookup + (sc, + cadar + (largs))), + ((s7_p_pp_t) + opt3_direct(largs)) (sc, + t_lookup + (sc, + opt2_sym + (cdr + (largs)), + arg), + u_lookup + (sc, + opt1_sym + (largs), + arg)))); +} + +static s7_pointer fx_num_eq_car_v_add_tu(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p1, p2, p3; + p1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg)); + p2 = t_lookup(sc, opt2_sym(cddr(arg)), arg); + p3 = u_lookup(sc, opt1_sym(cdr(arg)), arg); + if ((is_t_integer(p1)) && (is_t_integer(p2)) && (is_t_integer(p3))) + return (make_boolean + (sc, integer(p1) == (integer(p2) + integer(p3)))); + return (make_boolean(sc, num_eq_b_7pp(sc, p1, add_p_pp(sc, p2, p3)))); +} + +static s7_pointer fx_num_eq_car_v_subtract_tu(s7_scheme * sc, + s7_pointer arg) +{ + s7_pointer p1, p2, p3; + p1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg)); + p2 = t_lookup(sc, opt2_sym(cddr(arg)), arg); + p3 = u_lookup(sc, opt1_sym(cdr(arg)), arg); + if ((is_t_integer(p1)) && (is_t_integer(p2)) && (is_t_integer(p3))) + return (make_boolean + (sc, integer(p1) == (integer(p2) - integer(p3)))); + return (make_boolean + (sc, num_eq_b_7pp(sc, p1, subtract_p_pp(sc, p2, p3)))); +} + +static s7_pointer fx_c_opssq_opsq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cdr(arg); + set_car(sc->t2_1, lookup(sc, cadar(largs))); + set_car(sc->t2_2, lookup(sc, opt2_sym(cdar(largs)))); + gc_protect_via_stack(sc, fn_proc(car(largs)) (sc, sc->t2_1)); + largs = cadr(largs); + set_car(sc->t1_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, fn_proc(largs) (sc, sc->t1_1)); + set_car(sc->t2_1, stack_protected1(sc)); + unstack(sc); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_opssq_opssq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = cdr(arg); + set_car(sc->t2_1, lookup(sc, cadar(largs))); + set_car(sc->t2_2, lookup(sc, opt2_sym(cdar(largs)))); + gc_protect_via_stack(sc, fn_proc(car(largs)) (sc, sc->t2_1)); + largs = cadr(largs); + set_car(sc->t2_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); + set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1)); + set_car(sc->t2_1, stack_protected1(sc)); + unstack(sc); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_sub_mul_mul(s7_scheme * sc, s7_pointer arg) +{ /* (- (* s1 s2) (* s3 s4)) */ + s7_pointer a2, s1, s2, s3, s4, a1 = opt3_pair(arg); /* cdaddr(arg); */ + s1 = lookup(sc, car(a1)); + s2 = lookup(sc, cadr(a1)); + a2 = opt1_pair(cdr(arg)); /* cdadr(arg) *//* here and elsewhere this should be GC safe -- opssq->* (no methods?) etc */ + s3 = lookup(sc, car(a2)); + s4 = lookup(sc, cadr(a2)); + if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3)) + && (is_t_real(s4))) + return (make_real + (sc, (real(s3) * real(s4)) - (real(s1) * real(s2)))); + sc->u = multiply_p_pp(sc, s1, s2); + return (subtract_p_pp(sc, multiply_p_pp(sc, s3, s4), sc->u)); +} + +static s7_pointer fx_add_mul_mul(s7_scheme * sc, s7_pointer arg) +{ /* (+ (* s1 s2) (* s3 s4)) */ + s7_pointer a2, s1, s2, s3, s4, a1 = opt3_pair(arg); /* cdaddr(arg); */ + s1 = lookup(sc, car(a1)); + s2 = lookup(sc, cadr(a1)); + a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ + s3 = lookup(sc, car(a2)); + s4 = lookup(sc, cadr(a2)); + if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3)) + && (is_t_real(s4))) + return (make_real + (sc, (real(s3) * real(s4)) + (real(s1) * real(s2)))); + sc->u = multiply_p_pp(sc, s1, s2); + return (add_p_pp(sc, multiply_p_pp(sc, s3, s4), sc->u)); +} + +static s7_pointer fx_mul_sub_sub(s7_scheme * sc, s7_pointer arg) +{ /* (* (- s1 s2) (- s3 s4)) */ + s7_pointer a2, s1, s2, s3, s4, a1 = opt3_pair(arg); /* cdaddr(arg); */ + s1 = lookup(sc, car(a1)); + s2 = lookup(sc, cadr(a1)); + a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ + s3 = lookup(sc, car(a2)); + s4 = lookup(sc, cadr(a2)); + if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3)) + && (is_t_real(s4))) + return (make_real + (sc, (real(s3) - real(s4)) * (real(s1) - real(s2)))); + sc->u = subtract_p_pp(sc, s1, s2); + return (multiply_p_pp(sc, subtract_p_pp(sc, s3, s4), sc->u)); +} + +static s7_pointer fx_lt_sub2(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */ + sc->u = subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))); + a1 = opt1_pair(cdr(arg)); /* cdadr(arg) */ + return (lt_p_pp + (sc, + subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))), + sc->u)); +} + +static s7_pointer fx_sub_vref2(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p1, p2, v1, a1 = cdadr(arg); + v1 = lookup(sc, car(a1)); + p1 = lookup(sc, cadr(a1)); + p2 = lookup(sc, opt3_sym(arg)); /* caddaddr(arg)); */ + if ((is_t_integer(p1)) && (is_t_integer(p2)) + && ((is_normal_vector(v1)) && (vector_rank(v1) == 1))) { + s7_int i1 = integer(p1), i2 = integer(p2); + if ((i1 >= 0) && (i1 <= vector_length(v1)) && (i2 >= 0) + && (i2 < vector_length(v1))) + return (subtract_p_pp + (sc, vector_ref_p_pi(sc, v1, i1), + vector_ref_p_pi(sc, v1, i2))); + } + return (subtract_p_pp + (sc, vector_ref_p_pp(sc, v1, p1), + vector_ref_p_pp(sc, v1, p2))); +} + +static s7_pointer fx_c_op_opsqq(s7_scheme * sc, s7_pointer code) +{ + set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(code)))); + set_car(sc->t1_1, fn_proc(opt3_pair(code)) (sc, sc->t1_1)); + set_car(sc->t1_1, fn_proc(cadr(code)) (sc, sc->t1_1)); + return (fn_proc(code) (sc, sc->t1_1)); +} + +static s7_pointer fx_not_op_opsqq(s7_scheme * sc, s7_pointer code) +{ + set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(code)))); + set_car(sc->t1_1, fn_proc(opt3_pair(code)) (sc, sc->t1_1)); + return ((fn_proc(cadr(code)) (sc, sc->t1_1) == sc->F) ? sc->T : sc->F); +} + +static s7_pointer fx_not_is_pair_opsq(s7_scheme * sc, s7_pointer code) +{ + return (make_boolean(sc, !is_pair(fn_proc(opt3_pair(code)) + (sc, + set_plist_1(sc, + lookup(sc, + opt3_sym(cdr + (code)))))))); +} + +static s7_pointer fx_string_ref_t_last(s7_scheme * sc, s7_pointer arg) +{ + return (string_ref_p_plast + (sc, t_lookup(sc, cadr(arg), arg), int_zero)); +} + +static s7_pointer fx_c_a(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t1_1, fx_call(sc, cdr(arg))); + return (fn_proc(arg) (sc, sc->t1_1)); +} + +static s7_pointer fx_c_a_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_p_t) opt3_direct(arg)) (sc, fx_call(sc, cdr(arg)))); +} + +static s7_pointer fx_not_a(s7_scheme * sc, s7_pointer arg) +{ + return ((fx_call(sc, cdr(arg)) == sc->F) ? sc->T : sc->F); +} + +static s7_pointer fx_c_saa(s7_scheme * sc, s7_pointer arg) +{ + gc_protect_via_stack(sc, fx_call(sc, opt3_pair(arg))); /* opt3_pair=cddr */ + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); + set_car(sc->t3_1, lookup(sc, cadr(arg))); + set_car(sc->t3_2, stack_protected1(sc)); + unstack(sc); + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_ssa(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); + set_car(sc->t3_1, lookup(sc, cadr(arg))); + set_car(sc->t3_2, lookup(sc, car(opt3_pair(arg)))); + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_ssa_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_ppp_t) opt2_direct(cdr(arg))) (sc, + lookup(sc, cadr(arg)), + lookup(sc, + car(opt3_pair + (arg))), + fx_call(sc, + cdr(opt3_pair + (arg))))); +} + +static Inline s7_pointer op_ssa_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_ppp_t) opt2_direct(cdr(arg))) (sc, + lookup(sc, cadr(arg)), + lookup(sc, + car(opt3_pair + (arg))), + fx_call(sc, + cdr(opt3_pair + (arg))))); +} + +static s7_pointer fx_c_ass(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_1, fx_call(sc, cdr(arg))); + set_car(sc->t3_2, lookup(sc, car(opt3_pair(arg)))); + set_car(sc->t3_3, lookup(sc, cadr(opt3_pair(arg)))); + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_agg(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_1, fx_call(sc, cdr(arg))); + set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_sas(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); + set_car(sc->t3_1, lookup(sc, cadr(arg))); + set_car(sc->t3_3, lookup(sc, cadr(opt3_pair(arg)))); + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_sca(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); + set_car(sc->t3_1, lookup(sc, cadr(arg))); + set_car(sc->t3_2, car(opt3_pair(arg))); + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_Tca(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); + set_car(sc->t3_1, T_lookup(sc, cadr(arg), arg)); + set_car(sc->t3_2, car(opt3_pair(arg))); + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_csa(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); + set_car(sc->t3_1, cadr(arg)); + set_car(sc->t3_2, lookup(sc, car(opt3_pair(arg)))); + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_cac(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); + set_car(sc->t3_1, cadr(arg)); + set_car(sc->t3_3, cadr(opt3_pair(arg))); + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_aa(s7_scheme * sc, s7_pointer arg) +{ + /* check_stack_size(sc); */ + gc_protect_via_stack(sc, fx_call(sc, cdr(arg))); + set_car(sc->t2_2, fx_call(sc, opt3_pair(arg))); /* cddr(arg) */ + set_car(sc->t2_1, T_Pos(stack_protected1(sc))); + unstack(sc); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_ca(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t2_2, fx_call(sc, cddr(arg))); + set_car(sc->t2_1, opt3_con(arg)); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_ac(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t2_1, fx_call(sc, cdr(arg))); + set_car(sc->t2_2, opt3_con(arg)); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_ac_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pp_t) opt3_direct(cdr(arg))) (sc, fx_call(sc, cdr(arg)), + opt3_con(arg))); +} + +static s7_pointer fx_is_eq_ac(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x, y = opt3_con(arg); + x = fx_call(sc, cdr(arg)); + return (make_boolean(sc, (x == y) + || ((is_unspecified(x)) && (is_unspecified(y))))); +} + +#define fx_c_sa_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t2_2, fx_call(sc, cddr(arg))); \ + set_car(sc->t2_1, Lookup(sc, opt3_sym(arg), arg)); \ + return(fn_proc(arg)(sc, sc->t2_1)); \ + } + +fx_c_sa_any(fx_c_sa, s_lookup) + fx_c_sa_any(fx_c_ta, t_lookup) + fx_c_sa_any(fx_c_ua, u_lookup) +static s7_pointer fx_c_za(s7_scheme * sc, s7_pointer arg) +{ /* "z"=unsafe_s */ + s7_pointer val; + val = lookup_checked(sc, cadr(arg)); /* this can call an autoload function that steps on sc->t2_1 */ + set_car(sc->t2_2, fx_call(sc, opt3_pair(arg))); + set_car(sc->t2_1, val); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +#define fx_c_sa_direct_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup(sc, opt3_sym(arg), arg), fx_call(sc, cddr(arg)))); \ + } + +fx_c_sa_direct_any(fx_c_sa_direct, s_lookup) + fx_c_sa_direct_any(fx_c_ua_direct, u_lookup) +static s7_pointer fx_cons_ca(s7_scheme * sc, s7_pointer arg) +{ + return (cons(sc, opt3_con(arg), fx_call(sc, cddr(arg)))); +} + +static s7_pointer fx_cons_ac(s7_scheme * sc, s7_pointer arg) +{ + return (cons(sc, fx_call(sc, cdr(arg)), opt3_con(arg))); +} + +static s7_pointer fx_cons_sa(s7_scheme * sc, s7_pointer arg) +{ + return (cons(sc, lookup(sc, opt3_sym(arg)), fx_call(sc, cddr(arg)))); +} + +static s7_pointer fx_cons_as(s7_scheme * sc, s7_pointer arg) +{ + return (cons(sc, fx_call(sc, cdr(arg)), lookup(sc, opt3_sym(arg)))); +} + +static s7_pointer fx_cons_aa(s7_scheme * sc, s7_pointer arg) +{ + return (cons(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg)))); +} + +#define fx_c_as_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + set_car(sc->t2_1, fx_call(sc, cdr(arg))); \ + set_car(sc->t2_2, Lookup(sc, opt3_sym(arg), arg)); \ + return(fn_proc(arg)(sc, sc->t2_1)); \ + } + +fx_c_as_any(fx_c_as, s_lookup) + fx_c_as_any(fx_c_at, t_lookup) +static s7_pointer fx_c_as_direct(s7_scheme * sc, s7_pointer arg) +{ + return (((s7_p_pp_t) opt3_direct(cdr(arg))) (sc, fx_call(sc, cdr(arg)), + lookup(sc, + opt3_sym(arg)))); +} + +static s7_pointer fx_add_as(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x1, x2; + x1 = fx_call(sc, cdr(arg)); + x2 = lookup(sc, opt3_sym(arg)); + if ((is_t_real(x1)) && (is_t_real(x2))) + return (make_real(sc, real(x1) + real(x2))); + return (add_p_pp(sc, x1, x2)); +} + +static s7_pointer fx_multiply_sa(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x1, x2; + x1 = lookup(sc, cadr(arg)); + x2 = fx_call(sc, cddr(arg)); + if ((is_t_real(x1)) && (is_t_real(x2))) + return (make_real(sc, real(x1) * real(x2))); + return (multiply_p_pp(sc, x1, x2)); +} + +static s7_pointer fx_subtract_aa(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x1, x2; + x1 = fx_call(sc, cdr(arg)); + x2 = fx_call(sc, opt3_pair(arg)); + if ((is_t_real(x1)) && (is_t_real(x2))) + return (make_real(sc, real(x1) - real(x2))); + return (subtract_p_pp(sc, x1, x2)); +} + +static s7_pointer fx_add_aa(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x1, x2; + x1 = fx_call(sc, cdr(arg)); + x2 = fx_call(sc, opt3_pair(arg)); + if ((is_t_real(x1)) && (is_t_real(x2))) + return (make_real(sc, real(x1) + real(x2))); + return (add_p_pp(sc, x1, x2)); +} + +static s7_pointer fx_multiply_aa(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x1, x2; + x1 = fx_call(sc, cdr(arg)); + x2 = fx_call(sc, opt3_pair(arg)); + if ((is_t_real(x1)) && (is_t_real(x2))) + return (make_real(sc, real(x1) * real(x2))); + return (multiply_p_pp(sc, x1, x2)); +} + +static s7_pointer fx_add_sa(s7_scheme * sc, s7_pointer arg) +{ + return (add_p_pp + (sc, lookup(sc, opt3_sym(arg)), fx_call(sc, cddr(arg)))); +} + +static s7_pointer fx_number_to_string_aa(s7_scheme * sc, s7_pointer arg) +{ + return (number_to_string_p_pp + (sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg)))); +} + +static s7_pointer fx_c_3g(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_1, fx_call(sc, cdr(arg))); + set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_aaa(s7_scheme * sc, s7_pointer arg) +{ + /* check_stack_size(sc); */ + gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), + fx_call(sc, opt3_pair(arg))); + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); + set_car(sc->t3_2, stack_protected2(sc)); + set_car(sc->t3_1, stack_protected1(sc)); + unstack(sc); + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_gac(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); + set_car(sc->t3_3, cadr(opt3_pair(arg))); + set_car(sc->t3_1, lookup_global(sc, cadr(arg))); + return (fn_proc(arg) (sc, sc->t3_1)); +} + +static s7_pointer fx_c_opaq_s(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t1_1, fx_call(sc, cdadr(arg))); + set_car(sc->t2_1, fn_proc(cadr(arg)) (sc, sc->t1_1)); + set_car(sc->t2_2, lookup_checked(sc, caddr(arg))); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_s_opaq(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t1_1, fx_call(sc, opt3_pair(arg))); /* cdaddr(arg); */ + set_car(sc->t2_2, fn_proc(caddr(arg)) (sc, sc->t1_1)); + set_car(sc->t2_1, lookup_checked(sc, cadr(arg))); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_opaq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p = cadr(arg); + set_car(sc->t1_1, fx_call(sc, cdr(p))); + set_car(sc->t1_1, fn_proc(p) (sc, sc->t1_1)); + return (fn_proc(arg) (sc, sc->t1_1)); +} + +static s7_pointer fx_c_opaaq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p = cadr(arg); + /* check_stack_size(sc); */ + gc_protect_via_stack(sc, fx_call(sc, cdr(p))); + set_car(sc->t2_2, fx_call(sc, cddr(p))); + set_car(sc->t2_1, stack_protected1(sc)); + unstack(sc); + set_car(sc->t1_1, fn_proc(p) (sc, sc->t2_1)); + return (fn_proc(arg) (sc, sc->t1_1)); +} + +static s7_pointer fx_c_opsaq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p = cadr(arg); + set_car(sc->t2_2, fx_call(sc, cddr(p))); + set_car(sc->t2_1, lookup(sc, cadr(p))); + set_car(sc->t1_1, fn_proc(p) (sc, sc->t2_1)); + return (fn_proc(arg) (sc, sc->t1_1)); +} + +static s7_pointer fx_c_opaaaq(s7_scheme * sc, s7_pointer code) +{ + s7_pointer arg = cadr(code); + gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* cddr(arg) */ + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); + set_car(sc->t3_1, stack_protected1(sc)); + set_car(sc->t3_2, stack_protected2(sc)); + unstack(sc); + set_car(sc->t1_1, fn_proc(arg) (sc, sc->t3_1)); + return (fn_proc(code) (sc, sc->t1_1)); +} + +static s7_pointer fx_c_s_opaaq(s7_scheme * sc, s7_pointer code) +{ + s7_pointer arg = caddr(code); + gc_protect_via_stack(sc, fx_call(sc, cdr(arg))); + set_car(sc->t2_2, fx_call(sc, cddr(arg))); + set_car(sc->t2_1, stack_protected1(sc)); + set_car(sc->t2_2, fn_proc(arg) (sc, sc->t2_1)); + set_car(sc->t2_1, lookup(sc, cadr(code))); + unstack(sc); + return (fn_proc(code) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_s_opaaaq(s7_scheme * sc, s7_pointer code) +{ + s7_pointer arg = caddr(code); + gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* cddr(arg) */ + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); + set_car(sc->t3_1, stack_protected1(sc)); + set_car(sc->t3_2, stack_protected2(sc)); + unstack(sc); + set_car(sc->t2_2, fn_proc(arg) (sc, sc->t3_1)); + set_car(sc->t2_1, lookup(sc, cadr(code))); + return (fn_proc(code) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_4a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer res = cdr(code); + check_stack_size(sc); /* t718 pp cycles #f */ + gc_protect_2_via_stack(sc, fx_call(sc, res), fx_call(sc, cdr(res))); + res = cddr(res); + stack_protected3(sc) = fx_call(sc, res); + set_car(sc->t3_3, fx_call(sc, cdr(res))); + set_car(sc->t3_2, stack_protected3(sc)); + set_car(sc->t3_1, stack_protected2(sc)); + set_car(sc->t4_1, stack_protected1(sc)); + unstack(sc); + res = fn_proc(code) (sc, sc->t4_1); + set_car(sc->t4_1, sc->F); + return (res); +} + +static s7_pointer fx_c_4g(s7_scheme * sc, s7_pointer code) +{ /* all opts in use for code, opt1 free cdr(code), code opt3 is line_number, cdr(code) opt3 is arglen?? */ + s7_pointer res = cdr(code); + set_car(sc->t4_1, fx_call(sc, res)); + set_car(sc->t3_1, fx_call(sc, cdr(res))); + set_car(sc->t3_2, fx_call(sc, opt3_pair(code))); /* cddr(res) */ + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(code)))); /* cdddr(res) */ + res = fn_proc(code) (sc, sc->t4_1); + set_car(sc->t4_1, sc->F); + return (res); +} + +static s7_pointer fx_c_c_opscq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = caddr(arg); + set_car(sc->t2_1, lookup(sc, cadr(largs))); + set_car(sc->t2_2, opt2_con(cdr(largs))); + set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1)); + set_car(sc->t2_1, cadr(arg)); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_s_opcsq(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer largs = caddr(arg); + set_car(sc->t2_2, lookup(sc, caddr(largs))); + set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ + set_car(sc->t2_2, fn_proc(largs) (sc, sc->t2_1)); + set_car(sc->t2_1, lookup(sc, cadr(arg))); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_op_opssqq_s(s7_scheme * sc, s7_pointer code) +{ + s7_pointer arg = opt1_pair(cdr(code)); + set_car(sc->t2_1, lookup(sc, cadr(arg))); + set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(arg)))); + set_car(sc->t1_1, fn_proc(arg) (sc, sc->t2_1)); + set_car(sc->t2_1, fn_proc(cadr(code)) (sc, sc->t1_1)); + set_car(sc->t2_2, lookup(sc, caddr(code))); + return (fn_proc(code) (sc, sc->t2_1)); +} + +static s7_pointer fx_c_op_opssqq_s_direct(s7_scheme * sc, s7_pointer code) +{ + s7_pointer arg = opt1_pair(cdr(code)); + return (((s7_p_pp_t) opt3_direct(code)) (sc, ((s7_p_p_t) + opt2_direct(cdr(code))) + (sc, + ((s7_p_pp_t) + opt3_direct(cdr(code))) (sc, + lookup + (sc, + cadr + (arg)), + lookup + (sc, + caddr + (arg)))), + lookup(sc, caddr(code)))); +} + +static s7_pointer fx_c_ns(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer args, p, lst; + lst = safe_list_if_possible(sc, integer(opt3_arglen(cdr(arg)))); + if (in_heap(lst)) + gc_protect_via_stack(sc, lst); + for (args = cdr(arg), p = lst; is_pair(args); + args = cdr(args), p = cdr(p)) + set_car(p, lookup(sc, car(args))); + p = fn_proc(arg) (sc, lst); + if (in_heap(lst)) + unstack(sc); + else + clear_list_in_use(lst); + return (p); +} + +static s7_pointer fx_list_ns(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p, args, lst; + lst = make_list(sc, integer(opt3_arglen(cdr(arg))), sc->nil); + for (args = cdr(arg), p = lst; is_pair(args); + args = cdr(args), p = cdr(p)) + set_car(p, lookup(sc, car(args))); + return (lst); +} + +static s7_pointer fx_vector_ns(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer args, vec; + s7_int i; + s7_pointer *els; + vec = make_simple_vector(sc, integer(opt3_arglen(cdr(arg)))); + els = (s7_pointer *) vector_elements(vec); + for (args = cdr(arg), i = 0; is_pair(args); args = cdr(args), i++) + els[i] = lookup(sc, car(args)); + return (vec); +} + +static s7_pointer fx_c_all_ca(s7_scheme * sc, s7_pointer code) +{ + s7_pointer args, p, lst; + lst = safe_list_if_possible(sc, integer(opt3_arglen(cdr(code)))); + if (in_heap(lst)) + gc_protect_via_stack(sc, lst); + for (args = cdr(code), p = lst; is_pair(args); + args = cdr(args), p = cddr(p)) { + set_car(p, opt2_con(args)); + args = cdr(args); + set_car(cdr(p), fx_call(sc, args)); + } + p = fn_proc(code) (sc, lst); + if (in_heap(lst)) + unstack(sc); + else + clear_list_in_use(lst); + return (p); +} + +static s7_pointer fx_inlet_ca(s7_scheme * sc, s7_pointer code) +{ + s7_pointer new_e, x; + int64_t id; + + new_cell(sc, new_e, T_LET | T_SAFE_PROCEDURE); + let_set_slots(new_e, slot_end(sc)); + let_set_outlet(new_e, sc->nil); + gc_protect_via_stack(sc, new_e); + + /* as in let, we need to call the var inits before making the new let, but a simpler equivalent is to make the new let + * but don't set its id yet. + */ + for (x = cdr(code); is_pair(x); x = cddr(x)) { + s7_pointer symbol = car(x), value; + symbol = (is_keyword(symbol)) ? keyword_symbol(symbol) : cadr(symbol); /* (inlet ':allow-other-keys 3) */ + if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */ + return (wrong_type_argument_with_type + (sc, sc->inlet_symbol, 1, symbol, + a_non_constant_symbol_string)); + value = fx_call(sc, cdr(x)); /* it's necessary to do this first, before add_slot_unchecked */ + add_slot_unchecked(sc, new_e, symbol, value, symbol_id(symbol)); + } + id = ++sc->let_number; + let_set_id(new_e, id); + for (x = let_slots(new_e); tis_slot(x); x = next_slot(x)) + symbol_set_id(slot_symbol(x), id); + unstack(sc); + return (new_e); +} + +static s7_pointer fx_c_na(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer args, p, val; + val = safe_list_if_possible(sc, integer(opt3_arglen(cdr(arg)))); + if (in_heap(val)) + gc_protect_via_stack(sc, val); + for (args = cdr(arg), p = val; is_pair(args); + args = cdr(args), p = cdr(p)) + set_car(p, fx_call(sc, args)); + p = fn_proc(arg) (sc, val); + if (in_heap(val)) + unstack(sc); + else + clear_list_in_use(val); + return (p); +} + +static s7_pointer fx_vector_all_a(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer v, args; + s7_pointer *els; + s7_int i, len = integer(opt3_arglen(cdr(arg))); + /* check_free_heap_size(sc, len + 1); *//* I think since v is a filled vector protected on the stack that this is unnecessary */ + v = s7_make_vector(sc, len); + gc_protect_via_stack(sc, v); + els = vector_elements(v); + for (i = 0, args = cdr(arg); i < len; args = cdr(args), i++) + els[i] = fx_call(sc, args); + sc->value = v; + unstack(sc); + return (v); +} + +static s7_pointer fx_if_a_a(s7_scheme * sc, s7_pointer arg) +{ + return ((is_true(sc, fx_call(sc, cdr(arg)))) ? + fx_call(sc, opt1_pair(arg)) : sc->unspecified); +} + +static s7_pointer fx_if_not_a_a(s7_scheme * sc, s7_pointer arg) +{ + return ((is_false(sc, fx_call(sc, opt1_pair(arg)))) ? + fx_call(sc, opt2_pair(arg)) : sc->unspecified); +} + +static s7_pointer fx_if_a_a_a(s7_scheme * sc, s7_pointer arg) +{ + return ((is_true(sc, fx_call(sc, cdr(arg)))) ? + fx_call(sc, opt1_pair(arg)) : fx_call(sc, opt2_pair(arg))); +} + +#define fx_if_s_a_a_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + return((Lookup(sc, cadr(arg), arg) != sc->F) ? fx_call(sc, opt1_pair(arg)) : fx_call(sc, opt2_pair(arg))); \ + } + +fx_if_s_a_a_any(fx_if_s_a_a, s_lookup) + fx_if_s_a_a_any(fx_if_o_a_a, o_lookup) /* diff s->o of ca 3 */ +static s7_pointer fx_if_and2_s_a(s7_scheme * sc, s7_pointer arg) +{ + return (((fx_call(sc, opt1_pair(arg)) == sc->F) + || (fx_call(sc, opt2_pair(arg)) == sc->F)) ? fx_call(sc, + cdddr + (arg)) : + lookup(sc, opt3_sym(arg))); +} + +static s7_pointer fx_if_not_a_a_a(s7_scheme * sc, s7_pointer arg) +{ + return ((is_false(sc, fx_call(sc, opt1_pair(arg)))) ? + fx_call(sc, opt2_pair(arg)) : fx_call(sc, opt3_pair(arg))); +} + +static s7_pointer fx_if_a_c_c(s7_scheme * sc, s7_pointer arg) +{ + return ((is_true(sc, fx_call(sc, cdr(arg)))) ? opt1_con(arg) : + opt2_con(arg)); +} + +static s7_pointer fx_if_is_type_s_a_a(s7_scheme * sc, s7_pointer arg) +{ + if (gen_type_match + (sc, lookup(sc, opt2_sym(cdr(arg))), opt3_byte(cdr(arg)))) + return (fx_call(sc, cddr(arg))); + return (fx_call(sc, opt2_pair(arg))); /* cdddr(arg) */ +} + +static inline s7_pointer fx_and_2a(s7_scheme * sc, s7_pointer arg) +{ /* arg is the full expr: (and ...) */ + return ((fx_call(sc, cdr(arg)) == sc->F) ? sc->F : fx_call(sc, + cddr(arg))); +} + +static inline s7_pointer fx_and_s_2(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg) */ + return ((fn_proc(cadr(arg)) (sc, sc->t1_1) == + sc->F) ? sc->F : fn_proc(caddr(arg)) (sc, sc->t1_1)); +} + +static s7_pointer fx_and_or_2a_vref(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer or1 = cadr(arg), arg11, v; + arg11 = cdadr(or1); + v = lookup(sc, cadar(arg11)); + if ((is_normal_vector(v)) && (vector_rank(v) == 1)) { + s7_pointer ip, jp; + ip = lookup(sc, opt3_sym(or1)); + jp = lookup(sc, opt1_sym(or1)); + if ((is_t_integer(ip)) && (is_t_integer(jp))) { + s7_int i = integer(ip), j = integer(jp); + if ((i >= 0) && (j >= 0) && + (i < vector_length(v)) && (j < vector_length(v)) && + (is_t_real(vector_element(v, i))) + && (is_t_real(vector_element(v, j)))) { + s7_pointer xp; + xp = lookup(sc, cadr(arg11)); + if (is_t_real(xp)) { + s7_double vi = real(vector_element(v, i)), vj = + real(vector_element(v, j)), xf = real(xp); + return (make_boolean(sc, ((vi > xf) || (xf >= vj)) + && ((vj > xf) || (xf >= vi)))); + } + } + } + } + return (fx_and_2a(sc, arg)); +} + +static s7_pointer fx_len2_t(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer val; + val = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* isn't this unprotected from mock pair? *//* opt1_sym == cadadr(arg) */ + return (make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) + && (is_null(cddr(val))))); +} + +static s7_pointer fx_len3_t(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer val; + val = t_lookup(sc, opt1_sym(cdr(arg)), arg); + return (make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) + && (is_pair(cddr(val))))); +} + +static s7_pointer fx_and_3a(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p = cdr(arg), val; + val = fx_call(sc, p); + if (val == sc->F) + return (val); + p = cdr(p); + val = fx_call(sc, p); + return ((val == sc->F) ? val : fx_call(sc, cdr(p))); +} + +static s7_pointer fx_and_n(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p, x = sc->T; + for (p = cdr(arg); is_pair(p); p = cdr(p)) { /* in lg, 5/6 args appears to predominate */ + x = fx_call(sc, p); + if (is_false(sc, x)) + return (x); + } + return (x); +} + +static s7_pointer fx_or_2a(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p = cdr(arg), val; + val = fx_call(sc, p); + return ((val != sc->F) ? val : fx_call(sc, cdr(p))); +} + +static s7_pointer fx_or_s_2(s7_scheme * sc, s7_pointer arg) +{ + /* the "s" is looked up once here -- not obvious how to use fx_call anyway */ + s7_pointer x; + set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg); */ + x = fn_proc(cadr(arg)) (sc, sc->t1_1); + return ((x != sc->F) ? x : fn_proc(caddr(arg)) (sc, sc->t1_1)); +} + +static s7_pointer fx_or_s_type_2(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x; + x = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg)); */ + return (make_boolean(sc, (type(x) == integer(opt3_int(arg))) + || (type(x) == integer(opt2_int(cdr(arg)))))); +} + +static s7_pointer fx_not_symbol_or_keyword(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer val; + val = lookup(sc, opt3_sym(arg)); + return (make_boolean(sc, (!is_symbol(val)) || (is_keyword(val)))); +} + +static s7_pointer fx_or_and_2a(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p = cdr(arg), val; + val = fx_call(sc, p); + if (val != sc->F) + return (val); + p = opt3_pair(arg); /* cdadr(p); */ + val = fx_call(sc, p); + return ((val == sc->F) ? val : fx_call(sc, cdr(p))); +} + +static s7_pointer fx_or_and_3a(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p = cdr(arg), val; + val = fx_call(sc, p); + if (val != sc->F) + return (val); + p = opt3_pair(arg); /* cdadr(p); */ + val = fx_call(sc, p); + if (val == sc->F) + return (val); + p = cdr(p); + val = fx_call(sc, p); + return ((val == sc->F) ? val : fx_call(sc, cdr(p))); +} + +static s7_pointer fx_or_3a(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p = cdr(arg), val; + val = fx_call(sc, p); + if (val != sc->F) + return (val); + p = cdr(p); + val = fx_call(sc, p); + return ((val != sc->F) ? val : fx_call(sc, cdr(p))); +} + +static s7_pointer fx_or_n(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p; + for (p = cdr(arg); is_pair(p); p = cdr(p)) { + s7_pointer x; + x = fx_call(sc, p); + if (is_true(sc, x)) + return (x); + } + return (sc->F); +} + +static s7_pointer fx_begin_aa(s7_scheme * sc, s7_pointer arg) +{ + arg = cdr(arg); + fx_call(sc, arg); + return (fx_call(sc, cdr(arg))); +} + +static s7_pointer fx_begin_na(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p; + for (p = cdr(arg); is_pair(cdr(p)); p = cdr(p)) + fx_call(sc, p); + return (fx_call(sc, p)); +} + +static s7_pointer fx_safe_thunk_a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer f, result; + gc_protect_via_stack(sc, sc->curlet); + f = opt1_lambda(code); + set_curlet(sc, closure_let(f)); + result = fx_call(sc, closure_body(f)); + set_curlet(sc, stack_protected1(sc)); + unstack(sc); + return (result); +} + +static s7_pointer op_safe_thunk_a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer f = opt1_lambda(code); + set_curlet(sc, closure_let(f)); + return (fx_call(sc, closure_body(f))); +} + +static s7_pointer fx_safe_closure_s_a(s7_scheme * sc, s7_pointer code) +{ /* also called from h_safe_closure_s_a in eval */ + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + sc->curlet = + update_let_with_slot(sc, closure_let(opt1_lambda(code)), + lookup(sc, opt2_sym(code))); + result = fx_call(sc, closure_body(opt1_lambda(code))); + set_curlet(sc, stack_protected1(sc)); + unstack(sc); + return (result); +} + +static s7_pointer op_safe_closure_s_a(s7_scheme * sc, s7_pointer code) +{ /* also called from h_safe_closure_s_a in eval */ + sc->curlet = + update_let_with_slot(sc, closure_let(opt1_lambda(code)), + lookup(sc, opt2_sym(code))); + return (fx_call(sc, closure_body(opt1_lambda(code)))); +} + +static s7_pointer fx_safe_closure_t_a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + sc->curlet = + update_let_with_slot(sc, closure_let(opt1_lambda(code)), + t_lookup(sc, opt2_sym(code), code)); + result = fx_call(sc, closure_body(opt1_lambda(code))); + set_curlet(sc, stack_protected1(sc)); + unstack(sc); + return (result); +} + +static s7_pointer fx_safe_closure_s_to_s(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t1_1, lookup(sc, opt2_sym(arg))); + return (fn_proc(car(closure_body(opt1_lambda(arg)))) (sc, sc->t1_1)); +} + +static s7_pointer fx_safe_closure_s_to_sc(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t2_2, opt3_con(cdr(arg))); + set_car(sc->t2_1, lookup(sc, opt2_sym(arg))); + return (fn_proc(car(closure_body(opt1_lambda(arg)))) (sc, sc->t2_1)); +} + +static s7_pointer fx_safe_closure_s_to_vref(s7_scheme * sc, s7_pointer arg) +{ + return (vector_ref_p_pp + (sc, lookup(sc, opt2_sym(arg)), opt3_con(cdr(arg)))); +} + +static s7_pointer fx_safe_closure_s_to_sub1(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p; + p = lookup(sc, opt2_sym(arg)); + if ((!WITH_GMP) && (is_t_integer(p))) + return (make_integer(sc, integer(p) - 1)); + return (minus_c1(sc, p)); +} + +static s7_pointer fx_safe_closure_s_to_add1(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer p; + p = lookup(sc, opt2_sym(arg)); + if ((!WITH_GMP) && (is_t_integer(p))) + return (make_integer(sc, integer(p) + 1)); + return (g_add_x1_1(sc, p, 1)); +} + +static s7_pointer fx_c_ff(s7_scheme * sc, s7_pointer arg) +{ + s7_pointer x, p = cdr(arg); + x = fx_proc(cdar(p)) (sc, car(p)); + set_car(sc->t2_2, fx_proc(cdadr(p)) (sc, cadr(p))); + set_car(sc->t2_1, x); + return (fn_proc(arg) (sc, sc->t2_1)); +} + +static s7_pointer fx_safe_closure_a_to_sc(s7_scheme * sc, s7_pointer arg) +{ + set_car(sc->t2_1, fx_call(sc, cdr(arg))); + set_car(sc->t2_2, opt3_con(cdr(arg))); + return (fn_proc(car(closure_body(opt1_lambda(arg)))) (sc, sc->t2_1)); +} + +static s7_pointer fx_safe_closure_a_to_vref(s7_scheme * sc, s7_pointer arg) +{ + return (vector_ref_p_pp + (sc, fx_call(sc, cdr(arg)), opt3_con(cdr(arg)))); +} + +static s7_pointer fx_safe_closure_s_and_2a(s7_scheme * sc, s7_pointer code) +{ /* safe_closure_s_a where "a" is fx_and_2a */ + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + sc->curlet = + update_let_with_slot(sc, closure_let(opt1_lambda(code)), + lookup(sc, opt2_sym(code))); + code = cdar(closure_body(opt1_lambda(code))); + result = fx_call(sc, code); /* have to unwind the stack so this can't return */ + if (result != sc->F) + result = fx_call(sc, cdr(code)); + set_curlet(sc, stack_protected1(sc)); + unstack(sc); + return (result); +} + +static s7_pointer fx_safe_closure_s_and_pair(s7_scheme * sc, + s7_pointer code) +{ /* safe_closure_s_a where "a" is fx_and_2a with is_pair as first clause */ + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + sc->curlet = + update_let_with_slot(sc, closure_let(opt1_lambda(code)), + lookup(sc, opt2_sym(code))); + code = cdar(closure_body(opt1_lambda(code))); + if (is_pair(t_lookup(sc, cadar(code), code))) /* pair? arg = func par, pair? is global, symbol_id=0 */ + result = fx_call(sc, cdr(code)); + else + result = sc->F; + set_curlet(sc, stack_protected1(sc)); + unstack(sc); + return (result); +} + +static s7_pointer fx_safe_closure_a_a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + sc->curlet = + update_let_with_slot(sc, closure_let(opt1_lambda(code)), + fx_call(sc, cdr(code))); + result = fx_call(sc, closure_body(opt1_lambda(code))); + set_curlet(sc, stack_protected1(sc)); + unstack(sc); + return (result); +} + +static s7_pointer op_safe_closure_a_a(s7_scheme * sc, s7_pointer code) +{ + sc->curlet = + update_let_with_slot(sc, closure_let(opt1_lambda(code)), + fx_call(sc, cdr(code))); + return (fx_call(sc, closure_body(opt1_lambda(code)))); +} + +static s7_pointer fx_safe_closure_a_sqr(s7_scheme * sc, s7_pointer code) +{ + return (fx_sqr_1(sc, fx_call(sc, cdr(code)))); +} + +static s7_pointer fx_safe_closure_s_sqr(s7_scheme * sc, s7_pointer code) +{ + return (fx_sqr_1(sc, lookup(sc, opt2_sym(code)))); +} + +static s7_pointer fx_safe_closure_a_and_2a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer and_arg, result; + gc_protect_via_stack(sc, sc->curlet); + sc->curlet = + update_let_with_slot(sc, closure_let(opt1_lambda(code)), + fx_call(sc, cdr(code))); + and_arg = cdar(closure_body(opt1_lambda(code))); + result = fx_call(sc, and_arg); + if (result != sc->F) + result = fx_call(sc, cdr(and_arg)); + set_curlet(sc, stack_protected1(sc)); + unstack(sc); + return (result); +} + +static s7_pointer fx_safe_closure_ss_a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + sc->curlet = + update_let_with_two_slots(sc, closure_let(opt1_lambda(code)), + lookup(sc, cadr(code)), lookup(sc, + opt2_sym + (code))); + result = fx_call(sc, closure_body(opt1_lambda(code))); + set_curlet(sc, stack_protected1(sc)); + unstack(sc); + return (result); +} + +static s7_pointer op_safe_closure_ss_a(s7_scheme * sc, s7_pointer code) +{ + sc->curlet = + update_let_with_two_slots(sc, closure_let(opt1_lambda(code)), + lookup(sc, cadr(code)), lookup(sc, + opt2_sym + (code))); + return (fx_call(sc, closure_body(opt1_lambda(code)))); +} + +static s7_pointer fx_safe_closure_3s_a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + sc->curlet = + update_let_with_three_slots(sc, closure_let(opt1_lambda(code)), + lookup(sc, cadr(code)), lookup(sc, + opt2_sym + (code)), + lookup(sc, opt3_sym(code))); + result = fx_call(sc, closure_body(opt1_lambda(code))); + set_curlet(sc, stack_protected1(sc)); + unstack(sc); + return (result); +} + +static s7_pointer op_safe_closure_3s_a(s7_scheme * sc, s7_pointer code) +{ + sc->curlet = + update_let_with_three_slots(sc, closure_let(opt1_lambda(code)), + lookup(sc, cadr(code)), lookup(sc, + opt2_sym + (code)), + lookup(sc, opt3_sym(code))); + return (fx_call(sc, closure_body(opt1_lambda(code)))); +} + +static s7_pointer fx_safe_closure_aa_a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer f, p = cdr(code); + gc_protect_2_via_stack(sc, sc->curlet, fx_call(sc, cdr(p))); /* this is needed even if one of the args is a symbol, so nothing is saved by splitting out that case */ + f = opt1_lambda(code); + sc->curlet = + update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), + stack_protected2(sc)); + p = fx_call(sc, closure_body(f)); + set_curlet(sc, stack_protected1(sc)); + unstack(sc); + return (p); +} + +static inline s7_pointer fx_cond_fx_fx(s7_scheme * sc, s7_pointer code) +{ /* all tests are fxable, results are all fx, no =>, no missing results */ + s7_pointer p; + for (p = cdr(code); is_pair(p); p = cdr(p)) + if (is_true(sc, fx_call(sc, car(p)))) { + for (p = cdar(p); is_pair(cdr(p)); p = cdr(p)) + fx_call(sc, p); + return (fx_call(sc, p)); + } + return (sc->unspecified); +} + +static s7_pointer s7_let_field(s7_scheme * sc, s7_pointer sym); + +static s7_pointer fx_implicit_s7_let_ref_s(s7_scheme * sc, s7_pointer arg) +{ + return (s7_let_field(sc, opt3_sym(arg))); +} + +static s7_pointer fx_implicit_s7_let_set_sa(s7_scheme * sc, s7_pointer arg) +{ + return (s7_let_field_set + (sc, opt3_sym(cdr(arg)), fx_call(sc, cddr(arg)))); +} + +static s7_function *fx_function = NULL; + +static bool is_fxable(s7_scheme * sc, s7_pointer p) +{ + if (!is_pair(p)) + return (true); + if ((is_optimized(p)) && /* this is needed. In check_tc, for example, is_fxable can be confused by early optimize_op */ + (fx_function[optimize_op(p)])) + return (true); + return (is_proper_quote(sc, p)); +} + +static bool is_gxable(s7_pointer p) +{ + opcode_t op; + if (!is_optimized(p)) + return (false); + op = optimize_op(p); + return ((is_symbol(car(p))) && (symbol_ctr(car(p)) == 1) && + (op < FIRST_UNHOPPABLE_OP) && + (op > OP_GC_PROTECT) && (fx_function[op | 1])); +} + +static int32_t fx_count(s7_scheme * sc, s7_pointer x) +{ + int32_t count = 0; + s7_pointer p; + for (p = cdr(x); is_pair(p); p = cdr(p)) + if (is_fxable(sc, car(p))) + count++; + return (count); +} + +static bool is_code_constant(s7_scheme * sc, s7_pointer p) +{ + return ((is_pair(p)) ? (car(p) == sc->quote_symbol) : + is_constant(sc, p)); +} + +static inline s7_pointer check_quote(s7_scheme * sc, s7_pointer code); + +static s7_p_p_t s7_p_p_function(s7_pointer f); +static s7_p_pp_t s7_p_pp_function(s7_pointer f); +static s7_p_ppp_t s7_p_ppp_function(s7_pointer f); +static s7_p_dd_t s7_p_dd_function(s7_pointer f); +static s7_p_pi_t s7_p_pi_function(s7_pointer f); +static s7_p_ii_t s7_p_ii_function(s7_pointer f); + +#define is_unchanged_global(P) \ + ((is_symbol(P)) && (is_global(P)) && (symbol_id(P) == 0) && \ + (is_slot(initial_slot(P))) && \ + (initial_value(P) == global_value(P))) + +#define is_global_and_has_func(P, Func) ((is_unchanged_global(P)) && (Func(global_value(P)))) /* Func = s7_p_pp_function and friends */ + +static bool fx_matches(s7_pointer symbol, s7_pointer target_symbol) +{ + return ((symbol == target_symbol) && (is_unchanged_global(symbol))); +} + +static s7_pointer fx_in_place(s7_scheme * sc, s7_pointer arg) +{ + return (opt3_con(arg)); +} + +/* #define fx_choose(Sc, Holder, E, Checker) fx_choose_1(Sc, Holder, E, Checker, __func__, __LINE__) */ +static s7_function fx_choose(s7_scheme * sc, s7_pointer holder, + s7_pointer e, safe_sym_t * checker) +{ /* , const char *func, int line) */ + s7_pointer arg = car(holder); + if (!is_pair(arg)) { + if (is_symbol(arg)) { + if ((is_keyword(arg)) + || ((arg == sc->else_symbol) && (is_global(arg)))) + return (fx_c); + return ((is_global(arg)) ? fx_g + : ((checker(sc, arg, e)) ? fx_s : fx_unsafe_s)); + } + return (fx_c); + } + + if (is_optimized(arg)) { + switch (optimize_op(arg)) { + case HOP_SAFE_C_NC: + if (fn_proc(arg) == g_add_i_random) + return (fx_add_i_random); + /* an experiment -- does this ever happen in real code? -- no */ + /* integer->char string->number (string) (list) complex sqrt log expt * + - / + */ + if (((fn_proc(arg) == g_abs) && (is_t_integer(cadr(arg)))) || +#if WITH_PURE_S7 + ((fn_proc(arg) == g_length) && (is_string(cadr(arg))))) +#else + (((fn_proc(arg) == g_string_length) + || (fn_proc(arg) == g_length)) + && (is_string(cadr(arg))))) +#endif + { + set_opt3_con(arg, + make_permanent_integer((fn_proc(arg) == + g_abs) ? + s7_int_abs(integer + (cadr(arg))) + : + string_length(cadr + (arg)))); + return (fx_in_place); + } + return ((fn_proc(arg) == g_random_i) ? fx_random_i : fx_c_nc); + + case OP_OR_2A: + if (fx_proc(cddr(arg)) == fx_and_2a) { + set_opt3_pair(arg, cdaddr(arg)); + return (fx_or_and_2a); + } + if (fx_proc(cddr(arg)) == fx_and_3a) { + set_opt3_pair(arg, cdaddr(arg)); + return (fx_or_and_3a); + } + if ((fx_proc(cdr(arg)) == fx_not_is_symbol_s) + && (fx_proc(cddr(arg)) == fx_is_keyword_s) + && (cadr(cadadr(arg)) == cadaddr(arg))) { + /* (or (not (symbol? body)) (keyword? body)) */ + set_opt3_sym(arg, cadaddr(arg)); + return (fx_not_symbol_or_keyword); + } + return (fx_or_2a); + + case OP_AND_2A: + if ((fx_proc(cdr(arg)) == fx_or_2a) + && (fx_proc(cddr(arg)) == fx_or_2a)) { + s7_pointer o1 = cadr(arg), o2 = caddr(arg); + if ((fx_proc(cdr(o1)) == fx_gt_vref_s) + && (fx_proc(cddr(o1)) == fx_geq_s_vref) + && (fx_proc(cdr(o2)) == fx_gt_vref_s) + && (fx_proc(cddr(o2)) == fx_geq_s_vref)) { + s7_pointer v = cadr(cadadr(o1)); + if ((v == cadr(cadadr(o2))) + && (v == (cadr(caddaddr(o1)))) + && (v == (cadr(caddaddr(o2))))) { + s7_pointer x = caddadr(o1); + if ((x == caddadr(o2)) && (x == cadaddr(o1)) + && (x == cadaddr(o2))) { + s7_pointer i = caddr(cadadr(o1)), j = + caddaddr(caddr(o1)); + if ((j == caddr(cadadr(o2))) + && (i == caddaddr(caddr(o2)))) { + set_opt1_sym(o1, j); + set_opt3_sym(o1, i); + return (fx_and_or_2a_vref); + } + } + } + } + } + return (fx_and_2a); + + case HOP_SAFE_C_S: + if (is_unchanged_global(car(arg))) { + uint8_t typ; + if (car(arg) == sc->cdr_symbol) + return (fx_cdr_s); + if (car(arg) == sc->car_symbol) + return (fx_car_s); + if (car(arg) == sc->cadr_symbol) + return (fx_cadr_s); + if (car(arg) == sc->cddr_symbol) + return (fx_cddr_s); + if (car(arg) == sc->is_null_symbol) + return (fx_is_null_s); + if (car(arg) == sc->is_pair_symbol) + return (fx_is_pair_s); + if (car(arg) == sc->is_symbol_symbol) + return (fx_is_symbol_s); + if (car(arg) == sc->is_eof_object_symbol) + return (fx_is_eof_s); + if (car(arg) == sc->is_integer_symbol) + return (fx_is_integer_s); + if (car(arg) == sc->is_string_symbol) + return (fx_is_string_s); + if (car(arg) == sc->not_symbol) + return (fx_not_s); + if (car(arg) == sc->is_proper_list_symbol) + return (fx_is_proper_list_s); + if (car(arg) == sc->is_vector_symbol) + return (fx_is_vector_s); + if (car(arg) == sc->is_keyword_symbol) + return (fx_is_keyword_s); + if (car(arg) == sc->is_procedure_symbol) + return (fx_is_procedure_s); + if (car(arg) == sc->length_symbol) + return (fx_length_s); + /* not read_char here... */ + typ = symbol_type(car(arg)); + if (typ > 0) { + set_opt3_byte(cdr(arg), typ); + return (fx_is_type_s); + } + /* car_p_p (et al) does not look for a method so in: + * (define kar car) (load "mockery.scm") (let ((p (mock-pair '(1 2 3)))) (call-with-exit (lambda (x) (x (kar p))))) + * "kar" fails but not "car" because symbol_id(kar) == 0! symbol_id(car) > 0 because mockery provides a method for it. + */ + if (symbol_id(make_symbol(sc, c_function_name(global_value(car(arg))))) == 0) { /* yow! */ + s7_p_p_t f = s7_p_p_function(global_value(car(arg))); + if (f) { + set_opt2_direct(cdr(arg), (s7_pointer) f); + if (f == real_part_p_p) + return (fx_real_part_s); + if (f == imag_part_p_p) + return (fx_imag_part_s); + if (f == iterate_p_p) + return (fx_iterate_s); + if (f == car_p_p) + return (fx_car_s); /* can happen if (define var-name car) etc */ + return ((is_global(cadr(arg))) ? fx_c_g_direct : + fx_c_s_direct); + } + } + } + return ((is_global(cadr(arg))) ? fx_c_g : fx_c_s); + + case HOP_SAFE_C_SS: + if (fn_proc(arg) == g_cons) + return (fx_cons_ss); + if (fx_matches(car(arg), sc->num_eq_symbol)) + return (fx_num_eq_ss); + if (fn_proc(arg) == g_geq_2) + return (fx_geq_ss); + if (fn_proc(arg) == g_greater_2) + return (fx_gt_ss); + if (fn_proc(arg) == g_leq_2) + return (fx_leq_ss); + if (fn_proc(arg) == g_less_2) + return ((is_global(caddr(arg))) ? fx_lt_sg : fx_lt_ss); + if ((fx_matches(car(arg), sc->multiply_symbol)) + && (cadr(arg) == caddr(arg))) + return (fx_sqr_s); + if (fn_proc(arg) == g_multiply_2) + return (fx_multiply_ss); + if (fn_proc(arg) == g_is_eq) + return (fx_is_eq_ss); + if (fn_proc(arg) == g_add_2) + return (fx_add_ss); + if (fn_proc(arg) == g_subtract_2) + return (fx_subtract_ss); + if (fn_proc(arg) == g_hash_table_ref_2) + return (fx_hash_table_ref_ss); + + if (is_global_and_has_func(car(arg), s7_p_pp_function)) { + if (car(arg) == sc->assq_symbol) + return (fx_assq_ss); + if (car(arg) == sc->memq_symbol) + return (fx_memq_ss); + if (car(arg) == sc->vector_ref_symbol) + return (fx_vref_ss); + if (car(arg) == sc->string_ref_symbol) + return (fx_string_ref_ss); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value(car(arg))))); + return (fx_c_ss_direct); + } + /* fx_c_ss_direct via b_7pp is slower than fx_c_ss + g_<> */ + return (fx_c_ss); + + case HOP_SAFE_C_NS: + if (fn_proc(arg) == g_list) + return (fx_list_ns); + return ((fn_proc(arg) == g_vector) ? fx_vector_ns : fx_c_ns); + + case HOP_SAFE_C_opSq_S: + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caadr(arg), s7_p_p_function))) { + set_opt2_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value(car(arg))))); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_p_function + (global_value(caadr(arg))))); + return (((car(arg) == sc->cons_symbol) + && (caadr(arg) == + sc->car_symbol)) ? fx_cons_car_s_s : + fx_c_opsq_s_direct); + } + return (fx_c_opsq_s); + + case HOP_SAFE_C_SSS: + if ((fn_proc(arg) == g_less) && (is_global(cadr(arg))) + && (is_global(cadddr(arg)))) + return (fx_lt_gsg); + if (is_global_and_has_func(car(arg), s7_p_ppp_function)) { + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_ppp_function + (global_value(car(arg))))); + return (fx_c_sss_direct); + } + return (fx_c_sss); + + case HOP_SAFE_C_SSA: + if (is_global_and_has_func(car(arg), s7_p_ppp_function)) { + set_opt2_direct(cdr(arg), + (s7_pointer) (s7_p_ppp_function + (global_value(car(arg))))); + return (fx_c_ssa_direct); + } + return (fx_c_ssa); + + case HOP_SAFE_C_SCS: + if (is_global_and_has_func(car(arg), s7_p_ppp_function)) { + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_ppp_function + (global_value(car(arg))))); + return (fx_c_scs_direct); + } + return (fx_c_scs); + + case HOP_SAFE_C_AAA: + if ((fx_proc(cdr(arg)) == fx_g) + && (fx_proc(cdddr(arg)) == fx_c)) + return (fx_c_gac); + if ((is_unquoted_pair(cadr(arg))) + || (is_unquoted_pair(caddr(arg))) + || (is_unquoted_pair(cadddr(arg)))) + return (fx_c_aaa); + return (fx_c_3g); + + case HOP_SAFE_C_4A: + { + s7_pointer p; + for (p = cdr(arg); is_pair(p); p = cdr(p)) + if (is_unquoted_pair(car(p))) + break; + set_opt3_pair(arg, cdddr(arg)); + return ((is_null(p)) ? fx_c_4g : fx_c_4a); /* fx_c_ssaa doesn't save much */ + } + + case HOP_SAFE_C_S_opSSq: + { + s7_pointer s2 = caddr(arg); + if ((fx_matches(car(s2), sc->multiply_symbol)) + && (cadr(s2) == caddr(s2))) + return (fx_c_s_sqr); + + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(car(s2), s7_p_pp_function))) { + set_opt2_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value + (car(arg))))); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value + (car(s2))))); + set_opt3_pair(arg, cdr(s2)); + if (car(s2) == sc->vector_ref_symbol) { + if (car(arg) == sc->add_symbol) + return (fx_add_s_vref); + if (car(arg) == sc->subtract_symbol) + return (fx_subtract_s_vref); + if (car(arg) == sc->multiply_symbol) + return (fx_multiply_s_vref); + if (car(arg) == sc->geq_symbol) + return (fx_geq_s_vref); + if (car(arg) == sc->is_eq_symbol) + return (fx_is_eq_s_vref); + if (car(arg) == sc->hash_table_ref_symbol) + return (fx_href_s_vref); + if (car(arg) == sc->let_ref_symbol) + return (fx_lref_s_vref); + if ((is_global(cadr(arg))) && (is_global(cadr(s2))) + && (car(arg) == sc->vector_ref_symbol)) + return (fx_vref_g_vref_gs); + } + if ((car(arg) == sc->vector_ref_symbol) + && (car(s2) == sc->add_symbol)) + return (fx_vref_s_add); + return (fx_c_s_opssq_direct); + } + return (fx_c_s_opssq); + } + + case HOP_SAFE_C_opSSq_S: + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caadr(arg), s7_p_pp_function))) { + /* op_c_opgsq_t */ + set_opt2_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value(car(arg))))); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value(caadr(arg))))); + set_opt3_pair(arg, cdadr(arg)); + if (caadr(arg) == sc->vector_ref_symbol) { + if (car(arg) == sc->subtract_symbol) + return (fx_subtract_vref_s); + if (car(arg) == sc->gt_symbol) + return (fx_gt_vref_s); + if (car(arg) == sc->vector_ref_symbol) + return (fx_vref_vref_ss_s); + if (car(arg) == sc->add_symbol) + return (fx_add_vref_s); + } + if (car(arg) == sc->add_symbol) { + if ((caadr(arg) == sc->multiply_symbol) + && (cadadr(arg) == caddadr(arg))) + return (fx_add_sqr_s); + if (caadr(arg) == sc->subtract_symbol) + return (fx_add_sub_s); + } + if ((car(arg) == sc->cons_symbol) + && (caadr(arg) == sc->cons_symbol)) + return (fx_cons_cons_s); + /* also div(sub)[2] mul(div) */ + return (((car(arg) == sc->gt_symbol) + && (caadr(arg) == + sc->add_symbol)) ? fx_gt_add_s : (((car(arg) + == + sc->add_symbol) + && + (caadr(arg) + == + sc->multiply_symbol)) + ? + fx_add_mul_opssq_s + : + fx_c_opssq_s_direct)); + } + return (fx_c_opssq_s); + + case HOP_SAFE_C_opSSq_opSSq: + { + s7_pointer s1 = cadr(arg), s2 = caddr(arg); + set_opt3_pair(arg, cdr(s2)); + if ((fx_matches(car(s1), sc->multiply_symbol)) + && (car(s2) == sc->multiply_symbol)) { + set_opt1_pair(cdr(arg), cdr(s1)); + if (car(arg) == sc->subtract_symbol) + return (fx_sub_mul_mul); + if (car(arg) == sc->add_symbol) + return (((cadr(s1) == caddr(s1)) + && (cadr(s2) == + caddr(s2))) ? fx_add_sqr_sqr : + fx_add_mul_mul); + } + if ((fx_matches(car(s1), sc->subtract_symbol)) + && (car(s2) == sc->subtract_symbol)) { + set_opt1_pair(cdr(arg), cdr(s1)); + if (car(arg) == sc->multiply_symbol) + return (fx_mul_sub_sub); + if (car(arg) == sc->lt_symbol) + return (fx_lt_sub2); + } + if ((fx_matches(car(arg), sc->subtract_symbol)) + && (fx_matches(car(s1), sc->vector_ref_symbol)) + && (car(s2) == sc->vector_ref_symbol) + && (cadr(s1) == cadr(s2))) { + set_opt3_sym(arg, cadr(cdaddr(arg))); + return (fx_sub_vref2); + } + return (fx_c_opssq_opssq); + } + + case HOP_SAFE_C_opSq: + if (is_unchanged_global(caadr(arg))) { + if (fx_matches(car(arg), sc->is_pair_symbol)) { + if (caadr(arg) == sc->car_symbol) { + set_opt2_sym(cdr(arg), cadadr(arg)); + return (fx_is_pair_car_s); + } + if (caadr(arg) == sc->cdr_symbol) { + set_opt2_sym(cdr(arg), cadadr(arg)); + return (fx_is_pair_cdr_s); + } + if (caadr(arg) == sc->cadr_symbol) { + set_opt2_sym(cdr(arg), cadadr(arg)); + return (fx_is_pair_cadr_s); + } + if (caadr(arg) == sc->cddr_symbol) { + set_opt2_sym(cdr(arg), cadadr(arg)); + return (fx_is_pair_cddr_s); + } + } + if (fx_matches(car(arg), sc->is_null_symbol)) { + if (caadr(arg) == sc->cdr_symbol) { + set_opt2_sym(cdr(arg), cadadr(arg)); + return (fx_is_null_cdr_s); + } + if (caadr(arg) == sc->cadr_symbol) { + set_opt2_sym(cdr(arg), cadadr(arg)); + return (fx_is_null_cadr_s); + } + if (caadr(arg) == sc->cddr_symbol) { + set_opt2_sym(cdr(arg), cadadr(arg)); + return (fx_is_null_cddr_s); + } + } + if ((fx_matches(car(arg), sc->is_symbol_symbol)) && + (caadr(arg) == sc->cadr_symbol)) { + set_opt2_sym(cdr(arg), cadadr(arg)); + return (fx_is_symbol_cadr_s); + } + + if (fx_matches(car(arg), sc->not_symbol)) { + if (caadr(arg) == sc->is_pair_symbol) { + set_opt3_sym(arg, cadadr(arg)); + return (fx_not_is_pair_s); + } + if (caadr(arg) == sc->is_null_symbol) { + set_opt3_sym(arg, cadadr(arg)); + return (fx_not_is_null_s); + } + if (caadr(arg) == sc->is_symbol_symbol) { + set_opt3_sym(arg, cadadr(arg)); + return (fx_not_is_symbol_s); + } + return (fx_not_opsq); + } + if ((fx_matches(car(arg), sc->floor_symbol)) + && (caadr(arg) == sc->sqrt_symbol)) { + set_opt2_sym(cdr(arg), cadadr(arg)); + return (fx_floor_sqrt_s); + } + } + if (is_unchanged_global(car(arg))) { /* (? (op arg)) where (op arg) might return a let with a ? method etc */ + /* other possibility: fx_c_a */ + uint8_t typ = symbol_type(car(arg)); + if (typ > 0) { /* h_safe_c here so the type checker isn't shadowed */ + set_opt2_sym(cdr(arg), cadadr(arg)); + set_opt3_byte(cdr(arg), typ); + if (fn_proc(cadr(arg)) == + (s7_function) g_c_pointer_weak1) + return (fx_eq_weak1_type_s); + return (fx_matches(caadr(arg), sc->car_symbol) ? + fx_is_type_car_s : fx_is_type_opsq); + } + } + /* this should follow the is_type* check above */ + if (fx_matches(caadr(arg), sc->car_symbol)) { + set_opt2_sym(cdr(arg), cadadr(arg)); + return (fx_c_car_s); + } + if (fx_matches(caadr(arg), sc->cdr_symbol)) { + set_opt2_sym(cdr(arg), cadadr(arg)); + return (fx_c_cdr_s); + } + return (fx_c_opsq); + + case HOP_SAFE_C_SC: + if (is_unchanged_global(car(arg))) { + if (car(arg) == sc->add_symbol) { + if (is_t_real(caddr(arg))) + return (fx_add_sf); + if (is_t_integer(caddr(arg))) + return ((integer(caddr(arg)) == + 1) ? fx_add_s1 : fx_add_si); + } + if (car(arg) == sc->subtract_symbol) { + if (is_t_real(caddr(arg))) + return (fx_subtract_sf); + if (is_t_integer(caddr(arg))) + return ((integer(caddr(arg)) == + 1) ? fx_subtract_s1 : fx_subtract_si); + } + if (car(arg) == sc->multiply_symbol) { + if (is_t_real(caddr(arg))) + return (fx_multiply_sf); + if (is_t_integer(caddr(arg))) + return (fx_multiply_si); + } + if ((fn_proc(arg) == g_memq_2) && (is_pair(caddr(arg)))) + return (fx_memq_sq_2); + if ((fn_proc(arg) == g_is_eq) + && (!is_unspecified(caddr(arg)))) + return (fx_is_eq_sc); + + if ((is_t_integer(caddr(arg))) + && (s7_p_pi_function(global_value(car(arg))))) { + if (car(arg) == sc->num_eq_symbol) + return ((integer(caddr(arg)) == + 0) ? fx_num_eq_s0 : fx_num_eq_si); + if (car(arg) == sc->lt_symbol) + return (fx_lt_si); + if (car(arg) == sc->leq_symbol) + return (fx_leq_si); + if (car(arg) == sc->gt_symbol) + return (fx_gt_si); + if (car(arg) == sc->geq_symbol) + return (fx_geq_si); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pi_function + (global_value + (car(arg))))); + return (fx_c_si_direct); + } + if ((is_t_real(caddr(arg))) && (real(caddr(arg)) == 0.0) + && (car(arg) == sc->num_eq_symbol)) + return (fx_num_eq_s0f); + if ((s7_p_pp_function(global_value(car(arg)))) + && (fn_proc(arg) != g_divide_by_2)) { + if (car(arg) == sc->memq_symbol) { + if ((is_pair(caddr(arg))) + && (is_proper_list_3(sc, cadaddr(arg)))) + return (fx_memq_sc_3); + return (fx_memq_sc); + } + if ((car(arg) == sc->char_eq_symbol) + && (is_character(caddr(arg)))) + return (fx_char_eq_sc); /* maybe fx_char_eq_newline */ + if (car(arg) == sc->lt_symbol) + return (fx_lt_sc); /* integer case handled above */ + if (car(arg) == sc->leq_symbol) + return (fx_leq_sc); + if (car(arg) == sc->gt_symbol) + return (fx_gt_sc); + if (car(arg) == sc->geq_symbol) + return (fx_geq_sc); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value + (car(arg))))); + return (fx_c_sc_direct); + } + } + return (fx_c_sc); + + case HOP_SAFE_C_CS: + if (is_unchanged_global(car(arg))) { + if (car(arg) == sc->cons_symbol) + return (fx_cons_cs); + if ((car(arg) == sc->add_symbol) && (is_t_real(cadr(arg)))) + return (fx_add_fs); + if ((car(arg) == sc->subtract_symbol) + && (is_t_real(cadr(arg)))) + return (fx_subtract_fs); + if ((car(arg) == sc->num_eq_symbol) + && (cadr(arg) == int_zero)) + return (fx_num_eq_0s); + if (car(arg) == sc->multiply_symbol) { + if (is_t_real(cadr(arg))) + return (fx_multiply_fs); + if (is_t_integer(cadr(arg))) + return (fx_multiply_is); + } + } + return (fx_c_cs); + + case HOP_SAFE_C_S_opSq: + if (fx_matches(car(caddr(arg)), sc->car_symbol)) { + set_opt2_sym(cdr(arg), cadaddr(arg)); + if (fx_matches(car(arg), sc->hash_table_ref_symbol)) + return (fx_hash_table_ref_car); + return (fx_matches(car(arg), sc->add_symbol) ? + fx_add_s_car_s : fx_c_s_car_s); + } + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caaddr(arg), s7_p_p_function))) { + if ((car(arg) == sc->cons_symbol) + && (caaddr(arg) == sc->cdr_symbol)) { + set_opt2_sym(cdr(arg), cadaddr(arg)); + return (fx_cons_s_cdr_s); + } + set_opt1_sym(cdr(arg), cadaddr(arg)); + set_opt2_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value(car(arg))))); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_p_function + (global_value + (caaddr(arg))))); + return (fx_c_s_opsq_direct); + } + return (fx_c_s_opsq); + + case HOP_SAFE_C_C_opSq: + if (is_global_and_has_func(car(arg), s7_p_pp_function)) { + s7_pointer arg2 = caddr(arg); + if (is_global_and_has_func(car(arg2), s7_p_p_function)) { + set_opt2_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value + (car(arg))))); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_p_function + (global_value + (car(arg2))))); + set_opt1_sym(cdr(arg), cadr(arg2)); + return (fx_c_c_opsq_direct); + } + } + return (fx_c_c_opsq); + + case HOP_SAFE_C_opSq_C: + if (is_unchanged_global(car(arg))) { + if ((car(arg) == sc->memq_symbol) && + (fx_matches(caadr(arg), sc->car_symbol)) && + (is_proper_quote(sc, caddr(arg))) && + (is_pair(cadaddr(arg)))) + return ((s7_list_length(sc, opt2_con(cdr(arg))) == + 2) ? fx_memq_car_s_2 : fx_memq_car_s); + + if (car(arg) == sc->is_eq_symbol) { + if (((fx_matches(caadr(arg), sc->car_symbol)) + || (fx_matches(caadr(arg), sc->caar_symbol))) + && (is_proper_quote(sc, caddr(arg)))) { + set_opt3_sym(cdr(arg), cadadr(arg)); + set_opt2_con(cdr(arg), cadaddr(arg)); + return ((caadr(arg) == + sc->car_symbol) ? fx_is_eq_car_sq : + fx_is_eq_caar_sq); + } + } + if (((car(arg) == sc->lt_symbol) + || (car(arg) == sc->num_eq_symbol)) + && (is_t_integer(caddr(arg))) + && (fx_matches(caadr(arg), sc->length_symbol))) { + set_opt3_sym(cdr(arg), cadadr(arg)); + set_opt2_con(cdr(arg), caddr(arg)); + return ((car(arg) == + sc->lt_symbol) ? fx_less_length_i : + fx_num_eq_length_i); + } + } + set_opt1_sym(cdr(arg), cadadr(arg)); + return (fx_c_opsq_c); + + case HOP_SAFE_C_op_opSqq: + return ((fx_matches(car(arg), sc->not_symbol)) + ? ((fn_proc(cadr(arg)) == + g_is_pair) ? fx_not_is_pair_opsq : fx_not_op_opsqq) + : fx_c_op_opsqq); + + case HOP_SAFE_C_opSCq: + if (fx_matches(car(arg), sc->not_symbol)) { + if (fn_proc(cadr(arg)) == g_is_eq) { + set_opt2_sym(cdr(arg), cadadr(arg)); + set_opt3_con(cdr(arg), + (is_pair(caddadr(arg))) ? + cadaddr(cadr(arg)) : caddadr(arg)); + return (fx_not_is_eq_sq); + } + return (fx_not_opscq); + } + return (fx_c_opscq); + + case HOP_SAFE_C_S_opSCq: + if (is_global_and_has_func(car(arg), s7_p_pp_function)) { + s7_pointer arg2 = caddr(arg); + if ((is_global_and_has_func(car(arg2), s7_p_pi_function)) + && (is_t_integer(caddr(arg2)))) { + set_opt2_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value + (car(arg))))); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pi_function + (global_value + (car(arg2))))); + set_opt3_sym(arg, cadr(arg2)); + set_opt1_con(cdr(arg), caddr(arg2)); + if (car(arg) == sc->num_eq_symbol) { + if (car(arg2) == sc->add_symbol) + return (fx_num_eq_add_s_si); + if (car(arg2) == sc->subtract_symbol) + return (fx_num_eq_subtract_s_si); + } + if ((car(arg) == sc->vector_ref_symbol) + && (car(arg2) == sc->add_symbol) + && (integer(caddr(arg2)) == 1)) + return (fx_vref_p1); + return (fx_c_s_opsiq_direct); + } + if (is_global_and_has_func(car(arg2), s7_p_pp_function)) { + set_opt2_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value + (car(arg))))); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value + (car(arg2))))); + set_opt3_sym(arg, cadr(arg2)); + set_opt1_con(cdr(arg), + (is_pair(caddr(arg2))) ? cadaddr(arg2) : + caddr(arg2)); + return (fx_c_s_opscq_direct); + } + } + return (fx_c_s_opscq); + + case HOP_SAFE_C_opSSq: + if (fx_matches(car(arg), sc->not_symbol)) { + if (fn_proc(cadr(arg)) == g_is_eq) + return (fx_not_is_eq_ss); + return (fx_not_opssq); + } + if ((is_global_and_has_func(car(arg), s7_p_p_function)) && + (is_global_and_has_func(caadr(arg), s7_p_pp_function))) { + set_opt2_direct(cdr(arg), + (s7_pointer) (s7_p_p_function + (global_value(car(arg))))); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value(caadr(arg))))); + return (fx_c_opssq_direct); + } + return (fx_c_opssq); + + case HOP_SAFE_C_C_opSSq: + { + s7_pointer s2 = caddr(arg); + if ((fx_matches(car(s2), sc->multiply_symbol)) + && (cadr(s2) == caddr(s2))) + return (fx_c_c_sqr); + } + if ((is_small_real(cadr(arg))) && (is_global_and_has_func(car(arg), s7_p_dd_function)) && (is_global_and_has_func(caaddr(arg), s7_d_pd_function))) { /* not * currently (this is for clm) */ + set_opt3_direct(cdr(arg), + s7_d_pd_function(global_value + (caaddr(arg)))); + set_opt2_direct(cdr(arg), + s7_p_dd_function(global_value(car(arg)))); + set_opt3_sym(arg, cadaddr(arg)); + set_opt1_sym(cdr(arg), caddaddr(arg)); + return (fx_c_nc_opssq_direct); + } + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caaddr(arg), s7_p_pp_function))) { + set_opt2_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value(car(arg))))); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value + (caaddr(arg))))); + set_opt3_sym(arg, cadaddr(arg)); + set_opt1_sym(cdr(arg), caddaddr(arg)); + if ((is_t_real(cadr(arg))) && (car(arg) == caaddr(arg)) + && (car(arg) == sc->multiply_symbol)) + return (fx_multiply_c_opssq); + return (fx_c_c_opssq_direct); + } + return (fx_c_c_opssq); + + case HOP_SAFE_C_opSq_opSq: + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caadr(arg), s7_p_p_function)) && + (is_global_and_has_func(caaddr(arg), s7_p_p_function))) { + set_opt3_direct(arg, + (s7_pointer) (s7_p_pp_function + (global_value(car(arg))))); + set_opt2_direct(cdr(arg), + (s7_pointer) (s7_p_p_function + (global_value(caadr(arg))))); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_p_function + (global_value + (caaddr(arg))))); + if ((caadr(arg) == caaddr(arg)) + && (caadr(arg) == sc->cdr_symbol)) { + set_opt1_sym(cdr(arg), cadadr(arg)); + set_opt2_sym(cdr(arg), cadaddr(arg)); + return (fx_cdr_s_cdr_s); + } + set_opt1_sym(cdr(arg), cadaddr(arg)); /* opt2 is taken by second func */ + return (fx_c_opsq_opsq_direct); + } + return (fx_c_opsq_opsq); + + case HOP_SAFE_C_op_S_opSqq: + return ((fx_matches(car(arg), sc->not_symbol)) ? + fx_not_op_s_opsqq : fx_c_op_s_opsqq); + + case HOP_SAFE_C_op_opSSqq_S: + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caadr(arg), s7_p_p_function)) && + (is_global_and_has_func + (car(cadadr(arg)), s7_p_pp_function))) { + set_opt3_direct(arg, + (s7_pointer) (s7_p_pp_function + (global_value(car(arg))))); + set_opt2_direct(cdr(arg), + (s7_pointer) (s7_p_p_function + (global_value(caadr(arg))))); + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value + (caadr(cadr(arg)))))); + return (fx_c_op_opssqq_s_direct); + } + return (fx_c_op_opssqq_s); + + case HOP_SAFE_C_A: + if (fx_matches(car(arg), sc->not_symbol)) { + if (fx_proc(cdr(arg)) == fx_is_eq_car_sq) { + set_opt1_sym(cdr(arg), cadadr(cadr(arg))); + set_opt3_con(cdr(arg), cadaddr(cadr(arg))); + return (fx_not_is_eq_car_sq); + } + return (fx_not_a); + } + if (is_global_and_has_func(car(arg), s7_p_p_function)) { + set_opt3_direct(arg, + (s7_pointer) (s7_p_p_function + (global_value(car(arg))))); + return (fx_c_a_direct); + } + return (fx_c_a); + + case HOP_SAFE_C_AC: + if (fn_proc(arg) == g_cons) + return (fx_cons_ac); + if (fx_matches(car(arg), sc->is_eq_symbol)) + return (fx_is_eq_ac); + if (is_global_and_has_func(car(arg), s7_p_pp_function)) { + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value(car(arg))))); + if ((opt3_direct(cdr(arg)) == (s7_pointer) string_ref_p_pp) + && (is_t_integer(caddr(arg))) + && (integer(caddr(arg)) == 0)) + set_opt3_direct(cdr(arg), string_ref_p_p0); + if (opt3_direct(cdr(arg)) == (s7_pointer) memq_p_pp) { + if (fn_proc(arg) == g_memq_2) + set_opt3_direct(cdr(arg), + (s7_pointer) memq_2_p_pp); + else if ((is_pair(caddr(arg))) + && (is_proper_list_3(sc, cadaddr(arg)))) + set_opt3_direct(cdr(arg), memq_3_p_pp); + else if (fn_proc(arg) == g_memq_4) + set_opt3_direct(cdr(arg), memq_4_p_pp); /* this does not parallel 2 and 3 above (sigh) */ + } + return (fx_c_ac_direct); + } + return (fx_c_ac); + + case HOP_SAFE_C_CA: + return ((fn_proc(arg) == g_cons) ? fx_cons_ca : fx_c_ca); + + case HOP_SAFE_C_SA: + if (fn_proc(arg) == g_multiply_2) + return (fx_multiply_sa); + if (fn_proc(arg) == g_add_2) + return (fx_add_sa); + if (is_global_and_has_func(car(arg), s7_p_pp_function)) { + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value(car(arg))))); + return ((fn_proc(arg) == + g_cons) ? fx_cons_sa : fx_c_sa_direct); + } + return (fx_c_sa); + + case HOP_SAFE_C_AS: + if (fn_proc(arg) == g_add_2) + return (fx_add_as); + if (is_global_and_has_func(car(arg), s7_p_pp_function)) { + set_opt3_direct(cdr(arg), + (s7_pointer) (s7_p_pp_function + (global_value(car(arg))))); + return ((fn_proc(arg) == + g_cons) ? fx_cons_as : fx_c_as_direct); + } + return (fx_c_as); + + case HOP_SAFE_C_AA: + /* (* wr (float-vector-ref rl 0 j)) (* wr (block-ref (vector-ref rl j) 0)) (- (float-vector-ref rl 0 i) tempr) */ + if (fn_proc(arg) == g_add_2) + return (fx_add_aa); + if (fn_proc(arg) == g_subtract_2) + return (fx_subtract_aa); + if (fn_proc(arg) == g_multiply_2) + return (fx_multiply_aa); + if (fn_proc(arg) == g_number_to_string) + return (fx_number_to_string_aa); + if (fn_proc(arg) == g_cons) + return (fx_cons_aa); + /* we can get here from gx_annotate which does not call fx_tree, where A=fx_unsafe_s */ + if (fx_proc(cdr(arg)) == fx_unsafe_s) + return (fx_c_za); + return (fx_c_aa); + + case HOP_SAFE_C_opAAq: + return ((fx_proc(cdadr(arg)) == + fx_s) ? fx_c_opsaq : fx_c_opaaq); + + case HOP_SAFE_C_NA: + return ((fn_proc(arg) == + g_vector) ? fx_vector_all_a : fx_c_na); + + case HOP_SAFE_C_ALL_CA: + return ((fn_proc(arg) == + g_simple_inlet) ? fx_inlet_ca : fx_c_all_ca); + + case HOP_SAFE_CLOSURE_S_A: + { + s7_pointer body = car(closure_body(opt1_lambda(arg))); + if (is_pair(body)) { + if (optimize_op(body) == OP_AND_2A) { + if ((fx_matches(caadr(body), sc->is_pair_symbol)) + && (cadadr(body) == + car(closure_args(opt1_lambda(arg))))) + return (fx_safe_closure_s_and_pair); /* lint arg: (len>1? init), args: (x) body: (and (pair? x) (pair? (cdr x))) */ + return (fx_safe_closure_s_and_2a); + } + if (optimize_op(body) == HOP_SAFE_C_opSq_C) { + if ((fn_proc(body) == g_lint_let_ref) && + (cadadr(body) == + car(closure_args(opt1_lambda(arg))))) { + set_opt2_sym(cdr(arg), cadaddr(body)); + return (fx_lint_let_ref_s); /* (var-ref local-var) -> (let-ref (cdr v=local_var) 'ref) */ + } + } + } + return ((fx_proc(closure_body(opt1_lambda(arg))) == + fx_sqr_t) ? fx_safe_closure_s_sqr : + fx_safe_closure_s_a); + } + + case HOP_SAFE_CLOSURE_S_TO_SC: + { + s7_pointer body = car(closure_body(opt1_lambda(arg))); + if (fn_proc(body) == g_vector_ref_2) + return (fx_safe_closure_s_to_vref); + if ((is_t_integer(caddr(body))) + && (integer(caddr(body)) == 1)) { + if (car(body) == sc->subtract_symbol) + return (fx_safe_closure_s_to_sub1); + if (car(body) == sc->add_symbol) + return (fx_safe_closure_s_to_add1); + } + return (fx_safe_closure_s_to_sc); + } + + case HOP_SAFE_CLOSURE_A_TO_SC: + return ((fn_proc(car(closure_body(opt1_lambda(arg)))) == + g_vector_ref_2) ? fx_safe_closure_a_to_vref : + fx_safe_closure_a_to_sc); + + case HOP_SAFE_CLOSURE_A_A: + if (fx_proc(closure_body(opt1_lambda(arg))) == fx_and_2a) + return (fx_safe_closure_a_and_2a); + return ((fx_proc(closure_body(opt1_lambda(arg))) == + fx_sqr_t) ? fx_safe_closure_a_sqr : + fx_safe_closure_a_a); + + case HOP_SAFE_CLOSURE_3S_A: + if (fx_proc(closure_body(opt1_lambda(arg))) == + fx_vref_vref_tu_v) + return (fx_vref_vref_3_no_let); + + default: + /* if ((!fx_function[optimize_op(arg)]) && (is_h_optimized(arg))) fprintf(stderr, "fx_choose %s %s\n", op_names[optimize_op(arg)], display(arg)); */ + return (fx_function[optimize_op(arg)]); + } + } /* is_optimized */ + + if ((car(arg) == sc->quote_symbol) && (is_global(sc->quote_symbol))) { + check_quote(sc, arg); + return (fx_q); + } + return (NULL); +} + +#if S7_DEBUGGING +#define with_fx(P, F) with_fx_1(sc, P, F) +static bool with_fx_1(s7_scheme * sc, s7_pointer p, s7_function f) /* sc needed for set_opt2 under debugger = set_opt2_1(sc,...) */ +#else +static bool with_fx(s7_pointer p, s7_function f) +#endif +{ + set_fx_direct(p, f); + return (true); +} + +static bool o_var_ok(s7_pointer p, s7_pointer var1, s7_pointer var2, + s7_pointer var3) +{ + return ((p != var1) && (p != var2) && (p != var3)); +} + +static bool fx_tree_out(s7_scheme * sc, s7_pointer tree, s7_pointer var1, + s7_pointer var2, s7_pointer var3, bool more_vars) +{ + s7_pointer p = car(tree); + /* if (fx_proc(tree) == fx_iterate_o) fprintf(stderr, "[%d] %s %s %s %s\n", __LINE__, display(p), display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : ""); */ + /* fprintf(stderr, "%s[%d] %s %s %d: %s\n", __func__, __LINE__, display(var1), (var2) ? display(var2) : "", has_fx(tree), display(tree)); */ + if (is_symbol(p)) { + if ((fx_proc(tree) == fx_s) || (fx_proc(tree) == fx_o)) { + if (p == var1) + return (with_fx(tree, fx_T)); + if (p == var2) + return (with_fx(tree, fx_U)); + /* if O possible, make sure fx_tree_in checked all vars and its own more_vars -- ideally "o" coming in */ + } + return (false); + } + if ((is_pair(p)) && (is_pair(cdr(p)))) { + if (cadr(p) == var1) { + if ((fx_proc(tree) == fx_c_s) || (fx_proc(tree) == fx_c_o)) + return (with_fx(tree, fx_c_T)); /* fx_c_T_direct got no hits */ + if (fx_proc(tree) == fx_is_null_s) + return (with_fx(tree, fx_is_null_T)); + if (fx_proc(tree) == fx_subtract_s1) + return (with_fx(tree, fx_subtract_T1)); + if (fx_proc(tree) == fx_add_s1) + return (with_fx(tree, fx_add_T1)); + if (fx_proc(tree) == fx_c_sca) + return (with_fx(tree, fx_c_Tca)); + if ((fx_proc(tree) == fx_num_eq_si) + || (fx_proc(tree) == fx_num_eq_s0)) + return (with_fx(tree, fx_num_eq_Ti)); + if (fx_proc(tree) == fx_multiply_ss) + return (with_fx(tree, fx_multiply_Ts)); + if ((fx_proc(tree) == fx_c_scs_direct) && (cadddr(p) == var2)) + return (with_fx(tree, fx_c_TcU_direct)); + } else if (cadr(p) == var2) { + if (fx_proc(tree) == fx_subtract_s1) + return (with_fx(tree, fx_subtract_U1)); + if (fx_proc(tree) == fx_add_s1) + return (with_fx(tree, fx_add_U1)); + } else if (cadr(p) == var3) { + if (fx_proc(tree) == fx_add_s1) + return (with_fx(tree, fx_add_V1)); + } else if (is_pair(cddr(p))) { + if (caddr(p) == var1) { + if ((fx_proc(tree) == fx_num_eq_ts) + || (fx_proc(tree) == fx_num_eq_to)) + return (with_fx(tree, fx_num_eq_tT)); + if ((fx_proc(tree) == fx_gt_ts) + || (fx_proc(tree) == fx_gt_to)) + return (with_fx(tree, fx_gt_tT)); + if (fx_proc(tree) == fx_lt_ts) + return (with_fx(tree, fx_lt_tT)); + if ((fx_proc(tree) == fx_geq_ts) + || (fx_proc(tree) == fx_geq_to)) + return (with_fx(tree, fx_geq_tT)); + } else if (caddr(p) == var2) { + if (fx_proc(tree) == fx_c_ts) + return (with_fx(tree, fx_c_tU)); + if (fx_proc(tree) == fx_cons_ts) + return (with_fx(tree, fx_cons_tU)); + if (fx_proc(tree) == fx_c_ts_direct) + return (with_fx(tree, fx_c_tU_direct)); + if (fx_proc(tree) == fx_lt_ts) + return (with_fx(tree, fx_lt_tU)); + } else { + if ((!more_vars) && (caddr(p) != var3) + && ((fx_proc(tree) == fx_num_eq_ts) + || (fx_proc(tree) == fx_num_eq_to))) + return (with_fx(tree, fx_num_eq_tO)); + if ((fx_proc(tree) == fx_add_sqr_s) && (cadadr(p) == var1)) + return (with_fx(tree, fx_add_sqr_T)); + } + } + } + return (false); +} + +static s7_b_7p_t s7_b_7p_function(s7_pointer f); + +static bool fx_tree_in(s7_scheme * sc, s7_pointer tree, s7_pointer var1, + s7_pointer var2, s7_pointer var3, bool more_vars) +{ + s7_pointer p = car(tree); +#if 0 + /* if ((s7_tree_memq(sc, var1, car(tree))) || ((var2) && (s7_tree_memq(sc, var2, car(tree)))) || ((var3) && (s7_tree_memq(sc, var3, car(tree))))) */ + if (fx_proc(tree) == fx_c_s_opssq_direct) + fprintf(stderr, "fx_tree_in %s %s %s %s: %s\n", + op_names[optimize_op(car(tree))], display(var1), + (var2) ? display(var2) : "", (var3) ? display(var3) : "", + display_80(car(tree))); +#endif + if (is_symbol(p)) { + if (fx_proc(tree) == fx_s) { + if (p == var1) + return (with_fx(tree, fx_t)); + if (p == var2) + return (with_fx(tree, fx_u)); + if (p == var3) + return (with_fx(tree, fx_v)); + if (is_global(p)) + return (with_fx(tree, fx_g)); + if (!more_vars) + return (with_fx(tree, fx_o)); + } + return (false); + } + if ((S7_DEBUGGING) && (!has_fx(tree))) + fprintf(stderr, "%s[%d]: no fx! %s\n", __func__, __LINE__, + display_80(p)); + if ((!is_pair(p)) || (is_fx_treed(tree))) + return (false); + set_fx_treed(tree); + switch (optimize_op(p)) { + case HOP_SAFE_C_S: + if (cadr(p) == var1) { + if (fx_proc(tree) == fx_c_s) + return (with_fx(tree, fx_c_t)); + if (fx_proc(tree) == fx_c_s_direct) + return (with_fx + (tree, + (opt2_direct(cdr(p)) == + (s7_pointer) cddr_p_p) ? fx_cddr_t : + fx_c_t_direct)); + if (fx_proc(tree) == fx_car_s) + return (with_fx(tree, fx_car_t)); + if (fx_proc(tree) == fx_cdr_s) + return (with_fx(tree, fx_cdr_t)); + if (fx_proc(tree) == fx_cddr_s) + return (with_fx(tree, fx_cddr_t)); + if (fx_proc(tree) == fx_cadr_s) + return (with_fx(tree, fx_cadr_t)); + if (fx_proc(tree) == fx_not_s) + return (with_fx(tree, fx_not_t)); + if (fx_proc(tree) == fx_is_null_s) + return (with_fx(tree, fx_is_null_t)); + if (fx_proc(tree) == fx_is_pair_s) + return (with_fx(tree, fx_is_pair_t)); + if (fx_proc(tree) == fx_is_symbol_s) + return (with_fx(tree, fx_is_symbol_t)); + if (fx_proc(tree) == fx_is_eof_s) + return (with_fx(tree, fx_is_eof_t)); + if (fx_proc(tree) == fx_is_string_s) + return (with_fx(tree, fx_is_string_t)); + if (fx_proc(tree) == fx_is_vector_s) + return (with_fx(tree, fx_is_vector_t)); + if (fx_proc(tree) == fx_is_integer_s) + return (with_fx(tree, fx_is_integer_t)); + if (fx_proc(tree) == fx_is_procedure_s) + return (with_fx(tree, fx_is_procedure_t)); + if (fx_proc(tree) == fx_is_type_s) + return (with_fx(tree, fx_is_type_t)); + if (fx_proc(tree) == fx_length_s) + return (with_fx(tree, fx_length_t)); + if (fx_proc(tree) == fx_real_part_s) + return (with_fx(tree, fx_real_part_t)); + if (fx_proc(tree) == fx_imag_part_s) + return (with_fx(tree, fx_imag_part_t)); + return (false); + } + if (cadr(p) == var2) { + if (fx_proc(tree) == fx_c_s) { + if (is_global_and_has_func(car(p), s7_p_p_function)) { + set_opt2_direct(cdr(p), + (s7_pointer) (s7_p_p_function + (global_value(car(p))))); + return (with_fx + (tree, + (car(p) == + sc->cddr_symbol) ? fx_cddr_u : ((car(p) == + sc->is_positive_symbol) + ? + fx_is_positive_u + : ((car(p) == + sc->is_zero_symbol) + ? + fx_is_zero_u + : + fx_c_u_direct)))); + } + return (with_fx(tree, fx_c_u)); + } + if (fx_proc(tree) == fx_c_s_direct) + return (with_fx + (tree, + (car(p) == + sc->cddr_symbol) ? fx_cddr_u : ((car(p) == + sc->is_positive_symbol) + ? + fx_is_positive_u + : ((car(p) == + sc->is_zero_symbol) + ? fx_is_zero_u + : + fx_c_u_direct)))); + + if (fx_proc(tree) == fx_cdr_s) + return (with_fx(tree, fx_cdr_u)); + if (fx_proc(tree) == fx_cadr_s) + return (with_fx(tree, fx_cadr_u)); + if (fx_proc(tree) == fx_cddr_s) + return (with_fx(tree, fx_cddr_u)); + if (fx_proc(tree) == fx_car_s) + return (with_fx(tree, fx_car_u)); + if (fx_proc(tree) == fx_is_null_s) + return (with_fx(tree, fx_is_null_u)); + if (fx_proc(tree) == fx_is_type_s) + return (with_fx(tree, fx_is_type_u)); + if (fx_proc(tree) == fx_is_pair_s) + return (with_fx(tree, fx_is_pair_u)); + if (fx_proc(tree) == fx_is_symbol_s) + return (with_fx(tree, fx_is_symbol_u)); + if (fx_proc(tree) == fx_is_eof_s) + return (with_fx(tree, fx_is_eof_u)); + return (false); + } + if (cadr(p) == var3) { + if (fx_proc(tree) == fx_cdr_s) + return (with_fx(tree, fx_cdr_v)); + if (fx_proc(tree) == fx_is_null_s) + return (with_fx(tree, fx_is_null_v)); + if (fx_proc(tree) == fx_is_pair_s) + return (with_fx(tree, fx_is_pair_v)); + if (fx_proc(tree) == fx_c_s) + return (with_fx(tree, fx_c_v)); + if (fx_proc(tree) == fx_c_s_direct) + return (with_fx(tree, fx_c_v_direct)); + return (false); + } + if (!more_vars) { + if (fx_proc(tree) == fx_is_null_s) + return (with_fx(tree, fx_is_null_o)); + if (fx_proc(tree) == fx_car_s) + return (with_fx(tree, fx_car_o)); + if (fx_proc(tree) == fx_cdr_s) + return (with_fx(tree, fx_cdr_o)); + if (fx_proc(tree) == fx_cadr_s) + return (with_fx(tree, fx_cadr_o)); + if (fx_proc(tree) == fx_cddr_s) + return (with_fx(tree, fx_cddr_o)); + if (fx_proc(tree) == fx_iterate_s) + return (with_fx(tree, fx_iterate_o)); + if (fx_proc(tree) == fx_not_s) + return (with_fx(tree, fx_not_o)); + if (fx_proc(tree) == fx_c_s_direct) + return (with_fx(tree, fx_c_o_direct)); + if (fx_proc(tree) == fx_c_s) + return (with_fx(tree, fx_c_o)); + } + break; + + case HOP_SAFE_C_SC: + /* fprintf(stderr, "%s %d %s %s %s\n", display(p), cadr(p) == var3, display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : ""); */ + if (cadr(p) == var1) { + if ((fx_proc(tree) == fx_char_eq_sc) + || (fn_proc(p) == g_char_equal_2)) + return (with_fx(tree, fx_char_eq_tc)); + if (fx_proc(tree) == fx_c_sc) + return (with_fx(tree, fx_c_tc)); + if (fx_proc(tree) == fx_add_sf) + return (with_fx(tree, fx_add_tf)); + if (fn_proc(p) == g_less_xf) + return (with_fx(tree, fx_lt_tf)); + if (fn_proc(p) == g_less_x0) + return (with_fx(tree, fx_lt_t0)); + if (fn_proc(p) == g_less_xi) + return (with_fx + (tree, + (integer(caddr(p)) == + 2) ? fx_lt_t2 : ((integer(caddr(p)) == + 1) ? fx_lt_t1 : fx_lt_ti))); + if (fn_proc(p) == g_geq_xf) + return (with_fx(tree, fx_geq_tf)); + if (fn_proc(p) == g_geq_xi) + return (with_fx + (tree, + (integer(caddr(p)) == + 0) ? fx_geq_t0 : fx_geq_ti)); + if (fn_proc(p) == g_leq_xi) + return (with_fx(tree, fx_leq_ti)); + if (fn_proc(p) == g_greater_xi) + return (with_fx(tree, fx_gt_ti)); + + if (fx_proc(tree) == fx_c_sc_direct) { /* p_pp cases */ + if ((opt3_direct(cdr(p)) == (s7_pointer) vector_ref_p_pp) + && (is_t_integer(caddr(p)))) + return (with_fx(tree, fx_vector_ref_tc)); + if ((opt3_direct(cdr(p)) == (s7_pointer) string_ref_p_pp) + && (is_t_integer(caddr(p))) + && (integer(caddr(p)) == 0)) + set_opt3_direct(cdr(p), string_ref_p_p0); + return (with_fx(tree, fx_c_tc_direct)); + } + if (fx_proc(tree) == fx_c_si_direct) { /* p_pi cases */ + if (opt3_direct(cdr(p)) == (s7_pointer) vector_ref_p_pi) + return (with_fx(tree, fx_vector_ref_tc)); + if ((opt3_direct(cdr(p)) == (s7_pointer) string_ref_p_pi) + && (integer(caddr(p)) == 0)) + set_opt3_direct(cdr(p), string_ref_p_p0); + return (with_fx(tree, fx_c_ti_direct)); + } + + if (fx_proc(tree) == fx_is_eq_sc) + return (with_fx(tree, fx_is_eq_tc)); + if (fx_proc(tree) == fx_add_s1) + return (with_fx(tree, fx_add_t1)); + if (fx_proc(tree) == fx_subtract_s1) + return (with_fx(tree, fx_subtract_t1)); + if (fx_proc(tree) == fx_subtract_si) + return (with_fx(tree, fx_subtract_ti)); + if (fx_proc(tree) == fx_subtract_sf) + return (with_fx(tree, fx_subtract_tf)); + if (fx_proc(tree) == fx_multiply_sf) + return (with_fx(tree, fx_multiply_tf)); + if (fx_proc(tree) == fx_lt_si) /* is this ever hit? */ + return (with_fx + (tree, + (integer(caddr(p)) == + 2) ? fx_lt_t2 : ((integer(caddr(p)) == + 1) ? fx_lt_t1 : fx_lt_ti))); + if (fx_proc(tree) == fx_leq_si) + return (with_fx(tree, fx_leq_ti)); + if (fx_proc(tree) == fx_gt_si) + return (with_fx(tree, fx_gt_ti)); + if (fx_proc(tree) == fx_num_eq_si) + return (with_fx(tree, fx_num_eq_ti)); + if (fx_proc(tree) == fx_num_eq_s0) + return (with_fx(tree, fx_num_eq_t0)); + if (fx_proc(tree) == fx_memq_sc) + return (with_fx(tree, fx_memq_tc)); + return (false); + } + if (cadr(p) == var2) { + if (fx_proc(tree) == fx_c_sc) + return (with_fx(tree, fx_c_uc)); + if (fx_proc(tree) == fx_num_eq_s0) + return (with_fx(tree, fx_num_eq_u0)); + if (fx_proc(tree) == fx_num_eq_si) + return (with_fx(tree, fx_num_eq_ui)); + if (fx_proc(tree) == fx_add_s1) + return (with_fx(tree, fx_add_u1)); + if (fx_proc(tree) == fx_subtract_s1) + return (with_fx(tree, fx_subtract_u1)); + return (false); + } + if (cadr(p) == var3) { + if (fx_proc(tree) == fx_num_eq_s0) + return (with_fx(tree, fx_num_eq_v0)); + if (fx_proc(tree) == fx_num_eq_si) + return (with_fx(tree, fx_num_eq_vi)); + if (fx_proc(tree) == fx_c_sc) + return (with_fx(tree, fx_c_vc)); + return (false); + } + break; + + case HOP_SAFE_C_CS: + if (caddr(p) == var1) { + if ((car(p) == sc->cons_symbol) + && (is_unchanged_global(sc->cons_symbol))) + return (with_fx(tree, fx_cons_ct)); + if (fx_proc(tree) == fx_c_cs) { + if (is_global_and_has_func(car(p), s7_p_pp_function)) { + if (fn_proc(p) == g_tree_set_memq_1) + set_opt3_direct(cdr(p), + (s7_pointer) tree_set_memq_direct); + else + set_opt3_direct(cdr(p), + (s7_pointer) (s7_p_pp_function + (global_value + (car(p))))); + set_fx_direct(tree, fx_c_ct_direct); + } else + set_fx_direct(tree, fx_c_ct); + return (true); + } + } + if ((caddr(p) == var2) && (fx_proc(tree) == fx_c_cs)) + return (with_fx(tree, fx_c_cu)); + break; + + case HOP_SAFE_C_SS: + if (cadr(p) == var1) { + if (fx_proc(tree) == fx_c_ss) + return (with_fx + (tree, (caddr(p) == var2) ? fx_c_tu : fx_c_ts)); + if (fx_proc(tree) == fx_c_ss_direct) + return (with_fx(tree, fx_c_ts_direct)); + if (fx_proc(tree) == fx_add_ss) + return (with_fx + (tree, + (caddr(p) == var2) ? fx_add_tu : fx_add_ts)); + if (fx_proc(tree) == fx_subtract_ss) + return (with_fx + (tree, + (caddr(p) == + var2) ? fx_subtract_tu : fx_subtract_ts)); + if (fx_proc(tree) == fx_cons_ss) + return (with_fx(tree, fx_cons_ts)); + if (caddr(p) == var2) { + if (fx_proc(tree) == fx_gt_ss) + return (with_fx(tree, fx_gt_tu)); + if (fx_proc(tree) == fx_lt_ss) + return (with_fx(tree, fx_lt_tu)); + if (fx_proc(tree) == fx_leq_ss) + return (with_fx(tree, fx_leq_tu)); + if (fx_proc(tree) == fx_geq_ss) + return (with_fx(tree, fx_geq_tu)); + if (fx_proc(tree) == fx_multiply_ss) + return (with_fx(tree, fx_multiply_tu)); + if (fx_proc(tree) == fx_num_eq_ss) + return (with_fx(tree, fx_num_eq_tu)); + if (fx_proc(tree) == fx_memq_ss) + return (with_fx(tree, fx_memq_tu)); + } + if (fx_proc(tree) == fx_multiply_ss) + return (with_fx(tree, fx_multiply_ts)); + if (fx_proc(tree) == fx_num_eq_ss) { + if (is_global(caddr(p))) + return (with_fx(tree, fx_num_eq_tg)); + if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) + return (with_fx(tree, fx_num_eq_to)); + return (with_fx(tree, fx_num_eq_ts)); + } + if (fx_proc(tree) == fx_geq_ss) { + if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) + return (with_fx(tree, fx_geq_to)); + return (with_fx(tree, fx_geq_ts)); + } + if (fx_proc(tree) == fx_leq_ss) + return (with_fx(tree, fx_leq_ts)); + if (fx_proc(tree) == fx_lt_ss) + return (with_fx(tree, fx_lt_ts)); + if (fx_proc(tree) == fx_lt_sg) + return (with_fx(tree, fx_lt_tg)); + if (fx_proc(tree) == fx_gt_ss) { + if (is_global(caddr(p))) + return (with_fx(tree, fx_gt_tg)); + if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) + return (with_fx(tree, fx_gt_to)); + return (with_fx(tree, fx_gt_ts)); + } + if (fx_proc(tree) == fx_sqr_s) + return (with_fx(tree, fx_sqr_t)); + if (fx_proc(tree) == fx_is_eq_ss) { + if (caddr(p) == var2) + return (with_fx(tree, fx_is_eq_tu)); + if ((!more_vars) && (caddr(p) != var3) + && (caddr(p) != var1)) + return (with_fx(tree, fx_is_eq_to)); + return (with_fx(tree, fx_is_eq_ts)); + } + if (fx_proc(tree) == fx_vref_ss) { + if (caddr(p) == var2) + return (with_fx(tree, fx_vref_tu)); + return (with_fx(tree, fx_vref_ts)); + } + } + if (caddr(p) == var1) { + if (fx_proc(tree) == fx_c_ss) + return (with_fx(tree, fx_c_st)); + if (fx_proc(tree) == fx_c_ss_direct) { + return (with_fx + (tree, + (is_global(cadr(p))) ? fx_c_gt_direct : + fx_c_st_direct)); + } + if (fx_proc(tree) == fx_hash_table_ref_ss) + return (with_fx(tree, fx_hash_table_ref_st)); + if (fx_proc(tree) == fx_cons_ss) + return (with_fx(tree, fx_cons_st)); + if (fx_proc(tree) == fx_vref_ss) { + if (is_global(cadr(p))) + return (with_fx(tree, fx_vref_gt)); + if ((!more_vars) && (cadr(p) != var2) && (cadr(p) != var3)) + return (with_fx(tree, fx_vref_ot)); + return (with_fx(tree, fx_vref_st)); + } + if ((fx_proc(tree) == fx_gt_ss) && (cadr(p) == var2)) + return (with_fx(tree, fx_gt_ut)); + if ((fx_proc(tree) == fx_lt_ss) && (cadr(p) == var2)) + return (with_fx(tree, fx_lt_ut)); + if ((fx_proc(tree) == fx_geq_ss)) { + if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3))) + return (with_fx(tree, fx_geq_ot)); + return (with_fx(tree, fx_geq_st)); + } + } + if (cadr(p) == var2) { + if (fx_proc(tree) == fx_num_eq_ss) + return (with_fx + (tree, + (caddr(p) == + var1) ? fx_num_eq_ut : fx_num_eq_us)); + if (fx_proc(tree) == fx_geq_ss) + return (with_fx(tree, fx_geq_us)); + if (fx_proc(tree) == fx_add_ss) + return (with_fx + (tree, + (caddr(p) == var1) ? fx_add_ut : fx_add_us)); + if (fx_proc(tree) == fx_subtract_ss) + return (with_fx + (tree, + (caddr(p) == + var1) ? fx_subtract_ut : fx_subtract_us)); + if (caddr(p) == var3) + return (with_fx(tree, fx_c_uv)); + } + if (cadr(p) == var3) { + if (fx_proc(tree) == fx_num_eq_ss) + return (with_fx(tree, fx_num_eq_vs)); + if ((fx_proc(tree) == fx_add_ss) && (caddr(p) == var2)) + return (with_fx(tree, fx_add_vu)); + if (fx_proc(tree) == fx_geq_ss) + return (with_fx(tree, fx_geq_vs)); + } + break; + + case HOP_SAFE_C_AS: + if (caddr(p) == var1) + return (with_fx(tree, fx_c_at)); + break; + + case HOP_SAFE_C_SA: + if (cadr(p) == var1) { + if ((fx_proc(cddr(p)) == fx_c_opsq_c) && + (cadadr(caddr(p)) == var1) && + (is_t_integer(caddaddr(p))) && + (integer(caddaddr(p)) == 1) && + (car(p) == sc->string_ref_symbol) && + (caaddr(p) == sc->subtract_symbol) && +#if (!WITH_PURE_S7) + ((caadr(caddr(p)) == sc->string_length_symbol) + || (caadr(caddr(p)) == sc->length_symbol))) +#else + (caadr(caddr(p)) == sc->length_symbol)) +#endif + return (with_fx(tree, fx_string_ref_t_last)); + return (with_fx(tree, fx_c_ta)); + } + if (cadr(p) == var2) + return (with_fx + (tree, + (fx_proc(tree) == + fx_c_sa_direct) ? fx_c_ua_direct : fx_c_ua)); + break; + + case HOP_SAFE_C_SCS: + if (cadr(p) == var1) { + if (fx_proc(tree) == fx_c_scs) + return (with_fx(tree, fx_c_tcs)); + if (fx_proc(tree) == fx_c_scs_direct) + return (with_fx + (tree, + (cadddr(p) == + var2) ? fx_c_tcu_direct : fx_c_tcs_direct)); + } + break; + + case HOP_SAFE_C_SSC: + if ((cadr(p) == var1) && (caddr(p) == var2)) + return (with_fx(tree, fx_c_tuc)); + break; + + case HOP_SAFE_C_CSS: + if ((caddr(p) == var1) && (cadddr(p) == var3)) + return (with_fx(tree, fx_c_ctv)); + break; + + case HOP_SAFE_C_SSS: + if ((cadr(p) == var1) + && ((caddr(p) == var2) + && ((fx_proc(tree) == fx_c_sss) + || (fx_proc(tree) == fx_c_sss_direct)))) + return (with_fx + (tree, (cadddr(p) == var3) ? fx_c_tuv : fx_c_tus)); + if (caddr(p) == var1) { + if (car(p) == sc->vector_set_symbol) { + if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3)) + && (o_var_ok(cadddr(p), var1, var2, var3))) + return (with_fx(tree, fx_vset_oto)); + return (with_fx(tree, fx_vset_sts)); + } + return (with_fx(tree, fx_c_sts)); + } + break; + + case HOP_SAFE_C_opSq: + if (cadadr(p) == var1) { + if (fx_proc(tree) == fx_is_pair_car_s) + return (with_fx(tree, fx_is_pair_car_t)); + if (fx_proc(tree) == fx_is_pair_cdr_s) + return (with_fx(tree, fx_is_pair_cdr_t)); + if (fx_proc(tree) == fx_is_pair_cadr_s) + return (with_fx(tree, fx_is_pair_cadr_t)); + if (fx_proc(tree) == fx_is_symbol_cadr_s) + return (with_fx(tree, fx_is_symbol_cadr_t)); + if (fx_proc(tree) == fx_is_pair_cddr_s) + return (with_fx(tree, fx_is_pair_cddr_t)); + if (fx_proc(tree) == fx_is_null_cdr_s) + return (with_fx(tree, fx_is_null_cdr_t)); + if (fx_proc(tree) == fx_is_null_cadr_s) + return (with_fx(tree, fx_is_null_cadr_t)); + if (fx_proc(tree) == fx_is_null_cddr_s) + return (with_fx(tree, fx_is_null_cddr_t)); + if (fx_proc(tree) == fx_not_is_pair_s) + return (with_fx(tree, fx_not_is_pair_t)); + if (fx_proc(tree) == fx_not_is_null_s) + return (with_fx(tree, fx_not_is_null_t)); + if (fx_proc(tree) == fx_not_is_symbol_s) + return (with_fx(tree, fx_not_is_symbol_t)); + if (fx_proc(tree) == fx_is_type_car_s) + return (with_fx + (tree, + (car(p) == + sc->is_symbol_symbol) ? fx_is_symbol_car_t : + fx_is_type_car_t)); + if (fx_proc(tree) == fx_c_opsq) { + set_opt1_sym(cdr(p), cadadr(p)); + if ((is_global_and_has_func(car(p), s7_p_p_function)) && + (is_global_and_has_func(caadr(p), s7_p_p_function))) { + set_opt2_direct(cdr(p), + (s7_pointer) (s7_p_p_function + (global_value(car(p))))); + set_opt3_direct(cdr(p), + (s7_pointer) (s7_p_p_function + (global_value + (caadr(p))))); + return (with_fx(tree, fx_c_optq_direct)); + } + return (with_fx(tree, fx_c_optq)); + } + if (fx_proc(tree) == fx_c_car_s) + return (with_fx(tree, fx_c_car_t)); + if (fx_proc(tree) == fx_c_cdr_s) + return (with_fx(tree, fx_c_cdr_t)); + if (fx_proc(tree) == fx_is_type_opsq) + return (with_fx(tree, fx_is_type_optq)); + } + if (cadadr(p) == var2) { + if (fx_proc(tree) == fx_c_car_s) + return (with_fx(tree, fx_c_car_u)); + if (fx_proc(tree) == fx_not_is_null_s) + return (with_fx(tree, fx_not_is_null_u)); + if (fx_proc(tree) == fx_not_is_pair_s) + return (with_fx(tree, fx_not_is_pair_u)); + if (fx_proc(tree) == fx_is_pair_cdr_s) + return (with_fx(tree, fx_is_pair_cdr_u)); + } + if (cadadr(p) == var3) { + if (fx_proc(tree) == fx_not_is_pair_s) + return (with_fx(tree, fx_not_is_pair_v)); + } + break; + + case HOP_SAFE_C_opSq_S: + if (cadadr(p) == var1) { + if (fx_proc(tree) == fx_c_opsq_s) { + if ((is_global_and_has_func(car(p), s7_p_pp_function)) && + (is_global_and_has_func(caadr(p), s7_p_p_function))) { + set_opt2_direct(cdr(p), + (s7_pointer) (s7_p_pp_function + (global_value(car(p))))); + set_opt3_direct(cdr(p), + (s7_pointer) (s7_p_p_function + (global_value + (caadr(p))))); + return (with_fx(tree, fx_c_optq_s_direct)); + } + return (with_fx(tree, fx_c_optq_s)); + } + if (fx_proc(tree) == fx_c_opsq_s_direct) + return (with_fx(tree, fx_c_optq_s_direct)); + if (fx_proc(tree) == fx_cons_car_s_s) { + set_opt1_sym(cdr(p), var1); + return (with_fx + (tree, + (caddr(p) == + var3) ? fx_cons_car_t_v : fx_cons_car_t_s)); + } + } + if (cadadr(p) == var2) { + if ((fx_proc(tree) == fx_c_opsq_s) && (caddr(p) == var1)) { + if ((is_global_and_has_func(car(p), s7_p_pp_function)) && (is_global_and_has_func(caadr(p), s7_p_p_function))) { /* (memq (car sequence) items) lint */ + set_opt2_direct(cdr(p), + (s7_pointer) (s7_p_pp_function + (global_value(car(p))))); + set_opt3_direct(cdr(p), + (s7_pointer) (s7_p_p_function + (global_value + (caadr(p))))); + return (with_fx + (tree, + (car(p) == + sc->cons_symbol) ? ((caadr(p) == + sc->car_symbol) ? + fx_cons_car_u_t : + fx_cons_opuq_t) : + fx_c_opuq_t_direct)); + } + return (with_fx(tree, fx_c_opuq_t)); + } + if (((fx_proc(tree) == fx_c_opsq_s_direct) + || (fx_proc(tree) == fx_cons_car_s_s)) + && (caddr(p) == var1)) + return (with_fx + (tree, + (car(p) == + sc->cons_symbol) ? ((caadr(p) == + sc->car_symbol) ? + fx_cons_car_u_t : + fx_cons_opuq_t) : + fx_c_opuq_t_direct)); + } + break; + + case HOP_SAFE_C_S_opSq: + if (cadr(p) == var1) { + if (cadaddr(p) == var2) { + if (fx_proc(tree) == fx_c_s_car_s) + return (with_fx(tree, fx_c_t_car_u)); + if (fx_proc(tree) == fx_c_s_opsq_direct) + return (with_fx(tree, fx_c_t_opuq_direct)); + } + if (cadaddr(p) == var3) { + if (fx_proc(tree) == fx_add_s_car_s) + return (with_fx(tree, fx_add_t_car_v)); + if (fx_proc(tree) == fx_c_s_car_s) + return (with_fx(tree, fx_c_t_car_v)); /* ideally eq_p_pp not g_is_eq */ + } + } + if (cadr(p) == var2) { + if ((fx_proc(tree) == fx_add_s_car_s) && (cadaddr(p) == var1)) + return (with_fx(tree, fx_add_u_car_t)); + if ((fx_proc(tree) == fx_c_s_opsq_direct) + && (cadaddr(p) == var3)) + return (with_fx(tree, fx_c_u_opvq_direct)); + } + if ((cadaddr(p) == var1) && (fx_proc(tree) == fx_c_s_car_s)) + return (with_fx(tree, fx_c_s_car_t)); + break; + + case HOP_SAFE_C_opSq_opSq: + if (fx_proc(tree) == fx_c_opsq_opsq_direct) { + if ((cadadr(p) == var1) && (cadadr(p) == cadaddr(p))) { + set_opt1_sym(cdr(p), cadadr(p)); + return (with_fx(tree, fx_c_optq_optq_direct)); /* opuq got few hits */ + } + if ((caadr(p) == caaddr(p)) && (caadr(p) == sc->car_symbol)) { + set_opt1_sym(cdr(p), cadadr(p)); + set_opt2_sym(cdr(p), cadaddr(p)); + return (with_fx(tree, ((cadadr(p) == var1) + && (cadaddr(p) == + var2)) ? ((opt3_direct(p) == + (s7_pointer) + is_eq_p_pp) ? + fx_is_eq_car_car_tu : + fx_car_t_car_u) : + fx_car_s_car_s)); + } + } + break; + + case HOP_SAFE_C_opSq_C: + if (cadadr(p) == var1) { + if (fx_proc(tree) == fx_is_eq_car_sq) + return (with_fx(tree, fx_is_eq_car_tq)); + if ((fx_proc(tree) == fx_c_opsq_c) + || (fx_proc(tree) == fx_c_optq_c)) { + if (fn_proc(p) != g_lint_let_ref) { /* don't step on opt3_sym */ + if ((is_global_and_has_func(car(p), s7_p_pp_function)) + && + (is_global_and_has_func + (caadr(p), s7_p_p_function))) { + if (fn_proc(p) == g_memq_2) + set_opt3_direct(p, (s7_pointer) memq_2_p_pp); + else + set_opt3_direct(p, + (s7_pointer) (s7_p_pp_function + (global_value + (car(p))))); + set_opt3_direct(cdr(p), + (s7_pointer) (s7_p_p_function + (global_value + (caadr(p))))); + set_fx_direct(tree, fx_c_optq_c_direct); + return (true); + } + if ((is_t_integer(caddr(p))) && + (is_global_and_has_func + (caadr(p), s7_i_7p_function)) + && + (is_global_and_has_func(car(p), s7_p_ii_function))) + { + set_opt3_direct(p, + (s7_pointer) (s7_p_ii_function + (global_value + (car(p))))); + set_opt3_direct(cdr(p), + (s7_pointer) (s7_i_7p_function + (global_value + (caadr(p))))); + set_fx_direct(tree, fx_c_optq_i_direct); + } else + set_fx_direct(tree, fx_c_optq_c); + } + return (true); + } + } + break; + + case HOP_SAFE_C_opSSq: + if (fx_proc(tree) == fx_c_opssq) { + if (caddadr(p) == var1) + return (with_fx(tree, fx_c_opstq)); + if ((cadadr(p) == var1) && (caddadr(p) == var2)) + return (with_fx(tree, fx_c_optuq)); + } + if (fx_proc(tree) == fx_c_opssq_direct) { + if ((cadadr(p) == var1) && (caddadr(p) == var2)) + return (with_fx(tree, fx_c_optuq_direct)); + if (caddadr(p) == var1) { + if ((opt2_direct(cdr(p)) == (s7_pointer) is_zero_p_p) + && (opt3_direct(cdr(p)) == (s7_pointer) remainder_p_pp) + && (!more_vars) + && (o_var_ok(cadadr(p), var1, var2, var3))) + return (with_fx(tree, fx_is_zero_remainder_o)); + return (with_fx(tree, fx_c_opstq_direct)); + } + } + if ((cadadr(p) == var2) && (fx_proc(tree) == fx_not_opssq) + && (caddadr(p) == var1)) { + if (fn_proc(cadr(p)) == g_less_2) + set_fx_direct(tree, fx_not_lt_ut); + else + set_fx_direct(tree, fx_not_oputq); + return (true); + } + break; + + case HOP_SAFE_C_opSCq: + if (cadr(p) == var1) + return (with_fx(tree, fx_c_optcq)); /* there currently isn't any fx_c_opscq_direct */ + break; + + case HOP_SAFE_C_opSSq_C: + if ((fx_proc(tree) == fx_c_opssq_c) && (caddadr(p) == var1)) { + if (is_global_and_has_func(car(p), s7_p_pp_function)) { + if ((car(p) == sc->is_eq_symbol) + && (!is_unspecified(caddr(p))) + && (caadr(p) == sc->vector_ref_symbol) && (!more_vars) + && (o_var_ok(cadadr(p), var1, var2, var3))) + return (with_fx(tree, fx_is_eq_vref_opotq_c)); + set_opt3_direct(p, + (s7_pointer) (s7_p_pp_function + (global_value(car(p))))); + return (with_fx(tree, fx_c_opstq_c_direct)); + } + return (with_fx(tree, fx_c_opstq_c)); + } + break; + + case HOP_SAFE_C_S_opSCq: + if (cadr(p) == var1) { + if (fx_proc(tree) == fx_c_s_opscq_direct) + return (with_fx + (tree, + (cadaddr(p) == + var2) ? fx_c_t_opucq_direct : + fx_c_t_opscq_direct)); + if ((fx_proc(tree) == fx_c_s_opsiq_direct) && (!more_vars) + && (o_var_ok(cadaddr(p), var1, var2, var3))) + return (with_fx(tree, fx_c_t_opoiq_direct)); + } + break; + + case HOP_SAFE_C_opSq_CS: + if ((cadadr(p) == var1) && (fx_proc(tree) == fx_c_opsq_cs) + && (cadddr(p) == var2)) + return (with_fx(tree, fx_c_optq_cu)); + break; + + case HOP_SAFE_C_opSq_opSSq: + if ((fx_proc(tree) == fx_c_opsq_opssq) && (cadaddr(p) == var1) + && (caddaddr(p) == var2) + && (is_global_and_has_func(car(p), s7_p_pp_function)) + && (is_global_and_has_func(caadr(p), s7_p_p_function)) + && (is_global_and_has_func(caaddr(p), s7_p_pp_function))) { + set_opt3_direct(p, + (s7_pointer) (s7_p_pp_function + (global_value(car(p))))); + set_opt2_direct(cdr(p), + (s7_pointer) (s7_p_p_function + (global_value(caadr(p))))); + set_opt3_direct(cdr(p), + (s7_pointer) (s7_p_pp_function + (global_value(caaddr(p))))); + set_opt1_sym(cdr(p), var2); /* caddaddr(p) */ + + if ((car(p) == sc->num_eq_symbol) + && (caadr(p) == sc->car_symbol) && (cadadr(p) == var3)) { + if (caaddr(p) == sc->add_symbol) { + set_opt2_sym(cddr(p), var1); + return (with_fx(tree, fx_num_eq_car_v_add_tu)); + } + if (caaddr(p) == sc->subtract_symbol) { + set_opt2_sym(cddr(p), var1); + return (with_fx(tree, fx_num_eq_car_v_subtract_tu)); + } + } + return (with_fx(tree, fx_c_opsq_optuq_direct)); + } + break; + + case HOP_SAFE_C_opSSq_S: + if (fx_proc(tree) == fx_vref_vref_ss_s) { + if ((caddr(p) == var1) && (is_global(cadadr(p)))) { + if ((!more_vars) + && (o_var_ok(caddadr(p), var1, var2, var3))) + return (with_fx(tree, fx_vref_vref_go_t)); + return (with_fx(tree, fx_vref_vref_gs_t)); + } + if ((cadadr(p) == var1) && (caddadr(p) == var2) + && (caddr(p) == var3)) + return (with_fx(tree, fx_vref_vref_tu_v)); + } + break; + + case HOP_SAFE_C_S_opSSq: + if (caddaddr(p) == var1) { + if ((fn_proc(p) == g_vector_ref_2) + && (is_global(cadr(p)) && (is_global(cadaddr(p))))) { + set_opt3_pair(p, cdaddr(p)); + return (with_fx(tree, fx_vref_g_vref_gt)); + } + if (fx_proc(tree) == fx_c_s_opssq_direct) + return (with_fx(tree, fx_c_s_opstq_direct)); + } + if ((fx_proc(tree) == fx_c_s_opssq_direct) && (cadr(p) == var1) + && (caddaddr(p) == var2)) + return (with_fx(tree, fx_c_t_opsuq_direct)); + break; + + case HOP_SAFE_C_op_opSq_Sq: + if ((car(p) == sc->not_symbol) && (is_global(sc->not_symbol)) + && (var1 == cadr(cadadr(p)))) + return (with_fx(tree, fx_not_op_optq_sq)); + break; + + case HOP_SAFE_C_AC: + if (((fx_proc(tree) == fx_c_ac) + || (fx_proc(tree) == fx_c_ac_direct)) + && (fn_proc(p) == g_num_eq_xi) && (caddr(p) == int_zero) + && (fx_proc(cdr(p)) == fx_c_opuq_t_direct) + && (caadr(p) == sc->remainder_symbol) + && (fn_proc(cadadr(p)) == g_car)) { + set_opt3_sym(p, cadr(cadadr(p))); + set_opt1_sym(cdr(p), caddadr(p)); + return (with_fx(tree, fx_is_zero_remainder_car)); + } + break; + + case HOP_SAFE_CLOSURE_S_A: + if ((cadr(p) == var1) && (fx_proc(tree) == fx_safe_closure_s_a)) + return (with_fx(tree, fx_safe_closure_t_a)); + break; + + case OP_IF_S_A_A: + if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3))) + return (with_fx(tree, fx_if_o_a_a)); + break; + + case OP_AND_3A: + if ((fx_proc(tree) == fx_and_3a) && (is_pair(cadr(p))) && (is_pair(cdadr(p))) && (cadadr(p) == var1) && /* so "s" below is "t" */ + (((fx_proc(cdr(p)) == fx_is_pair_t) + && (fx_proc(cddr(p)) == fx_is_pair_cdr_t)) + || ((fx_proc(cdr(p)) == fx_is_pair_s) + && (fx_proc(cddr(p)) == fx_is_pair_cdr_s)))) { + set_opt1_sym(cdr(p), cadadr(p)); + if ((fx_proc(cdddr(p)) == fx_is_null_cddr_t) + || (fx_proc(cdddr(p)) == fx_is_null_cddr_s)) + return (with_fx(tree, fx_len2_t)); + if ((fx_proc(cdddr(p)) == fx_is_pair_cddr_t) + || (fx_proc(cdddr(p)) == fx_is_pair_cddr_s)) + return (with_fx(tree, fx_len3_t)); + } + break; + } +#if 0 + if ((var3) + && ((s7_tree_memq(sc, var1, car(tree))) + || ((var2) && (s7_tree_memq(sc, var2, car(tree)))) || ((var3) + && + (s7_tree_memq + (sc, + var3, + car + (tree)))))) + fprintf(stderr, "fx_tree_in %s %s %s: %s %s\n", display(var1), + (var2) ? display(var2) : "", (var3) ? display(var3) : "", + display_80(car(tree)), op_names[optimize_op(car(tree))]); +#endif + return (false); +} + +static void fx_tree(s7_scheme * sc, s7_pointer tree, s7_pointer var1, + s7_pointer var2, s7_pointer var3, bool more_vars) +{ + if (!is_pair(tree)) + return; + if ((is_symbol(car(tree))) && (is_definer_or_binder(car(tree)))) { + if ((car(tree) == sc->let_symbol) && (is_pair(cdr(tree))) + && (is_pair(cadr(tree))) && (is_null(cdadr(tree)))) + fx_tree(sc, cddr(tree), caaadr(tree), NULL, NULL, more_vars); + return; + } + if (is_syntax(car(tree))) + return; /* someday let #_when/#_if etc through -- the symbol 'if, for example, is not syntax */ + + if ((!has_fx(tree)) || + (!fx_tree_in(sc, tree, var1, var2, var3, more_vars))) + fx_tree(sc, car(tree), var1, var2, var3, more_vars); + fx_tree(sc, cdr(tree), var1, var2, var3, more_vars); +} + +static void fx_tree_outer(s7_scheme * sc, s7_pointer tree, s7_pointer var1, + s7_pointer var2, s7_pointer var3, bool more_vars) +{ + /* if (is_pair(tree)) fprintf(stderr, "%s[%d]: %s %d %s %s\n", __func__, __LINE__, display_80(tree), has_fx(tree), display(var1), (var2) ? display(var2) : ""); */ + if ((!is_pair(tree)) || + ((is_symbol(car(tree))) && (is_definer_or_binder(car(tree)))) || + (is_syntax(car(tree)))) + return; + + if ((!has_fx(tree)) || + (!fx_tree_out(sc, tree, var1, var2, var3, more_vars))) + fx_tree_outer(sc, car(tree), var1, var2, var3, more_vars); + fx_tree_outer(sc, cdr(tree), var1, var2, var3, more_vars); +} + + +/* -------------------------------------------------------------------------------- */ + +static opt_funcs_t *alloc_permanent_opt_func(s7_scheme * sc) +{ + if (sc->alloc_opt_func_k == ALLOC_FUNCTION_SIZE) { + sc->alloc_opt_func_cells = + (opt_funcs_t *) malloc(ALLOC_FUNCTION_SIZE * + sizeof(opt_funcs_t)); + add_saved_pointer(sc, sc->alloc_opt_func_cells); + sc->alloc_opt_func_k = 0; + } + return (&(sc->alloc_opt_func_cells[sc->alloc_opt_func_k++])); +} + +static void add_opt_func(s7_scheme * sc, s7_pointer f, opt_func_t typ, + void *func) +{ + opt_funcs_t *op; +#if S7_DEBUGGING + static const char *o_names[] = + { "o_d_v", "o_d_vd", "o_d_vdd", "o_d_vid", "o_d_id", "o_d_7pi", + "o_d_7pii", "o_d_7piid", "o_d_7piii", "o_d_7piiid", + "o_d_ip", "o_d_pd", "o_d_7pid", "o_d", "o_d_d", "o_d_dd", + "o_d_7dd", "o_d_ddd", "o_d_dddd", + "o_i_i", "o_i_7i", "o_i_ii", "o_i_7ii", "o_i_iii", "o_i_7pi", + "o_i_7pii", "o_i_7_piii", "o_d_p", + "o_b_p", "o_b_7p", "o_b_pp", "o_b_7pp", "o_b_pp_unchecked", + "o_b_pi", "o_b_ii", "o_b_7ii", "o_b_dd", + "o_p", "o_p_p", "o_p_ii", "o_p_d", "o_p_dd", "o_i_7d", "o_i_7p", + "o_d_7d", "o_p_pp", "o_p_ppp", "o_p_pi", "o_p_pi_unchecked", + "o_p_ppi", "o_p_i", "o_p_pii", "o_p_pip", "o_p_pip_unchecked", + "o_p_piip", "o_b_i", "o_b_d" + }; + if (!is_c_function(f)) { + fprintf(stderr, "%s[%d]: %s is not a c_function\n", __func__, + __LINE__, s7_object_to_c_string(sc, f)); + if (sc->stop_at_error) + abort(); + } else if (c_function_opt_data(f)) { + opt_funcs_t *p; + for (p = c_function_opt_data(f); p; p = p->next) { + if (p->typ == typ) + fprintf(stderr, + "%s[%d]: %s has a function of type %d (%s)\n", + __func__, __LINE__, s7_object_to_c_string(sc, f), + typ, o_names[typ]); + if (p->func == func) + fprintf(stderr, + "%s[%d]: %s already has this function as type %d %s (current: %d %s)\n", + __func__, __LINE__, s7_object_to_c_string(sc, f), + p->typ, o_names[p->typ], typ, o_names[typ]); + } + } +#endif + op = alloc_permanent_opt_func(sc); + op->typ = typ; + op->func = func; + op->next = c_function_opt_data(f); + c_function_opt_data(f) = op; +} + +static void *opt_func(s7_pointer f, opt_func_t typ) +{ + if (is_c_function(f)) { + opt_funcs_t *p; + for (p = c_function_opt_data(f); p; p = p->next) + if (p->typ == typ) + return (p->func); + } + return (NULL); +} + +/* clm2xen.c */ +void s7_set_d_function(s7_scheme * sc, s7_pointer f, s7_d_t df) +{ + add_opt_func(sc, f, o_d, (void *) df); +} + +s7_d_t s7_d_function(s7_pointer f) +{ + return ((s7_d_t) opt_func(f, o_d)); +} + +void s7_set_d_d_function(s7_scheme * sc, s7_pointer f, s7_d_d_t df) +{ + add_opt_func(sc, f, o_d_d, (void *) df); +} + +s7_d_d_t s7_d_d_function(s7_pointer f) +{ + return ((s7_d_d_t) opt_func(f, o_d_d)); +} + +void s7_set_d_dd_function(s7_scheme * sc, s7_pointer f, s7_d_dd_t df) +{ + add_opt_func(sc, f, o_d_dd, (void *) df); +} + +s7_d_dd_t s7_d_dd_function(s7_pointer f) +{ + return ((s7_d_dd_t) opt_func(f, o_d_dd)); +} + +void s7_set_d_v_function(s7_scheme * sc, s7_pointer f, s7_d_v_t df) +{ + add_opt_func(sc, f, o_d_v, (void *) df); +} + +s7_d_v_t s7_d_v_function(s7_pointer f) +{ + return ((s7_d_v_t) opt_func(f, o_d_v)); +} + +void s7_set_d_vd_function(s7_scheme * sc, s7_pointer f, s7_d_vd_t df) +{ + add_opt_func(sc, f, o_d_vd, (void *) df); +} + +s7_d_vd_t s7_d_vd_function(s7_pointer f) +{ + return ((s7_d_vd_t) opt_func(f, o_d_vd)); +} + +void s7_set_d_vdd_function(s7_scheme * sc, s7_pointer f, s7_d_vdd_t df) +{ + add_opt_func(sc, f, o_d_vdd, (void *) df); +} + +s7_d_vdd_t s7_d_vdd_function(s7_pointer f) +{ + return ((s7_d_vdd_t) opt_func(f, o_d_vdd)); +} + +void s7_set_d_vid_function(s7_scheme * sc, s7_pointer f, s7_d_vid_t df) +{ + add_opt_func(sc, f, o_d_vid, (void *) df); +} + +s7_d_vid_t s7_d_vid_function(s7_pointer f) +{ + return ((s7_d_vid_t) opt_func(f, o_d_vid)); +} + +void s7_set_d_id_function(s7_scheme * sc, s7_pointer f, s7_d_id_t df) +{ + add_opt_func(sc, f, o_d_id, (void *) df); +} + +s7_d_id_t s7_d_id_function(s7_pointer f) +{ + return ((s7_d_id_t) opt_func(f, o_d_id)); +} + +void s7_set_d_7pid_function(s7_scheme * sc, s7_pointer f, s7_d_7pid_t df) +{ + add_opt_func(sc, f, o_d_7pid, (void *) df); +} + +s7_d_7pid_t s7_d_7pid_function(s7_pointer f) +{ + return ((s7_d_7pid_t) opt_func(f, o_d_7pid)); +} + +void s7_set_d_ip_function(s7_scheme * sc, s7_pointer f, s7_d_ip_t df) +{ + add_opt_func(sc, f, o_d_ip, (void *) df); +} + +s7_d_ip_t s7_d_ip_function(s7_pointer f) +{ + return ((s7_d_ip_t) opt_func(f, o_d_ip)); +} + +void s7_set_d_pd_function(s7_scheme * sc, s7_pointer f, s7_d_pd_t df) +{ + add_opt_func(sc, f, o_d_pd, (void *) df); +} + +s7_d_pd_t s7_d_pd_function(s7_pointer f) +{ + return ((s7_d_pd_t) opt_func(f, o_d_pd)); +} + +void s7_set_d_p_function(s7_scheme * sc, s7_pointer f, s7_d_p_t df) +{ + add_opt_func(sc, f, o_d_p, (void *) df); +} + +s7_d_p_t s7_d_p_function(s7_pointer f) +{ + return ((s7_d_p_t) opt_func(f, o_d_p)); +} + +void s7_set_b_p_function(s7_scheme * sc, s7_pointer f, s7_b_p_t df) +{ + add_opt_func(sc, f, o_b_p, (void *) df); +} + +s7_b_p_t s7_b_p_function(s7_pointer f) +{ + return ((s7_b_p_t) opt_func(f, o_b_p)); +} + +void s7_set_d_7pi_function(s7_scheme * sc, s7_pointer f, s7_d_7pi_t df) +{ + add_opt_func(sc, f, o_d_7pi, (void *) df); +} + +s7_d_7pi_t s7_d_7pi_function(s7_pointer f) +{ + return ((s7_d_7pi_t) opt_func(f, o_d_7pi)); +} + +static void s7_set_d_7pii_function(s7_scheme * sc, s7_pointer f, + s7_d_7pii_t df) +{ + add_opt_func(sc, f, o_d_7pii, (void *) df); +} + +static s7_d_7pii_t s7_d_7pii_function(s7_pointer f) +{ + return ((s7_d_7pii_t) opt_func(f, o_d_7pii)); +} + +static void s7_set_d_7piii_function(s7_scheme * sc, s7_pointer f, + s7_d_7piii_t df) +{ + add_opt_func(sc, f, o_d_7piii, (void *) df); +} + +static s7_d_7piii_t s7_d_7piii_function(s7_pointer f) +{ + return ((s7_d_7piii_t) opt_func(f, o_d_7piii)); +} + +void s7_set_i_7p_function(s7_scheme * sc, s7_pointer f, s7_i_7p_t df) +{ + add_opt_func(sc, f, o_i_7p, (void *) df); +} + +s7_i_7p_t s7_i_7p_function(s7_pointer f) +{ + return ((s7_i_7p_t) opt_func(f, o_i_7p)); +} + +/* cload.scm */ +void s7_set_d_ddd_function(s7_scheme * sc, s7_pointer f, s7_d_ddd_t df) +{ + add_opt_func(sc, f, o_d_ddd, (void *) df); +} + +s7_d_ddd_t s7_d_ddd_function(s7_pointer f) +{ + return ((s7_d_ddd_t) opt_func(f, o_d_ddd)); +} + +void s7_set_d_dddd_function(s7_scheme * sc, s7_pointer f, s7_d_dddd_t df) +{ + add_opt_func(sc, f, o_d_dddd, (void *) df); +} + +s7_d_dddd_t s7_d_dddd_function(s7_pointer f) +{ + return ((s7_d_dddd_t) opt_func(f, o_d_dddd)); +} + +void s7_set_i_i_function(s7_scheme * sc, s7_pointer f, s7_i_i_t df) +{ + add_opt_func(sc, f, o_i_i, (void *) df); +} + +s7_i_i_t s7_i_i_function(s7_pointer f) +{ + return ((s7_i_i_t) opt_func(f, o_i_i)); +} + +void s7_set_i_ii_function(s7_scheme * sc, s7_pointer f, s7_i_ii_t df) +{ + add_opt_func(sc, f, o_i_ii, (void *) df); +} + +s7_i_ii_t s7_i_ii_function(s7_pointer f) +{ + return ((s7_i_ii_t) opt_func(f, o_i_ii)); +} + +void s7_set_i_7d_function(s7_scheme * sc, s7_pointer f, s7_i_7d_t df) +{ + add_opt_func(sc, f, o_i_7d, (void *) df); +} + +s7_i_7d_t s7_i_7d_function(s7_pointer f) +{ + return ((s7_i_7d_t) opt_func(f, o_i_7d)); +} + +/* s7test.scm */ +void s7_set_p_d_function(s7_scheme * sc, s7_pointer f, s7_p_d_t df) +{ + add_opt_func(sc, f, o_p_d, (void *) df); +} + +s7_p_d_t s7_p_d_function(s7_pointer f) +{ + return ((s7_p_d_t) opt_func(f, o_p_d)); +} + +static void s7_set_d_7dd_function(s7_scheme * sc, s7_pointer f, + s7_d_7dd_t df) +{ + add_opt_func(sc, f, o_d_7dd, (void *) df); +} + +static s7_d_7dd_t s7_d_7dd_function(s7_pointer f) +{ + return ((s7_d_7dd_t) opt_func(f, o_d_7dd)); +} + +static void s7_set_i_7i_function(s7_scheme * sc, s7_pointer f, + s7_i_7i_t df) +{ + add_opt_func(sc, f, o_i_7i, (void *) df); +} + +static s7_i_7i_t s7_i_7i_function(s7_pointer f) +{ + return ((s7_i_7i_t) opt_func(f, o_i_7i)); +} + +static void s7_set_i_7ii_function(s7_scheme * sc, s7_pointer f, + s7_i_7ii_t df) +{ + add_opt_func(sc, f, o_i_7ii, (void *) df); +} + +static s7_i_7ii_t s7_i_7ii_function(s7_pointer f) +{ + return ((s7_i_7ii_t) opt_func(f, o_i_7ii)); +} + +static void s7_set_i_iii_function(s7_scheme * sc, s7_pointer f, + s7_i_iii_t df) +{ + add_opt_func(sc, f, o_i_iii, (void *) df); +} + +s7_i_iii_t s7_i_iii_function(s7_pointer f) +{ + return ((s7_i_iii_t) opt_func(f, o_i_iii)); +} + +static void s7_set_p_pi_function(s7_scheme * sc, s7_pointer f, + s7_p_pi_t df) +{ + add_opt_func(sc, f, o_p_pi, (void *) df); +} + +static s7_p_pi_t s7_p_pi_function(s7_pointer f) +{ + return ((s7_p_pi_t) opt_func(f, o_p_pi)); +} + +static void s7_set_p_ppi_function(s7_scheme * sc, s7_pointer f, + s7_p_ppi_t df) +{ + add_opt_func(sc, f, o_p_ppi, (void *) df); +} + +static s7_p_ppi_t s7_p_ppi_function(s7_pointer f) +{ + return ((s7_p_ppi_t) opt_func(f, o_p_ppi)); +} + +static void s7_set_i_7pi_function(s7_scheme * sc, s7_pointer f, + s7_i_7pi_t df) +{ + add_opt_func(sc, f, o_i_7pi, (void *) df); +} + +static s7_i_7pi_t s7_i_7pi_function(s7_pointer f) +{ + return ((s7_i_7pi_t) opt_func(f, o_i_7pi)); +} + +static void s7_set_i_7pii_function(s7_scheme * sc, s7_pointer f, + s7_i_7pii_t df) +{ + add_opt_func(sc, f, o_i_7pii, (void *) df); +} + +static s7_i_7pii_t s7_i_7pii_function(s7_pointer f) +{ + return ((s7_i_7pii_t) opt_func(f, o_i_7pii)); +} + +static void s7_set_i_7piii_function(s7_scheme * sc, s7_pointer f, + s7_i_7piii_t df) +{ + add_opt_func(sc, f, o_i_7piii, (void *) df); +} + +static s7_i_7piii_t s7_i_7piii_function(s7_pointer f) +{ + return ((s7_i_7piii_t) opt_func(f, o_i_7piii)); +} + +static void s7_set_b_d_function(s7_scheme * sc, s7_pointer f, s7_b_d_t df) +{ + add_opt_func(sc, f, o_b_d, (void *) df); +} + +static s7_b_d_t s7_b_d_function(s7_pointer f) +{ + return ((s7_b_d_t) opt_func(f, o_b_d)); +} + +static void s7_set_b_i_function(s7_scheme * sc, s7_pointer f, s7_b_i_t df) +{ + add_opt_func(sc, f, o_b_i, (void *) df); +} + +static s7_b_i_t s7_b_i_function(s7_pointer f) +{ + return ((s7_b_i_t) opt_func(f, o_b_i)); +} + +static void s7_set_b_7p_function(s7_scheme * sc, s7_pointer f, + s7_b_7p_t df) +{ + add_opt_func(sc, f, o_b_7p, (void *) df); +} + +static s7_b_7p_t s7_b_7p_function(s7_pointer f) +{ + return ((s7_b_7p_t) opt_func(f, o_b_7p)); +} + +static void s7_set_b_pp_function(s7_scheme * sc, s7_pointer f, + s7_b_pp_t df) +{ + add_opt_func(sc, f, o_b_pp, (void *) df); +} + +static s7_b_pp_t s7_b_pp_function(s7_pointer f) +{ + return ((s7_b_pp_t) opt_func(f, o_b_pp)); +} + +static void s7_set_b_7pp_function(s7_scheme * sc, s7_pointer f, + s7_b_7pp_t df) +{ + add_opt_func(sc, f, o_b_7pp, (void *) df); +} + +static s7_b_7pp_t s7_b_7pp_function(s7_pointer f) +{ + return ((s7_b_7pp_t) opt_func(f, o_b_7pp)); +} + +static void s7_set_d_7d_function(s7_scheme * sc, s7_pointer f, + s7_d_7d_t df) +{ + add_opt_func(sc, f, o_d_7d, (void *) df); +} + +static s7_d_7d_t s7_d_7d_function(s7_pointer f) +{ + return ((s7_d_7d_t) opt_func(f, o_d_7d)); +} + +static void s7_set_b_pi_function(s7_scheme * sc, s7_pointer f, + s7_b_pi_t df) +{ + add_opt_func(sc, f, o_b_pi, (void *) df); +} + +static s7_b_pi_t s7_b_pi_function(s7_pointer f) +{ + return ((s7_b_pi_t) opt_func(f, o_b_pi)); +} + +static void s7_set_b_ii_function(s7_scheme * sc, s7_pointer f, + s7_b_ii_t df) +{ + add_opt_func(sc, f, o_b_ii, (void *) df); +} + +static s7_b_ii_t s7_b_ii_function(s7_pointer f) +{ + return ((s7_b_ii_t) opt_func(f, o_b_ii)); +} + +static void s7_set_b_7ii_function(s7_scheme * sc, s7_pointer f, + s7_b_7ii_t df) +{ + add_opt_func(sc, f, o_b_7ii, (void *) df); +} + +static s7_b_7ii_t s7_b_7ii_function(s7_pointer f) +{ + return ((s7_b_7ii_t) opt_func(f, o_b_7ii)); +} + +static void s7_set_b_dd_function(s7_scheme * sc, s7_pointer f, + s7_b_dd_t df) +{ + add_opt_func(sc, f, o_b_dd, (void *) df); +} + +static s7_b_dd_t s7_b_dd_function(s7_pointer f) +{ + return ((s7_b_dd_t) opt_func(f, o_b_dd)); +} + +static void s7_set_p_p_function(s7_scheme * sc, s7_pointer f, s7_p_p_t df) +{ + add_opt_func(sc, f, o_p_p, (void *) df); +} + +static s7_p_p_t s7_p_p_function(s7_pointer f) +{ + return ((s7_p_p_t) opt_func(f, o_p_p)); +} + +static void s7_set_p_function(s7_scheme * sc, s7_pointer f, s7_p_t df) +{ + add_opt_func(sc, f, o_p, (void *) df); +} + +static s7_p_t s7_p_function(s7_pointer f) +{ + return ((s7_p_t) opt_func(f, o_p)); +} + +static void s7_set_p_pp_function(s7_scheme * sc, s7_pointer f, + s7_p_pp_t df) +{ + add_opt_func(sc, f, o_p_pp, (void *) df); +} + +static s7_p_pp_t s7_p_pp_function(s7_pointer f) +{ + return ((s7_p_pp_t) opt_func(f, o_p_pp)); +} + +static void s7_set_p_ppp_function(s7_scheme * sc, s7_pointer f, + s7_p_ppp_t df) +{ + add_opt_func(sc, f, o_p_ppp, (void *) df); +} + +static s7_p_ppp_t s7_p_ppp_function(s7_pointer f) +{ + return ((s7_p_ppp_t) opt_func(f, o_p_ppp)); +} + +static void s7_set_p_pip_function(s7_scheme * sc, s7_pointer f, + s7_p_pip_t df) +{ + add_opt_func(sc, f, o_p_pip, (void *) df); +} + +static s7_p_pip_t s7_p_pip_function(s7_pointer f) +{ + return ((s7_p_pip_t) opt_func(f, o_p_pip)); +} + +static void s7_set_p_pii_function(s7_scheme * sc, s7_pointer f, + s7_p_pii_t df) +{ + add_opt_func(sc, f, o_p_pii, (void *) df); +} + +static s7_p_pii_t s7_p_pii_function(s7_pointer f) +{ + return ((s7_p_pii_t) opt_func(f, o_p_pii)); +} + +static void s7_set_p_piip_function(s7_scheme * sc, s7_pointer f, + s7_p_piip_t df) +{ + add_opt_func(sc, f, o_p_piip, (void *) df); +} + +static s7_p_piip_t s7_p_piip_function(s7_pointer f) +{ + return ((s7_p_piip_t) opt_func(f, o_p_piip)); +} + +static void s7_set_p_pi_unchecked_function(s7_scheme * sc, s7_pointer f, + s7_p_pi_t df) +{ + add_opt_func(sc, f, o_p_pi_unchecked, (void *) df); +} + +static s7_p_pi_t s7_p_pi_unchecked_function(s7_pointer f) +{ + return ((s7_p_pi_t) opt_func(f, o_p_pi_unchecked)); +} + +static void s7_set_p_pip_unchecked_function(s7_scheme * sc, s7_pointer f, + s7_p_pip_t df) +{ + add_opt_func(sc, f, o_p_pip_unchecked, (void *) df); +} + +static s7_p_pip_t s7_p_pip_unchecked_function(s7_pointer f) +{ + return ((s7_p_pip_t) opt_func(f, o_p_pip_unchecked)); +} + +static void s7_set_b_pp_unchecked_function(s7_scheme * sc, s7_pointer f, + s7_b_pp_t df) +{ + add_opt_func(sc, f, o_b_pp_unchecked, (void *) df); +} + +static s7_b_pp_t s7_b_pp_unchecked_function(s7_pointer f) +{ + return ((s7_b_pp_t) opt_func(f, o_b_pp_unchecked)); +} + +static void s7_set_p_i_function(s7_scheme * sc, s7_pointer f, s7_p_i_t df) +{ + add_opt_func(sc, f, o_p_i, (void *) df); +} + +static s7_p_i_t s7_p_i_function(s7_pointer f) +{ + return ((s7_p_i_t) opt_func(f, o_p_i)); +} + +static void s7_set_p_ii_function(s7_scheme * sc, s7_pointer f, + s7_p_ii_t df) +{ + add_opt_func(sc, f, o_p_ii, (void *) df); +} + +static s7_p_ii_t s7_p_ii_function(s7_pointer f) +{ + return ((s7_p_ii_t) opt_func(f, o_p_ii)); +} + +static void s7_set_d_7piid_function(s7_scheme * sc, s7_pointer f, + s7_d_7piid_t df) +{ + add_opt_func(sc, f, o_d_7piid, (void *) df); +} + +static s7_d_7piid_t s7_d_7piid_function(s7_pointer f) +{ + return ((s7_d_7piid_t) opt_func(f, o_d_7piid)); +} + +static void s7_set_d_7piiid_function(s7_scheme * sc, s7_pointer f, + s7_d_7piiid_t df) +{ + add_opt_func(sc, f, o_d_7piiid, (void *) df); +} + +static s7_d_7piiid_t s7_d_7piiid_function(s7_pointer f) +{ + return ((s7_d_7piiid_t) opt_func(f, o_d_7piiid)); +} + +static void s7_set_p_dd_function(s7_scheme * sc, s7_pointer f, + s7_p_dd_t df) +{ + add_opt_func(sc, f, o_p_dd, (void *) df); +} + +static s7_p_dd_t s7_p_dd_function(s7_pointer f) +{ + return ((s7_p_dd_t) opt_func(f, o_p_dd)); +} + +static opt_info *alloc_opo(s7_scheme * sc) +{ + opt_info *o; + if (sc->pc >= OPTS_SIZE) + sc->pc = OPTS_SIZE - 1; + o = sc->opts[sc->pc++]; + o->v[O_WRAP].fd = NULL; /* see bool_optimize -- this is a kludge */ + return (o); +} + +#define backup_pc(sc) sc->pc-- + +#define OPT_PRINT 0 +#if OPT_PRINT +#define return_false(Sc, Expr) return(return_false_1(Sc, Expr, __func__, __LINE__)) +static bool return_false_1(s7_scheme * sc, s7_pointer expr, + const char *func, int32_t line) +{ + if (expr) + fprintf(stderr, " %s%s[%d]%s: %s\n", BOLD_TEXT, func, line, + UNBOLD_TEXT, display_80(expr)); + else + fprintf(stderr, " %s%s[%d]%s: false\n", BOLD_TEXT, func, line, + UNBOLD_TEXT); + return (false); +} + +#define return_true(Sc, P, Expr) return(return_true_1(Sc, P, Expr, __func__, __LINE__)) +static s7_pfunc return_true_1(s7_scheme * sc, s7_pfunc p, s7_pointer expr, + const char *func, int line) +{ + fprintf(stderr, " %s%s[%d]%s: %s %ssuccess%s\n", BOLD_TEXT, func, + line, UNBOLD_TEXT, display_80(expr), BOLD_TEXT "\033[32m", + UNBOLD_TEXT "\033[0m"); + return (p); +} + +#define return_null(Sc, Expr) return(return_null_1(Sc, Expr, __func__, __LINE__)) +static s7_pfunc return_null_1(s7_scheme * sc, s7_pointer expr, + const char *func, int line) +{ + fprintf(stderr, " %s%s[%d]%s: %s %sfailure%s\n", BOLD_TEXT, func, + line, UNBOLD_TEXT, display_80(expr), BOLD_TEXT "\033[31m", + UNBOLD_TEXT "\033[0m"); + return (NULL); +} +#else +#define return_false(Sc, Expr) return(false) +#define return_true(Sc, P, Expr) return(P) +#define return_null(Sc, Expr) return(NULL) +#endif + +static s7_pointer opt_integer_symbol(s7_scheme * sc, s7_pointer sym) +{ + if (is_symbol(sym)) { + s7_pointer p; + p = lookup_slot_from(sym, sc->curlet); + if ((is_slot(p)) && (is_t_integer(slot_value(p)))) + return (p); + } + return (NULL); +} + +static s7_pointer opt_real_symbol(s7_scheme * sc, s7_pointer sym) +{ + if (is_symbol(sym)) { + s7_pointer p; + p = lookup_slot_from(sym, sc->curlet); + if ((is_slot(p)) && (is_small_real(slot_value(p)))) + return (p); + } + return (NULL); +} + +static s7_pointer opt_float_symbol(s7_scheme * sc, s7_pointer sym) +{ + if (is_symbol(sym)) { + s7_pointer p; + p = lookup_slot_from(sym, sc->curlet); + if ((is_slot(p)) && (is_t_real(slot_value(p)))) + return (p); + } + return (NULL); +} + +static s7_pointer opt_simple_symbol(s7_scheme * sc, s7_pointer sym) +{ + s7_pointer p; + p = lookup_slot_from(sym, sc->curlet); + if ((is_slot(p)) && (!has_methods(slot_value(p)))) + return (p); + return (NULL); +} + +static s7_pointer opt_types_match(s7_scheme * sc, s7_pointer check, + s7_pointer sym) +{ + s7_pointer slot, checker; + checker = s7_symbol_value(sc, check); + slot = lookup_slot_from(sym, sc->curlet); + if (is_slot(slot)) { + s7_pointer obj; + obj = slot_value(slot); + if (s7_apply_function(sc, checker, set_plist_1(sc, obj)) == sc->T) + return (slot); + } + return (NULL); +} + +typedef s7_pointer(*opt_pfunc) (s7_scheme * sc); + +static s7_pointer opt_bool_any(s7_scheme * sc) +{ + return ((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F); +} + +static s7_pointer opt_float_any_nr(s7_scheme * sc) +{ + sc->opts[0]->v[0].fd(sc->opts[0]); + return (NULL); +} + +static s7_pointer opt_int_any_nr(s7_scheme * sc) +{ + sc->opts[0]->v[0].fi(sc->opts[0]); + return (NULL); +} + +static s7_pointer opt_bool_any_nr(s7_scheme * sc) +{ + sc->opts[0]->v[0].fb(sc->opts[0]); + return (NULL); +} + +static s7_pointer opt_cell_any_nr(s7_scheme * sc) +{ + return (sc->opts[0]->v[0].fp(sc->opts[0])); +} /* this is faster than returning null */ + +static s7_pointer opt_wrap_float(s7_scheme * sc) +{ + return (make_real(sc, sc->opts[0]->v[0].fd(sc->opts[0]))); +} + +static s7_pointer opt_wrap_int(s7_scheme * sc) +{ + return (make_integer(sc, sc->opts[0]->v[0].fi(sc->opts[0]))); +} + +static s7_pointer opt_wrap_cell(s7_scheme * sc) +{ + return (sc->opts[0]->v[0].fp(sc->opts[0])); +} + +static s7_pointer opt_wrap_bool(s7_scheme * sc) +{ + return ((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F); +} + +static bool p_to_b(opt_info * o) +{ + return (o->v[O_WRAP].fp(o) != opt_sc(o)->F); +} + +static s7_pointer d_to_p(opt_info * o) +{ + return (make_real(opt_sc(o), o->v[O_WRAP].fd(o))); +} + +static s7_pointer d_to_p_nr(opt_info * o) +{ + o->v[O_WRAP].fd(o); + return (NULL); +} + +static s7_pointer i_to_p(opt_info * o) +{ + return (make_integer(opt_sc(o), o->v[O_WRAP].fi(o))); +} + +static s7_pointer i_to_p_nr(opt_info * o) +{ + o->v[O_WRAP].fi(o); + return (NULL); +} + + +/* -------------------------------- int opts -------------------------------- */ + +static bool int_optimize(s7_scheme * sc, s7_pointer expr); +static bool float_optimize(s7_scheme * sc, s7_pointer expr); + +static s7_int opt_i_c(opt_info * o) +{ + return (o->v[1].i); +} + +static s7_int opt_i_s(opt_info * o) +{ + return (integer(slot_value(o->v[1].p))); +} + +static bool opt_int_not_pair(s7_scheme * sc, s7_pointer car_x) +{ + opt_info *opc; + s7_pointer p; + if (is_t_integer(car_x)) { + opc = alloc_opo(sc); + opc->v[1].i = integer(car_x); + opc->v[0].fi = opt_i_c; + return (true); + } + p = opt_integer_symbol(sc, car_x); + if (!p) + return_false(sc, car_x); + opc = alloc_opo(sc); + opc->v[1].p = p; + opc->v[0].fi = opt_i_s; + return (true); +} + +/* -------- i_i|d|p -------- */ +static s7_int opt_i_i_c(opt_info * o) +{ + return (o->v[2].i_i_f(o->v[1].i)); +} + +static s7_int opt_i_i_s(opt_info * o) +{ + return (o->v[2].i_i_f(integer(slot_value(o->v[1].p)))); +} + +static s7_int opt_i_7i_c(opt_info * o) +{ + return (o->v[2].i_7i_f(opt_sc(o), o->v[1].i)); +} + +static s7_int opt_i_7i_s(opt_info * o) +{ + return (o->v[2].i_7i_f(opt_sc(o), integer(slot_value(o->v[1].p)))); +} + +static s7_int opt_i_7i_s_rand(opt_info * o) +{ + return (random_i_7i(opt_sc(o), integer(slot_value(o->v[1].p)))); +} + +static s7_int opt_i_d_c(opt_info * o) +{ + return (o->v[2].i_7d_f(opt_sc(o), o->v[1].x)); +} + +static s7_int opt_i_d_s(opt_info * o) +{ + return (o->v[2].i_7d_f(opt_sc(o), real(slot_value(o->v[1].p)))); +} + +static s7_int opt_i_i_f(opt_info * o) +{ + return (o->v[2].i_i_f(o->v[4].fi(o->v[3].o1))); +} + +static s7_int opt_i_7i_f(opt_info * o) +{ + return (o->v[2].i_7i_f(opt_sc(o), o->v[4].fi(o->v[3].o1))); +} + +static s7_int opt_i_7d_f(opt_info * o) +{ + return (o->v[2].i_7d_f(opt_sc(o), o->v[4].fd(o->v[3].o1))); +} + +static s7_int opt_i_7p_f(opt_info * o) +{ + return (o->v[2].i_7p_f(opt_sc(o), o->v[4].fp(o->v[3].o1))); +} + +static s7_int opt_i_7p_f_cint(opt_info * o) +{ + return (char_to_integer_i_7p(opt_sc(o), o->v[4].fp(o->v[3].o1))); +} + +static s7_int opt_i_i_s_abs(opt_info * o) +{ + return (abs_i_i(integer(slot_value(o->v[1].p)))); +} + +static s7_int opt_i_i_f_abs(opt_info * o) +{ + return (abs_i_i(o->v[4].fi(o->v[3].o1))); +} + +static bool i_idp_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_i_i_t func; + s7_i_7i_t func7 = NULL; + s7_i_7d_t idf; + s7_i_7p_t ipf; + s7_pointer p; + int32_t start = sc->pc; + opc->v[3].o1 = sc->opts[start]; + + func = s7_i_i_function(s_func); + if (!func) + func7 = s7_i_7i_function(s_func); + if ((func) || (func7)) { + if (func) + opc->v[2].i_i_f = func; + else + opc->v[2].i_7i_f = func7; + if (is_t_integer(cadr(car_x))) { + opc->v[1].i = integer(cadr(car_x)); + opc->v[0].fi = (func) ? opt_i_i_c : opt_i_7i_c; + return (true); + } + p = opt_integer_symbol(sc, cadr(car_x)); + if (p) { + opc->v[1].p = p; + opc->v[0].fi = + (func) ? ((func == abs_i_i) ? opt_i_i_s_abs : opt_i_i_s) + : ((func7 == random_i_7i) ? opt_i_7i_s_rand : opt_i_7i_s); + return (true); + } + if (int_optimize(sc, cdr(car_x))) { + opc->v[4].fi = sc->opts[start]->v[0].fi; + opc->v[0].fi = + (func) ? ((func == abs_i_i) ? opt_i_i_f_abs : opt_i_i_f) : + opt_i_7i_f; + return (true); + } + pc_fallback(sc, start); + } + if (!is_t_ratio(cadr(car_x))) { + idf = s7_i_7d_function(s_func); + if (idf) { + opc->v[2].i_7d_f = idf; + if (is_small_real(cadr(car_x))) { + opc->v[1].x = s7_number_to_real(sc, cadr(car_x)); + opc->v[0].fi = opt_i_d_c; + return (true); + } + p = opt_float_symbol(sc, cadr(car_x)); + if (p) { + opc->v[1].p = p; + opc->v[0].fi = opt_i_d_s; + return (true); + } + if (float_optimize(sc, cdr(car_x))) { + opc->v[0].fi = opt_i_7d_f; + opc->v[4].fd = sc->opts[start]->v[0].fd; + return (true); + } + pc_fallback(sc, start); + } + } + ipf = s7_i_7p_function(s_func); + if (ipf) { + opc->v[2].i_7p_f = ipf; + if (cell_optimize(sc, cdr(car_x))) { + opc->v[0].fi = + (ipf == + char_to_integer_i_7p) ? opt_i_7p_f_cint : opt_i_7p_f; + opc->v[4].fp = sc->opts[start]->v[0].fp; + return (true); + } + pc_fallback(sc, start); + } + return_false(sc, car_x); +} + + +/* -------- i_pi -------- */ + +static s7_int opt_i_7pi_ss(opt_info * o) +{ + return (o->v[3].i_7pi_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)))); +} + +static s7_int opt_7pi_ss_ivref(opt_info * o) +{ + return (int_vector + (slot_value(o->v[1].p), integer(slot_value(o->v[2].p)))); +} + +static s7_int opt_7pi_ss_bvref(opt_info * o) +{ + return (byte_vector + (slot_value(o->v[1].p), integer(slot_value(o->v[2].p)))); +} + +static s7_int opt_i_7pi_sf(opt_info * o) +{ + return (o->v[3].i_7pi_f(opt_sc(o), slot_value(o->v[1].p), + o->v[5].fi(o->v[4].o1))); +} + +static bool i_7pi_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_pointer sig; + s7_i_7pi_t pfunc; + + pfunc = s7_i_7pi_function(s_func); + if (!pfunc) + return_false(sc, car_x); + + sig = c_function_signature(s_func); + if (is_pair(sig)) { + s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); + int32_t start = sc->pc; + if ((is_symbol(cadr(sig))) && + (is_symbol(arg1)) && + (slot = opt_types_match(sc, cadr(sig), arg1))) { + s7_pointer p; + opc->v[1].p = slot; + if ((s_func == slot_value(global_slot(sc->int_vector_ref_symbol))) && /* ivref etc */ + ((!is_int_vector(slot_value(slot))) || + (vector_rank(slot_value(slot)) > 1))) + return_false(sc, car_x); + if ((s_func == slot_value(global_slot(sc->byte_vector_ref_symbol))) && /* bvref etc */ + ((!is_byte_vector(slot_value(slot))) || + (vector_rank(slot_value(slot)) > 1))) + return_false(sc, car_x); + + opc->v[3].i_7pi_f = pfunc; + p = opt_integer_symbol(sc, arg2); + if (p) { + opc->v[2].p = p; + opc->v[0].fi = opt_i_7pi_ss; + if ((s_func == + slot_value(global_slot(sc->int_vector_ref_symbol))) + && + (step_end_fits + (opc->v[2].p, + vector_length(slot_value(opc->v[1].p))))) { + opc->v[0].fi = opt_7pi_ss_ivref; + opc->v[3].i_7pi_f = int_vector_ref_unchecked; + } else + if ((s_func == + slot_value(global_slot + (sc->byte_vector_ref_symbol))) + && + (step_end_fits + (opc->v[2].p, + vector_length(slot_value(opc->v[1].p))))) { + opc->v[0].fi = opt_7pi_ss_bvref; + opc->v[3].i_7pi_f = byte_vector_ref_unchecked; + } + return (true); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[0].fi = opt_i_7pi_sf; + opc->v[5].fi = opc->v[4].o1->v[0].fi; + return (true); + } + pc_fallback(sc, start); + } + } + return_false(sc, car_x); +} + +/* -------- i_ii -------- */ +static s7_int opt_i_ii_cc(opt_info * o) +{ + return (o->v[3].i_ii_f(o->v[1].i, o->v[2].i)); +} + +static s7_int opt_i_ii_cs(opt_info * o) +{ + return (o->v[3].i_ii_f(o->v[1].i, integer(slot_value(o->v[2].p)))); +} + +static s7_int opt_i_ii_cs_mul(opt_info * o) +{ + return (o->v[1].i * integer(slot_value(o->v[2].p))); +} + +static s7_int opt_i_ii_sc(opt_info * o) +{ + return (o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i)); +} + +static s7_int opt_i_ii_sc_add(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) + o->v[2].i); +} /* +1 is not faster */ + +static s7_int opt_i_ii_sc_sub(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) - o->v[2].i); +} /* -1 is not faster */ + +static s7_int opt_i_ii_ss(opt_info * o) +{ + return (o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), + integer(slot_value(o->v[2].p)))); +} + +static s7_int opt_i_ii_ss_add(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) + + integer(slot_value(o->v[2].p))); +} + +static s7_pointer opt_p_ii_ss_add(opt_info * o) +{ + return (make_integer + (opt_sc(o), + integer(slot_value(o->v[1].p)) + + integer(slot_value(o->v[2].p)))); +} + +static s7_int opt_i_ii_cf(opt_info * o) +{ + return (o->v[3].i_ii_f(o->v[1].i, o->v[5].fi(o->v[4].o1))); +} + +static s7_int opt_i_ii_cf_mul(opt_info * o) +{ + return (o->v[1].i * o->v[5].fi(o->v[4].o1)); +} + +static s7_int opt_i_ii_sf(opt_info * o) +{ + return (o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), + o->v[5].fi(o->v[4].o1))); +} + +static s7_int opt_i_ii_sf_add(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) + o->v[5].fi(o->v[4].o1)); +} + +static s7_int opt_i_ii_ff(opt_info * o) +{ + s7_int i1, i2; + i1 = o->v[11].fi(o->v[10].o1); + i2 = o->v[9].fi(o->v[8].o1); + return (o->v[3].i_ii_f(i1, i2)); +} + +static s7_int opt_i_ii_fc(opt_info * o) +{ + return (o->v[3].i_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i)); +} + +static s7_int opt_i_ii_fc_add(opt_info * o) +{ + return (o->v[11].fi(o->v[10].o1) + o->v[2].i); +} + +static s7_int opt_i_ii_fc_mul(opt_info * o) +{ + return (o->v[11].fi(o->v[10].o1) * o->v[2].i); +} + +static s7_int opt_i_7ii_fc(opt_info * o) +{ + return (o-> + v[3].i_7ii_f(opt_sc(o), o->v[11].fi(o->v[10].o1), o->v[2].i)); +} + +static s7_int opt_i_ii_fco(opt_info * o) +{ + return (o-> + v[3].i_ii_f(o-> + v[4].i_7pi_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p))), + o->v[5].i)); +} + +static s7_int opt_i_ii_fco_ivref_add(opt_info * o) +{ + return (int_vector_ref_unchecked + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p))) + o->v[5].i); +} /* tref */ + +static s7_int opt_i_7ii_fco(opt_info * o) +{ + return (o->v[3].i_7ii_f(opt_sc(o), + o->v[4].i_7pi_f(opt_sc(o), + slot_value(o->v[1].p), + integer(slot_value + (o->v[2].p))), + o->v[5].i)); +} + +static bool i_ii_fc_combinable(s7_scheme * sc, opt_info * opc, + s7_i_ii_t func) +{ + if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { + opt_info *o1 = sc->opts[sc->pc - 1]; + if ((o1->v[0].fi == opt_i_7pi_ss) + || (o1->v[0].fi == opt_7pi_ss_ivref)) { + opc->v[5].i = opc->v[2].i; /* move v2.i ("c" in fc = arg2) out of the symbols' way */ + opc->v[4].i_7pi_f = o1->v[3].i_7pi_f; + opc->v[1].p = o1->v[1].p; + opc->v[2].p = o1->v[2].p; + if (func) + opc->v[0].fi = ((opc->v[3].i_ii_f == add_i_ii) + && (opc->v[4].i_7pi_f == + int_vector_ref_unchecked)) ? + opt_i_ii_fco_ivref_add : opt_i_ii_fco; + else + opc->v[0].fi = opt_i_7ii_fco; + backup_pc(sc); + return (true); + } + } + return_false(sc, NULL); +} + +static s7_int opt_i_7ii_cc(opt_info * o) +{ + return (o->v[3].i_7ii_f(opt_sc(o), o->v[1].i, o->v[2].i)); +} + +static s7_int opt_i_7ii_cs(opt_info * o) +{ + return (o-> + v[3].i_7ii_f(opt_sc(o), o->v[1].i, + integer(slot_value(o->v[2].p)))); +} + +static s7_int opt_i_7ii_sc(opt_info * o) +{ + return (o-> + v[3].i_7ii_f(opt_sc(o), integer(slot_value(o->v[1].p)), + o->v[2].i)); +} /* currently unhittable I think */ + +static s7_int opt_i_7ii_ss(opt_info * o) +{ + return (o->v[3].i_7ii_f(opt_sc(o), integer(slot_value(o->v[1].p)), + integer(slot_value(o->v[2].p)))); +} + +static s7_int opt_i_7ii_cf(opt_info * o) +{ + return (o->v[3].i_7ii_f(opt_sc(o), o->v[1].i, o->v[5].fi(o->v[4].o1))); +} + +static s7_int opt_i_7ii_sf(opt_info * o) +{ + return (o->v[3].i_7ii_f(opt_sc(o), integer(slot_value(o->v[1].p)), + o->v[5].fi(o->v[4].o1))); +} + +static s7_int opt_i_7ii_ff(opt_info * o) +{ + s7_int i1, i2; + i1 = o->v[11].fi(o->v[10].o1); + i2 = o->v[9].fi(o->v[8].o1); + return (o->v[3].i_7ii_f(opt_sc(o), i1, i2)); +} + +#if WITH_GMP +static s7_int opt_add_i_random_i(opt_info * o) +{ + return (o->v[1].i + (s7_int) (o->v[2].i * next_random(opt_sc(o)))); +} + +static s7_int opt_subtract_random_i_i(opt_info * o) +{ + return ((s7_int) (o->v[1].i * next_random(opt_sc(o))) - o->v[2].i); +} +#else +static s7_int opt_add_i_random_i(opt_info * o) +{ + return (o->v[1].i + + (s7_int) (o->v[2].i * next_random(opt_sc(o)->default_rng))); +} + +static s7_int opt_subtract_random_i_i(opt_info * o) +{ + return ((s7_int) (o->v[1].i * next_random(opt_sc(o)->default_rng)) - + o->v[2].i); +} +#endif + +static bool i_ii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_i_ii_t ifunc; + s7_i_7ii_t ifunc7 = NULL; + s7_pointer p, sig; + + ifunc = s7_i_ii_function(s_func); + if (!ifunc) { + ifunc7 = s7_i_7ii_function(s_func); + if (!ifunc7) + return_false(sc, car_x); + } + sig = c_function_signature(s_func); + if (is_pair(sig)) { + s7_pointer arg1 = cadr(car_x), arg2 = caddr(car_x); + int32_t start = sc->pc; + if (ifunc) + opc->v[3].i_ii_f = ifunc; + else + opc->v[3].i_7ii_f = ifunc7; + + if (is_t_integer(arg1)) { + opc->v[1].i = integer(arg1); + if (is_t_integer(arg2)) { + opc->v[2].i = integer(arg2); + opc->v[0].fi = (ifunc) ? opt_i_ii_cc : opt_i_7ii_cc; + return (true); + } + p = opt_integer_symbol(sc, arg2); + if (p) { + opc->v[2].p = p; + if (ifunc) + opc->v[0].fi = + (opc->v[3].i_ii_f == + multiply_i_ii) ? opt_i_ii_cs_mul : opt_i_ii_cs; + else + opc->v[0].fi = opt_i_7ii_cs; + return (true); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + if (ifunc) { + opc->v[0].fi = opt_i_ii_cf; /* sc->opts[start]->v[0].fi -> opt_i_7i_c -> same_opt->v[2].i_7i_f = random_i_7i tmap */ + if ((ifunc == add_i_ii) + && (opc == sc->opts[sc->pc - 2]) + && (sc->opts[start]->v[0].fi == opt_i_7i_c) + && (sc->opts[start]->v[2].i_7i_f == random_i_7i)) { + opc->v[0].fi = opt_add_i_random_i; + opc->v[2].i = sc->opts[start]->v[1].i; + backup_pc(sc); + } else if (ifunc == multiply_i_ii) + opc->v[0].fi = opt_i_ii_cf_mul; + } else + opc->v[0].fi = opt_i_7ii_cf; + opc->v[5].fi = opc->v[4].o1->v[0].fi; + return (true); + } + pc_fallback(sc, start); + } else { + p = opt_integer_symbol(sc, arg1); + if (p) { + opc->v[1].p = p; + if (is_t_integer(arg2)) { + opc->v[2].i = integer(arg2); + if (ifunc) { + if (opc->v[3].i_ii_f == add_i_ii) + opc->v[0].fi = opt_i_ii_sc_add; + else + opc->v[0].fi = (opc->v[3].i_ii_f == subtract_i_ii) ? opt_i_ii_sc_sub : opt_i_ii_sc; /* add1/sub1 are not faster */ + } else + opc->v[0].fi = opt_i_7ii_sc; + if ((car(car_x) == sc->modulo_symbol) && + (integer(arg2) > 1)) + opc->v[3].i_ii_f = modulo_i_ii_unchecked; + else { + if (car(car_x) == sc->ash_symbol) { + if (opc->v[2].i < 0) { + opc->v[3].i_ii_f = + (opc->v[2].i == + -1) ? rsh_i_i2_direct : + rsh_i_ii_unchecked; + opc->v[0].fi = opt_i_ii_sc; + } else if (opc->v[2].i < S7_INT_BITS) { + opc->v[3].i_ii_f = lsh_i_ii_unchecked; + opc->v[0].fi = opt_i_ii_sc; + } + } else if (opc->v[2].i > 0) { + /* these assume vunion is a union, not a struct; i_7ii_f otherwise might be leftover from a previous use */ + if (opc->v[3].i_7ii_f == quotient_i_7ii) { + opc->v[3].i_ii_f = quotient_i_ii_unchecked; + opc->v[0].fi = opt_i_ii_sc; + } else if ((opc->v[2].i > 1) + && (opc->v[3].i_7ii_f == + remainder_i_7ii)) { + opc->v[3].i_ii_f = + remainder_i_ii_unchecked; + opc->v[0].fi = opt_i_ii_sc; + } + } + } + return (true); + } /* opt_int arg2 */ + p = opt_integer_symbol(sc, arg2); + if (p) { + opc->v[2].p = p; + if (ifunc) + opc->v[0].fi = + (opc->v[3].i_ii_f == + add_i_ii) ? opt_i_ii_ss_add : opt_i_ii_ss; + else + opc->v[0].fi = opt_i_7ii_ss; + return (true); + } + if (int_optimize(sc, cddr(car_x))) { + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fi = sc->opts[start]->v[0].fi; + if (ifunc) + opc->v[0].fi = + (opc->v[3].i_ii_f == + add_i_ii) ? opt_i_ii_sf_add : opt_i_ii_sf; + else + opc->v[0].fi = opt_i_7ii_sf; + return (true); + } + pc_fallback(sc, start); + } else { + if (is_t_integer(arg2)) { + opc->v[2].i = integer(arg2); + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + if (!i_ii_fc_combinable(sc, opc, ifunc)) { + if (ifunc) { + if (opc->v[3].i_ii_f == add_i_ii) { + opc->v[0].fi = opt_i_ii_fc_add; + return (true); + } + if (opc->v[3].i_ii_f == multiply_i_ii) { + opc->v[0].fi = opt_i_ii_fc_mul; + return (true); + } + opc->v[0].fi = opt_i_ii_fc; + + if ((opc->v[3].i_ii_f == subtract_i_ii) + && (opc == sc->opts[sc->pc - 2]) + && (sc->opts[start]->v[0].fi == + opt_i_7i_c) + && (sc->opts[start]->v[2].i_7i_f == + random_i_7i)) { + opc->v[0].fi = opt_subtract_random_i_i; + opc->v[1].i = sc->opts[start]->v[1].i; + backup_pc(sc); + } + } else + opc->v[0].fi = opt_i_7ii_fc; + if (opc->v[2].i > 0) { + if (opc->v[3].i_7ii_f == quotient_i_7ii) { + opc->v[3].i_ii_f = + quotient_i_ii_unchecked; + opc->v[0].fi = opt_i_ii_fc; + } else if ((opc->v[2].i > 1) + && (opc->v[3].i_7ii_f == + remainder_i_7ii)) { + opc->v[3].i_ii_f = + remainder_i_ii_unchecked; + opc->v[0].fi = opt_i_ii_fc; + } + } + } + return (true); + } + pc_fallback(sc, start); + } else { + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[0].fi = + (ifunc) ? opt_i_ii_ff : opt_i_7ii_ff; + return (true); + } + pc_fallback(sc, start); + } + } + } + } + } + return_false(sc, car_x); +} + +/* -------- i_iii -------- */ +static s7_int opt_i_iii_fff(opt_info * o) +{ + s7_int i1, i2, i3; + i1 = o->v[11].fi(o->v[10].o1); + i2 = o->v[9].fi(o->v[8].o1); + i3 = o->v[5].fi(o->v[4].o1); + return (o->v[3].i_iii_f(i1, i2, i3)); +} + +static bool i_iii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + int32_t start; + s7_i_iii_t ifunc; + ifunc = s7_i_iii_function(s_func); + if (!ifunc) + return_false(sc, car_x); + start = sc->pc; + opc->v[10].o1 = sc->opts[start]; + if (int_optimize(sc, cdr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[4].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(car_x))) { + opc->v[3].i_iii_f = ifunc; + opc->v[0].fi = opt_i_iii_fff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[5].fi = opc->v[4].o1->v[0].fi; + return (true); + } + } + } + pc_fallback(sc, start); + return_false(sc, car_x); +} + +/* -------- i_7pii -------- */ +static s7_int opt_i_7pii_ssf(opt_info * o) +{ + return (o->v[3].i_7pii_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + o->v[5].fi(o->v[4].o1))); +} + +static s7_int opt_i_7pii_ssf_vset(opt_info * o) +{ + return (int_vector_set_unchecked + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), o->v[5].fi(o->v[4].o1))); +} + +static s7_int opt_i_7pii_ssc(opt_info * o) +{ + return (o->v[3].i_7pii_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), o->v[4].i)); +} + +static s7_int opt_i_7pii_sss(opt_info * o) +{ + return (o->v[4].i_7pii_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p)))); +} + +static s7_int opt_i_pii_sss_ivref_unchecked(opt_info * o) +{ + s7_pointer v = slot_value(o->v[1].p); + return (int_vector + (v, + ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + + integer(slot_value(o->v[3].p))))); +} + +static s7_int opt_i_7pii_sff(opt_info * o) +{ + s7_int i1, i2; + i1 = o->v[11].fi(o->v[10].o1); + i2 = o->v[9].fi(o->v[8].o1); + return (o->v[3].i_7pii_f(opt_sc(o), slot_value(o->v[1].p), i1, i2)); +} + + +/* -------- i_7piii -------- */ +static s7_int opt_i_7piii_sssf(opt_info * o) +{ + return (o->v[5].i_7piii_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p)), + o->v[11].fi(o->v[10].o1))); +} + +static s7_int opt_i_piii_sssf_ivset_unchecked(opt_info * o) +{ + s7_pointer v = slot_value(o->v[1].p); + s7_int val; + val = o->v[11].fi(o->v[10].o1); + int_vector(v, + ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + + integer(slot_value(o->v[3].p)))) = val; + return (val); +} + +static s7_int opt_i_7piii_sssc(opt_info * o) +{ + return (o->v[5].i_7piii_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p)), o->v[4].i)); +} + +static s7_int opt_i_7piii_ssss(opt_info * o) +{ + return (o->v[5].i_7piii_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p)), + integer(slot_value(o->v[4].p)))); +} + +static s7_int opt_i_7piii_sfff(opt_info * o) +{ + s7_int i1, i2, i3; + i1 = o->v[11].fi(o->v[10].o1); + i2 = o->v[9].fi(o->v[8].o1); + i3 = o->v[6].fi(o->v[4].o1); + return (o-> + v[5].i_7piii_f(opt_sc(o), slot_value(o->v[1].p), i1, i2, i3)); +} + +static bool opt_i_7piii_args(s7_scheme * sc, opt_info * opc, + s7_pointer indexp1, s7_pointer indexp2, + s7_pointer valp) +{ + /* opc->v[5] is the called function (int-vector-set! etc) */ + s7_pointer slot; + slot = opt_integer_symbol(sc, car(indexp2)); + if (slot) { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) { + opc->v[2].p = slot; + if (is_t_integer(car(valp))) { + opc->v[0].fi = opt_i_7piii_sssc; + opc->v[4].i = integer(car(valp)); + return (true); + } + slot = opt_integer_symbol(sc, car(valp)); + if (slot) { + opc->v[4].p = slot; + opc->v[0].fi = opt_i_7piii_ssss; + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, valp)) { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[0].fi = opt_i_7piii_sssf; + if ((opc->v[5].i_7piii_f == int_vector_set_i_7piii) && + (step_end_fits + (opc->v[2].p, + vector_dimension(slot_value(opc->v[1].p), 0))) + && + (step_end_fits + (opc->v[3].p, + vector_dimension(slot_value(opc->v[1].p), 1)))) + opc->v[0].fi = opt_i_piii_sssf_ivset_unchecked; + return (true); + } + } + return_false(sc, NULL); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) { + opc->v[4].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, valp)) { + opc->v[0].fi = opt_i_7piii_sfff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[6].fi = opc->v[4].o1->v[0].fi; /* v[5] is in use */ + return (true); + } + } + } + return_false(sc, indexp1); +} + +static bool opt_int_vector_set(s7_scheme * sc, int otype, opt_info * opc, + s7_pointer v, s7_pointer indexp1, + s7_pointer indexp2, s7_pointer valp) +{ + s7_pointer settee; + settee = lookup_slot_from(v, sc->curlet); + if ((is_slot(settee)) && (!is_immutable(slot_value(settee)))) { + bool int_case; + s7_pointer slot, vect = slot_value(settee); + int_case = (is_int_vector(vect)); + opc->v[1].p = settee; + if ((int_case) || (is_byte_vector(vect))) { + if ((otype >= 0) && (otype != ((int_case) ? 1 : 0))) + return_false(sc, indexp1); + if ((!indexp2) && (vector_rank(vect) == 1)) { + opc->v[3].i_7pii_f = + (int_case) ? int_vector_set_i_7pii : + byte_vector_set_i_7pii; + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) { + int32_t start = sc->pc; + opc->v[2].p = slot; + if (step_end_fits(opc->v[2].p, vector_length(vect))) + opc->v[3].i_7pii_f = + (int_case) ? int_vector_set_unchecked : + byte_vector_set_unchecked; + if ((is_pair(valp)) && (is_null(cdr(valp))) + && (is_t_integer(car(valp)))) { + opc->v[4].i = integer(car(valp)); + opc->v[0].fi = opt_i_7pii_ssc; + return (true); + } + if (!int_optimize(sc, valp)) + return_false(sc, NULL); + opc->v[0].fi = + (opc->v[3].i_7pii_f == + int_vector_set_unchecked) ? opt_i_7pii_ssf_vset : + opt_i_7pii_ssf; + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fi = sc->opts[start]->v[0].fi; + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, valp)) { + opc->v[0].fi = opt_i_7pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + return (true); + } + } + return_false(sc, NULL); + } + if ((indexp2) && (vector_rank(vect) == 2)) { + opc->v[5].i_7piii_f = + (int_case) ? int_vector_set_i_7piii : + byte_vector_set_i_7piii; + return (opt_i_7piii_args(sc, opc, indexp1, indexp2, valp)); + } + } + } + return_false(sc, v); +} + +static bool is_target_or_its_alias(s7_pointer symbol, s7_pointer symfunc, + s7_pointer target) +{ + return ((symbol == target) || (symfunc == initial_value(target))); +} + +static bool i_7pii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_pointer sig; + s7_i_7pii_t pfunc; + pfunc = s7_i_7pii_function(s_func); + if (!pfunc) + return_false(sc, car_x); + sig = c_function_signature(s_func); + if ((is_pair(sig)) && (is_symbol(cadr(car_x)))) { + s7_pointer slot, fname = car(car_x); + + if ((is_target_or_its_alias + (fname, s_func, sc->int_vector_set_symbol)) + || + (is_target_or_its_alias + (fname, s_func, sc->byte_vector_set_symbol))) + return (opt_int_vector_set + (sc, (fname == sc->int_vector_set_symbol) ? 1 : 0, opc, + cadr(car_x), cddr(car_x), NULL, cdddr(car_x))); + + slot = opt_types_match(sc, cadr(sig), cadr(car_x)); + if (slot) { + s7_pointer arg2, p; + int32_t start = sc->pc; + opc->v[1].p = slot; + + if (((is_target_or_its_alias + (fname, s_func, sc->int_vector_ref_symbol)) + || + (is_target_or_its_alias + (fname, s_func, sc->byte_vector_ref_symbol))) + && (vector_rank(slot_value(slot)) != 2)) + return_false(sc, car_x); + + arg2 = caddr(car_x); + p = opt_integer_symbol(sc, arg2); + if (p) { + opc->v[2].p = p; + p = opt_integer_symbol(sc, cadddr(car_x)); + if (p) { + opc->v[3].p = p; + opc->v[4].i_7pii_f = pfunc; + opc->v[0].fi = opt_i_7pii_sss; + if ((pfunc == int_vector_ref_i_7pii) && + (step_end_fits + (opc->v[2].p, + vector_dimension(slot_value(opc->v[1].p), 0))) + && + (step_end_fits + (opc->v[3].p, + vector_dimension(slot_value(opc->v[1].p), 1)))) + opc->v[0].fi = opt_i_pii_sss_ivref_unchecked; + return (true); + } + if (int_optimize(sc, cdddr(car_x))) { + opc->v[3].i_7pii_f = pfunc; + opc->v[0].fi = opt_i_7pii_ssf; + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fi = sc->opts[start]->v[0].fi; + return (true); + } + return_false(sc, car_x); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(car_x))) { + opc->v[3].i_7pii_f = pfunc; + opc->v[0].fi = opt_i_7pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + return (true); + } + } + pc_fallback(sc, start); + } + } + return_false(sc, car_x); +} + +static bool i_7piii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_i_7piii_t f; + f = s7_i_7piii_function(s_func); + if ((f) && (is_symbol(cadr(car_x)))) { + s7_pointer settee; + if ((is_target_or_its_alias + (car(car_x), s_func, sc->int_vector_set_symbol)) + || + (is_target_or_its_alias + (car(car_x), s_func, sc->byte_vector_set_symbol))) + return (opt_int_vector_set + (sc, (car(car_x) == sc->int_vector_set_symbol) ? 1 : 0, + opc, cadr(car_x), cddr(car_x), cdddr(car_x), + cddddr(car_x))); + + settee = lookup_slot_from(cadr(car_x), sc->curlet); + if (is_slot(settee)) { + s7_pointer vect = slot_value(settee); + if ((is_int_vector(vect)) && (vector_rank(vect) == 3)) { + opc->v[5].i_7piii_f = f; + opc->v[1].p = settee; + return (opt_i_7piii_args + (sc, opc, cddr(car_x), cdddr(car_x), + cddddr(car_x))); + } + } + } + return_false(sc, car_x); +} + +/* -------- i_add|multiply_any -------- */ +static s7_int opt_i_add_any_f(opt_info * o) +{ + s7_int sum = 0; + int32_t i; + for (i = 0; i < o->v[1].i; i++) { + opt_info *o1; + o1 = o->v[i + 2].o1; + sum += o1->v[0].fi(o1); + } + return (sum); +} + +static s7_int opt_i_add2(opt_info * o) +{ + s7_int sum; + sum = o->v[6].fi(o->v[2].o1); + return (sum + o->v[7].fi(o->v[3].o1)); +} + +static s7_int opt_i_mul2(opt_info * o) +{ + s7_int sum; + sum = o->v[6].fi(o->v[2].o1); + return (sum * o->v[7].fi(o->v[3].o1)); +} + +static s7_int opt_i_add3(opt_info * o) +{ + s7_int sum; + sum = o->v[6].fi(o->v[2].o1); + sum += o->v[7].fi(o->v[3].o1); + return (sum + o->v[8].fi(o->v[4].o1)); +} + +static s7_int opt_i_mul3(opt_info * o) +{ + s7_int sum; + sum = o->v[6].fi(o->v[2].o1); + sum *= o->v[7].fi(o->v[3].o1); + return (sum * o->v[8].fi(o->v[4].o1)); +} + +static s7_int opt_i_add4(opt_info * o) +{ + s7_int sum; + sum = o->v[6].fi(o->v[2].o1); + sum += o->v[7].fi(o->v[3].o1); + sum += o->v[8].fi(o->v[4].o1); + return (sum + o->v[9].fi(o->v[5].o1)); +} + +static s7_int opt_i_mul4(opt_info * o) +{ + s7_int sum; + sum = o->v[6].fi(o->v[2].o1); + sum *= o->v[7].fi(o->v[3].o1); + sum *= o->v[8].fi(o->v[4].o1); + return (sum * o->v[9].fi(o->v[5].o1)); +} + +static s7_int opt_i_multiply_any_f(opt_info * o) +{ + s7_int sum = 1; + int32_t i; + for (i = 0; i < o->v[1].i; i++) { + opt_info *o1; + o1 = o->v[i + 2].o1; + sum *= o1->v[0].fi(o1); + } + return (sum); +} + +static bool i_add_any_ok(s7_scheme * sc, opt_info * opc, s7_pointer car_x) +{ + s7_pointer p, head = car(car_x); + int32_t cur_len, start = sc->pc; + for (cur_len = 0, p = cdr(car_x); (is_pair(p)) && (cur_len < 12); + p = cdr(p), cur_len++) { + opc->v[cur_len + 2].o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, p)) + break; + } + if (is_null(p)) { + opc->v[1].i = cur_len; + if (cur_len <= 4) { + int32_t i; + for (i = 0; i < cur_len; i++) + opc->v[i + 6].fi = opc->v[i + 2].o1->v[0].fi; + } + if (cur_len == 2) + opc->v[0].fi = + (head == sc->add_symbol) ? opt_i_add2 : opt_i_mul2; + else if (cur_len == 3) + opc->v[0].fi = + (head == sc->add_symbol) ? opt_i_add3 : opt_i_mul3; + else if (cur_len == 4) + opc->v[0].fi = + (head == sc->add_symbol) ? opt_i_add4 : opt_i_mul4; + else + opc->v[0].fi = + (head == + sc->add_symbol) ? opt_i_add_any_f : opt_i_multiply_any_f; + return (true); + } + pc_fallback(sc, start); + return_false(sc, car_x); +} + + +/* -------- set_i_i -------- */ +static s7_int opt_set_i_i_f(opt_info * o) +{ + s7_int x; + x = o->v[3].fi(o->v[2].o1); + slot_set_value(o->v[1].p, make_integer(opt_sc(o), x)); + return (x); +} + +static s7_int opt_set_i_i_fm(opt_info * o) +{ /* called in increment: (set! sum (+ sum (...))) where are all ints */ + s7_int x; + x = o->v[3].fi(o->v[2].o1); + integer(slot_value(o->v[1].p)) = x; + return (x); +} + +static s7_int opt_set_i_i_fo(opt_info * o) +{ + s7_int x; + x = integer(slot_value(o->v[3].p)) + o->v[2].i; + slot_set_value(o->v[1].p, make_integer(opt_sc(o), x)); + return (x); +} + +static bool set_i_i_f_combinable(s7_scheme * sc, opt_info * opc) +{ + if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { + opt_info *o1 = sc->opts[sc->pc - 1]; + if (o1->v[0].fi == opt_i_ii_sc_add) { + /* opc->v[4].i_ii_f = o1->v[3].i_ii_f; */ + opc->v[3].p = o1->v[1].p; + opc->v[2].i = o1->v[2].i; + opc->v[0].fi = opt_set_i_i_fo; + backup_pc(sc); + return (true); /* ii_sc v[1].p is a slot */ + } + } + return_false(sc, NULL); +} + +static bool i_syntax_ok(s7_scheme * sc, s7_pointer car_x, int32_t len) +{ + if ((car(car_x) == sc->set_symbol) && (len == 3)) { + opt_info *opc; + opc = alloc_opo(sc); + if (is_symbol(cadr(car_x))) { /* (set! i 3) */ + s7_pointer settee; + if (is_immutable(cadr(car_x))) + return_false(sc, car_x); + settee = lookup_slot_from(cadr(car_x), sc->curlet); + if ((is_slot(settee)) && + (!is_immutable(settee)) && ((!slot_has_setter(settee)) + || (slot_setter(settee) != + initial_value(sc-> + is_integer_symbol)))) + { + opt_info *o1 = sc->opts[sc->pc]; + opc->v[1].p = settee; + if ((is_t_integer(slot_value(settee))) && + (int_optimize(sc, cddr(car_x)))) { + if (set_i_i_f_combinable(sc, opc)) + return (true); + opc->v[0].fi = + (is_mutable_integer(slot_value(opc->v[1].p))) ? + opt_set_i_i_fm : opt_set_i_i_f; + opc->v[2].o1 = o1; + opc->v[3].fi = o1->v[0].fi; + return (true); /* or OO_I? */ + } + } + } else if ((is_pair(cadr(car_x))) && /* if is_pair(settee) get setter */ + (is_symbol(caadr(car_x))) && (is_pair(cdadr(car_x)))) { + if (is_null(cddadr(car_x))) + return (opt_int_vector_set + (sc, -1, opc, caadr(car_x), cdadr(car_x), NULL, + cddr(car_x))); + if (is_null(cdddr(cadr(car_x)))) + return (opt_int_vector_set + (sc, -1, opc, caadr(car_x), cdadr(car_x), + cddadr(car_x), cddr(car_x))); + } + } + return_false(sc, car_x); +} + +static bool i_implicit_ok(s7_scheme * sc, s7_pointer s_slot, + s7_pointer car_x, int32_t len) +{ + s7_pointer obj = slot_value(s_slot); + if ((is_int_vector(obj)) || (is_byte_vector(obj))) { + bool int_case = is_int_vector(obj); + s7_pointer slot; + + if ((len == 2) && (vector_rank(obj) == 1)) { + opt_info *opc; + opc = alloc_opo(sc); + opc->v[1].p = s_slot; + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) { + opc->v[0].fi = opt_i_7pi_ss; + opc->v[3].i_7pi_f = + (int_case) ? int_vector_ref_i_7pi : + byte_vector_ref_i_7pi; + opc->v[2].p = slot; + if (step_end_fits(opc->v[2].p, vector_length(obj))) + opc->v[3].i_7pi_f = + (int_case) ? int_vector_ref_unchecked : + byte_vector_ref_unchecked; + /* not opc->v[0].fi = opt_7pi_ss_ivref -- this causes a huge slowdown in dup.scm?? */ + return (true); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(car_x))) + return_false(sc, car_x); + opc->v[0].fi = opt_i_7pi_sf; + opc->v[3].i_7pi_f = + (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; + opc->v[5].fi = opc->v[4].o1->v[0].fi; + return (true); + } + if ((len == 3) && (vector_rank(obj) == 2)) { + opt_info *opc; + opc = alloc_opo(sc); + opc->v[1].p = s_slot; + + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) { + opc->v[2].p = slot; + slot = opt_integer_symbol(sc, caddr(car_x)); + if (!slot) + return_false(sc, car_x); + opc->v[4].i_7pii_f = + (int_case) ? int_vector_ref_i_7pii : + byte_vector_ref_i_7pii; + opc->v[3].p = slot; + opc->v[0].fi = opt_i_7pii_sss; + if ((int_case) && + (step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) + && + (step_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) + opc->v[0].fi = opt_i_pii_sss_ivref_unchecked; + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[3].i_7pii_f = + (int_case) ? int_vector_ref_i_7pii : + byte_vector_ref_i_7pii; + opc->v[0].fi = opt_i_7pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + return (true); + } + } + } + } + return_false(sc, car_x); +} + + +/* ------------------------------------- float opts ------------------------------------------- */ + +static s7_double opt_d_c(opt_info * o) +{ + return (o->v[1].x); +} + +static s7_double opt_d_s(opt_info * o) +{ + return (real(slot_value(o->v[1].p))); +} + +static s7_double opt_D_s(opt_info * o) +{ + s7_pointer x = slot_value(o->v[1].p); + return ((is_t_integer(x)) ? (s7_double) (integer(x)) : + s7_number_to_real(opt_sc(o), x)); +} + +static bool opt_float_not_pair(s7_scheme * sc, s7_pointer car_x) +{ + opt_info *opc; + s7_pointer p; + if (is_small_real(car_x)) { + opc = alloc_opo(sc); + opc->v[1].x = s7_number_to_real(sc, car_x); + opc->v[0].fd = opt_d_c; + return (true); + } + p = opt_real_symbol(sc, car_x); + if (p) { + opc = alloc_opo(sc); + opc->v[1].p = p; + opc->v[0].fd = (is_t_real(slot_value(p))) ? opt_d_s : opt_D_s; + return (true); + } + return_false(sc, car_x); +} + +/* -------- d -------- */ +static s7_double opt_d_f(opt_info * o) +{ + return (o->v[1].d_f()); +} + +static bool d_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func) +{ + s7_d_t func; /* (f): (mus-srate) */ + func = s7_d_function(s_func); + if (!func) + return_false(sc, NULL); + opc->v[0].fd = opt_d_f; + opc->v[1].d_f = func; + return (true); +} + +/* -------- d_d -------- */ +static s7_double opt_d_d_c(opt_info * o) +{ + return (o->v[3].d_d_f(o->v[1].x)); +} + +static s7_double opt_d_d_s(opt_info * o) +{ + return (o->v[3].d_d_f(real(slot_value(o->v[1].p)))); +} + +static s7_double opt_d_d_s_abs(opt_info * o) +{ + return (abs_d_d(real(slot_value(o->v[1].p)))); +} + +static s7_double opt_d_7d_c(opt_info * o) +{ + return (o->v[3].d_7d_f(opt_sc(o), o->v[1].x)); +} + +static s7_double opt_d_7d_s(opt_info * o) +{ + return (o->v[3].d_7d_f(opt_sc(o), real(slot_value(o->v[1].p)))); +} + +static s7_double opt_d_d_f(opt_info * o) +{ + return (o->v[3].d_d_f(o->v[5].fd(o->v[4].o1))); +} + +static s7_double opt_d_d_f_abs(opt_info * o) +{ + return (abs_d_d(o->v[5].fd(o->v[4].o1))); +} + +static s7_double opt_d_d_f_sin(opt_info * o) +{ + return (sin_d_d(o->v[5].fd(o->v[4].o1))); +} + +static s7_double opt_d_d_f_cos(opt_info * o) +{ + return (cos_d_d(o->v[5].fd(o->v[4].o1))); +} + +static s7_double opt_d_7d_f(opt_info * o) +{ + return (o->v[3].d_7d_f(opt_sc(o), o->v[5].fd(o->v[4].o1))); +} + +static s7_double opt_d_7d_f_divide(opt_info * o) +{ + return (divide_d_7d(opt_sc(o), o->v[5].fd(o->v[4].o1))); +} + +static s7_double opt_d_7pi_ss_fvref_unchecked(opt_info * o); +static s7_double opt_abs_d_ss_fvref(opt_info * o) +{ + opt_info *o1 = o->v[4].o1; + return (abs_d_d + (float_vector + (slot_value(o1->v[1].p), integer(slot_value(o1->v[2].p))))); +} + +static bool d_d_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_d_d_t func; + s7_d_7d_t func7 = NULL; + int32_t start = sc->pc; + + func = s7_d_d_function(s_func); + if (!func) + func7 = s7_d_7d_function(s_func); + if ((func) || (func7)) { + s7_pointer p; + if (func) + opc->v[3].d_d_f = func; + else + opc->v[3].d_7d_f = func7; + if (is_small_real(cadr(car_x))) { + if ((!is_t_real(cadr(car_x))) && /* (random 1) != (random 1.0) */ + ((car(car_x) == sc->random_symbol) || + (car(car_x) == sc->sin_symbol) || + (car(car_x) == sc->cos_symbol))) + return_false(sc, car_x); + opc->v[1].x = s7_number_to_real(sc, cadr(car_x)); + opc->v[0].fd = (func) ? opt_d_d_c : opt_d_7d_c; + return (true); + } + p = opt_float_symbol(sc, cadr(car_x)); + if ((p) && (!has_methods(slot_value(p)))) { + opc->v[1].p = p; + opc->v[0].fd = + (func) ? ((func == abs_d_d) ? opt_d_d_s_abs : opt_d_d_s) : + opt_d_7d_s; + return (true); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(car_x))) { + opc->v[0].fd = + (func) ? ((func == abs_d_d) ? opt_d_d_f_abs + : ((func == + sin_d_d) ? opt_d_d_f_sin : ((func == + cos_d_d) ? + opt_d_d_f_cos : + opt_d_d_f))) + : ((func7 == + divide_d_7d) ? opt_d_7d_f_divide : opt_d_7d_f); + opc->v[5].fd = opc->v[4].o1->v[0].fd; + if ((func == abs_d_d) + && (opc->v[5].fd == opt_d_7pi_ss_fvref_unchecked)) + opc->v[0].fd = opt_abs_d_ss_fvref; + return (true); + } + pc_fallback(sc, start); + } + return_false(sc, car_x); +} + +/* -------- d_v -------- */ +static s7_double opt_d_v(opt_info * o) +{ + return (o->v[3].d_v_f(o->v[5].obj)); +} + +static bool d_v_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_pointer sig; + s7_d_v_t flt_func; + flt_func = s7_d_v_function(s_func); + if (!flt_func) + return_false(sc, car_x); + sig = c_function_signature(s_func); + if ((is_pair(sig)) && (is_symbol(cadr(sig))) && (is_symbol(cadr(car_x)))) { /* look for (oscil g) */ + s7_pointer slot; + slot = opt_types_match(sc, cadr(sig), cadr(car_x)); + if (slot) { + opc->v[1].p = slot; + opc->v[5].obj = (void *) c_object_value(slot_value(slot)); + opc->v[3].d_v_f = flt_func; + opc->v[0].fd = opt_d_v; + return (true); + } + } + return_false(sc, car_x); +} + +/* -------- d_p -------- */ +static s7_double opt_d_p_s(opt_info * o) +{ + return (o->v[3].d_p_f(slot_value(o->v[1].p))); +} + +static s7_double opt_d_p_f(opt_info * o) +{ + return (o->v[3].d_p_f(o->v[5].fp(o->v[4].o1))); +} + +static bool d_p_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_d_p_t dpf; /* mostly clm gens */ + int32_t start = sc->pc; + dpf = s7_d_p_function(s_func); + if (!dpf) + return_false(sc, car_x); + opc->v[3].d_p_f = dpf; + if (is_symbol(cadr(car_x))) { + s7_pointer slot; + slot = opt_simple_symbol(sc, cadr(car_x)); + if (!slot) + return_false(sc, car_x); + opc->v[1].p = slot; + opc->v[0].fd = opt_d_p_s; + return (true); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(car_x))) { + opc->v[0].fd = opt_d_p_f; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + return (true); + } + pc_fallback(sc, start); + return_false(sc, car_x); +} + +/* -------- d_7pi -------- */ + +static s7_double opt_d_7pi_sc(opt_info * o) +{ + return (o->v[3].d_7pi_f(opt_sc(o), slot_value(o->v[1].p), o->v[2].i)); +} + +static s7_double opt_d_7pi_ss(opt_info * o) +{ + return (o->v[3].d_7pi_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)))); +} + +static s7_double opt_d_7pi_sf(opt_info * o) +{ + return (o->v[3].d_7pi_f(opt_sc(o), slot_value(o->v[1].p), + o->v[11].fi(o->v[10].o1))); +} + +static s7_double opt_d_7pi_ss_fvref(opt_info * o) +{ + return (float_vector_ref_d_7pi + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)))); +} + +static s7_double opt_d_7pi_ss_fvref_unchecked(opt_info * o) +{ + return (float_vector + (slot_value(o->v[1].p), integer(slot_value(o->v[2].p)))); +} + +static s7_double opt_d_7pi_ff(opt_info * o) +{ + s7_pointer seq; + seq = o->v[5].fp(o->v[4].o1); + return (o->v[3].d_7pi_f(opt_sc(o), seq, o->v[9].fi(o->v[8].o1))); +} + +static bool d_7pi_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + /* float-vector-ref is checked for a 1D float-vector arg, but other callers should do type checking */ + int32_t start = sc->pc; + s7_d_7pi_t ifunc; + ifunc = s7_d_7pi_function(s_func); /* ifunc: float_vector_ref_d_7pi, s_func: global_value(sc->float_vector_ref_symbol) */ + if (!ifunc) + return_false(sc, car_x); + opc->v[3].d_7pi_f = ifunc; + if (is_symbol(cadr(car_x))) { /* (float-vector-ref v i) */ + s7_pointer arg2, p, obj; + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + if (!is_slot(opc->v[1].p)) + return_false(sc, car_x); + + obj = slot_value(opc->v[1].p); + if ((is_target_or_its_alias + (car(car_x), s_func, sc->float_vector_ref_symbol)) + && ((!is_float_vector(obj)) || (vector_rank(obj) > 1))) + return_false(sc, car_x); + + arg2 = caddr(car_x); + if (!is_pair(arg2)) { + if (is_t_integer(arg2)) { + opc->v[2].i = integer(arg2); + opc->v[0].fd = opt_d_7pi_sc; + return (true); + } + p = opt_integer_symbol(sc, arg2); + if (!p) + return_false(sc, car_x); + opc->v[2].p = p; + opc->v[0].fd = opt_d_7pi_ss; + if (is_target_or_its_alias + (car(car_x), s_func, sc->float_vector_ref_symbol)) { + if (step_end_fits(opc->v[2].p, vector_length(obj))) + opc->v[0].fd = opt_d_7pi_ss_fvref_unchecked; + else + opc->v[0].fd = opt_d_7pi_ss_fvref; + } + return (true); + } + if (int_optimize(sc, cddr(car_x))) { + opc->v[0].fd = opt_d_7pi_sf; + opc->v[10].o1 = sc->opts[start]; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + return (true); + } + pc_fallback(sc, start); + return_false(sc, car_x); + } + + if ((is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) && ((!is_float_vector(cadr(car_x))) || (vector_rank(cadr(car_x)) > 1))) /* (float-vector-ref #r2d((.1 .2) (.3 .4)) 3) */ + return_false(sc, car_x); + + if (cell_optimize(sc, cdr(car_x))) { + opt_info *o2 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[0].fd = opt_d_7pi_ff; + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fp = sc->opts[start]->v[0].fp; + opc->v[8].o1 = o2; + opc->v[9].fi = o2->v[0].fi; + return (true); + } + } + pc_fallback(sc, start); + return_false(sc, car_x); +} + +/* -------- d_ip -------- */ +static s7_double opt_d_ip_ss(opt_info * o) +{ + return (o-> + v[3].d_ip_f(integer(slot_value(o->v[1].p)), + slot_value(o->v[2].p))); +} + +static bool d_ip_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_d_ip_t pfunc; + pfunc = s7_d_ip_function(s_func); + if ((pfunc) && (is_symbol(caddr(car_x)))) { + s7_pointer p; + p = opt_integer_symbol(sc, cadr(car_x)); + if (p) { + opc->v[3].d_ip_f = pfunc; + opc->v[1].p = p; + opc->v[2].p = lookup_slot_from(caddr(car_x), sc->curlet); + if (is_slot(opc->v[2].p)) { /* (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .4 :reverb-amount .5)) */ + opc->v[0].fd = opt_d_ip_ss; + return (true); + } + } + } + return_false(sc, car_x); +} + +/* -------- d_pd -------- */ +static s7_double opt_d_pd_sf(opt_info * o) +{ + return (o-> + v[3].d_pd_f(slot_value(o->v[1].p), o->v[11].fd(o->v[10].o1))); +} + +static s7_double opt_d_pd_ss(opt_info * o) +{ + return (o-> + v[3].d_pd_f(slot_value(o->v[1].p), + real(slot_value(o->v[2].p)))); +} + +static bool d_pd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + if (is_symbol(cadr(car_x))) { + s7_d_pd_t func; + func = s7_d_pd_function(s_func); + if (func) { + s7_pointer p, arg2 = caddr(car_x); + int32_t start = sc->pc; + opc->v[3].d_pd_f = func; + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + if (!is_slot(opc->v[1].p)) + return_false(sc, car_x); + p = opt_float_symbol(sc, arg2); + if (p) { + opc->v[2].p = p; + opc->v[0].fd = opt_d_pd_ss; + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(car_x))) { + opc->v[0].fd = opt_d_pd_sf; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + return (true); + } + pc_fallback(sc, start); + } + } + return_false(sc, car_x); +} + +/* -------- d_vd -------- */ +static s7_double opt_d_vd_c(opt_info * o) +{ + return (o->v[3].d_vd_f(o->v[5].obj, o->v[2].x)); +} + +static s7_double opt_d_vd_s(opt_info * o) +{ + return (o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p)))); +} + +static s7_double opt_d_vd_f(opt_info * o) +{ + return (o->v[3].d_vd_f(o->v[5].obj, o->v[9].fd(o->v[8].o1))); +} + +static s7_double opt_d_vd_o(opt_info * o) +{ + return (o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj))); +} + +static s7_double opt_d_vd_o1_mul(opt_info * o) +{ + return (o->v[3].d_vd_f(o->v[5].obj, + real(slot_value(o->v[2].p)) * + o->v[11].fd(o->v[10].o1))); +} + +static s7_double opt_d_vd_o1(opt_info * o) +{ + return (o->v[3].d_vd_f(o->v[5].obj, + o->v[4].d_dd_f(real(slot_value(o->v[2].p)), + o->v[11].fd(o->v[10].o1)))); +} + +static s7_double opt_d_vd_o2(opt_info * o) +{ + return (o->v[4].d_vd_f(o->v[6].obj, + o->v[5].d_vd_f(o->v[2].obj, + real(slot_value(o->v[3].p))))); +} + +static s7_double opt_d_vd_o3(opt_info * o) +{ + return (o->v[3].d_vd_f(o->v[5].obj, + o->v[4].d_dd_f(o->v[6].x, + real(slot_value(o->v[2].p))))); +} + +static s7_double opt_d_vd_ff(opt_info * o) +{ + return (o->v[3].d_vd_f(o->v[5].obj, + o->v[2].d_vd_f(o->v[4].obj, + o->v[11].fd(o->v[10].o1)))); +} + +static s7_double opt_d_dd_cs(opt_info * o); +static s7_double opt_d_dd_sf_mul(opt_info * o); +static s7_double opt_d_dd_sf_add(opt_info * o); +static s7_double opt_d_dd_sf(opt_info * o); + +static bool d_vd_f_combinable(s7_scheme * sc, int32_t start) +{ + opt_info *opc = sc->opts[start - 1], *o1 = sc->opts[start]; + if (o1->v[0].fd == opt_d_v) { + opc->v[2].p = o1->v[1].p; + opc->v[6].obj = o1->v[5].obj; + opc->v[4].d_v_f = o1->v[3].d_v_f; + opc->v[0].fd = opt_d_vd_o; + backup_pc(sc); + return (true); + } + if (o1->v[0].fd == opt_d_vd_s) { + opc->v[6].obj = opc->v[5].obj; + opc->v[4].d_vd_f = opc->v[3].d_vd_f; /* room for symbols */ + opc->v[2].obj = o1->v[5].obj; + opc->v[5].d_vd_f = o1->v[3].d_vd_f; + opc->v[3].p = o1->v[2].p; + opc->v[7].p = o1->v[1].p; + opc->v[0].fd = opt_d_vd_o2; + backup_pc(sc); + return (true); + } + if (o1->v[0].fd == opt_d_dd_cs) { + opc->v[4].d_dd_f = o1->v[3].d_dd_f; + opc->v[6].x = o1->v[2].x; + opc->v[2].p = o1->v[1].p; + opc->v[0].fd = opt_d_vd_o3; + backup_pc(sc); + return (true); + } + if ((o1->v[0].fd == opt_d_dd_sf_mul) || (o1->v[0].fd == opt_d_dd_sf) + || (o1->v[0].fd == opt_d_dd_sf_add)) { + opc->v[2].p = o1->v[1].p; + opc->v[4].d_dd_f = o1->v[3].d_dd_f; + opc->v[0].fd = + (o1->v[0].fd == + opt_d_dd_sf_mul) ? opt_d_vd_o1_mul : opt_d_vd_o1; + opc->v[11].fd = o1->v[5].fd; + opc->v[10].o1 = o1->v[4].o1; + return (true); + } + if (o1->v[0].fd == opt_d_vd_f) { + opc->v[2].d_vd_f = o1->v[3].d_vd_f; + opc->v[4].obj = o1->v[5].obj; + opc->v[6].p = o1->v[1].p; + opc->v[0].fd = opt_d_vd_ff; + opc->v[11].fd = o1->v[9].fd; + opc->v[10].o1 = o1->v[8].o1; + return (true); + } + return_false(sc, NULL); +} + +static bool d_vd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_pointer sig; + s7_d_vd_t vfunc; + if (!is_symbol(cadr(car_x))) + return_false(sc, car_x); + vfunc = s7_d_vd_function(s_func); + if (!vfunc) + return_false(sc, car_x); + sig = c_function_signature(s_func); + if ((is_pair(sig)) && (is_symbol(cadr(sig)))) { + s7_pointer slot; + slot = opt_types_match(sc, cadr(sig), cadr(car_x)); + if (slot) { + s7_pointer arg2 = caddr(car_x); + int32_t start = sc->pc; + opc->v[3].d_vd_f = vfunc; + if (!is_pair(arg2)) { + opc->v[1].p = slot; + opc->v[5].obj = (void *) c_object_value(slot_value(slot)); + if (is_small_real(arg2)) { + opc->v[2].x = s7_number_to_real(sc, arg2); + opc->v[0].fd = opt_d_vd_c; + return (true); + } + opc->v[2].p = lookup_slot_from(arg2, sc->curlet); + if (is_slot(opc->v[2].p)) { + if (is_t_real(slot_value(opc->v[2].p))) { + opc->v[0].fd = opt_d_vd_s; + return (true); + } + if (!float_optimize(sc, cddr(car_x))) + return_false(sc, car_x); + if (d_vd_f_combinable(sc, start)) + return (true); + opc->v[0].fd = opt_d_vd_f; + opc->v[8].o1 = sc->opts[start]; + opc->v[9].fd = sc->opts[start]->v[0].fd; + return (true); + } + } else { /* is pair arg2 */ + if (float_optimize(sc, cddr(car_x))) { + opc->v[1].p = slot; + opc->v[5].obj = + (void *) c_object_value(slot_value(slot)); + if (d_vd_f_combinable(sc, start)) + return (true); + opc->v[0].fd = opt_d_vd_f; + opc->v[8].o1 = sc->opts[start]; + opc->v[9].fd = sc->opts[start]->v[0].fd; + return (true); + } + pc_fallback(sc, start); + } + } + } + return_false(sc, car_x); +} + +/* -------- d_id -------- */ +static s7_double opt_d_id_sf(opt_info * o) +{ + return (o->v[3].d_id_f(integer(slot_value(o->v[1].p)), + o->v[5].fd(o->v[4].o1))); +} + +static s7_double opt_d_id_sc(opt_info * o) +{ + return (o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[2].x)); +} + +static s7_double opt_d_id_sfo1(opt_info * o) +{ + return (o->v[3].d_id_f(integer(slot_value(o->v[1].p)), + o->v[5].d_v_f(o->v[2].obj))); +} + +static s7_double opt_d_id_sfo(opt_info * o) +{ + return (o->v[4].d_id_f(integer(slot_value(o->v[1].p)), + o->v[5].d_vd_f(o->v[6].obj, + real(slot_value(o->v[3].p))))); +} + +static s7_double opt_d_id_cf(opt_info * o) +{ + return (o->v[3].d_id_f(o->v[1].i, o->v[5].fd(o->v[4].o1))); +} + +static s7_double opt_d_id_ff(opt_info * o) +{ + s7_int x1; + x1 = o->v[9].fi(o->v[8].o1); + return (o->v[3].d_id_f(x1, o->v[11].fd(o->v[10].o1))); +} + +static bool d_id_sf_combinable(s7_scheme * sc, opt_info * opc) +{ + if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { + opt_info *o1 = sc->opts[sc->pc - 1]; + if (o1->v[0].fd == opt_d_vd_s) { + opc->v[4].d_id_f = opc->v[3].d_id_f; + opc->v[2].p = o1->v[1].p; + opc->v[6].obj = o1->v[5].obj; + opc->v[5].d_vd_f = o1->v[3].d_vd_f; + opc->v[3].p = o1->v[2].p; + opc->v[0].fd = opt_d_id_sfo; + backup_pc(sc); + return (true); + } + if (o1->v[0].fd == opt_d_v) { + opc->v[6].p = o1->v[1].p; + opc->v[2].obj = o1->v[5].obj; + opc->v[5].d_v_f = o1->v[3].d_v_f; + opc->v[0].fd = opt_d_id_sfo1; + backup_pc(sc); + return (true); + } + } + return_false(sc, NULL); +} + +static bool d_id_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_pointer p; + int32_t start = sc->pc; + s7_d_id_t flt_func; + flt_func = s7_d_id_function(s_func); + if (!flt_func) + return_false(sc, car_x); + opc->v[3].d_id_f = flt_func; + p = opt_integer_symbol(sc, cadr(car_x)); + if (p) { + opc->v[1].p = p; + if (is_t_real(caddr(car_x))) { + opc->v[0].fd = opt_d_id_sc; + opc->v[2].x = real(caddr(car_x)); + return (true); + } + if (float_optimize(sc, cddr(car_x))) { + if (d_id_sf_combinable(sc, opc)) + return (true); + opc->v[0].fd = opt_d_id_sf; + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + return (true); + } + pc_fallback(sc, start); + } + if (is_t_integer(cadr(car_x))) { + if (float_optimize(sc, cddr(car_x))) { + opc->v[0].fd = opt_d_id_cf; + opc->v[1].i = integer(cadr(car_x)); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + return (true); + } + pc_fallback(sc, start); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) { + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(car_x))) { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[0].fd = opt_d_id_ff; + return (true); + } + pc_fallback(sc, start); + } + return_false(sc, car_x); +} + +/* -------- d_dd -------- */ + +static s7_double opt_d_dd_cc(opt_info * o) +{ + return (o->v[3].d_dd_f(o->v[1].x, o->v[2].x)); +} + +static s7_double opt_d_dd_cs(opt_info * o) +{ + return (o->v[3].d_dd_f(o->v[2].x, real(slot_value(o->v[1].p)))); +} + +static s7_double opt_d_dd_sc(opt_info * o) +{ + return (o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[2].x)); +} + +static s7_double opt_d_dd_sc_sub(opt_info * o) +{ + return (real(slot_value(o->v[1].p)) - o->v[2].x); +} + +static s7_double opt_d_dd_ss(opt_info * o) +{ + return (o->v[3].d_dd_f(real(slot_value(o->v[1].p)), + real(slot_value(o->v[2].p)))); +} + +static s7_double opt_d_dd_ss_add(opt_info * o) +{ + return (real(slot_value(o->v[1].p)) + real(slot_value(o->v[2].p))); +} + +static s7_double opt_d_dd_ss_mul(opt_info * o) +{ + return (real(slot_value(o->v[1].p)) * real(slot_value(o->v[2].p))); +} + +static s7_double opt_d_dd_cf(opt_info * o) +{ + return (o->v[3].d_dd_f(o->v[1].x, o->v[5].fd(o->v[4].o1))); +} + +static s7_double opt_d_dd_1f_subtract(opt_info * o) +{ + return (1.0 - o->v[5].fd(o->v[4].o1)); +} + +static s7_double opt_d_dd_fc(opt_info * o) +{ + return (o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), o->v[2].x)); +} + +#if WITH_GMP +static s7_double opt_subtract_random_f_f(opt_info * o) +{ + return (o->v[1].x * next_random(opt_sc(o)) - o->v[2].x); +} +#else +static s7_double opt_subtract_random_f_f(opt_info * o) +{ + return (o->v[1].x * next_random(opt_sc(o)->default_rng) - o->v[2].x); +} +#endif + +static s7_double opt_d_dd_fc_add(opt_info * o) +{ + return (o->v[5].fd(o->v[4].o1) + o->v[2].x); +} + +static s7_double opt_d_dd_fc_fvref_add(opt_info * o) +{ + return (o->v[2].x + + float_vector(slot_value(o->v[4].o1->v[1].p), + integer(slot_value(o->v[4].o1->v[2].p)))); +} + +static s7_double opt_d_dd_fc_subtract(opt_info * o) +{ + return (o->v[5].fd(o->v[4].o1) - o->v[2].x); +} + +static s7_double opt_d_dd_sf(opt_info * o) +{ + return (o-> + v[3].d_dd_f(real(slot_value(o->v[1].p)), + o->v[5].fd(o->v[4].o1))); +} + +static s7_double opt_d_dd_sf_mul(opt_info * o) +{ + return (real(slot_value(o->v[1].p)) * o->v[5].fd(o->v[4].o1)); +} + +static s7_double opt_d_dd_sf_add(opt_info * o) +{ + return (real(slot_value(o->v[1].p)) + o->v[5].fd(o->v[4].o1)); +} + +static s7_double opt_d_dd_sf_sub(opt_info * o) +{ + return (real(slot_value(o->v[1].p)) - o->v[5].fd(o->v[4].o1)); +} + +static s7_double opt_d_7dd_cc(opt_info * o) +{ + return (o->v[3].d_7dd_f(opt_sc(o), o->v[1].x, o->v[2].x)); +} + +static s7_double opt_d_7dd_cs(opt_info * o) +{ + return (o-> + v[3].d_7dd_f(opt_sc(o), o->v[2].x, + real(slot_value(o->v[1].p)))); +} + +static s7_double opt_d_7dd_sc(opt_info * o) +{ + return (o-> + v[3].d_7dd_f(opt_sc(o), real(slot_value(o->v[1].p)), + o->v[2].x)); +} + +static s7_double opt_d_7dd_ss(opt_info * o) +{ + return (o->v[3].d_7dd_f(opt_sc(o), real(slot_value(o->v[1].p)), + real(slot_value(o->v[2].p)))); +} + +static s7_double opt_d_7dd_cf(opt_info * o) +{ + return (o->v[3].d_7dd_f(opt_sc(o), o->v[1].x, o->v[5].fd(o->v[4].o1))); +} + +static s7_double opt_d_7dd_fc(opt_info * o) +{ + return (o->v[3].d_7dd_f(opt_sc(o), o->v[5].fd(o->v[4].o1), o->v[2].x)); +} + +static s7_double opt_d_7dd_sf(opt_info * o) +{ + return (o->v[3].d_7dd_f(opt_sc(o), real(slot_value(o->v[1].p)), + o->v[5].fd(o->v[4].o1))); +} + +static s7_double opt_d_7pii_scs(opt_info * o); +static s7_double opt_d_dd_sf_mul_fvref(opt_info * o) +{ + opt_info *o1 = o->v[4].o1; + return (real(slot_value(o->v[1].p)) * + float_vector_ref_d_7pii(opt_sc(o1), slot_value(o1->v[1].p), + o1->v[2].i, + integer(slot_value(o1->v[3].p)))); +} + +static s7_double opt_d_dd_sfo(opt_info * o) +{ + return (o->v[4].d_dd_f(real(slot_value(o->v[1].p)), + o->v[5].d_7pi_f(opt_sc(o), + slot_value(o->v[2].p), + integer(slot_value + (o->v[3].p))))); +} + +static s7_double opt_d_7dd_sfo(opt_info * o) +{ + return (o->v[4].d_7dd_f(opt_sc(o), real(slot_value(o->v[1].p)), + o->v[5].d_7pi_f(opt_sc(o), + slot_value(o->v[2].p), + integer(slot_value + (o->v[3].p))))); +} + +static bool d_dd_sf_combinable(s7_scheme * sc, opt_info * opc, + s7_d_dd_t func) +{ + if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { + opt_info *o1 = sc->opts[sc->pc - 1]; + if ((o1->v[0].fd == opt_d_7pi_ss) + || (o1->v[0].fd == opt_d_7pi_ss_fvref) + || (o1->v[0].fd == opt_d_7pi_ss_fvref_unchecked)) { + if (func) { + opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* need room for 3 symbols */ + opc->v[0].fd = opt_d_dd_sfo; + } else { + opc->v[4].d_7dd_f = opc->v[3].d_7dd_f; /* need room for 3 symbols */ + opc->v[0].fd = opt_d_7dd_sfo; + } + opc->v[2].p = o1->v[1].p; + opc->v[3].p = o1->v[2].p; + opc->v[5].d_7pi_f = o1->v[3].d_7pi_f; + backup_pc(sc); + return (true); + } + } + return_false(sc, NULL); +} + +static s7_double opt_d_dd_fs(opt_info * o) +{ + return (o-> + v[3].d_dd_f(o->v[5].fd(o->v[4].o1), + real(slot_value(o->v[1].p)))); +} + +static s7_double opt_d_dd_fs_mul(opt_info * o) +{ + return (o->v[5].fd(o->v[4].o1) * real(slot_value(o->v[1].p))); +} + +static s7_double opt_d_dd_fs_add(opt_info * o) +{ + return (o->v[5].fd(o->v[4].o1) + real(slot_value(o->v[1].p))); +} + +static s7_double opt_d_dd_fs_sub(opt_info * o) +{ + return (o->v[5].fd(o->v[4].o1) - real(slot_value(o->v[1].p))); +} + +static s7_double opt_d_7dd_fs(opt_info * o) +{ + return (o->v[3].d_7dd_f(opt_sc(o), o->v[5].fd(o->v[4].o1), + real(slot_value(o->v[1].p)))); +} + +static s7_double opt_d_dd_fs_add_fvref(opt_info * o) +{ + opt_info *o1 = o->v[4].o1; + return (real(slot_value(o->v[1].p)) + + float_vector_ref_d_7pii(opt_sc(o1), slot_value(o1->v[1].p), + o1->v[2].i, + integer(slot_value(o1->v[3].p)))); +} + +static s7_double opt_d_dd_fso(opt_info * o) +{ + return (o-> + v[4].d_dd_f(o-> + v[5].d_7pi_f(opt_sc(o), slot_value(o->v[2].p), + integer(slot_value(o->v[3].p))), + real(slot_value(o->v[1].p)))); +} + +static s7_double opt_d_7dd_fso(opt_info * o) +{ + return (o->v[4].d_7dd_f(opt_sc(o), + o->v[5].d_7pi_f(opt_sc(o), + slot_value(o->v[2].p), + integer(slot_value + (o->v[3].p))), + real(slot_value(o->v[1].p)))); +} + +static bool d_dd_fs_combinable(s7_scheme * sc, opt_info * opc, + s7_d_dd_t func) +{ + if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { + opt_info *o1 = sc->opts[sc->pc - 1]; + if ((o1->v[0].fd == opt_d_7pi_ss) + || (o1->v[0].fd == opt_d_7pi_ss_fvref) + || (o1->v[0].fd == opt_d_7pi_ss_fvref_unchecked)) { + if (func) { + opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* need room for 3 symbols */ + opc->v[0].fd = opt_d_dd_fso; + } else { + opc->v[4].d_7dd_f = opc->v[3].d_7dd_f; + opc->v[0].fd = opt_d_7dd_fso; + } + opc->v[2].p = o1->v[1].p; + opc->v[3].p = o1->v[2].p; + opc->v[5].d_7pi_f = o1->v[3].d_7pi_f; + backup_pc(sc); + return (true); + } + } + return_false(sc, NULL); +} + +static s7_double opt_d_dd_ff(opt_info * o) +{ + s7_double x1; + x1 = o->v[9].fd(o->v[8].o1); + return (o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1))); +} + +static s7_double opt_d_dd_ff_mul(opt_info * o) +{ + s7_double x1; + x1 = o->v[9].fd(o->v[8].o1); + return (x1 * o->v[11].fd(o->v[10].o1)); +} + +static s7_double opt_d_dd_ff_square(opt_info * o) +{ + s7_double x1; + x1 = o->v[9].fd(o->v[8].o1); + return (x1 * x1); +} + +static s7_double opt_d_dd_ff_add(opt_info * o) +{ + s7_double x1; + x1 = o->v[5].fd(o->v[4].o1); + return (x1 + o->v[11].fd(o->v[10].o1)); +} + +static s7_double opt_d_dd_ff_add_mul(opt_info * o) +{ + s7_double x1, x2; + x1 = o->v[5].fd(o->v[4].o1); + x2 = o->v[9].fd(o->v[8].o1); + return (x1 + (x2 * o->v[11].fd(o->v[10].o1))); +} + +static s7_double opt_d_dd_ff_add_fv_ref(opt_info * o) +{ + s7_double x1; + x1 = o->v[5].fd(o->v[4].o1); + return (x1 + + float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[6].p), + o->v[9].fi(o->v[8].o1))); +} + +static s7_double opt_d_dd_ff_sub(opt_info * o) +{ + s7_double x1; + x1 = o->v[5].fd(o->v[4].o1); + return (x1 - o->v[11].fd(o->v[10].o1)); +} + +static s7_double opt_d_7dd_ff(opt_info * o) +{ + s7_double x1; + x1 = o->v[9].fd(o->v[8].o1); + return (o->v[3].d_7dd_f(opt_sc(o), x1, o->v[11].fd(o->v[10].o1))); +} + +static s7_double opt_d_dd_ff_o1(opt_info * o) +{ + s7_double x1; + x1 = o->v[2].d_v_f(o->v[1].obj); + return (o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1))); +} + +static s7_double opt_d_dd_ff_mul1(opt_info * o) +{ + return (o->v[2].d_v_f(o->v[1].obj) * o->v[11].fd(o->v[10].o1)); +} + +static s7_double opt_d_dd_ff_o2(opt_info * o) +{ + s7_double x1; + x1 = o->v[4].d_v_f(o->v[1].obj); + return (o->v[3].d_dd_f(x1, o->v[5].d_v_f(o->v[2].obj))); +} + +static s7_double opt_d_dd_ff_mul2(opt_info * o) +{ + return (o->v[4].d_v_f(o->v[1].obj) * o->v[5].d_v_f(o->v[2].obj)); +} + +static s7_double opt_d_dd_ff_o3(opt_info * o) +{ + s7_double x1; + x1 = o->v[5].d_v_f(o->v[1].obj); + return (o->v[4].d_dd_f(x1, + o->v[6].d_vd_f(o->v[2].obj, + real(slot_value(o->v[3].p))))); +} + +static s7_double opt_d_dd_fff(opt_info * o) +{ + s7_double x1, x2; + x1 = o->v[3 + 4].d_dd_f(o->v[3 + 5].d_7pi_f(opt_sc(o), slot_value(o->v[3 + 2].p), integer(slot_value(o->v[3 + 3].p))), real(slot_value(o->v[3 + 1].p))); /* dd_fso */ + x2 = o->v[8 + 4].d_dd_f(o->v[8 + 5].d_7pi_f(opt_sc(o), slot_value(o->v[8 + 2].p), integer(slot_value(o->v[8 + 3].p))), real(slot_value(o->v[8 + 1].p))); /* dd_fso */ + return (o->v[3].d_dd_f(x1, x2)); +} + +static s7_double opt_d_mm_fff(opt_info * o) +{ + s7_double x1, x2; + x1 = float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[3 + 2].p), + integer(slot_value(o->v[3 + 3].p))) * + real(slot_value(o->v[3 + 1].p)); + x2 = float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[8 + 2].p), + integer(slot_value(o->v[8 + 3].p))) * + real(slot_value(o->v[8 + 1].p)); + return (o->v[3].d_dd_f(x1, x2)); +} + +static s7_double opt_d_dd_fff_rev(opt_info * o) +{ /* faster with opt_sc(o)? */ + s7_double x1, x2; + x1 = o->v[3 + 4].d_dd_f(real(slot_value(o->v[3 + 1].p)), + o->v[3 + 5].d_7pi_f(opt_sc(o), + slot_value(o->v[3 + 2].p), + integer(slot_value + (o->v[3 + 3].p)))); + x2 = o->v[8 + 4].d_dd_f(real(slot_value(o->v[8 + 1].p)), + o->v[8 + 5].d_7pi_f(opt_sc(o), + slot_value(o->v[8 + 2].p), + integer(slot_value + (o->v[8 + 3].p)))); + return (o->v[3].d_dd_f(x1, x2)); +} + +static s7_double opt_d_dd_ff_o4(opt_info * o) +{ + s7_double x1; + x1 = o->v[2].d_v_f(o->v[1].obj); + return (o->v[3].d_dd_f(x1, + o->v[7].d_vd_f(o->v[5].obj, + o->v[4].d_v_f(o->v[6].obj)))); +} + +static s7_double opt_d_dd_ff_mul4(opt_info * o) +{ + return (o->v[2].d_v_f(o->v[1].obj) * + o->v[7].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj))); +} + +static s7_double opt_d_7pii_sss(opt_info * o); +static s7_double opt_d_dd_ff_mul_sss(opt_info * o) +{ + s7_double x1; + s7_int i1, i2; + s7_pointer v; + opt_info *o1 = o->v[8].o1; + v = slot_value(o1->v[1].p); + i1 = integer(slot_value(o1->v[2].p)); + i2 = integer(slot_value(o1->v[3].p)); + x1 = float_vector_ref_d_7pii(opt_sc(o1), v, i1, i2); + o1 = o->v[10].o1; + v = slot_value(o1->v[1].p); + i1 = integer(slot_value(o1->v[2].p)); /* in (* (A i j) (B j k)) we could reuse i2->i1 (flipping args below) */ + i2 = integer(slot_value(o1->v[3].p)); + return (x1 * float_vector_ref_d_7pii(opt_sc(o1), v, i1, i2)); +} + +static bool finish_dd_fso(opt_info * opc, opt_info * o1, opt_info * o2) +{ + opc->v[3 + 1].p = o1->v[1].p; + opc->v[3 + 2].p = o1->v[2].p; + opc->v[3 + 3].p = o1->v[3].p; + opc->v[3 + 4].d_dd_f = o1->v[4].d_dd_f; + opc->v[3 + 5].d_7pi_f = o1->v[5].d_7pi_f; + opc->v[8 + 1].p = o2->v[1].p; + opc->v[8 + 2].p = o2->v[2].p; + opc->v[8 + 3].p = o2->v[3].p; + opc->v[8 + 4].d_dd_f = o2->v[4].d_dd_f; + opc->v[8 + 5].d_7pi_f = o2->v[5].d_7pi_f; + return (true); +} + +static bool d_dd_ff_combinable(s7_scheme * sc, opt_info * opc, + int32_t start) +{ + opt_info *o1 = opc->v[8].o1, *o2 = opc->v[10].o1; + if (o1->v[0].fd == opt_d_v) { + /* opc->v[3] is in use */ + if ((o2->v[0].fd == opt_d_v) && (sc->pc == start + 2)) { + opc->v[1].obj = o1->v[5].obj; + opc->v[6].p = o1->v[1].p; + opc->v[4].d_v_f = o1->v[3].d_v_f; + opc->v[2].obj = o2->v[5].obj; + opc->v[7].p = o2->v[1].p; + opc->v[5].d_v_f = o2->v[3].d_v_f; + opc->v[0].fd = + (opc->v[3].d_dd_f == + multiply_d_dd) ? opt_d_dd_ff_mul2 : opt_d_dd_ff_o2; + sc->pc -= 2; + return (true); + } + if ((o2->v[0].fd == opt_d_vd_s) && (sc->pc == start + 2)) { + opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* make room for symbols */ + opc->v[1].obj = o1->v[5].obj; + opc->v[7].p = o1->v[1].p; + opc->v[5].d_v_f = o1->v[3].d_v_f; + opc->v[2].obj = o2->v[5].obj; + opc->v[8].p = o2->v[1].p; + opc->v[6].d_vd_f = o2->v[3].d_vd_f; + opc->v[3].p = o2->v[2].p; + opc->v[0].fd = opt_d_dd_ff_o3; + sc->pc -= 2; + return (true); + } + if ((o2->v[0].fd == opt_d_vd_o) && (sc->pc == start + 2)) { + opc->v[1].obj = o1->v[5].obj; + opc->v[8].p = o1->v[1].p; + opc->v[2].d_v_f = o1->v[3].d_v_f; + opc->v[7].d_vd_f = o2->v[3].d_vd_f; + opc->v[4].d_v_f = o2->v[4].d_v_f; + opc->v[5].obj = o2->v[5].obj; + opc->v[9].p = o2->v[1].p; + opc->v[6].obj = o2->v[6].obj; + opc->v[10].p = o2->v[2].p; + opc->v[0].fd = + (opc->v[3].d_dd_f == + multiply_d_dd) ? opt_d_dd_ff_mul4 : opt_d_dd_ff_o4; + sc->pc -= 2; + return (true); + } + opc->v[1].obj = o1->v[5].obj; + opc->v[4].p = o1->v[1].p; + opc->v[2].d_v_f = o1->v[3].d_v_f; + opc->v[0].fd = + (opc->v[3].d_dd_f == + multiply_d_dd) ? opt_d_dd_ff_mul1 : opt_d_dd_ff_o1; + return (true); + } + if (o1->v[0].fd == opt_d_dd_fso) { + if (o2->v[0].fd == opt_d_dd_fso) { + if ((o1->v[4].d_dd_f == multiply_d_dd) && + (o2->v[4].d_dd_f == multiply_d_dd) && + (o1->v[5].d_7pi_f == float_vector_ref_d_7pi) && + (o2->v[5].d_7pi_f == float_vector_ref_d_7pi)) + opc->v[0].fd = opt_d_mm_fff; /* a placeholder (never called) */ + else + opc->v[0].fd = opt_d_dd_fff; + return (finish_dd_fso(opc, o1, o2)); + } + } + if (o1->v[0].fd == opt_d_dd_sfo) { + if (o2->v[0].fd == opt_d_dd_sfo) { + if ((o1->v[4].d_dd_f == multiply_d_dd) && + (o2->v[4].d_dd_f == multiply_d_dd) && + (o1->v[5].d_7pi_f == float_vector_ref_d_7pi) && + (o2->v[5].d_7pi_f == float_vector_ref_d_7pi)) + opc->v[0].fd = opt_d_mm_fff; /* multiply is commutative */ + else + opc->v[0].fd = opt_d_dd_fff_rev; + return (finish_dd_fso(opc, o1, o2)); + } + } + return_false(sc, NULL); +} + +static s7_double opt_d_dd_cfo(opt_info * o) +{ + return (o->v[3].d_dd_f(o->v[2].x, o->v[4].d_v_f(o->v[1].obj))); +} + +static s7_double opt_d_7dd_cfo(opt_info * o) +{ + return (o-> + v[3].d_7dd_f(opt_sc(o), o->v[2].x, + o->v[4].d_v_f(o->v[1].obj))); +} + +static s7_double opt_d_dd_cfo1(opt_info * o) +{ + return (o->v[3].d_dd_f(o->v[4].x, + o->v[5].d_vd_f(o->v[6].obj, + real(slot_value(o->v[2].p))))); +} + +static s7_double opt_d_7dd_cfo1(opt_info * o) +{ + return (o->v[3].d_7dd_f(opt_sc(o), o->v[4].x, + o->v[5].d_vd_f(o->v[6].obj, + real(slot_value(o->v[2].p))))); +} + +static bool d_dd_call_combinable(s7_scheme * sc, opt_info * opc, + s7_d_dd_t func) +{ + if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { + opt_info *o1 = sc->opts[sc->pc - 1]; + if (o1->v[0].fd == opt_d_v) { + opc->v[2].x = opc->v[1].x; + opc->v[6].p = o1->v[1].p; + opc->v[1].obj = o1->v[5].obj; + opc->v[4].d_v_f = o1->v[3].d_v_f; + opc->v[0].fd = (func) ? opt_d_dd_cfo : opt_d_7dd_cfo; + backup_pc(sc); + return (true); + } + if (o1->v[0].fd == opt_d_vd_s) { + opc->v[4].x = opc->v[1].x; + opc->v[1].p = o1->v[1].p; + opc->v[6].obj = o1->v[5].obj; + opc->v[2].p = o1->v[2].p; + opc->v[5].d_vd_f = o1->v[3].d_vd_f; + opc->v[0].fd = (func) ? opt_d_dd_cfo1 : opt_d_7dd_cfo1; + backup_pc(sc); + return (true); + } + } + return_false(sc, NULL); +} + +static bool d_dd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); + int32_t start = sc->pc; + opt_info *o1; + s7_d_dd_t func; + s7_d_7dd_t func7 = NULL; + func = s7_d_dd_function(s_func); + if (!func) { + func7 = s7_d_7dd_function(s_func); + if (!func7) + return_false(sc, car_x); + } + if (func) + opc->v[3].d_dd_f = func; + else + opc->v[3].d_7dd_f = func7; + + /* arg1 = real constant */ + if (is_small_real(arg1)) { + if (is_small_real(arg2)) { + if ((!is_t_real(arg1)) && (!is_t_real(arg2))) + return_false(sc, car_x); + opc->v[1].x = s7_number_to_real(sc, arg1); + opc->v[2].x = s7_number_to_real(sc, arg2); + opc->v[0].fd = (func) ? opt_d_dd_cc : opt_d_7dd_cc; + return (true); + } + slot = opt_float_symbol(sc, arg2); + if (slot) { + opc->v[1].p = slot; + opc->v[2].x = s7_number_to_real(sc, arg1); /* move arg1? */ + opc->v[0].fd = (func) ? opt_d_dd_cs : opt_d_7dd_cs; + return (true); + } + if (float_optimize(sc, cddr(car_x))) { + opc->v[1].x = s7_number_to_real(sc, arg1); + if (d_dd_call_combinable(sc, opc, func)) + return (true); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + opc->v[0].fd = (func) ? opt_d_dd_cf : opt_d_7dd_cf; + if ((opc->v[1].x == 1.0) && (func == subtract_d_dd)) + opc->v[0].fd = opt_d_dd_1f_subtract; + return (true); + } + pc_fallback(sc, start); + return_false(sc, car_x); + } + + /* arg1 = float symbol */ + slot = opt_float_symbol(sc, arg1); + if (slot) { + opc->v[1].p = slot; + if (is_small_real(arg2)) { + opc->v[2].x = s7_number_to_real(sc, arg2); + if (func) + opc->v[0].fd = + (func == + subtract_d_dd) ? opt_d_dd_sc_sub : opt_d_dd_sc; + else + opc->v[0].fd = opt_d_7dd_sc; + return (true); + } + slot = opt_float_symbol(sc, arg2); + if (slot) { + opc->v[2].p = slot; + if (func) { + if (func == multiply_d_dd) + opc->v[0].fd = opt_d_dd_ss_mul; + else + opc->v[0].fd = + (func == add_d_dd) ? opt_d_dd_ss_add : opt_d_dd_ss; + } else + opc->v[0].fd = opt_d_7dd_ss; + return (true); + } + if (float_optimize(sc, cddr(car_x))) { + if (d_dd_sf_combinable(sc, opc, func)) + return (true); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + if (func) { + opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_sf_mul : + ((func == add_d_dd) ? opt_d_dd_sf_add : + ((func == + subtract_d_dd) ? opt_d_dd_sf_sub : opt_d_dd_sf)); + if ((func == multiply_d_dd) + && (opc->v[5].fd == opt_d_7pii_scs)) + opc->v[0].fd = opt_d_dd_sf_mul_fvref; + } else + opc->v[0].fd = opt_d_7dd_sf; + return (true); + } + pc_fallback(sc, start); + return_false(sc, car_x); + } + + /* arg1 = float expr or non-float */ + o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(car_x))) { + int32_t start2 = sc->pc; + if (is_small_real(arg2)) { + opc->v[2].x = s7_number_to_real(sc, arg2); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + if (func) { + if (func == add_d_dd) { + opc->v[0].fd = + (opc->v[5].fd == + opt_d_7pi_ss_fvref_unchecked) ? + opt_d_dd_fc_fvref_add : opt_d_dd_fc_add; + return (true); + } + if (func == subtract_d_dd) { + opc->v[0].fd = opt_d_dd_fc_subtract; + /* if o1->v[0].fd = opt_d_7d_c and its o->v[3].d_7d_f = random_d_7d it's (- (random f1) f2) */ + if ((opc == sc->opts[sc->pc - 2]) && + (sc->opts[start]->v[0].fd == opt_d_7d_c) && + (sc->opts[start]->v[3].d_7d_f == random_d_7d)) { + opc->v[0].fd = opt_subtract_random_f_f; + opc->v[1].x = sc->opts[start]->v[1].x; /* random arg */ + backup_pc(sc); + } + } else + opc->v[0].fd = opt_d_dd_fc; + } else + opc->v[0].fd = opt_d_7dd_fc; + return (true); + } + slot = opt_float_symbol(sc, arg2); + if (slot) { + opc->v[1].p = slot; + if (d_dd_fs_combinable(sc, opc, func)) + return (true); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + if (func) { + opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_fs_mul : + ((func == add_d_dd) ? opt_d_dd_fs_add : + ((func == + subtract_d_dd) ? opt_d_dd_fs_sub : opt_d_dd_fs)); + if ((func == add_d_dd) && (opc->v[5].fd == opt_d_7pii_scs)) + opc->v[0].fd = opt_d_dd_fs_add_fvref; + } else + opc->v[0].fd = opt_d_7dd_fs; + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(car_x))) { + opc->v[8].o1 = o1; + opc->v[9].fd = o1->v[0].fd; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + if (func) { + if (d_dd_ff_combinable(sc, opc, start)) + return (true); + opc->v[0].fd = opt_d_dd_ff; + if (func == multiply_d_dd) { + if (arg1 == arg2) + opc->v[0].fd = opt_d_dd_ff_square; + else if ((opc->v[9].fd == opt_d_7pii_sss) && (opc->v[11].fd == opt_d_7pii_sss) && (o1->v[4].d_7pii_f == float_vector_ref_d_7pii)) /* currently redundant */ + opc->v[0].fd = opt_d_dd_ff_mul_sss; + else + opc->v[0].fd = opt_d_dd_ff_mul; + return (true); + } else { + opt_info *o2 = sc->opts[start2]; /* this is opc->v[10].o1 */ + if (func == add_d_dd) { + if (o2->v[0].fd == opt_d_dd_ff_mul) { + opc->v[0].fd = opt_d_dd_ff_add_mul; + opc->v[4].o1 = o1; /* add first arg */ + opc->v[5].fd = o1->v[0].fd; + opc->v[8].o1 = o2->v[8].o1; /* mul first arg */ + opc->v[9].fd = o2->v[9].fd; + opc->v[10].o1 = o2->v[10].o1; /* mul second arg */ + opc->v[11].fd = o2->v[11].fd; + return (true); + } + if ((o2->v[0].fd == opt_d_7pi_sf) && + (o2->v[3].d_7pi_f == float_vector_ref_d_7pi)) { + opc->v[0].fd = opt_d_dd_ff_add_fv_ref; + opc->v[6].p = o2->v[1].p; + opc->v[8].o1 = o2->v[10].o1; /* sc->opts[start2 + 1]; */ + opc->v[9].fi = o2->v[11].fi; /* sc->opts[start2 + 1]->v[0].fi; */ + } else { + opc->v[0].fd = opt_d_dd_ff_add; + opc->v[10].o1 = o2; + opc->v[11].fd = o2->v[0].fd; + } + opc->v[4].o1 = o1; /* sc->opts[start]; */ + opc->v[5].fd = o1->v[0].fd; /* sc->opts[start]->v[0].fd; */ + return (true); + } + if (func == subtract_d_dd) { + opc->v[0].fd = opt_d_dd_ff_sub; + opc->v[4].o1 = o1; /* sc->opts[start]; */ + opc->v[5].fd = o1->v[0].fd; /* sc->opts[start]->v[0].fd; */ + opc->v[10].o1 = o2; + opc->v[11].fd = o2->v[0].fd; + return (true); + } + } + } else + opc->v[0].fd = opt_d_7dd_ff; + return (true); + } + } + pc_fallback(sc, start); + return_false(sc, car_x); +} + +/* -------- d_ddd -------- */ +static s7_double opt_d_ddd_sss(opt_info * o) +{ + return (o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), + real(slot_value(o->v[2].p)), + real(slot_value(o->v[3].p)))); +} + +static s7_double opt_d_ddd_ssf(opt_info * o) +{ + return (o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), + real(slot_value(o->v[2].p)), + o->v[11].fd(o->v[10].o1))); +} + +static s7_double opt_d_ddd_sff(opt_info * o) +{ + s7_double x1, x2; + x1 = o->v[11].fd(o->v[10].o1); + x2 = o->v[9].fd(o->v[8].o1); + return (o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), x1, x2)); +} + +static s7_double opt_d_ddd_fff(opt_info * o) +{ + s7_double x1, x2, x3; + x1 = o->v[11].fd(o->v[10].o1); + x2 = o->v[9].fd(o->v[8].o1); + x3 = o->v[6].fd(o->v[5].o1); + return (o->v[4].d_ddd_f(x1, x2, x3)); +} + +static s7_double opt_d_ddd_fff1(opt_info * o) +{ + s7_double x1, x2, x3; + x1 = o->v[1].d_v_f(o->v[2].obj); + x2 = o->v[3].d_v_f(o->v[4].obj); + x3 = o->v[5].d_v_f(o->v[6].obj); + return (o->v[7].d_ddd_f(x1, x2, x3)); +} + +static s7_double opt_d_ddd_fff2(opt_info * o) +{ + s7_double x1, x2, x3; + x1 = o->v[1].d_v_f(o->v[2].obj); + x2 = o->v[9].fd(o->v[12].o1); + x3 = o->v[6].fd(o->v[5].o1); + return (o->v[7].d_ddd_f(x1, x2, x3)); +} + +static bool d_ddd_fff_combinable(s7_scheme * sc, opt_info * opc, + int32_t start) +{ + opt_info *o1; + if (sc->opts[start]->v[0].fd != opt_d_v) + return_false(sc, NULL); + opc->v[12].o1 = opc->v[8].o1; + opc->v[7].d_ddd_f = opc->v[4].d_ddd_f; + o1 = sc->opts[start]; + opc->v[1].d_v_f = o1->v[3].d_v_f; + opc->v[2].obj = o1->v[5].obj; + opc->v[8].p = o1->v[1].p; + if ((sc->opts[start + 1]->v[0].fd == opt_d_v) && + (sc->opts[start + 2]->v[0].fd == opt_d_v)) { + opc->v[0].fd = opt_d_ddd_fff1; + o1 = sc->opts[start + 1]; + opc->v[3].d_v_f = o1->v[3].d_v_f; + opc->v[4].obj = o1->v[5].obj; + opc->v[9].p = o1->v[1].p; + o1 = sc->opts[start + 2]; + opc->v[5].d_v_f = o1->v[3].d_v_f; + opc->v[6].obj = o1->v[5].obj; + opc->v[10].p = o1->v[1].p; + sc->pc -= 3; + return (true); + } + opc->v[0].fd = opt_d_ddd_fff2; + opc->v[9].fd = opc->v[12].o1->v[0].fd; + opc->v[6].fd = opc->v[5].o1->v[0].fd; + return (true); +} + +static bool d_ddd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + int32_t start = sc->pc; + s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); + s7_d_ddd_t f; + f = s7_d_ddd_function(s_func); + if (!f) + return_false(sc, car_x); + opc->v[4].d_ddd_f = f; + slot = opt_float_symbol(sc, arg1); + opc->v[10].o1 = sc->opts[start]; + if (slot) { + opc->v[1].p = slot; + slot = opt_float_symbol(sc, arg2); + if (slot) { + s7_pointer arg3 = cadddr(car_x); + opc->v[2].p = slot; + slot = opt_float_symbol(sc, arg3); + if (slot) { + opc->v[3].p = slot; + opc->v[0].fd = opt_d_ddd_sss; + return (true); + } + if (float_optimize(sc, cdddr(car_x))) { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[0].fd = opt_d_ddd_ssf; + return (true); + } + pc_fallback(sc, start); + } + if (float_optimize(sc, cddr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(car_x))) { + opc->v[0].fd = opt_d_ddd_sff; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + return (true); + } + } + pc_fallback(sc, start); + } + if (float_optimize(sc, cdr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(car_x))) { + opc->v[5].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(car_x))) { + if (d_ddd_fff_combinable(sc, opc, start)) + return (true); + opc->v[0].fd = opt_d_ddd_fff; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + opc->v[6].fd = opc->v[5].o1->v[0].fd; + return (true); + } + } + } + pc_fallback(sc, start); + return_false(sc, car_x); +} + +/* -------- d_7pid -------- */ +static s7_double opt_d_7pid_ssf(opt_info * o) +{ + return (o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + o->v[11].fd(o->v[10].o1))); +} + +static s7_pointer opt_d_7pid_ssf_nr(opt_info * o) +{ + o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + o->v[11].fd(o->v[10].o1)); + return (NULL); +} + +static s7_double opt_d_7pid_sss(opt_info * o) +{ + return (o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + real(slot_value(o->v[3].p)))); +} + +static s7_double opt_d_7pid_ssc(opt_info * o) +{ + return (o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), o->v[3].x)); +} + +static s7_double opt_d_7pid_sff(opt_info * o) +{ + s7_int pos; + pos = o->v[11].fi(o->v[10].o1); + return (o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p), pos, + o->v[9].fd(o->v[8].o1))); +} + +static s7_double opt_d_7pid_sso(opt_info * o) +{ + return (o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + o->v[5].d_v_f(o->v[3].obj))); +} + +static s7_double opt_d_7pid_ss_ss(opt_info * o) +{ + return (o->v[4].d_7pid_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + o->v[3].d_7pi_f(opt_sc(o), + slot_value(o->v[5].p), + integer(slot_value + (o->v[6].p))))); +} + +static s7_double opt_d_7pid_ssfo(opt_info * o) +{ + s7_pointer fv = slot_value(o->v[1].p); + return (o->v[4].d_7pid_f(opt_sc(o), fv, integer(slot_value(o->v[2].p)), + o->v[6].d_dd_f(o->v[5].d_7pi_f(opt_sc(o), fv, + integer + (slot_value + (o->v[3].p))), + real(slot_value(o->v[8].p))))); +} + +static s7_double opt_d_7pid_ssfo_fv(opt_info * o) +{ + s7_double val; + s7_double *els = float_vector_floats(slot_value(o->v[1].p)); + val = + o->v[6].d_dd_f(els[integer(slot_value(o->v[3].p))], + real(slot_value(o->v[8].p))); + els[integer(slot_value(o->v[2].p))] = val; + return (val); +} + +static s7_pointer opt_d_7pid_ssfo_fv_nr(opt_info * o) +{ /* these next are variations on (float-vector-set! s (float-vector-ref s...)) */ + s7_double *els = float_vector_floats(slot_value(o->v[1].p)); + els[integer(slot_value(o->v[2].p))] = + o->v[6].d_dd_f(els[integer(slot_value(o->v[3].p))], + real(slot_value(o->v[8].p))); + return (NULL); +} + +static s7_pointer opt_d_7pid_ssfo_fv_add_nr(opt_info * o) +{ + s7_double *els = float_vector_floats(slot_value(o->v[1].p)); + els[integer(slot_value(o->v[2].p))] = + els[integer(slot_value(o->v[3].p))] + real(slot_value(o->v[8].p)); + return (NULL); +} + +static s7_pointer opt_d_7pid_ssfo_fv_sub_nr(opt_info * o) +{ + s7_double *els = float_vector_floats(slot_value(o->v[1].p)); + els[integer(slot_value(o->v[2].p))] = + els[integer(slot_value(o->v[3].p))] - real(slot_value(o->v[8].p)); + return (NULL); +} + +static bool d_7pid_ssf_combinable(s7_scheme * sc, opt_info * opc) +{ + if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { + opt_info *o1 = sc->opts[sc->pc - 1]; + if (o1->v[0].fd == opt_d_v) { + opc->v[6].p = o1->v[1].p; + opc->v[3].obj = o1->v[5].obj; + opc->v[5].d_v_f = o1->v[3].d_v_f; + opc->v[0].fd = opt_d_7pid_sso; + backup_pc(sc); + return (true); + } + if ((o1->v[0].fd == opt_d_7pi_ss) + || (o1->v[0].fd == opt_d_7pi_ss_fvref) + || (o1->v[0].fd == opt_d_7pi_ss_fvref_unchecked)) { + opc->v[3].d_7pi_f = o1->v[3].d_7pi_f; + opc->v[5].p = o1->v[1].p; + opc->v[6].p = o1->v[2].p; + opc->v[0].fd = opt_d_7pid_ss_ss; + backup_pc(sc); + return (true); + } + if ((o1->v[0].fd == opt_d_dd_fso) && (opc->v[1].p == o1->v[2].p)) { + /* opc: pid_ssf: o->v[4].d_7pid_f(slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o1->v[0].fd(o1)) + * o1: d_dd_fso: o->v[4].d_dd_f(o->v[5].d_7pi_f(slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p)))) + */ + opc->v[6].d_dd_f = o1->v[4].d_dd_f; + opc->v[5].d_7pi_f = o1->v[5].d_7pi_f; + opc->v[3].p = o1->v[3].p; + opc->v[8].p = o1->v[1].p; + opc->v[0].fd = opt_d_7pid_ssfo; + if ((opc->v[5].d_7pi_f == float_vector_ref_d_7pi) && + ((opc->v[4].d_7pid_f == float_vector_set_unchecked) + || (opc->v[4].d_7pid_f == float_vector_set_d_7pid))) + opc->v[0].fd = opt_d_7pid_ssfo_fv; /* actually if either is *_d, we need to check the indices */ + backup_pc(sc); + return (true); + } + } + return_false(sc, NULL); +} + +static bool opt_float_vector_set(s7_scheme * sc, opt_info * opc, + s7_pointer v, s7_pointer indexp1, + s7_pointer indexp2, s7_pointer indexp3, + s7_pointer valp); +static bool d_7pid_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_d_7pid_t f; + f = s7_d_7pid_function(s_func); + if ((f) && (is_symbol(cadr(car_x)))) { + s7_pointer slot, head = car(car_x); + int32_t start = sc->pc; + opc->v[4].d_7pid_f = f; + + if (is_target_or_its_alias + (head, s_func, sc->float_vector_set_symbol)) + return (opt_float_vector_set + (sc, opc, cadr(car_x), cddr(car_x), NULL, NULL, + cdddr(car_x))); + + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + opc->v[10].o1 = sc->opts[start]; + if (is_slot(opc->v[1].p)) { + slot = opt_integer_symbol(sc, caddr(car_x)); + if (slot) { + opc->v[2].p = slot; + slot = opt_float_symbol(sc, cadddr(car_x)); + if (slot) { + opc->v[3].p = slot; + opc->v[0].fd = opt_d_7pid_sss; + return (true); + } + if (float_optimize(sc, cdddr(car_x))) { + opc->v[11].fd = sc->opts[start]->v[0].fd; + if (d_7pid_ssf_combinable(sc, opc)) + return (true); + opc->v[0].fd = opt_d_7pid_ssf; + return (true); + } + pc_fallback(sc, start); + } + if (int_optimize(sc, cddr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(car_x))) { + opc->v[0].fd = opt_d_7pid_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + return (true); + } + } + pc_fallback(sc, start); + } + } + return_false(sc, car_x); +} + +/* -------- d_7pii -------- */ +/* currently this can only be float_vector_ref_d_7pii (d_7pii is not exported at this time) */ + +static s7_double opt_d_7pii_sss(opt_info * o) +{ /* o->v[4].d_7pii_f */ + return (float_vector_ref_d_7pii + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p)))); +} + +static s7_double opt_d_7pii_sss_unchecked(opt_info * o) +{ + s7_pointer v = slot_value(o->v[1].p); + return (float_vector + (v, + ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + + integer(slot_value(o->v[3].p))))); +} + +static s7_double opt_d_7pii_scs(opt_info * o) +{ + return (float_vector_ref_d_7pii + (opt_sc(o), slot_value(o->v[1].p), o->v[2].i, + integer(slot_value(o->v[3].p)))); +} + +static s7_double opt_d_7pii_sff(opt_info * o) +{ + return (float_vector_ref_d_7pii + (opt_sc(o), slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1), + o->v[9].fi(o->v[8].o1))); +} + +static bool d_7pii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_d_7pii_t ifunc; + ifunc = s7_d_7pii_function(s_func); + if ((ifunc == float_vector_ref_d_7pii) && (is_symbol(cadr(car_x)))) { + s7_pointer slot; + int32_t start = sc->pc; + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + if ((!is_slot(opc->v[1].p)) || + (!is_float_vector(slot_value(opc->v[1].p))) || + (vector_rank(slot_value(opc->v[1].p)) != 2)) + return_false(sc, car_x); + + opc->v[4].d_7pii_f = ifunc; /* currently pointless */ + slot = opt_integer_symbol(sc, cadddr(car_x)); + if (slot) { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, caddr(car_x)); + if (slot) { + opc->v[2].p = slot; + opc->v[0].fd = opt_d_7pii_sss; + if ((step_end_fits + (opc->v[2].p, + vector_dimension(slot_value(opc->v[1].p), 0))) + && + (step_end_fits + (opc->v[3].p, + vector_dimension(slot_value(opc->v[1].p), 1)))) + opc->v[0].fd = opt_d_7pii_sss_unchecked; + return (true); + } + if (is_t_integer(caddr(car_x))) { + opc->v[2].i = integer(caddr(car_x)); + opc->v[0].fd = opt_d_7pii_scs; + return (true); + } + } + opc->v[10].o1 = sc->opts[start]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(car_x))) { + opc->v[0].fd = opt_d_7pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + return (true); + } + } + pc_fallback(sc, start); + } + return_false(sc, car_x); +} + +/* -------- d_7piid -------- */ +/* currently only float_vector_set */ + +static s7_double opt_d_7piid_sssf(opt_info * o) +{ /* o->v[5].d_7piid_f and below */ + return (float_vector_set_d_7piid + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p)), o->v[9].fd(o->v[8].o1))); +} + +static s7_double opt_d_7piid_sssc(opt_info * o) +{ + return (float_vector_set_d_7piid + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p)), o->v[4].x)); +} + +static s7_double opt_d_7piid_scsf(opt_info * o) +{ + return (float_vector_set_d_7piid + (opt_sc(o), slot_value(o->v[1].p), o->v[2].i, + integer(slot_value(o->v[3].p)), o->v[11].fd(o->v[10].o1))); +} + +static s7_double opt_d_7piid_sfff(opt_info * o) +{ + s7_int i1, i2; + i1 = o->v[11].fi(o->v[10].o1); + i2 = o->v[9].fi(o->v[8].o1); + return (float_vector_set_d_7piid + (opt_sc(o), slot_value(o->v[1].p), i1, i2, + o->v[4].fd(o->v[3].o1))); +} + +static s7_double opt_d_7piid_sssf_unchecked(opt_info * o) +{ /* this could be subsumed by the call above if we were using o->v[5] or o->v[0].fd */ + s7_int i1, i2; + s7_pointer vect = slot_value(o->v[1].p); + s7_double val; + i1 = integer(slot_value(o->v[2].p)); + i2 = integer(slot_value(o->v[3].p)); + val = o->v[9].fd(o->v[8].o1); + float_vector(vect, (i1 * (vector_offset(vect, 0)) + i2)) = val; + return (val); +} + +static bool d_7piid_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_d_7piid_t f; + f = s7_d_7piid_function(s_func); + if ((f) && (is_symbol(cadr(car_x)))) { + opc->v[4].d_7piid_f = f; + if (is_target_or_its_alias + (car(car_x), s_func, sc->float_vector_set_symbol)) + return (opt_float_vector_set + (sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x), NULL, + cddddr(car_x))); + } + return_false(sc, car_x); +} + +/* -------- d_7piii -------- */ +static s7_double opt_d_7piii_ssss(opt_info * o) +{ + return (float_vector_ref_d_7piii + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p)), + integer(slot_value(o->v[5].p)))); +} + +static s7_double opt_d_7piii_ssss_unchecked(opt_info * o) +{ + s7_pointer v = slot_value(o->v[1].p); + s7_int i1, i2; + i1 = integer(slot_value(o->v[2].p)) * vector_offset(v, 0); + i2 = integer(slot_value(o->v[3].p)) * vector_offset(v, 1); /* offsets accumulate */ + return (float_vector(v, (i1 + i2 + integer(slot_value(o->v[5].p))))); +} + +static bool d_7piii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_d_7piii_t ifunc; + ifunc = s7_d_7piii_function(s_func); + if ((ifunc == float_vector_ref_d_7piii) && (is_symbol(cadr(car_x)))) { + s7_pointer slot; + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + if ((!is_slot(opc->v[1].p)) || + (!is_float_vector(slot_value(opc->v[1].p))) || + (vector_rank(slot_value(opc->v[1].p)) != 3)) + return_false(sc, car_x); + + opc->v[4].d_7piii_f = ifunc; /* currently ignored */ + slot = opt_integer_symbol(sc, car(cddddr(car_x))); + if (slot) { + opc->v[5].p = slot; + slot = opt_integer_symbol(sc, cadddr(car_x)); + if (slot) { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, caddr(car_x)); + if (slot) { + s7_pointer vect = slot_value(opc->v[1].p); + opc->v[2].p = slot; + opc->v[0].fd = opt_d_7piii_ssss; + if ((step_end_fits + (opc->v[2].p, vector_dimension(vect, 0))) + && + (step_end_fits + (opc->v[3].p, vector_dimension(vect, 1))) + && + (step_end_fits + (opc->v[5].p, vector_dimension(vect, 2)))) + opc->v[0].fd = opt_d_7piii_ssss_unchecked; + return (true); + } + } + } + } + return (false); +} + +/* -------- d_7piiid -------- */ +static s7_double opt_d_7piiid_ssssf(opt_info * o) +{ + return (float_vector_set_d_7piiid + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p)), + integer(slot_value(o->v[5].p)), o->v[11].fd(o->v[10].o1))); +} + +static s7_double opt_d_7piiid_ssssf_unchecked(opt_info * o) +{ + s7_int i1, i2, i3; + s7_pointer vect = slot_value(o->v[1].p); + s7_double val; + i1 = integer(slot_value(o->v[2].p)) * vector_offset(vect, 0); + i2 = integer(slot_value(o->v[3].p)) * vector_offset(vect, 1); + i3 = integer(slot_value(o->v[5].p)); + val = o->v[11].fd(o->v[10].o1); + float_vector(vect, (i1 + i2 + i3)) = val; + return (val); +} + +static bool d_7piiid_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_d_7piiid_t f; + f = s7_d_7piiid_function(s_func); + if ((f == float_vector_set_d_7piiid) && (is_symbol(cadr(car_x)))) { + opc->v[4].d_7piiid_f = f; + if (is_target_or_its_alias + (car(car_x), s_func, sc->float_vector_set_symbol)) + return (opt_float_vector_set + (sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x), + cddddr(car_x), cdr(cddddr(car_x)))); + } + return (false); +} + +static bool opt_float_vector_set(s7_scheme * sc, opt_info * opc, + s7_pointer v, s7_pointer indexp1, + s7_pointer indexp2, s7_pointer indexp3, + s7_pointer valp) +{ + s7_pointer settee; + settee = lookup_slot_from(v, sc->curlet); + if ((is_slot(settee)) && (!is_immutable(slot_value(settee)))) { + s7_pointer slot, vect = slot_value(settee); + int32_t start = sc->pc; + opc->v[1].p = settee; + if (!is_float_vector(vect)) + return_false(sc, NULL); + opc->v[10].o1 = sc->opts[start]; + if ((!indexp2) && (vector_rank(vect) == 1)) { + opc->v[4].d_7pid_f = float_vector_set_d_7pid; + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) { + opc->v[2].p = slot; + if (step_end_fits(opc->v[2].p, vector_length(vect))) + opc->v[4].d_7pid_f = float_vector_set_unchecked; + slot = opt_float_symbol(sc, car(valp)); + if (slot) { + opc->v[3].p = slot; + opc->v[0].fd = opt_d_7pid_sss; + return (true); + } + if (is_small_real(car(valp))) { + opc->v[3].x = s7_real(car(valp)); + opc->v[0].fd = opt_d_7pid_ssc; + return (true); + } + if (float_optimize(sc, valp)) { + opc->v[11].fd = sc->opts[start]->v[0].fd; + if (d_7pid_ssf_combinable(sc, opc)) + return (true); + opc->v[0].fd = opt_d_7pid_ssf; + return (true); + } + pc_fallback(sc, start); + } + if (int_optimize(sc, indexp1)) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, valp)) { + opc->v[0].fd = opt_d_7pid_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + return (true); + } + } + return_false(sc, NULL); + } + if ((indexp2) && (!indexp3) && (vector_rank(vect) == 2)) { + opc->v[5].d_7piid_f = float_vector_set_d_7piid; + /* could check for step_end/end-ok here for both indices, but the d_7pii* functions currently assume fv_d_7piid + * perhaps set a different fd? so opc->v[0].fd = fvset_unchecked_d_7piid or whatever + */ + slot = opt_integer_symbol(sc, car(indexp2)); + if (slot) { + opc->v[3].p = slot; + if (is_t_integer(car(indexp1))) { + if (!float_optimize(sc, valp)) + return_false(sc, NULL); + opc->v[0].fd = opt_d_7piid_scsf; + opc->v[2].i = integer(car(indexp1)); + opc->v[11].fd = opc->v[10].o1->v[0].fd; + return (true); + } + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) { + opc->v[2].p = slot; + if (is_small_real(car(valp))) { + opc->v[0].fd = opt_d_7piid_sssc; + opc->v[4].x = s7_real(car(valp)); + return (true); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, valp)) { + opc->v[0].fd = opt_d_7piid_sssf; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + + if ((step_end_fits + (opc->v[2].p, vector_dimension(vect, 0))) + && + (step_end_fits + (opc->v[3].p, vector_dimension(vect, 1)))) + opc->v[0].fd = opt_d_7piid_sssf_unchecked; + return (true); + } + pc_fallback(sc, start); + } + } + if (int_optimize(sc, indexp1)) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) { + opc->v[3].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, valp)) { + opc->v[0].fd = opt_d_7piid_sfff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[4].fd = opc->v[3].o1->v[0].fd; + return (true); + } + } + } + return_false(sc, NULL); + } + if ((indexp3) && (vector_rank(vect) == 3)) { + opc->v[4].d_7piiid_f = float_vector_set_d_7piiid; + slot = opt_integer_symbol(sc, car(indexp3)); + if (slot) { + opc->v[5].p = slot; + slot = opt_integer_symbol(sc, car(indexp2)); + if (slot) { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) { + opc->v[2].p = slot; + if (float_optimize(sc, valp)) { + opc->v[0].fd = opt_d_7piiid_ssssf; + opc->v[11].fd = sc->opts[start]->v[0].fd; + if ((step_end_fits + (opc->v[2].p, vector_dimension(vect, 0))) + && + (step_end_fits + (opc->v[3].p, vector_dimension(vect, 1))) + && + (step_end_fits + (opc->v[5].p, vector_dimension(vect, 2)))) + opc->v[0].fd = + opt_d_7piiid_ssssf_unchecked; + return (true); + } + } + } + } + } + } + return_false(sc, NULL); +} + + +/* -------- d_vid -------- */ +static s7_double opt_d_vid_ssf(opt_info * o) +{ + return (o->v[4].d_vid_f(o->v[5].obj, integer(slot_value(o->v[2].p)), + o->v[11].fd(o->v[10].o1))); +} + +static inline s7_double opt_fmv(opt_info * o) +{ + /* d_vid_ssf -> d_dd_ff_o1 -> d_vd_o1 -> d_dd_ff_o3, this is a placeholder */ + opt_info *o1, *o2, *o3; + s7_double amp_env, index_env, vib; + o1 = o->v[12].o1; /* o2 below */ + o2 = o->v[13].o1; /* o3 below */ + o3 = o->v[14].o1; /* o1 below */ + amp_env = o1->v[2].d_v_f(o1->v[1].obj); + vib = real(slot_value(o2->v[2].p)); + index_env = o3->v[5].d_v_f(o3->v[1].obj); + return (o->v[4].d_vid_f(o->v[5].obj, + integer(slot_value(o->v[2].p)), + amp_env * o2->v[3].d_vd_f(o2->v[5].obj, + vib + + (index_env * + o3->v[6]. + d_vd_f(o3->v[2].obj, + vib))))); +} + +static bool d_vid_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + if ((is_symbol(cadr(car_x))) && (is_symbol(caddr(car_x)))) { + s7_pointer sig; + s7_d_vid_t flt; + flt = s7_d_vid_function(s_func); + if (!flt) + return_false(sc, car_x); + opc->v[4].d_vid_f = flt; + sig = c_function_signature(s_func); + if (is_pair(sig)) { + int32_t start = sc->pc; + s7_pointer vslot; + vslot = opt_types_match(sc, cadr(sig), cadr(car_x)); + if (vslot) { + s7_pointer slot; + opc->v[0].fd = opt_d_vid_ssf; + opc->v[1].p = vslot; + opc->v[10].o1 = sc->opts[start]; + slot = opt_integer_symbol(sc, caddr(car_x)); + if ((slot) && (float_optimize(sc, cdddr(car_x)))) { + opt_info *o2; + opc->v[2].p = slot; + opc->v[5].obj = + (void *) c_object_value(slot_value(vslot)); + opc->v[11].fd = opc->v[10].o1->v[0].fd; + o2 = sc->opts[start]; + if (o2->v[0].fd == opt_d_dd_ff_mul1) { + opt_info *o3 = sc->opts[start + 2]; + if (o3->v[0].fd == opt_d_vd_o1) { + opt_info *o1 = sc->opts[start + 4]; + if ((o1->v[0].fd == opt_d_dd_ff_o3) && + (o1->v[4].d_dd_f == multiply_d_dd) && + (o3->v[4].d_dd_f == add_d_dd)) { + opc->v[0].fd = opt_fmv; /* a placeholder -- see below */ + opc->v[12].o1 = o2; + opc->v[13].o1 = o3; + opc->v[14].o1 = o1; + } + } + } + return (true); + } + } + pc_fallback(sc, start); + } + } + return_false(sc, car_x); +} + +/* -------- d_vdd -------- */ +static s7_double opt_d_vdd_ff(opt_info * o) +{ + s7_double x1, x2; + x1 = o->v[11].fd(o->v[10].o1); + x2 = o->v[9].fd(o->v[8].o1); + return (o->v[4].d_vdd_f(o->v[5].obj, x1, x2)); +} + +static bool d_vdd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_d_vdd_t flt; + flt = s7_d_vdd_function(s_func); + if (flt) { + s7_pointer sig = c_function_signature(s_func); + opc->v[4].d_vdd_f = flt; + if (is_pair(sig)) { + s7_pointer slot; + slot = opt_types_match(sc, cadr(sig), cadr(car_x)); + if (slot) { + int32_t start = sc->pc; + opc->v[10].o1 = sc->opts[start]; + if (float_optimize(sc, cddr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(car_x))) { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + opc->v[1].p = slot; + opc->v[5].obj = + (void *) c_object_value(slot_value(slot)); + opc->v[0].fd = opt_d_vdd_ff; + return (true); + } + } + pc_fallback(sc, start); + } + } + } + return_false(sc, car_x); +} + + +/* -------- d_dddd -------- */ +static s7_double opt_d_dddd_ffff(opt_info * o) +{ + s7_double x1, x2, x3, x4; + x1 = o->v[11].fd(o->v[10].o1); + x2 = o->v[9].fd(o->v[8].o1); + x3 = o->v[5].fd(o->v[4].o1); + x4 = o->v[3].fd(o->v[2].o1); + return (o->v[1].d_dddd_f(x1, x2, x3, x4)); +} + +static bool d_dddd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_d_dddd_t f; + f = s7_d_dddd_function(s_func); + if (!f) + return_false(sc, car_x); + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(car_x))) { + opc->v[4].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(car_x))) { + opc->v[2].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddddr(car_x))) { + opc->v[1].d_dddd_f = f; + opc->v[0].fd = opt_d_dddd_ffff; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + opc->v[5].fd = opc->v[4].o1->v[0].fd; + opc->v[3].fd = opc->v[2].o1->v[0].fd; + return (true); + } + } + } + } + return_false(sc, car_x); +} + +/* -------- d_add|multiply|subtract_any ------- */ +static s7_double opt_d_add_any_f(opt_info * o) +{ + s7_double sum = 0.0; + int32_t i; + for (i = 0; i < o->v[1].i; i++) { + opt_info *o1; + o1 = o->v[i + 2].o1; + sum += o1->v[0].fd(o1); + } + return (sum); +} + +static s7_double opt_d_multiply_any_f(opt_info * o) +{ + s7_double sum = 1.0; + int32_t i; + for (i = 0; i < o->v[1].i; i++) { + opt_info *o1; + o1 = o->v[i + 2].o1; + sum *= o1->v[0].fd(o1); + } + return (sum); +} + +static bool d_add_any_ok(s7_scheme * sc, opt_info * opc, s7_pointer car_x, + int32_t len) +{ + s7_pointer head = car(car_x); + int32_t start = sc->pc; + if ((head == sc->add_symbol) || (head == sc->multiply_symbol)) { + s7_pointer p; + int32_t cur_len; + for (cur_len = 0, p = cdr(car_x); (is_pair(p)) && (cur_len < 12); + p = cdr(p), cur_len++) { + opc->v[cur_len + 2].o1 = sc->opts[sc->pc]; + if (!float_optimize(sc, p)) + break; + } + if (is_null(p)) { + opc->v[1].i = cur_len; + opc->v[0].fd = + (head == + sc->add_symbol) ? opt_d_add_any_f : opt_d_multiply_any_f; + return (true); + } + } + pc_fallback(sc, start); + return_false(sc, car_x); +} + + +/* -------- d_syntax -------- */ +static s7_double opt_set_d_d_f(opt_info * o) +{ + s7_double x; + x = o->v[3].fd(o->v[2].o1); + slot_set_value(o->v[1].p, make_real(opt_sc(o), x)); + return (x); +} + +static s7_double opt_set_d_d_fm(opt_info * o) +{ + s7_double x; + x = o->v[3].fd(o->v[2].o1); + real(slot_value(o->v[1].p)) = x; + return (x); +} + +static bool d_syntax_ok(s7_scheme * sc, s7_pointer car_x, int32_t len) +{ + if ((len == 3) && (car(car_x) == sc->set_symbol)) { + opt_info *opc; + opc = alloc_opo(sc); + if (is_symbol(cadr(car_x))) { + s7_pointer settee; + if (is_immutable(cadr(car_x))) + return_false(sc, car_x); + settee = lookup_slot_from(cadr(car_x), sc->curlet); + if ((is_slot(settee)) && + (!is_immutable(settee)) && ((!slot_has_setter(settee)) + || (slot_setter(settee) != + initial_value(sc-> + is_float_symbol)))) + /* ttl.scm experiment: if setter is float? (sin float) is a float so we can float_optimize this */ + { + opt_info *o1 = sc->opts[sc->pc]; + opc->v[1].p = settee; + if ((!is_t_integer(caddr(car_x))) && + (is_t_real(slot_value(settee))) && + (float_optimize(sc, cddr(car_x)))) { + opc->v[0].fd = + (is_mutable_number(slot_value(opc->v[1].p))) ? + opt_set_d_d_fm : opt_set_d_d_f; + opc->v[2].o1 = o1; + opc->v[3].fd = o1->v[0].fd; + return (true); + } + } + } else /* if is_pair(settee) get setter */ + if ((is_pair(cadr(car_x))) && + (is_symbol(caadr(car_x))) && (is_pair(cdadr(car_x)))) { + if (is_null(cddadr(car_x))) + return (opt_float_vector_set + (sc, opc, caadr(car_x), cdadr(car_x), NULL, NULL, + cddr(car_x))); + if (is_null(cdddr(cadr(car_x)))) + return (opt_float_vector_set + (sc, opc, caadr(car_x), cdadr(car_x), + cddadr(car_x), NULL, cddr(car_x))); + } + } + return_false(sc, car_x); +} + +static bool d_implicit_ok(s7_scheme * sc, s7_pointer s_slot, + s7_pointer car_x, int32_t len) +{ + s7_pointer slot, obj = slot_value(s_slot); + opt_info *opc; + if (is_float_vector(obj)) { + /* implicit float-vector-ref */ + if ((len == 2) && (vector_rank(obj) == 1)) { + opc = alloc_opo(sc); + opc->v[1].p = s_slot; + opc->v[3].d_7pi_f = float_vector_ref_d_7pi; + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) { + opc->v[2].p = slot; + if (step_end_fits(opc->v[2].p, vector_length(obj))) + opc->v[0].fd = opt_d_7pi_ss_fvref_unchecked; + else + opc->v[0].fd = opt_d_7pi_ss_fvref; + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(car_x))) + return_false(sc, car_x); + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[0].fd = opt_d_7pi_sf; + return (true); + } + if ((len == 3) && (vector_rank(obj) == 2)) { + opc = alloc_opo(sc); + opc->v[1].p = s_slot; + opc->v[4].d_7pii_f = float_vector_ref_d_7pii; + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) { + opc->v[2].p = slot; + slot = opt_integer_symbol(sc, caddr(car_x)); + if (slot) { + opc->v[3].p = slot; + opc->v[0].fd = opt_d_7pii_sss; + if ((step_end_fits + (opc->v[2].p, vector_dimension(obj, 0))) + && + (step_end_fits + (opc->v[3].p, vector_dimension(obj, 1)))) + opc->v[0].fd = opt_d_7pii_sss_unchecked; + return (true); + } + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[0].fd = opt_d_7pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + return (true); + } + } + } + if ((len == 4) && (vector_rank(obj) == 3)) { + opc = alloc_opo(sc); + opc->v[1].p = s_slot; + opc->v[4].d_7piii_f = float_vector_ref_d_7piii; + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) { + opc->v[2].p = slot; + slot = opt_integer_symbol(sc, caddr(car_x)); + if (slot) { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, cadddr(car_x)); + if (slot) { + opc->v[5].p = slot; + opc->v[0].fd = opt_d_7piii_ssss; + if ((step_end_fits + (opc->v[2].p, vector_dimension(obj, 0))) + && + (step_end_fits + (opc->v[3].p, vector_dimension(obj, 1))) + && + (step_end_fits + (opc->v[5].p, vector_dimension(obj, 2)))) + opc->v[0].fd = opt_d_7piii_ssss_unchecked; + return (true); + } + } + } + } + } + if ((is_c_object(obj)) && (len == 2)) { + s7_d_7pi_t func; + s7_pointer getf; + getf = c_object_getf(sc, obj); + if (is_c_function(getf)) { /* default is #f */ + func = s7_d_7pi_function(getf); + if (func) { + opc = alloc_opo(sc); + opc->v[1].p = s_slot; + opc->v[4].obj = (void *) c_object_value(obj); + opc->v[3].d_7pi_f = func; + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) { + opc->v[0].fd = opt_d_7pi_ss; + opc->v[2].p = slot; + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[0].fd = opt_d_7pi_sf; + return (true); + } + } + } + } + return_false(sc, car_x); +} + + +/* -------------------------------- bool opts -------------------------------- */ +static bool opt_b_s(opt_info * o) +{ + return (slot_value(o->v[1].p) != opt_sc(o)->F); +} + +static bool opt_bool_not_pair(s7_scheme * sc, s7_pointer car_x) +{ + s7_pointer p; + if (!is_symbol(car_x)) + return_false(sc, car_x); /* i.e. use cell_optimize */ + p = opt_simple_symbol(sc, car_x); + if ((p) && (s7_is_boolean(slot_value(p)))) { + opt_info *opc; + opc = alloc_opo(sc); + opc->v[1].p = p; + opc->v[0].fb = opt_b_s; + return (true); + } + return_false(sc, car_x); +} + +/* -------- b_idp -------- */ +static bool opt_b_i_s(opt_info * o) +{ + return (o->v[2].b_i_f(integer(slot_value(o->v[1].p)))); +} + +static bool opt_b_i_f(opt_info * o) +{ + return (o->v[2].b_i_f(o->v[11].fi(o->v[10].o1))); +} + +static bool opt_b_d_s(opt_info * o) +{ + return (o->v[2].b_d_f(real(slot_value(o->v[1].p)))); +} + +static bool opt_b_d_f(opt_info * o) +{ + return (o->v[2].b_d_f(o->v[11].fd(o->v[10].o1))); +} + +static bool opt_b_p_s(opt_info * o) +{ + return (o->v[2].b_p_f(slot_value(o->v[1].p))); +} + +static bool opt_b_p_f(opt_info * o) +{ + return (o->v[2].b_p_f(o->v[4].fp(o->v[3].o1))); +} + +static bool opt_b_7p_s(opt_info * o) +{ + return (o->v[2].b_7p_f(opt_sc(o), slot_value(o->v[1].p))); +} + +static bool opt_b_7p_f(opt_info * o) +{ + return (o->v[2].b_7p_f(opt_sc(o), o->v[4].fp(o->v[3].o1))); +} + +static bool opt_b_d_s_is_positive(opt_info * o) +{ + return (real(slot_value(o->v[1].p)) > 0.0); +} + +static bool opt_b_p_s_is_integer(opt_info * o) +{ + return (s7_is_integer(slot_value(o->v[1].p))); +} + +static bool opt_b_p_s_is_pair(opt_info * o) +{ + return (is_pair(slot_value(o->v[1].p))); +} + +static bool opt_b_p_f_is_string(opt_info * o) +{ + return (s7_is_string(o->v[4].fp(o->v[3].o1))); +} + +static bool opt_b_7p_s_iter_at_end(opt_info * o) +{ + return (iterator_is_at_end(slot_value(o->v[1].p))); +} + +static bool opt_zero_mod(opt_info * o) +{ + s7_int x = integer(slot_value(o->v[1].p)); + return ((x % o->v[2].i) == 0); +} + +static bool b_idp_ok(s7_scheme * sc, s7_pointer s_func, s7_pointer car_x, + s7_pointer arg_type) +{ + int32_t cur_index; + s7_b_p_t bpf = NULL; + s7_b_7p_t bpf7 = NULL; + opt_info *opc; + + opc = alloc_opo(sc); + cur_index = sc->pc; + + if (arg_type == sc->is_integer_symbol) { + s7_b_i_t bif; + bif = s7_b_i_function(s_func); + if (bif) { + opc->v[2].b_i_f = bif; + if (is_symbol(cadr(car_x))) { + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + opc->v[0].fb = opt_b_i_s; + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) { + opt_info *o1 = sc->opts[sc->pc - 1]; + if ((car(car_x) == sc->is_zero_symbol) && + (o1->v[0].fi == opt_i_ii_sc) && + (o1->v[3].i_ii_f == modulo_i_ii_unchecked)) { + opc->v[0].fb = opt_zero_mod; + opc->v[1].p = o1->v[1].p; + opc->v[2].i = o1->v[2].i; + backup_pc(sc); + return (true); + } + opc->v[0].fb = opt_b_i_f; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + return (true); + } + } + } else if (arg_type == sc->is_float_symbol) { + s7_b_d_t bdf; + bdf = s7_b_d_function(s_func); + if (bdf) { + opc->v[2].b_d_f = bdf; + if (is_symbol(cadr(car_x))) { + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + opc->v[0].fb = + (bdf == + is_positive_d) ? opt_b_d_s_is_positive : opt_b_d_s; + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(car_x))) { + opc->v[0].fb = opt_b_d_f; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + return (true); + } + } + } + pc_fallback(sc, cur_index); + + bpf = s7_b_p_function(s_func); + if (!bpf) + bpf7 = s7_b_7p_function(s_func); + if ((bpf) || (bpf7)) { + if (bpf) + opc->v[2].b_p_f = bpf; + else + opc->v[2].b_7p_f = bpf7; + if (is_symbol(cadr(car_x))) { + s7_pointer p; + p = opt_simple_symbol(sc, cadr(car_x)); + if (!p) + return_false(sc, car_x); + opc->v[1].p = p; + opc->v[0].fb = + (bpf) ? ((bpf == s7_is_integer) ? opt_b_p_s_is_integer + : ((bpf == + s7_is_pair) ? opt_b_p_s_is_pair : opt_b_p_s)) + : (((bpf7 == iterator_is_at_end_b_7p) + && (is_iterator(slot_value(p)))) ? + opt_b_7p_s_iter_at_end : opt_b_7p_s); + return (true); + } + opc->v[3].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(car_x))) { + opc->v[0].fb = + (bpf) ? ((bpf == s7_is_string) ? opt_b_p_f_is_string : + opt_b_p_f) : opt_b_7p_f; + opc->v[4].fp = opc->v[3].o1->v[0].fp; + return (true); + } + } + return_false(sc, car_x); +} + + +/* -------- b_pp -------- */ +static s7_pointer opt_arg_type(s7_scheme * sc, s7_pointer argp) +{ + s7_pointer slot, arg = car(argp); + if (is_pair(arg)) { + if (is_symbol(car(arg))) { + if ((is_global(car(arg))) || + ((is_slot(global_slot(car(arg)))) && + (lookup_slot_from(car(arg), sc->curlet) == + global_slot(car(arg))))) { + s7_pointer a_func = global_value(car(arg)); + if (is_c_function(a_func)) { + s7_pointer sig = c_function_signature(a_func); + if (is_pair(sig)) { + if ((car(sig) == sc->is_integer_symbol) || + ((is_pair(car(sig))) + && + (direct_memq + (sc->is_integer_symbol, car(sig))))) + return (sc->is_integer_symbol); + if ((car(sig) == sc->is_float_symbol) || + ((is_pair(car(sig))) + && + (direct_memq(sc->is_float_symbol, car(sig))))) + return (sc->is_float_symbol); + if ((car(sig) == sc->is_real_symbol) || + (car(sig) == sc->is_number_symbol)) { + int32_t start = sc->pc; + if (int_optimize(sc, argp)) { + pc_fallback(sc, start); + return (sc->is_integer_symbol); + } + if (float_optimize(sc, argp)) { + pc_fallback(sc, start); + return (sc->is_float_symbol); + } + pc_fallback(sc, start); + } + return (car(sig)); /* we want the function's return type in this context */ + } + } + } + slot = lookup_slot_from(car(arg), sc->curlet); + if ((is_slot(slot)) && (is_sequence(slot_value(slot)))) { + s7_pointer sig; + sig = s7_signature(sc, slot_value(slot)); + if (is_pair(sig)) + return (car(sig)); + } + } + return (sc->T); + } + if (is_symbol(arg)) { + slot = opt_simple_symbol(sc, arg); + if (!slot) + return (sc->T); +#if WITH_GMP + if (is_big_number(slot_value(slot))) + return (sc->T); + if ((is_t_integer(slot_value(slot))) && + (integer(slot_value(slot)) > QUOTIENT_INT_LIMIT)) + return (sc->T); + if ((is_t_real(slot_value(slot))) && + (real(slot_value(slot)) > QUOTIENT_FLOAT_LIMIT)) + return (sc->T); +#endif + return (s7_type_of(sc, slot_value(slot))); + } + return (s7_type_of(sc, arg)); +} + +static bool opt_b_pp_ff(opt_info * o) +{ + s7_pointer p1; + p1 = o->v[9].fp(o->v[8].o1); + return (o->v[3].b_pp_f(p1, o->v[11].fp(o->v[10].o1))); +} + +static bool opt_b_7pp_ff(opt_info * o) +{ + s7_pointer p1; + p1 = o->v[9].fp(o->v[8].o1); + return (o->v[3].b_7pp_f(opt_sc(o), p1, o->v[11].fp(o->v[10].o1))); +} + +static bool opt_b_pp_sf(opt_info * o) +{ + return (o-> + v[3].b_pp_f(slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1))); +} + +static bool opt_b_pp_fs(opt_info * o) +{ + return (o-> + v[3].b_pp_f(o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p))); +} + +static bool opt_b_pp_ss(opt_info * o) +{ + return (o->v[3].b_pp_f(slot_value(o->v[1].p), slot_value(o->v[2].p))); +} + +static bool opt_b_pp_sc(opt_info * o) +{ + return (o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[2].p)); +} + +static bool opt_b_pp_sfo(opt_info * o) +{ + return (o->v[3].b_pp_f(slot_value(o->v[1].p), + o->v[4].p_p_f(opt_sc(o), + slot_value(o->v[2].p)))); +} + +static bool opt_b_7pp_sf(opt_info * o) +{ + return (o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p), + o->v[11].fp(o->v[10].o1))); +} + +static bool opt_b_7pp_fs(opt_info * o) +{ + return (o->v[3].b_7pp_f(opt_sc(o), o->v[11].fp(o->v[10].o1), + slot_value(o->v[1].p))); +} + +static bool opt_b_7pp_ss(opt_info * o) +{ + return (o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p), + slot_value(o->v[2].p))); +} + +static bool opt_b_7pp_ss_lt(opt_info * o) +{ + return (lt_b_7pp + (opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p))); +} + +static bool opt_b_7pp_ss_gt(opt_info * o) +{ + return (gt_b_7pp + (opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p))); +} + +static bool opt_b_7pp_ss_char_lt(opt_info * o) +{ + return (char_lt_b_7pp + (opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p))); +} + +static bool opt_b_7pp_sc(opt_info * o) +{ + return (o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p), o->v[2].p)); +} + +static bool opt_b_7pp_sfo(opt_info * o) +{ + return (o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p), + o->v[4].p_p_f(opt_sc(o), + slot_value(o->v[2].p)))); +} + +static bool opt_is_equal_sfo(opt_info * o) +{ + return (s7_is_equal + (opt_sc(o), slot_value(o->v[1].p), + o->v[4].p_p_f(opt_sc(o), slot_value(o->v[2].p)))); +} + +static bool opt_is_equivalent_sfo(opt_info * o) +{ + return (is_equivalent_1 + (opt_sc(o), slot_value(o->v[1].p), + o->v[4].p_p_f(opt_sc(o), slot_value(o->v[2].p)), NULL)); +} + +static bool opt_b_pp_sf_char_eq(opt_info * o) +{ + return (slot_value(o->v[1].p) == o->v[11].fp(o->v[10].o1)); +} /* lt above checks for char args */ + +static bool opt_b_pp_ff_char_eq(opt_info * o) +{ + return (o->v[9].fp(o->v[8].o1) == o->v[11].fp(o->v[10].o1)); +} + +static bool opt_car_equal_sf(opt_info * o) +{ + s7_pointer p = slot_value(o->v[2].p); + return (s7_is_equal + (opt_sc(o), slot_value(o->v[1].p), + (is_pair(p)) ? car(p) : g_car(opt_sc(o), + set_plist_1(opt_sc(o), p)))); +} + +static bool opt_car_equivalent_sf(opt_info * o) +{ + s7_pointer p = slot_value(o->v[2].p); + return (is_equivalent_1 + (opt_sc(o), slot_value(o->v[1].p), + (is_pair(p)) ? car(p) : g_car(opt_sc(o), + set_plist_1(opt_sc(o), p)), + NULL)); +} + +static bool opt_b_7pp_car_sf(opt_info * o) +{ + s7_pointer p = slot_value(o->v[2].p); + return (o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[1].p), + (is_pair(p)) ? car(p) : g_car(opt_sc(o), + set_plist_1 + (opt_sc(o), + p)))); +} + +static s7_pointer opt_p_substring_uncopied_ssf(opt_info * o) +{ /* "inline" here rather than copying below is much slower? */ + return (substring_uncopied_p_pii(opt_sc(o), slot_value(o->v[1].p), + s7_integer_checked(opt_sc(o), + slot_value(o-> + v + [2].p)), + s7_integer_checked(opt_sc(o), + o->v[6].fp(o-> + v + [5].o1)))); +} + +static bool opt_substring_equal_sf(opt_info * o) +{ + return (scheme_strings_are_equal + (slot_value(o->v[1].p), + opt_p_substring_uncopied_ssf(o->v[10].o1))); +} + +static s7_pointer opt_p_p_s(opt_info * o); + +static bool b_pp_sf_combinable(s7_scheme * sc, opt_info * opc, + bool bpf_case) +{ + if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { + opt_info *o1 = sc->opts[sc->pc - 1]; + if (o1->v[0].fp == opt_p_p_s) { + opc->v[2].p = o1->v[1].p; + opc->v[4].p_p_f = o1->v[2].p_p_f; + if (bpf_case) + opc->v[0].fb = opt_b_pp_sfo; + else if (opc->v[4].p_p_f == car_p_p) + opc->v[0].fb = + ((opc->v[3].b_7pp_f == + s7_is_equal) ? opt_car_equal_sf : ((opc-> + v[3].b_7pp_f == + s7_is_equivalent) + ? + opt_car_equivalent_sf + : + opt_b_7pp_car_sf)); + else + opc->v[0].fb = + ((opc->v[3].b_7pp_f == + s7_is_equal) ? opt_is_equal_sfo : ((opc-> + v[3].b_7pp_f == + s7_is_equivalent) + ? + opt_is_equivalent_sfo + : opt_b_7pp_sfo)); + backup_pc(sc); + return (true); + } + } + return_false(sc, NULL); +} + +static bool opt_b_pp_ffo(opt_info * o) +{ + s7_pointer b1; + b1 = o->v[4].p_p_f(opt_sc(o), slot_value(o->v[1].p)); + return (o-> + v[3].b_pp_f(b1, + o->v[5].p_p_f(opt_sc(o), slot_value(o->v[2].p)))); +} + +static bool opt_b_pp_ffo_is_eq(opt_info * o) +{ + s7_pointer b1, b2; + b1 = o->v[4].p_p_f(opt_sc(o), slot_value(o->v[1].p)); + b2 = o->v[5].p_p_f(opt_sc(o), slot_value(o->v[2].p)); + return ((b1 == b2) || ((is_unspecified(b1)) && (is_unspecified(b2)))); +} + +static bool opt_b_7pp_ffo(opt_info * o) +{ + s7_pointer b1; + b1 = o->v[4].p_p_f(opt_sc(o), slot_value(o->v[1].p)); + return (o->v[3].b_7pp_f(opt_sc(o), b1, + o->v[5].p_p_f(opt_sc(o), + slot_value(o->v[2].p)))); +} + +static bool opt_b_cadr_cadr(opt_info * o) +{ + s7_pointer p1 = slot_value(o->v[1].p), p2 = slot_value(o->v[2].p); + p1 = ((is_pair(p1)) + && (is_pair(cdr(p1)))) ? cadr(p1) : g_cadr(opt_sc(o), + set_plist_1(opt_sc(o), + p1)); + p2 = ((is_pair(p2)) + && (is_pair(cdr(p2)))) ? cadr(p2) : g_cadr(opt_sc(o), + set_plist_1(opt_sc(o), + p2)); + return (o->v[3].b_7pp_f(opt_sc(o), p1, p2)); +} + +static bool b_pp_ff_combinable(s7_scheme * sc, opt_info * opc, + bool bpf_case) +{ + if ((sc->pc > 2) && (opc == sc->opts[sc->pc - 3])) { + opt_info *o1 = sc->opts[sc->pc - 2], *o2 = sc->opts[sc->pc - 1]; + if ((o1->v[0].fp == opt_p_p_s) && (o2->v[0].fp == opt_p_p_s)) { + opc->v[1].p = o1->v[1].p; + opc->v[4].p_p_f = o1->v[2].p_p_f; + opc->v[2].p = o2->v[1].p; + opc->v[5].p_p_f = o2->v[2].p_p_f; + opc->v[0].fb = + (bpf_case) ? ((opc->v[3].b_pp_f == s7_is_eq) ? + opt_b_pp_ffo_is_eq : opt_b_pp_ffo) + : (((opc->v[4].p_p_f == cadr_p_p) + && (opc->v[5].p_p_f = + cadr_p_p)) ? opt_b_cadr_cadr : opt_b_7pp_ffo); + sc->pc -= 2; + return (true); + } + } + return_false(sc, NULL); +} + +static void check_b_types(s7_scheme * sc, opt_info * opc, + s7_pointer s_func, s7_pointer car_x, + bool (*fb)(opt_info * o)) +{ + if (s7_b_pp_unchecked_function(s_func)) { + s7_pointer arg1_type, arg2_type, call_sig = + c_function_signature(s_func); + arg1_type = opt_arg_type(sc, cdr(car_x)); + arg2_type = opt_arg_type(sc, cddr(car_x)); + if ((cadr(call_sig) == arg1_type) && /* not car(arg1_type) here: (string>? (string) (read-line)) */ + (caddr(call_sig) == arg2_type)) { + opc->v[0].fb = fb; + opc->v[3].b_pp_f = s7_b_pp_unchecked_function(s_func); + } + } +#if 0 + if ((arg2_type == sc->is_integer_symbol) && s7_b_pi_function(s_func)) { + /* opc->v[0].fb = opt_b_pi */ + fprintf(stderr, " pi: %s\n", display(car_x)); + } +#endif +} + +static bool b_pp_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x, s7_pointer arg1, s7_pointer arg2, + bool bpf_case) +{ + int32_t cur_index = sc->pc; + opt_info *o1; + /* v[3] is set when we get here */ + + if ((is_symbol(arg1)) && (is_symbol(arg2))) { + opc->v[1].p = opt_simple_symbol(sc, arg1); + opc->v[2].p = opt_simple_symbol(sc, arg2); + if ((opc->v[1].p) && (opc->v[2].p)) { + s7_b_7pp_t b7f; + b7f = (bpf_case) ? NULL : opc->v[3].b_7pp_f; + opc->v[0].fb = (bpf_case) ? opt_b_pp_ss : + ((b7f == + lt_b_7pp) ? opt_b_7pp_ss_lt : ((b7f == + gt_b_7pp) ? + opt_b_7pp_ss_gt + : ((b7f == + char_lt_b_7pp) ? + opt_b_7pp_ss_char_lt : + opt_b_7pp_ss))); + return (true); + } + } + if (is_symbol(arg1)) { + opc->v[1].p = opt_simple_symbol(sc, arg1); + if (!opc->v[1].p) + return_false(sc, car_x); + if ((!is_symbol(arg2)) && (!is_pair(arg2))) { + opc->v[2].p = arg2; + opc->v[0].fb = (bpf_case) ? opt_b_pp_sc : opt_b_7pp_sc; + check_b_types(sc, opc, s_func, car_x, opt_b_pp_sc); + return (true); + } + if (cell_optimize(sc, cddr(car_x))) { + if (!b_pp_sf_combinable(sc, opc, bpf_case)) { + opc->v[10].o1 = sc->opts[cur_index]; + opc->v[11].fp = opc->v[10].o1->v[0].fp; + opc->v[0].fb = (bpf_case) ? opt_b_pp_sf : opt_b_7pp_sf; + check_b_types(sc, opc, s_func, car_x, opt_b_pp_sf); /* this finds b_pp_unchecked cases */ + if ((opc->v[11].fp == opt_p_substring_uncopied_ssf) + && (opc->v[3].b_pp_f == string_eq_b_unchecked)) + opc->v[0].fb = opt_substring_equal_sf; + if (opc->v[3].b_pp_f == char_eq_b_unchecked) + opc->v[0].fb = opt_b_pp_sf_char_eq; + } + return (true); + } + pc_fallback(sc, cur_index); + } else if ((is_symbol(arg2)) && (is_pair(arg1))) { + opc->v[10].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(car_x))) { + opc->v[1].p = lookup_slot_from(arg2, sc->curlet); + if ((!is_slot(opc->v[1].p)) || + (has_methods(slot_value(opc->v[1].p)))) + return_false(sc, car_x); + opc->v[11].fp = opc->v[10].o1->v[0].fp; + opc->v[0].fb = (bpf_case) ? opt_b_pp_fs : opt_b_7pp_fs; + check_b_types(sc, opc, s_func, car_x, opt_b_pp_fs); + return (true); + } + pc_fallback(sc, cur_index); + } + /* fprintf(stderr, "%d %s %s\n", __LINE__, display(opt_arg_type(sc, cdr(car_x))), display(opt_arg_type(sc, cddr(car_x)))); */ + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(car_x))) { + opc->v[10].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) { + if (b_pp_ff_combinable(sc, opc, bpf_case)) + return (true); + opc->v[0].fb = (bpf_case) ? opt_b_pp_ff : opt_b_7pp_ff; + opc->v[8].o1 = o1; + opc->v[9].fp = o1->v[0].fp; + opc->v[11].fp = opc->v[10].o1->v[0].fp; + check_b_types(sc, opc, s_func, car_x, opt_b_pp_ff); + if (opc->v[3].b_pp_f == char_eq_b_unchecked) + opc->v[0].fb = opt_b_pp_ff_char_eq; + return (true); + } + } + return_false(sc, car_x); +} + +/* -------- b_pi -------- */ +static bool opt_b_pi_fs(opt_info * o) +{ + return (o->v[2].b_pi_f(opt_sc(o), o->v[11].fp(o->v[10].o1), + integer(slot_value(o->v[1].p)))); +} + +static bool opt_b_pi_fs_num_eq(opt_info * o) +{ + return (num_eq_b_pi + (opt_sc(o), o->v[11].fp(o->v[10].o1), + integer(slot_value(o->v[1].p)))); +} + +static bool opt_b_pi_fi(opt_info * o) +{ + return (o-> + v[2].b_pi_f(opt_sc(o), o->v[11].fp(o->v[10].o1), o->v[1].i)); +} + +#if 0 +static bool opt_b_pi_ff(opt_info * o) +{ + s7_pointer p1; + p1 = o->v[9].fp(o->v[8].o1); + return (o->v[3].b_pi_f(opt_sc(o), p1, o->v[11].fi(o->v[10].o1))); +} +#endif + +static bool b_pi_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x, s7_pointer arg2) +{ + s7_b_pi_t bpif; + bpif = s7_b_pi_function(s_func); + if (bpif) { + if (is_symbol(arg2)) + opc->v[1].p = lookup_slot_from(arg2, sc->curlet); /* slot checked in opt_arg_type */ + else + opc->v[1].i = integer(arg2); + opc->v[10].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(car_x))) { + opc->v[2].b_pi_f = bpif; + if (is_symbol(arg2)) /* not pair? arg2 in bool_optimize */ + opc->v[0].fb = + (bpif == + num_eq_b_pi) ? opt_b_pi_fs_num_eq : opt_b_pi_fs; + else + opc->v[0].fb = opt_b_pi_fi; + opc->v[11].fp = opc->v[10].o1->v[0].fp; + return (true); + } + } + return_false(sc, car_x); +} + + +/* -------- b_dd -------- */ +static bool opt_b_dd_ss(opt_info * o) +{ + return (o->v[3].b_dd_f(real(slot_value(o->v[1].p)), + real(slot_value(o->v[2].p)))); +} + +static bool opt_b_dd_ss_lt(opt_info * o) +{ + return (real(slot_value(o->v[1].p)) < real(slot_value(o->v[2].p))); +} + +static bool opt_b_dd_ss_gt(opt_info * o) +{ + return (real(slot_value(o->v[1].p)) > real(slot_value(o->v[2].p))); +} + +static bool opt_b_dd_sc(opt_info * o) +{ + return (o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[2].x)); +} + +static bool opt_b_dd_sc_lt(opt_info * o) +{ + return (real(slot_value(o->v[1].p)) < o->v[2].x); +} + +static bool opt_b_dd_sc_geq(opt_info * o) +{ + return (real(slot_value(o->v[1].p)) >= o->v[2].x); +} + +static bool opt_b_dd_sc_eq(opt_info * o) +{ + return (real(slot_value(o->v[1].p)) == o->v[2].x); +} + +static bool opt_b_dd_sf(opt_info * o) +{ + return (o-> + v[3].b_dd_f(real(slot_value(o->v[1].p)), + o->v[11].fd(o->v[10].o1))); +} + +static bool opt_b_dd_fs(opt_info * o) +{ + return (o-> + v[3].b_dd_f(o->v[11].fd(o->v[10].o1), + real(slot_value(o->v[1].p)))); +} + +static bool opt_b_dd_fs_gt(opt_info * o) +{ + return (o->v[11].fd(o->v[10].o1) > real(slot_value(o->v[1].p))); +} + +static bool opt_b_dd_fc(opt_info * o) +{ + return (o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), o->v[1].x)); +} + +static bool opt_b_dd_ff(opt_info * o) +{ + s7_double x1, x2; + x1 = o->v[11].fd(o->v[10].o1); + x2 = o->v[9].fd(o->v[8].o1); + return (o->v[3].b_dd_f(x1, x2)); +} + +static bool b_dd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x, s7_pointer arg1, s7_pointer arg2) +{ + s7_b_dd_t bif; + int32_t cur_index = sc->pc; + bif = s7_b_dd_function(s_func); + if (!bif) + return_false(sc, car_x); + opc->v[3].b_dd_f = bif; + if (is_symbol(arg1)) { + opc->v[1].p = lookup_slot_from(arg1, sc->curlet); + if (is_symbol(arg2)) { + opc->v[2].p = lookup_slot_from(arg2, sc->curlet); + opc->v[0].fb = + (bif == + lt_b_dd) ? opt_b_dd_ss_lt : ((bif == + gt_b_dd) ? opt_b_dd_ss_gt : + opt_b_dd_ss); + return (true); + } + if (is_t_real(arg2)) { + opc->v[2].x = s7_number_to_real(sc, arg2); + opc->v[0].fb = + (bif == + lt_b_dd) ? opt_b_dd_sc_lt : ((bif == + geq_b_dd) ? opt_b_dd_sc_geq + : ((bif == + num_eq_b_dd) ? + opt_b_dd_sc_eq : + opt_b_dd_sc)); + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(car_x))) { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[0].fb = opt_b_dd_sf; + return (true); + } + } + pc_fallback(sc, cur_index); + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(car_x))) { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + if (is_symbol(arg2)) { + opc->v[1].p = lookup_slot_from(arg2, sc->curlet); + opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs; + return (true); + } + if (is_small_real(arg2)) { + opc->v[1].x = s7_number_to_real(sc, arg2); + opc->v[0].fb = opt_b_dd_fc; + return (true); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(car_x))) { + opc->v[9].fd = opc->v[8].o1->v[0].fd; + opc->v[0].fb = opt_b_dd_ff; + return (true); + } + } + pc_fallback(sc, cur_index); + return_false(sc, car_x); +} + + +/* -------- b_ii -------- */ +static bool opt_b_ii_ss(opt_info * o) +{ + return (o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), + integer(slot_value(o->v[2].p)))); +} + +static bool opt_b_ii_ss_lt(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) < + integer(slot_value(o->v[2].p))); +} + +static bool opt_b_ii_ss_gt(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) > + integer(slot_value(o->v[2].p))); +} + +static bool opt_b_ii_ss_leq(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) <= + integer(slot_value(o->v[2].p))); +} + +static bool opt_b_ii_ss_geq(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) >= + integer(slot_value(o->v[2].p))); +} + +static bool opt_b_ii_ss_eq(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) == + integer(slot_value(o->v[2].p))); +} + +static bool opt_b_ii_sc(opt_info * o) +{ + return (o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i)); +} + +static bool opt_b_ii_sc_lt(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) < o->v[2].i); +} + +static bool opt_b_ii_sc_leq(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) <= o->v[2].i); +} + +static bool opt_b_ii_sc_gt(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) > o->v[2].i); +} + +static bool opt_b_ii_sc_geq(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) >= o->v[2].i); +} + +static bool opt_b_ii_sc_eq(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) == o->v[2].i); +} + +static bool opt_b_ii_sc_lt_2(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) < 2); +} + +static bool opt_b_ii_sc_lt_1(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) < 1); +} + +static bool opt_b_ii_sc_lt_0(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) < 0); +} + +static bool opt_b_ii_sc_leq_0(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) <= 0); +} + +static bool opt_b_ii_sc_gt_0(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) > 0); +} + +static bool opt_b_ii_sc_geq_0(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) >= 0); +} + +static bool opt_b_ii_sc_eq_0(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) == 0); +} + +static bool opt_b_ii_sc_eq_1(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) == 1); +} + +static bool opt_b_7ii_ss(opt_info * o) +{ + return (o->v[3].b_7ii_f(opt_sc(o), integer(slot_value(o->v[1].p)), + integer(slot_value(o->v[2].p)))); +} + +static bool opt_b_7ii_sc(opt_info * o) +{ + return (o-> + v[3].b_7ii_f(opt_sc(o), integer(slot_value(o->v[1].p)), + o->v[2].i)); +} + +static bool opt_b_7ii_sc_bit(opt_info * o) +{ + return ((integer(slot_value(o->v[1].p)) & + ((int64_t) (1LL << o->v[2].i))) != 0); +} + +static bool opt_b_ii_ff(opt_info * o) +{ + s7_int i1, i2; + i1 = o->v[11].fi(o->v[10].o1); + i2 = o->v[9].fi(o->v[8].o1); + return (o->v[3].b_ii_f(i1, i2)); +} + +static bool opt_b_ii_fs(opt_info * o) +{ + return (o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), + integer(slot_value(o->v[2].p)))); +} + +static bool opt_b_ii_sf(opt_info * o) +{ + return (o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), + o->v[11].fi(o->v[10].o1))); +} + +static bool opt_b_ii_sf_eq(opt_info * o) +{ + return (integer(slot_value(o->v[1].p)) == o->v[11].fi(o->v[10].o1)); +} + +static bool opt_b_ii_fc(opt_info * o) +{ + return (o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i)); +} + +static bool opt_b_ii_fc_eq(opt_info * o) +{ + return (o->v[11].fi(o->v[10].o1) == o->v[2].i); +} + +static bool b_ii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x, s7_pointer arg1, s7_pointer arg2) +{ + s7_b_ii_t bif; + s7_b_7ii_t b7if = NULL; + bif = s7_b_ii_function(s_func); + if (!bif) { + b7if = s7_b_7ii_function(s_func); + if (!b7if) + return_false(sc, car_x); + } + if (bif) + opc->v[3].b_ii_f = bif; + else + opc->v[3].b_7ii_f = b7if; + if (is_symbol(arg1)) { + opc->v[1].p = lookup_slot_from(arg1, sc->curlet); + if (is_symbol(arg2)) { + opc->v[2].p = lookup_slot_from(arg2, sc->curlet); + + opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_ss_lt : + ((bif == leq_b_ii) ? opt_b_ii_ss_leq : + ((bif == gt_b_ii) ? opt_b_ii_ss_gt : + ((bif == geq_b_ii) ? opt_b_ii_ss_geq : + ((bif == num_eq_b_ii) ? opt_b_ii_ss_eq : + ((bif) ? opt_b_ii_ss : opt_b_7ii_ss))))); + return (true); + } + if (is_t_integer(arg2)) { + s7_int i2 = integer(arg2); + opc->v[2].i = i2; + opc->v[0].fb = + (bif == + num_eq_b_ii) ? ((i2 == + 0) ? opt_b_ii_sc_eq_0 : ((i2 == + 1) ? + opt_b_ii_sc_eq_1 + : + opt_b_ii_sc_eq)) + : ((bif == + lt_b_ii) ? ((i2 == + 0) ? opt_b_ii_sc_lt_0 : ((i2 == + 1) ? + opt_b_ii_sc_lt_1 + : ((i2 == + 2) ? + opt_b_ii_sc_lt_2 + : + opt_b_ii_sc_lt))) + : ((bif == + gt_b_ii) ? ((i2 == + 0) ? opt_b_ii_sc_gt_0 : opt_b_ii_sc_gt) + : ((bif == + leq_b_ii) ? ((i2 == + 0) ? opt_b_ii_sc_leq_0 : + opt_b_ii_sc_leq) : ((bif == + geq_b_ii) + ? ((i2 == + 0) ? + opt_b_ii_sc_geq_0 + : + opt_b_ii_sc_geq) + : (((b7if == + logbit_b_7ii) + && (i2 >= 0) + && (i2 < + S7_INT_BITS)) + ? + opt_b_7ii_sc_bit + : ((bif) ? + opt_b_ii_sc + : + opt_b_7ii_sc)))))); + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if ((bif) && (int_optimize(sc, cddr(car_x)))) { + opc->v[0].fb = + (bif == num_eq_b_ii) ? opt_b_ii_sf_eq : opt_b_ii_sf; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + return (true); + } + return_false(sc, car_x); + } + if (!bif) + return_false(sc, car_x); + + if (is_symbol(arg2)) { + opc->v[10].o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(car_x))) + return_false(sc, car_x); + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[2].p = lookup_slot_from(arg2, sc->curlet); + opc->v[0].fb = opt_b_ii_fs; + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + if (is_t_integer(arg2)) { + opc->v[2].i = integer(arg2); + opc->v[0].fb = + (bif == num_eq_b_ii) ? opt_b_ii_fc_eq : opt_b_ii_fc; + return (true); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[0].fb = opt_b_ii_ff; + return (true); + } + } + return_false(sc, car_x); +} + +/* -------- b_or|and -------- */ +static bool opt_and_bb(opt_info * o) +{ + return ((o->v[3].fb(o->v[2].o1)) ? o->v[11].fb(o->v[10].o1) : false); +} + +static bool opt_and_any_b(opt_info * o) +{ + int32_t i; + for (i = 0; i < o->v[1].i; i++) { + opt_info *o1; + o1 = o->v[i + 3].o1; + if (!o1->v[0].fb(o1)) + return (false); + } + return (true); +} + +static bool opt_or_bb(opt_info * o) +{ + return ((o->v[3].fb(o->v[2].o1)) ? true : o->v[11].fb(o->v[10].o1)); +} + +static bool opt_or_any_b(opt_info * o) +{ + int32_t i; + for (i = 0; i < o->v[1].i; i++) { + opt_info *o1; + o1 = o->v[i + 3].o1; + if (o1->v[0].fb(o1)) + return (true); + } + return (false); +} + +static bool opt_b_or_and(s7_scheme * sc, s7_pointer car_x, int32_t len, + int32_t is_and) +{ + opt_info *opc; + s7_pointer p; + int32_t i; + + opc = alloc_opo(sc); + if (len == 3) { + opt_info *o1 = sc->opts[sc->pc]; + if (bool_optimize_nw(sc, cdr(car_x))) { + opt_info *o2 = sc->opts[sc->pc]; + if (bool_optimize_nw(sc, cddr(car_x))) { + opc->v[10].o1 = o2; + opc->v[11].fb = o2->v[0].fb; + opc->v[0].fb = (is_and) ? opt_and_bb : opt_or_bb; + opc->v[2].o1 = o1; + opc->v[3].fb = o1->v[0].fb; + return (true); + } + } + return_false(sc, car_x); + } + opc->v[1].i = (len - 1); + for (i = 0, p = cdr(car_x); (is_pair(p)) && (i < 12); i++, p = cdr(p)) { + opc->v[i + 3].o1 = sc->opts[sc->pc]; + if (!bool_optimize_nw(sc, p)) + break; + } + if (!is_null(p)) + return_false(sc, car_x); + opc->v[0].fb = (is_and) ? opt_and_any_b : opt_or_any_b; + return (true); +} + +static bool opt_b_and(s7_scheme * sc, s7_pointer car_x, int32_t len) +{ + return (opt_b_or_and(sc, car_x, len, true)); +} + +static bool opt_b_or(s7_scheme * sc, s7_pointer car_x, int32_t len) +{ + return (opt_b_or_and(sc, car_x, len, false)); +} + + +/* ---------------------------------------- cell opts ---------------------------------------- */ + +static s7_pointer opt_p_c(opt_info * o) +{ + return (o->v[1].p); +} + +static s7_pointer opt_p_s(opt_info * o) +{ + return (slot_value(o->v[1].p)); +} + +static bool opt_cell_not_pair(s7_scheme * sc, s7_pointer car_x) +{ + s7_pointer p; + opt_info *opc; + if (!is_symbol(car_x)) { + opc = alloc_opo(sc); + opc->v[1].p = car_x; + opc->v[0].fp = opt_p_c; + return (true); + } + p = opt_simple_symbol(sc, car_x); + if (!p) + return_false(sc, car_x); + opc = alloc_opo(sc); + opc->v[1].p = p; + opc->v[0].fp = opt_p_s; + return (true); +} + +/* -------- p -------- */ +#define is_opt_safe(P) ((optimize_op(P) >= OP_SAFE_C_S) && (!is_unknown_op(optimize_op(P)))) + +#define cf_call(Sc, Car_x, S_func, Num) \ + (((is_optimized(Car_x)) && (is_opt_safe(Car_x))) ? fn_proc(Car_x) : c_function_call(c_function_chooser(S_func)(Sc, S_func, Num, Car_x, false))) + +static s7_pointer opt_p_f(opt_info * o) +{ + return (o->v[1].p_f(opt_sc(o))); +} + +static s7_pointer opt_p_call(opt_info * o) +{ + return (o->v[1].call(opt_sc(o), opt_sc(o)->nil)); +} + +static bool p_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_p_t func; + func = s7_p_function(s_func); + if (func) { + opc->v[1].p_f = func; + opc->v[0].fp = opt_p_f; + return (true); + } + if ((is_safe_procedure(s_func)) && + (c_function_required_args(s_func) == 0)) { + opc->v[1].call = cf_call(sc, car_x, s_func, 0); + opc->v[0].fp = opt_p_call; + return (true); + } + return_false(sc, car_x); +} + +/* -------- p_p -------- */ +static s7_pointer opt_p_p_c(opt_info * o) +{ + return (o->v[2].p_p_f(opt_sc(o), o->v[1].p)); +} + +static s7_pointer opt_p_i_c(opt_info * o) +{ + return (make_integer(opt_sc(o), o->v[2].i_i_f(o->v[1].i))); +} + +static s7_pointer opt_p_7i_c(opt_info * o) +{ + return (make_integer(opt_sc(o), o->v[2].i_7i_f(opt_sc(o), o->v[1].i))); +} + +static s7_pointer opt_p_d_c(opt_info * o) +{ + return (make_real(opt_sc(o), o->v[2].d_d_f(o->v[1].x))); +} + +static s7_pointer opt_p_7d_c(opt_info * o) +{ + return (make_real(opt_sc(o), o->v[2].d_7d_f(opt_sc(o), o->v[1].x))); +} + +static s7_pointer opt_p_p_s(opt_info * o) +{ + return (o->v[2].p_p_f(opt_sc(o), slot_value(o->v[1].p))); +} + +static s7_pointer opt_p_p_s_abs(opt_info * o) +{ + return (abs_p_p(opt_sc(o), slot_value(o->v[1].p))); +} + +static s7_pointer opt_p_p_s_cdr(opt_info * o) +{ + s7_pointer p = slot_value(o->v[1].p); + return ((is_pair(p)) ? cdr(p) : cdr_p_p(opt_sc(o), p)); +} + +static s7_pointer opt_p_p_s_iterate(opt_info * o) +{ + return (iterate_p_p(opt_sc(o), slot_value(o->v[1].p))); +} + +static s7_pointer opt_p_p_f(opt_info * o) +{ + return (o->v[2].p_p_f(opt_sc(o), o->v[4].fp(o->v[3].o1))); +} + +static s7_pointer opt_p_p_f1(opt_info * o) +{ + return (o->v[2].p_p_f(opt_sc(o), + o->v[3].p_p_f(opt_sc(o), + slot_value(o->v[1].p)))); +} + +static s7_pointer opt_p_7d_c_random(opt_info * o) +{ + return (make_real(opt_sc(o), random_d_7d(opt_sc(o), o->v[1].x))); +} + +static s7_pointer opt_p_p_f_exp(opt_info * o) +{ + return (exp_p_p(opt_sc(o), o->v[4].fp(o->v[3].o1))); +} + +static bool p_p_f_combinable(s7_scheme * sc, opt_info * opc) +{ + if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { + opt_info *o1 = sc->opts[sc->pc - 1]; + if (o1->v[0].fp == opt_p_p_s) { + opc->v[3].p_p_f = o1->v[2].p_p_f; + opc->v[1].p = o1->v[1].p; + opc->v[0].fp = opt_p_p_f1; + backup_pc(sc); + return (true); + } + } + return_false(sc, NULL); +} + +static s7_pointer opt_p_call_f(opt_info * o) +{ + return (o->v[2].call(opt_sc(o), + set_plist_1(opt_sc(o), o->v[5].fp(o->v[4].o1)))); +} + +static s7_pointer opt_p_call_s(opt_info * o) +{ + return (o->v[2].call(opt_sc(o), + set_plist_1(opt_sc(o), slot_value(o->v[1].p)))); +} + +static s7_pointer opt_p_call_c(opt_info * o) +{ + return (o->v[2].call(opt_sc(o), set_plist_1(opt_sc(o), o->v[1].p))); +} + +static bool p_p_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_p_p_t ppf; + int32_t start = sc->pc; + if (is_t_integer(cadr(car_x))) { + s7_i_i_t iif; + s7_i_7i_t i7if; + opc->v[1].i = integer(cadr(car_x)); + iif = s7_i_i_function(s_func); + if (iif) { + opc->v[2].i_i_f = iif; + opc->v[0].fp = opt_p_i_c; + return (true); + } + i7if = s7_i_7i_function(s_func); + if (i7if) { + opc->v[2].i_7i_f = i7if; + opc->v[0].fp = opt_p_7i_c; + return (true); + } + } + if (is_t_real(cadr(car_x))) { + s7_d_d_t ddf; + s7_d_7d_t d7df; + opc->v[1].x = real(cadr(car_x)); + ddf = s7_d_d_function(s_func); + if (ddf) { + opc->v[2].d_d_f = ddf; + opc->v[0].fp = opt_p_d_c; + return (true); + } + d7df = s7_d_7d_function(s_func); + if (d7df) { + opc->v[2].d_7d_f = d7df; + opc->v[0].fp = + (d7df == random_d_7d) ? opt_p_7d_c_random : opt_p_7d_c; + return (true); + } + } + ppf = s7_p_p_function(s_func); + if (ppf) { + opt_info *o1; + opc->v[2].p_p_f = ppf; + if ((ppf == symbol_to_string_p_p) && + (is_optimized(car_x)) && + (fn_proc(car_x) == g_symbol_to_string_uncopied)) + opc->v[2].p_p_f = symbol_to_string_uncopied_p; + + if (is_symbol(cadr(car_x))) { + opc->v[1].p = opt_simple_symbol(sc, cadr(car_x)); + if (!opc->v[1].p) + return_false(sc, car_x); + opc->v[0].fp = + (ppf == + abs_p_p) ? opt_p_p_s_abs : ((ppf == + cdr_p_p) ? opt_p_p_s_cdr + : ((ppf == + iterate_p_p) ? + opt_p_p_s_iterate : + opt_p_p_s)); + return (true); + } + if (!is_pair(cadr(car_x))) { + opc->v[1].p = cadr(car_x); + opc->v[0].fp = opt_p_p_c; + return (true); + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(car_x))) { + if (!p_p_f_combinable(sc, opc)) { + opc->v[0].fp = opt_p_p_f; + if (ppf == exp_p_p) + opc->v[0].fp = opt_p_p_f_exp; + else if (caadr(car_x) == sc->string_ref_symbol) { + if (opc->v[2].p_p_f == char_upcase_p_p) + opc->v[2].p_p_f = char_upcase_p_p_unchecked; + else if (opc->v[2].p_p_f == is_char_whitespace_p_p) + opc->v[2].p_p_f = is_char_whitespace_p_p_unchecked; + } + opc->v[3].o1 = o1; + opc->v[4].fp = o1->v[0].fp; + } + return (true); + } + } + pc_fallback(sc, start); + if ((is_safe_procedure(s_func)) && + (c_function_required_args(s_func) <= 1) && + (c_function_all_args(s_func) >= 1)) { + s7_pointer slot; + opc->v[2].call = cf_call(sc, car_x, s_func, 1); + if (is_symbol(cadr(car_x))) { + slot = opt_simple_symbol(sc, cadr(car_x)); + if (slot) { + opc->v[1].p = slot; + opc->v[0].fp = opt_p_call_s; + return (true); + } + } else { + opt_info *o1; + if (!is_pair(cadr(car_x))) { + opc->v[1].p = cadr(car_x); + opc->v[0].fp = opt_p_call_c; + return (true); + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(car_x))) { + opc->v[0].fp = opt_p_call_f; + opc->v[4].o1 = o1; + opc->v[5].fp = o1->v[0].fp; + return (true); + } + } + } + return_false(sc, car_x); +} + +/* -------- p_i -------- */ +static s7_pointer opt_p_i_s(opt_info * o) +{ + return (o->v[2].p_i_f(opt_sc(o), integer(slot_value(o->v[1].p)))); +} + +static s7_pointer opt_p_i_f(opt_info * o) +{ + return (o->v[2].p_i_f(opt_sc(o), o->v[4].fi(o->v[3].o1))); +} + +static s7_pointer opt_p_i_f_intc(opt_info * o) +{ + return (integer_to_char_p_i(opt_sc(o), o->v[4].fi(o->v[3].o1))); +} + +static bool p_i_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x, int32_t pstart) +{ + s7_pointer p; + s7_p_i_t ifunc; + ifunc = s7_p_i_function(s_func); + if (!ifunc) + return_false(sc, car_x); + p = opt_integer_symbol(sc, cadr(car_x)); + if (p) { + opc->v[1].p = p; + opc->v[2].p_i_f = ifunc; + opc->v[0].fp = opt_p_i_s; + return (true); + } + if (int_optimize(sc, cdr(car_x))) { + opc->v[2].p_i_f = ifunc; + opc->v[0].fp = + (ifunc == integer_to_char_p_i) ? opt_p_i_f_intc : opt_p_i_f; + opc->v[3].o1 = sc->opts[pstart]; + opc->v[4].fi = sc->opts[pstart]->v[0].fi; + return (true); + } + pc_fallback(sc, pstart); + return_false(sc, car_x); +} + +/* -------- p_ii -------- */ +static s7_pointer opt_p_ii_ss(opt_info * o) +{ + return (o->v[3].p_ii_f(opt_sc(o), integer(slot_value(o->v[1].p)), + integer(slot_value(o->v[2].p)))); +} + +static s7_pointer opt_p_ii_fs(opt_info * o) +{ + return (o->v[3].p_ii_f(opt_sc(o), o->v[11].fi(o->v[10].o1), + integer(slot_value(o->v[2].p)))); +} + +static s7_pointer opt_p_ii_ff_divide(opt_info * o) +{ + return (s7_make_ratio + (opt_sc(o), o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1))); +} + +static s7_pointer opt_p_ii_ff(opt_info * o) +{ + s7_int i1; + i1 = o->v[11].fi(o->v[10].o1); + return (o->v[3].p_ii_f(opt_sc(o), i1, o->v[9].fi(o->v[8].o1))); +} + +static bool p_ii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x, int32_t pstart) +{ + s7_pointer p2; + s7_p_ii_t ifunc; + ifunc = s7_p_ii_function(s_func); + if (!ifunc) + return_false(sc, car_x); + p2 = opt_integer_symbol(sc, caddr(car_x)); + if (p2) { + s7_pointer p1; + p1 = opt_integer_symbol(sc, cadr(car_x)); + if (p1) { + opc->v[1].p = p1; + opc->v[2].p = p2; + opc->v[3].p_ii_f = ifunc; + opc->v[0].fp = opt_p_ii_ss; + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[2].p = p2; + opc->v[3].p_ii_f = ifunc; + opc->v[0].fp = opt_p_ii_fs; + return (true); + } + pc_fallback(sc, pstart); + return_false(sc, car_x); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[3].p_ii_f = ifunc; + opc->v[0].fp = + (ifunc == divide_p_ii) ? opt_p_ii_ff_divide : opt_p_ii_ff; + return (true); + } + } + pc_fallback(sc, pstart); + return_false(sc, car_x); + +} + +/* -------- p_d -------- */ +static s7_pointer opt_p_d_s(opt_info * o) +{ + return (o->v[2].p_d_f(opt_sc(o), + real_to_double(opt_sc(o), slot_value(o->v[1].p), + "p_d"))); +} + +static s7_pointer opt_p_d_f(opt_info * o) +{ + return (o->v[2].p_d_f(opt_sc(o), o->v[4].fd(o->v[3].o1))); +} + +static bool p_d_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x, int32_t pstart) +{ + s7_pointer p; + opt_info *o1; + s7_p_d_t ifunc; + ifunc = s7_p_d_function(s_func); + if (!ifunc) + return_false(sc, car_x); + p = opt_float_symbol(sc, cadr(car_x)); + if (p) { + opc->v[1].p = p; + opc->v[2].p_d_f = ifunc; + opc->v[0].fp = opt_p_d_s; + return (true); + } + if ((is_number(cadr(car_x))) && (!is_t_real(cadr(car_x)))) + return_false(sc, car_x); + o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(car_x))) { + opc->v[2].p_d_f = ifunc; + opc->v[0].fp = opt_p_d_f; + opc->v[3].o1 = o1; + opc->v[4].fd = o1->v[0].fd; + return (true); + } + pc_fallback(sc, pstart); + return_false(sc, car_x); +} + +/* -------- p_dd -------- */ +static s7_pointer opt_p_dd_sc(opt_info * o) +{ + return (o->v[3].p_dd_f(opt_sc(o), + real_to_double(opt_sc(o), slot_value(o->v[1].p), + "p_dd"), o->v[2].x)); +} + +static s7_pointer opt_p_dd_cs(opt_info * o) +{ + return (o->v[3].p_dd_f(opt_sc(o), o->v[2].x, + real_to_double(opt_sc(o), slot_value(o->v[1].p), + "p_dd"))); +} + +static s7_pointer opt_p_dd_cc(opt_info * o) +{ + return (o->v[3].p_dd_f(opt_sc(o), o->v[1].x, o->v[2].x)); +} + +static bool p_dd_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x, int32_t pstart) +{ + s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); + s7_p_dd_t ifunc; + ifunc = s7_p_dd_function(s_func); + if (!ifunc) + return_false(sc, car_x); + if (is_t_real(arg2)) { + if (is_t_real(arg1)) { + opc->v[1].x = real(arg1); + opc->v[2].x = real(arg2); + opc->v[3].p_dd_f = ifunc; + opc->v[0].fp = opt_p_dd_cc; + return (true); + } + slot = opt_real_symbol(sc, arg1); + if (slot) { + opc->v[2].x = real(arg2); + opc->v[1].p = slot; + opc->v[3].p_dd_f = ifunc; + opc->v[0].fp = opt_p_dd_sc; + return (true); + } + } + if (is_t_real(arg1)) { + slot = opt_real_symbol(sc, arg2); + if (slot) { + opc->v[2].x = real(arg1); + opc->v[1].p = slot; + opc->v[3].p_dd_f = ifunc; + opc->v[0].fp = opt_p_dd_cs; + return (true); + } + } + pc_fallback(sc, pstart); + return_false(sc, car_x); +} + +/* -------- p_pi -------- */ +static s7_pointer opt_p_pi_ss(opt_info * o) +{ + return (o->v[3].p_pi_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)))); +} + +static s7_pointer opt_p_pi_ss_sref(opt_info * o) +{ + return (string_ref_p_pi_unchecked + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)))); +} + +static s7_pointer opt_p_pi_ss_vref(opt_info * o) +{ + return (normal_vector_ref_p_pi_unchecked + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)))); +} + +static s7_pointer opt_p_pi_ss_lref(opt_info * o) +{ + return (list_ref_p_pi_unchecked + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)))); +} + +static s7_pointer opt_p_pi_sc(opt_info * o) +{ + return (o->v[3].p_pi_f(opt_sc(o), slot_value(o->v[1].p), o->v[2].i)); +} + +static s7_pointer opt_p_pi_sc_lref(opt_info * o) +{ + return (list_ref_p_pi_unchecked + (opt_sc(o), slot_value(o->v[1].p), o->v[2].i)); +} + +static s7_pointer opt_p_pi_sf(opt_info * o) +{ + return (o->v[3].p_pi_f(opt_sc(o), slot_value(o->v[1].p), + o->v[5].fi(o->v[4].o1))); +} + +static s7_pointer opt_p_pi_sf_sref(opt_info * o) +{ + return (string_ref_p_pi_unchecked + (opt_sc(o), slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1))); +} + +static s7_pointer opt_p_pi_fc(opt_info * o) +{ + return (o->v[3].p_pi_f(opt_sc(o), o->v[5].fp(o->v[4].o1), o->v[2].i)); +} + +/* use a unique name for this use of denominator (need to remember that any such integer should be new (i.e. mutable, not a small int) */ +#define do_loop_end(A) denominator(T_Int(A)) +#define set_do_loop_end(A, B) denominator(T_Int(A)) = B + +static void check_unchecked(s7_scheme * sc, s7_pointer obj, + s7_pointer slot, opt_info * opc, + s7_pointer expr) +{ + switch (type(obj)) { /* can't use funcs here (opc->v[3].p_pi_f et al) because there are so many, and copy depends on this choice */ + case T_STRING: + if (((!expr) || (car(expr) == sc->string_ref_symbol)) + && (do_loop_end(slot_value(slot)) <= string_length(obj))) + opc->v[3].p_pi_f = string_ref_unchecked; + break; + case T_BYTE_VECTOR: + if (((!expr) || (car(expr) == sc->byte_vector_ref_symbol) + || (car(expr) == sc->vector_ref_symbol)) + && (do_loop_end(slot_value(slot)) <= byte_vector_length(obj))) + opc->v[3].p_pi_f = byte_vector_ref_unchecked_p; + break; + case T_VECTOR: + if (((!expr) || (car(expr) == sc->vector_ref_symbol)) + && (do_loop_end(slot_value(slot)) <= vector_length(obj))) + opc->v[3].p_pi_f = vector_ref_unchecked; + break; + case T_FLOAT_VECTOR: + if (((!expr) || (car(expr) == sc->float_vector_ref_symbol) + || (car(expr) == sc->vector_ref_symbol)) + && (do_loop_end(slot_value(slot)) <= vector_length(obj))) + opc->v[3].p_pi_f = float_vector_ref_unchecked_p; + break; + case T_INT_VECTOR: + if (((!expr) || (car(expr) == sc->int_vector_ref_symbol) + || (car(expr) == sc->vector_ref_symbol)) + && (do_loop_end(slot_value(slot)) <= vector_length(obj))) + opc->v[3].p_pi_f = int_vector_ref_unchecked_p; + break; + } +} + +static bool p_pi_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer sig, s7_pointer car_x) +{ + s7_pointer obj = NULL, slot1, checker = NULL; + opt_info *o1; + s7_p_pi_t func; + func = s7_p_pi_function(s_func); + if (!func) + return_false(sc, car_x); + /* here we know cadr is a symbol */ + slot1 = opt_simple_symbol(sc, cadr(car_x)); + if (!slot1) + return_false(sc, car_x); + if ((is_any_vector(slot_value(slot1))) && + (vector_rank(slot_value(slot1)) > 1)) + return_false(sc, car_x); + + opc->v[3].p_pi_f = func; + opc->v[1].p = slot1; + + if (is_symbol(cadr(sig))) + checker = cadr(sig); + + if ((s7_p_pi_unchecked_function(s_func)) && (checker)) { + obj = slot_value(opc->v[1].p); + if ((is_string(obj)) || (is_pair(obj)) || (is_any_vector(obj))) { + if (((is_string(obj)) && (checker == sc->is_string_symbol)) || + ((is_any_vector(obj)) && (checker == sc->is_vector_symbol)) + || ((is_pair(obj)) && (checker == sc->is_pair_symbol)) + || ((is_byte_vector(obj)) + && (checker == sc->is_byte_vector_symbol))) + opc->v[3].p_pi_f = + (is_normal_vector(obj)) ? + normal_vector_ref_p_pi_unchecked : + s7_p_pi_unchecked_function(s_func); + } + } + slot1 = opt_integer_symbol(sc, caddr(car_x)); + if (slot1) { + opc->v[0].fp = + (opc->v[3].p_pi_f == + string_ref_p_pi_unchecked) ? opt_p_pi_ss_sref : ((opc-> + v[3].p_pi_f + == + normal_vector_ref_p_pi_unchecked) + ? + opt_p_pi_ss_vref + : ((opc->v + [3].p_pi_f + == + list_ref_p_pi_unchecked) + ? + opt_p_pi_ss_lref + : + opt_p_pi_ss)); + opc->v[2].p = slot1; + if ((obj) && (is_step_end(slot1))) + check_unchecked(sc, obj, slot1, opc, car_x); + return (true); + } + if (is_t_integer(caddr(car_x))) { + opc->v[2].i = integer(caddr(car_x)); + opc->v[0].fp = + (opc->v[3].p_pi_f == + list_ref_p_pi_unchecked) ? opt_p_pi_sc_lref : opt_p_pi_sc; + return (true); + } + o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[0].fp = + (opc->v[3].p_pi_f == + string_ref_p_pi_unchecked) ? opt_p_pi_sf_sref : opt_p_pi_sf; + opc->v[4].o1 = o1; + opc->v[5].fi = o1->v[0].fi; + return (true); + } + return_false(sc, car_x); +} + +static s7_pointer opt_p_pi_fco(opt_info * o) +{ + return (o->v[3].p_pi_f(opt_sc(o), + o->v[4].p_p_f(opt_sc(o), slot_value(o->v[1].p)), + o->v[2].i)); +} + +static bool p_pi_fc_combinable(s7_scheme * sc, opt_info * opc) +{ + if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { + opt_info *o1 = sc->opts[sc->pc - 1]; + if (o1->v[0].fp == opt_p_p_s) { + opc->v[4].p_p_f = o1->v[2].p_p_f; + opc->v[1].p = o1->v[1].p; + opc->v[0].fp = opt_p_pi_fco; + backup_pc(sc); + return (true); + } + } + return_false(sc, NULL); +} + +/* -------- p_pp -------- */ +static s7_pointer opt_p_pp_ss(opt_info * o) +{ + return (o->v[3].p_pp_f(opt_sc(o), slot_value(o->v[1].p), + slot_value(o->v[2].p))); +} + +static s7_pointer opt_p_pp_sc(opt_info * o) +{ + return (o->v[3].p_pp_f(opt_sc(o), slot_value(o->v[1].p), o->v[2].p)); +} + +static s7_pointer opt_p_pp_cs(opt_info * o) +{ + return (o->v[3].p_pp_f(opt_sc(o), o->v[2].p, slot_value(o->v[1].p))); +} + +static s7_pointer opt_p_pp_sf(opt_info * o) +{ + return (o->v[3].p_pp_f(opt_sc(o), slot_value(o->v[1].p), + o->v[5].fp(o->v[4].o1))); +} + +static s7_pointer opt_p_pp_fs(opt_info * o) +{ + return (o->v[3].p_pp_f(opt_sc(o), o->v[5].fp(o->v[4].o1), + slot_value(o->v[1].p))); +} + +static s7_pointer opt_p_pp_fc(opt_info * o) +{ + return (o->v[3].p_pp_f(opt_sc(o), o->v[5].fp(o->v[4].o1), o->v[2].p)); +} + +static s7_pointer opt_p_pp_cc(opt_info * o) +{ + return (o->v[3].p_pp_f(opt_sc(o), o->v[1].p, o->v[2].p)); +} + +static s7_pointer opt_set_car_pp_ss(opt_info * o) +{ + return (inline_set_car + (opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p))); +} + +static s7_pointer opt_p_pp_sf_add(opt_info * o) +{ + return (add_p_pp + (opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1))); +} + +static s7_pointer opt_p_pp_sf_sub(opt_info * o) +{ + return (subtract_p_pp + (opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1))); +} + +static s7_pointer opt_p_pp_sf_set_car(opt_info * o) +{ + return (inline_set_car + (opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1))); +} + +static s7_pointer opt_p_pp_sf_set_cdr(opt_info * o) +{ + return (inline_set_cdr + (opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1))); +} + +static s7_pointer opt_p_pp_sf_href(opt_info * o) +{ + return (s7_hash_table_ref + (opt_sc(o), slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1))); +} + +static s7_pointer opt_p_pp_fs_vref(opt_info * o) +{ + return (vector_ref_p_pp + (opt_sc(o), o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p))); +} + +static s7_pointer opt_p_pp_fs_cons(opt_info * o) +{ + return (cons + (opt_sc(o), o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p))); +} + +static s7_pointer opt_p_pp_ff(opt_info * o) +{ + s7_pointer p1; + p1 = o->v[11].fp(o->v[10].o1); + opt_sc(o)->temp2 = p1; /* feeble GC protection */ + return (o->v[3].p_pp_f(opt_sc(o), p1, o->v[9].fp(o->v[8].o1))); +} + +static bool p_pp_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x, int32_t pstart) +{ + s7_pointer slot; + s7_p_pp_t func; + func = s7_p_pp_function(s_func); + if (!func) + return_false(sc, car_x); + + opc->v[3].p_pp_f = func; + if (is_symbol(cadr(car_x))) { + slot = opt_simple_symbol(sc, cadr(car_x)); + if (!slot) { + pc_fallback(sc, pstart); + return_false(sc, car_x); + } + if ((is_any_vector(slot_value(slot))) && + (vector_rank(slot_value(slot)) > 1)) { + pc_fallback(sc, pstart); + return_false(sc, car_x); + } + opc->v[1].p = slot; + + if ((func == hash_table_ref_p_pp) + && (is_hash_table(slot_value(slot)))) + opc->v[3].p_pp_f = s7_hash_table_ref; + + if (is_symbol(caddr(car_x))) { + opc->v[2].p = opt_simple_symbol(sc, caddr(car_x)); + if (opc->v[2].p) { + opc->v[0].fp = + (func == + set_car_p_pp) ? opt_set_car_pp_ss : opt_p_pp_ss; + return (true); + } + pc_fallback(sc, pstart); + return_false(sc, car_x); + } + if ((!is_pair(caddr(car_x))) || + (is_proper_quote(sc, caddr(car_x)))) { + opc->v[2].p = + (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); + opc->v[0].fp = opt_p_pp_sc; + return (true); + } + if (cell_optimize(sc, cddr(car_x))) { + opc->v[0].fp = + (func == + add_p_pp) ? opt_p_pp_sf_add : ((func == + subtract_p_pp) ? + opt_p_pp_sf_sub + : ((func == + set_car_p_pp) ? + opt_p_pp_sf_set_car + : ((func == + set_cdr_p_pp) ? + opt_p_pp_sf_set_cdr + : ((opc-> + v[3].p_pp_f == + s7_hash_table_ref) + ? opt_p_pp_sf_href + : opt_p_pp_sf)))); + opc->v[4].o1 = sc->opts[pstart]; + opc->v[5].fp = sc->opts[pstart]->v[0].fp; + return (true); + } + } else { + opt_info *o1 = sc->opts[sc->pc]; + if ((!is_pair(cadr(car_x))) || (is_proper_quote(sc, cadr(car_x)))) { + opc->v[1].p = + (!is_pair(cadr(car_x))) ? cadr(car_x) : cadadr(car_x); + if ((!is_symbol(caddr(car_x))) + && ((!is_pair(caddr(car_x))) + || (is_proper_quote(sc, caddr(car_x))))) { + opc->v[2].p = + (!is_pair(caddr(car_x))) ? caddr(car_x) : + cadaddr(car_x); + opc->v[0].fp = opt_p_pp_cc; + return (true); + } + if (is_symbol(caddr(car_x))) { + opc->v[2].p = opc->v[1].p; + opc->v[1].p = opt_simple_symbol(sc, caddr(car_x)); + if (opc->v[1].p) { + opc->v[0].fp = opt_p_pp_cs; + return (true); + } + pc_fallback(sc, pstart); + return_false(sc, car_x); + } + } + if (cell_optimize(sc, cdr(car_x))) { + if (is_symbol(caddr(car_x))) { + opc->v[1].p = opt_simple_symbol(sc, caddr(car_x)); + if (opc->v[1].p) { + opc->v[0].fp = + (func == + vector_ref_p_pp) ? opt_p_pp_fs_vref : ((func == + cons_p_pp) + ? + opt_p_pp_fs_cons + : + opt_p_pp_fs); + opc->v[4].o1 = o1; + opc->v[5].fp = o1->v[0].fp; + return (true); + } + pc_fallback(sc, pstart); + return_false(sc, car_x); + } + if ((!is_pair(caddr(car_x))) || + (is_proper_quote(sc, caddr(car_x)))) { + if (is_t_integer(caddr(car_x))) { + s7_p_pi_t ifunc; + ifunc = s7_p_pi_function(s_func); + if (ifunc) { + opc->v[2].i = integer(caddr(car_x)); + opc->v[3].p_pi_f = ifunc; + if (!p_pi_fc_combinable(sc, opc)) { + opc->v[0].fp = opt_p_pi_fc; + opc->v[4].o1 = o1; + opc->v[5].fp = o1->v[0].fp; + } + return (true); + } + } + opc->v[2].p = + (!is_pair(caddr(car_x))) ? caddr(car_x) : + cadaddr(car_x); + opc->v[0].fp = opt_p_pp_fc; + opc->v[4].o1 = o1; + opc->v[5].fp = o1->v[0].fp; + return (true); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) { + opc->v[10].o1 = o1; + opc->v[11].fp = o1->v[0].fp; + opc->v[9].fp = opc->v[8].o1->v[0].fp; + opc->v[0].fp = opt_p_pp_ff; + return (true); + } + } + } + pc_fallback(sc, pstart); + return_false(sc, car_x); +} + +/* -------- p_call_pp -------- */ +static s7_pointer opt_p_call_ff(opt_info * o) +{ + s7_pointer po2; + s7_scheme *sc = opt_sc(o); + gc_protect_via_stack(sc, o->v[11].fp(o->v[10].o1)); + po2 = o->v[9].fp(o->v[8].o1); + po2 = o->v[3].call(sc, set_plist_2(sc, stack_protected1(sc), po2)); + unstack(sc); + return (po2); +} + +static s7_pointer opt_p_call_fs(opt_info * o) +{ + s7_pointer po1; + po1 = o->v[11].fp(o->v[10].o1); + return (o->v[3].call(opt_sc(o), + set_plist_2(opt_sc(o), po1, + slot_value(o->v[1].p)))); +} + +static s7_pointer opt_p_call_sf(opt_info * o) +{ + s7_pointer po1; + po1 = o->v[11].fp(o->v[10].o1); + return (o->v[3].call(opt_sc(o), + set_plist_2(opt_sc(o), slot_value(o->v[1].p), + po1))); +} + +static s7_pointer opt_p_call_sc(opt_info * o) +{ + return (o->v[3].call(opt_sc(o), + set_plist_2(opt_sc(o), slot_value(o->v[1].p), + o->v[2].p))); +} + +static s7_pointer opt_p_call_ss(opt_info * o) +{ + return (o->v[3].call(opt_sc(o), + set_plist_2(opt_sc(o), slot_value(o->v[1].p), + slot_value(o->v[2].p)))); +} + +static bool p_call_pp_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x, int32_t pstart) +{ + if ((is_safe_procedure(s_func)) && + (c_function_required_args(s_func) <= 2) && + (c_function_all_args(s_func) >= 2)) { + /* if optimized, we want to use the current fn_proc (to take advantage of fixups like substring_temp), + * but those same fixups are incorrect for this context if op_safe_c_c related. + */ + opc->v[3].call = cf_call(sc, car_x, s_func, 2); + if (is_symbol(cadr(car_x))) { + opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); + if ((is_slot(opc->v[1].p)) && + (!has_methods(slot_value(opc->v[1].p)))) { + if (is_symbol(caddr(car_x))) { + opc->v[2].p = opt_simple_symbol(sc, caddr(car_x)); + if (opc->v[2].p) { + opc->v[0].fp = opt_p_call_ss; + return (true); + } + pc_fallback(sc, pstart); + return_false(sc, car_x); + } + if (!is_pair(caddr(car_x))) { + opc->v[2].p = caddr(car_x); + opc->v[0].fp = opt_p_call_sc; + return (true); + } + if (cell_optimize(sc, cddr(car_x))) { + opc->v[10].o1 = sc->opts[pstart]; + opc->v[11].fp = opc->v[10].o1->v[0].fp; + opc->v[0].fp = opt_p_call_sf; + return (true); + } + } else { + pc_fallback(sc, pstart); + return_false(sc, car_x); + } + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(car_x))) { + opc->v[11].fp = opc->v[10].o1->v[0].fp; + if (is_symbol(caddr(car_x))) { + opc->v[1].p = opt_simple_symbol(sc, caddr(car_x)); + if (opc->v[1].p) { + opc->v[0].fp = opt_p_call_fs; + return (true); + } + pc_fallback(sc, pstart); + return_false(sc, car_x); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) { + opc->v[9].fp = opc->v[8].o1->v[0].fp; + opc->v[0].fp = opt_p_call_ff; + return (true); + } + } + } + pc_fallback(sc, pstart); + return_false(sc, car_x); +} + + +/* -------- p_pip --------*/ + +static s7_pointer opt_p_pip_ssf(opt_info * o) +{ + return (o->v[3].p_pip_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + o->v[5].fp(o->v[4].o1))); +} + +static s7_pointer opt_p_pip_ssf_sset(opt_info * o) +{ + return (string_set_unchecked + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1))); +} + +static s7_pointer opt_p_pip_ssf_vset(opt_info * o) +{ + return (vector_set_p_pip_unchecked + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1))); +} + +static s7_pointer opt_p_pip_sss(opt_info * o) +{ + return (o->v[4].p_pip_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + slot_value(o->v[3].p))); +} + +static s7_pointer opt_p_pip_sss_vset(opt_info * o) +{ + return (vector_set_p_pip_unchecked + (opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), slot_value(o->v[3].p))); +} + +static s7_pointer opt_p_pip_ssc(opt_info * o) +{ + return (o->v[3].p_pip_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), o->v[4].p)); +} + +static s7_pointer opt_p_pip_c(opt_info * o) +{ + return (o->v[3].p_pip_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + o->v[5].p_p_f(opt_sc(o), o->v[4].p))); +} + +static s7_pointer opt_p_pip_sff(opt_info * o) +{ + s7_int i1; + i1 = o->v[11].fi(o->v[10].o1); + return (o->v[3].p_pip_f(opt_sc(o), slot_value(o->v[1].p), i1, + o->v[9].fp(o->v[8].o1))); +} + +static s7_pointer opt_p_pip_sff_lset(opt_info * o) +{ + s7_int i1; + i1 = o->v[11].fi(o->v[10].o1); + return (list_set_p_pip_unchecked + (opt_sc(o), slot_value(o->v[1].p), i1, + o->v[9].fp(o->v[8].o1))); +} + +static s7_pointer opt_p_pip_sso(opt_info * o) +{ + return (o->v[5].p_pip_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + o->v[6].p_pi_f(opt_sc(o), + slot_value(o->v[3].p), + integer(slot_value + (o->v[4].p))))); +} + +static s7_pointer opt_p_pip_ssf1(opt_info * o) +{ + return (o->v[3].p_pip_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + o->v[4].p_p_f(opt_sc(o), + o->v[6].fp(o->v[5].o1)))); +} + +static bool p_pip_ssf_combinable(s7_scheme * sc, opt_info * opc, + int32_t start) +{ + opt_info *o1; + if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { + o1 = sc->opts[sc->pc - 1]; + if ((o1->v[0].fp == opt_p_pi_ss) + || (o1->v[0].fp == opt_p_pi_ss_sref) + || (o1->v[0].fp == opt_p_pi_ss_vref) + || (o1->v[0].fp == opt_p_pi_ss_lref)) { + opc->v[5].p_pip_f = opc->v[3].p_pip_f; + opc->v[6].p_pi_f = o1->v[3].p_pi_f; + opc->v[3].p = o1->v[1].p; + opc->v[4].p = o1->v[2].p; + opc->v[0].fp = opt_p_pip_sso; + backup_pc(sc); + return (true); + } + if (o1->v[0].fp == opt_p_p_c) { + opc->v[5].p_p_f = o1->v[2].p_p_f; + opc->v[4].p = o1->v[1].p; + backup_pc(sc); + opc->v[0].fp = opt_p_pip_c; + return (true); + } + } + o1 = sc->opts[start]; + if (o1->v[0].fp != opt_p_p_f) + return_false(sc, NULL); + opc->v[4].p_p_f = o1->v[2].p_p_f; + opc->v[5].o1 = sc->opts[start + 1]; + opc->v[6].fp = sc->opts[start + 1]->v[0].fp; + opc->v[0].fp = opt_p_pip_ssf1; + return (true); +} + +static bool p_pip_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_p_pip_t func; + s7_pointer obj, slot1, sig, checker = NULL; + + func = s7_p_pip_function(s_func); + if (!func) + return_false(sc, car_x); + + sig = c_function_signature(s_func); + if ((is_pair(sig)) && (is_pair(cdr(sig))) && (is_symbol(cadr(sig)))) + checker = cadr(sig); + + /* here we know cadr is a symbol */ + slot1 = lookup_slot_from(cadr(car_x), sc->curlet); + if ((!is_slot(slot1)) || + (has_methods(slot_value(slot1))) || + (is_immutable(slot_value(slot1)))) + return_false(sc, car_x); + if ((is_any_vector(slot_value(slot1))) && + (vector_rank(slot_value(slot1)) > 1)) + return_false(sc, car_x); + + opc->v[1].p = slot1; + obj = slot_value(opc->v[1].p); + opc->v[3].p_pip_f = func; + if ((s7_p_pip_unchecked_function(s_func)) && (checker)) { + if ((is_normal_vector(obj)) && (checker == sc->is_vector_symbol)) + opc->v[3].p_pip_f = + (is_typed_vector(obj)) ? typed_vector_set_p_pip_unchecked : + vector_set_p_pip_unchecked; + else if ((is_pair(obj)) && (checker == sc->is_pair_symbol)) /* avoid dumb mismatch in val_type and sig below, #t integer:any? and integer? integer:any? */ + opc->v[3].p_pip_f = s7_p_pip_unchecked_function(s_func); + else { + s7_pointer val_type; + val_type = opt_arg_type(sc, cdddr(car_x)); + if ((val_type == cadddr(sig)) && + (((is_string(obj)) && (checker == sc->is_string_symbol)) || + ((is_float_vector(obj)) + && (checker == sc->is_float_vector_symbol)) + || ((is_int_vector(obj)) + && (checker == sc->is_int_vector_symbol)) + || ((is_byte_vector(obj)) + && (checker == sc->is_byte_vector_symbol)))) + opc->v[3].p_pip_f = s7_p_pip_unchecked_function(s_func); + } + } + if (is_symbol(caddr(car_x))) { + s7_pointer slot2; + int32_t start = sc->pc; + slot2 = opt_integer_symbol(sc, caddr(car_x)); + if (slot2) { + opc->v[2].p = slot2; + if (is_step_end(slot2)) + switch (type(obj)) { + case T_VECTOR: + if (do_loop_end(slot_value(slot2)) <= + vector_length(obj)) + opc->v[3].p_pip_f = + (is_typed_vector(obj)) ? + typed_vector_set_unchecked : + vector_set_unchecked; + break; + case T_INT_VECTOR: + if (do_loop_end(slot_value(slot2)) <= + vector_length(obj)) + opc->v[3].p_pip_f = int_vector_set_unchecked_p; + break; + case T_FLOAT_VECTOR: + if (do_loop_end(slot_value(slot2)) <= + vector_length(obj)) + opc->v[3].p_pip_f = float_vector_set_unchecked_p; + break; + case T_STRING: + if (do_loop_end(slot_value(slot2)) <= + string_length(obj)) + opc->v[3].p_pip_f = string_set_unchecked; + break; + case T_BYTE_VECTOR: + if (do_loop_end(slot_value(slot2)) <= + vector_length(obj)) + opc->v[3].p_pip_f = byte_vector_set_unchecked_p; + break; + } /* T_PAIR here would require list_length check which sort of defeats the purpose */ + + if (is_symbol(cadddr(car_x))) { + s7_pointer val_slot; + val_slot = opt_simple_symbol(sc, cadddr(car_x)); + if (val_slot) { + opc->v[4].p_pip_f = opc->v[3].p_pip_f; + opc->v[3].p = val_slot; + opc->v[0].fp = + (opc->v[4].p_pip_f == + vector_set_p_pip_unchecked) ? opt_p_pip_sss_vset : + opt_p_pip_sss; + return (true); + } + } else + if ((!is_pair(cadddr(car_x))) || + (is_proper_quote(sc, cadddr(car_x)))) { + opc->v[4].p = + (is_pair(cadddr(car_x))) ? cadr(cadddr(car_x)) : + cadddr(car_x); + opc->v[0].fp = opt_p_pip_ssc; + return (true); + } + if (cell_optimize(sc, cdddr(car_x))) { + if (p_pip_ssf_combinable(sc, opc, start)) + return (true); + opc->v[0].fp = + (opc->v[3].p_pip_f == + string_set_unchecked) ? opt_p_pip_ssf_sset + : ((opc->v[3].p_pip_f == vector_set_p_pip_unchecked) + ? opt_p_pip_ssf_vset : opt_p_pip_ssf); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fp = sc->opts[start]->v[0].fp; + return (true); + } + } + } else { /* not symbol caddr */ + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(car_x))) { + opc->v[0].fp = + (opc->v[3].p_pip_f == + list_set_p_pip_unchecked) ? opt_p_pip_sff_lset : + opt_p_pip_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fp = opc->v[8].o1->v[0].fp; + return (true); + } + } + } + return_false(sc, car_x); +} + +/* -------- p_piip -------- */ +static s7_pointer opt_p_piip_sssf(opt_info * o) +{ + return (o->v[5].p_piip_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p)), + o->v[11].fp(o->v[10].o1))); +} + +static s7_pointer vector_set_piip_sssf_unchecked(opt_info * o) +{ + s7_pointer val, v = slot_value(o->v[1].p); + val = o->v[11].fp(o->v[10].o1); + vector_element(v, + ((integer(slot_value(o->v[2].p)) * + vector_offset(v, + 0)) + integer(slot_value(o->v[3].p)))) = + val; + return (val); +} + +static s7_pointer opt_p_piip_sssc(opt_info * o) +{ + return (o->v[5].p_piip_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p)), o->v[4].p)); +} + +static s7_pointer opt_p_piip_sfff(opt_info * o) +{ + s7_int i1, i2; + i1 = o->v[11].fi(o->v[10].o1); + i2 = o->v[9].fi(o->v[8].o1); + return (o->v[5].p_piip_f(opt_sc(o), slot_value(o->v[1].p), i1, i2, o->v[3].fp(o->v[4].o1))); /* v[3] because v[5] is already in use */ +} + +static bool p_piip_to_sx(s7_scheme * sc, opt_info * opc, + s7_pointer indexp1, s7_pointer indexp2, + s7_pointer valp, s7_pointer obj) +{ + s7_pointer slot; + slot = opt_integer_symbol(sc, car(indexp2)); + if (!slot) + return_false(sc, indexp1); + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) { + opc->v[2].p = slot; + if ((is_symbol(car(valp))) || (is_unquoted_pair(car(valp)))) { + opc->v[10].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, valp)) + return_false(sc, indexp1); + opc->v[11].fp = opc->v[10].o1->v[0].fp; + opc->v[0].fp = opt_p_piip_sssf; + if ((is_normal_vector(obj)) && + (step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && + (step_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) + opc->v[0].fp = vector_set_piip_sssf_unchecked; + return (true); + } + opc->v[0].fp = opt_p_piip_sssc; + opc->v[4].p = (is_pair(car(valp))) ? cadar(valp) : car(valp); + return (true); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) { + opc->v[4].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, valp)) { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[3].fp = opc->v[4].o1->v[0].fp; + opc->v[0].fp = opt_p_piip_sfff; + return (true); + } + } + } + return_false(sc, indexp1); +} + +static bool p_piip_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + /* this currently assumes s_func == vector-set! because there aren't any other p_piip functions(!) */ + s7_p_piip_t func; + func = s7_p_piip_function(s_func); + if ((func) && (is_symbol(cadr(car_x)))) { + s7_pointer slot1, obj; + slot1 = lookup_slot_from(cadr(car_x), sc->curlet); + if (!is_slot(slot1)) + return_false(sc, car_x); + obj = slot_value(slot1); + if ((has_methods(obj)) || (is_immutable(obj))) + return_false(sc, car_x); + if ((is_any_vector(obj)) && /* vector_set_p_piip calls vector_setter(obj) */ + (vector_rank(obj) == 2)) { + opc->v[1].p = slot1; + opc->v[5].p_piip_f = vector_set_p_piip; + return (p_piip_to_sx + (sc, opc, cddr(car_x), cdddr(car_x), cddddr(car_x), + obj)); + } + } + return_false(sc, car_x); +} + +/* -------- p_pii -------- */ +static s7_pointer opt_p_pii_sss(opt_info * o) +{ + return (o->v[4].p_pii_f(opt_sc(o), slot_value(o->v[1].p), + integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p)))); +} + +static s7_pointer opt_p_pii_sff(opt_info * o) +{ + s7_int i1, i2; + i1 = o->v[11].fi(o->v[10].o1); + i2 = o->v[9].fi(o->v[8].o1); + return (o->v[4].p_pii_f(opt_sc(o), slot_value(o->v[1].p), i1, i2)); +} + +static s7_pointer vector_ref_pii_sss_unchecked(opt_info * o) +{ + s7_pointer v = slot_value(o->v[1].p); + return (vector_element + (v, + ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + + integer(slot_value(o->v[3].p))))); +} + +static bool p_pii_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_p_pii_t func; + func = s7_p_pii_function(s_func); + if ((func) && (is_symbol(cadr(car_x)))) { + s7_pointer slot1, obj; + slot1 = lookup_slot_from(cadr(car_x), sc->curlet); + if (!is_slot(slot1)) + return_false(sc, car_x); + obj = slot_value(slot1); + if ((has_methods(obj)) || (is_immutable(obj))) + return_false(sc, car_x); + if ((is_normal_vector(obj)) && (vector_rank(obj) == 2)) { + s7_pointer slot, indexp1 = cddr(car_x), indexp2 = cdddr(car_x); + opc->v[1].p = slot1; + opc->v[4].p_pii_f = vector_ref_p_pii; + slot = opt_integer_symbol(sc, car(indexp2)); + if (slot) { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) { + opc->v[2].p = slot; + opc->v[0].fp = opt_p_pii_sss; + /* normal vector rank 2 (see above) */ + if ((step_end_fits + (opc->v[2].p, + vector_dimension(slot_value(opc->v[1].p), 0))) + && + (step_end_fits + (opc->v[3].p, + vector_dimension(slot_value(opc->v[1].p), 1)))) + opc->v[0].fp = vector_ref_pii_sss_unchecked; + return (true); + } + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) { + opc->v[0].fp = opt_p_pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + return (true); + } + } + } + } + return_false(sc, car_x); +} + +/* -------- p_ppi -------- */ +static s7_pointer opt_p_ppi_psf(opt_info * o) +{ + return (o->v[3].p_ppi_f(opt_sc(o), o->v[2].p, slot_value(o->v[1].p), + o->v[5].fi(o->v[4].o1))); +} + +static s7_pointer opt_p_ppi_psf_cpos(opt_info * o) +{ + return (char_position_p_ppi + (opt_sc(o), o->v[2].p, slot_value(o->v[1].p), + o->v[5].fi(o->v[4].o1))); +} + +static bool p_ppi_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + int32_t start = sc->pc; + s7_p_ppi_t ifunc; + ifunc = s7_p_ppi_function(s_func); + if (!ifunc) + return_false(sc, car_x); + opc->v[3].p_ppi_f = ifunc; + if ((is_character(cadr(car_x))) && + (is_symbol(caddr(car_x))) && (int_optimize(sc, cdddr(car_x)))) { + s7_pointer slot; + slot = opt_simple_symbol(sc, caddr(car_x)); + if (slot) { + opc->v[2].p = cadr(car_x); + opc->v[1].p = slot; + opc->v[0].fp = + (ifunc == + char_position_p_ppi) ? opt_p_ppi_psf_cpos : opt_p_ppi_psf; + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fi = sc->opts[start]->v[0].fi; + return (true); + } + } + pc_fallback(sc, start); + return_false(sc, car_x); +} + +/* -------- p_ppp -------- */ +static s7_pointer opt_p_ppp_ssf(opt_info * o) +{ + return (o->v[3].p_ppp_f(opt_sc(o), slot_value(o->v[1].p), + slot_value(o->v[2].p), + o->v[5].fp(o->v[4].o1))); +} + +static s7_pointer opt_p_ppp_hash_table_increment(opt_info * o) +{ + return (fx_hash_table_increment_1 + (opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p), + o->v[5].p)); +} + +static s7_pointer opt_p_ppp_sfs(opt_info * o) +{ + return (o->v[3].p_ppp_f(opt_sc(o), slot_value(o->v[1].p), + o->v[5].fp(o->v[4].o1), + slot_value(o->v[2].p))); +} + +static s7_pointer opt_p_ppp_scs(opt_info * o) +{ + return (o->v[3].p_ppp_f(opt_sc(o), slot_value(o->v[1].p), o->v[4].p, + slot_value(o->v[2].p))); +} + +static s7_pointer opt_p_ppp_scs_eset(opt_info * o) +{ + return (let_set_1 + (opt_sc(o), slot_value(o->v[1].p), o->v[4].p, + slot_value(o->v[2].p))); +} + +static s7_pointer opt_p_ppp_sss(opt_info * o) +{ + return (o->v[4].p_ppp_f(opt_sc(o), slot_value(o->v[1].p), + slot_value(o->v[2].p), slot_value(o->v[3].p))); +} + +static s7_pointer opt_p_ppp_sss_mul(opt_info * o) +{ + return (multiply_p_ppp + (opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p), + slot_value(o->v[3].p))); +} + +static s7_pointer opt_p_ppp_sss_hset(opt_info * o) +{ + return (s7_hash_table_set + (opt_sc(o), slot_value(o->v[1].p), slot_value(o->v[2].p), + slot_value(o->v[3].p))); +} + +static s7_pointer opt_p_ppp_ssc(opt_info * o) +{ + return (o->v[3].p_ppp_f(opt_sc(o), slot_value(o->v[1].p), + slot_value(o->v[2].p), o->v[4].p)); +} + +static s7_pointer opt_p_ppp_sff(opt_info * o) +{ + s7_pointer po1; + po1 = o->v[11].fp(o->v[10].o1); + return (o->v[3].p_ppp_f(opt_sc(o), slot_value(o->v[1].p), po1, + o->v[9].fp(o->v[8].o1))); +} + +static s7_pointer opt_p_ppp_fff(opt_info * o) +{ + s7_pointer res; + s7_scheme *sc = opt_sc(o); + gc_protect_2_via_stack(sc, T_Pos(o->v[11].fp(o->v[10].o1)), + T_Pos(o->v[9].fp(o->v[8].o1))); + res = + o->v[3].p_ppp_f(sc, stack_protected1(sc), stack_protected2(sc), + o->v[5].fp(o->v[4].o1)); + unstack(sc); + return (res); +} + +static bool p_ppp_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer car_x) +{ + s7_pointer arg1 = cadr(car_x), arg2 = caddr(car_x), arg3 = + cadddr(car_x); + int32_t start = sc->pc; + s7_p_ppp_t func; + func = s7_p_ppp_function(s_func); + if (!func) + return_false(sc, car_x); + opc->v[3].p_ppp_f = func; + if (is_symbol(arg1)) { /* dealt with at the top -> p1 */ + s7_pointer slot, obj; + opt_info *o1; + + slot = lookup_slot_from(arg1, sc->curlet); + if ((!is_slot(slot)) || (has_methods(slot_value(slot)))) + return_false(sc, car_x); + + obj = slot_value(slot); + if ((is_any_vector(obj)) && (vector_rank(obj) > 1)) + return_false(sc, car_x); + + if (is_target_or_its_alias + (car(car_x), s_func, sc->hash_table_set_symbol)) { + if ((!is_hash_table(obj)) || (is_immutable(obj))) + return_false(sc, car_x); + } else + if ((is_target_or_its_alias + (car(car_x), s_func, sc->let_set_symbol)) + && ((!is_let(obj)) || (is_immutable(obj)))) + return_false(sc, car_x); + + opc->v[1].p = slot; + + if ((func == hash_table_set_p_ppp) && (is_hash_table(obj))) + opc->v[3].p_ppp_f = s7_hash_table_set; + + if (is_symbol(arg2)) { + slot = opt_simple_symbol(sc, arg2); + if (slot) { + opc->v[2].p = slot; + if (is_symbol(arg3)) { + slot = opt_simple_symbol(sc, arg3); + if (slot) { + s7_p_ppp_t func1; + func1 = opc->v[3].p_ppp_f; + opc->v[4].p_ppp_f = func1; + opc->v[3].p = slot; + opc->v[0].fp = + (func1 == + multiply_p_ppp) ? opt_p_ppp_sss_mul : ((func1 + == + s7_hash_table_set) + ? + opt_p_ppp_sss_hset + : + opt_p_ppp_sss); + return (true); + } + } else if ((!is_pair(arg3)) || (is_proper_quote(sc, arg3))) { + opc->v[4].p = (is_pair(arg3)) ? cadr(arg3) : arg3; + opc->v[0].fp = opt_p_ppp_ssc; + return (true); + } + if (optimize_op(car_x) == HOP_HASH_TABLE_INCREMENT) { + opc->v[0].fp = opt_p_ppp_hash_table_increment; + opc->v[5].p = car_x; + return (true); + } + if (cell_optimize(sc, cdddr(car_x))) { + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + opc->v[0].fp = opt_p_ppp_ssf; + return (true); + } + pc_fallback(sc, start); + } + } + if ((is_proper_quote(sc, arg2)) && (is_symbol(arg3))) { + s7_pointer val_slot; + val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) { + opc->v[4].p = cadr(arg2); + opc->v[2].p = val_slot; + opc->v[0].fp = opt_p_ppp_scs; + if (opc->v[3].p_ppp_f == s7_let_set) { + if (is_symbol(cadr(arg2))) /* checked is_let, has_methods and is_immutable above */ + opc->v[0].fp = opt_p_ppp_scs_eset; + else + return_false(sc, car_x); + } + return (true); + } + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) { + opt_info *o2 = sc->opts[sc->pc]; + if (is_symbol(arg3)) { + s7_pointer val_slot; + val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) { + opc->v[2].p = val_slot; + opc->v[0].fp = opt_p_ppp_sfs; /* hset case goes through the case below */ + opc->v[4].o1 = o1; + opc->v[5].fp = o1->v[0].fp; + return (true); + } + } + if (cell_optimize(sc, cdddr(car_x))) { + opc->v[0].fp = opt_p_ppp_sff; + opc->v[10].o1 = o1; + opc->v[11].fp = o1->v[0].fp; + opc->v[8].o1 = o2; + opc->v[9].fp = o2->v[0].fp; + return (true); + } + } + } else { + opc->v[10].o1 = sc->opts[start]; + if (cell_optimize(sc, cdr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) { + opc->v[4].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(car_x))) { + opc->v[0].fp = opt_p_ppp_fff; + opc->v[11].fp = opc->v[10].o1->v[0].fp; + opc->v[9].fp = opc->v[8].o1->v[0].fp; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + return (true); + } + } + } + } + pc_fallback(sc, start); + return_false(sc, car_x); +} + +/* -------- p_call_ppp -------- */ +static s7_pointer opt_p_call_sss(opt_info * o) +{ + return (o->v[4].call(opt_sc(o), + set_plist_3(opt_sc(o), slot_value(o->v[1].p), + slot_value(o->v[2].p), + slot_value(o->v[3].p)))); +} + +static s7_pointer opt_p_call_css(opt_info * o) +{ + return (o->v[4].call(opt_sc(o), + set_plist_3(opt_sc(o), o->v[1].p, + slot_value(o->v[2].p), + slot_value(o->v[3].p)))); +} + +static s7_pointer opt_p_call_ssf(opt_info * o) +{ + return (o->v[4].call(opt_sc(o), + set_plist_3(opt_sc(o), slot_value(o->v[1].p), + slot_value(o->v[2].p), + o->v[6].fp(o->v[5].o1)))); +} + +static s7_pointer opt_p_call_ppp(opt_info * o) +{ + s7_pointer res; + s7_scheme *sc = opt_sc(o); + gc_protect_2_via_stack(sc, o->v[4].fp(o->v[3].o1), + o->v[6].fp(o->v[5].o1)); + res = o->v[11].fp(o->v[10].o1); /* not combinable into next */ + res = + o->v[2].call(sc, + set_plist_3(sc, stack_protected1(sc), + stack_protected2(sc), res)); + unstack(sc); + return (res); +} + +static bool p_call_ppp_ok(s7_scheme * sc, opt_info * opc, + s7_pointer s_func, s7_pointer car_x) +{ + int32_t start = sc->pc; + if ((is_safe_procedure(s_func)) && + (c_function_required_args(s_func) <= 3) && + (c_function_all_args(s_func) >= 3)) { + s7_pointer slot, arg = cadr(car_x); + opt_info *o1 = sc->opts[sc->pc]; + + if (!is_pair(arg)) { + if (is_symbol(arg)) { + slot = opt_simple_symbol(sc, arg); + if (slot) + opc->v[1].p = slot; + else + return_false(sc, car_x); /* no need for pc_fallback here, I think */ + } else + opc->v[1].p = arg; + arg = caddr(car_x); + if (is_symbol(arg)) { + slot = opt_simple_symbol(sc, arg); + if (slot) { + opc->v[2].p = slot; + arg = cadddr(car_x); + if (is_symbol(arg)) { + slot = opt_simple_symbol(sc, arg); + if (slot) { + opc->v[3].p = slot; + opc->v[4].call = cf_call(sc, car_x, s_func, 3); + opc->v[0].fp = + (is_slot(opc->v[1].p)) ? opt_p_call_sss : + opt_p_call_css; + return (true); + } + } else if ((is_slot(opc->v[1].p)) + && (cell_optimize(sc, cdddr(car_x)))) { + opc->v[4].call = cf_call(sc, car_x, s_func, 3); + opc->v[0].fp = + (opc->v[4].call == + g_substring_uncopied) ? + opt_p_substring_uncopied_ssf : opt_p_call_ssf; + opc->v[5].o1 = o1; + opc->v[6].fp = o1->v[0].fp; + return (true); + } + } + } + } + if (cell_optimize(sc, cdr(car_x))) { + opt_info *o2 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) { + opt_info *o3 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(car_x))) { + opc->v[2].call = cf_call(sc, car_x, s_func, 3); + opc->v[0].fp = opt_p_call_ppp; + opc->v[3].o1 = o1; + opc->v[4].fp = o1->v[0].fp; + opc->v[5].o1 = o2; + opc->v[6].fp = o2->v[0].fp; + opc->v[10].o1 = o3; + opc->v[11].fp = o3->v[0].fp; + return (true); + } + } + } + } + pc_fallback(sc, start); + return_false(sc, car_x); +} + + +/* -------- p_call_any -------- */ +#define P_CALL_O1 3 + +static s7_pointer opt_p_call_any(opt_info * o) +{ + s7_pointer arg, val; + int32_t i; + s7_scheme *sc = opt_sc(o); + val = safe_list_if_possible(sc, o->v[1].i); + if (in_heap(val)) + gc_protect_via_stack(sc, val); + for (i = 0, arg = val; i < o->v[1].i; i++, arg = cdr(arg)) { + opt_info *o1 = o->v[i + P_CALL_O1].o1; + set_car(arg, o1->v[0].fp(o1)); + } + arg = o->v[2].call(sc, val); + if (in_heap(val)) + unstack(sc); + else + clear_list_in_use(val); + return (arg); +} + +static bool p_call_any_ok(s7_scheme * sc, opt_info * opc, + s7_pointer s_func, s7_pointer car_x, int32_t len) +{ + if ((len < (NUM_VUNIONS - P_CALL_O1)) && + (is_safe_procedure(s_func)) && + (c_function_required_args(s_func) <= (len - 1)) && + (c_function_all_args(s_func) >= (len - 1))) { + s7_pointer p; /* (vector-set! v k i 2) gets here */ + int32_t pctr; + opc->v[1].i = (len - 1); + for (pctr = P_CALL_O1, p = cdr(car_x); is_pair(p); + pctr++, p = cdr(p)) { + opc->v[pctr].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } + if (is_null(p)) { + opc->v[0].fp = opt_p_call_any; + opc->v[2].call = cf_call(sc, car_x, s_func, len - 1); + return (true); + } + } + return_false(sc, car_x); +} + + +/* -------- p_fx_any -------- */ + +static s7_pointer opt_p_fx_any(opt_info * o) +{ + return (o->v[1].call(opt_sc(o), o->v[2].p)); +} + +static bool p_fx_any_ok(s7_scheme * sc, opt_info * opc, s7_pointer s_func, + s7_pointer x) +{ + s7_function f; + f = (has_fx(x)) ? fx_proc(x) : fx_choose(sc, x, sc->curlet, + let_symbol_is_safe); + if (!f) + return_false(sc, x); + opc->v[0].fp = opt_p_fx_any; + opc->v[1].call = f; + opc->v[2].p = car(x); + return (true); +} + + +/* -------- p_implicit -------- */ + +static bool p_implicit_ok(s7_scheme * sc, s7_pointer s_slot, + s7_pointer car_x, int32_t len) +{ + s7_pointer obj = slot_value(s_slot); + opt_info *opc; + int32_t start; + + if ((!is_sequence(obj)) || (len < 2)) + return_false(sc, car_x); + + opc = alloc_opo(sc); + opc->v[1].p = s_slot; + start = sc->pc; + if (len == 2) { + switch (type(obj)) { + case T_PAIR: + opc->v[3].p_pi_f = list_ref_p_pi_unchecked; + break; + case T_HASH_TABLE: + opc->v[3].p_pp_f = s7_hash_table_ref; + break; + case T_LET: + opc->v[3].p_pp_f = s7_let_ref; + break; + case T_STRING: + opc->v[3].p_pi_f = string_ref_p_pi_unchecked; + break; + case T_C_OBJECT: + return_false(sc, car_x); /* no pi_ref because ref assumes pp */ + + case T_VECTOR: + if (vector_rank(obj) != 1) + return_false(sc, car_x); + opc->v[3].p_pi_f = normal_vector_ref_p_pi_unchecked; + break; + + case T_BYTE_VECTOR: + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + if (vector_rank(obj) != 1) + return_false(sc, car_x); + opc->v[3].p_pi_f = vector_ref_p_pi_unchecked; + break; + + default: + return_false(sc, car_x); + } + /* now v3.p_pi|pp.f is set */ + if (is_symbol(cadr(car_x))) { + s7_pointer slot; + slot = lookup_slot_from(cadr(car_x), sc->curlet); + if (is_slot(slot)) { + opc->v[2].p = slot; + if ((!is_hash_table(obj)) && /* these because opt_int below */ + (!is_let(obj))) { + if (!is_t_integer(slot_value(slot))) + return_false(sc, car_x); /* I think this reflects that a non-int index is an error for list-ref et al */ + opc->v[0].fp = opt_p_pi_ss; + if (is_step_end(opc->v[2].p)) + check_unchecked(sc, obj, opc->v[2].p, opc, NULL); + return (true); + } + opc->v[0].fp = opt_p_pp_ss; + return (true); + } + } else { + if ((!is_hash_table(obj)) && (!is_let(obj))) { + opt_info *o1; + if (is_t_integer(cadr(car_x))) { + opc->v[2].i = integer(cadr(car_x)); + opc->v[0].fp = opt_p_pi_sc; + return (true); + } + o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(car_x))) + return_false(sc, car_x); + opc->v[0].fp = opt_p_pi_sf; + opc->v[4].o1 = o1; + opc->v[5].fi = o1->v[0].fi; + return (true); + } + if (cell_optimize(sc, cdr(car_x))) { + opc->v[0].fp = opt_p_pp_sf; + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fp = sc->opts[start]->v[0].fp; + return (true); + } + } + } /* len==2 */ + else { /* len > 2 */ + if ((is_normal_vector(obj)) && (len == 3) + && (vector_rank(obj) == 2)) { + s7_pointer slot; + slot = opt_integer_symbol(sc, caddr(car_x)); + if (slot) { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) { + opc->v[2].p = slot; + opc->v[4].p_pii_f = vector_ref_p_pii; + opc->v[0].fp = opt_p_pii_sss; + if ((step_end_fits + (opc->v[2].p, vector_dimension(obj, 0))) + && + (step_end_fits + (opc->v[3].p, vector_dimension(obj, 1)))) + opc->v[0].fp = vector_ref_pii_sss_unchecked; + return (true); + } + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) { + opc->v[0].fp = opt_p_pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + /* opc->v[1].p set above */ + opc->v[4].p_pii_f = vector_ref_p_pii_direct; + return (true); + } + } + pc_fallback(sc, start); + } + + if (len < (NUM_VUNIONS - 4)) { /* mimic p_call_any_ok */ + int32_t pctr; + s7_pointer p; + opc->v[1].i = len; + for (pctr = 3, p = car_x; is_pair(p); pctr++, p = cdr(p)) { + opc->v[pctr].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } + if (is_null(p)) { + /* todo??: here we know the vector rank/type, probably can handle the new value type, and maybe indices/dimensions, + * so at least forgo the vec type/rank + immutable checks, the *_set cases are from p_call_any_ok called in cell_optimize + */ + opc->v[0].fp = opt_p_call_any; + switch (type(obj)) { /* string can't happen here (no multidimensional strings) */ + case T_PAIR: + opc->v[2].call = g_list_ref; + break; + case T_HASH_TABLE: + opc->v[2].call = g_hash_table_ref; + break; + /* case T_LET: opc->v[2].call = g_let_ref; break; *//* this doesn't handle implicit indices via g_let_ref! apply_let */ + case T_INT_VECTOR: + opc->v[2].call = g_int_vector_ref; + break; + case T_BYTE_VECTOR: + opc->v[2].call = g_byte_vector_ref; + break; + case T_FLOAT_VECTOR: + opc->v[2].call = g_float_vector_ref; + break; + case T_VECTOR: + opc->v[2].call = g_vector_ref; + break; + default: + return_false(sc, car_x); + } + return (true); + } + } + } + return_false(sc, car_x); +} + +/* -------- cell_quote -------- */ +static bool opt_cell_quote(s7_scheme * sc, s7_pointer car_x) +{ + opt_info *opc; + if (!is_null(cddr(car_x))) + return_false(sc, car_x); + opc = alloc_opo(sc); + opc->v[1].p = cadr(car_x); + opc->v[0].fp = opt_p_c; + return (true); +} + +/* -------- cell_set -------- */ +static s7_pointer opt_set_p_p_f(opt_info * o) +{ + s7_pointer x; + x = o->v[4].fp(o->v[3].o1); + slot_set_value(o->v[1].p, x); + return (x); +} + +static s7_pointer opt_set_p_i_s(opt_info * o) +{ + s7_pointer val = slot_value(o->v[2].p); + if (is_mutable_integer(val)) + val = make_integer(opt_sc(o), integer(val)); + slot_set_value(o->v[1].p, val); + return (val); +} + +static s7_pointer opt_set_p_i_f(opt_info * o) +{ + s7_pointer x; + x = make_integer(opt_sc(o), o->v[6].fi(o->v[5].o1)); + slot_set_value(o->v[1].p, x); + return (x); +} + +static s7_pointer opt_set_p_d_s(opt_info * o) +{ + s7_pointer val = slot_value(o->v[2].p); + if (is_mutable_number(val)) + val = make_real(opt_sc(o), real(val)); + slot_set_value(o->v[1].p, val); + return (val); +} + +static s7_pointer opt_set_p_d_f(opt_info * o) +{ + s7_pointer x; + x = make_real(opt_sc(o), o->v[5].fd(o->v[4].o1)); + slot_set_value(o->v[1].p, x); + return (x); +} + +static s7_pointer opt_set_p_d_f_sf_add(opt_info * o) +{ + s7_pointer x; + x = make_real(opt_sc(o), opt_d_dd_sf_add(o->v[4].o1)); + slot_set_value(o->v[1].p, x); + return (x); +} + +static s7_pointer opt_set_p_d_f_mm_add(opt_info * o) +{ + s7_double x1, x2; + x1 = float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[4].p), + integer(slot_value(o->v[5].p))) * + real(slot_value(o->v[3].p)); + x2 = float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[10].p), + integer(slot_value(o->v[11].p))) * + real(slot_value(o->v[9].p)); + slot_set_value(o->v[1].p, make_real(opt_sc(o), x1 + x2)); + return (slot_value(o->v[1].p)); +} + +static s7_pointer opt_set_p_d_f_mm_subtract(opt_info * o) +{ + s7_double x1, x2; + x1 = float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[4].p), + integer(slot_value(o->v[5].p))) * + real(slot_value(o->v[3].p)); + x2 = float_vector_ref_d_7pi(opt_sc(o), slot_value(o->v[10].p), + integer(slot_value(o->v[11].p))) * + real(slot_value(o->v[9].p)); + slot_set_value(o->v[1].p, make_real(opt_sc(o), x1 - x2)); + return (slot_value(o->v[1].p)); +} + +static s7_pointer opt_set_p_c(opt_info * o) +{ + slot_set_value(o->v[1].p, o->v[2].p); + return (o->v[2].p); +} + +static s7_pointer opt_set_p_i_fo(opt_info * o) +{ + s7_pointer x; + s7_int i; + i = o->v[4].i_ii_f(integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[3].p))); + x = make_integer(opt_sc(o), i); + slot_set_value(o->v[1].p, x); + return (x); +} + +static s7_pointer opt_set_p_i_fo_add(opt_info * o) +{ + s7_pointer x; + s7_int i; + i = integer(slot_value(o->v[2].p)) + integer(slot_value(o->v[3].p)); + x = make_integer(opt_sc(o), i); + slot_set_value(o->v[1].p, x); + return (x); +} + +static s7_pointer opt_set_p_i_fo1(opt_info * o) +{ + s7_pointer x; + s7_int i; + i = o->v[4].i_ii_f(integer(slot_value(o->v[2].p)), o->v[3].i); + x = make_integer(opt_sc(o), i); + slot_set_value(o->v[1].p, x); + return (x); +} + +static s7_pointer opt_set_p_i_fo1_add(opt_info * o) +{ + s7_pointer x; + s7_int i; + i = integer(slot_value(o->v[2].p)) + o->v[3].i; + x = make_integer(opt_sc(o), i); + slot_set_value(o->v[1].p, x); + return (x); +} + +static bool set_p_i_f_combinable(s7_scheme * sc, opt_info * opc) +{ + if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { + opt_info *o1 = sc->opts[sc->pc - 1]; + if ((o1->v[0].fi == opt_i_ii_ss) || + (o1->v[0].fi == opt_i_ii_ss_add)) { + opc->v[4].i_ii_f = o1->v[3].i_ii_f; + opc->v[2].p = o1->v[1].p; + opc->v[3].p = o1->v[2].p; + opc->v[0].fp = + (o1->v[0].fi == + opt_i_ii_ss_add) ? opt_set_p_i_fo_add : opt_set_p_i_fo; + backup_pc(sc); + return (true); + } + if ((o1->v[0].fi == opt_i_ii_sc) + || (o1->v[0].fi == opt_i_ii_sc_add) + || (o1->v[0].fi == opt_i_ii_sc_sub)) { + opc->v[4].i_ii_f = o1->v[3].i_ii_f; + opc->v[2].p = o1->v[1].p; + opc->v[3].i = o1->v[2].i; + opc->v[0].fp = + (o1->v[0].fi == + opt_i_ii_sc_add) ? opt_set_p_i_fo1_add : opt_set_p_i_fo1; + backup_pc(sc); + return (true); + } + } + return_false(sc, NULL); +} + +static bool set_p_d_f_combinable(s7_scheme * sc, opt_info * opc) +{ + if ((sc->pc > 3) && (opc == sc->opts[sc->pc - 4])) { + opt_info *o1 = sc->opts[sc->pc - 3]; + if ((o1->v[0].fd == opt_d_mm_fff) && ((o1->v[3].d_dd_f == add_d_dd) + || (o1->v[3].d_dd_f == + subtract_d_dd))) { + opc->v[0].fp = + (o1->v[3].d_dd_f == + add_d_dd) ? opt_set_p_d_f_mm_add : + opt_set_p_d_f_mm_subtract; + o1 = sc->opts[sc->pc - 2]; + opc->v[3].p = o1->v[1].p; + opc->v[4].p = o1->v[2].p; + opc->v[5].p = o1->v[3].p; + o1 = sc->opts[sc->pc - 1]; + opc->v[9].p = o1->v[1].p; + opc->v[10].p = o1->v[2].p; + opc->v[11].p = o1->v[3].p; + sc->pc -= 3; + return (true); + } + } + return_false(sc, NULL); +} + +static bool is_some_number(s7_scheme * sc, s7_pointer tp) +{ + return ((tp == sc->is_integer_symbol) || + (tp == sc->is_float_symbol) || + (tp == sc->is_real_symbol) || + (tp == sc->is_complex_symbol) || + (tp == sc->is_number_symbol) || + (tp == sc->is_rational_symbol)); +} + +static bool check_type_uncertainty(s7_scheme * sc, s7_pointer target, + s7_pointer car_x, opt_info * opc, + int32_t start_pc) +{ + s7_pointer code = sc->code; + /* if we're optimizing do, sc->code is (sometimes) ((vars...) (end...) car_x) where car_x is the do body, but it can also be for-each etc */ + + /* maybe the type uncertainty is not a problem */ + if ((is_pair(code)) && /* t101-aux-14: (vector-set! !v! 0 (do ((x (list 1 2 3) (cdr x)) (j -1)) ((null? x) j) (set! j (car x)))) */ + (is_pair(car(code))) && (is_pair(cdr(code))) && /* weird that code sometimes has nothing to do with car_x -- tree_memq below for reality check */ + (is_pair(cadr(code)))) { + s7_int counts; + if ((!has_high_c(code)) && /* only set below */ + (s7_tree_memq(sc, car_x, code))) { + if (is_pair(caar(code))) { + s7_pointer p; + counts = tree_count(sc, target, car(code), 0) + + tree_count(sc, target, caadr(code), 0) + + tree_count(sc, target, cddr(code), 0); + for (p = car(code); is_pair(p); p = cdr(p)) { + s7_pointer var = car(p); + if ((is_proper_list_2(sc, var)) && + (car(var) == target)) + counts--; + } + } else + counts = tree_count(sc, target, code, 0); + } else + counts = 2; + /* can be from lambda: (lambda (n)...): ((n) (set! sum (+ sum n))) etc */ + if (counts <= 2) { + set_has_high_c(code); + pc_fallback(sc, start_pc); + if (cell_optimize(sc, cddr(car_x))) { + opc->v[0].fp = opt_set_p_p_f; + opc->v[3].o1 = sc->opts[start_pc]; + opc->v[4].fp = sc->opts[start_pc]->v[0].fp; + return (true); + } + } + } + return_false(sc, car_x); +} + +static bool opt_cell_set(s7_scheme * sc, s7_pointer car_x) +{ /* len == 3 here (p_syntax) */ + opt_info *opc; + s7_pointer target = cadr(car_x); + opc = alloc_opo(sc); + if (is_symbol(target)) { + s7_pointer settee; + if ((is_constant_symbol(sc, target)) || + (symbol_has_setter(target))) + return_false(sc, car_x); + settee = lookup_slot_from(target, sc->curlet); + + if ((is_slot(settee)) && + (!is_immutable(settee)) && (!is_syntax(slot_value(settee)))) { + s7_pointer atype, stype; + int32_t start_pc = sc->pc; + + opc->v[1].p = settee; + stype = s7_type_of(sc, slot_value(settee)); + + if (stype == sc->is_integer_symbol) { + if (is_symbol(caddr(car_x))) { + s7_pointer val_slot; + val_slot = opt_integer_symbol(sc, caddr(car_x)); + if (val_slot) { + opc->v[2].p = val_slot; + opc->v[0].fp = opt_set_p_i_s; + return (true); + } + } else { + opc->v[5].o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cddr(car_x))) + return (check_type_uncertainty + (sc, target, car_x, opc, start_pc)); + if (!set_p_i_f_combinable(sc, opc)) { + opc->v[0].fp = opt_set_p_i_f; + opc->v[6].fi = opc->v[5].o1->v[0].fi; + } + return (true); + } + } + if (stype == sc->is_float_symbol) { + if (is_t_real(caddr(car_x))) { + opc->v[2].p = caddr(car_x); + opc->v[0].fp = opt_set_p_c; + return (true); + } + if (is_symbol(caddr(car_x))) { + s7_pointer val_slot; + val_slot = opt_float_symbol(sc, caddr(car_x)); + if (val_slot) { + opc->v[2].p = val_slot; + opc->v[0].fp = opt_set_p_d_s; + return (true); + } + } else { + if ((is_pair(caddr(car_x))) && + (float_optimize(sc, cddr(car_x)))) { + if (!set_p_d_f_combinable(sc, opc)) { + opc->v[4].o1 = sc->opts[start_pc]; + opc->v[5].fd = sc->opts[start_pc]->v[0].fd; + opc->v[0].fp = + (opc->v[5].fd == + opt_d_dd_sf_add) ? opt_set_p_d_f_sf_add : + opt_set_p_d_f; + } + return (true); + } + return (check_type_uncertainty + (sc, target, car_x, opc, start_pc)); + } + } + atype = opt_arg_type(sc, cddr(car_x)); + if ((is_some_number(sc, atype)) && + (!is_some_number(sc, stype))) + return_false(sc, car_x); + if (cell_optimize(sc, cddr(car_x))) { + if ((stype != atype) && (is_symbol(stype)) && (((t_sequence_p[symbol_type(stype)]) && (stype != sc->is_null_symbol) && (stype != sc->is_pair_symbol)) || /* compatible with is_proper_list! */ + (stype == + sc->is_iterator_symbol))) + return_false(sc, car_x); + opc->v[0].fp = opt_set_p_p_f; + opc->v[3].o1 = sc->opts[start_pc]; + opc->v[4].fp = sc->opts[start_pc]->v[0].fp; + return (true); + } + } + } else { + if ((is_pair(target)) && + (is_symbol(car(target))) && + (is_pair(cdr(target))) && + ((is_null(cddr(target))) || (is_null(cdddr(target))) + || (is_null(cddddr(target))))) { + s7_pointer s_slot; + s_slot = lookup_slot_from(car(target), sc->curlet); + if (is_slot(s_slot)) { + s7_pointer obj = slot_value(s_slot); + opc->v[1].p = s_slot; + if ( /* (!has_methods(obj)) && *//* not mentioned in d_impicit */ + (is_mutable_sequence(obj))) { + s7_pointer index; + switch (type(obj)) { + case T_STRING: + { + s7_pointer val_type; + if (is_pair(cddr(target))) + return_false(sc, car_x); + val_type = opt_arg_type(sc, cddr(car_x)); + if (val_type != sc->is_char_symbol) + return_false(sc, car_x); + opc->v[3].p_pip_f = string_set_p_pip_unchecked; + } + break; + + case T_VECTOR: + /* is_t_integer below to handle the index */ + if (is_null(cddr(target))) { + if (vector_rank(obj) != 1) + return_false(sc, car_x); + opc->v[3].p_pip_f = + (is_typed_vector(obj)) ? + typed_vector_set_p_pip_unchecked : + vector_set_p_pip_unchecked; + } else { + if (vector_rank(obj) != 2) + return_false(sc, car_x); + opc->v[5].p_piip_f = + (is_typed_vector(obj)) ? + typed_vector_set_p_piip_direct : + vector_set_p_piip_direct; + return (p_piip_to_sx + (sc, opc, cdr(target), cddr(target), + cddr(car_x), obj)); + } + break; + + case T_FLOAT_VECTOR: + if (opt_float_vector_set + (sc, opc, car(target), cdr(target), + (is_null(cddr(target))) ? NULL : cddr(target), + ((!is_pair(cddr(target))) + || (is_null(cdddr(target)))) ? NULL : + cdddr(target), cddr(car_x))) { + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; + return (true); + } + return_false(sc, car_x); + + case T_BYTE_VECTOR: + case T_INT_VECTOR: + if (opt_int_vector_set + (sc, -1, opc, car(target), cdr(target), + (is_null(cddr(target))) ? NULL : cddr(target), + cddr(car_x))) { + opc->v[O_WRAP].fi = opc->v[0].fi; + opc->v[0].fp = i_to_p; + return (true); + } + return_false(sc, car_x); + + case T_C_OBJECT: + if ((is_null(cddr(target))) && + (is_c_function(c_object_setf(sc, obj)))) { + /* d_7pid_ok assumes cadr is the target, not car etc */ + s7_d_7pid_t func; + func = + s7_d_7pid_function(c_object_setf(sc, obj)); + if (func) { + s7_pointer slot; + opc->v[4].d_7pid_f = func; + slot = + opt_integer_symbol(sc, cadr(target)); + opc->v[10].o1 = sc->opts[sc->pc]; + if (slot) { + if (float_optimize(sc, cddr(car_x))) { + opc->v[O_WRAP].fd = opt_d_7pid_ssf; + opc->v[0].fp = d_to_p; /* cell_optimize, so need to return s7_pointer */ + opc->v[2].p = slot; + opc->v[11].fd = + opc->v[10].o1->v[0].fd; + return (true); + } + } else if (int_optimize(sc, cdr(target))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(car_x))) { + opc->v[O_WRAP].fd = opt_d_7pid_sff; + opc->v[11].fi = + opc->v[10].o1->v[0].fi; + opc->v[9].fd = + opc->v[8].o1->v[0].fd; + opc->v[0].fp = d_to_p; + return (true); + } + } + } + } + return_false(sc, car_x); + + case T_PAIR: + if (is_pair(cddr(target))) + return_false(sc, car_x); + opc->v[3].p_pip_f = list_set_p_pip_unchecked; + + /* an experiment -- is this ever hit in normal code? */ + { + s7_pointer val = caddr(car_x); + if ((is_pair(val)) + && (car(val) == sc->add_symbol) + && (is_t_integer(caddr(val))) + && (is_null(cdddr(val))) + && (is_symbol(cadr(target))) + && (car(target) == (caadr(val))) + && (is_pair(cdadr(val))) + && (is_null(cddadr(val))) + && (cadr(target) == cadadr(val))) { + s7_pointer slot; + index = cadr(target); + slot = opt_simple_symbol(sc, index); + if ((slot) + && (is_t_integer(slot_value(slot)))) { + opc->v[2].p = slot; + opc->v[3].p = caddr(val); + opc->v[0].fp = + list_increment_p_pip_unchecked; + return (true); + } + } + } + break; + + case T_HASH_TABLE: + if (is_pair(cddr(target))) + return_false(sc, car_x); + opc->v[3].p_ppp_f = s7_hash_table_set; + break; + + case T_LET: + /* here we know the let is a covered mutable let -- ?? not true if s7-optimize called explicitly */ + if ((is_pair(cddr(target))) || (has_methods(obj))) + return_false(sc, car_x); + if ((is_keyword(cadr(target))) || + ((is_quoted_symbol(cadr(target))))) + opc->v[3].p_ppp_f = let_set_1; + else + opc->v[3].p_ppp_f = let_set_p_ppp_2; + break; + + default: + return_false(sc, car_x); + } + index = cadr(target); + if (is_symbol(index)) { + s7_pointer slot; + int32_t start = sc->pc; + slot = opt_simple_symbol(sc, index); + if (slot) { + opc->v[2].p = slot; + if ((is_t_integer(slot_value(slot))) && + (is_step_end(opc->v[2].p))) { + if (is_string(obj)) { + if (do_loop_end + (slot_value(opc->v[2].p)) <= + string_length(obj)) + opc->v[3].p_pip_f = + string_set_unchecked; + } else if (is_byte_vector(obj)) { + if (do_loop_end + (slot_value(opc->v[2].p)) <= + byte_vector_length(obj)) + opc->v[3].p_pip_f = + byte_vector_set_unchecked_p; + } else if (is_any_vector(obj)) { /* true for all 3 vectors */ + if ((is_any_vector(obj)) && + (do_loop_end + (slot_value(opc->v[2].p)) <= + vector_length(obj))) { + if ((is_normal_vector(obj)) + && (is_typed_vector(obj))) + opc->v[3].p_pip_f = + typed_vector_set_unchecked; + else + opc->v[3].p_pip_f = + vector_set_unchecked; + } + } + } + if (is_symbol(caddr(car_x))) { + s7_pointer val_slot; + s7_p_ppp_t func1; + val_slot = + opt_simple_symbol(sc, caddr(car_x)); + if (val_slot) { + if ((is_string(obj)) || + (is_any_vector(obj)) || + (is_pair(obj))) { + opc->v[4].p_pip_f = + opc->v[3].p_pip_f; + opc->v[3].p = val_slot; + opc->v[0].fp = opt_p_pip_sss; + return (true); + } + func1 = opc->v[3].p_ppp_f; + opc->v[4].p_ppp_f = func1; + opc->v[3].p = val_slot; + opc->v[0].fp = + (func1 == + multiply_p_ppp) ? + opt_p_ppp_sss_mul + : ((func1 == + s7_hash_table_set) ? + opt_p_ppp_sss_hset : + opt_p_ppp_sss); + return (true); + } + } else + if ((!is_pair(caddr(car_x))) || + (is_proper_quote(sc, caddr(car_x)))) { + if (!is_pair(caddr(car_x))) + opc->v[4].p = caddr(car_x); + else + opc->v[4].p = cadaddr(car_x); + if ((is_string(obj)) || + (is_any_vector(obj)) || + (is_pair(obj))) { + opc->v[0].fp = opt_p_pip_ssc; + return (true); + } + opc->v[0].fp = opt_p_ppp_ssc; + return (true); + } + if (cell_optimize(sc, cddr(car_x))) { + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fp = sc->opts[start]->v[0].fp; + if ((is_string(obj)) || + (is_any_vector(obj)) || + (is_pair(obj))) { + if (p_pip_ssf_combinable + (sc, opc, start)) + return (true); + opc->v[0].fp = opt_p_pip_ssf; + return (true); + } + opc->v[0].fp = opt_p_ppp_ssf; + return (true); + } + } + } else { + opt_info *o1; + if ((is_string(obj)) || + (is_pair(obj)) || (is_any_vector(obj))) { + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(target))) { + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) { + opc->v[0].fp = opt_p_pip_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fp = opc->v[8].o1->v[0].fp; + return (true); + } + } + return_false(sc, car_x); + } + if ((is_proper_quote(sc, cadr(target))) && + (is_symbol(caddr(car_x)))) { + s7_pointer val_slot; + val_slot = opt_simple_symbol(sc, caddr(car_x)); + if (val_slot) { + opc->v[4].p = cadadr(target); + opc->v[2].p = val_slot; + opc->v[0].fp = (opc->v[3].p_ppp_f = + let_set_1) ? + opt_p_ppp_scs_eset : opt_p_ppp_scs; + return (true); + } + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(target))) { + opt_info *o2; + if (is_symbol(caddr(car_x))) { + s7_pointer val_slot; + val_slot = + opt_simple_symbol(sc, caddr(car_x)); + if (val_slot) { + opc->v[2].p = val_slot; + opc->v[0].fp = opt_p_ppp_sfs; + opc->v[4].o1 = o1; + opc->v[5].fp = o1->v[0].fp; + return (true); + } + } + o2 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) { + opc->v[0].fp = opt_p_ppp_sff; + opc->v[10].o1 = o1; + opc->v[11].fp = o1->v[0].fp; + opc->v[8].o1 = o2; + opc->v[9].fp = o2->v[0].fp; + return (true); + } + } + } + } + } + } + } + return_false(sc, car_x); +} + + +/* -------- cell_begin -------- */ +static s7_pointer opt_begin_p(opt_info * o) +{ + opt_info *o1; + s7_int i, len = o->v[1].i; /* len = 1 if 2 exprs, etc */ + for (i = 0; i < len; i++) { + o1 = o->v[i + 2].o1; + o1->v[0].fp(o1); + } + o1 = o->v[i + 2].o1; + return (o1->v[0].fp(o1)); +} + +static s7_pointer opt_begin_p_1(opt_info * o) +{ + o->v[3].fp(o->v[2].o1); + return (o->v[5].fp(o->v[4].o1)); +} + +static void oo_idp_nr_fixup(opt_info * start) +{ + if (start->v[0].fp == d_to_p) { + start->v[0].fp = d_to_p_nr; + if (start->v[O_WRAP].fd == opt_d_7pid_ssf) + start->v[0].fp = opt_d_7pid_ssf_nr; + else if (start->v[O_WRAP].fd == opt_d_7pid_ssfo_fv) { + start->v[0].fp = opt_d_7pid_ssfo_fv_nr; + if (start->v[6].d_dd_f == add_d_dd) + start->v[0].fp = opt_d_7pid_ssfo_fv_add_nr; + else if (start->v[6].d_dd_f == subtract_d_dd) + start->v[0].fp = opt_d_7pid_ssfo_fv_sub_nr; + } + } else if (start->v[0].fp == i_to_p) + start->v[0].fp = i_to_p_nr; +} + +static bool opt_cell_begin(s7_scheme * sc, s7_pointer car_x, int32_t len) +{ + int32_t i; + opt_info *opc; + s7_pointer p; + if (len > (NUM_VUNIONS - 3)) + return_false(sc, car_x); + opc = alloc_opo(sc); + for (i = 2, p = cdr(car_x); is_pair(p); i++, p = cdr(p)) { + opt_info *start = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, car_x); + if (is_pair(cdr(p))) + oo_idp_nr_fixup(start); + opc->v[i].o1 = start; + } + opc->v[1].i = len - 2; + if (len == 3) { + opc->v[0].fp = opt_begin_p_1; + opc->v[4].o1 = opc->v[3].o1; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + opc->v[3].fp = opc->v[2].o1->v[0].fp; + } else + opc->v[0].fp = opt_begin_p; + return (true); +} + +/* -------- cell_when|unless -------- */ +static s7_pointer opt_when_p_2(opt_info * o) +{ + if (o->v[4].fb(o->v[3].o1)) { + o->v[6].fp(o->v[5].o1); + return (o->v[8].fp(o->v[7].o1)); + } + return (opt_sc(o)->unspecified); +} + +static s7_pointer opt_when_p(opt_info * o) +{ + if (o->v[4].fb(o->v[3].o1)) { + int32_t i, len; + opt_info *o1; + len = o->v[1].i - 1; + for (i = 0; i < len; i++) { + o1 = o->v[i + 5].o1; + o1->v[0].fp(o1); + } + o1 = o->v[i + 5].o1; + return (o1->v[0].fp(o1)); + } + return (opt_sc(o)->unspecified); +} + +static s7_pointer opt_when_p_1(opt_info * o) +{ + opt_info *o1; + if (!o->v[4].fb(o->v[3].o1)) + return (opt_sc(o)->unspecified); + o1 = o->v[5].o1; + return (o1->v[0].fp(o1)); +} + +static s7_pointer opt_unless_p(opt_info * o) +{ + opt_info *o1; + int32_t i, len; + + if (o->v[4].fb(o->v[3].o1)) + return (opt_sc(o)->unspecified); + len = o->v[1].i - 1; + for (i = 0; i < len; i++) { + o1 = o->v[i + 5].o1; + o1->v[0].fp(o1); + } + o1 = o->v[i + 5].o1; + return (o1->v[0].fp(o1)); +} + +static s7_pointer opt_unless_p_1(opt_info * o) +{ + opt_info *o1; + if (o->v[4].fb(o->v[3].o1)) + return (opt_sc(o)->unspecified); + o1 = o->v[5].o1; + return (o1->v[0].fp(o1)); +} + +static bool opt_cell_when(s7_scheme * sc, s7_pointer car_x, int32_t len) +{ + s7_pointer p; + int32_t k; + opt_info *opc; + if (len > (NUM_VUNIONS - 6)) + return_false(sc, car_x); + opc = alloc_opo(sc); + opc->v[3].o1 = sc->opts[sc->pc]; + if (!bool_optimize(sc, cdr(car_x))) + return_false(sc, car_x); + for (k = 5, p = cddr(car_x); is_pair(p); k++, p = cdr(p)) { + opt_info *start = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, car_x); + if (is_pair(cdr(p))) + oo_idp_nr_fixup(start); + opc->v[k].o1 = start; + } + opc->v[4].fb = opc->v[3].o1->v[0].fb; + opc->v[1].i = len - 2; + if (car(car_x) == sc->when_symbol) { + if (len == 3) + opc->v[0].fp = opt_when_p_1; + else if (len == 4) { + opc->v[0].fp = opt_when_p_2; + opc->v[7].o1 = opc->v[6].o1; + opc->v[8].fp = opc->v[7].o1->v[0].fp; + opc->v[6].fp = opc->v[5].o1->v[0].fp; + } else + opc->v[0].fp = opt_when_p; + } else + opc->v[0].fp = (len == 3) ? opt_unless_p_1 : opt_unless_p; + return (true); +} + +/* -------- cell_cond -------- */ + +#define COND_O1 3 +#define COND_CLAUSE_O1 5 + +static s7_pointer cond_value(opt_info * o) +{ + opt_info *o1; + int32_t i, len = o->v[1].i - 1; + for (i = 0; i < len; i++) { + o1 = o->v[i + COND_CLAUSE_O1].o1; + o1->v[0].fp(o1); + } + o1 = o->v[i + COND_CLAUSE_O1].o1; + return (o1->v[0].fp(o1)); +} + +static s7_pointer opt_cond(opt_info * top) +{ + int32_t clause, len = top->v[2].i; + for (clause = 0; clause < len; clause++) { + opt_info *o2, *o1 = top->v[clause + COND_O1].o1; + o2 = o1->v[4].o1; + if (o2->v[0].fb(o2)) { + s7_pointer res; + res = cond_value(o1); + return (res); + } + } + return (top->sc->unspecified); +} + +static s7_pointer opt_cond_1(opt_info * o) +{ + return ((o->v[5].fb(o->v[4].o1)) ? cond_value(o->v[6]. + o1) : + opt_sc(o)->unspecified); +} /* cond as when */ + +static s7_pointer opt_cond_1b(opt_info * o) +{ + return ((o->v[4].o1->v[O_WRAP].fp(o->v[4].o1) != + opt_sc(o)->F) ? cond_value(o->v[6]. + o1) : opt_sc(o)->unspecified); +} + +static s7_pointer opt_cond_2(opt_info * o) +{ /* 2 branches, results 1 expr, else */ + opt_info *o1; + s7_pointer res; + o1 = (o->v[5].fb(o->v[4].o1)) ? o->v[6].o1 : o->v[7].o1; + res = o1->v[0].fp(o1); + return (res); +} + +static bool opt_cell_cond(s7_scheme * sc, s7_pointer car_x) +{ + /* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */ + s7_pointer p, last_clause = NULL; + opt_info *top; + int32_t branches = 0, max_blen = 0, start_pc; + + top = alloc_opo(sc); + start_pc = sc->pc; + for (p = cdr(car_x); is_pair(p); p = cdr(p), branches++) { + opt_info *opc; + s7_pointer clause = car(p), cp; + int32_t blen; + if ((branches >= (NUM_VUNIONS - COND_O1)) || (!is_pair(clause)) || (!is_pair(cdr(clause))) || /* leave the test->result case for later */ + (cadr(clause) == sc->feed_to_symbol)) + return_false(sc, clause); + + last_clause = clause; + top->v[branches + COND_O1].o1 = sc->opts[sc->pc]; + opc = alloc_opo(sc); + opc->v[4].o1 = sc->opts[sc->pc]; + if (!bool_optimize(sc, clause)) + return_false(sc, clause); + + for (blen = 0, cp = cdr(clause); is_pair(cp); blen++, cp = cdr(cp)) { + if (blen >= NUM_VUNIONS - COND_CLAUSE_O1) + return_false(sc, cp); + opc->v[blen + COND_CLAUSE_O1].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cp)) + return_false(sc, cp); + } + if (!is_null(cp)) + return_false(sc, cp); + opc->v[1].i = blen; + if (max_blen < blen) + max_blen = blen; + opc->v[0].fp = opt_cond; /* a placeholder */ + } + if (branches == 1) { + opt_info *o1 = sc->opts[start_pc + 1]; + top->v[0].fp = (o1->v[0].fb == p_to_b) ? opt_cond_1b : opt_cond_1; + top->v[4].o1 = o1; + top->v[5].fb = o1->v[0].fb; + top->v[6].o1 = sc->opts[start_pc]; + return (true); + } + if (branches == 2) { + if ((max_blen == 1) && + ((car(last_clause) == sc->else_symbol) || + (car(last_clause) == sc->T))) { + opt_info *o1; + top->v[6].o1 = top->v[COND_O1].o1->v[COND_CLAUSE_O1].o1; + top->v[7].o1 = top->v[COND_O1 + 1].o1->v[COND_CLAUSE_O1].o1; + + o1 = sc->opts[start_pc + 1]; + top->v[4].o1 = o1; + top->v[5].fb = o1->v[0].fb; + top->v[0].fp = opt_cond_2; + return (true); + } + } + top->v[2].i = branches; + top->v[0].fp = opt_cond; + return (true); +} + +/* -------- cell_and|or -------- */ +static s7_pointer opt_and_pp(opt_info * o) +{ + return ((o->v[11].fp(o->v[10].o1) == + opt_sc(o)->F) ? opt_sc(o)->F : o->v[9].fp(o->v[8].o1)); +} + +static s7_pointer opt_and_any_p(opt_info * o) +{ + int32_t i; + s7_pointer val = opt_sc(o)->T; /* (and) -> #t */ + for (i = 0; i < o->v[1].i; i++) { + opt_info *o1 = o->v[i + 3].o1; + val = o1->v[0].fp(o1); + if (val == opt_sc(o)->F) + return (opt_sc(o)->F); + } + return (val); +} + +static s7_pointer opt_or_pp(opt_info * o) +{ + s7_pointer val; + val = o->v[11].fp(o->v[10].o1); + return ((val != opt_sc(o)->F) ? val : o->v[9].fp(o->v[8].o1)); +} + +static s7_pointer opt_or_any_p(opt_info * o) +{ + int32_t i; + for (i = 0; i < o->v[1].i; i++) { + s7_pointer val; + opt_info *o1 = o->v[i + 3].o1; + val = o1->v[0].fp(o1); + if (val != opt_sc(o)->F) + return (val); + } + return (opt_sc(o)->F); +} + +static bool opt_cell_and(s7_scheme * sc, s7_pointer car_x, int32_t len) +{ + opt_info *opc; + opc = alloc_opo(sc); + if (len == 3) { + opc->v[0].fp = + ((car(car_x) == sc->or_symbol) ? opt_or_pp : opt_and_pp); + + opc->v[10].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdr(car_x))) + return_false(sc, car_x); + opc->v[11].fp = opc->v[10].o1->v[0].fp; + + opc->v[8].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cddr(car_x))) + return_false(sc, car_x); + opc->v[9].fp = opc->v[8].o1->v[0].fp; + return (true); + } + + if ((len > 1) && (len < (NUM_VUNIONS - 4))) { + s7_pointer p; + int32_t i; + opc->v[1].i = (len - 1); + opc->v[0].fp = + ((car(car_x) == sc->or_symbol) ? opt_or_any_p : opt_and_any_p); + + for (i = 3, p = cdr(car_x); is_pair(p); i++, p = cdr(p)) { + opc->v[i].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, car_x); + } + return (true); + } + return_false(sc, car_x); +} + +/* -------- cell_if -------- */ +static s7_pointer opt_if_bp(opt_info * o) +{ + return ((o->v[3].fb(o->v[2].o1)) ? o->v[5]. + fp(o->v[4].o1) : opt_sc(o)->unspecified); +} + +static s7_pointer opt_if_nbp(opt_info * o) +{ + return ((o->v[5].fb(o->v[4].o1)) ? opt_sc(o)->unspecified : o-> + v[11].fp(o->v[10].o1)); +} + +static s7_pointer opt_if_bp_pb(opt_info * o) +{ /* p_to_b at outer, p_to_b expanded and moved to o[3] */ + return ((o->v[3].fp(o->v[2].o1) != + opt_sc(o)->F) ? o->v[5].fp(o->v[4]. + o1) : opt_sc(o)->unspecified); +} + +static s7_pointer opt_if_bp_ii_fc(opt_info * o) +{ + return ((o->v[3]. + b_ii_f(o->v[11].fi(o->v[10].o1), + o->v[2].i)) ? o->v[5].fp(o->v[4].o1) : opt_sc(o)-> + unspecified); +} + +static s7_pointer opt_if_nbp_s(opt_info * o) +{ + return ((o->v[2]. + b_p_f(slot_value(o->v[3].p))) ? opt_sc(o)->unspecified : o-> + v[11].fp(o->v[10].o1)); +} + +static s7_pointer opt_if_nbp_sc(opt_info * o) +{ /* b_pp_sc */ + return ((o->v[3].b_pp_f(slot_value(o->v[2].p), + o->v[4].p)) ? opt_sc(o)->unspecified : o-> + v[11].fp(o->v[10].o1)); +} + +static s7_pointer opt_if_nbp_7sc(opt_info * o) +{ /* b_7pp_sc */ + return ((o->v[3].b_7pp_f(opt_sc(o), slot_value(o->v[2].p), + o->v[4].p)) ? opt_sc(o)->unspecified : o-> + v[11].fp(o->v[10].o1)); +} + +static s7_pointer opt_if_nbp_ss(opt_info * o) +{ /* b_ii_ss */ + return ((o->v[3].b_ii_f(integer(slot_value(o->v[2].p)), + integer(slot_value(o->v[4].p)))) ? + opt_sc(o)->unspecified : o->v[11].fp(o->v[10].o1)); +} + +static s7_pointer opt_if_eq_ii_ss(opt_info * o) +{ /* b_ii_ss */ + return ((integer(slot_value(o->v[2].p)) == + integer(slot_value(o->v[4].p))) ? opt_sc(o)-> + unspecified : o->v[11].fp(o->v[10].o1)); +} + +static s7_pointer opt_if_nbp_fs(opt_info * o) +{ /* b_pi_fs */ + return ((o->v[2].b_pi_f(opt_sc(o), o->v[5].fp(o->v[4].o1), + integer(slot_value(o->v[3].p)))) ? + opt_sc(o)->unspecified : o->v[11].fp(o->v[10].o1)); +} + +static s7_pointer opt_if_nbp_sf(opt_info * o) +{ /* b_pp_sf */ + return ((o->v[2].b_pp_f(slot_value(o->v[3].p), + o->v[5].fp(o->v[4].o1))) ? opt_sc(o)-> + unspecified : o->v[11].fp(o->v[10].o1)); +} + +static s7_pointer opt_if_nbp_7sf(opt_info * o) +{ /* b_7pp_sf */ + return ((o->v[2].b_7pp_f(opt_sc(o), slot_value(o->v[3].p), + o->v[5].fp(o->v[4]. + o1))) ? opt_sc(o)->unspecified : + o->v[11].fp(o->v[10].o1)); +} + +static s7_pointer opt_if_bpp(opt_info * o) +{ + return ((o->v[5].fb(o->v[4].o1)) ? o->v[9].fp(o->v[8].o1) : o-> + v[11].fp(o->v[10].o1)); +} + +static bool opt_cell_if(s7_scheme * sc, s7_pointer car_x, int32_t len) +{ + opt_info *opc, *bop, *top; + opc = alloc_opo(sc); + bop = sc->opts[sc->pc]; + if (len == 3) { + if ((is_proper_list_2(sc, cadr(car_x))) && /* (not arg) */ + (caadr(car_x) == sc->not_symbol)) { + if (bool_optimize(sc, cdadr(car_x))) { + top = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) { + opc->v[10].o1 = top; + opc->v[11].fp = top->v[0].fp; + if (bop->v[0].fb == opt_b_p_s) { + opc->v[2].b_p_f = bop->v[2].b_p_f; + opc->v[3].p = bop->v[1].p; + opc->v[0].fp = opt_if_nbp_s; + return (true); + } + if ((bop->v[0].fb == opt_b_pi_fs) + || (bop->v[0].fb == opt_b_pi_fs_num_eq)) { + opc->v[2].b_pi_f = bop->v[2].b_pi_f; + opc->v[3].p = bop->v[1].p; + opc->v[4].o1 = bop->v[10].o1; + opc->v[5].fp = bop->v[11].fp; + opc->v[0].fp = opt_if_nbp_fs; + return (true); + } + if ((bop->v[0].fb == opt_b_pp_sf) || + (bop->v[0].fb == opt_b_7pp_sf)) { + opc->v[4].o1 = bop->v[10].o1; + opc->v[5].fp = bop->v[11].fp; + if (bop->v[0].fb == opt_b_pp_sf) { + opc->v[2].b_pp_f = bop->v[3].b_pp_f; + opc->v[0].fp = opt_if_nbp_sf; + } else { + opc->v[2].b_7pp_f = bop->v[3].b_7pp_f; + opc->v[0].fp = opt_if_nbp_7sf; + } + opc->v[3].p = bop->v[1].p; + return (true); + } + if ((bop->v[0].fb == opt_b_pp_sc) || + (bop->v[0].fb == opt_b_7pp_sc)) { + if (bop->v[0].fb == opt_b_pp_sc) { + opc->v[3].b_pp_f = bop->v[3].b_pp_f; + opc->v[0].fp = opt_if_nbp_sc; + } else { + opc->v[3].b_7pp_f = bop->v[3].b_7pp_f; + opc->v[0].fp = opt_if_nbp_7sc; + } + opc->v[2].p = bop->v[1].p; + opc->v[4].p = bop->v[2].p; + return (true); + } + if ((bop->v[0].fb == opt_b_ii_ss) + || (bop->v[0].fb == opt_b_ii_ss_eq) + || (bop->v[0].fb == opt_b_ii_ss_lt) + || (bop->v[0].fb == opt_b_ii_ss_gt) + || (bop->v[0].fb == opt_b_ii_ss_leq) + || (bop->v[0].fb == opt_b_ii_ss_geq)) { + opc->v[3].b_ii_f = bop->v[3].b_ii_f; + opc->v[2].p = bop->v[1].p; + opc->v[4].p = bop->v[2].p; + opc->v[0].fp = + (opc->v[3].b_ii_f == + num_eq_b_ii) ? opt_if_eq_ii_ss : + opt_if_nbp_ss; + return (true); + } + opc->v[4].o1 = bop; + opc->v[5].fb = bop->v[0].fb; + opc->v[0].fp = opt_if_nbp; + return (true); + } + } + } else if (bool_optimize(sc, cdr(car_x))) { + top = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) { + opc->v[2].o1 = bop; + opc->v[4].o1 = top; + opc->v[5].fp = top->v[0].fp; + if (bop->v[0].fb == p_to_b) { + opc->v[0].fp = opt_if_bp_pb; + opc->v[3].fp = bop->v[O_WRAP].fp; + return (true); + } + if (bop->v[0].fb == opt_b_ii_fc) { + opc->v[2].i = bop->v[2].i; + opc->v[3].b_ii_f = bop->v[3].b_ii_f; + opc->v[11].fi = bop->v[11].fi; + opc->v[10].o1 = bop->v[10].o1; + opc->v[0].fp = opt_if_bp_ii_fc; + return (true); + } + opc->v[0].fp = opt_if_bp; + opc->v[3].fb = bop->v[0].fb; + return (true); + } + } + return_false(sc, car_x); + } + if (len == 4) { + if (bool_optimize(sc, cdr(car_x))) { + top = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) { + opt_info *o3 = sc->opts[sc->pc]; + opc->v[0].fp = opt_if_bpp; + if (cell_optimize(sc, cdddr(car_x))) { + opc->v[4].o1 = bop; + opc->v[5].fb = bop->v[0].fb; + opc->v[8].o1 = top; + opc->v[9].fp = top->v[0].fp; + opc->v[10].o1 = o3; + opc->v[11].fp = o3->v[0].fp; + return (true); + } + } + } + } + return_false(sc, car_x); +} + +/* -------- cell_case -------- */ +static bool case_memv(s7_scheme * sc, s7_pointer x, s7_pointer y) +{ + s7_pointer z; + if (is_simple(x)) { + for (z = y; is_pair(z); z = cdr(z)) + if (x == car(z)) + return (true); + return (false); + } + for (z = y; is_pair(z); z = cdr(z)) + if (s7_is_eqv(sc, x, car(z))) + return (true); + return (false); +} + +#define CASE_O1 3 +#define CASE_SEL 2 +#define CASE_CLAUSE_O1 4 +#define CASE_CLAUSE_KEYS 2 + +static s7_pointer case_value(s7_scheme * sc, opt_info * top, opt_info * o) +{ + opt_info *o1; + int32_t i, len = o->v[1].i - 1; + for (i = 0; i < len; i++) { + o1 = o->v[i + CASE_CLAUSE_O1].o1; + o1->v[0].fp(o1); + } + o1 = o->v[i + CASE_CLAUSE_O1].o1; + return (o1->v[0].fp(o1)); +} + +static s7_pointer opt_case(opt_info * o) +{ + opt_info *o1 = o->v[CASE_SEL].o1; + int32_t ctr, lim; + s7_pointer selector; + + selector = o1->v[0].fp(o1); + lim = o->v[1].i; + + for (ctr = CASE_O1; ctr < lim; ctr++) { + o1 = o->v[ctr].o1; + if ((o1->v[CASE_CLAUSE_KEYS].p == opt_sc(o)->else_symbol) || + (case_memv(opt_sc(o), selector, o1->v[CASE_CLAUSE_KEYS].p))) + return (case_value(opt_sc(o), o, o1)); + } + return (opt_sc(o)->unspecified); +} + +static bool opt_cell_case(s7_scheme * sc, s7_pointer car_x) +{ + /* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */ + opt_info *top; + s7_pointer p; + int32_t ctr; + top = alloc_opo(sc); + top->v[CASE_SEL].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdr(car_x))) /* selector */ + return_false(sc, car_x); + for (ctr = CASE_O1, p = cddr(car_x); + (is_pair(p)) && (ctr < NUM_VUNIONS); ctr++, p = cdr(p)) { + opt_info *opc; + s7_pointer clause = car(p), cp; + int32_t blen; + if ((!is_pair(clause)) || + ((!is_pair(car(clause))) && (car(clause) != sc->else_symbol)) + || (!is_pair(cdr(clause))) + || (cadr(clause) == sc->feed_to_symbol)) + return_false(sc, clause); + + opc = alloc_opo(sc); + top->v[ctr].o1 = opc; + if (car(clause) == sc->else_symbol) { + if (!is_null(cdr(p))) + return_false(sc, clause); + opc->v[CASE_CLAUSE_KEYS].p = sc->else_symbol; + } else { + if (!s7_is_proper_list(sc, car(clause))) + return_false(sc, clause); + opc->v[CASE_CLAUSE_KEYS].p = car(clause); + } + + for (blen = 0, cp = cdr(clause); + (is_pair(cp)) && (blen < (NUM_VUNIONS - CASE_CLAUSE_O1)); + blen++, cp = cdr(cp)) { + opc->v[blen + CASE_CLAUSE_O1].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cp)) + return_false(sc, cp); + } + if (!is_null(cp)) + return_false(sc, cp); + opc->v[1].i = blen; + opc->v[0].fp = opt_case; /* just a placeholder I hope */ + } + if (!is_null(p)) + return_false(sc, p); + top->v[1].i = ctr; + top->v[0].fp = opt_case; + return (true); +} + +/* -------- cell_let_temporarily -------- */ + +#define LET_TEMP_O1 5 + +static s7_pointer opt_let_temporarily(opt_info * o) +{ + opt_info *o1; + int32_t i, len; + s7_pointer result; + + if (is_immutable_slot(o->v[1].p)) + immutable_object_error(opt_sc(o), + set_elist_3(opt_sc(o), + immutable_error_string, + opt_sc + (o)->let_temporarily_symbol, + slot_symbol(o->v[1].p))); + + o1 = o->v[4].o1; + o->v[3].p = slot_value(o->v[1].p); /* save and protect old value */ + gc_protect_via_stack(opt_sc(o), o->v[3].p); + slot_set_value(o->v[1].p, o1->v[0].fp(o1)); /* set new value */ + len = o->v[2].i - 1; + for (i = 0; i < len; i++) { + o1 = o->v[i + LET_TEMP_O1].o1; + o1->v[0].fp(o1); + } + o1 = o->v[i + LET_TEMP_O1].o1; + result = o1->v[0].fp(o1); + slot_set_value(o->v[1].p, o->v[3].p); /* restore old */ + unstack(opt_sc(o)); + return (result); +} + +static bool opt_cell_let_temporarily(s7_scheme * sc, s7_pointer car_x, + int32_t len) +{ + s7_pointer vars; + if (len <= 2) + return_false(sc, car_x); + + vars = cadr(car_x); + if ((len < (NUM_VUNIONS - LET_TEMP_O1)) && (is_proper_list_1(sc, vars)) && /* just one var for now */ + (is_proper_list_2(sc, car(vars))) && /* and var is (sym val) */ + (is_symbol(caar(vars))) && + (!is_immutable(caar(vars))) && + (!is_syntactic_symbol(caar(vars)))) { + s7_pointer p; + opt_info *opc; + int32_t i; + opc = alloc_opo(sc); + opc->v[1].p = lookup_slot_from(caaadr(car_x), sc->curlet); + if (!is_slot(opc->v[1].p)) + return_false(sc, car_x); + + opc->v[4].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdaadr(car_x))) + return_false(sc, car_x); + + for (i = LET_TEMP_O1, p = cddr(car_x); is_pair(p); i++, p = cdr(p)) { + opc->v[i].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, car_x); + } + + opc->v[2].i = len - 2; + opc->v[0].fp = opt_let_temporarily; + return (true); + } + return_false(sc, car_x); +} + +/* -------- cell_do -------- */ + +#define do_curlet(o) o->v[2].p +#define do_body_length(o) o->v[3].i +#define do_result_length(o) o->v[4].i + +static void let_set_has_pending_value(s7_pointer lt) +{ + s7_pointer vp; + for (vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp)) + slot_set_pending_value(vp, eof_object); /* gc needs a legit value here */ +} + +static void let_clear_has_pending_value(s7_pointer lt) +{ + s7_pointer vp; + for (vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp)) + slot_clear_has_pending_value(vp); +} + +#define do_any_inits(o) o->v[7].o1 +#define do_any_body(o) o->v[10].o1 +#define do_any_results(o) o->v[11].o1 +#define do_any_test(o) o->v[12].o1 +#define do_any_steps(o) o->v[13].o1 + +static s7_pointer opt_do_any(opt_info * o) +{ + /* o->v[2].p=let, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length, o->v[7].i=inits */ + opt_info *o1, *ostart, *body, *inits, *steps, *results; + int32_t i, k; + s7_pointer vp, old_e, result; + s7_scheme *sc = opt_sc(o); + + old_e = sc->curlet; + s7_gc_protect_via_stack(sc, old_e); + sc->curlet = T_Let(do_curlet(o)); + + /* init */ + inits = do_any_inits(o); + for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); + k++, vp = next_slot(vp)) { + o1 = inits->v[k].o1; + slot_set_value(vp, o1->v[0].fp(o1)); + } + + ostart = do_any_test(o); + body = do_any_body(o); + results = do_any_results(o); + steps = do_any_steps(o); + let_set_has_pending_value(sc->curlet); + + while (true) { + /* end */ + if (ostart->v[0].fb(ostart)) + break; + + /* body */ + for (i = 0; i < do_body_length(o); i++) { + o1 = body->v[i].o1; + o1->v[0].fp(o1); + } + + /* step (let not let*) */ + for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); + k++, vp = next_slot(vp)) + if (has_stepper(vp)) { + o1 = steps->v[k].o1; + slot_simply_set_pending_value(vp, o1->v[0].fp(o1)); + } + for (vp = let_slots(sc->curlet); tis_slot(vp); vp = next_slot(vp)) + if (has_stepper(vp)) + slot_set_value(vp, slot_pending_value(vp)); + } + + /* result */ + result = sc->T; + for (i = 0; i < do_result_length(o); i++) { + o1 = results->v[i].o1; + result = o1->v[0].fp(o1); + } + let_clear_has_pending_value(sc->curlet); + unstack(sc); + set_curlet(sc, old_e); + return (result); +} + +static s7_pointer opt_do_step_1(opt_info * o) +{ + /* 1 stepper (multi inits perhaps), 1 body, 1 rtn */ + opt_info *o1, *ostart, *ostep, *inits, *body; + int32_t k; + s7_pointer vp, old_e, result, stepper = NULL; + s7_scheme *sc = opt_sc(o); + + ostep = o->v[9].o1; + old_e = sc->curlet; + s7_gc_protect_via_stack(sc, old_e); + sc->curlet = T_Let(do_curlet(o)); + + inits = do_any_inits(o); + for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); + k++, vp = next_slot(vp)) { + o1 = inits->v[k].o1; + slot_set_value(vp, o1->v[0].fp(o1)); + if (has_stepper(vp)) + stepper = vp; + } + ostart = do_any_test(o); + body = do_any_body(o); + + while (!(ostart->v[0].fb(ostart))) { + body->v[0].fp(body); + slot_set_value(stepper, ostep->v[0].fp(ostep)); + } + o1 = do_any_results(o); + result = o1->v[0].fp(o1); + + unstack(sc); + set_curlet(sc, old_e); + return (result); +} + +static s7_pointer opt_do_step_i(opt_info * o) +{ + /* 1 stepper (multi inits perhaps), 1 body, 1 rtn */ + opt_info *o1, *ostart, *ostep, *inits, *body; + int32_t k; + s7_pointer vp, old_e, result, stepper = NULL, si; + s7_scheme *sc = opt_sc(o); + s7_int end, incr; + + ostep = o->v[9].o1; + old_e = sc->curlet; + s7_gc_protect_via_stack(sc, old_e); + sc->curlet = T_Let(do_curlet(o)); + + inits = do_any_inits(o); + for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); + k++, vp = next_slot(vp)) { + o1 = inits->v[k].o1; + slot_set_value(vp, o1->v[0].fp(o1)); + if (has_stepper(vp)) + stepper = vp; + } + ostart = do_any_test(o); + body = do_any_body(o); + + end = integer(slot_value(ostart->v[2].p)); + incr = ostep->v[2].i; + si = make_mutable_integer(sc, integer(slot_value(ostart->v[1].p))); + slot_set_value(stepper, si); + + while (integer(si) != end) { + body->v[0].fp(body); + integer(si) += incr; + } + clear_mutable_integer(si); + + o1 = do_any_results(o); + result = o1->v[0].fp(o1); + + unstack(sc); + set_curlet(sc, old_e); + return (result); +} + +#define do_no_vars_test(o) o->v[6].o1 +#define do_no_vars_body(o) o->v[7].o1 + +static s7_pointer opt_do_no_vars(opt_info * o) +{ + /* no vars, no return, o->v[2].p=let, o->v[1].i=body end index, o->v[3].i=body length, o->v[4].i=return length=0, o->v[6]=end test */ + opt_info *ostart; + int32_t len; + s7_pointer old_e; + s7_scheme *sc = opt_sc(o); + bool (*fb)(opt_info * o); + + old_e = sc->curlet; + s7_gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + len = do_body_length(o); + ostart = do_no_vars_test(o); + fb = ostart->v[0].fb; + + if (len == 0) /* titer */ + while (!(fb(ostart))); + else { + opt_info *body; + body = do_no_vars_body(o); + while (!(fb(ostart))) { /* tshoot, tfft */ + int32_t i; + for (i = 0; i < len; i++) { + opt_info *o1; + o1 = body->v[i].o1; + o1->v[0].fp(o1); + } + } + } + unstack(sc); + set_curlet(sc, old_e); + return (sc->T); +} + +#define do_stepper_init(o) o->v[11].o1 + +static s7_pointer opt_do_1(opt_info * o) +{ + /* 1 var, 1 expr, no return */ + opt_info *o1, *ostart, *ostep, *body; /* o->v[2].p=let */ + s7_pointer vp, old_e; + s7_scheme *sc = opt_sc(o); + + old_e = sc->curlet; + s7_gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + + ostep = o->v[9].o1; + vp = let_slots(do_curlet(o)); + o1 = do_stepper_init(o); + slot_set_value(vp, o1->v[0].fp(o1)); + ostart = do_any_test(o); + body = do_any_body(o); + + if ((o->v[8].i == 1) && (is_t_integer(slot_value(vp)))) { + if ((ostep->v[0].fp == opt_p_ii_ss_add) || /* tmap */ + (ostep->v[0].fp == i_to_p)) { + s7_pointer step_val; + step_val = make_mutable_integer(sc, integer(slot_value(vp))); + slot_set_value(vp, step_val); + if (ostep->v[0].fp == opt_p_ii_ss_add) + while (!ostart->v[0].fb(ostart)) { + body->v[0].fp(body); + integer(step_val) = opt_i_ii_ss_add(ostep); + } else + while (!ostart->v[0].fb(ostart)) { + body->v[0].fp(body); + integer(step_val) = ostep->v[O_WRAP].fi(ostep); + } + unstack(sc); + set_curlet(sc, old_e); + return (sc->T); + } + o->v[8].i = 2; + } + while (!(ostart->v[0].fb(ostart))) { /* s7test tref */ + body->v[0].fp(body); + slot_set_value(vp, ostep->v[0].fp(ostep)); + } + unstack(sc); + set_curlet(sc, old_e); + return (sc->T); +} + +#define do_n_body(o) o->v[7].o1 + +static s7_pointer opt_do_n(opt_info * o) +{ + /* 1 var, no return */ + opt_info *o1, *ostart, *ostep, *body; /* o->v[2].p=let, o->v[3].i=body length */ + int32_t len; + s7_pointer vp, old_e; + s7_scheme *sc = opt_sc(o); + + old_e = sc->curlet; + s7_gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + ostep = o->v[9].o1; + len = do_body_length(o); + + vp = let_slots(do_curlet(o)); + o1 = do_stepper_init(o); + slot_set_value(vp, o1->v[0].fp(o1)); + ostart = do_any_test(o); + body = do_n_body(o); + + if (len == 2) { /* tmac tshoot */ + opt_info *e1 = body->v[0].o1, *e2 = body->v[1].o1; + while (!(ostart->v[0].fb(ostart))) { + e1->v[0].fp(e1); + e2->v[0].fp(e2); + slot_set_value(vp, ostep->v[0].fp(ostep)); + } + } else + while (!ostart->v[0].fb(ostart)) { /* tfft teq */ + int32_t i; + for (i = 0; i < len; i++) { + o1 = body->v[i].o1; + o1->v[0].fp(o1); + } + slot_set_value(vp, ostep->v[0].fp(ostep)); + } + unstack(sc); + set_curlet(sc, old_e); + return (sc->T); +} + +static s7_pointer opt_dotimes_2(opt_info * o) +{ + /* 1 var, no return */ + opt_info *o1, *body; /* o->v[2].p=let, o->v[3].i=body length, o->v[4].i=return length=0, o->v[6].i=end index, v6.i=end, v7=init */ + int32_t len; + s7_int end; + s7_pointer vp, old_e; + s7_scheme *sc = opt_sc(o); + + old_e = sc->curlet; + s7_gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + len = do_body_length(o); + + vp = let_dox1_value(do_curlet(o)); + if (is_slot(let_dox_slot2_unchecked(do_curlet(o)))) + end = integer(slot_value(let_dox_slot2(do_curlet(o)))); + else + end = o->v[6].i; + + o1 = do_stepper_init(o); + integer(vp) = integer(o1->v[0].fp(o1)); + body = do_n_body(o); + + if (len == 2) { /* tmac tmisc */ + opt_info *e1, *e2; + e1 = body->v[0].o1; + e2 = body->v[1].o1; + while (integer(vp) < end) { + e1->v[0].fp(e1); + e2->v[0].fp(e2); + integer(vp)++; + } + } else + while (integer(vp) < end) { /* tbig sg */ + int32_t i; + for (i = 0; i < len; i++) { + o1 = body->v[i].o1; + o1->v[0].fp(o1); + } + integer(vp)++; + } + unstack(sc); + set_curlet(sc, old_e); + return (sc->T); +} + +static s7_pointer opt_do_list_simple(opt_info * o) +{ + /* 1 var, 1 expr, no return, step by cdr, end=null? */ + opt_info *o1; /* o->v[2].p=let */ + s7_pointer vp, old_e; + s7_scheme *sc = opt_sc(o); + s7_pointer(*fp) (opt_info * o); + + old_e = sc->curlet; + s7_gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + + vp = let_slots(do_curlet(o)); + o1 = do_stepper_init(o); + slot_set_value(vp, o1->v[0].fp(o1)); + o1 = do_any_body(o); + + fp = o1->v[0].fp; + if (fp == opt_if_bp) { + while (is_pair(slot_value(vp))) { + if (o1->v[3].fb(o1->v[2].o1)) + o1->v[5].fp(o1->v[4].o1); + slot_set_value(vp, cdr(slot_value(vp))); + } + } else + while (!is_null(slot_value(vp))) { + fp(o1); + slot_set_value(vp, cdr(slot_value(vp))); + } + unstack(sc); + set_curlet(sc, old_e); + return (sc->T); +} + +static s7_pointer opt_do_very_simple(opt_info * o) +{ + /* like simple but step can be direct, v[2].p is a let, v[3].i=end? */ + opt_info *o1; + s7_int end; + s7_pointer vp, old_e; + s7_pointer(*f) (opt_info * o); + s7_scheme *sc = opt_sc(o); + + old_e = sc->curlet; + s7_gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + + vp = let_dox1_value(do_curlet(o)); + if (is_slot(let_dox_slot2_unchecked(do_curlet(o)))) + end = integer(slot_value(let_dox_slot2(do_curlet(o)))); + else + end = o->v[3].i; + + o1 = do_stepper_init(o); + integer(vp) = integer(o1->v[0].fp(o1)); + + o1 = do_any_body(o); + f = o1->v[0].fp; + if (f == opt_p_pip_ssf) { /* tref.scm */ + opt_info *o2 = o1; + o1 = o2->v[4].o1; + if (o2->v[3].p_pip_f == vector_set_unchecked) { + s7_pointer v = slot_value(o2->v[1].p); + while (integer(vp) < end) { + vector_set_unchecked(o2->sc, v, + integer(slot_value(o2->v[2].p)), + o1->v[0].fp(o1)); + integer(vp)++; + } + } else + while (integer(vp) < end) { + o2->v[3].p_pip_f(o2->sc, slot_value(o2->v[1].p), + integer(slot_value(o2->v[2].p)), + o1->v[0].fp(o1)); + integer(vp)++; + } + } else { + if (f == opt_p_pip_sso) { /* vector-set from vector-ref (i.e. copy), but treating vector-* as generic */ + if (((let_dox_slot1(do_curlet(o)) == o1->v[2].p) + && (o1->v[2].p == o1->v[4].p)) + && (((o1->v[5].p_pip_f == float_vector_set_unchecked_p) + && (o1->v[6].p_pi_f == float_vector_ref_unchecked_p)) + || ((o1->v[5].p_pip_f == int_vector_set_unchecked_p) + && (o1->v[6].p_pi_f == int_vector_ref_unchecked_p)) + || ((o1->v[5].p_pip_f == string_set_unchecked) + && (o1->v[6].p_pi_f == string_ref_unchecked)) + || ((o1->v[5].p_pip_f == byte_vector_set_unchecked_p) + && (o1->v[6].p_pi_f == + byte_vector_ref_unchecked_p)))) { + copy_to_same_type(sc, slot_value(o1->v[1].p), + slot_value(o1->v[3].p), integer(vp), end, + integer(vp)); + unstack(sc); + set_curlet(sc, old_e); + return (sc->T); + } + while (integer(vp) < end) { + o1->v[5].p_pip_f(o1->sc, slot_value(o1->v[1].p), + integer(slot_value(o1->v[2].p)), + o1->v[6].p_pi_f(o1->sc, + slot_value(o1->v[3].p), + integer(slot_value + (o1->v[4].p)))); + integer(vp)++; + } + } else if ((f == opt_set_p_i_f) && /* tvect.scm */ + (is_t_integer(slot_value(o1->v[1].p))) && + (o1->v[1].p != let_dox_slot1(do_curlet(o)))) { + s7_pointer ival; + opt_info *o2; + s7_int(*fi) (opt_info * o); + ival = + make_mutable_integer(sc, integer(slot_value(o1->v[1].p))); + slot_set_value(o1->v[1].p, ival); + o2 = o1->v[5].o1; /* set_p_i_f: x = make_integer(opt_sc(o), o->v[6].fi(o->v[5].o1)); */ + fi = o2->v[0].fi; + while (integer(vp) < end) { + integer(ival) = fi(o2); + integer(vp)++; + } + slot_set_value(o1->v[1].p, + make_integer(sc, + integer(slot_value(o1->v[1].p)))); + } else if ((f == opt_d_7pid_ssf_nr) && /* tref.scm */ + (o1->v[4].d_7pid_f == float_vector_set_unchecked)) { + s7_pointer fv, ind; + opt_info *o2; + s7_double(*fd) (opt_info * o); + o2 = do_any_body(o1); + fv = slot_value(o1->v[1].p); + ind = o1->v[2].p; + fd = o2->v[0].fd; + while (integer(vp) < end) { + float_vector_set_unchecked(sc, fv, + integer(slot_value(ind)), + fd(o2)); + integer(vp)++; + } + } else + while (integer(vp) < end) { + f(o1); + integer(vp)++; + } + } + unstack(sc); + set_curlet(sc, old_e); + return (sc->T); +} + +#define do_prepack_end(o) o->v[1].i +#define do_prepack_stepper(o) o->v[6].p + +static s7_pointer opt_do_prepackaged(opt_info * o) +{ + opt_info *o1; + s7_int end; + s7_pointer vp, old_e; + s7_scheme *sc = opt_sc(o); + + old_e = sc->curlet; + s7_gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + + vp = let_dox1_value(do_curlet(o)); + if (is_slot(let_dox_slot2_unchecked(do_curlet(o)))) + end = integer(slot_value(let_dox_slot2(do_curlet(o)))); + else + end = o->v[3].i; + + o1 = do_stepper_init(o); + integer(vp) = integer(o1->v[0].fp(o1)); + + do_prepack_stepper(o) = vp; + do_prepack_end(o) = end; + o->v[7].fp(o); /* call opt_do_i|dpnr below */ + + unstack(sc); + set_curlet(sc, old_e); + return (sc->T); +} + +static s7_pointer opt_do_dpnr(opt_info * o) +{ + opt_info *o1; + s7_pointer vp; + s7_int end; + s7_double(*f) (opt_info * o); + end = do_prepack_end(o); + vp = do_prepack_stepper(o); + o1 = do_any_body(o); + f = o1->v[O_WRAP].fd; + while (integer(vp) < end) { + f(o1); + integer(vp)++; + } + return (NULL); +} + +static s7_pointer opt_do_ipnr(opt_info * o) +{ + opt_info *o1; + s7_pointer vp; + s7_int end; + s7_int(*f) (opt_info * o); + end = do_prepack_end(o); + vp = do_prepack_stepper(o); + o1 = do_any_body(o); + f = o1->v[O_WRAP].fi; + while (integer(vp) < end) { + f(o1); + integer(vp)++; + } + return (NULL); +} + +static bool stop_is_safe(s7_scheme * sc, s7_pointer stop, s7_pointer body) +{ + /* this could be folded into the cell_optimize traveral */ + s7_pointer p; + for (p = body; is_pair(p); p = cdr(p)) + if ((is_pair(car(p))) && + (caar(p) == sc->set_symbol) && + (is_pair(cdar(p))) && (cadar(p) == stop)) + return (!s7_tree_memq(sc, stop, cdr(p))); + return (true); +} + +static bool tree_has_setters(s7_scheme * sc, s7_pointer tree) +{ + clear_symbol_list(sc); + add_symbol_to_list(sc, sc->set_symbol); + add_symbol_to_list(sc, sc->vector_set_symbol); + add_symbol_to_list(sc, sc->list_set_symbol); + add_symbol_to_list(sc, sc->let_set_symbol); + add_symbol_to_list(sc, sc->hash_table_set_symbol); + add_symbol_to_list(sc, sc->set_car_symbol); + add_symbol_to_list(sc, sc->set_cdr_symbol); + return (tree_set_memq(sc, tree)); +} + +static bool do_is_safe(s7_scheme * sc, s7_pointer body, s7_pointer stepper, + s7_pointer var_list, bool *has_set); + +static bool do_passes_safety_check(s7_scheme * sc, s7_pointer body, + s7_pointer stepper, bool *has_set) +{ + if (!is_pair(body)) + return (true); + if (!is_safety_checked(body)) { + set_safety_checked(body); + if (!(do_is_safe(sc, body, stepper, sc->nil, has_set))) + set_unsafe_do(body); + } + return (!is_unsafe_do(body)); +} + +#define SIZE_O NUM_VUNIONS + +static bool all_integers(s7_scheme * sc, s7_pointer expr) +{ + if ((is_symbol(car(expr))) && (is_all_integer(car(expr)))) { + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!((is_t_integer(car(p))) || ((is_symbol(car(p))) + && + (is_t_integer + (slot_value + (lookup_slot_from + (car(p), sc->curlet))))) + || ((is_pair(car(p))) && (all_integers(sc, car(p)))))) + break; + return (is_null(p)); + } + return (false); +} + +static bool all_floats(s7_scheme * sc, s7_pointer expr) +{ + if ((is_symbol(car(expr))) && (is_all_float(car(expr)))) { + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!((is_t_real(car(p))) || ((is_symbol(car(p))) + && + (is_t_real + (slot_value + (lookup_slot_from + (car(p), sc->curlet))))) + || ((is_pair(car(p))) && (all_floats(sc, car(p)))))) + break; + return (is_null(p)); + } + return (false); +} + +static bool opt_cell_do(s7_scheme * sc, s7_pointer car_x, int32_t len) +{ + opt_info *opc; + s7_pointer p, end, let = NULL, old_e, stop, ind, ind_step; + int32_t i, k, var_len, body_len, body_index, step_len, rtn_len, + step_pc, init_pc, end_test_pc; + bool has_set = false; + opt_info *init_o[SIZE_O], *step_o[SIZE_O], *body_o[SIZE_O], + *return_o[SIZE_O]; + + if (len < 3) + return_false(sc, car_x); + + if (!s7_is_proper_list(sc, cadr(car_x))) + return_false(sc, car_x); + var_len = proper_list_length(cadr(car_x)); + step_len = var_len; + body_len = len - 3; + if (body_len > SIZE_O) + return_false(sc, car_x); + end = caddr(car_x); + if (!is_pair(end)) + return_false(sc, car_x); + + old_e = sc->curlet; + opc = alloc_opo(sc); + + let = make_let(sc, sc->curlet); + push_stack(sc, OP_GC_PROTECT, old_e, let); + + /* the vars have to be added to the let before evaluating the inits + * else symbol_id can be > let_id (see "(test (do ((i (do ((i (do ((i 0 (+ i 1)))...") + */ + clear_symbol_list(sc); + for (p = cadr(car_x); is_pair(p); p = cdr(p)) { + s7_pointer var = car(p); + if ((is_pair(var)) && (is_symbol(car(var))) && (is_pair(cdr(var)))) { + s7_pointer sym = car(var); + + if ((is_constant_symbol(sc, sym)) || (symbol_has_setter(sym))) + return_false(sc, car_x); + if (symbol_is_in_list(sc, sym)) + eval_error(sc, "duplicate identifier in do: ~A", 30, var); + add_symbol_to_list(sc, sym); + add_slot(sc, let, sym, sc->undefined); + } else + return_false(sc, car_x); + } + if (tis_slot(let_slots(let))) + let_set_slots(let, reverse_slots(sc, let_slots(let))); + + /* inits */ + { + s7_pointer slot; + init_pc = sc->pc; + + for (k = 0, p = cadr(car_x), slot = let_slots(let); + (is_pair(p)) && (k < SIZE_O); + k++, p = cdr(p), slot = next_slot(slot)) { + s7_pointer var = car(p); + init_o[k] = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdr(var))) /* opt init in outer let */ + return_false(sc, car_x); + if (is_pair(cddr(var))) { + set_has_stepper(slot); + if (!is_null(cdddr(var))) + return_false(sc, car_x); + } else { + step_len--; + if (!is_null(cddr(var))) + return_false(sc, car_x); + } + /* we can't use slot_set_value(slot, init_o[k]->v[0].fp(init_o[k])) to get the init value here: it might involve side-effects, + * and in some contexts might access variables that aren't set up yet. So, we kludge around... + */ + if (is_symbol(cadr(var))) + slot_set_value(slot, + slot_value(lookup_slot_from + (cadr(var), sc->curlet))); + else if (!is_pair(cadr(var))) + slot_set_value(slot, cadr(var)); + else if (is_proper_quote(sc, cadr(var))) + slot_set_value(slot, cadadr(var)); + else { + s7_pointer sf; + sf = lookup_checked(sc, caadr(var)); + if (is_c_function(sf)) { + s7_pointer sig = c_function_signature(sf); + if (is_pair(sig)) { + if ((car(sig) == sc->is_integer_symbol) || + ((is_pair(car(sig))) && + (direct_memq + (sc->is_integer_symbol, car(sig)))) + || (all_integers(sc, cadr(var)))) + slot_set_value(slot, int_zero); + else if ((car(sig) == sc->is_float_symbol) || + ((is_pair(car(sig))) && + (direct_memq + (sc->is_float_symbol, car(sig)))) + || (all_floats(sc, cadr(var)))) + slot_set_value(slot, real_zero); + /* need for stepper too -- how does it know (+ x 0.1) is float? try (i 0 (floor (+ i 1))) etc */ + } + } + } + } + set_curlet(sc, let); + for (p = cadr(car_x); is_pair(p); p = cdr(p)) { + s7_pointer var = car(p); + if (is_pair(cddr(var))) { + s7_pointer init_type; + init_type = opt_arg_type(sc, cdr(var)); + if (((init_type == sc->is_integer_symbol) || + (init_type == sc->is_float_symbol)) && + (opt_arg_type(sc, cddr(var)) != init_type)) { + unstack(sc); /* not pop_stack! */ + set_curlet(sc, old_e); + return_false(sc, car_x); + } + } + } + } + + /* end test */ + end_test_pc = sc->pc; + if (!bool_optimize_nw(sc, end)) { + unstack(sc); /* not pop_stack! */ + set_curlet(sc, old_e); + return_false(sc, car_x); + } + + stop = car(end); + if ((is_proper_list_3(sc, stop)) && + ((car(stop) == sc->num_eq_symbol) || (car(stop) == sc->geq_symbol) + || (car(stop) == sc->gt_symbol)) && (is_symbol(cadr(stop))) + && ((is_t_integer(caddr(stop))) || (is_symbol(caddr(stop))))) { + s7_pointer stop_slot; + stop_slot = + (is_symbol(caddr(stop))) ? opt_integer_symbol(sc, + caddr(stop)) : + sc->nil; + if (stop_slot) { + s7_int lim; + bool set_stop = false; + s7_pointer slot; + + lim = + (is_slot(stop_slot)) ? integer(slot_value(stop_slot)) : + integer(caddr(stop)); + if (car(stop) == sc->gt_symbol) + lim++; + + for (p = cadr(car_x), slot = let_slots(let); is_pair(p); + p = cdr(p), slot = next_slot(slot)) { + /* this could be put off until it is needed (ref/set), but this code is not called much + * another choice: go from init downto 0: init is lim + */ + if (slot_symbol(slot) == cadr(stop)) + set_stop = true; /* don't overrule this decision below */ + if (has_stepper(slot)) { + s7_pointer var = car(p), step = caddr(var); + if ((is_t_integer(slot_value(slot))) && (is_pair(step)) && (is_pair(cdr(step))) && (car(var) == cadr(stop)) && (car(var) == cadr(step)) && ((car(stop) != sc->num_eq_symbol) || /* else > protects at least the top */ + ((caddr(step) == int_one) && (car(step) == sc->add_symbol)))) { + set_step_end(slot); + slot_set_value(slot, + make_mutable_integer(sc, + integer + (slot_value + (slot)))); + set_do_loop_end(slot_value(slot), lim); + } + } + } + + if (!set_stop) { + s7_pointer slot2; + slot2 = opt_integer_symbol(sc, cadr(stop)); + if ((slot2) && (stop_is_safe(sc, cadr(stop), cddr(car_x)))) { + set_step_end(slot2); + set_do_loop_end(slot_value(slot2), lim); + } + } + } + } + + /* body */ + body_index = sc->pc; + for (k = 0, i = 3, p = cdddr(car_x); i < len; k++, i++, p = cdr(p)) { + opt_info *start = sc->opts[sc->pc]; + body_o[k] = start; + if (i < 5) + opc->v[i + 7].o1 = start; + if (!cell_optimize(sc, p)) + break; + oo_idp_nr_fixup(start); + } + if (!is_null(p)) { + unstack(sc); + set_curlet(sc, old_e); + return_false(sc, car_x); + } + + /* we faked up sc->curlet above, so s7_optimize_1 (float_optimize) isn't safe here + * this means if clm nested loops get here, they aren't fully optimized -- fallback into dox would be better + */ + /* steps */ + step_pc = sc->pc; + for (k = 0, p = cadr(car_x); is_pair(p); k++, p = cdr(p)) { + s7_pointer var = car(p); + step_o[k] = sc->opts[sc->pc]; + if ((is_pair(cddr(var))) && (!cell_optimize(sc, cddr(var)))) + break; + } + if (!is_null(p)) { + unstack(sc); + set_curlet(sc, old_e); + return_false(sc, car_x); + } + + /* result */ + if (!is_list(cdr(end))) { + unstack(sc); + set_curlet(sc, old_e); + return_false(sc, car_x); + } + for (rtn_len = 0, p = cdr(end); (is_pair(p)) && (rtn_len < SIZE_O); + p = cdr(p), rtn_len++) { + return_o[rtn_len] = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } + if (!is_null(p)) { + unstack(sc); + set_curlet(sc, old_e); + return_false(sc, car_x); + } + + do_curlet(opc) = let; + do_body_length(opc) = len - 3; + do_result_length(opc) = rtn_len; + + opc->v[9].o1 = sc->opts[step_pc]; + set_curlet(sc, old_e); + + if ((var_len == 0) && (rtn_len == 0)) { + opt_info *body; + do_no_vars_test(opc) = sc->opts[end_test_pc]; + opc->v[0].fp = opt_do_no_vars; + if (body_len > 0) { + body = alloc_opo(sc); + for (k = 0; k < body_len; k++) + body->v[k].o1 = body_o[k]; + do_no_vars_body(opc) = body; + } + return (true); + } + opc->v[8].i = 0; + if (body_len == 1) { + s7_pointer expr = cadddr(car_x); + if ((is_pair(expr)) && ((is_safe_setter(car(expr))) || ((car(expr) == sc->set_symbol) && (cadr(expr) != caaadr(car_x))) || /* caadr: (stepper init ...) */ + ((car(expr) == sc->vector_set_symbol) && + (is_null(cddddr(expr))) && + (is_code_constant(sc, cadddr(expr)))))) + opc->v[8].i = 1; + } + if ((var_len != 1) || (step_len != 1) || (rtn_len != 0)) { + opt_info *inits; + + opc->v[0].fp = ((step_len == 1) && (body_len == 1) + && (rtn_len == 1)) ? opt_do_step_1 : opt_do_any; + /* (do ((sum 0.0) (k 0 (+ k 1))) ((= k size) (set! (C i j) sum)) (set! sum (+ sum (* (A i k) (B k j))))) tmat */ + + do_any_test(opc) = sc->opts[end_test_pc]; + + if ((opc->v[0].fp == opt_do_step_1) && + (opc->v[9].o1->v[0].fp == i_to_p) && + (opc->v[9].o1->v[O_WRAP].fi == opt_i_ii_sc_add) && + (do_any_test(opc)->v[0].fb == opt_b_ii_ss_eq)) + opc->v[0].fp = opt_do_step_i; + + inits = alloc_opo(sc); + for (k = 0; k < var_len; k++) + inits->v[k].o1 = init_o[k]; + do_any_inits(opc) = inits; + + if (opc->v[0].fp == opt_do_any) { + opt_info *body, *result, *step; + + body = alloc_opo(sc); + for (k = 0; k < body_len; k++) + body->v[k].o1 = body_o[k]; + do_any_body(opc) = body; + + result = alloc_opo(sc); + for (k = 0; k < rtn_len; k++) + result->v[k].o1 = return_o[k]; + do_any_results(opc) = result; + + step = alloc_opo(sc); + for (k = 0; k < var_len; k++) + step->v[k].o1 = step_o[k]; + do_any_steps(opc) = step; + } else { + do_any_body(opc) = sc->opts[body_index]; + do_any_results(opc) = return_o[0]; + } + return (true); + } + + opc->v[0].fp = (body_len == 1) ? opt_do_1 : opt_do_n; + p = caadr(car_x); + ind = car(p); + ind_step = caddr(p); + end = caaddr(car_x); + + if (body_len == 1) /* opt_do_1 */ + do_any_body(opc) = sc->opts[body_index]; + else { + opt_info *body; + body = alloc_opo(sc); + for (k = 0; k < body_len; k++) + body->v[k].o1 = body_o[k]; + do_n_body(opc) = body; + } + do_stepper_init(opc) = sc->opts[init_pc]; + do_any_test(opc) = sc->opts[end_test_pc]; + do_any_steps(opc) = sc->opts[step_pc]; + + if ((is_pair(end)) && /* (= i len|100) */ + (cadr(end) == ind) && (is_pair(ind_step))) { /* (+ i 1) */ + /* we can't use step_end_ok here yet (not set except for op_dox?) */ + if (((car(end) == sc->num_eq_symbol) + || (car(end) == sc->geq_symbol)) && ((is_symbol(caddr(end))) + || + (is_t_integer + (caddr(end)))) + && (is_null(cdddr(end))) && (car(ind_step) == sc->add_symbol) + && (cadr(ind_step) == ind) && (caddr(ind_step) == int_one) + && (is_null(cdddr(ind_step))) + && (do_passes_safety_check(sc, cdddr(car_x), ind, &has_set))) { + s7_pointer slot = let_slots(let); + let_set_dox_slot1(let, slot); + let_set_dox_slot2_unchecked(let, + (is_symbol(caddr(end))) ? + lookup_slot_from(caddr(end), + sc-> + curlet) : + sc->undefined); + slot_set_value(slot, + make_mutable_integer(sc, + integer(slot_value + (slot)))); + opc->v[4].i = body_index; + if (body_len == 1) { /* opt_do_1 */ + opt_info *o1; + opc->v[0].fp = opt_do_very_simple; + if (is_t_integer(caddr(end))) + opc->v[3].i = integer(caddr(end)); + o1 = sc->opts[body_index]; + if (o1->v[0].fp == d_to_p_nr) { /* snd-test: (do ((k 0 (+ k 1))) ((= k N)) (float-vector-set! rl k (read-sample rd))) */ + opc->v[0].fp = opt_do_prepackaged; + opc->v[7].fp = opt_do_dpnr; + } else if (o1->v[0].fp == i_to_p_nr) { + opc->v[0].fp = opt_do_prepackaged; + opc->v[7].fp = opt_do_ipnr; + } + } else { + opc->v[0].fp = opt_dotimes_2; + if (is_t_integer(caddr(end))) + opc->v[6].i = integer(caddr(end)); + } + } else + if ((car(end) == sc->is_null_symbol) && + (is_null(cddr(end))) && + (car(ind_step) == sc->cdr_symbol) && + (cadr(ind_step) == ind) && + (is_null(cddr(ind_step))) && + (body_len == 1) && + (do_passes_safety_check(sc, cdddr(car_x), ind, &has_set))) + opc->v[0].fp = opt_do_list_simple; + } + return (true); +} + +static bool p_syntax(s7_scheme * sc, s7_pointer car_x, int32_t len) +{ + opcode_t op; + s7_pointer func; + func = lookup_global(sc, car(car_x)); + if (!is_syntax(func)) { + clear_syntactic(car_x); + return (false); + } + /* I think this is the only case where we don't precede syntax_opcode with syntactic_symbol checks */ + op = (opcode_t) syntax_opcode(func); + switch (op) { + case OP_QUOTE: + if ((is_pair(cdr(car_x))) && (is_null(cddr(car_x)))) + return (opt_cell_quote(sc, car_x)); + break; + case OP_SET: + if (len == 3) + return (opt_cell_set(sc, car_x)); + break; + case OP_BEGIN: + if (len > 1) + return (opt_cell_begin(sc, car_x, len)); + break; + case OP_WHEN: + case OP_UNLESS: + if (len > 2) + return (opt_cell_when(sc, car_x, len)); + break; + case OP_COND: + if (len > 1) + return (opt_cell_cond(sc, car_x)); + break; + case OP_CASE: + if (len > 2) + return (opt_cell_case(sc, car_x)); + break; + case OP_AND: + case OP_OR: + return (opt_cell_and(sc, car_x, len)); + case OP_IF: + return (opt_cell_if(sc, car_x, len)); + case OP_DO: + return (opt_cell_do(sc, car_x, len)); + case OP_LET_TEMPORARILY: + return (opt_cell_let_temporarily(sc, car_x, len)); + default: /* lambda let/let* with-let define etc */ + break; + } + return_false(sc, car_x); +} + + +/* -------------------------------------------------------------------------------- */ +static bool float_optimize_1(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer car_x = car(expr), head; + if (!is_pair(car_x)) /* wrap constants/symbols */ + return (opt_float_not_pair(sc, car_x)); + + head = car(car_x); + if (is_symbol(head)) { + /* get func, check sig, check all args */ + s7_pointer s_func, s_slot; + s7_int len; + len = s7_list_length(sc, car_x); + + if ((is_syntactic_symbol(head)) || (is_syntactic_pair(car_x))) + return (d_syntax_ok(sc, car_x, len)); + + s_slot = lookup_slot_from(head, sc->curlet); + if (!is_slot(s_slot)) + return_false(sc, car_x); + s_func = slot_value(s_slot); + if (is_c_function(s_func)) { + opt_info *opc; + opc = alloc_opo(sc); + switch (len) { + case 1: + if (d_ok(sc, opc, s_func)) + return (true); + break; + + case 2: /* (f v) or (f d): (env e) or (abs x) */ + if ((d_d_ok(sc, opc, s_func, car_x)) || + (d_v_ok(sc, opc, s_func, car_x)) || + (d_p_ok(sc, opc, s_func, car_x))) + return (true); + break; + + case 3: + if ((d_dd_ok(sc, opc, s_func, car_x)) || + (d_id_ok(sc, opc, s_func, car_x)) || + (d_vd_ok(sc, opc, s_func, car_x)) || + (d_pd_ok(sc, opc, s_func, car_x)) || + (d_ip_ok(sc, opc, s_func, car_x)) || + (d_7pi_ok(sc, opc, s_func, car_x))) + return (true); + break; + + case 4: + if ((d_ddd_ok(sc, opc, s_func, car_x)) || + (d_7pid_ok(sc, opc, s_func, car_x)) || + (d_vid_ok(sc, opc, s_func, car_x)) || + (d_vdd_ok(sc, opc, s_func, car_x)) || + (d_7pii_ok(sc, opc, s_func, car_x))) + return (true); + break; + + case 5: + if ((d_dddd_ok(sc, opc, s_func, car_x)) || + (d_7piid_ok(sc, opc, s_func, car_x)) || + (d_7piii_ok(sc, opc, s_func, car_x))) + return (true); + break; + + case 6: + if (d_7piiid_ok(sc, opc, s_func, car_x)) + return (true); + break; + + default: + if (d_add_any_ok(sc, opc, car_x, len)) + return (true); + break; + } + } else { + /* this is not good -- we're evaluating the macro body! Need something much smarter or ensure body simplicity and safety (no side-effects etc) */ + if ((is_macro(s_func)) && (!no_cell_opt(expr))) + return (float_optimize(sc, set_plist_1(sc, s7_macroexpand(sc, s_func, cdar(expr))))); /* is this use of plist safe? */ + return (d_implicit_ok(sc, s_slot, car_x, len)); + } + } + return_false(sc, car_x); +} + +static bool float_optimize(s7_scheme * sc, s7_pointer expr) +{ + return ((float_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE)); +} + +static bool int_optimize_1(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer car_x = car(expr), head; + + if (!is_pair(car_x)) /* wrap constants/symbols */ + return (opt_int_not_pair(sc, car_x)); + + head = car(car_x); + if (is_symbol(head)) { + s7_pointer s_func, s_slot; + s7_int len; + len = s7_list_length(sc, car_x); + if ((is_syntactic_symbol(head)) || (is_syntactic_pair(car_x))) + return (i_syntax_ok(sc, car_x, len)); + + s_slot = lookup_slot_from(head, sc->curlet); + if (!is_slot(s_slot)) + return_false(sc, car_x); + s_func = slot_value(s_slot); + if (is_c_function(s_func)) { + opt_info *opc; + opc = alloc_opo(sc); + switch (len) { + case 2: + if (i_idp_ok(sc, opc, s_func, car_x)) + return (true); + break; + + case 3: + if ((i_ii_ok(sc, opc, s_func, car_x)) || + (i_7pi_ok(sc, opc, s_func, car_x))) + return (true); + break; + + case 4: + if ((i_iii_ok(sc, opc, s_func, car_x)) || + (i_7pii_ok(sc, opc, s_func, car_x))) + return (true); + break; + + case 5: + { + int32_t pstart = sc->pc; + if (i_7piii_ok(sc, opc, s_func, car_x)) + return (true); + pc_fallback(sc, pstart); + } + /* break; */ + + default: + if (((head == sc->add_symbol) || + (head == sc->multiply_symbol)) && + (i_add_any_ok(sc, opc, car_x))) + return (true); + break; + } + } else { + if ((is_macro(s_func)) && (!no_cell_opt(expr))) + return (int_optimize + (sc, + set_plist_1(sc, + s7_macroexpand(sc, s_func, + cdar(expr))))); + return (i_implicit_ok(sc, s_slot, car_x, len)); + } + } + return_false(sc, car_x); +} + +static bool int_optimize(s7_scheme * sc, s7_pointer expr) +{ + return ((int_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE)); +} + +static bool cell_optimize_1(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer car_x = car(expr), head; + if (!is_pair(car_x)) /* wrap constants/symbols */ + return (opt_cell_not_pair(sc, car_x)); + + head = car(car_x); + if (is_symbol(head)) { + s7_pointer s_func, s_slot; + s7_int len; + len = s7_list_length(sc, car_x); + + if ((is_syntactic_symbol(head)) || (is_syntactic_pair(car_x))) /* this can be wrong! */ + return (p_syntax(sc, car_x, len)); + + s_slot = lookup_slot_from(head, sc->curlet); + if (!is_slot(s_slot)) + return_false(sc, car_x); + s_func = slot_value(s_slot); + if (is_c_function(s_func)) { + opt_info *opc; + s7_pointer sig = c_function_signature(s_func); + int32_t pstart; + + opc = alloc_opo(sc); + pstart = sc->pc; + + switch (len) { + case 1: + if (p_ok(sc, opc, s_func, car_x)) + return (true); + break; + + case 2: + if ((p_i_ok(sc, opc, s_func, car_x, sc->pc)) || + (p_d_ok(sc, opc, s_func, car_x, sc->pc)) || + (p_p_ok(sc, opc, s_func, car_x))) + return (true); + break; + + case 3: + { + s7_i_ii_t ifunc; + if (is_symbol(cadr(car_x))) { + if ((is_pair(sig)) && + (is_pair(cdr(sig))) && + (is_pair(cddr(sig))) && + (caddr(sig) == sc->is_integer_symbol)) { + if (p_pi_ok(sc, opc, s_func, sig, car_x)) + return (true); + + if ((car(sig) == sc->is_float_symbol) || + (car(sig) == sc->is_real_symbol)) { + s7_d_7pi_t f; + f = s7_d_7pi_function(s_func); + if (f) { + sc->pc = pstart - 1; + if (float_optimize(sc, expr)) { + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; + return (true); + } + } + } + } + pc_fallback(sc, pstart); + } + + ifunc = s7_i_ii_function(s_func); + sc->pc = pstart - 1; + if ((ifunc) && (int_optimize(sc, expr))) { + opc->v[O_WRAP].fi = opc->v[0].fi; + opc->v[0].fp = i_to_p; + if (opc->v[O_WRAP].fi == opt_i_ii_ss_add) + opc->v[0].fp = opt_p_ii_ss_add; + return (true); + } + pc_fallback(sc, pstart); + + if ((p_ii_ok(sc, opc, s_func, car_x, pstart)) || + (p_dd_ok(sc, opc, s_func, car_x, pstart)) || + (p_pp_ok(sc, opc, s_func, car_x, pstart)) || + (p_call_pp_ok(sc, opc, s_func, car_x, pstart))) + return (true); + } + break; + + case 4: + if (is_symbol(cadr(car_x))) { + if ((is_pair(sig)) && + (is_pair(cdr(sig))) && + (is_pair(cddr(sig))) && + (caddr(sig) == sc->is_integer_symbol)) { + if (p_pii_ok(sc, opc, s_func, car_x)) + return (true); + if (p_pip_ok(sc, opc, s_func, car_x)) + return (true); + + if (((car(sig) == sc->is_float_symbol) || + (car(sig) == sc->is_real_symbol)) && + (s7_d_7pid_function(s_func)) && + (d_7pid_ok(sc, opc, s_func, car_x))) { + /* if d_7pid is ok, we need d_to_p for cell_optimize */ + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; + return (true); + } + + sc->pc = pstart - 1; + if ((car(sig) == sc->is_integer_symbol) && + (s7_i_7pii_function(s_func)) && + (i_7pii_ok(sc, alloc_opo(sc), s_func, car_x))) + { + opc->v[O_WRAP].fi = opc->v[0].fi; + opc->v[0].fp = i_to_p; + return (true); + } + } + pc_fallback(sc, pstart); + } + if ((p_ppi_ok(sc, opc, s_func, car_x)) || + (p_ppp_ok(sc, opc, s_func, car_x)) || + (p_call_ppp_ok(sc, opc, s_func, car_x))) + return (true); + break; + + case 5: + if ((is_target_or_its_alias + (head, s_func, sc->float_vector_set_symbol)) + && (d_7piid_ok(sc, opc, s_func, car_x))) { + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; /* as above, if d_7piid is ok, we need d_to_p for cell_optimize */ + return (true); + } + if ((is_target_or_its_alias + (head, s_func, sc->float_vector_ref_symbol)) + && (d_7piii_ok(sc, opc, s_func, car_x))) { + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; + return (true); + } + if (i_7piii_ok(sc, opc, s_func, car_x)) { + opc->v[O_WRAP].fi = opc->v[0].fi; + opc->v[0].fp = i_to_p; + return (true); + } + if (is_target_or_its_alias + (head, s_func, sc->int_vector_set_symbol)) + return_false(sc, car_x); + if (p_piip_ok(sc, opc, s_func, car_x)) + return (true); + pc_fallback(sc, pstart); + if (p_call_any_ok(sc, opc, s_func, car_x, len)) + return (true); + break; + + case 6: + if ((is_target_or_its_alias + (head, s_func, sc->float_vector_set_symbol)) + && (d_7piiid_ok(sc, opc, s_func, car_x))) { + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; + return (true); + } + + default: /* >3D vector-set etc */ + if (p_call_any_ok(sc, opc, s_func, car_x, len)) + return (true); + break; + } + } else { + if (is_closure(s_func)) { + opt_info *opc; + opc = alloc_opo(sc); + if (p_fx_any_ok(sc, opc, s_func, expr)) + return (true); + } + if (is_macro(s_func)) + return_false(sc, car_x); /* macroexpand+cell_optimize here restarts the optimize process */ + return (p_implicit_ok(sc, s_slot, car_x, len)); + } + } + return_false(sc, car_x); +} + +static bool cell_optimize(s7_scheme * sc, s7_pointer expr) +{ + return ((cell_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE)); +} + +static bool bool_optimize_nw_1(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer car_x = car(expr), head; + if (!is_pair(car_x)) /* wrap constants/symbols */ + return (opt_bool_not_pair(sc, car_x)); + + head = car(car_x); + if (is_symbol(head)) { + s7_pointer s_func; + s7_int len; + len = s7_list_length(sc, car_x); + + if ((is_syntactic_symbol(head)) || (is_syntactic_pair(car_x))) { + if (head == sc->and_symbol) + return (opt_b_and(sc, car_x, len)); + if (head == sc->or_symbol) + return (opt_b_or(sc, car_x, len)); + return_false(sc, car_x); + } + s_func = lookup_unexamined(sc, head); + if (!s_func) + return_false(sc, car_x); + if (is_c_function(s_func)) { + if (symbol_id(head) != 0) /* (float-vector? (block)) -- both safe c_funcs, but this is a method invocation */ + return_false(sc, car_x); + switch (len) { + case 2: + return (b_idp_ok + (sc, s_func, car_x, opt_arg_type(sc, cdr(car_x)))); + + case 3: + { + s7_b_pp_t bpf; + s7_b_7pp_t bpf7 = NULL; + bpf = s7_b_pp_function(s_func); + if (!bpf) + bpf7 = s7_b_7pp_function(s_func); + if ((bpf) || (bpf7)) { + opt_info *opc; + s7_pointer sig1, sig2, arg1 = cadr(car_x), arg2 = + caddr(car_x); + + opc = alloc_opo(sc); + sig1 = opt_arg_type(sc, cdr(car_x)); + sig2 = opt_arg_type(sc, cddr(car_x)); + if (sig2 == sc->is_integer_symbol) { + int32_t cur_index = sc->pc; + + if ((sig1 == sc->is_integer_symbol) && + (b_ii_ok + (sc, opc, s_func, car_x, arg1, arg2))) + return (true); + pc_fallback(sc, cur_index); + + if ((!is_pair(arg2)) && + (b_pi_ok(sc, opc, s_func, car_x, arg2))) + return (true); + pc_fallback(sc, cur_index); + } + + if ((sig1 == sc->is_float_symbol) && + (sig2 == sc->is_float_symbol) && + (b_dd_ok(sc, opc, s_func, car_x, arg1, arg2))) + return (true); + + if (bpf) + opc->v[3].b_pp_f = bpf; + else + opc->v[3].b_7pp_f = bpf7; + return (b_pp_ok + (sc, opc, s_func, car_x, arg1, arg2, + bpf != NULL)); + } + } + break; + + default: + break; + } + } else if (is_macro(s_func)) + return_false(sc, car_x); + } + return_false(sc, car_x); +} + +static bool bool_optimize_nw(s7_scheme * sc, s7_pointer expr) +{ + return ((bool_optimize_nw_1(sc, expr)) && (sc->pc < OPTS_SIZE)); +} + +static bool bool_optimize(s7_scheme * sc, s7_pointer expr) +{ + int32_t start = sc->pc; + opt_info *wrapper; + if (bool_optimize_nw(sc, expr)) + return (true); + pc_fallback(sc, start); + wrapper = sc->opts[start]; + if (!cell_optimize(sc, expr)) + return_false(sc, NULL); + if (wrapper->v[O_WRAP].fp) /* (when (+ i 1) ...) */ + return_false(sc, NULL); + wrapper->v[O_WRAP].fp = wrapper->v[0].fp; + wrapper->v[0].fb = p_to_b; + return (true); +} + +static s7_pfunc s7_bool_optimize(s7_scheme * sc, s7_pointer expr) +{ + sc->pc = 0; + if ((bool_optimize(sc, expr)) && (sc->pc < OPTS_SIZE)) + return_true(sc, opt_bool_any, expr); + return_null(sc, expr); +} + +/* snd-sig.c experiment */ +static s7_double opt_float_any(s7_scheme * sc) +{ + return (sc->opts[0]->v[0].fd(sc->opts[0])); +} + +s7_float_function s7_float_optimize(s7_scheme * sc, s7_pointer expr) +{ + sc->pc = 0; + if ((float_optimize(sc, expr)) && (sc->pc < OPTS_SIZE)) + return (opt_float_any); + return (NULL); +} + +static s7_pfunc s7_optimize_1(s7_scheme * sc, s7_pointer expr, bool nr) +{ + if ((!is_pair(expr)) || (no_cell_opt(expr)) || (sc->debug != 0)) + return (NULL); + sc->pc = 0; + if (!no_int_opt(expr)) { + if (int_optimize(sc, expr)) + return ((nr) ? opt_int_any_nr : opt_wrap_int); + pc_fallback(sc, 0); + set_no_int_opt(expr); + } + if (!no_float_opt(expr)) { + if (float_optimize(sc, expr)) + return_true(sc, (nr) ? opt_float_any_nr : opt_wrap_float, + expr); + pc_fallback(sc, 0); + set_no_float_opt(expr); + } + if (!no_bool_opt(expr)) { + if (bool_optimize_nw(sc, expr)) + return_true(sc, (nr) ? opt_bool_any_nr : opt_wrap_bool, expr); + pc_fallback(sc, 0); + set_no_bool_opt(expr); + } + if (cell_optimize(sc, expr)) + return_true(sc, (nr) ? opt_cell_any_nr : opt_wrap_cell, expr); + set_no_cell_opt(expr); /* checked above */ + return_null(sc, expr); +} + +s7_pfunc s7_optimize(s7_scheme * sc, s7_pointer expr) +{ + return (s7_optimize_1(sc, expr, false)); +} + +s7_pfunc s7_optimize_nr(s7_scheme * sc, s7_pointer expr) +{ + return (s7_optimize_1(sc, expr, true)); +} + +static s7_pointer g_optimize(s7_scheme * sc, s7_pointer args) +{ + s7_pfunc f; + s7_pointer code = car(args); + f = s7_optimize(sc, code); + return ((f) ? f(sc) : sc->undefined); +} + +static s7_pfunc s7_cell_optimize(s7_scheme * sc, s7_pointer expr, bool nr) +{ + sc->pc = 0; + if ((cell_optimize(sc, expr)) && (sc->pc < OPTS_SIZE)) + return ((nr) ? opt_cell_any_nr : opt_wrap_cell); + return (NULL); +} + + +/* ---------------- bool funcs (an experiment) ---------------- */ +typedef bool (*s7_bfunc)(s7_scheme * sc, s7_pointer expr); + +static bool fb_lt_ss(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer x, y; + x = lookup(sc, cadr(expr)); + y = lookup(sc, opt2_sym(cdr(expr))); + return (((is_t_integer(x)) + && (is_t_integer(y))) ? (integer(x) < + integer(y)) : lt_b_7pp(sc, x, y)); +} + +static bool fb_num_eq_ss(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer x, y; + x = lookup(sc, cadr(expr)); + y = lookup(sc, opt2_sym(cdr(expr))); + return (((is_t_integer(x)) + && (is_t_integer(y))) ? (integer(x) == + integer(y)) : num_eq_b_7pp(sc, x, + y)); +} + +static bool fb_num_eq_s0(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer x; + x = lookup(sc, cadr(expr)); + return ((is_t_integer(x)) ? (integer(x) == 0) : + num_eq_b_7pp(sc, x, int_zero)); +} + +static bool fb_num_eq_s0f(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer x; + x = lookup(sc, cadr(expr)); + return ((is_t_real(x)) ? (real(x) == 0.0) : + num_eq_b_7pp(sc, x, real_zero)); +} + +static bool fb_gt_tu(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer x, y; + x = t_lookup(sc, cadr(expr), expr); + y = u_lookup(sc, opt2_sym(cdr(expr)), expr); + return (((is_t_integer(x)) + && (is_t_integer(y))) ? (integer(x) > + integer(y)) : gt_b_7pp(sc, x, y)); +} + +static bool fb_gt_ss(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer x, y; + x = s_lookup(sc, cadr(expr), expr); + y = s_lookup(sc, opt2_sym(cdr(expr)), expr); + return (((is_t_integer(x)) + && (is_t_integer(y))) ? (integer(x) > + integer(y)) : gt_b_7pp(sc, x, y)); +} + +static bool fb_geq_ss(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer x, y; + x = s_lookup(sc, cadr(expr), expr); + y = s_lookup(sc, opt2_sym(cdr(expr)), expr); + return (((is_t_integer(x)) + && (is_t_integer(y))) ? (integer(x) >= + integer(y)) : geq_b_7pp(sc, x, y)); +} + +static bool fb_leq_ss(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer x, y; + x = s_lookup(sc, cadr(expr), expr); + y = s_lookup(sc, opt2_sym(cdr(expr)), expr); + return (((is_t_integer(x)) + && (is_t_integer(y))) ? (integer(x) <= + integer(y)) : leq_b_7pp(sc, x, y)); +} + +static s7_pointer fx_to_fb(s7_scheme * sc, s7_function fx) +{ /* eventually parallel arrays? */ + if (fx == fx_num_eq_ss) + return ((s7_pointer) fb_num_eq_ss); + if (fx == fx_lt_ss) + return ((s7_pointer) fb_lt_ss); + if (fx == fx_gt_ss) + return ((s7_pointer) fb_gt_ss); + if (fx == fx_leq_ss) + return ((s7_pointer) fb_leq_ss); + if (fx == fx_geq_ss) + return ((s7_pointer) fb_geq_ss); + if (fx == fx_gt_tu) + return ((s7_pointer) fb_gt_tu); + if (fx == fx_num_eq_s0) + return ((s7_pointer) fb_num_eq_s0); + if (fx == fx_num_eq_s0f) + return ((s7_pointer) fb_num_eq_s0f); + return (NULL); +} + +/* when_b cond? do end-test? num_eq_vs|us */ + + +/* ---------------------------------------- for-each ---------------------------------------- */ + +static Inline s7_pointer make_counter(s7_scheme * sc, s7_pointer iter) +{ + s7_pointer x; + new_cell(sc, x, T_COUNTER); + counter_set_result(x, sc->nil); + counter_set_list(x, iter); /* iterator -- here it's always either an iterator or a pair */ + counter_set_capture(x, 0); /* will be capture_let_counter */ + counter_set_let(x, sc->nil); /* will be the saved let */ + counter_set_slots(x, sc->nil); /* local let slots before body is evalled */ + stack_set_has_counters(sc->stack); + return (x); +} + +static s7_pointer make_iterators(s7_scheme * sc, s7_pointer args) +{ + s7_pointer p; + sc->temp3 = args; + sc->z = sc->nil; /* don't use sc->args here -- it needs GC protection until we get the iterators */ + for (p = cdr(args); is_pair(p); p = cdr(p)) { + s7_pointer iter = car(p); + if (!is_iterator(car(p))) + iter = s7_make_iterator(sc, iter); + sc->z = cons(sc, iter, sc->z); + } + sc->temp3 = sc->nil; + return (proper_list_reverse_in_place(sc, sc->z)); +} + +static s7_pointer seq_init(s7_scheme * sc, s7_pointer seq) +{ + if (is_float_vector(seq)) + return (real_zero); + if (is_string(seq)) + return (chars[65]); + if ((is_int_vector(seq)) || (is_byte_vector(seq))) + return (int_zero); + return (sc->F); +} + +#define MUTLIM 32 /* was 1000 */ + +#define for_each_any_list(Code) \ + do { \ + for (x = seq, y = x; is_pair(x); ) \ + { \ + slot_set_value(slot, car(x)); \ + Code; \ + x = cdr(x); \ + if (is_pair(x)) \ + { \ + slot_set_value(slot, car(x)); \ + Code; \ + y = cdr(y); x = cdr(x); \ + if (x == y) break; \ + }}} while (0) + +static s7_pointer g_for_each_closure(s7_scheme * sc, s7_pointer f, + s7_pointer seq) +{ /* one sequence arg */ + s7_pointer body = closure_body(f); + if (!no_cell_opt(body)) { /* if at top level we often get an unoptimized (not safe) function here that can be cell_optimized below */ + s7_pfunc func; + s7_pointer old_e = sc->curlet, pars = closure_args(f), val, slot; + + val = seq_init(sc, seq); + sc->curlet = + make_let_with_slot(sc, closure_let(f), + (is_pair(car(pars))) ? caar(pars) : + car(pars), val); + slot = let_slots(sc->curlet); + + if (is_null(cdr(body))) + func = s7_optimize_nr(sc, body); + else if (is_null(cddr(body))) { /* 3 sometimes works */ + set_ulist_1(sc, sc->begin_symbol, body); + func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); /* was list_1 via cons 8-Apr-21, true=nr */ + } else + func = NULL; + if (func) { + s7_int(*fi) (opt_info * o); + opt_info *o; + if (is_pair(seq)) { + s7_pointer x, y; + if (func == opt_cell_any_nr) { /* this block saves less than 0.5% */ + o = sc->opts[0]; + for_each_any_list(o->v[0].fp(o)); + } else + for_each_any_list(func(sc)); + return (sc->unspecified); + } + if (is_float_vector(seq)) { + s7_double *vals = float_vector_floats(seq); + s7_int i, len = vector_length(seq); + if ((len > MUTLIM) && (!tree_has_setters(sc, body))) { + s7_pointer sv; + sv = s7_make_mutable_real(sc, 0.0); + slot_set_value(slot, sv); + if (func == opt_float_any_nr) { + s7_double(*fd) (opt_info * o); + o = sc->opts[0]; + fd = o->v[0].fd; + for (i = 0; i < len; i++) { + real(sv) = vals[i]; + fd(o); + } + } else if (func == opt_cell_any_nr) { + s7_pointer(*fp) (opt_info * o); + o = sc->opts[0]; + fp = o->v[0].fp; + if (fp == opt_unless_p_1) + for (i = 0; i < len; i++) { + real(sv) = vals[i]; + if (!(o->v[4].fb(o->v[3].o1))) + o->v[5].o1->v[0].fp(o->v[5].o1); + } else + for (i = 0; i < len; i++) { + real(sv) = vals[i]; + fp(o); + } + } else + for (i = 0; i < len; i++) { + real(sv) = vals[i]; + func(sc); + } + } else + for (i = 0; i < len; i++) { + slot_set_value(slot, make_real(sc, vals[i])); + func(sc); + } + return (sc->unspecified); + } + if (is_int_vector(seq)) { + s7_int *vals = int_vector_ints(seq); + s7_int i, len = vector_length(seq); + if ((len > MUTLIM) && (!tree_has_setters(sc, body))) { + s7_pointer sv; + sv = make_mutable_integer(sc, 0); + slot_set_value(slot, sv); + /* since there are no setters, the inner step is also mutable if there is one. + * func=opt_cell_any_nr, sc->opts[0]->v[0].fp(sc->opts[0]) fp=opt_do_1 -> mutable version + */ + if (func == opt_int_any_nr) { + o = sc->opts[0]; + fi = o->v[0].fi; + for (i = 0; i < len; i++) { + integer(sv) = vals[i]; + fi(o); + } + } else + for (i = 0; i < len; i++) { + integer(sv) = vals[i]; + func(sc); + } + } else + for (i = 0; i < len; i++) { + slot_set_value(slot, make_integer(sc, vals[i])); + func(sc); + } + return (sc->unspecified); + } + if (is_normal_vector(seq)) { + s7_pointer *vals = vector_elements(seq); + s7_int i, len = vector_length(seq); + if (func == opt_cell_any_nr) { + s7_pointer(*fp) (opt_info * o); + o = sc->opts[0]; + fp = o->v[0].fp; + for (i = 0; i < len; i++) { + slot_set_value(slot, vals[i]); + fp(o); + } + } else + for (i = 0; i < len; i++) { + slot_set_value(slot, vals[i]); + func(sc); + } + return (sc->unspecified); + } + if (is_string(seq)) { + const char *str = string_value(seq); + s7_int i, len = string_length(seq); + for (i = 0; i < len; i++) { + slot_set_value(slot, chars[(uint8_t) (str[i])]); + func(sc); + } + return (sc->unspecified); + } + if (is_byte_vector(seq)) { + uint8_t *vals = byte_vector_bytes(seq); + s7_int i, len = vector_length(seq); + if (func == opt_int_any_nr) { + o = sc->opts[0]; + fi = o->v[0].fi; + for (i = 0; i < len; i++) { + slot_set_value(slot, small_int(vals[i])); + fi(o); + } + } else + for (i = 0; i < len; i++) { + slot_set_value(slot, small_int(vals[i])); + func(sc); + } + return (sc->unspecified); + } + sc->z = seq; + if (!is_iterator(sc->z)) + sc->z = s7_make_iterator(sc, sc->z); + seq = sc->z; + push_stack_no_let(sc, OP_GC_PROTECT, seq, f); + sc->z = sc->nil; + if (func == opt_cell_any_nr) { + s7_pointer(*fp) (opt_info * o); + o = sc->opts[0]; + fp = o->v[0].fp; + while (true) { + slot_set_value(slot, s7_iterate(sc, seq)); + if (iterator_is_at_end(seq)) { + unstack(sc); + return (sc->unspecified); + } + fp(o); + } + } + if (func == opt_int_any_nr) { + o = sc->opts[0]; + fi = o->v[0].fi; + while (true) { + slot_set_value(slot, s7_iterate(sc, seq)); + if (iterator_is_at_end(seq)) { + unstack(sc); + return (sc->unspecified); + } + fi(o); + } + } + while (true) { + slot_set_value(slot, s7_iterate(sc, seq)); + if (iterator_is_at_end(seq)) { + unstack(sc); + return (sc->unspecified); + } + func(sc); + } + } /* we never get here -- the while loops above exit via return # */ + else { /* not func -- unneeded "else" but otherwise confusing code */ + set_no_cell_opt(body); + set_curlet(sc, old_e); + } + } + if ((!is_closure_star(f)) && (is_null(cdr(body))) && (is_pair(seq))) { + s7_pointer c; + c = make_counter(sc, seq); + counter_set_result(c, seq); + push_stack(sc, OP_FOR_EACH_2, c, f); + return (sc->unspecified); + } + sc->z = seq; + if (!is_iterator(sc->z)) + sc->z = s7_make_iterator(sc, sc->z); + push_stack(sc, OP_FOR_EACH_1, make_counter(sc, sc->z), f); + sc->z = sc->nil; + return (sc->unspecified); +} + +static s7_pointer g_for_each_closure_2(s7_scheme * sc, s7_pointer f, + s7_pointer seq_1, s7_pointer seq_2) +{ + s7_pointer body = closure_body(f); + /* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(sc->code), display(seq1), display(seq2)); */ + if (!no_cell_opt(body)) { + s7_pfunc fnc; + s7_pointer olde = sc->curlet, pars = + closure_args(f), val_1, val_2, slot_1, slot_2; + + val_1 = seq_init(sc, seq_1); + val_2 = seq_init(sc, seq_2); + sc->curlet = make_let_with_two_slots(sc, closure_let(f), + (is_pair(car(pars))) ? + caar(pars) : car(pars), val_1, + (is_pair(cadr(pars))) ? + cadar(pars) : cadr(pars), + val_2); + slot_1 = let_slots(sc->curlet); + slot_2 = next_slot(slot_1); + + if (is_null(cdr(body))) + fnc = s7_optimize_nr(sc, body); + else if (is_null(cddr(body))) { + set_ulist_1(sc, sc->begin_symbol, body); + fnc = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); + } else + fnc = NULL; + if (fnc) { + if ((is_pair(seq_1)) && (is_pair(seq_2))) { + s7_pointer fast_1, slow_1, fast_2, slow_2; + for (fast_1 = seq_1, slow_1 = seq_1, fast_2 = + seq_2, slow_2 = seq_2; + (is_pair(fast_1)) && (is_pair(fast_2)); + fast_1 = cdr(fast_1), slow_1 = cdr(slow_1), fast_2 = + cdr(fast_2), slow_2 = cdr(slow_2)) { + slot_set_value(slot_1, car(fast_1)); + slot_set_value(slot_2, car(fast_2)); + fnc(sc); + if ((is_pair(cdr(fast_1))) && (is_pair(cdr(fast_2)))) { + fast_1 = cdr(fast_1); + if (fast_1 == slow_1) + break; + fast_2 = cdr(fast_2); + if (fast_2 == slow_2) + break; + slot_set_value(slot_1, car(fast_1)); + slot_set_value(slot_2, car(fast_2)); + fnc(sc); + } + } + set_curlet(sc, olde); + return (sc->unspecified); + } else if ((is_any_vector(seq_1)) && (is_any_vector(seq_2))) { + s7_int i, len = vector_length(seq_1); + if (len > vector_length(seq_2)) + len = vector_length(seq_2); + for (i = 0; i < len; i++) { + slot_set_value(slot_1, + vector_getter(seq_1) (sc, seq_1, i)); + slot_set_value(slot_2, + vector_getter(seq_2) (sc, seq_2, i)); + fnc(sc); + } + set_curlet(sc, olde); + return (sc->unspecified); + } else if ((is_string(seq_1)) && (is_string(seq_2))) { + s7_int i, len = string_length(seq_1); + const char *s_1 = string_value(seq_1), *s_2 = + string_value(seq_2); + if (len > string_length(seq_2)) + len = string_length(seq_2); + for (i = 0; i < len; i++) { + slot_set_value(slot_1, chars[(uint8_t) (s_1[i])]); + slot_set_value(slot_2, chars[(uint8_t) (s_2[i])]); + fnc(sc); + } + set_curlet(sc, olde); + return (sc->unspecified); + } else { + set_no_cell_opt(body); + set_curlet(sc, olde); + } + } else { /* not fnc */ + set_no_cell_opt(body); + set_curlet(sc, olde); + } + } + + sc->z = + list_1(sc, + (is_iterator(seq_2)) ? seq_2 : s7_make_iterator(sc, seq_2)); + sc->z = + cons(sc, + (is_iterator(seq_1)) ? seq_1 : s7_make_iterator(sc, seq_1), + sc->z); + push_stack(sc, OP_FOR_EACH, + cons_unchecked(sc, sc->z, make_list(sc, 2, sc->nil)), f); + sc->z = sc->nil; + return (sc->unspecified); +} + +static inline bool for_each_arg_is_null(s7_scheme * sc, s7_pointer args) +{ + s7_pointer p; + bool got_nil = false; + for (p = args; is_pair(p); p = cdr(p)) { + s7_pointer obj = car(p); + if (!is_mappable(obj)) { + if (is_null(obj)) + got_nil = true; + else + return (simple_wrong_type_argument_with_type + (sc, sc->for_each_symbol, obj, a_sequence_string)); + } + } + return (got_nil); +} + +static s7_pointer g_for_each(s7_scheme * sc, s7_pointer args) +{ +#define H_for_each "(for-each proc object . objects) applies proc to each element of the objects traversed in parallel. \ +Each object can be a list, string, vector, hash-table, or any other sequence." +#define Q_for_each s7_make_circular_signature(sc, 2, 3, sc->is_unspecified_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol) + + s7_pointer f = car(args); + s7_int len; + bool arity_ok = false; + + /* try the normal case first */ + sc->value = f; + len = proper_list_length(cdr(args)); + + if (is_closure(f)) { /* not lambda* that might get confused about arg names */ + if ((len == 1) && + (is_pair(closure_args(f))) && (is_null(cdr(closure_args(f))))) + arity_ok = true; + } else if (!is_applicable(f)) + return (method_or_bust_with_type + (sc, f, sc->for_each_symbol, args, + something_applicable_string, 1)); + + if ((!arity_ok) && (!s7_is_aritable(sc, f, len))) + return (s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, + wrap_string(sc, + "for-each ~A: ~A argument~P?", + 27), f, make_integer(sc, + len), + make_integer(sc, len)))); + + if (for_each_arg_is_null(sc, cdr(args))) + return (sc->unspecified); + + /* if function is safe c func, do the for-each locally */ + if ((is_c_function(f)) && (is_safe_procedure(f))) { + s7_function func; + s7_pointer iters; + + s7_p_p_t fp = s7_p_p_function(f); + if ((fp) && (len == 1)) { + if (is_pair(cadr(args))) { + s7_pointer fast, slow; + for (fast = cadr(args), slow = cadr(args); is_pair(fast); + fast = cdr(fast), slow = cdr(slow)) { + fp(sc, car(fast)); + if (is_pair(cdr(fast))) { + fast = cdr(fast); + if (fast == slow) + break; + fp(sc, car(fast)); + } + return (sc->unspecified); + } + } else if (is_any_vector(cadr(args))) { + s7_int i, vlen; + s7_pointer v = cadr(args); + vlen = vector_length(v); + for (i = 0; i < vlen; i++) + fp(sc, vector_getter(v) (sc, v, i)); + return (sc->unspecified); + } else if (is_string(cadr(args))) { + s7_int i, slen; + s7_pointer str = cadr(args); + const char *s; + s = string_value(str); + slen = string_length(str); + for (i = 0; i < slen; i++) + fp(sc, chars[(uint8_t) (s[i])]); + return (sc->unspecified); + } + } + + func = c_function_call(f); /* presumably this is either display/write, or method call? */ + sc->z = make_iterators(sc, args); + sc->z = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); + push_stack_no_let(sc, OP_GC_PROTECT, sc->args, sc->z); /* temporary GC protection */ + if (len == 1) { + s7_pointer x = caar(sc->z), y = cdr(sc->z); + sc->z = sc->nil; + while (true) { + set_car(y, s7_iterate(sc, x)); + if (iterator_is_at_end(x)) { + /* not pop_stack here since that can clobber sc->code et al, and if this for-each call is + * being treated as safe, fn_proc(for-each) assumes everywhere that sc->code is left alone. + */ + unstack(sc); /* free_cell(sc, x); *//* 16-Jan-19 */ + return (sc->unspecified); + } + func(sc, y); + } + } + iters = sc->z; + sc->z = sc->nil; + while (true) { + s7_pointer x, y; + for (x = car(iters), y = cdr(iters); is_pair(x); + x = cdr(x), y = cdr(y)) { + set_car(y, s7_iterate(sc, car(x))); + if (iterator_is_at_end(car(x))) { + unstack(sc); + return (sc->unspecified); + } + } + func(sc, cdr(iters)); + } + } + + /* if closure call is straightforward, use OP_FOR_EACH_1 */ + if ((len == 1) && + (((is_closure(f)) && + (closure_arity_to_int(sc, f) == 1) && + (!is_constant_symbol(sc, car(closure_args(f))))) || + ((is_closure_star(f)) && + (closure_star_arity_to_int(sc, f) == 1) && + (!is_constant_symbol + (sc, + (is_pair(car(closure_args(f)))) ? caar(closure_args(f)) : + car(closure_args(f))))))) + return (g_for_each_closure(sc, f, cadr(args))); + + push_stack(sc, OP_FOR_EACH, + cons_unchecked(sc, make_iterators(sc, args), + make_list(sc, len, sc->nil)), f); + sc->z = sc->nil; + return (sc->unspecified); +} + +static bool op_for_each(s7_scheme * sc) +{ + s7_pointer x, y, iterators = car(sc->args), saved_args = cdr(sc->args); + for (x = saved_args, y = iterators; is_pair(x); x = cdr(x), y = cdr(y)) { + set_car(x, s7_iterate(sc, car(y))); + if (iterator_is_at_end(car(y))) { + sc->value = sc->unspecified; + free_cell(sc, sc->args); + return (true); + } + } + push_stack_direct(sc, OP_FOR_EACH); + if (needs_copied_args(sc->code)) + sc->args = copy_proper_list(sc, saved_args); + else + sc->args = saved_args; + return (false); +} + +/* for-each et al remake the local let, but that's only needed if the local let is exported, + * and that can only happen through make-closure in various guises and curlet. + * owlet captures, but it would require a deliberate error to use it in this context. + * c_objects call object_set_let but that requires a prior curlet or sublet. So we have + * sc->capture_let_counter that is incremented every time an environment is captured, then + * here we save that ctr, call body, on rerun check ctr, if it has not changed we are safe and + * can reuse let. But that reuse assumes no new slots were added (by define etc), because + * update_let* only update the symbol_id's they expect, and that can happen even in op_for_each_2. + */ + +static Inline bool op_for_each_1(s7_scheme * sc) +{ + s7_pointer counter = sc->args, p, arg, code; + p = counter_list(counter); + arg = s7_iterate(sc, p); + if (iterator_is_at_end(p)) { + sc->value = sc->unspecified; + free_cell(sc, counter); + return (true); + } + code = T_Clo(sc->code); + if (counter_capture(counter) != sc->capture_let_counter) { + s7_pointer sym = car(closure_args(code)); + sc->curlet = + make_let_with_slot(sc, closure_let(code), + (is_symbol(sym)) ? sym : car(sym), arg); + counter_set_let(counter, sc->curlet); + counter_set_slots(counter, let_slots(sc->curlet)); + counter_set_capture(counter, sc->capture_let_counter); + } else { + let_set_slots(counter_let(counter), counter_slots(counter)); /* this is needed (unless safe_closure but that costs more to check than this set) */ + sc->curlet = update_let_with_slot(sc, counter_let(counter), arg); + } + push_stack(sc, OP_FOR_EACH_1, counter, code); + sc->code = T_Pair(closure_body(code)); + return (false); +} + +static Inline bool op_for_each_2(s7_scheme * sc) +{ + s7_pointer c = sc->args, lst; + lst = counter_list(c); + if (!is_pair(lst)) { /* '(1 2 . 3) as arg? -- counter_list can be anything here */ + sc->value = sc->unspecified; + free_cell(sc, c); /* not sc->args = sc->nil; */ + return (true); + } + counter_set_list(c, cdr(lst)); + if (sc->cur_op == OP_FOR_EACH_3) { + counter_set_result(c, cdr(counter_result(c))); + if (counter_result(c) == counter_list(c)) { + sc->value = sc->unspecified; + free_cell(sc, c); /* not sc->args = sc->nil; */ + return (true); + } + push_stack_direct(sc, OP_FOR_EACH_2); + } else + push_stack_direct(sc, OP_FOR_EACH_3); + if (counter_capture(c) != sc->capture_let_counter) { + sc->curlet = + make_let_with_slot(sc, closure_let(sc->code), + car(closure_args(sc->code)), car(lst)); + counter_set_let(c, sc->curlet); + counter_set_slots(c, let_slots(sc->curlet)); + counter_set_capture(c, sc->capture_let_counter); + } else { + let_set_slots(counter_let(c), counter_slots(c)); + sc->curlet = update_let_with_slot(sc, counter_let(c), car(lst)); + } + sc->code = car(closure_body(sc->code)); + return (false); +} + + +/* ---------------------------------------- map ---------------------------------------- */ + +static s7_pointer g_map_closure(s7_scheme * sc, s7_pointer f, + s7_pointer seq) +{ /* one sequence argument */ + s7_pointer body = closure_body(f); + sc->value = f; + + if (!no_cell_opt(body)) { + s7_pfunc func = NULL; + s7_pointer old_e = sc->curlet, pars = closure_args(f), val, slot; + + val = seq_init(sc, seq); + sc->curlet = + make_let_with_slot(sc, closure_let(f), + (is_pair(car(pars))) ? caar(pars) : + car(pars), val); + slot = let_slots(sc->curlet); + + if (is_null(cdr(body))) + func = s7_cell_optimize(sc, body, false); + else if (is_null(cddr(body))) { + set_ulist_1(sc, sc->begin_symbol, body); + func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); /* list_1 8-Apr-21 */ + } else + func = NULL; + if (func) { + s7_pointer z; + sc->v = sc->nil; + push_stack_no_let(sc, OP_GC_PROTECT, f, seq); + if (is_pair(seq)) { + s7_pointer fast, slow; + for (fast = seq, slow = seq; is_pair(fast); + fast = cdr(fast), slow = cdr(slow)) { + slot_set_value(slot, car(fast)); + z = func(sc); + if (z != sc->no_value) + sc->v = cons(sc, z, sc->v); + if (is_pair(cdr(fast))) { + fast = cdr(fast); + if (fast == slow) + break; + slot_set_value(slot, car(fast)); + z = func(sc); + if (z != sc->no_value) + sc->v = cons(sc, z, sc->v); + } + } + unstack(sc); + return (proper_list_reverse_in_place(sc, sc->v)); + } + if (is_float_vector(seq)) { + s7_double *vals = float_vector_floats(seq); + s7_int i, len = vector_length(seq); + for (i = 0; i < len; i++) { + slot_set_value(slot, make_real(sc, vals[i])); + z = func(sc); + if (z != sc->no_value) + sc->v = cons(sc, z, sc->v); + } + unstack(sc); + return (proper_list_reverse_in_place(sc, sc->v)); + } + if (is_int_vector(seq)) { + s7_int *vals = int_vector_ints(seq); + s7_int i, len = vector_length(seq); + for (i = 0; i < len; i++) { + slot_set_value(slot, make_integer(sc, vals[i])); + z = func(sc); + if (z != sc->no_value) + sc->v = cons(sc, z, sc->v); + } + unstack(sc); + return (proper_list_reverse_in_place(sc, sc->v)); + } + if (is_normal_vector(seq)) { + s7_pointer *vals = vector_elements(seq); + s7_int i, len = vector_length(seq); + for (i = 0; i < len; i++) { + slot_set_value(slot, vals[i]); + z = func(sc); + if (z != sc->no_value) + sc->v = cons(sc, z, sc->v); + } + unstack(sc); + return (proper_list_reverse_in_place(sc, sc->v)); + } + if (is_string(seq)) { + s7_int i, len = string_length(seq); + const char *str = string_value(seq); + for (i = 0; i < len; i++) { + slot_set_value(slot, chars[(uint8_t) (str[i])]); + z = func(sc); + if (z != sc->no_value) + sc->v = cons(sc, z, sc->v); + } + unstack(sc); + return (proper_list_reverse_in_place(sc, sc->v)); + } + } + set_no_cell_opt(body); + set_curlet(sc, old_e); + } + + if (is_closure_star(f)) { + sc->z = make_iterators(sc, set_plist_2(sc, sc->nil, seq)); + push_stack(sc, OP_MAP, make_counter(sc, sc->z), f); + sc->z = sc->nil; + return (sc->nil); + } + if ((is_null(cdr(body))) && (is_pair(seq))) { + closure_set_map_list(f, seq); + push_stack(sc, OP_MAP_2, make_counter(sc, seq), f); + return (sc->unspecified); + } + sc->z = (!is_iterator(seq)) ? s7_make_iterator(sc, seq) : seq; + push_stack(sc, OP_MAP_1, make_counter(sc, sc->z), f); + sc->z = sc->nil; + return (sc->nil); +} + +static s7_pointer g_map_closure_2(s7_scheme * sc, s7_pointer f, + s7_pointer seq1, s7_pointer seq2) +{ + s7_pointer body = closure_body(f); + /* fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(sc->code), display(seq1), display(seq2)); */ + if (!no_cell_opt(body)) { + s7_pfunc func; + s7_pointer old_e = sc->curlet, pars = + closure_args(f), val1, val2, slot1, slot2; + + val1 = seq_init(sc, seq1); + val2 = seq_init(sc, seq2); + sc->curlet = make_let_with_two_slots(sc, closure_let(f), + (is_pair(car(pars))) ? + caar(pars) : car(pars), val1, + (is_pair(cadr(pars))) ? + cadar(pars) : cadr(pars), + val2); + slot1 = let_slots(sc->curlet); + slot2 = next_slot(slot1); + + if (is_null(cdr(body))) + func = s7_cell_optimize(sc, body, false); + else if (is_null(cddr(body))) { + set_ulist_1(sc, sc->begin_symbol, body); + func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); + } else + func = NULL; + if (func) { + s7_pointer val; + if ((is_pair(seq1)) && (is_pair(seq2))) { + s7_pointer fast1, slow1, fast2, slow2; + sc->v = sc->nil; + for (fast1 = seq1, slow1 = seq1, fast2 = seq2, slow2 = + seq2; (is_pair(fast1)) && (is_pair(fast2)); + fast1 = cdr(fast1), slow1 = cdr(slow1), fast2 = + cdr(fast2), slow2 = cdr(slow2)) { + slot_set_value(slot1, car(fast1)); + slot_set_value(slot2, car(fast2)); + val = func(sc); + if (val != sc->no_value) + sc->v = cons(sc, val, sc->v); + if ((is_pair(cdr(fast1))) && (is_pair(cdr(fast2)))) { + fast1 = cdr(fast1); + if (fast1 == slow1) + break; + fast2 = cdr(fast2); + if (fast2 == slow2) + break; + slot_set_value(slot1, car(fast1)); + slot_set_value(slot2, car(fast2)); + val = func(sc); + if (val != sc->no_value) + sc->v = cons(sc, val, sc->v); + } + } + set_curlet(sc, old_e); + return (proper_list_reverse_in_place(sc, sc->v)); + } else if ((is_any_vector(seq1)) && (is_any_vector(seq2))) { + s7_int i, len = vector_length(seq1); + if (len > vector_length(seq2)) + len = vector_length(seq2); + sc->v = sc->nil; + for (i = 0; i < len; i++) { + slot_set_value(slot1, + vector_getter(seq1) (sc, seq1, i)); + slot_set_value(slot2, + vector_getter(seq2) (sc, seq2, i)); + val = func(sc); + if (val != sc->no_value) + sc->v = cons(sc, val, sc->v); + } + set_curlet(sc, old_e); + return (proper_list_reverse_in_place(sc, sc->v)); + } else if ((is_string(seq1)) && (is_string(seq2))) { + s7_int i, len = string_length(seq1); + const char *s1 = string_value(seq1), *s2 = + string_value(seq2); + if (len > string_length(seq2)) + len = string_length(seq2); + sc->v = sc->nil; + for (i = 0; i < len; i++) { + slot_set_value(slot1, chars[(uint8_t) (s1[i])]); + slot_set_value(slot2, chars[(uint8_t) (s2[i])]); + val = func(sc); + if (val != sc->no_value) + sc->v = cons(sc, val, sc->v); + } + set_curlet(sc, old_e); + return (proper_list_reverse_in_place(sc, sc->v)); + } else { + set_no_cell_opt(body); + set_curlet(sc, old_e); + } + } else { /* not func */ + set_no_cell_opt(body); + set_curlet(sc, old_e); + } + } + + sc->z = + list_1(sc, + (is_iterator(seq2)) ? seq2 : s7_make_iterator(sc, seq2)); + sc->z = + cons(sc, (is_iterator(seq1)) ? seq1 : s7_make_iterator(sc, seq1), + sc->z); + push_stack(sc, OP_MAP, make_counter(sc, sc->z), f); + sc->z = sc->nil; + return (sc->unspecified); +} + +static s7_pointer g_map(s7_scheme * sc, s7_pointer args) +{ +#define H_map "(map proc object . objects) applies proc to a list made up of the next element of each of its arguments, returning \ +a list of the results. Its arguments can be lists, vectors, strings, hash-tables, or any applicable objects." +#define Q_map s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol) + + s7_pointer p, f = car(args); + s7_int len; + bool got_nil = false; + + for (len = 0, p = cdr(args); is_not_null(p); p = cdr(p), len++) + if (!is_mappable(car(p))) { + if (is_null(car(p))) + got_nil = true; + else + return (simple_wrong_type_argument_with_type + (sc, sc->map_symbol, car(p), a_sequence_string)); + } + + switch (type(f)) { + case T_C_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + if ((c_function_required_args(f) > len) || + (c_function_all_args(f) < len)) + return (s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, + wrap_string(sc, + "map ~A: ~A argument~P?", + 22), f, + wrap_integer1(sc, len), + wrap_integer2(sc, len)))); + + case T_C_OPT_ARGS_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + /* if function is safe c func, do the map locally */ + if (got_nil) + return (sc->nil); + if (is_safe_procedure(f)) { + s7_pointer val, val1, old_args, iter_list; + s7_function func = c_function_call(f); + if (is_pair(cadr(args))) { + if (len == 1) { + s7_p_p_t fp = s7_p_p_function(f); + if (fp) { + s7_pointer fast, slow; + val = list_1_unchecked(sc, sc->nil); + push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); + for (fast = cadr(args), slow = cadr(args); + is_pair(fast); + fast = cdr(fast), slow = cdr(slow)) { + s7_pointer z; + z = fp(sc, car(fast)); + if (z != sc->no_value) + set_car(val, cons(sc, z, car(val))); + if (is_pair(cdr(fast))) { + fast = cdr(fast); + if (fast == slow) + break; + z = fp(sc, car(fast)); + if (z != sc->no_value) + set_car(val, cons(sc, z, car(val))); + } + } + unstack(sc); + return (proper_list_reverse_in_place + (sc, car(val))); + } + } + if ((len == 2) && (is_pair(caddr(args)))) { + s7_p_pp_t fp = s7_p_pp_function(f); + if (fp) { + s7_pointer fast1, slow1, fast2, slow2; + val = list_1_unchecked(sc, sc->nil); + push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); + for (fast1 = cadr(args), slow1 = + cadr(args), fast2 = caddr(args), slow2 = + caddr(args); + (is_pair(fast1)) && (is_pair(fast2)); + fast1 = cdr(fast1), slow1 = + cdr(slow1), fast2 = cdr(fast2), slow2 = + cdr(slow2)) { + s7_pointer z; + z = fp(sc, car(fast1), car(fast2)); + if (z != sc->no_value) + set_car(val, cons(sc, z, car(val))); + if ((is_pair(cdr(fast1))) + && (is_pair(cdr(fast2)))) { + fast1 = cdr(fast1); + if (fast1 == slow1) + break; + fast2 = cdr(fast2); + if (fast2 == slow2) + break; + z = fp(sc, car(fast1), car(fast2)); + if (z != sc->no_value) + set_car(val, cons(sc, z, car(val))); + } + } + unstack(sc); + return (proper_list_reverse_in_place + (sc, car(val))); + } + } + } + if ((is_string(cadr(args))) && (len == 1)) { + s7_p_p_t fp = s7_p_p_function(f); + if (fp) { + s7_int i, len; + s7_pointer val, str = cadr(args); + const char *s; + val = list_1_unchecked(sc, sc->nil); + push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); + s = string_value(str); + len = string_length(str); + for (i = 0; i < len; i++) { + s7_pointer z; + z = fp(sc, chars[(uint8_t) (s[i])]); + if (z != sc->no_value) + set_car(val, cons(sc, z, car(val))); + } + unstack(sc); + return (proper_list_reverse_in_place(sc, car(val))); + } + } + if ((is_any_vector(cadr(args))) && (len == 1)) { + s7_p_p_t fp = s7_p_p_function(f); + if (fp) { + s7_int i, len; + s7_pointer val, vec = cadr(args); + val = list_1_unchecked(sc, sc->nil); + push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); + len = vector_length(vec); + for (i = 0; i < len; i++) { + s7_pointer z; + z = fp(sc, vector_getter(vec) (sc, vec, i)); + if (z != sc->no_value) + set_car(val, cons(sc, z, car(val))); + } + unstack(sc); + return (proper_list_reverse_in_place(sc, car(val))); + } + } + + sc->z = make_iterators(sc, args); + val1 = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); + iter_list = sc->z; + old_args = sc->args; + /* func = c_function_call(f); */ + push_stack_no_let(sc, OP_GC_PROTECT, val1, val = cons(sc, sc->nil, sc->code)); /* temporary GC protection: need to protect val1, iter_list, val */ + sc->z = sc->nil; + while (true) { + s7_pointer x, y, z; + for (x = iter_list, y = cdr(val1); is_pair(x); + x = cdr(x), y = cdr(y)) { + set_car(y, s7_iterate(sc, car(x))); + if (iterator_is_at_end(car(x))) { + unstack(sc); + /* free_cell(sc, car(x)); *//* 16-Jan-19 iterator in circular list -- see s7test */ + sc->args = T_Pos(old_args); + return (proper_list_reverse_in_place + (sc, car(val))); + } + } + z = func(sc, cdr(val1)); /* can this contain multiple-values? */ + if (z != sc->no_value) + set_car(val, cons(sc, z, car(val))); + } + } + + else /* not safe procedure */ + if ((f == global_value(sc->values_symbol)) && + (len == 1) && (!has_methods(cadr(args)))) { /* iterator should be ok here -- object_to_list can handle it */ + p = object_to_list(sc, cadr(args)); + if (p != cadr(args)) + return (p); + } + break; + + case T_CLOSURE: + case T_CLOSURE_STAR: + { + int32_t fargs; + fargs = + (is_closure(f)) ? closure_arity_to_int(sc, + f) : + closure_star_arity_to_int(sc, f); + if ((len == 1) && (fargs == 1) + && + (!is_constant_symbol + (sc, + (is_pair(car(closure_args(f)))) ? caar(closure_args(f)) : + car(closure_args(f))))) { + if (got_nil) + return (sc->nil); + if (is_closure_star(f)) + return (g_map_closure(sc, f, cadr(args))); + + /* don't go to OP_MAP_2 here! It assumes no recursion */ + sc->z = + (!is_iterator(cadr(args))) ? s7_make_iterator(sc, + cadr + (args)) : + cadr(args); + push_stack(sc, OP_MAP_1, make_counter(sc, sc->z), f); + sc->z = sc->nil; + symbol_increment_ctr(car(closure_args(f))); + return (sc->nil); + } + if (((fargs >= 0) && (fargs < len)) || + ((is_closure(f)) && (abs(fargs) > len))) + return (s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, + wrap_string(sc, + "map ~A: ~A argument~P?", + 22), f, + wrap_integer1(sc, len), + wrap_integer2(sc, len)))); + if (got_nil) + return (sc->nil); + } + break; + + default: + if (!is_applicable(f)) + return (method_or_bust_with_type + (sc, f, sc->map_symbol, args, + something_applicable_string, 1)); + if ((!is_pair(f)) && (!s7_is_aritable(sc, f, len))) + return (s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, + wrap_string(sc, + "map ~A: ~A argument~P?", + 22), f, + wrap_integer1(sc, len), + wrap_integer2(sc, len)))); + if (got_nil) + return (sc->nil); + break; + } + + sc->z = make_iterators(sc, args); + push_stack(sc, OP_MAP, make_counter(sc, sc->z), f); + sc->z = sc->nil; + return (sc->nil); +} + +static bool op_map(s7_scheme * sc) +{ + s7_pointer y, iterators = counter_list(sc->args); + sc->x = sc->nil; /* can't use preset args list here (as in for-each): (map list '(a b c)) */ + for (y = iterators; is_pair(y); y = cdr(y)) { + s7_pointer x; + x = s7_iterate(sc, car(y)); + if (iterator_is_at_end(car(y))) { + sc->value = + proper_list_reverse_in_place(sc, counter_result(sc->args)); + free_cell(sc, sc->args); /* not sc->args = sc->nil; */ + return (true); + } + sc->x = cons(sc, x, sc->x); + } + sc->x = proper_list_reverse_in_place(sc, sc->x); + push_stack_direct(sc, OP_MAP_GATHER); + sc->args = sc->x; + sc->x = sc->nil; + if (needs_copied_args(sc->code)) + sc->args = copy_proper_list(sc, sc->args); + return (false); +} + +static bool op_map_1(s7_scheme * sc) +{ + s7_pointer x, args = sc->args, p, code = sc->code; + p = counter_list(args); + x = s7_iterate(sc, p); + + if (iterator_is_at_end(p)) { + sc->value = proper_list_reverse_in_place(sc, counter_result(args)); + free_cell(sc, sc->args); /* not sc->args = sc->nil; */ + return (true); + } + push_stack_direct(sc, OP_MAP_GATHER_1); + if (counter_capture(args) != sc->capture_let_counter) { + sc->curlet = + make_let_with_slot(sc, closure_let(code), + car(closure_args(code)), x); + counter_set_let(args, sc->curlet); + counter_set_slots(args, let_slots(sc->curlet)); + counter_set_capture(args, sc->capture_let_counter); + } else { + /* the counter_slots field saves the original local let slot(s) representing the function + * argument. If the function has internal defines, they get added to the front of the + * slots list, but update_let_with_slot (maybe stupidly) assumes only the one original + * slot exists when it updates its symbol_id from the (possibly changed) let_id. So, + * a subsequent reference to the parameter name causes "unbound variable", or a segfault + * if the check has been optimized away. I think each function call should start with + * the original let slots, so counter_slots saves that pointer, and resets it here. + */ + let_set_slots(counter_let(args), counter_slots(args)); + sc->curlet = update_let_with_slot(sc, counter_let(args), x); + } + sc->code = T_Pair(closure_body(code)); + return (false); +} + +static bool op_map_2(s7_scheme * sc) +{ + s7_pointer x, c = sc->args, p, code = sc->code; + p = counter_list(c); + if (!is_pair(p)) { + sc->value = proper_list_reverse_in_place(sc, counter_result(c)); + free_cell(sc, sc->args); /* not sc->args = sc->nil; */ + return (true); + } + x = car(p); + counter_set_list(c, cdr(p)); + + if (sc->cur_op == OP_MAP_GATHER_3) { + closure_set_map_list(code, cdr(closure_map_list(code))); + /* this depends on code (the function) being non-recursive, else closure_setter gets stepped on */ + if (closure_map_list(code) == counter_list(c)) { + sc->value = + proper_list_reverse_in_place(sc, counter_result(c)); + free_cell(sc, c); /* not sc->args = sc->nil; */ + return (true); + } + push_stack_direct(sc, OP_MAP_GATHER_2); + } else + push_stack_direct(sc, OP_MAP_GATHER_3); + + if (counter_capture(c) != sc->capture_let_counter) { + sc->curlet = + make_let_with_slot(sc, closure_let(code), + car(closure_args(code)), x); + counter_set_let(c, sc->curlet); + counter_set_slots(c, let_slots(sc->curlet)); + counter_set_capture(c, sc->capture_let_counter); + } else { + let_set_slots(counter_let(c), counter_slots(c)); /* needed -- see comment under for-each above */ + sc->curlet = update_let_with_slot(sc, counter_let(c), x); + } + sc->code = car(closure_body(code)); + return (false); +} + + +/* -------------------------------- multiple-values -------------------------------- */ +#if S7_DEBUGGING +#define T_Mut(p) T_Mut_1(p, __func__, __LINE__) +static s7_pointer T_Mut_1(s7_pointer p, const char *func, int line) +{ + if ((is_pair(p)) && ((is_immutable(p)) || (!in_heap(p)))) /* might be nil */ + fprintf(stderr, "%s[%d]: immutable list: %p\n", func, line, p); + return (p); +} +#else +#define T_Mut(p) p +#endif + +static s7_pointer splice_in_values(s7_scheme * sc, s7_pointer args) +{ + int64_t top; + s7_pointer x; + top = current_stack_top(sc) - 1; /* stack_end - stack_start if negative, we're in big trouble */ + if (SHOW_EVAL_OPS) + safe_print(fprintf + (stderr, "%s[%d]: splice %s %s\n", __func__, __LINE__, + op_names[stack_op(sc->stack, top)], display_80(args))); + + switch (stack_op(sc->stack, top)) { + /* the normal case -- splice values into caller's args */ + case OP_EVAL_ARGS1: + case OP_EVAL_ARGS2: + case OP_EVAL_ARGS3: + case OP_EVAL_ARGS4: + /* code = args yet to eval in order, args = evalled args reversed. + * it is not safe to simply reverse args and tack the current stacked args onto its (new) end, + * setting stacked args to cdr of reversed-args and returning car because the list (args) + * can be some variable's value in a macro expansion via ,@ and reversing it in place + * (all this to avoid consing), clobbers the variable's value. + */ + for (x = args; is_not_null(cdr(x)); x = cdr(x)) + stack_args(sc->stack, top) = + cons(sc, car(x), T_Mut(stack_args(sc->stack, top))); + return (car(x)); + + /* in the next set, the main evaluator branches blithely assume no multiple-values, + * and if it happens anyway, we go to a different branch here + */ + case OP_ANY_CLOSURE_NP_2: + stack_element(sc->stack, top) = + (s7_pointer) OP_ANY_CLOSURE_NP_MV_1; + goto FP_MV; + + case OP_ANY_C_NP_2: + stack_element(sc->stack, top) = (s7_pointer) OP_ANY_C_NP_MV_1; + goto FP_MV; + + case OP_ANY_C_NP_1: + case OP_ANY_CLOSURE_NP_1: + stack_element(sc->stack, top) = (s7_pointer) (stack_op(sc->stack, top) + 1); /* replace with mv version */ + + case OP_ANY_C_NP_MV_1: + case OP_ANY_CLOSURE_NP_MV_1: + FP_MV: + if ((is_immutable(args)) || /* (let () (define (func) (with-output-to-string (lambda () (apply-values (write '(1 2)))))) (func) (func)) */ + (needs_copied_args(args))) { + clear_needs_copied_args(args); + args = copy_proper_list(sc, args); + } + set_multiple_value(args); + return (args); + + case OP_SAFE_C_SSP_1: + stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_SSP_MV_1; + return (args); + + case OP_SAFE_C_SP_1: + case OP_SAFE_CONS_SP_1: + case OP_SAFE_LIST_SP_1: + case OP_SAFE_ADD_SP_1: + case OP_SAFE_MULTIPLY_SP_1: + stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_SP_MV; + return (args); + + case OP_SAFE_C_PS_1: + stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_PS_MV; + return (args); + + case OP_SAFE_C_PC_1: + stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_PC_MV; + return (args); + + case OP_SAFE_C_PA_1: + stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_PA_MV; + return (args); + + case OP_C_P_1: + case OP_SAFE_C_P_1: + stack_element(sc->stack, top) = (s7_pointer) OP_C_P_MV; + return (args); + + case OP_C_AP_1: + stack_element(sc->stack, top) = (s7_pointer) OP_C_AP_MV; + sc->value = args; + return (args); + + case OP_SAFE_CLOSURE_P_1: + case OP_CLOSURE_P_1: + case OP_SAFE_CLOSURE_P_A_1: + case OP_SAFE_CLOSURE_AP_1: + case OP_CLOSURE_AP_1: + case OP_SAFE_CLOSURE_PP_1: + case OP_CLOSURE_PP_1: + case OP_SAFE_CLOSURE_PA_1: + case OP_CLOSURE_PA_1: /* arity is 2, we have 2 args, this has to be an error (see optimize_closure_dotted_args) */ + case OP_ANY_CLOSURE_3P_1: + case OP_ANY_CLOSURE_3P_2: + case OP_ANY_CLOSURE_3P_3: + case OP_ANY_CLOSURE_4P_1: + case OP_ANY_CLOSURE_4P_2: + case OP_ANY_CLOSURE_4P_3: + case OP_ANY_CLOSURE_4P_4: + return (s7_error + (sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, + stack_code(sc->stack, top), sc->value))); + + case OP_SAFE_C_PP_1: + stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_PP_3_MV; + return (args); + + case OP_SAFE_C_PP_5: + stack_element(sc->stack, top) = (s7_pointer) OP_SAFE_C_PP_6_MV; + return (args); + + case OP_SAFE_C_3P_1: + case OP_SAFE_C_3P_2: + case OP_SAFE_C_3P_3: + stack_element(sc->stack, top) = + (s7_pointer) (stack_op(sc->stack, top) + 3); + case OP_SAFE_C_3P_1_MV: + case OP_SAFE_C_3P_2_MV: + case OP_SAFE_C_3P_3_MV: + return (cons(sc, sc->unused, copy_proper_list(sc, args))); + + case OP_EVAL_ARGS5: + /* code = previous arg saved, args = ante-previous args reversed + * we'll take value->code->args and reverse in args5 + * if one value, return it, else + * put code onto args, splice as above until there are 2 left + * set code to first and value to last + */ + if (is_null(args)) + return (sc->unspecified); + + if (is_null(cdr(args))) + return (car(args)); + + stack_args(sc->stack, top) = + cons(sc, stack_code(sc->stack, top), + T_Mut(stack_args(sc->stack, top))); + for (x = args; is_not_null(cddr(x)); x = cdr(x)) + stack_args(sc->stack, top) = + cons(sc, car(x), stack_args(sc->stack, top)); + stack_code(sc->stack, top) = car(x); + return (cadr(x)); + + /* look for errors here rather than glomming up the set! and let code. */ + case OP_SET_SAFE: /* symbol is sc->code after pop */ + case OP_SET1: + case OP_SET_FROM_LET_TEMP: /* (set! var (values 1 2 3)) */ + case OP_SET_FROM_SETTER: + eval_error_with_caller2(sc, "~A: can't set ~A to ~S", 22, + sc->set_symbol, stack_code(sc->stack, top), + set_ulist_1(sc, sc->values_symbol, args)); + + case OP_SET_PAIR_P_1: + eval_error(sc, "too many values to set! ~S", 26, + set_ulist_1(sc, sc->values_symbol, args)); + + case OP_INCREMENT_SP_1: /* slot is in stack_args(top), args is the values list */ + stack_element(sc->stack, top) = (s7_pointer) OP_INCREMENT_SP_MV; + return (args); + + case OP_LET1: /* (let ((var (values 1 2 3))) ...) */ + { + s7_pointer p, let_code, vars, sym; + p = stack_args(sc->stack, top); + for (let_code = p; is_pair(cdr(let_code)); + let_code = cdr(let_code)); + for (vars = caar(let_code); is_pair(cdr(p)); + p = cdr(p), vars = cdr(vars)); + sym = caar(vars); + eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, + sc->let_symbol, sym, set_ulist_1(sc, + sc->values_symbol, + args)); + /* stack_args: ((((x (values 1 2))) x)) in (let ((x (values 1 2))) x) + * (1 (((x 1) (y (values 1 2))) x)) in (let ((x 1) (y (values 1 2))) x) + */ + } + + case OP_LET_ONE_NEW_1: + case OP_LET_ONE_P_NEW_1: + eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, + sc->let_symbol, + opt2_sym(stack_code(sc->stack, top)), + set_ulist_1(sc, sc->values_symbol, args)); + + case OP_LET_ONE_OLD_1: + case OP_LET_ONE_P_OLD_1: + eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, + sc->let_symbol, + slot_symbol(let_slots + (opt3_let + (stack_code + (sc->stack, top)))), + set_ulist_1(sc, sc->values_symbol, args)); + + case OP_LET_STAR1: /* here caar(sc->code) is bound to sc->value */ + eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, + sc->let_star_symbol, + caar(stack_code(sc->stack, top)), + set_ulist_1(sc, sc->values_symbol, args)); + + case OP_LETREC1: /* here sc->args is the slot about to receive a value */ + eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, + sc->letrec_symbol, + slot_symbol(stack_args(sc->stack, top)), + set_ulist_1(sc, sc->values_symbol, args)); + + case OP_LETREC_STAR1: + eval_error_with_caller2(sc, "~A: can't bind ~A to ~S", 23, + sc->letrec_star_symbol, + slot_symbol(stack_args(sc->stack, top)), + set_ulist_1(sc, sc->values_symbol, args)); + + case OP_AND_P1: + case OP_AND_SAFE_P_REST: /* from OP_AND_SAFE_P1 or P2 */ + for (x = args; is_not_null(cdr(x)); x = cdr(x)) + if (car(x) == sc->F) + return (sc->F); + return (car(x)); + + case OP_OR_P1: + for (x = args; is_not_null(cdr(x)); x = cdr(x)) + if (car(x) != sc->F) + return (car(x)); + return (car(x)); + + case OP_IF1: /* (if (values ...) ...) */ + case OP_IF_PP: + case OP_IF_PPP: + case OP_IF_PR: + case OP_IF_PRR: + case OP_WHEN_PP: + case OP_UNLESS_PP: + case OP_WITH_LET1: + case OP_CASE_G_G: + case OP_CASE_G_S: + case OP_CASE_E_G: + case OP_CASE_E_S: + case OP_CASE_S_G: + case OP_CASE_S_S: + case OP_CASE_I_S: + case OP_COND1: + case OP_COND1_SIMPLE: + return (car(args)); + + case OP_DYNAMIC_UNWIND: + case OP_DYNAMIC_UNWIND_PROFILE: + { + s7_pointer old_value = sc->value; + bool mv = is_multiple_value(args); + if (mv) + clear_multiple_value(args); + sc->value = cons(sc, sc->values_symbol, args); + dynamic_unwind(sc, stack_code(sc->stack, top), stack_args(sc->stack, top)); /* func (curlet) */ + sc->value = old_value; + if (mv) + set_multiple_value(args); + sc->stack_end -= 4; /* either op is possible I think */ + return (splice_in_values(sc, args)); + } + + case OP_BARRIER: + pop_stack(sc); + return (splice_in_values(sc, args)); + + case OP_GC_PROTECT: + sc->stack_end -= 4; + return (splice_in_values(sc, args)); + + case OP_BEGIN_HOOK: + case OP_BEGIN_NO_HOOK: + case OP_BEGIN_2_UNCHECKED: + case OP_SIMPLE_DO_STEP: + case OP_DOX_STEP_O: + case OP_DOX_STEP: + case OP_FLUSH_VALUES: + /* here we have a values call with nothing to splice into. So flush it... + * otherwise the multiple-values bit gets set in some innocent list and never unset: + * (let ((x '((1 2)))) (eval `(apply apply values x)) x) -> ((values 1 2)) + * other cases: (+ 1 (begin (values 5 6) (values 2 3)) 4) -> 10 -- the (5 6) is dropped + * (let () (values 1 2 3) 4) but (+ (let () (values 1 2))) -> 3 + */ + return (args); + + case OP_DEACTIVATE_GOTO: /* (+ (call-with-exit (lambda (ret) (values 1 2 3)))) */ + call_exit_active(stack_args(sc->stack, top)) = false; + + case OP_CATCH: + case OP_CATCH_1: + case OP_CATCH_2: + case OP_CATCH_ALL: /* (+ (catch #t (lambda () (values 3 4)) (lambda args args))) */ + pop_stack(sc); + return (splice_in_values(sc, args)); + + case OP_EXPANSION: + /* we get here if a reader-macro (define-expansion) returns multiple values. + * these need to be read in order into the current reader lists (we'll assume OP_READ_LIST is next in the stack. + * and that it will be expecting the next arg entry in sc->value). + */ + top -= 4; + for (x = args; is_not_null(cdr(x)); x = cdr(x)) + stack_args(sc->stack, top) = + cons(sc, car(x), T_Mut(stack_args(sc->stack, top))); + pop_stack(sc); /* need GC protection in loop above, so do this afterwards */ + return (car(x)); /* sc->value from OP_READ_LIST point of view */ + + case OP_EVAL_DONE: + if (stack_op(sc->stack, (top - 4)) == OP_NO_VALUES) + return (s7_error + (sc, sc->error_symbol, + set_elist_1(sc, + wrap_string(sc, + "function-port should not return multiple-values", + 47)))); + stack_element(sc->stack, top) = (s7_pointer) OP_SPLICE_VALUES; /* tricky -- continue from eval_done with the current splice */ + stack_args(sc->stack, top) = args; + push_stack_op(sc, OP_EVAL_DONE); + return (args); + + default: + /* fprintf(stderr, "%s[%d]: splice on: %s\n", __func__, __LINE__, op_names[stack_op(sc->stack, top)]); */ + break; + } + + /* let it meander back up the call chain until someone knows where to splice it + * the is_immutable check protects against setting the multiple value bit on (say) sc->hash_table_signature + */ + if (is_immutable(args)) + args = copy_proper_list(sc, args); /* copy needed else (apply values x) where x is a list can leave the mv bit on for x's value */ + if (needs_copied_args(args)) { + clear_needs_copied_args(args); + args = copy_proper_list(sc, args); + } + set_multiple_value(args); + return (args); +} + + +/* -------------------------------- values -------------------------------- */ +s7_pointer s7_values(s7_scheme * sc, s7_pointer args) +{ +#define H_values "(values obj ...) splices its arguments into whatever list holds it (its 'continuation')" +#define Q_values s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T) + + if (is_null(args)) /* ((lambda () (let ((x 1)) (set! x (boolean? (values)))))) */ + return (sc->no_value); + if (is_null(cdr(args))) + return (car(args)); + set_needs_copied_args(args); + /* copy needed: see s7test (test `(,x ,@y ,x) '(3 a b c 3)) -> (append (list-values x (apply-values y)) x), and apply_values calls s7_values directly */ + return (splice_in_values(sc, args)); +} + +#define g_values s7_values + +static s7_pointer values_p(s7_scheme * sc) +{ + return (sc->no_value); +} + +static s7_pointer values_p_p(s7_scheme * sc, s7_pointer p) +{ + return (p); +} + +static s7_pointer values_chooser(s7_scheme * sc, s7_pointer f, + int32_t args, s7_pointer expr, bool ops) +{ + if (args > 1) + return (sc->values_uncopied); /* splice_in_values */ + return (f); +} + + +/* -------------------------------- list-values -------------------------------- */ +static s7_pointer g_list_values(s7_scheme * sc, s7_pointer args) +{ +#define H_list_values "(list-values ...) returns its arguments in a list (internal to quasiquote)" +#define Q_list_values s7_make_circular_signature(sc, 1, 2, sc->is_list_symbol, sc->T) + + /* list-values can't be replaced by list(-n) because (list-values (values)) -> () and anything can be # (see s7test) */ + /* but (list-values ) will complain or get into an infinite recursion in copy_tree, so it should not use copy_tree */ + + s7_pointer x; + bool checked = false; + for (x = args; is_pair(x); x = cdr(x)) + if (is_pair(car(x))) { + if (is_checked(car(x))) + checked = true; + } else if (car(x) == sc->no_value) /* unchecked_car|cdr unrolled here is not faster */ + break; + if (is_null(x)) { + if (!checked) { /* (!tree_has_definers(sc, args)) seems to work, reduces copy_tree calls slightly, but costs more than it saves in tgen */ + s7_pointer p; + for (p = args; is_pair(p); p = cdr(p)) + if (is_immutable(p)) + return (copy_proper_list(sc, args)); + return (args); + } + sc->u = args; + check_free_heap_size(sc, 8192); + if (sc->safety > NO_SAFETY) { + if (!tree_is_cyclic(sc, args)) /* we're copying to clear optimizations I think, and a cyclic list here can't be optimized */ + args = cons_unchecked(sc, /* since list-values is a safe function, args can be immutable, which should not be passed through the copy */ + (is_unquoted_pair(car(args))) ? + copy_tree_with_type(sc, + car(args)) : + car(args), + (is_unquoted_pair(cdr(args))) ? + copy_tree_with_type(sc, + cdr(args)) : + cdr(args)); + } else + args = copy_tree(sc, args); /* not copy_any_list here -- see comment below */ + sc->u = sc->nil; + return (args); + } + /* if a macro expands into a recursive function with a macro argument as its body (or reasonable facsimile thereof), + * and the safety (as in safe_closure) of the body changes from safe to unsafe, then (due to the checked bits + * protecting against cycles in optimize_expression|syntax), the possible safe_closure call will not be fixed, + * the safe_closure's assumption about the saved local let will be violated, and we'll get " unbound" (see tgen.scm). + * clear_all_optimizations assumes its argument has no cycles, and automatically calling copy_tree slows + * everything down intolerably, so if the checked bit is on in a macro expansion, that means we're re-expanding this macro, + * and therefore have to copy the tree. But isn't that only the case if the macro expands into closures? + */ + { + s7_pointer p, tp, np; + if (is_null(args)) + return (sc->nil); + while (car(args) == sc->no_value) { + args = cdr(args); + if (is_null(args)) + return (sc->nil); + } + tp = list_1(sc, car(args)); + sc->y = tp; + for (p = cdr(args), np = tp; is_pair(p); p = cdr(p)) + if (car(p) != sc->no_value) { + set_cdr(np, list_1(sc, car(p))); + np = cdr(np); + } + sc->y = sc->nil; + return (tp); + } +} + + +/* -------------------------------- apply-values -------------------------------- */ +static s7_pointer g_apply_values(s7_scheme * sc, s7_pointer args) +{ +#define H_apply_values "(apply-values var) applies values to var. This is an internal function." +#define Q_apply_values s7_make_signature(sc, 2, sc->T, sc->is_list_symbol) + s7_pointer x; + /* apply-values takes 1 arg: ,@a -> (apply-values a) */ + if (is_null(args)) + return (sc->no_value); + + x = car(args); + if (is_null(x)) + return (sc->no_value); + + if (!s7_is_proper_list(sc, x)) + return (apply_list_error(sc, args)); + return (g_values(sc, x)); +} + +/* (apply values ...) replaces (unquote_splicing ...) + * (define-macro (hi a) `(+ 1 ,a) == (list '+ 1 a) + * (define-macro (hi a) ``(+ 1 ,,a) == (list list '+ 1 (list quote a))) + * (define-macro (hi a) `(+ 1 ,@a) == (list '+ 1 (apply values a)) + * (define-macro (hi a) ``(+ 1 ,,@a) == (list list '+ 1 (apply values a)) + * + * this is not the same as CL's quasiquote; for example: + * [1]> (let ((a 1) (b 2)) `(,a ,@b)) -> '(1 . 2) + * in s7 this is an error. + * + * also in CL the target of ,@ can apparently be a circular list + * one surprising twist: write/display return their first argument directly, so (apply-values (write `(+ x 1))) is the same as (apply-values `(+ x 1)) + * If this is in a function body, and the function is called twice, it is self-modifying code and behaves in unexpected ways. + */ + + +/* -------------------------------- quasiquote -------------------------------- */ +static bool is_simple_code(s7_scheme * sc, s7_pointer form) +{ + /* if nested with quasiquotes say 20 levels, this is really slow, but to tag intermediate results burns up 2 type bits */ + s7_pointer tmp, slow; + for (tmp = form, slow = form; is_pair(tmp); + tmp = cdr(tmp), slow = cdr(slow)) { + if (is_pair(car(tmp))) { + if (!is_simple_code(sc, car(tmp))) + return (false); + } else if (car(tmp) == sc->unquote_symbol) + return (false); + tmp = cdr(tmp); + if (!is_pair(tmp)) + return (is_null(tmp)); + if (tmp == slow) + return (false); + if (is_pair(car(tmp))) { + if (!is_simple_code(sc, car(tmp))) + return (false); + } else if (car(tmp) == sc->unquote_symbol) + return (false); + } + return (is_null(tmp)); +} + +/* since the reader expands unquote et al, and the printer does not unexpand them, the standard scheme quine in s7 is: + * ((lambda (x) (list-values x (list-values 'quote x))) '(lambda (x) (list-values x (list-values 'quote x)))) + * but that depends on the "p" in repl... + */ + +static s7_pointer g_quasiquote_1(s7_scheme * sc, s7_pointer form, + bool check_cycles) +{ +#define H_quasiquote "(quasiquote arg) is the same as `arg. If arg is a list, it can contain \ +comma (\"unquote\") and comma-atsign (\"apply values\") to pre-evaluate portions of the list. \ +unquoted expressions are evaluated and plugged into the list, apply-values evaluates the expression \ +and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -> (1 2 3 4)." + + if (!is_pair(form)) { + if (is_normal_symbol(form)) + return (list_2 + (sc, + (is_global(sc->quote_symbol)) ? sc->quote_symbol : + initial_value(sc->quote_symbol), form)); + /* things that evaluate to themselves don't need to be quoted. */ + return (form); + } + + if (car(form) == sc->unquote_symbol) { + if (!is_pair(cdr(form))) { /* (unquote) or (unquote . 1) */ + if (is_null(cdr(form))) + eval_error(sc, "unquote: no argument, ~S", 24, form); + else + eval_error(sc, "unquote: stray dot, ~S", 22, form); + } + if (is_not_null(cddr(form))) + eval_error(sc, "unquote: too many arguments, ~S", 31, form); + return (cadr(form)); + } + + /* it's a list, so return the list with each element handled as above. + * we try to support dotted lists which makes the code much messier. + * if no element of the list is a list or unquote, just return the original quoted + */ + if (((check_cycles) && (tree_is_cyclic(sc, form))) || + (is_simple_code(sc, form))) + /* we can't lookup sc->quote_symbol because this gets called in op_read_quasiquote (at read-time), and sc->curlet can be junk in that context */ + return (list_2 + (sc, + (is_global(sc->quote_symbol)) ? sc->quote_symbol : + initial_value(sc->quote_symbol), form)); + + { + s7_int len, i; + s7_pointer orig, bq, old_scw; + bool dotted = false; + + len = s7_list_length(sc, form); + if (len < 0) { + len = -len; + dotted = true; + } + old_scw = sc->w; + s7_gc_protect_via_stack(sc, sc->w); + + check_free_heap_size(sc, len); + sc->w = sc->nil; + for (i = 0; i <= len; i++) + sc->w = cons_unchecked(sc, sc->nil, sc->w); + + set_car(sc->w, sc->list_values_symbol); + if (!dotted) { + for (orig = form, bq = cdr(sc->w), i = 0; i < len; + i++, orig = cdr(orig), bq = cdr(bq)) + if ((is_pair(cdr(orig))) && /* this was is_pair(orig) which seems to be always the case */ + (cadr(orig) == sc->unquote_symbol)) { /* `(1 . ,(+ 1 1)) -> '(1 unquote (+ 1 1)) -> '(1 . 2) etc */ + if (!is_pair(cddr(orig))) { + sc->w = old_scw; + unstack(sc); + eval_error(sc, "unquote: no argument, ~S", 24, + form); + } + set_car(bq, g_quasiquote_1(sc, car(orig), false)); + set_cdr(bq, sc->nil); + sc->w = + list_3(sc, sc->append_symbol, sc->w, caddr(orig)); + break; + } else + set_car(bq, g_quasiquote_1(sc, car(orig), false)); + } else { + /* `(1 2 . 3) */ + len--; + for (orig = form, bq = cdr(sc->w), i = 0; i < len; + i++, orig = cdr(orig), bq = cdr(bq)) + set_car(bq, g_quasiquote_1(sc, car(orig), false)); + set_car(bq, g_quasiquote_1(sc, car(orig), false)); + + sc->w = + list_3(sc, sc->append_symbol, sc->w, + g_quasiquote_1(sc, cdr(orig), false)); + /* quasiquote might quote a symbol in cdr(orig), so it's not completely pointless */ + } + bq = sc->w; + sc->w = old_scw; + unstack(sc); + return (bq); + } +} + +static s7_pointer g_quasiquote(s7_scheme * sc, s7_pointer args) +{ + /* this is for explicit quasiquote support, not the backquote stuff in macros + * but it is problematic. g_quasiquote_1 above expands (for example) `(+ ,x) into (list (quote +) x), + * so (multiple-value-bind (quote) quasiquote `(+ ,x)) expands to ((lambda (quote) (list '+ x)) quasiquote) + * which is an infinite loop. Guile says syntax error (because it thinks "quote" can't be a parameter name, I think). + */ + return (g_quasiquote_1(sc, car(args), true)); +} + + +/* -------------------------------- choosers -------------------------------- */ +static s7_pointer make_function_with_class(s7_scheme * sc, s7_pointer cls, + const char *name, s7_function f, + int32_t required_args, + int32_t optional_args, + bool rest_arg) +{ + s7_pointer uf; + if ((S7_DEBUGGING) + && (!is_safe_procedure(global_value(s7_make_symbol(sc, name))))) + fprintf(stderr, "%s unsafe: %s\n", __func__, name); + uf = s7_make_safe_function(sc, name, f, required_args, optional_args, + rest_arg, NULL); + s7_function_set_class(sc, uf, cls); + c_function_signature(uf) = c_function_signature(cls); + return (uf); +} + +static s7_pointer make_unsafe_function_with_class(s7_scheme * sc, + s7_pointer cls, + const char *name, + s7_function f, + int32_t required_args, + int32_t optional_args, + bool rest_arg) +{ + s7_pointer uf; + uf = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, NULL); /* was s7_make_safe_function! 14-Dec-20 */ + s7_function_set_class(sc, uf, cls); + c_function_signature(uf) = c_function_signature(cls); + return (uf); +} + +static s7_pointer set_function_chooser(s7_scheme * sc, s7_pointer sym, + s7_pointer(*chooser) (s7_scheme * + sc, + s7_pointer f, + int32_t args, + s7_pointer + expr, + bool ops)) +{ + s7_pointer f = global_value(sym); + c_function_chooser(f) = chooser; + return (f); +} + +static void init_choosers(s7_scheme * sc) +{ + s7_pointer f; + + /* + */ + f = set_function_chooser(sc, sc->add_symbol, add_chooser); + sc->add_class = c_function_class(f); + sc->add_2 = make_function_with_class(sc, f, "+", g_add_2, 2, 0, false); + sc->add_3 = make_function_with_class(sc, f, "+", g_add_3, 3, 0, false); + sc->add_1x = + make_function_with_class(sc, f, "+", g_add_1x, 2, 0, false); + sc->add_x1 = + make_function_with_class(sc, f, "+", g_add_x1, 2, 0, false); + sc->add_i_random = + make_function_with_class(sc, f, "+", g_add_i_random, 2, 0, false); + sc->add_2_ff = + make_function_with_class(sc, f, "+", g_add_2_ff, 2, 0, false); + sc->add_2_ii = + make_function_with_class(sc, f, "+", g_add_2_ii, 2, 0, false); + sc->add_2_if = + make_function_with_class(sc, f, "+", g_add_2_if, 2, 0, false); + sc->add_2_fi = + make_function_with_class(sc, f, "+", g_add_2_fi, 2, 0, false); + sc->add_2_xi = + make_function_with_class(sc, f, "+", g_add_2_xi, 2, 0, false); + sc->add_2_ix = + make_function_with_class(sc, f, "+", g_add_2_ix, 2, 0, false); + sc->add_2_fx = + make_function_with_class(sc, f, "+", g_add_2_fx, 2, 0, false); + sc->add_2_xf = + make_function_with_class(sc, f, "+", g_add_2_xf, 2, 0, false); + + /* - */ + f = set_function_chooser(sc, sc->subtract_symbol, subtract_chooser); + sc->subtract_class = c_function_class(f); + sc->subtract_1 = + make_function_with_class(sc, f, "-", g_subtract_1, 1, 0, false); + sc->subtract_2 = + make_function_with_class(sc, f, "-", g_subtract_2, 2, 0, false); + sc->subtract_3 = + make_function_with_class(sc, f, "-", g_subtract_3, 3, 0, false); + sc->subtract_x1 = + make_function_with_class(sc, f, "-", g_subtract_x1, 2, 0, false); + sc->subtract_2f = + make_function_with_class(sc, f, "-", g_subtract_2f, 2, 0, false); + sc->subtract_f2 = + make_function_with_class(sc, f, "-", g_subtract_f2, 2, 0, false); + + /* * */ + f = set_function_chooser(sc, sc->multiply_symbol, multiply_chooser); + sc->multiply_class = c_function_class(f); + sc->multiply_2 = + make_function_with_class(sc, f, "*", g_multiply_2, 2, 0, false); + sc->mul_2_ff = + make_function_with_class(sc, f, "*", g_mul_2_ff, 2, 0, false); + sc->mul_2_ii = + make_function_with_class(sc, f, "*", g_mul_2_ii, 2, 0, false); + sc->mul_2_if = + make_function_with_class(sc, f, "*", g_mul_2_if, 2, 0, false); + sc->mul_2_fi = + make_function_with_class(sc, f, "*", g_mul_2_fi, 2, 0, false); + sc->mul_2_xi = + make_function_with_class(sc, f, "*", g_mul_2_xi, 2, 0, false); + sc->mul_2_ix = + make_function_with_class(sc, f, "*", g_mul_2_ix, 2, 0, false); + sc->mul_2_fx = + make_function_with_class(sc, f, "*", g_mul_2_fx, 2, 0, false); + sc->mul_2_xf = + make_function_with_class(sc, f, "*", g_mul_2_xf, 2, 0, false); + + /* / */ + f = set_function_chooser(sc, sc->divide_symbol, divide_chooser); + sc->invert_1 = + make_function_with_class(sc, f, "/", g_invert_1, 1, 0, false); + sc->divide_2 = + make_function_with_class(sc, f, "/", g_divide_2, 2, 0, false); + sc->invert_x = + make_function_with_class(sc, f, "/", g_invert_x, 2, 0, false); + sc->divide_by_2 = + make_function_with_class(sc, f, "/", g_divide_by_2, 2, 0, false); + + /* = */ + f = set_function_chooser(sc, sc->num_eq_symbol, num_eq_chooser); + sc->num_eq_class = c_function_class(f); + sc->num_eq_2 = + make_function_with_class(sc, f, "=", g_num_eq_2, 2, 0, false); + sc->num_eq_xi = + make_function_with_class(sc, f, "=", g_num_eq_xi, 2, 0, false); + sc->num_eq_ix = + make_function_with_class(sc, f, "=", g_num_eq_ix, 2, 0, false); + + /* min */ + f = set_function_chooser(sc, sc->min_symbol, min_chooser); + sc->min_2 = + make_function_with_class(sc, f, "min", g_min_2, 2, 0, false); + sc->min_3 = + make_function_with_class(sc, f, "min", g_min_3, 3, 0, false); + + /* max */ + f = set_function_chooser(sc, sc->max_symbol, max_chooser); + sc->max_2 = + make_function_with_class(sc, f, "max", g_max_2, 2, 0, false); + sc->max_3 = + make_function_with_class(sc, f, "max", g_max_3, 3, 0, false); + + /* < */ + f = set_function_chooser(sc, sc->lt_symbol, less_chooser); + sc->less_xi = + make_function_with_class(sc, f, "<", g_less_xi, 2, 0, false); + sc->less_x0 = + make_function_with_class(sc, f, "<", g_less_x0, 2, 0, false); + sc->less_xf = + make_function_with_class(sc, f, "<", g_less_xf, 2, 0, false); + sc->less_2 = + make_function_with_class(sc, f, "<", g_less_2, 2, 0, false); + + /* > */ + f = set_function_chooser(sc, sc->gt_symbol, greater_chooser); + sc->greater_xi = + make_function_with_class(sc, f, ">", g_greater_xi, 2, 0, false); + sc->greater_xf = + make_function_with_class(sc, f, ">", g_greater_xf, 2, 0, false); + sc->greater_2 = + make_function_with_class(sc, f, ">", g_greater_2, 2, 0, false); + + /* <= */ + f = set_function_chooser(sc, sc->leq_symbol, leq_chooser); + sc->leq_xi = + make_function_with_class(sc, f, "<=", g_leq_xi, 2, 0, false); + sc->leq_2 = + make_function_with_class(sc, f, "<=", g_leq_2, 2, 0, false); + sc->leq_ixx = + make_function_with_class(sc, f, "<=", g_leq_ixx, 3, 0, false); + + /* >= */ + f = set_function_chooser(sc, sc->geq_symbol, geq_chooser); + sc->geq_xi = + make_function_with_class(sc, f, ">=", g_geq_xi, 2, 0, false); + sc->geq_xf = + make_function_with_class(sc, f, ">=", g_geq_xf, 2, 0, false); + sc->geq_2 = + make_function_with_class(sc, f, ">=", g_geq_2, 2, 0, false); + + /* random */ + f = set_function_chooser(sc, sc->random_symbol, random_chooser); + sc->random_1 = + make_function_with_class(sc, f, "random", g_random_1, 1, 0, false); + sc->random_i = + make_function_with_class(sc, f, "random", g_random_i, 1, 0, false); + sc->random_f = + make_function_with_class(sc, f, "random", g_random_f, 1, 0, false); + + /* defined? */ + f = set_function_chooser(sc, sc->is_defined_symbol, + is_defined_chooser); + sc->is_defined_in_rootlet = + make_function_with_class(sc, f, "defined?", + g_is_defined_in_rootlet, 2, 0, false); + + /* char=? */ + f = set_function_chooser(sc, sc->char_eq_symbol, char_equal_chooser); + sc->simple_char_eq = + make_function_with_class(sc, f, "char=?", g_simple_char_eq, 2, 0, + false); + sc->char_equal_2 = + make_function_with_class(sc, f, "char=?", g_char_equal_2, 2, 0, + false); + + /* char>? */ + f = set_function_chooser(sc, sc->char_gt_symbol, char_greater_chooser); + sc->char_greater_2 = + make_function_with_class(sc, f, "char>?", g_char_greater_2, 2, 0, + false); + + /* charchar_lt_symbol, char_less_chooser); + sc->char_less_2 = + make_function_with_class(sc, f, "charread_char_symbol, read_char_chooser); + sc->read_char_1 = + make_function_with_class(sc, f, "read-char", g_read_char_1, 1, 0, + false); + + /* char-position */ + f = set_function_chooser(sc, sc->char_position_symbol, + char_position_chooser); + sc->char_position_csi = + make_function_with_class(sc, f, "char-position", + g_char_position_csi, 2, 1, false); + + /* string=? */ + f = set_function_chooser(sc, sc->string_eq_symbol, + string_equal_chooser); + sc->string_equal_2 = + make_function_with_class(sc, f, "string=?", g_string_equal_2, 2, 0, + false); + sc->string_equal_2c = + make_function_with_class(sc, f, "string=?", g_string_equal_2c, 2, + 0, false); + + /* substring */ + sc->substring_uncopied = + s7_make_function(sc, "substring", g_substring_uncopied, 2, 1, + false, NULL); + s7_function_set_class(sc, sc->substring_uncopied, + global_value(sc->substring_symbol)); + + /* string>? */ + f = set_function_chooser(sc, sc->string_gt_symbol, + string_greater_chooser); + sc->string_greater_2 = + make_function_with_class(sc, f, "string>?", g_string_greater_2, 2, + 0, false); + + /* stringstring_lt_symbol, + string_less_chooser); + sc->string_less_2 = + make_function_with_class(sc, f, "stringstring_symbol, string_chooser); + sc->string_c1 = + make_function_with_class(sc, f, "string", g_string_c1, 1, 0, + false); + + /* string-append */ + f = set_function_chooser(sc, sc->string_append_symbol, + string_append_chooser); + sc->string_append_2 = + make_function_with_class(sc, f, "string-append", g_string_append_2, + 2, 0, false); + + /* string-ref et al */ + set_function_chooser(sc, sc->string_ref_symbol, + string_substring_chooser); + set_function_chooser(sc, sc->string_to_symbol_symbol, string_substring_chooser); /* not string_to_number here */ + set_function_chooser(sc, sc->string_to_keyword_symbol, + string_substring_chooser); + set_function_chooser(sc, sc->string_downcase_symbol, + string_substring_chooser); + set_function_chooser(sc, sc->string_upcase_symbol, + string_substring_chooser); + /* if the function assumes a null-terminated string, substring needs to return a copy */ +#if (!WITH_PURE_S7) + set_function_chooser(sc, sc->string_length_symbol, + string_substring_chooser); + set_function_chooser(sc, sc->string_to_list_symbol, + string_substring_chooser); +#endif + set_function_chooser(sc, sc->string_copy_symbol, string_copy_chooser); + + /* symbol->string */ + f = global_value(sc->symbol_to_string_symbol); + sc->symbol_to_string_uncopied = + s7_make_function(sc, "symbol->string", g_symbol_to_string_uncopied, + 1, 0, false, NULL); + s7_function_set_class(sc, sc->symbol_to_string_uncopied, f); + + /* display */ + f = set_function_chooser(sc, sc->display_symbol, display_chooser); + sc->display_f = + make_function_with_class(sc, f, "display", g_display_f, 2, 0, + false); + sc->display_2 = + make_function_with_class(sc, f, "display", g_display_2, 2, 0, + false); + + /* vector */ + f = set_function_chooser(sc, sc->vector_symbol, vector_chooser); + sc->vector_2 = + make_function_with_class(sc, f, "vector", g_vector_2, 2, 0, false); + sc->vector_3 = + make_function_with_class(sc, f, "vector", g_vector_3, 3, 0, false); + + /* vector-ref */ + f = set_function_chooser(sc, sc->vector_ref_symbol, + vector_ref_chooser); + sc->vector_ref_2 = + make_function_with_class(sc, f, "vector-ref", g_vector_ref_2, 2, 0, + false); + sc->vector_ref_3 = + make_function_with_class(sc, f, "vector-ref", g_vector_ref_3, 3, 0, + false); + + /* vector-set! */ + f = set_function_chooser(sc, sc->vector_set_symbol, + vector_set_chooser); + sc->vector_set_3 = + make_function_with_class(sc, f, "vector-set!", g_vector_set_3, 3, + 0, false); + sc->vector_set_4 = + make_function_with_class(sc, f, "vector-set!", g_vector_set_4, 4, + 0, false); + + /* float-vector-ref */ + f = set_function_chooser(sc, sc->float_vector_ref_symbol, + float_vector_ref_chooser); + sc->fv_ref_2 = + make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_2, 2, + 0, false); + sc->fv_ref_3 = + make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_3, 3, + 0, false); + + /* float-vector-set */ + f = set_function_chooser(sc, sc->float_vector_set_symbol, + float_vector_set_chooser); + sc->fv_set_3 = + make_function_with_class(sc, f, "float-vector-set!", g_fv_set_3, 3, + 0, false); + sc->fv_set_unchecked = + make_function_with_class(sc, f, "float-vector-set!", + g_fv_set_unchecked, 3, 0, false); + + /* int-vector-ref */ + f = set_function_chooser(sc, sc->int_vector_ref_symbol, + int_vector_ref_chooser); + sc->iv_ref_2 = + make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_2, 2, 0, + false); + sc->iv_ref_3 = + make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_3, 3, 0, + false); + + /* int-vector-set */ + f = set_function_chooser(sc, sc->int_vector_set_symbol, + int_vector_set_chooser); + sc->iv_set_3 = + make_function_with_class(sc, f, "int-vector-set!", g_iv_set_3, 3, + 0, false); + + /* byte-vector-ref */ + f = set_function_chooser(sc, sc->byte_vector_ref_symbol, + byte_vector_ref_chooser); + sc->bv_ref_2 = + make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_2, 2, + 0, false); + sc->bv_ref_3 = + make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_3, 3, + 0, false); + + /* byte-vector-set */ + f = set_function_chooser(sc, sc->byte_vector_set_symbol, + byte_vector_set_chooser); + sc->bv_set_3 = + make_function_with_class(sc, f, "byte-vector-set!", g_bv_set_3, 3, + 0, false); + + /* list-set! */ + f = set_function_chooser(sc, sc->list_set_symbol, list_set_chooser); + sc->list_set_i = + make_function_with_class(sc, f, "list-set!", g_list_set_i, 3, 0, + false); + + /* hash-table-ref */ + f = set_function_chooser(sc, sc->hash_table_ref_symbol, + hash_table_ref_chooser); + sc->hash_table_ref_2 = + make_function_with_class(sc, f, "hash-table-ref", + g_hash_table_ref_2, 2, 0, false); + + /* hash-table-set! */ + set_function_chooser(sc, sc->hash_table_set_symbol, + hash_table_set_chooser); + + /* hash-table */ + f = set_function_chooser(sc, sc->hash_table_symbol, + hash_table_chooser); + sc->hash_table_2 = + make_function_with_class(sc, f, "hash-table", g_hash_table_2, 2, 0, + false); + + /* format */ + f = set_function_chooser(sc, sc->format_symbol, format_chooser); + sc->format_f = + make_function_with_class(sc, f, "format", g_format_f, 1, 0, true); + sc->format_no_column = + make_function_with_class(sc, f, "format", g_format_no_column, 1, 0, + true); + sc->format_just_control_string = + make_function_with_class(sc, f, "format", + g_format_just_control_string, 2, 0, + false); + sc->format_as_objstr = + make_function_with_class(sc, f, "format", g_format_as_objstr, 3, 0, + true); + + /* list */ + f = set_function_chooser(sc, sc->list_symbol, list_chooser); + sc->list_0 = + make_function_with_class(sc, f, "list", g_list_0, 0, 0, false); + sc->list_1 = + make_function_with_class(sc, f, "list", g_list_1, 1, 0, false); + sc->list_2 = + make_function_with_class(sc, f, "list", g_list_2, 2, 0, false); + sc->list_3 = + make_function_with_class(sc, f, "list", g_list_3, 3, 0, false); + sc->list_4 = + make_function_with_class(sc, f, "list", g_list_4, 4, 0, false); + + /* append */ + f = set_function_chooser(sc, sc->append_symbol, append_chooser); + sc->append_2 = + make_function_with_class(sc, f, "append", g_append_2, 2, 0, false); + + /* list-ref */ + f = set_function_chooser(sc, sc->list_ref_symbol, list_ref_chooser); + sc->list_ref_at_0 = + make_function_with_class(sc, f, "list", g_list_ref_at_0, 2, 0, + false); + sc->list_ref_at_1 = + make_function_with_class(sc, f, "list", g_list_ref_at_1, 2, 0, + false); + sc->list_ref_at_2 = + make_function_with_class(sc, f, "list", g_list_ref_at_2, 2, 0, + false); + + /* assoc */ + set_function_chooser(sc, sc->assoc_symbol, assoc_chooser); + + /* member */ + set_function_chooser(sc, sc->member_symbol, member_chooser); + + /* memq */ + f = set_function_chooser(sc, sc->memq_symbol, memq_chooser); /* is pure-s7, use member here */ + sc->memq_2 = + make_function_with_class(sc, f, "memq", g_memq_2, 2, 0, false); + sc->memq_3 = + make_function_with_class(sc, f, "memq", g_memq_3, 2, 0, false); + sc->memq_4 = + make_function_with_class(sc, f, "memq", g_memq_4, 2, 0, false); + sc->memq_any = + make_function_with_class(sc, f, "memq", g_memq_any, 2, 0, false); + + /* tree-set-memq */ + f = set_function_chooser(sc, sc->tree_set_memq_symbol, + tree_set_memq_chooser); + sc->tree_set_memq_syms = + make_function_with_class(sc, f, "tree-set-memq", g_tree_set_memq_1, + 2, 0, false); + + /* eval-string */ + set_function_chooser(sc, sc->eval_string_symbol, eval_string_chooser); + + /* dynamic-wind */ + f = set_function_chooser(sc, sc->dynamic_wind_symbol, + dynamic_wind_chooser); + sc->dynamic_wind_unchecked = + make_unsafe_function_with_class(sc, f, "dynamic-wind", + g_dynamic_wind_unchecked, 3, 0, + false); + + /* inlet */ + f = set_function_chooser(sc, sc->inlet_symbol, inlet_chooser); + sc->simple_inlet = + make_function_with_class(sc, f, "inlet", g_simple_inlet, 0, 0, + true); + + /* let-ref */ + f = set_function_chooser(sc, sc->let_ref_symbol, let_ref_chooser); + sc->lint_let_ref = + make_function_with_class(sc, f, "let-ref", g_lint_let_ref, 2, 0, + false); + + /* let-set */ + f = set_function_chooser(sc, sc->let_set_symbol, let_set_chooser); + sc->lint_let_set = + make_function_with_class(sc, f, "let-set!", g_lint_let_set, 3, 0, + false); + + /* values */ + f = set_function_chooser(sc, sc->values_symbol, values_chooser); + sc->values_uncopied = + make_unsafe_function_with_class(sc, f, "values", splice_in_values, + 0, 0, true); +} + + +/* ---------------- reader funcs for eval ---------------- */ + +static void back_up_stack(s7_scheme * sc) +{ + opcode_t top_op = stack_op(sc->stack, current_stack_top(sc) - 1); + if (top_op == OP_READ_DOT) { + pop_stack(sc); + top_op = stack_op(sc->stack, current_stack_top(sc) - 1); + } + if ((top_op == OP_READ_VECTOR) || + (top_op == OP_READ_BYTE_VECTOR) || + (top_op == OP_READ_INT_VECTOR) || + (top_op == OP_READ_FLOAT_VECTOR)) { + pop_stack(sc); + top_op = stack_op(sc->stack, current_stack_top(sc) - 1); + } + if (top_op == OP_READ_QUOTE) + pop_stack(sc); +} + +static token_t read_sharp(s7_scheme * sc, s7_pointer pt) +{ + int32_t c; + /* inchar can return EOF, so it can't be used directly as an index into the digits array */ + c = inchar(pt); + switch (c) { + case EOF: + s7_error(sc, sc->read_error_symbol, + set_elist_1(sc, + wrap_string(sc, + "unexpected '#' at end of input", + 30))); + break; + + case '(': + sc->w = int_one; + return (TOKEN_VECTOR); + + case 'i': + if (read_sharp(sc, pt) == TOKEN_VECTOR) + return (TOKEN_INT_VECTOR); + backchar('i', pt); + break; + + case 'r': + if (read_sharp(sc, pt) == TOKEN_VECTOR) + return (TOKEN_FLOAT_VECTOR); + backchar('r', pt); + break; + + case 'u': + if (s7_peek_char(sc, pt) == chars[(int32_t) ('8')]) { /* backwards compatibility: #u8(...) == #u(...) */ + int32_t bc; + bc = inchar(pt); + if (s7_peek_char(sc, pt) == chars[(int32_t) ('(')]) { + inchar(pt); + sc->w = int_one; + return (TOKEN_BYTE_VECTOR); + } + backchar(bc, pt); + } + if (read_sharp(sc, pt) == TOKEN_VECTOR) + return (TOKEN_BYTE_VECTOR); + backchar('u', pt); + break; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + { + /* here we can get an overflow: #1231231231231232131D() */ + s7_int dims; + int32_t d, loc = 0; + sc->strbuf[loc++] = (unsigned char) c; + dims = digits[c]; + + while (true) { + s7_int dig; + d = inchar(pt); + if (d == EOF) + s7_error(sc, sc->read_error_symbol, + set_elist_1(sc, + wrap_string(sc, + "unexpected end of input while reading #n...", + 43))); + dig = digits[d]; + if (dig >= 10) + break; + dims = dig + (dims * 10); + if (dims <= 0) { + sc->strbuf[loc++] = (unsigned char) d; + s7_error(sc, sc->read_error_symbol, + set_elist_3(sc, + wrap_string(sc, + "reading #~A...: ~A must be a positive integer", + 37), wrap_string(sc, + sc->strbuf, + loc), + wrap_integer1(sc, dims))); + } + if (dims > sc->max_vector_dimensions) { + sc->strbuf[loc++] = (unsigned char) d; + sc->strbuf[loc + 1] = '\0'; + s7_error(sc, sc->read_error_symbol, + set_elist_4(sc, + wrap_string(sc, + "reading #~A...: ~A is too large, (*s7* 'max-vector-dimensions): ~A", + 66), wrap_string(sc, + sc->strbuf, + loc), + wrap_integer1(sc, dims), + wrap_integer2(sc, + sc->max_vector_dimensions))); + } + sc->strbuf[loc++] = (unsigned char) d; + } + sc->strbuf[loc++] = d; + if ((d == 'd') || (d == 'i') || (d == 'r') || (d == 'u')) { + int32_t e; + e = inchar(pt); + if (e == EOF) + s7_error(sc, sc->read_error_symbol, + set_elist_1(sc, + wrap_string(sc, + "unexpected end of input while reading #n()", + 42))); + sc->strbuf[loc++] = (unsigned char) e; + if (e == '(') { + sc->w = make_integer(sc, dims); + if (d == 'd') + return (TOKEN_VECTOR); + if (d == 'r') + return (TOKEN_FLOAT_VECTOR); + return ((d == + 'u') ? TOKEN_BYTE_VECTOR : TOKEN_INT_VECTOR); + } + } + /* try to back out */ + for (d = loc - 1; d > 0; d--) + backchar(sc->strbuf[d], pt); + } + break; + + case ':': /* turn #: into : -- this is for compatibility with Guile, sigh. + * I just noticed that Rick is using this -- I'll just leave it alone. + * but that means : readers need to handle this case specially. + * I don't think #! is special anymore -- maybe remove that code? + */ + sc->strbuf[0] = ':'; + return (TOKEN_ATOM); + + /* block comments in #! ... !# */ + /* this is needed when an input file is treated as a script: + #!/home/bil/cl/snd + !# + (format #t "a test~%") + (exit) + * but very often the closing !# is omitted which is too bad + */ + case '!': + { + char last_char; + s7_pointer reader; + + /* make it possible to override #! handling */ + for (reader = slot_value(sc->sharp_readers); is_pair(reader); + reader = cdr(reader)) + if (s7_character(caar(reader)) == '!') { + sc->strbuf[0] = (unsigned char) c; + return (TOKEN_SHARP_CONST); /* next stage notices any errors */ + } + + /* not #! as block comment (for Guile I guess) */ + last_char = ' '; + while ((c = inchar(pt)) != EOF) { + if ((c == '#') && (last_char == '!')) + break; + last_char = c; + } + if (c == EOF) + s7_error(sc, sc->read_error_symbol, + set_elist_1(sc, + wrap_string(sc, + "unexpected end of input while reading #!", + 40))); + return (token(sc)); + } + + /* block comments in #| ... |# + * since we ignore everything until the |#, internal semicolon comments are ignored, + * meaning that ;|# is as effective as |# + */ + case '|': + { + const char *str, *orig_str, *p, *pend; + if (is_file_port(pt)) { + char last_char = ' '; + while (true) { + c = fgetc(port_file(pt)); + if (c == EOF) + s7_error(sc, sc->read_error_symbol, + set_elist_1(sc, + wrap_string(sc, + "unexpected end of input while reading #|", + 40))); + if ((c == '#') && (last_char == '|')) + break; + last_char = c; + if (c == '\n') + port_line_number(pt)++; + } + return (token(sc)); + } + + orig_str = (const char *) (port_data(pt) + port_position(pt)); + pend = (const char *) (port_data(pt) + port_data_size(pt)); + str = orig_str; + + while (true) { + p = strchr(str, (int) '|'); + if ((!p) || (p >= pend)) { + port_position(pt) = port_data_size(pt); + s7_error(sc, sc->read_error_symbol, + set_elist_1(sc, + wrap_string(sc, + "unexpected end of input while reading #|", + 40))); + } + if (p[1] == '#') + break; + str = (const char *) (p + 1); + } + port_position(pt) += (p - orig_str + 2); + + /* now count newlines inside the comment */ + str = (const char *) orig_str; + pend = p; + while (true) { + p = strchr(str, (int) '\n'); + if ((p) && (p < pend)) { + port_line_number(pt)++; + str = (char *) (p + 1); + } else + break; + } + return (token(sc)); + } + } + sc->strbuf[0] = (unsigned char) c; + return (TOKEN_SHARP_CONST); /* next stage notices any errors */ +} + +static token_t read_comma(s7_scheme * sc, s7_pointer pt) +{ + int32_t c; + /* here we probably should check for symbol names that start with "@": + (define-macro (hi @foo) `(+ ,@foo 1)) -> hi + (hi 2) -> ;foo: unbound variable + but + (define-macro (hi .foo) `(+ ,.foo 1)) -> hi + (hi 2) -> 3 + and ambiguous: + (define-macro (hi @foo . foo) `(list ,@foo)) + what about , @foo -- is the space significant? We accept ,@ foo. + */ + + if ((c = inchar(pt)) == '@') + return (TOKEN_AT_MARK); + + if (c == EOF) { + sc->strbuf[0] = ','; /* was '@' which doesn't make any sense */ + return (TOKEN_COMMA); /* was TOKEN_ATOM, which also doesn't seem sensible */ + } + backchar(c, pt); + return (TOKEN_COMMA); +} + +static token_t read_dot(s7_scheme * sc, s7_pointer pt) +{ + int32_t c; + c = inchar(pt); + if (c != EOF) { + backchar(c, pt); + if ((!char_ok_in_a_name[c]) && (c != 0)) + return (TOKEN_DOT); + } else { + sc->strbuf[0] = '.'; + return (TOKEN_DOT); + } + sc->strbuf[0] = '.'; + return (TOKEN_ATOM); /* i.e. something that can start with a dot like a number */ +} + +static token_t token(s7_scheme * sc) +{ /* inline here is slower */ + int32_t c; + c = port_read_white_space(current_input_port(sc)) (sc, + current_input_port + (sc)); + switch (c) { + case '(': + return (TOKEN_LEFT_PAREN); + case ')': + return (TOKEN_RIGHT_PAREN); + case '.': + return (read_dot(sc, current_input_port(sc))); + case '\'': + return (TOKEN_QUOTE); + case ';': + return (port_read_semicolon(current_input_port(sc)) + (sc, current_input_port(sc))); + case '"': + return (TOKEN_DOUBLE_QUOTE); + case '`': + return (TOKEN_BACK_QUOTE); + case ',': + return (read_comma(sc, current_input_port(sc))); + case '#': + return (read_sharp(sc, current_input_port(sc))); + case '\0': + case EOF: + return (TOKEN_EOF); + default: + sc->strbuf[0] = (unsigned char) c; /* every TOKEN_ATOM return goes to port_read_name, so we save a backchar/inchar shuffle by starting the read here */ + return (TOKEN_ATOM); + } +} + +static int32_t read_x_char(s7_scheme * sc, int32_t i, s7_pointer pt) +{ + /* possible "\xn...;" char (write creates these things, so we have to read them) + * but we could have crazy input like "\x -- with no trailing double quote + */ + while (true) { + int32_t d1, d2, c; + c = inchar(pt); + if (c == '"') { + backchar(c, pt); + return (i); + } + if (c == ';') + return (i); + if (c == EOF) { + read_error(sc, "# in midst of hex-char"); + return (i); + } + d1 = digits[c]; + if (d1 >= 16) { + sc->strbuf[i++] = (unsigned char) c; /* just go on -- maybe a special char is not intended */ + return (i); + } + c = inchar(pt); + if (c == '"') { + sc->strbuf[i++] = (unsigned char) d1; + backchar((char) c, pt); + return (i); + } + if (c == EOF) { + read_error(sc, "# in midst of hex-char"); + return (i); + } + if (c == ';') { + sc->strbuf[i++] = (unsigned char) d1; + return (i); + } + d2 = digits[c]; + if (d2 >= 16) { + sc->strbuf[i++] = (unsigned char) c; /* just go on -- maybe a special char is not intended */ + return (i); + } + sc->strbuf[i++] = (unsigned char) (16 * d1 + d2); + } + return (i); +} + +static s7_pointer unknown_string_constant(s7_scheme * sc, int32_t c) +{ + /* check *read-error-hook* */ + if (hook_has_functions(sc->read_error_hook)) { + s7_pointer result; + result = + s7_call(sc, sc->read_error_hook, + set_plist_2(sc, sc->F, chars[(uint8_t) c])); + if (is_character(result)) + return (result); + } + return (sc->T); +} + +static s7_pointer read_string_constant(s7_scheme * sc, s7_pointer pt) +{ + /* sc->F => error, no check needed here for bad input port and so on */ + s7_int i = 0; + + if (is_string_port(pt)) { + /* try the most common case first */ + char *s, *start, *end; + start = (char *) (port_data(pt) + port_position(pt)); + if (*start == '"') { + port_position(pt)++; + return (nil_string); + } + + end = (char *) (port_data(pt) + port_data_size(pt)); + s = strpbrk(start, "\"\n\\"); + if ((!s) || (s >= end)) { /* can this read a huge string constant from a file? */ + if (start == end) + sc->strbuf[0] = '\0'; + else + memcpy((void *) (sc->strbuf), (void *) start, + (end - start > 8) ? 8 : (end - start)); + sc->strbuf[8] = '\0'; + return (sc->F); + } + if (*s == '"') { + s7_int len; + len = s - start; + port_position(pt) += (len + 1); + return (make_string_with_length(sc, start, len)); + } + + for (; s < end; s++) { + if (*s == '"') { /* switch here no faster */ + s7_int len; + len = s - start; + port_position(pt) += (len + 1); + return (make_string_with_length(sc, start, len)); + } + if (*s == '\\') { + /* all kinds of special cases here (resultant string is not the current string), so drop to loop below (setting "i") */ + s7_int len; + len = (s7_int) (s - start); + if (len > 0) { + if (len >= sc->strbuf_size) + resize_strbuf(sc, len); + memcpy((void *) (sc->strbuf), + (void *) (port_data(pt) + port_position(pt)), + len); + port_position(pt) += len; + } + i = len; + break; + } else if (*s == '\n') + port_line_number(pt)++; + } + } + + while (true) { + /* splitting this check out and duplicating the loop was slower?!? */ + int32_t c; + c = port_read_character(pt) (sc, pt); + + switch (c) { + case '\n': + port_line_number(pt)++; + sc->strbuf[i++] = (unsigned char) c; + break; + + case EOF: + sc->strbuf[(i > 8) ? 8 : i] = '\0'; + return (sc->F); + + case '"': + return (make_string_with_length(sc, sc->strbuf, i)); + + case '\\': + c = inchar(pt); + + switch (c) { + case EOF: + sc->strbuf[(i > 8) ? 8 : i] = '\0'; + return (sc->F); + + case '\\': + case '"': + case '|': + sc->strbuf[i++] = (unsigned char) c; + break; + + case 'n': + sc->strbuf[i++] = '\n'; + break; + case 't': + sc->strbuf[i++] = '\t'; + break; + case 'r': + sc->strbuf[i++] = '\r'; + break; + case '/': + sc->strbuf[i++] = '/'; + break; + case 'b': + sc->strbuf[i++] = (unsigned char) 8; + break; + case 'f': + sc->strbuf[i++] = (unsigned char) 12; + break; + + case 'x': + i = read_x_char(sc, i, pt); + break; + + default: /* if (!is_white_space(c)) *//* changed 8-Apr-12 */ + if ((c != '\n') && (c != '\r')) { /* i.e. line continuation via #\\ at end of line */ + s7_pointer result; + result = unknown_string_constant(sc, c); + if (is_character(result)) + sc->strbuf[i++] = character(result); + else + return (result); + } + /* #f here would give confusing error message "end of input", so return #t=bad backslash. + * this is not optimal. It's easy to forget that backslash needs to be backslashed. + * the white_space business half-implements Scheme's \...... or \...... + * feature -- the characters after \ are flushed if they're all white space and include a newline. + * (string->number "1\ 2") is 12?? Too bizarre. + */ + } + break; + + default: + sc->strbuf[i++] = (unsigned char) c; + break; + } + + if (i >= sc->strbuf_size) + resize_strbuf(sc, i); + } +} + +static void read_double_quote(s7_scheme * sc) +{ + sc->value = read_string_constant(sc, current_input_port(sc)); + if (sc->value == sc->F) /* can happen if input code ends in the middle of a string */ + string_read_error(sc, + "end of input encountered while in a string"); + if (sc->value == sc->T) + read_error(sc, + "unknown backslash usage -- perhaps you meant two backslashes?"); + if (sc->safety > IMMUTABLE_VECTOR_SAFETY) + set_immutable(sc->value); +} + +static inline bool read_sharp_const(s7_scheme * sc) +{ + sc->value = + port_read_sharp(current_input_port(sc)) (sc, + current_input_port(sc)); + if (sc->value == sc->no_value) { + /* (set! *#readers* (cons (cons #\; (lambda (s) (read) (values))) *#readers*)) + * (+ 1 #;(* 2 3) 4) + * so we need to get the next token, act on it without any assumptions about read list + */ + sc->tok = token(sc); + return (true); + } + return (false); +} + +static s7_pointer read_expression_read_error(s7_scheme * sc) +{ + s7_pointer pt; + pop_stack(sc); + pt = current_input_port(sc); + if ((is_input_port(pt)) && + (!port_is_closed(pt)) && + (port_data(pt)) && (port_position(pt) > 0)) { + s7_int start, pos = port_position(pt); + s7_pointer p; + char *msg; + + start = pos - 40; + if (start < 0) + start = 0; + + p = make_empty_string(sc, 128, '\0'); + msg = string_value(p); + memcpy((void *) msg, (void *) "at \"...", 7); + memcpy((void *) (msg + 7), (void *) (port_data(pt) + start), + pos - start); + memcpy((void *) (msg + 7 + pos - start), (void *) "...", 3); + string_length(p) = 7 + pos - start + 3; + return (s7_error(sc, sc->read_error_symbol, set_elist_1(sc, p))); + } + return (read_error(sc, "stray comma before ')'?")); /* '("a" "b",) */ +} + +static s7_pointer read_expression(s7_scheme * sc) +{ + while (true) { + int32_t c; + switch (sc->tok) { + case TOKEN_EOF: + return (eof_object); + + case TOKEN_BYTE_VECTOR: + push_stack_no_let_no_code(sc, OP_READ_BYTE_VECTOR, sc->w); + sc->tok = TOKEN_LEFT_PAREN; + break; + + case TOKEN_INT_VECTOR: + push_stack_no_let_no_code(sc, OP_READ_INT_VECTOR, sc->w); + sc->tok = TOKEN_LEFT_PAREN; + break; + + case TOKEN_FLOAT_VECTOR: + push_stack_no_let_no_code(sc, OP_READ_FLOAT_VECTOR, sc->w); + sc->tok = TOKEN_LEFT_PAREN; + break; + + case TOKEN_VECTOR: /* already read #( -- TOKEN_VECTOR is triggered by #( */ + push_stack_no_let_no_code(sc, OP_READ_VECTOR, sc->w); /* sc->w is the dimensions */ + /* fall through */ + + case TOKEN_LEFT_PAREN: + sc->tok = token(sc); + if (sc->tok == TOKEN_RIGHT_PAREN) + return (sc->nil); + if (sc->tok == TOKEN_DOT) { + back_up_stack(sc); + do { + c = inchar(current_input_port(sc)); + } while ((c != ')') && (c != EOF)); + return (read_error(sc, "stray dot after '('?")); /* (car '( . )) */ + } + if (sc->tok == TOKEN_EOF) + return (missing_close_paren_error(sc)); + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil); + /* here we need to clear args, but code is ignored */ + check_stack_size(sc); /* s7test */ + break; + + case TOKEN_QUOTE: + push_stack_no_let_no_code(sc, OP_READ_QUOTE, sc->nil); + sc->tok = token(sc); + break; + + case TOKEN_BACK_QUOTE: + sc->tok = token(sc); + push_stack_no_let_no_code(sc, OP_READ_QUASIQUOTE, sc->nil); + break; + + case TOKEN_COMMA: + push_stack_no_let_no_code(sc, OP_READ_UNQUOTE, sc->nil); + sc->tok = token(sc); + switch (sc->tok) { + case TOKEN_EOF: + pop_stack(sc); + return (read_error + (sc, "stray comma at the end of the input?")); + case TOKEN_RIGHT_PAREN: + return (read_expression_read_error(sc)); + default: + break; + } + break; + + case TOKEN_AT_MARK: + push_stack_no_let_no_code(sc, OP_READ_APPLY_VALUES, sc->nil); + sc->tok = token(sc); + break; + + case TOKEN_ATOM: + return (port_read_name(current_input_port(sc)) + (sc, current_input_port(sc))); + /* If reading list (from lparen), this will finally get us to op_read_list */ + + case TOKEN_DOUBLE_QUOTE: + read_double_quote(sc); + return (sc->value); + + case TOKEN_SHARP_CONST: + return (port_read_sharp(current_input_port(sc)) + (sc, current_input_port(sc))); + + case TOKEN_DOT: /* (catch #t (lambda () (+ 1 . . )) (lambda args 'hiho)) */ + back_up_stack(sc); + do { + c = inchar(current_input_port(sc)); + } while ((c != ')') && (c != EOF)); + return (read_error(sc, "stray dot in list?")); /* (+ 1 . . ) */ + + case TOKEN_RIGHT_PAREN: /* (catch #t (lambda () '(1 2 . )) (lambda args 'hiho)) */ + back_up_stack(sc); + return (read_error(sc, "unexpected close paren")); /* (+ 1 2)) or (+ 1 . ) */ + } + } + /* we never get here */ + return (sc->nil); +} + +static void read_dot_and_expression(s7_scheme * sc) +{ + push_stack_no_let_no_code(sc, OP_READ_DOT, sc->args); + sc->tok = token(sc); + sc->value = read_expression(sc); +} + +static void read_tok_default(s7_scheme * sc) +{ + /* by far the main case here is TOKEN_LEFT_PAREN, but it doesn't save anything to move it to this level */ + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + sc->value = read_expression(sc); + /* check for op_read_list here and explicit pop_stack are slower */ +} + +static void pair_set_current_input_location(s7_scheme * sc, s7_pointer p) +{ + if (current_input_port(sc) != sc->standard_input) { /* (port_file_number(current_input_port(sc)) > 1) -- maybe 0 is legit? */ + pair_set_location(p, port_location(current_input_port(sc))); + set_has_location(p); /* current_input_port(sc) above can't be nil(?) -- it falls back on stdin now */ + } +} + +static int32_t read_atom(s7_scheme * sc, s7_pointer pt) +{ + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + /* check_stack_size(sc); */ + sc->value = port_read_name(pt) (sc, pt); + sc->args = list_1(sc, sc->value); + pair_set_current_input_location(sc, sc->args); + return (port_read_white_space(pt) (sc, pt)); +} + + +/* ---------------- *unbound-variable-hook* ---------------- */ + +static s7_pointer loaded_library(s7_scheme * sc, const char *file) +{ + s7_pointer p; + for (p = global_value(sc->libraries_symbol); is_pair(p); p = cdr(p)) + if (local_strcmp(file, string_value(caar(p)))) + return (cdar(p)); + return (sc->nil); +} + +static s7_pointer unbound_variable_error(s7_scheme * sc, s7_pointer sym) +{ + if (s7_tree_memq(sc, sym, current_code(sc))) + return (s7_error + (sc, sc->unbound_variable_symbol, + set_elist_3(sc, + wrap_string(sc, "unbound variable ~S in ~S", + 25), sym, current_code(sc)))); + if ((symbol_name(sym)[symbol_name_length(sym) - 1] == ',') + && + (lookup_unexamined + (sc, + make_symbol_with_length(sc, symbol_name(sym), + symbol_name_length(sym) - 1)))) + return (s7_error + (sc, sc->unbound_variable_symbol, + set_elist_2(sc, + wrap_string(sc, + "unbound variable ~S (perhaps a stray comma?)", + 44), sym))); + return (s7_error + (sc, sc->unbound_variable_symbol, + set_elist_2(sc, wrap_string(sc, "unbound variable ~S", 19), + sym))); +} + +static s7_pointer unbound_variable(s7_scheme * sc, s7_pointer sym) +{ + /* this always occurs in a context where we're trying to find anything, so I'll move a couple of those checks here */ + if (has_let_ref_fallback(sc->curlet)) /* an experiment -- see s7test (with-let *db* (+ int32_t (length str))) */ + return (call_let_ref_fallback(sc, sc->curlet, sym)); + /* but if the thing we want to hit this fallback happens to exist at a higher level, oops... */ + + if (sym == sc->unquote_symbol) + eval_error(sc, "unquote (',') occurred outside quasiquote: ~S", 45, + current_code(sc)); + + if (safe_strcmp(symbol_name(sym), "|#")) + return (read_error(sc, "unmatched |#")); + + /* check *autoload*, autoload_names, then *unbound-variable-hook* */ + if ((sc->autoload_names) || + (is_hash_table(sc->autoload_table)) || + (hook_has_functions(sc->unbound_variable_hook))) { + s7_pointer result, cur_code, value, code, args, current_let, x, z; + /* sc->args and sc->code are pushed on the stack by s7_call, then + * restored by eval, so they are normally protected, but sc->value and current_code(sc) are + * not protected. We need current_code(sc) so that the possible eventual error + * call can tell where the error occurred, and we need sc->value because it might + * be awaiting addition to sc->args in e.g. OP_EVAL_ARGS5, and then be clobbered + * by the hook function. (+ 1 asdf) will end up evaluating (+ asdf asdf) if sc->value + * is not protected. We also need to save/restore sc->curlet in case s7_load is called. + */ + args = (sc->args) ? sc->args : sc->nil; + code = sc->code; + value = sc->value; + cur_code = current_code(sc); + current_let = sc->curlet; + result = sc->undefined; + x = sc->x; + z = sc->z; + sc->temp7 = cons_unchecked(sc, code, cons_unchecked(sc, args, list_4(sc, value, cur_code, x, z))); /* not s7_list (debugger checks) */ + if (!is_pair(cur_code)) { + /* isolated typo perhaps -- no pair to hold the position info, so make one. current_code(sc) is GC-protected, so this should be safe. */ + cur_code = list_1(sc, sym); /* the error will say "(sym)" which is not too misleading */ + pair_set_current_input_location(sc, cur_code); + } + +#if (!DISABLE_AUTOLOAD) + /* check sc->autoload_names */ + if ((sc->is_autoloading) && (sc->autoload_names)) { + const char *file; + bool loaded = false; + file = find_autoload_name(sc, sym, &loaded, true); + if ((file) && (!loaded)) { + s7_pointer e; + /* if we've already loaded this file, we can get the library (e) from a table [(file lib) ...] + * here it was possible to get caught in a loop: + * change file, reload, unbound var seen, check autoload, it says "load file"... (where file does not get added to *libraries*) + * so the "loaded" arg tries to catch such cases + */ + e = loaded_library(sc, file); + if ((!e) || (!is_let(e))) { + if (hook_has_functions(sc->autoload_hook)) + s7_apply_function(sc, sc->autoload_hook, + set_plist_2(sc, sym, sc->temp6 = + s7_make_string(sc, + file))); + e = s7_load(sc, file); /* s7_load can return NULL */ + } + result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ + if ((result == sc->undefined) && (e) && (is_let(e))) { + result = s7_let_ref(sc, e, sym); + /* I think to be consistent we should add '(sym . result) to the global let */ + if (result != sc->undefined) + s7_define(sc, sc->nil, sym, result); + } + } + } +#endif + if (result == sc->undefined) { +#if (!DISABLE_AUTOLOAD) + /* check the *autoload* hash table */ + if ((sc->is_autoloading) && + (is_hash_table(sc->autoload_table))) { + s7_pointer val; + /* it was possible to get in a loop here: missing paren in x.scm, checks last symbol, sees + * autoload sym -> x.scm, loads x.scm, missing paren... + */ + val = s7_hash_table_ref(sc, sc->autoload_table, sym); + if (is_string(val)) { /* val should be a filename. *load-path* is searched if necessary. */ + if (hook_has_functions(sc->autoload_hook)) + s7_apply_function(sc, sc->autoload_hook, + set_plist_2(sc, sym, val)); + s7_load(sc, string_value(val)); + } else if (is_closure(val)) { /* val should be a function of one argument, the current (calling) environment */ + if (hook_has_functions(sc->autoload_hook)) + s7_apply_function(sc, sc->autoload_hook, + set_plist_2(sc, sym, val)); + s7_call(sc, val, set_ulist_1(sc, sc->curlet, sc->nil)); + } + result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ + } +#endif + /* check *unbound-variable-hook* */ + if ((result == sc->undefined) && + (is_procedure(sc->unbound_variable_hook)) && + (hook_has_functions(sc->unbound_variable_hook))) { + /* (let () (set! (hook-functions *unbound-variable-hook*) (list (lambda (v) _asdf_))) _asdf_) */ + s7_pointer old_hook; + bool old_history_enabled; + + old_history_enabled = s7_set_history_enabled(sc, false); + old_hook = sc->unbound_variable_hook; + set_car(sc->z2_1, old_hook); + sc->unbound_variable_hook = sc->error_hook; /* avoid the infinite loop mentioned above -- error_hook might be () or #f if we're in error-hook now */ + result = s7_call(sc, old_hook, set_plist_1(sc, sym)); /* not s7_apply_function */ + sc->unbound_variable_hook = old_hook; + s7_set_history_enabled(sc, old_history_enabled); + } + } + + sc->value = T_Pos(value); + sc->args = T_Pos(args); + sc->code = code; + set_curlet(sc, current_let); + sc->x = x; + sc->z = z; + sc->temp7 = sc->nil; + if ((result != sc->undefined) && (result != sc->unspecified)) + return (result); + } + return (unbound_variable_error(sc, sym)); +} + +static bool gx_annotate_arg(s7_scheme * sc, s7_pointer p, s7_pointer e) +{ + if (is_gxable(car(p))) { + opcode_t old_op = optimize_op(car(p)); + s7_pointer fxf; + set_optimize_op(car(p), old_op + 1); + fxf = + (s7_pointer) fx_choose(sc, p, e, + (is_list(e)) ? pair_symbol_is_safe : + let_symbol_is_safe); + if (fxf) { + set_has_gx(p); + set_opt2(p, fxf, OPT2_FX); + } + set_optimize_op(car(p), old_op); + return (fxf); + } + return (false); +} + +static void gx_annotate_args(s7_scheme * sc, s7_pointer args, s7_pointer e) +{ + s7_pointer p; + for (p = args; is_pair(p); p = cdr(p)) + gx_annotate_arg(sc, p, e); +} + +#define choose_c_function(Sc, Expr, Func, Args) set_c_function(Expr, c_function_chooser(Func)(Sc, Func, Args, Expr, true)) + +static void fx_annotate_arg(s7_scheme * sc, s7_pointer arg, s7_pointer e) +{ +#if S7_DEBUGGING + s7_function fx; + if (has_fx(arg)) + return; + fx = fx_choose(sc, arg, e, + (is_list(e)) ? pair_symbol_is_safe : + let_symbol_is_safe); + if (fx) + set_fx_direct(arg, fx); +#else + if (has_fx(arg)) + return; + set_fx(arg, + fx_choose(sc, arg, e, + (is_list(e)) ? pair_symbol_is_safe : + let_symbol_is_safe)); +#endif +} + +static void fx_annotate_args(s7_scheme * sc, s7_pointer args, s7_pointer e) +{ + s7_pointer p; + for (p = args; is_pair(p); p = cdr(p)) +#if S7_DEBUGGING + fx_annotate_arg(sc, p, e); /* checks has_fx */ +#else + if (!has_fx(p)) + set_fx(p, + fx_choose(sc, p, e, + (is_list(e)) ? pair_symbol_is_safe : + let_symbol_is_safe)); +#endif +} + +static opt_t optimize_thunk(s7_scheme * sc, s7_pointer expr, + s7_pointer func, int32_t hop, s7_pointer e) +{ + if ((hop != 1) && (is_constant_symbol(sc, car(expr)))) + hop = 1; + + if ((is_closure(func)) || (is_closure_star(func))) { + bool safe_case = is_safe_closure(func); + if (is_immutable(func)) + hop = 1; + if (is_null(closure_args(func))) { /* no rest arg funny business */ + s7_pointer body = closure_body(func); + set_optimized(expr); + if ((is_null(cdr(body))) && (safe_case) && (is_fxable(sc, car(body)))) { /* fx stuff is not set yet */ + fx_annotate_arg(sc, body, e); + set_optimize_op(expr, hop + OP_SAFE_THUNK_A); + set_closure_one_form_fx_arg(func); + set_opt1_lambda_add(expr, func); + return (OPT_T); + } + /* thunks with fully fxable bodies are rare apparently, and the time spent here overwhelms run time gains */ + set_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_THUNK : OP_THUNK)); + set_opt1_lambda_add(expr, func); + return (OPT_F); + } + if (is_symbol(closure_args(func))) { /* (define* (f1 . a) ...) called (f1) -- called a closure (not closure*) in define_unchecked */ + set_opt1_lambda_add(expr, func); + set_unsafe_optimize_op(expr, hop + OP_THUNK_ANY); /* "thunk" because here it is called with no args, I guess */ + return (OPT_F); + } + if (is_closure_star(func)) { + set_opt1_lambda_add(expr, func); + set_safe_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_0 : + OP_CLOSURE_STAR_NA)); + } + return (OPT_F); + } + + if (is_c_function(func)) { + if (c_function_required_args(func) != 0) + return (OPT_F); + if ((hop == 0) && (symbol_id(car(expr)) == 0)) + hop = 1; + + if (is_safe_procedure(func)) { + set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); + choose_c_function(sc, expr, func, 0); + return (OPT_T); + } + set_unsafe_optimize_op(expr, hop + OP_C); + choose_c_function(sc, expr, func, 0); + return (OPT_F); + } + + if (is_c_function_star(func)) { + set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR); + set_c_function(expr, func); + return (OPT_T); + } + return (OPT_F); +} + +static opt_t optimize_closure_dotted_args(s7_scheme * sc, s7_pointer expr, + s7_pointer func, int32_t hop, + int32_t args, s7_pointer e) +{ + if ((S7_DEBUGGING) && (!is_symbol(closure_args(func)))) + fprintf(stderr, "%s[%d]: %s but %s\n", __func__, __LINE__, + display_80(expr), display(func)); + if (fx_count(sc, expr) != args) /* fx_count starts at cdr, args here is the number of exprs in cdr(expr) -- so this means "are all args fxable" */ + return (OPT_F); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), small_int(args)); + set_unsafe_optimize_op(expr, hop + OP_ANY_CLOSURE_NA); + set_opt1_lambda_add(expr, func); + return (OPT_F); +} + +static int32_t combine_ops(s7_scheme * sc, s7_pointer func, + s7_pointer expr, combine_op_t cop, + s7_pointer e1, s7_pointer e2) +{ /* sc needed for debugger stuff */ + int32_t arg_op; + s7_pointer arg; + + switch (cop) { + case E_C_P: + arg_op = op_no_hop(e1); + switch (arg_op) { + case OP_SAFE_C_S: + return (OP_SAFE_C_opSq); + case OP_SAFE_C_NC: + return (OP_SAFE_C_opNCq); + case OP_SAFE_C_SC: + return (OP_SAFE_C_opSCq); + case OP_SAFE_C_CS: + return (OP_SAFE_C_opCSq); + case OP_SAFE_C_A: + return (OP_SAFE_C_opAq); + case OP_SAFE_C_AA: + return (OP_SAFE_C_opAAq); + case OP_SAFE_C_AAA: + return (OP_SAFE_C_opAAAq); + case OP_SAFE_C_SS: + set_opt3_sym(expr, cadr(e1)); + set_opt1_sym(cdr(expr), caddr(e1)); + return (OP_SAFE_C_opSSq); + case OP_SAFE_C_opSq: + set_opt3_pair(expr, cadr(e1)); + set_opt3_sym(cdr(expr), cadadr(e1)); + return (OP_SAFE_C_op_opSqq); + case OP_SAFE_C_S_opSq: + set_opt3_pair(expr, caddr(e1)); + return (OP_SAFE_C_op_S_opSqq); + case OP_SAFE_C_opSq_S: + set_opt3_pair(expr, cadr(e1)); + return (OP_SAFE_C_op_opSq_Sq); + } + return (OP_SAFE_C_P); /* this splits out to A in optimize_func one_arg */ + + case E_C_SP: + arg = e2; + arg_op = op_no_hop(arg); + switch (arg_op) { + case OP_SAFE_C_S: + return (OP_SAFE_C_S_opSq); + case OP_SAFE_C_AA: + return (OP_SAFE_C_S_opAAq); + case OP_SAFE_C_AAA: + return (OP_SAFE_C_S_opAAAq); + + case OP_SAFE_C_SC: + set_opt2_con(cdr(expr), caddr(arg)); + return (OP_SAFE_C_S_opSCq); + + case OP_SAFE_C_CS: /* expr is (* a (- 1 b)), e2 is (- 1 b) */ + set_opt2_sym(cdr(expr), caddr(arg)); + return (OP_SAFE_C_S_opCSq); + + case OP_SAFE_C_SS: /* (* a (- b c)) */ + set_opt2_sym(cdr(expr), caddr(arg)); + return (OP_SAFE_C_S_opSSq); + + case OP_SAFE_C_A: + set_opt3_pair(expr, cdaddr(expr)); + return (OP_SAFE_C_S_opAq); + } + return (OP_SAFE_C_SP); /* if fxable -> AA later */ + + case E_C_PS: + arg = e1; + arg_op = op_no_hop(arg); + switch (arg_op) { + case OP_SAFE_C_S: + set_opt1_sym(cdr(expr), cadr(e1)); + set_opt3_sym(expr, e2); + return (OP_SAFE_C_opSq_S); + case OP_SAFE_C_SS: + return (OP_SAFE_C_opSSq_S); + case OP_SAFE_C_CS: + return (OP_SAFE_C_opCSq_S); + case OP_SAFE_C_A: + return (OP_SAFE_C_opAq_S); + case OP_SAFE_C_opSSq: + set_opt1_pair(cdr(expr), cadadr(expr)); + set_opt3_pair(expr, cadr(e1)); + return (OP_SAFE_C_op_opSSqq_S); + } + return (OP_SAFE_C_PS); + + case E_C_PC: + arg = e1; + arg_op = op_no_hop(arg); + switch (arg_op) { + case OP_SAFE_C_S: + set_opt1_sym(cdr(expr), cadr(e1)); + set_opt2_con(cdr(expr), e2); + return (OP_SAFE_C_opSq_C); + case OP_SAFE_C_CS: + return (OP_SAFE_C_opCSq_C); + case OP_SAFE_C_SC: + return (OP_SAFE_C_opSCq_C); + case OP_SAFE_C_SS: + set_opt3_con(cdr(expr), caddr(expr)); + return (OP_SAFE_C_opSSq_C); + } + set_opt3_con(cdr(expr), caddr(expr)); + return (OP_SAFE_C_PC); + + case E_C_CP: + arg = e2; + arg_op = op_no_hop(arg); + switch (arg_op) { + case OP_SAFE_C_S: + set_opt3_pair(expr, arg); + return (OP_SAFE_C_C_opSq); + case OP_SAFE_C_SC: + set_opt1_sym(cdr(expr), cadr(arg)); + set_opt2_con(cdr(expr), caddr(arg)); + return (OP_SAFE_C_C_opSCq); + case OP_SAFE_C_SS: + set_opt1_sym(cdr(expr), cadr(arg)); + return (OP_SAFE_C_C_opSSq); + } + return (OP_SAFE_C_CP); + + case E_C_PP: + arg = e2; + arg_op = op_no_hop(arg); + switch (arg_op) { + case OP_SAFE_C_S: + if (is_safe_c_s(e1)) + return (OP_SAFE_C_opSq_opSq); + if (optimize_op_match(e1, OP_SAFE_C_SS)) + return (OP_SAFE_C_opSSq_opSq); + break; + case OP_SAFE_C_SS: + if (optimize_op_match(e1, OP_SAFE_C_SS)) + return (OP_SAFE_C_opSSq_opSSq); + if (is_safe_c_s(e1)) + return (OP_SAFE_C_opSq_opSSq); + break; + } + return (OP_SAFE_C_PP); + + default: + break; + } + return (OP_UNOPT); +} + +static bool arg_findable(s7_scheme * sc, s7_pointer arg1, s7_pointer e) +{ + if (pair_symbol_is_safe(sc, arg1, e)) + return (true); /* includes global_slot check */ + return ((!sc->in_with_let) && + (is_slot(lookup_slot_from(arg1, sc->curlet)))); +} + +static bool safe_c_aa_to_ag_ga(s7_scheme * sc, s7_pointer arg, int hop) +{ + if (fx_proc(cddr(arg)) == fx_s) { + set_opt3_sym(arg, caddr(arg)); + set_safe_optimize_op(arg, hop + OP_SAFE_C_AS); + return (true); + } + if (fx_proc(cdr(arg)) == fx_s) { + set_opt3_sym(arg, cadr(arg)); + set_safe_optimize_op(arg, hop + OP_SAFE_C_SA); + return (true); + } + if (fx_proc(cddr(arg)) == fx_c) { + set_opt3_con(arg, caddr(arg)); + set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); + return (true); + } + if (fx_proc(cdr(arg)) == fx_c) { + set_opt3_con(arg, cadr(arg)); + set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); + return (true); + } + if (fx_proc(cddr(arg)) == fx_q) { + set_opt3_con(arg, cadaddr(arg)); + set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); + return (true); + } + if (fx_proc(cdr(arg)) == fx_q) { + set_opt3_con(arg, cadadr(arg)); + set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); + return (true); + } + return (false); +} + +static opt_t check_c_aa(s7_scheme * sc, s7_pointer expr, s7_pointer func, + int32_t hop, s7_pointer e) +{ + fx_annotate_args(sc, cdr(expr), e); + if (!safe_c_aa_to_ag_ga(sc, expr, hop)) { + set_optimize_op(expr, hop + OP_SAFE_C_AA); + set_opt3_pair(expr, cddr(expr)); + } + choose_c_function(sc, expr, func, 2); + return (OPT_T); +} + +static opt_t wrap_bad_args(s7_scheme * sc, s7_pointer func, + s7_pointer expr, int32_t n_args, int32_t hop, + s7_pointer e) +{ + set_opt3_arglen(cdr(expr), small_int(n_args)); + if (is_c_function(func)) { + set_safe_optimize_op(expr, hop + ((is_safe_procedure(func)) ? + ((n_args == + 1) ? OP_SAFE_C_A : + OP_SAFE_C_AA) : ((n_args == 1) + ? ((is_semisafe + (func)) ? + OP_CL_A : + OP_C_A) + : ((is_semisafe + (func)) ? + OP_CL_AA : + OP_C_AA)))); + if (op_no_hop(expr) == OP_SAFE_C_AA) { + set_opt3_pair(expr, cddr(expr)); + if (optimize_op(expr) == HOP_SAFE_C_AA) + return (check_c_aa(sc, expr, func, hop, e)); + } + set_c_function(expr, func); + return (OPT_T); + } + if ((is_closure(func)) && (!arglist_has_rest(sc, closure_args(func)))) { + s7_pointer body = closure_body(func); + bool one_form = is_null(cdr(body)), safe_case = + is_safe_closure(func); + set_unsafely_optimized(expr); + set_opt1_lambda_add(expr, func); + if (one_form) + set_optimize_op(expr, hop + ((safe_case) ? + ((n_args == + 1) ? OP_SAFE_CLOSURE_A_O : + OP_SAFE_CLOSURE_AA_O) : ((n_args + == + 1) ? + OP_CLOSURE_A_O + : + OP_CLOSURE_AA_O))); + else + set_optimize_op(expr, hop + ((safe_case) ? + ((n_args == + 1) ? OP_SAFE_CLOSURE_A : + OP_SAFE_CLOSURE_AA) : ((n_args == + 1) ? + OP_CLOSURE_A + : + OP_CLOSURE_AA))); + return (OPT_F); + } + if ((is_closure_star(func)) && + (lambda_has_simple_defaults(func)) && + (closure_star_arity_to_int(sc, func) >= n_args) && + (!arglist_has_rest(sc, closure_args(func)))) { + set_unsafely_optimized(expr); + if (n_args == 1) + set_optimize_op(expr, + ((is_safe_closure(func)) ? + OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); + else if (closure_star_arity_to_int(sc, func) == 2) + set_optimize_op(expr, ((is_safe_closure(func)) + ? ((is_null(cdr(closure_body(func)))) ? + OP_SAFE_CLOSURE_STAR_AA_O : + OP_SAFE_CLOSURE_STAR_AA) : + OP_CLOSURE_STAR_NA)); + else + set_optimize_op(expr, + ((is_safe_closure(func)) ? + OP_SAFE_CLOSURE_STAR_NA : + OP_CLOSURE_STAR_NA)); + set_opt1_lambda_add(expr, func); + } + return (OPT_F); +} + +static inline s7_pointer find_uncomplicated_symbol(s7_scheme * sc, + s7_pointer symbol, + s7_pointer e) +{ + s7_pointer x; + int64_t id; + + if ((symbol_is_in_list(sc, symbol)) && (direct_memq(symbol, e))) /* it's probably a local variable reference */ + return (sc->nil); + /* ((!symbol_is_in_list(sc, symbol)) && (direct_memq(symbol, e))) can happen if there's an intervening lambda: + * (let loop () (with-let (for-each (lambda (a) a) (list))) (loop)) + * misses 'loop (it's not in symbol_list when recursive call is encountered) -- tricky to fix + */ + + if (is_global(symbol)) + return (global_slot(symbol)); + + /* see 59108 (OP_DEFINE_* in optimize_syntax) -- keyword version of name is used if a definition is + * contingent on some run-time decision, so we're looking here for local defines that might not happen. + * s7test.scm has a test case using acos. + */ + if ((has_keyword(symbol)) && + (symbol_is_in_list(sc, symbol_to_keyword(sc, symbol)))) + return (sc->nil); + + id = symbol_id(symbol); + for (x = sc->curlet; id < let_id(x); x = let_outlet(x)); + for (; is_let(x); x = let_outlet(x)) { + s7_pointer y; + if (let_id(x) == id) + return (local_slot(symbol)); + for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == symbol) + return (y); + } + return (global_slot(symbol)); /* it's no longer global perhaps (local definition now inaccessible) */ +} + +static bool is_ok_lambda(s7_scheme * sc, s7_pointer arg2) +{ + return ((is_pair(arg2)) && + (is_lambda(sc, car(arg2))) && + (is_pair(cdr(arg2))) && + (is_pair(cddr(arg2))) && (s7_is_proper_list(sc, cddr(arg2)))); +} + +static opt_t optimize_c_function_one_arg(s7_scheme * sc, s7_pointer expr, + s7_pointer func, int32_t hop, + int32_t pairs, int32_t symbols, + int32_t quotes, int32_t bad_pairs, + s7_pointer e) +{ + s7_pointer arg1 = cadr(expr); + bool func_is_safe = is_safe_procedure(func); + if ((hop == 0) + && ((is_immutable(func)) + || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) + hop = 1; + /* hooboy! if c_function func is immutable or we're not in with-let and func's name's id is zero (so func is global), set hop to 1?? */ + if (pairs == 0) { + if (func_is_safe) { /* safe c function */ + set_safe_optimize_op(expr, + hop + + ((symbols == + 0) ? OP_SAFE_C_NC : OP_SAFE_C_S)); + choose_c_function(sc, expr, func, 1); + return (OPT_T); + } + /* c function is not safe */ + if (symbols == 0) { + set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); /* OP_C_C never happens */ + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_one); + } else { + set_unsafely_optimized(expr); + if (c_function_call(func) == g_read) + set_optimize_op(expr, hop + OP_READ_S); + else + set_optimize_op(expr, + hop + + ((is_semisafe(func)) ? OP_CL_S : OP_C_S)); + } + choose_c_function(sc, expr, func, 1); + return (OPT_F); + } + /* pairs == 1 */ + if (bad_pairs == 0) { + if (func_is_safe) { + int32_t op; + op = combine_ops(sc, func, expr, E_C_P, arg1, NULL); + set_safe_optimize_op(expr, hop + op); + if ((op == OP_SAFE_C_P) && (is_fxable(sc, arg1))) { + set_optimize_op(expr, hop + OP_SAFE_C_A); + fx_annotate_arg(sc, cdr(expr), e); + } + choose_c_function(sc, expr, func, 1); + return (OPT_T); + } + if (is_fxable(sc, arg1)) { + set_unsafe_optimize_op(expr, + hop + + ((is_semisafe(func)) ? OP_CL_A : + OP_C_A)); + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_one); + choose_c_function(sc, expr, func, 1); + return (OPT_F); + } + } else { /* bad_pairs == 1 */ + if (quotes == 1) { + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_one); + if (func_is_safe) { + set_safe_optimize_op(expr, hop + OP_SAFE_C_A); + choose_c_function(sc, expr, func, 1); + return (OPT_T); + } + set_unsafe_optimize_op(expr, + hop + + ((is_semisafe(func)) ? OP_CL_A : + OP_C_A)); + choose_c_function(sc, expr, func, 1); + return (OPT_F); + } + /* quotes == 0 */ + if (!func_is_safe) { + s7_pointer lambda_expr = arg1; + if ((is_ok_lambda(sc, lambda_expr)) && (!direct_memq(car(lambda_expr), e))) { /* (let ((lambda #f)) (call-with-exit (lambda ...))) */ + if (((c_function_call(func) == g_call_with_exit) || (c_function_call(func) == g_call_cc) || (c_function_call(func) == g_call_with_output_string)) && (is_proper_list_1(sc, cadr(lambda_expr))) && (is_symbol(caadr(lambda_expr))) && (!is_probably_constant(caadr(lambda_expr)))) { /* (call-with-exit (lambda (pi) ...) */ + if (c_function_call(func) == g_call_cc) + set_unsafe_optimize_op(expr, OP_CALL_CC); + else if (c_function_call(func) == g_call_with_exit) { + if (is_null(cdddr(lambda_expr))) + set_unsafe_optimize_op(expr, + hop + + OP_CALL_WITH_EXIT_O); + else + set_unsafe_optimize_op(expr, + hop + + OP_CALL_WITH_EXIT); + } else { + set_unsafe_optimize_op(expr, + OP_CALL_WITH_OUTPUT_STRING); + set_opt2_pair(expr, cddr(lambda_expr)); + set_opt3_sym(expr, caadr(lambda_expr)); + set_local(caadr(lambda_expr)); + return (OPT_F); + } + choose_c_function(sc, expr, func, 1); + set_opt2_pair(expr, cdr(lambda_expr)); + set_local(caadr(lambda_expr)); /* check_lambda_args normally handles this, but if hop==1, we'll skip that step */ + return (OPT_F); + } + if ((c_function_call(func) == g_with_output_to_string) && + (is_null(cadr(lambda_expr)))) { + set_unsafe_optimize_op(expr, OP_WITH_OUTPUT_TO_STRING); + set_opt2_pair(expr, cddr(lambda_expr)); + return (OPT_F); + } + } + } + } + set_unsafe_optimize_op(expr, + hop + ((func_is_safe) ? OP_SAFE_C_P : OP_C_P)); + choose_c_function(sc, expr, func, 1); + return (OPT_F); +} + +static bool walk_fxable(s7_scheme * sc, s7_pointer tree) +{ + s7_pointer p; + for (p = cdr(tree); is_pair(p); p = cdr(p)) { + s7_pointer q = car(p); + if ((is_pair(q)) && (is_optimized(q))) { + opcode_t op = optimize_op(q); + if (is_safe_c_op(op)) + return (true); + if ((op >= OP_TC_AND_A_OR_A_LA) || + ((op >= OP_THUNK) && (op < OP_BEGIN)) || + (!walk_fxable(sc, q))) + return (false); + } + } + return (true); +} + +static bool is_safe_fxable(s7_scheme * sc, s7_pointer p) +{ + if (!is_pair(p)) + return (true); + if (is_optimized(p)) { + if ((fx_function[optimize_op(p)]) && (walk_fxable(sc, (p)))) + return (true); + } + if (is_proper_quote(sc, p)) + return (true); + if ((S7_DEBUGGING) && (is_optimized(p)) + && (fx_function[optimize_op(p)])) + fprintf(stderr, "omit %s: %s\n", op_names[optimize_op(p)], + display(p)); + return (false); +} + +static bool check_tc_when(s7_scheme * sc, s7_pointer name, s7_pointer args, + s7_pointer body) +{ + s7_pointer test_expr = cadr(body); + if (is_fxable(sc, test_expr)) { + s7_pointer p; + for (p = cddr(body); is_pair(cdr(p)); p = cdr(p)) + if (!is_fxable(sc, car(p))) + break; + if ((is_proper_list_1(sc, p)) && + (is_proper_list_3(sc, car(p))) && (caar(p) == name)) { + s7_pointer laa = car(p); + if ((is_fxable(sc, cadr(laa))) && + (is_safe_fxable(sc, caddr(laa)))) { + set_safe_optimize_op(body, OP_TC_WHEN_LAA); + fx_annotate_arg(sc, cdr(body), args); + for (p = cddr(body); is_pair(cdr(p)); p = cdr(p)) + fx_annotate_arg(sc, p, args); + fx_annotate_args(sc, cdr(laa), args); + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + return (true); + } + } + } + return (false); +} + +static bool check_tc_case(s7_scheme * sc, s7_pointer name, s7_pointer args, + s7_pointer body) +{ + /* opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */ + s7_pointer clauses; + s7_int len; + bool got_else = false, results_fxable = true; + for (clauses = cddr(body), len = 0; is_pair(clauses); + clauses = cdr(clauses), len++) { + s7_pointer clause = car(clauses), result; + if (is_proper_list_1(sc, car(clause))) { + if (!is_simple(caar(clause))) + return (false); /* even if key is a small int, selector might be a mutable alias of that, so = will fail */ + set_opt1_any(clauses, caar(clause)); + } else { + if ((car(clause) != sc->else_symbol) || + (!is_null(cdr(clauses)))) + return (false); + got_else = true; + } + set_opt2_any(clauses, NULL); + result = cdr(clause); + if (is_null(result)) + return (false); + if (is_proper_list_1(sc, result)) { + if (is_fxable(sc, car(result))) { + fx_annotate_arg(sc, result, args); + set_opt2_any(clauses, result); + } else + if ((is_proper_list_2(sc, car(result))) && + (caar(result) == name) && + (is_fxable(sc, cadar(result)))) { + set_has_tc(car(result)); + set_opt2_any(clauses, car(result)); + fx_annotate_arg(sc, cdar(result), args); + } else + results_fxable = false; + } else + results_fxable = false; + if (!opt2_any(clauses)) { + if (car(result) == sc->feed_to_symbol) + return (false); + if (tree_count(sc, name, result, 0) != 0) + return (false); + set_opt2_any(clauses, result); + } + } + if ((!got_else) || (!is_null(clauses))) + return (false); + set_optimize_op(body, OP_TC_CASE_LA); + set_opt3_arglen(cdr(body), small_int((len < 6) ? len : 0)); + fx_annotate_arg(sc, cdr(body), args); + fx_tree(sc, cdr(body), car(args), NULL, NULL, true); + if (results_fxable) + set_optimized(body); + return (results_fxable); +} + +static bool check_tc_cond(s7_scheme * sc, s7_pointer name, int32_t vars, + s7_pointer args, s7_pointer body) +{ + s7_pointer p = cdr(body), clause1 = car(p); + if ((is_proper_list_2(sc, clause1)) && (is_fxable(sc, car(clause1)))) { /* cond_a... */ + s7_pointer clause2; + p = cdr(p); + if ((is_pair(p)) && (is_null(cdr(p))) + && ((caar(p) == sc->else_symbol) || (caar(p) == sc->T))) { + s7_pointer else_clause; + if (((vars != 1) && (vars != 2)) + || (tree_count(sc, name, body, 0) != 1)) + return (false); + else_clause = cdar(p); + if (is_proper_list_1(sc, else_clause)) { + bool zs_fxable; + s7_pointer la = car(else_clause); + fx_annotate_arg(sc, clause1, args); + if ((is_pair(la)) && (car(la) == name) + && (is_pair(cdr(la)))) { + if ((is_fxable(sc, cadr(la))) + && ((((vars == 1) && (is_null(cddr(la)))) + || ((vars == 2) && (is_pair(cddr(la))) + && (is_null(cdddr(la))) + && (is_fxable(sc, caddr(la))))))) { + zs_fxable = is_fxable(sc, cadr(clause1)); + set_optimize_op(body, + (vars == + 1) ? OP_TC_COND_A_Z_LA : + OP_TC_COND_A_Z_LAA); + if (zs_fxable) + fx_annotate_arg(sc, cdr(clause1), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), + (vars == 1) ? NULL : cadr(args), NULL, + false); + if (zs_fxable) + set_optimized(body); + set_opt1_pair(cdr(body), cdadr(body)); + set_opt3_pair(cdr(body), cdadr(caddr(body))); + return (zs_fxable); + } + } else { + la = cadr(clause1); + if ((is_pair(la)) && (car(la) == name) + && (is_pair(cdr(la)))) { + if ((is_fxable(sc, cadr(la))) + && (((vars == 1) && (is_null(cddr(la)))) + || ((vars == 2) && (is_pair(cddr(la))) + && (is_null(cdddr(la))) + && (is_fxable(sc, caddr(la)))))) { + zs_fxable = is_fxable(sc, car(else_clause)); + set_optimize_op(body, + (vars == + 1) ? OP_TC_COND_A_LA_Z : + OP_TC_COND_A_LAA_Z); + if (zs_fxable) + fx_annotate_arg(sc, else_clause, args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), + (vars == 1) ? NULL : cadr(args), NULL, + false); + if (zs_fxable) + set_optimized(body); + set_opt1_pair(cdr(body), cdaddr(body)); + set_opt3_pair(cdr(body), cdadr(cadr(body))); + return (zs_fxable); + } + } + } + } + return (false); + } + if (is_proper_list_2(sc, p)) { + clause2 = car(p); + if ((is_proper_list_2(sc, clause2)) && + (is_fxable(sc, car(clause2)))) { + s7_pointer else_clause, else_p = cdr(p); + else_clause = car(else_p); + + if ((is_proper_list_2(sc, else_clause)) && + ((car(else_clause) == sc->else_symbol) + || (car(else_clause) == sc->T))) { + bool zs_fxable = true; + if ((vars == 2) && /* ...laa_laa case */ + (is_proper_list_3(sc, cadr(clause2))) + && (caadr(clause2) == name) + && (is_fxable(sc, cadadr(clause2))) + && (is_safe_fxable(sc, caddadr(clause2))) + && (is_proper_list_3(sc, cadr(else_clause))) + && (caadr(else_clause) == name) + && (is_fxable(sc, cadadr(else_clause))) + && (is_safe_fxable(sc, caddadr(else_clause)))) { + set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_LAA); + if (is_fxable(sc, cadr(clause1))) + fx_annotate_args(sc, clause1, args); + else { + fx_annotate_arg(sc, clause1, args); + zs_fxable = false; + } + fx_annotate_arg(sc, clause2, args); + fx_annotate_args(sc, cdadr(clause2), args); + fx_annotate_args(sc, cdadr(else_clause), args); + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, + false); + set_opt3_pair(body, cadr(else_clause)); + if (zs_fxable) + set_optimized(body); + return (zs_fxable); + } + + if ((tree_count(sc, name, body, 0) == 1) && /* needed to filter out cond_a_a_a_laa_opa_laa */ + (((is_pair(cadr(else_clause))) + && (caadr(else_clause) == name) + && (is_pair(cdadr(else_clause))) + && (is_fxable(sc, cadadr(else_clause))) + && + (((vars == 1) && (is_null(cddadr(else_clause)))) + || ((vars == 2) + && (is_proper_list_3(sc, cadr(else_clause))) + && (is_fxable(sc, caddadr(else_clause)))))) + || ((is_pair(cadr(clause2))) + && (caadr(clause2) == name) + && (is_pair(cdadr(clause2))) + && (is_fxable(sc, cadadr(clause2))) + && + (((vars == 1) && (is_null(cddadr(clause2)))) + || ((vars == 2) && (is_pair(cddadr(clause2))) + && (is_fxable(sc, caddadr(clause2))) + && (is_null(cdddr(cadr(clause2))))))))) { + s7_pointer test2 = clause2, la_test = else_clause; + if (vars == 1) { + if ((is_pair(cadr(else_clause))) + && (caadr(else_clause) == name)) + set_optimize_op(body, + OP_TC_COND_A_Z_A_Z_LA); + else { + set_optimize_op(body, + OP_TC_COND_A_Z_A_LA_Z); + test2 = else_clause; + la_test = clause2; + fx_annotate_arg(sc, clause2, args); + } + } else if ((is_pair(cadr(else_clause))) + && (caadr(else_clause) == name)) { + set_opt3_pair(body, cdadr(else_clause)); + set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LAA); + } else { + set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_Z); + test2 = else_clause; + la_test = clause2; + set_opt3_pair(body, cdadr(la_test)); + fx_annotate_arg(sc, clause2, args); + } + if (is_fxable(sc, cadr(clause1))) + fx_annotate_args(sc, clause1, args); + else { + fx_annotate_arg(sc, clause1, args); + zs_fxable = false; + } + if (is_fxable(sc, cadr(test2))) + fx_annotate_args(sc, test2, args); + else { + fx_annotate_arg(sc, test2, args); + zs_fxable = false; + } + fx_annotate_args(sc, cdadr(la_test), args); + fx_tree(sc, cdr(body), car(args), + (vars == 2) ? cadr(args) : NULL, NULL, + false); + if (zs_fxable) + set_optimized(body); + return (zs_fxable); + } + } + } + } + } + return (false); +} + +static bool check_tc_let(s7_scheme * sc, s7_pointer name, int32_t vars, + s7_pointer args, s7_pointer body) +{ + s7_pointer let_body = caddr(body); /* body: (let ((x (- y 1))) (if (<= x 0) 0 (f1 (- x 1)))) etc */ + if (((vars == 2) + && ((car(let_body) == sc->if_symbol) + || (car(let_body) == sc->when_symbol) + || (car(let_body) == sc->unless_symbol))) || ((vars == 1) + && + (car(let_body) + == + sc->if_symbol))) + { + s7_pointer test_expr = cadr(let_body); + if (is_fxable(sc, test_expr)) { + if ((car(let_body) == sc->if_symbol) + && (is_pair(cdddr(let_body)))) { + s7_pointer laa = cadddr(let_body); + if ((is_pair(laa)) && /* else caddr is laa and cadddr is z */ + (car(laa) == name) && + (((vars == 1) && (is_proper_list_2(sc, laa))) || + ((vars == 2) && (is_proper_list_3(sc, laa)) + && (is_safe_fxable(sc, caddr(laa))))) + && (is_fxable(sc, cadr(laa)))) { + bool z_fxable; + set_optimize_op(body, + (vars == + 1) ? OP_TC_LET_IF_A_Z_LA : + OP_TC_LET_IF_A_Z_LAA); + fx_annotate_arg(sc, cdaadr(body), args); /* let var binding, caadr: (x (- y 1)) etc */ + fx_annotate_arg(sc, cdr(let_body), args); /* test_expr */ + fx_annotate_args(sc, cdr(laa), args); + z_fxable = is_fxable(sc, caddr(let_body)); + if (z_fxable) + fx_annotate_arg(sc, cddr(let_body), args); + fx_tree(sc, cdaadr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); /* these are references to laa args, applied to the let var binding */ + fx_tree(sc, cdr(let_body), car(caadr(body)), NULL, + NULL, false); + fx_tree_outer(sc, cdr(let_body), car(args), + (vars == 1) ? NULL : cadr(args), NULL, + false); + if (z_fxable) + set_optimized(body); + return (z_fxable); + } + } else { + s7_pointer p; + for (p = cddr(let_body); is_pair(cdr(p)); p = cdr(p)) + if (!is_fxable(sc, car(p))) + break; + if ((is_proper_list_1(sc, p)) && + (is_proper_list_3(sc, car(p))) && (caar(p) == name)) { + s7_pointer laa = car(p); + if ((is_fxable(sc, cadr(laa))) && + (is_safe_fxable(sc, caddr(laa)))) { + set_optimize_op(body, + (car(let_body) == + sc->when_symbol) ? + OP_TC_LET_WHEN_LAA : + OP_TC_LET_UNLESS_LAA); + fx_annotate_arg(sc, cdaadr(body), args); /* outer var */ + fx_annotate_arg(sc, cdr(let_body), args); /* test */ + for (p = cddr(let_body); is_pair(cdr(p)); + p = cdr(p)) + fx_annotate_arg(sc, p, args); + fx_annotate_args(sc, cdr(laa), args); + fx_tree(sc, cdaadr(body), car(args), cadr(args), NULL, false); /* these are references to the outer let */ + fx_tree(sc, cdr(let_body), car(caadr(body)), NULL, + NULL, false); + fx_tree_outer(sc, cdr(let_body), car(args), + cadr(args), NULL, false); + set_optimized(body); + return (true); + } + } + } + } + } else { + if (car(let_body) == sc->cond_symbol) { /* vars=#loop pars, args=names thereof (arglist) */ + s7_pointer p, var_name; + bool all_fxable = true; + for (p = cdr(let_body); is_pair(p); p = cdr(p)) { + s7_pointer clause = car(p); + if ((is_proper_list_2(sc, clause)) && (is_fxable(sc, car(clause)))) { /* test is ok */ + s7_pointer result; + + if ((!is_pair(cdr(p))) && + (car(clause) != sc->else_symbol) + && (car(clause) != sc->T)) + return (false); + + result = cadr(clause); + if ((is_pair(result)) && (car(result) == name)) { /* result is recursive call */ + s7_pointer arg; + s7_int i; + for (i = 0, arg = cdr(result); is_pair(arg); + i++, arg = cdr(arg)) + if (!is_fxable(sc, car(arg))) + return (false); + if (i != vars) + return (false); + } + } else + return (false); + } + /* cond form looks ok */ + set_optimize_op(body, OP_TC_LET_COND); + set_opt3_arglen(cdr(body), small_int(vars)); + fx_annotate_arg(sc, cdaadr(body), args); /* let var */ + if (vars > 0) + fx_tree(sc, cdaadr(body), car(args), + (vars > 1) ? cadr(args) : NULL, + (vars > 2) ? caddr(args) : NULL, vars > 3); + var_name = caaadr(body); + for (p = cdr(let_body); is_pair(p); p = cdr(p)) { + s7_pointer clause = car(p), result; + result = cadr(clause); + fx_annotate_arg(sc, clause, args); + if ((is_pair(result)) && (car(result) == name)) { + set_has_tc(cdr(clause)); + fx_annotate_args(sc, cdr(result), args); + } else if (is_fxable(sc, result)) + fx_annotate_arg(sc, cdr(clause), args); + else + all_fxable = false; + fx_tree(sc, clause, var_name, NULL, NULL, false); /* just 1 let var */ + if (vars > 0) + fx_tree_outer(sc, clause, car(args), + (vars > 1) ? cadr(args) : NULL, + (vars > 2) ? caddr(args) : NULL, + vars > 3); + } + if (all_fxable) + set_optimized(body); + return (all_fxable); + } + } + return (false); +} + +/* tc lets can be let* or let+vars that don't refer to previous names, and there are more cond/if choices */ + +static bool check_tc(s7_scheme * sc, s7_pointer name, int32_t vars, + s7_pointer args, s7_pointer body) +{ + if (!is_pair(body)) + return (false); + + if (((vars == 1) || (vars == 2)) && + ((car(body) == sc->and_symbol) || (car(body) == sc->or_symbol)) && + (is_pair(cdr(body))) && + (is_fxable(sc, cadr(body))) && (is_pair(cddr(body)))) { + s7_pointer orx = caddr(body); + if (((car(orx) == sc->or_symbol) || (car(orx) == sc->and_symbol)) + && (car(body) != car(orx)) && (is_fxable(sc, cadr(orx)))) { + s7_int len; + len = proper_list_length(orx); + if ((len == 3) + || ((vars == 1) && (len == 4) + && (tree_count(sc, name, orx, 0) == 1) + && (is_fxable(sc, caddr(orx))))) { + s7_pointer tc; + tc = (len == 3) ? caddr(orx) : cadddr(orx); + if ((is_pair(tc)) && + (car(tc) == name) && + (is_pair(cdr(tc))) && + (is_fxable(sc, cadr(tc))) && + (((vars == 1) && (is_null(cddr(tc)))) || + ((vars == 2) && (is_pair(cddr(tc))) + && (is_null(cdddr(tc))) + && (is_safe_fxable(sc, caddr(tc)))))) { + if (vars == 1) + set_safe_optimize_op(body, + (car(body) == + sc->and_symbol) ? ((len == + 3) ? + OP_TC_AND_A_OR_A_LA + : + OP_TC_AND_A_OR_A_A_LA) + : ((len == + 3) ? OP_TC_OR_A_AND_A_LA : + OP_TC_OR_A_AND_A_A_LA)); + else + set_safe_optimize_op(body, + (car(body) == + sc->and_symbol) ? + OP_TC_AND_A_OR_A_LAA : + OP_TC_OR_A_AND_A_LAA); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cdr(orx), args); + if (len == 4) + fx_annotate_arg(sc, cddr(orx), args); + fx_annotate_args(sc, cdr(tc), args); + /* if ((fx_proc(cdr(tc)) == fx_c_sca) && (fn_proc(cadr(tc)) == g_substring)) -> g_substring_uncopied); */ + /* for that to be safe we need to be sure nothing in the body looks for null-termination (e.g.. string->number) */ + fx_tree(sc, cdr(body), car(args), + (vars == 1) ? NULL : cadr(args), NULL, false); + return (true); + } + } + } else { + if ((vars == 1) && + (car(body) == sc->or_symbol) && + (is_fxable(sc, orx)) && + (is_pair(cdddr(body))) && (is_pair(cadddr(body)))) { + s7_pointer and_p = cadddr(body); + if ((is_proper_list_4(sc, and_p)) && + (car(and_p) == sc->and_symbol) && + (is_fxable(sc, cadr(and_p))) && + (is_fxable(sc, caddr(and_p)))) { + s7_pointer la = cadddr(and_p); + if ((is_proper_list_2(sc, la)) && + (car(la) == name) && (is_fxable(sc, cadr(la)))) { + set_safe_optimize_op(body, + OP_TC_OR_A_A_AND_A_A_LA); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cddr(body), args); + fx_annotate_arg(sc, cdr(and_p), args); + fx_annotate_arg(sc, cddr(and_p), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), NULL, NULL, + false); + return (true); + } + } + } else { + if ((vars == 1) && (car(body) == sc->and_symbol) + && (car(orx) == sc->if_symbol) + && (is_proper_list_4(sc, orx)) + && (is_fxable(sc, cadr(orx))) + && (tree_count(sc, name, orx, 0) == 1)) { + s7_pointer la; + bool z_first; + z_first = ((is_pair(cadddr(orx))) + && (car(cadddr(orx)) == name)); + la = (z_first) ? cadddr(orx) : caddr(orx); + if ((car(la) == name) && (is_proper_list_2(sc, la)) + && (is_fxable(sc, cadr(la)))) { + bool z_fxable = true; + s7_pointer z; + z = (z_first) ? cddr(orx) : cdddr(orx); + set_optimize_op(body, + (z_first) ? OP_TC_AND_A_IF_A_Z_LA : + OP_TC_AND_A_IF_A_LA_Z); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cdr(orx), args); + fx_annotate_arg(sc, cdr(la), args); + if (is_fxable(sc, car(z))) + fx_annotate_arg(sc, z, args); + else + z_fxable = false; + fx_tree(sc, cdr(body), car(args), NULL, NULL, + false); + if (z_fxable) + set_optimized(body); + return (z_fxable); + } + } + } + } + } + + if ((vars == 3) && (((car(body) == sc->or_symbol) + && (is_proper_list_2(sc, cdr(body)))) + || ((car(body) == sc->if_symbol) + && (is_proper_list_3(sc, cdr(body))) + && (caddr(body) == sc->T))) + && (is_fxable(sc, cadr(body)))) { + s7_pointer and_p; + and_p = (car(body) == sc->or_symbol) ? caddr(body) : cadddr(body); + if ((is_proper_list_4(sc, and_p)) && + (car(and_p) == sc->and_symbol) && + (is_fxable(sc, cadr(and_p))) && + (is_fxable(sc, caddr(and_p)))) { + s7_pointer la = cadddr(and_p); + if ((is_proper_list_4(sc, la)) && + (car(la) == name) && + (is_fxable(sc, cadr(la))) && + (is_safe_fxable(sc, caddr(la))) && + (is_safe_fxable(sc, cadddr(la)))) { + set_safe_optimize_op(body, OP_TC_OR_A_AND_A_A_L3A); + set_opt3_pair(cdr(body), + (car(body) == + sc->or_symbol) ? cdaddr(body) : + cdr(cadddr(body))); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cdr(and_p), args); + fx_annotate_arg(sc, cddr(and_p), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), + false); + return (true); + } + } + } + + if (((vars >= 1) && (vars <= 3)) && + (car(body) == sc->if_symbol) && (proper_list_length(body) == 4)) { + s7_pointer test = cadr(body); + if (is_fxable(sc, test)) { + s7_pointer true_p = caddr(body), false_p = cadddr(body); + s7_int false_len, true_len; + + true_len = proper_list_length(true_p); + false_len = proper_list_length(false_p); + fx_annotate_arg(sc, cdr(body), args); + + if (vars == 1) { + if ((false_len == 2) && + (car(false_p) == name) && + (is_fxable(sc, cadr(false_p)))) { + set_optimize_op(body, OP_TC_IF_A_Z_LA); + fx_annotate_arg(sc, cdr(false_p), args); /* arg */ + set_opt1_pair(cdr(body), cddr(body)); + set_opt3_pair(cdr(body), cdar(cdddr(body))); + if (!is_fxable(sc, true_p)) + return (false); + fx_annotate_arg(sc, cddr(body), args); /* result */ + fx_tree(sc, cdr(body), car(args), NULL, NULL, false); + set_optimized(body); /* split here and elsewhere from set_optimize_op is deliberate */ + return (true); + } + if ((true_len == 2) && + (car(true_p) == name) && + (is_fxable(sc, cadr(true_p)))) { + set_optimize_op(body, OP_TC_IF_A_LA_Z); + fx_annotate_arg(sc, cdr(true_p), args); /* arg */ + set_opt1_pair(cdr(body), cdddr(body)); + set_opt3_pair(cdr(body), cdar(cddr(body))); + if (!is_fxable(sc, false_p)) + return (false); + fx_annotate_arg(sc, cdddr(body), args); /* result */ + fx_tree(sc, cdr(body), car(args), NULL, NULL, false); + set_optimized(body); + return (true); + } + } + + if (vars == 2) { + if ((false_len == 3) && + (car(false_p) == name) && + (is_fxable(sc, cadr(false_p))) && + (is_safe_fxable(sc, caddr(false_p)))) { + set_optimize_op(body, OP_TC_IF_A_Z_LAA); + fx_annotate_args(sc, cdr(false_p), args); + set_opt1_pair(cdr(body), cddr(body)); /* body == code in op, if_z */ + set_opt3_pair(cdr(body), cdar(cdddr(body))); /* la */ + if (!is_fxable(sc, true_p)) + return (false); + fx_annotate_arg(sc, cddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, + false); + set_optimized(body); + return (true); + } + if ((true_len == 3) && + (car(true_p) == name) && + (is_fxable(sc, cadr(true_p))) && + (is_safe_fxable(sc, caddr(true_p)))) { + set_optimize_op(body, OP_TC_IF_A_LAA_Z); + fx_annotate_args(sc, cdr(true_p), args); + set_opt1_pair(cdr(body), cdddr(body)); + set_opt3_pair(cdr(body), cdar(cddr(body))); + if (!is_fxable(sc, false_p)) + return (false); + fx_annotate_arg(sc, cdddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, + false); + set_optimized(body); + return (true); + } + } + + if (vars == 3) { + if ((false_len == 4) && + (car(false_p) == name) && + (is_fxable(sc, cadr(false_p))) + && (is_safe_fxable(sc, caddr(false_p))) + && (is_safe_fxable(sc, cadddr(false_p)))) { + set_optimize_op(body, OP_TC_IF_A_Z_L3A); + fx_annotate_args(sc, cdr(false_p), args); + set_opt1_pair(cdr(body), cddr(body)); + set_opt3_pair(cdr(body), cdar(cdddr(body))); + if (!is_fxable(sc, true_p)) + return (false); + fx_annotate_arg(sc, cddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args), + caddr(args), false); + set_optimized(body); + return (true); + } + if ((true_len == 4) && + (car(true_p) == name) && (is_fxable(sc, cadr(true_p))) + && (is_safe_fxable(sc, caddr(true_p))) + && (is_safe_fxable(sc, cadddr(true_p)))) { + set_optimize_op(body, OP_TC_IF_A_L3A_Z); + fx_annotate_args(sc, cdr(true_p), args); + set_opt1_pair(cdr(body), cdddr(body)); + set_opt3_pair(cdr(body), cdar(cddr(body))); + if (!is_fxable(sc, false_p)) + return (false); + fx_annotate_arg(sc, cdddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args), + caddr(args), false); + set_optimized(body); + return (true); + } + } + + if ((false_len == 4) && (car(false_p) == sc->if_symbol)) { + s7_pointer in_test = cadr(false_p), in_true = + caddr(false_p), in_false = cadddr(false_p); + if (is_fxable(sc, in_test)) { + s7_pointer la = NULL, z; + if ((is_pair(in_false)) && + (car(in_false) == name) && + (is_pair(cdr(in_false))) && + (is_fxable(sc, cadr(in_false)))) { + la = in_false; + z = cddr(false_p); + } else + if ((is_pair(in_true)) && + (car(in_true) == name) && + (is_pair(cdr(in_true))) && + (is_fxable(sc, cadr(in_true)))) { + la = in_true; + z = cdddr(false_p); + } + if ((la) + && ((vars == 3) + || (!s7_tree_memq(sc, name, car(z))))) { + if (((vars == 1) && (is_null(cddr(la)))) + || ((vars == 2) && (is_pair(cddr(la))) + && (is_null(cdddr(la))) + && (is_safe_fxable(sc, caddr(la)))) + || ((vars == 3) + && (is_proper_list_4(sc, in_true)) + && (car(in_true) == name) + && (is_proper_list_4(sc, in_false)) + && (is_safe_fxable(sc, caddr(la))) + && (is_safe_fxable(sc, cadddr(la))) + && (is_fxable(sc, cadr(in_true))) + && (is_safe_fxable(sc, caddr(in_true))) + && (is_safe_fxable(sc, cadddr(in_true))))) { + bool zs_fxable = true; + if (vars == 1) + set_optimize_op(body, + (la == + in_false) ? + OP_TC_IF_A_Z_IF_A_Z_LA : + OP_TC_IF_A_Z_IF_A_LA_Z); + else if (vars == 2) + set_optimize_op(body, + (la == + in_false) ? + OP_TC_IF_A_Z_IF_A_Z_LAA : + OP_TC_IF_A_Z_IF_A_LAA_Z); + else + set_optimize_op(body, + OP_TC_IF_A_Z_IF_A_L3A_L3A); + if (is_fxable(sc, true_p)) /* outer (z) result */ + fx_annotate_arg(sc, cddr(body), args); + else + zs_fxable = false; + fx_annotate_arg(sc, cdr(false_p), args); /* inner test */ + fx_annotate_args(sc, cdr(la), args); /* la arg(s) */ + if (vars == 3) + fx_annotate_args(sc, cdr(in_true), args); + else if (is_fxable(sc, car(z))) + fx_annotate_arg(sc, z, args); /* inner (z) result */ + else + zs_fxable = false; + if ((has_fx(cddr(body))) && (has_fx(z))) + fx_tree(sc, cdr(body), car(args), + (vars > 1) ? cadr(args) : NULL, + (vars > 2) ? caddr(args) : NULL, + false); + if (zs_fxable) + set_optimized(body); + return (zs_fxable); + } + } + } + } + + if ((vars == 2) && + (false_len == 3) && + (car(false_p) == sc->let_star_symbol)) { + s7_pointer letv = cadr(false_p), letb, v; + + if (!is_pair(letv)) + return (false); + letb = caddr(false_p); + for (v = letv; is_pair(v); v = cdr(v)) + if (!is_fxable(sc, cadar(v))) + return (false); + if ((is_proper_list_4(sc, letb)) && + (car(letb) == sc->if_symbol) && + (is_fxable(sc, cadr(letb)))) { + s7_pointer laa = cadddr(letb); + if ((car(laa) == name) && + (is_proper_list_3(sc, laa)) && + (is_fxable(sc, cadr(laa))) && + (is_safe_fxable(sc, caddr(laa)))) { + bool zs_fxable; + set_safe_optimize_op(body, + OP_TC_IF_A_Z_LET_IF_A_Z_LAA); + fx_annotate_args(sc, cdr(laa), args); + zs_fxable = is_fxable(sc, caddr(letb)); + fx_annotate_args(sc, cdr(letb), args); + for (v = letv; is_pair(v); v = cdr(v)) + fx_annotate_arg(sc, cdar(v), args); + fx_tree(sc, cdar(letv), car(args), cadr(args), NULL, true); /* first var of let*, second var of let* can't be fx_treed */ + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, true); /* these are references to the outer let */ + fx_tree(sc, cdr(laa), caar(letv), + (is_pair(cdr(letv))) ? caadr(letv) : NULL, + NULL, true); + fx_tree(sc, cdr(letb), caar(letv), + (is_pair(cdr(letv))) ? caadr(letv) : NULL, + NULL, true); + fx_tree_outer(sc, cddr(letb), car(args), + cadr(args), NULL, true); + if (!is_fxable(sc, caddr(body))) + return (false); + fx_annotate_arg(sc, cddr(body), args); + return (zs_fxable); + } + } + } + } + } + + /* let */ + if ((is_proper_list_3(sc, body)) && (car(body) == sc->let_symbol) && (is_proper_list_1(sc, cadr(body))) && (is_fxable(sc, cadr(caadr(body)))) && /* let one var is fxable */ + (is_pair(caddr(body)))) + return (check_tc_let(sc, name, vars, args, body)); + + /* cond */ + if ((car(body) == sc->cond_symbol) && (vars <= 2)) + return (check_tc_cond(sc, name, vars, args, body)); + + /* case */ + if ((vars == 1) && + (car(body) == sc->case_symbol) && + (is_pair(cdr(body))) && (is_fxable(sc, cadr(body)))) + return (check_tc_case(sc, name, args, body)); + + /* when */ + if ((vars == 2) && + (car(body) == sc->when_symbol) && (is_fxable(sc, cadr(body)))) + return (check_tc_when(sc, name, args, body)); + return (false); +} + +static bool check_recur_if(s7_scheme * sc, s7_pointer name, int32_t vars, + s7_pointer args, s7_pointer body) +{ + s7_pointer test = cadr(body); + if (is_fxable(sc, test)) { /* if_(A)... */ + s7_pointer true_p, false_p, obody = cddr(body), orig = NULL; + true_p = car(obody); /* if_a_(A)... */ + false_p = cadr(obody); /* if_a_a_(if...) */ + + if ((vars <= 2) && + (is_fxable(sc, true_p)) && (is_proper_list_4(sc, false_p))) { + if (car(false_p) == sc->if_symbol) { + s7_pointer test2 = cadr(false_p), true2 = + caddr(false_p), false2 = cadddr(false_p); + if ((is_fxable(sc, test2)) && (is_proper_list_3(sc, false2)) && /* opa_laaq or oplaa_laaq */ + (is_h_optimized(false2))) { /* the c-op */ + s7_pointer la1 = cadr(false2), la2 = caddr(false2); + if ((is_fxable(sc, true2)) && + (((vars == 1) && (is_proper_list_2(sc, la1)) + && (is_proper_list_2(sc, la2))) || (((vars == 2) + && + (is_proper_list_3 + (sc, la1)) + && + (is_proper_list_3 + (sc, + la2))))) + && (car(la1) == name) && (car(la2) == name) + && (is_fxable(sc, cadr(la1))) + && (is_fxable(sc, cadr(la2))) && ((vars == 1) + || + ((is_fxable + (sc, + caddr(la1))) + && + (is_fxable + (sc, + caddr + (la2)))))) { + set_safe_optimize_op(body, + (vars == + 1) ? + OP_RECUR_IF_A_A_IF_A_A_opLA_LAq + : + OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, obody, args); + fx_annotate_args(sc, cdr(false_p), args); + fx_annotate_args(sc, cdr(la1), args); + fx_annotate_args(sc, cdr(la2), args); + fx_tree(sc, cdr(body), car(args), + (vars == 2) ? cadr(args) : NULL, NULL, + false); + set_opt1_pair(body, cdr(false_p)); + set_opt3_pair(body, false2); + set_opt3_pair(false2, cdr(la2)); + return (true); + } + if ((vars == 2) && (is_proper_list_3(sc, true2)) && (car(true2) == name) && (is_fxable(sc, cadr(true2))) && (is_fxable(sc, caddr(true2))) && (is_fxable(sc, cadr(false2))) && (is_proper_list_3(sc, la2)) && (car(la2) == name) && /* actually, not needed because func is TC (not RECUR) if not == name */ + (is_fxable(sc, cadr(la2))) && + (is_fxable(sc, caddr(la2)))) { + set_safe_optimize_op(body, + OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq); + fx_annotate_arg(sc, cdr(body), args); /* if_(A)... */ + fx_annotate_arg(sc, obody, args); /* if_a_(A)... */ + fx_annotate_arg(sc, cdr(false_p), args); /* if_a_a_if_(A)... */ + fx_annotate_args(sc, cdr(true2), args); /* if_a_a_if_a_l(AA)... */ + fx_annotate_arg(sc, cdr(false2), args); /* if_a_a_if_a_laa_op(A).. */ + fx_annotate_args(sc, cdr(la2), args); /* if_a_a_if_a_laa_opa_l(AA)q */ + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, + false); + set_opt3_pair(body, false2); + set_opt3_pair(false2, la2); + return (true); + } + } + } + + if (car(false_p) == sc->and_symbol) { + s7_pointer a1 = cadr(false_p), a2 = caddr(false_p), a3 = + cadddr(false_p); + if ((is_fxable(sc, a1)) && (is_proper_list_3(sc, a2)) + && (is_proper_list_3(sc, a3)) && (car(a2) == name) + && (car(a3) == name) && (is_fxable(sc, cadr(a2))) + && (is_fxable(sc, cadr(a3))) + && (is_fxable(sc, caddr(a2))) + && (is_fxable(sc, caddr(a3)))) { + set_safe_optimize_op(body, + OP_RECUR_IF_A_A_AND_A_LAA_LAA); + fx_annotate_arg(sc, cdr(body), args); /* if_(A)... */ + fx_annotate_arg(sc, cddr(body), args); /* if_a_(A)... */ + fx_annotate_arg(sc, cdr(false_p), args); /* if_a_a_and_(A)... */ + fx_annotate_args(sc, cdr(a2), args); /* if_a_a_and_a_l(AA)... */ + fx_annotate_args(sc, cdr(a3), args); /* if_a_a_and_a_laa_l(AA) */ + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, + false); + set_opt3_pair(body, false_p); + return (true); + } + } + } + + if ((is_fxable(sc, true_p)) && + (is_pair(false_p)) && + (is_h_optimized(false_p)) && + (is_pair(cdr(false_p))) && (is_pair(cddr(false_p)))) + orig = false_p; + else if ((is_fxable(sc, false_p)) && + (is_pair(true_p)) && + (is_h_optimized(true_p)) && + (is_pair(cdr(true_p))) && (is_pair(cddr(true_p)))) { + orig = true_p; + /* true_p = false_p; */ + false_p = orig; + obody = cdr(obody); + } + + if (orig) { + if (is_null(cdddr(false_p))) { /* 2 args to outer (c) func */ + if ((is_fxable(sc, cadr(false_p))) + || (is_fxable(sc, caddr(false_p)))) { + s7_pointer la; + la = (is_fxable(sc, cadr(false_p))) ? caddr(false_p) : + cadr(false_p); + if ((is_pair(la)) && (car(la) == name) + && (is_pair(cdr(la))) + && (is_fxable(sc, cadr(la)))) { + if ((vars == 1) && (is_null(cddr(la)))) + set_safe_optimize_op(body, + (orig == + cadddr(body)) ? ((la == + cadr + (false_p)) + ? + OP_RECUR_IF_A_A_opLA_Aq + : + OP_RECUR_IF_A_A_opA_LAq) + : ((la == + cadr(false_p)) ? + OP_RECUR_IF_A_opLA_Aq_A + : + OP_RECUR_IF_A_opA_LAq_A)); + else if ((vars == 2) && (is_pair(cddr(la))) + && (is_fxable(sc, caddr(la))) + && (is_null(cdddr(la)))) + set_safe_optimize_op(body, + (orig == + cadddr(body)) ? + OP_RECUR_IF_A_A_opA_LAAq : + OP_RECUR_IF_A_opA_LAAq_A); + else { + if ((vars == 3) && (is_pair(cddr(la))) + && (is_fxable(sc, caddr(la))) + && (is_pair(cdddr(la))) + && (is_fxable(sc, cadddr(la))) + && (is_null(cddddr(la))) + && (orig == cadddr(body))) + set_safe_optimize_op(body, + OP_RECUR_IF_A_A_opA_L3Aq); + else + return (false); + } + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, obody, args); + fx_annotate_arg(sc, + (la == + cadr(false_p)) ? cddr(false_p) : + cdr(false_p), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), + (vars > 1) ? cadr(args) : NULL, + (vars > 2) ? caddr(args) : NULL, false); + set_opt3_pair(body, false_p); + set_opt3_pair(false_p, la); + return (true); + } + } else { + s7_pointer la1 = cadr(false_p), la2 = caddr(false_p); + if ((vars == 1) && (is_proper_list_2(sc, la1)) + && (is_proper_list_2(sc, la2)) + && (car(la1) == name) && (car(la2) == name) + && (is_fxable(sc, cadr(la1))) + && (is_fxable(sc, cadr(la2)))) { + set_safe_optimize_op(body, + (orig == + cadddr(body)) ? + OP_RECUR_IF_A_A_opLA_LAq : + OP_RECUR_IF_A_opLA_LAq_A); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, obody, args); + fx_annotate_arg(sc, cdr(la1), args); + fx_annotate_arg(sc, cdr(la2), args); + fx_tree(sc, cdr(body), car(args), NULL, NULL, + false); + set_opt3_pair(body, false_p); + set_opt3_pair(false_p, la2); + return (true); + } + } + } else { /* 3 args to c func */ + if ((vars == 1) && + (is_pair(cdddr(false_p))) + && (is_null(cddddr(false_p)))) { + s7_pointer la1 = cadr(false_p), la2 = + caddr(false_p), la3 = cadddr(false_p); + if ((is_proper_list_2(sc, la2)) + && (is_proper_list_2(sc, la3)) + && (car(la2) == name) + && (car(la3) == name) && (is_fxable(sc, cadr(la2))) + && (is_fxable(sc, cadr(la3)))) { + if ((is_proper_list_2(sc, la1)) + && (car(la1) == name) + && (is_fxable(sc, cadr(la1)))) { + if (orig != cadddr(body)) + return (false); + set_safe_optimize_op(body, + OP_RECUR_IF_A_A_opLA_LA_LAq); + fx_annotate_arg(sc, cdr(la1), args); + } else if (is_fxable(sc, la1)) { + set_safe_optimize_op(body, + (orig == + cadddr(body)) ? + OP_RECUR_IF_A_A_opA_LA_LAq + : + OP_RECUR_IF_A_opA_LA_LAq_A); + fx_annotate_arg(sc, cdr(false_p), args); + } else + return (false); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, obody, args); + fx_annotate_arg(sc, cdr(la2), args); + fx_annotate_arg(sc, cdr(la3), args); + fx_tree(sc, cdr(body), car(args), NULL, NULL, + false); + set_opt3_pair(body, false_p); + set_opt3_pair(false_p, la3); + return (true); + } + } + } + } + } + + if ((vars == 3) && (is_fxable(sc, test))) { + s7_pointer true_p = caddr(body), false_p = cadddr(body); + if ((is_fxable(sc, true_p)) && + (is_proper_list_4(sc, false_p)) && (car(false_p) == name)) { + s7_pointer la1, la2, la3, l3a = cdr(false_p); + la1 = car(l3a); + la2 = cadr(l3a); + la3 = caddr(l3a); + if ((is_proper_list_4(sc, la1)) && (is_proper_list_4(sc, la2)) + && (is_proper_list_4(sc, la3)) && (car(la1) == name) + && (car(la2) == name) && (car(la3) == name) + && (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) + && (is_fxable(sc, cadr(la3))) + && (is_fxable(sc, caddr(la1))) + && (is_fxable(sc, caddr(la2))) + && (is_fxable(sc, caddr(la3))) + && (is_fxable(sc, cadddr(la1))) + && (is_fxable(sc, cadddr(la2))) + && (is_fxable(sc, cadddr(la3)))) { + set_safe_optimize_op(body, + OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq); + fx_annotate_args(sc, cdr(la1), args); + fx_annotate_args(sc, cdr(la2), args); + fx_annotate_args(sc, cdr(la3), args); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), + false); + set_opt3_pair(body, false_p); + set_opt3_pair(false_p, la3); + return (true); + } + } + } + return (false); +} + +static bool check_recur(s7_scheme * sc, s7_pointer name, int32_t vars, + s7_pointer args, s7_pointer body) +{ + if ((car(body) == sc->if_symbol) && (proper_list_length(body) == 4)) + return (check_recur_if(sc, name, vars, args, body)); + + if ((car(body) == sc->and_symbol) && + (vars == 2) && + (proper_list_length(body) == 3) && + (proper_list_length(caddr(body)) == 4) && + (caaddr(body) == sc->or_symbol) && (is_fxable(sc, cadr(body)))) { + s7_pointer la1, la2, or_p = caddr(body); + la1 = caddr(or_p); + la2 = cadddr(or_p); + if ((is_fxable(sc, cadr(or_p))) && + (proper_list_length(la1) == 3) && + (proper_list_length(la2) == 3) && + (car(la1) == name) && + (car(la2) == name) && + (is_fxable(sc, cadr(la1))) && + (is_fxable(sc, caddr(la1))) && + (is_fxable(sc, cadr(la2))) && (is_fxable(sc, caddr(la2)))) { + set_safe_optimize_op(body, OP_RECUR_AND_A_OR_A_LAA_LAA); + fx_annotate_args(sc, cdr(la1), args); + fx_annotate_args(sc, cdr(la2), args); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cdr(or_p), args); + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + set_opt3_pair(body, or_p); + return (true); + } + } + + if (car(body) == sc->cond_symbol) { + s7_pointer clause = cadr(body), clause2 = NULL; + if ((is_proper_list_1(sc, (cdr(clause)))) && + (is_fxable(sc, car(clause))) && + (is_fxable(sc, cadr(clause)))) { + s7_pointer la_clause = caddr(body); + s7_int len; + len = proper_list_length(body); + if (len == 4) { + if ((is_proper_list_2(sc, la_clause)) && + (is_fxable(sc, car(la_clause)))) { + clause2 = la_clause; + la_clause = cadddr(body); + } else + return (false); + } + if ((is_proper_list_2(sc, la_clause)) && + ((car(la_clause) == sc->else_symbol) + || (car(la_clause) == sc->T)) + && (is_pair(cadr(la_clause)))) { + la_clause = cadr(la_clause); /* (c_op arg (recur par)) or (c_op (recur) (recur)) or (op|l a laa) */ + if (is_proper_list_2(sc, cdr(la_clause))) { + if (is_h_optimized(la_clause)) { + if ((is_fxable(sc, cadr(la_clause))) && + ((len == 3) || + ((len == 4) && (vars == 2) && + (is_proper_list_3(sc, cadr(clause2))) && + (caadr(clause2) == name)))) { + s7_pointer la = caddr(la_clause); + if ((is_pair(la)) && + (car(la) == name) && + (is_pair(cdr(la))) && + (is_fxable(sc, cadr(la))) && + (((vars == 1) && (is_null(cddr(la)))) || + ((vars == 2) && + (is_pair(cddr(la))) && + (is_fxable(sc, caddr(la))) && + (is_null(cdddr(la)))))) { + if (len == 3) + set_safe_optimize_op(body, + (vars == + 1) ? + OP_RECUR_COND_A_A_opA_LAq + : + OP_RECUR_COND_A_A_opA_LAAq); + else { + s7_pointer laa = cadr(clause2); + if ((is_fxable(sc, cadr(laa))) && /* args to first laa */ + (is_fxable(sc, caddr(laa)))) { + set_safe_optimize_op(body, + OP_RECUR_COND_A_A_A_LAA_opA_LAAq); + fx_annotate_arg(sc, clause2, args); + fx_annotate_args(sc, cdr(laa), + args); + } else + return (false); + } + fx_annotate_args(sc, clause, args); + fx_annotate_arg(sc, cdr(la_clause), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), + (vars == 1) ? NULL : cadr(args), + NULL, false); + set_opt3_pair(body, la_clause); + set_opt3_pair(la_clause, la); + return (true); + } + } else { + if ((len == 4) && + (is_fxable(sc, cadr(clause2)))) { + s7_pointer la1 = cadr(la_clause), la2 = + caddr(la_clause); + bool happy = false; + + if ((vars == 1) && + (is_proper_list_2(sc, la1)) + && (is_proper_list_2(sc, la2)) + && (car(la1) == name) + && (car(la2) == name) + && (is_fxable(sc, cadr(la1))) + && (is_fxable(sc, cadr(la2)))) { + set_safe_optimize_op(body, + OP_RECUR_COND_A_A_A_A_opLA_LAq); + fx_annotate_arg(sc, cdr(la1), args); + happy = true; + } else if ((vars == 2) && + /* (is_fxable(sc, cadr(clause2))) && */ + (is_proper_list_3(sc, la2)) + && (car(la2) == name) + && (is_fxable(sc, cadr(la2))) + && (is_fxable(sc, caddr(la2)))) { + if (is_fxable(sc, la1)) { + set_safe_optimize_op(body, + OP_RECUR_COND_A_A_A_A_opA_LAAq); + fx_annotate_arg(sc, cdr(la_clause), + args); + happy = true; + } else + if ((is_proper_list_3(sc, la1)) && + (car(la1) == name) && + (is_fxable(sc, cadr(la1))) && + (is_fxable(sc, caddr(la1)))) { + set_safe_optimize_op(body, + OP_RECUR_COND_A_A_A_A_opLAA_LAAq); + fx_annotate_args(sc, cdr(la1), + args); + happy = true; + } + } + if (happy) { + set_opt3_pair(la_clause, cdr(la2)); + fx_annotate_args(sc, clause, args); + fx_annotate_args(sc, clause2, args); + fx_annotate_args(sc, cdr(la2), args); + fx_tree(sc, cdr(body), car(args), + (vars == + 1) ? NULL : cadr(args), NULL, + false); + set_opt3_pair(body, la_clause); + return (true); + } + } + } + } else { + if (clause2) { + s7_pointer laa = cadr(clause2); + + if ((vars == 2) && (len == 4) && + (is_proper_list_3(sc, laa)) + && (car(laa) == name) + && (is_fxable(sc, cadr(laa))) + && (is_fxable(sc, caddr(laa)))) { + s7_pointer la1 = cadr(la_clause), la2 = + caddr(la_clause); + if ((is_fxable(sc, la1)) + && (is_proper_list_3(sc, la2)) + && (car(la2) == name) + && (is_fxable(sc, cadr(la2))) + && (is_fxable(sc, caddr(la2)))) { + set_safe_optimize_op(body, + OP_RECUR_COND_A_A_A_LAA_LopA_LAAq); + fx_annotate_args(sc, clause, args); + fx_annotate_arg(sc, clause2, args); + fx_annotate_args(sc, cdr(laa), args); + fx_annotate_arg(sc, cdr(la_clause), + args); + fx_annotate_args(sc, cdr(la2), args); + fx_tree(sc, cdr(body), car(args), + cadr(args), NULL, false); + set_opt3_pair(body, la_clause); + set_opt3_pair(la_clause, cdr(la2)); + return (true); + } + } + } + } + } + } + } + } + return (false); +} + +static opt_t fxify_closure_s(s7_scheme * sc, s7_pointer func, + s7_pointer expr, s7_pointer e, int32_t hop) +{ + s7_pointer body = closure_body(func); + fx_annotate_arg(sc, body, e); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_A); + if ((is_pair(car(body))) && (is_pair(cdar(body))) + && (car(closure_args(func)) == cadar(body))) { + if (optimize_op(car(body)) == HOP_SAFE_C_S) + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_S); + else if (optimize_op(car(body)) == HOP_SAFE_C_SC) { + s7_pointer body_arg2 = caddar(body); + set_opt3_con(cdr(expr), + (is_pair(body_arg2)) ? cadr(body_arg2) : + body_arg2); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_SC); + if ((caar(body) == sc->vector_ref_symbol) + && (is_global(sc->vector_ref_symbol))) + set_fx_direct(cdr(expr), fx_safe_closure_s_to_vref); + else { + set_fx_direct(cdr(expr), fx_safe_closure_s_to_sc); + if ((is_t_integer(body_arg2)) && (integer(body_arg2) == 1)) { + if (caar(body) == sc->subtract_symbol) + set_fx_direct(cdr(expr), + fx_safe_closure_s_to_sub1); + if (caar(body) == sc->add_symbol) + set_fx_direct(cdr(expr), + fx_safe_closure_s_to_add1); + } + } + } + } + set_closure_one_form_fx_arg(func); + fx_tree(sc, body, car(closure_args(func)), NULL, NULL, false); + return (OPT_T); +} + +static bool fxify_closure_a(s7_scheme * sc, s7_pointer func, bool one_form, + bool safe_case, int32_t hop, s7_pointer expr, + s7_pointer e) +{ + if (one_form) { + if (safe_case) { + s7_pointer body = closure_body(func); + if (is_fxable(sc, car(body))) { + fx_annotate_arg(sc, body, e); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_A); + + if ((is_pair(car(body))) && + (optimize_op(car(body)) == HOP_SAFE_C_SC) && + (car(closure_args(func)) == cadar(body))) { + s7_pointer body_arg2 = caddar(body); + set_opt3_con(cdr(expr), + (is_pair(body_arg2)) ? cadr(body_arg2) : + body_arg2); + set_safe_optimize_op(expr, + hop + OP_SAFE_CLOSURE_A_TO_SC); + if ((caar(body) == sc->vector_ref_symbol) + && (is_global(sc->vector_ref_symbol))) + set_fx_direct(expr, fx_safe_closure_a_to_vref); + else + set_fx_direct(expr, fx_safe_closure_a_to_sc); + } + set_closure_one_form_fx_arg(func); + fx_tree(sc, body, car(closure_args(func)), NULL, NULL, + false); + return (true); + } + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_O); + } else + set_optimize_op(expr, hop + OP_CLOSURE_A_O); + } else + set_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_A : OP_CLOSURE_A)); + return (false); +} + +static opt_t optimize_closure_one_arg(s7_scheme * sc, s7_pointer expr, + s7_pointer func, int32_t hop, + int32_t pairs, int32_t symbols, + int32_t quotes, int32_t bad_pairs, + s7_pointer e) +{ + bool one_form, safe_case; + s7_pointer body, arg1 = cadr(expr); + int32_t arit; + arit = closure_arity_to_int(sc, func); + if (arit != 1) { + if ((arit == -1) && (is_symbol(closure_args(func)))) + return (optimize_closure_dotted_args + (sc, expr, func, hop, 1, e)); + return (OPT_F); + } + + safe_case = is_safe_closure(func); + body = closure_body(func); + one_form = is_null(cdr(body)); + if (is_immutable(func)) + hop = 1; + + if (symbols == 1) { + set_opt2_sym(expr, arg1); + set_opt1_lambda_add(expr, func); + + if (one_form) { + if (safe_case) { + if (is_fxable(sc, car(body))) + return (fxify_closure_s(sc, func, expr, e, hop)); + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_O); + } else + set_optimize_op(expr, hop + OP_CLOSURE_S_O); + } else + set_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_S : + OP_CLOSURE_S)); + set_unsafely_optimized(expr); + return (OPT_F); + } + + if (fx_count(sc, expr) == 1) { + set_unsafely_optimized(expr); + set_opt1_lambda_add(expr, func); + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_one); + if (fxify_closure_a(sc, func, one_form, safe_case, hop, expr, e)) + return (OPT_T); + set_unsafely_optimized(expr); + return (OPT_F); + } + set_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_P : OP_CLOSURE_P)); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), int_one); + set_unsafely_optimized(expr); + if ((safe_case) && (one_form) + && (is_fxable(sc, car(closure_body(func))))) { + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_P_A); /* other possibilities: 3p fp (ap|pa only get a few hits), but none of these matter much */ + fx_annotate_arg(sc, closure_body(func), e); + } + return (OPT_F); /* don't check is_optimized here for OPT_T */ +} + +static opt_t optimize_func_one_arg(s7_scheme * sc, s7_pointer expr, + s7_pointer func, int32_t hop, + int32_t pairs, int32_t symbols, + int32_t quotes, int32_t bad_pairs, + s7_pointer e) +{ + s7_pointer arg1; + /* very often, expr is already optimized, quoted stuff is counted under "bad_pairs"! as well as quotes */ + + if (quotes > 0) { + if (direct_memq(sc->quote_symbol, e)) + return (OPT_OOPS); + if ((bad_pairs == quotes) && + (is_symbol(car(expr))) && (is_constant_symbol(sc, car(expr)))) + hop = 1; + } + + arg1 = cadr(expr); + /* need in_with_let -> search only rootlet not lookup */ + if ((symbols == 1) && (!arg_findable(sc, arg1, e))) { + /* wrap the bad arg in a check symbol lookup */ + if (s7_is_aritable(sc, func, 1)) { + set_fx_direct(cdr(expr), fx_unsafe_s); + return (wrap_bad_args(sc, func, expr, 1, hop, e)); + } + return (OPT_F); + } + if ((is_c_function(func)) && + (c_function_required_args(func) <= 1) && + (c_function_all_args(func) >= 1)) + return (optimize_c_function_one_arg + (sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, + e)); + + if (is_closure(func)) + return (optimize_closure_one_arg + (sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, + e)); + + if (is_closure_star(func)) { + if (is_null(closure_args(func))) + return (OPT_F); + if (fx_count(sc, expr) == 1) { + bool safe_case = is_safe_closure(func); + if (is_immutable(func)) + hop = 1; + fx_annotate_arg(sc, cdr(expr), e); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), int_one); + set_unsafely_optimized(expr); + + if ((safe_case) && (is_null(cdr(closure_args(func))))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_A1); + else if (lambda_has_simple_defaults(func)) { + if (arglist_has_rest(sc, closure_args(func))) + set_optimize_op(expr, + hop + + ((safe_case) ? + OP_SAFE_CLOSURE_STAR_NA_1 : + OP_CLOSURE_STAR_NA)); + else + set_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_STAR_A : + OP_CLOSURE_STAR_A)); + } else + set_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : + OP_CLOSURE_STAR_NA)); + } + return (OPT_F); + } + + if ((is_c_function_star(func)) && (fx_count(sc, expr) == 1) && (c_function_all_args(func) >= 1) && (!is_keyword(arg1))) { /* the only arg should not be a keyword (needs error checks later) */ + if ((hop == 0) + && ((is_immutable(func)) + || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) + hop = 1; + set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_A); + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_one); + set_c_function(expr, func); + return (OPT_T); + } + + if (((is_any_vector(func)) || (is_pair(func))) && + (is_fxable(sc, arg1))) { + set_unsafe_optimize_op(expr, + (is_pair(func) ? OP_IMPLICIT_PAIR_REF_A : + OP_IMPLICIT_VECTOR_REF_A)); + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_one); + return (OPT_T); + } + + if ((func == sc->s7_let) && /* (*s7* ...) */ + (((quotes == 1) && (is_symbol(cadr(arg1)))) || (is_keyword(arg1)))) { + s7_pointer sym; + sym = (quotes == 1) ? cadr(arg1) : arg1; + if (is_keyword(sym)) + sym = keyword_symbol(sym); /* might even be ':print-length */ + set_safe_optimize_op(expr, OP_IMPLICIT_S7_LET_REF_S); + set_opt3_sym(expr, sym); + return (OPT_T); + } + + if (is_let(func)) { + if ((is_pair(arg1)) && (car(arg1) == sc->quote_symbol)) { + set_opt3_con(expr, cadr(arg1)); + set_unsafe_optimize_op(expr, OP_IMPLICIT_LET_REF_C); + return (OPT_T); + } + if (is_fxable(sc, arg1)) { + set_unsafe_optimize_op(expr, OP_IMPLICIT_LET_REF_A); + set_opt3_any(expr, arg1); + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_one); + return (OPT_T); + } + } + + /* unknown_* for other cases is set later(? -- we're getting eval-args...) */ + /* op_safe_c_p for (< (values 1 2 3)) op_s_s for (op arg) op_s_c for (op 'x) or (op 1) also op_s_a + * but is it better to wait for unknown* ? These are not hit often at this point (except in s7test). + * do they end up in op_s_a or whatever after unknown*? + */ + return ((is_optimized(expr)) ? OPT_T : OPT_F); +} + +static bool unsafe_is_safe(s7_scheme * sc, s7_pointer f, s7_pointer e) +{ + if (!is_symbol(f)) + return (false); + f = find_uncomplicated_symbol(sc, f, e); /* how to catch local c-funcs here? */ + if (!is_slot(f)) + return (false); + return ((is_c_function(slot_value(f))) + && (is_safe_procedure(slot_value(f)))); +} + +static opt_t set_any_closure_np(s7_scheme * sc, s7_pointer func, + s7_pointer expr, s7_pointer e, + int32_t num_args, opcode_t op) +{ + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cdr(p)) + set_fx(p, + fx_choose(sc, p, e, + (is_list(e)) ? pair_symbol_is_safe : + let_symbol_is_safe)); + set_opt3_arglen(cdr(expr), make_permanent_integer(num_args)); + set_unsafe_optimize_op(expr, op); + set_opt1_lambda_add(expr, func); + return (OPT_F); +} + +static bool two_args_ok(s7_scheme * sc, s7_pointer expr, s7_pointer e) +{ + if ((is_symbol(car(expr))) + && ((car(expr) == sc->member_symbol) + || (car(expr) == sc->assoc_symbol))) + return (true); + return (unsafe_is_safe(sc, cadr(expr), e)); +} + +static void opt_sp_1(s7_scheme * sc, s7_function g, s7_pointer expr) +{ + set_opt1_any(cdr(expr), (s7_pointer) ((intptr_t) + ((g == + g_cons) ? OP_SAFE_CONS_SP_1 + : (((g == g_list) + || (g == + g_list_2)) ? + OP_SAFE_LIST_SP_1 + : (((g == g_multiply) + || (g == + g_multiply_2)) ? + OP_SAFE_MULTIPLY_SP_1 + : (((g == g_add) + || (g == + g_add_2)) ? + OP_SAFE_ADD_SP_1 : + OP_SAFE_C_SP_1)))))); +} + +static opt_t set_any_c_np(s7_scheme * sc, s7_pointer func, s7_pointer expr, + s7_pointer e, int32_t num_args, opcode_t op) +{ + s7_pointer p; + + /* fprintf(stderr, "%d %d %d %s %s\n", num_args, is_safe_procedure(func), is_semisafe(func), op_names[op], display_80(expr)); */ + /* we get safe/semisafe funcs here of 2 args and up! very few more than 5 */ + /* would safe_c_pp work for cl? or should unknown_* deal with op_cl_*? why aren't unknown* used in op_safe_c and op_c? + * 2 | 3 args store on stack rather than consing? then use sc->t2|3 to pass to fn_proc (unless unsafe) + * or use op_stack? error clears this? op-any-c-fp: op_any_c_2p|3p|fp? -- mimic clo_3p|4p? + * all: 3 1 0 any_c_np (* 0.5 (- n 1) y)?? + */ + + for (p = cdr(expr); is_pair(p); p = cdr(p)) { + set_fx(p, + fx_choose(sc, p, e, + (is_list(e)) ? pair_symbol_is_safe : + let_symbol_is_safe)); + if (!has_fx(p)) + gx_annotate_arg(sc, p, e); + } + set_opt3_arglen(cdr(expr), make_permanent_integer(num_args)); /* for op_unknown_np */ + set_unsafe_optimize_op(expr, op); + choose_c_function(sc, expr, func, num_args); /* we can use num_args -- mv will redirect to generic call */ + return (OPT_F); +} + +static s7_function io_function(s7_scheme * sc, s7_function func) +{ + if (func == g_with_input_from_string) + return (with_string_in); + if (func == g_with_input_from_file) + return (with_file_in); + if (func == g_with_output_to_file) + return (with_file_out); + if (func == g_call_with_input_string) + return (call_string_in); + if (func == g_call_with_input_file) + return (call_file_in); + return (call_file_out); /* call_with_output_to_file */ +} + +static void fixup_closure_star_aa(s7_scheme * sc, s7_pointer f, + s7_pointer code, int32_t hop) +{ + int32_t arity; + bool safe_case = is_safe_closure(f); + s7_pointer arg1 = cadr(code), par1; + + arity = closure_star_arity_to_int(sc, f); + par1 = car(closure_args(f)); + if (is_pair(par1)) + par1 = car(par1); + set_opt3_arglen(cdr(code), int_two); + set_unsafely_optimized(code); + + if ((arity == 1) && (is_keyword(arg1)) + && (keyword_symbol(arg1) == par1)) + set_optimize_op(code, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_STAR_KA : + OP_CLOSURE_STAR_KA)); + else if ((lambda_has_simple_defaults(f)) && (arity == 2)) + set_optimize_op(code, hop + ((is_safe_closure(f)) + ? ((is_null(cdr(closure_body(f)))) ? + OP_SAFE_CLOSURE_STAR_AA_O : + OP_SAFE_CLOSURE_STAR_AA) : + OP_CLOSURE_STAR_NA)); + else + set_optimize_op(code, + hop + + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA_2 : + OP_CLOSURE_STAR_NA)); +} + +static int32_t check_lambda(s7_scheme * sc, s7_pointer form, bool optl); + +static opt_t optimize_func_two_args(s7_scheme * sc, s7_pointer expr, + s7_pointer func, int32_t hop, + int32_t pairs, int32_t symbols, + int32_t quotes, int32_t bad_pairs, + s7_pointer e) +{ + s7_pointer arg1, arg2; + if (quotes > 0) { + if (direct_memq(sc->quote_symbol, e)) + return (OPT_OOPS); + if ((bad_pairs == quotes) && + (is_symbol(car(expr))) && (is_constant_symbol(sc, car(expr)))) + hop = 1; + } + arg1 = cadr(expr); + arg2 = caddr(expr); + if (((is_symbol(arg1)) && + (!arg_findable(sc, arg1, e))) || + ((is_symbol(arg2)) && (!arg_findable(sc, arg2, e)))) { + /* wrap bad args */ + if ((is_fxable(sc, arg1)) && + (is_fxable(sc, arg2)) && (s7_is_aritable(sc, func, 2))) { + fx_annotate_args(sc, cdr(expr), e); + return (wrap_bad_args(sc, func, expr, 2, hop, e)); + } + return (OPT_F); + } + /* end of bad symbol wrappers */ + + if (is_c_function(func) && + (c_function_required_args(func) <= 2) && + (c_function_all_args(func) >= 2)) { + /* this is a mess */ + bool func_is_safe = is_safe_procedure(func); + if ((hop == 0) + && ((is_immutable(func)) + || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) + hop = 1; + + if (pairs == 0) { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) { + /* another case here: set-car! and set-cdr! are safe if symbols==1 and arg1 is the symbol (i.e. arg2 is a constant) */ + if (symbols == 0) + set_optimize_op(expr, hop + OP_SAFE_C_NC); + else if (symbols == 2) { /* these two symbols are almost never the same, (sqrt (+ (* x x) (* y y))) */ + set_optimize_op(expr, hop + OP_SAFE_C_SS); + set_opt2_sym(cdr(expr), arg2); + } else if (is_normal_symbol(arg1)) { + set_opt2_con(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_SAFE_C_SC); + } else { + set_opt1_con(cdr(expr), arg1); + set_opt2_sym(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_SAFE_C_CS); + } + set_optimized(expr); + choose_c_function(sc, expr, func, 2); + return (OPT_T); + } + + set_unsafely_optimized(expr); + if (symbols == 2) { + if (c_function_call(func) == g_apply) { + set_optimize_op(expr, OP_APPLY_SS); + set_opt1_cfunc(expr, func); /* not quite set_c_function */ + set_opt2_sym(expr, arg2); + } else { + if (is_semisafe(func)) { + set_opt2_sym(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_CL_SS); + } else + set_optimize_op(expr, hop + OP_C_SS); + choose_c_function(sc, expr, func, 2); + } + } else { + set_optimize_op(expr, + hop + + ((is_semisafe(func)) ? OP_CL_AA : + OP_C_AA)); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_two); + choose_c_function(sc, expr, func, 2); + if (is_safe_procedure(opt1_cfunc(expr))) { + clear_unsafe(expr); + /* symbols can be 0..2 here, no pairs */ + set_optimized(expr); + if (symbols == 1) { + if (is_normal_symbol(arg1)) { + set_optimize_op(expr, hop + OP_SAFE_C_SC); + set_opt2_con(cdr(expr), arg2); + } else { + set_opt1_con(cdr(expr), arg1); + set_opt2_sym(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_SAFE_C_CS); + } + } + return (OPT_T); + } + } + return (OPT_F); + } + + /* pairs != 0 */ + if ((bad_pairs == 0) && (pairs == 2)) { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) { + int32_t op; + op = combine_ops(sc, func, expr, E_C_PP, arg1, arg2); + set_safe_optimize_op(expr, hop + op); + if (op == OP_SAFE_C_PP) { + if (((op_no_hop(cadr(expr))) == + OP_SAFE_CLOSURE_S_TO_SC) + && ((op_no_hop(caddr(expr))) == + OP_SAFE_CLOSURE_S_TO_SC) + && (is_global(caadr(expr))) + && (is_global(caaddr(expr)))) { + /* ideally this would be OP not HOP, but safe_closure_s_to_sc is too picky */ + /* set_opt3_pair(expr, caddr(expr)); */ + set_opt3_arglen(cdr(expr), int_two); + set_safe_optimize_op(expr, HOP_SAFE_C_FF); + } + + opt_sp_1(sc, c_function_call(func), expr); /* calls set_opt1_any, sets opt1(cdr(expr)) to OP_SAFE_CONS_SP_1 and friends */ + if (is_fxable(sc, arg1)) { + if (is_fxable(sc, arg2)) + return (check_c_aa(sc, expr, func, hop, e)); /* AA case */ + set_optimize_op(expr, hop + OP_SAFE_C_AP); + fx_annotate_arg(sc, cdr(expr), e); + gx_annotate_arg(sc, cddr(expr), e); + set_opt3_arglen(cdr(expr), int_two); + } else if (is_fxable(sc, arg2)) { + set_optimize_op(expr, hop + OP_SAFE_C_PA); + fx_annotate_arg(sc, cddr(expr), e); + gx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_two); + } else + gx_annotate_args(sc, cdr(expr), e); + } + choose_c_function(sc, expr, func, 2); /* this might change the op to safe_c_c, so it has to be last */ + return (OPT_T); + } + } + + if ((bad_pairs == 0) && (pairs == 1)) { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) { + combine_op_t orig_op; + int32_t op; + + if (is_pair(arg1)) { + orig_op = (is_normal_symbol(arg2)) ? E_C_PS : E_C_PC; + op = combine_ops(sc, func, expr, orig_op, arg1, arg2); + } else { + orig_op = (is_normal_symbol(arg1)) ? E_C_SP : E_C_CP; + op = combine_ops(sc, func, expr, orig_op, arg1, arg2); + } + if ((((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) && + (is_fxable(sc, arg2))) || + (((op == OP_SAFE_C_PS) || (op == OP_SAFE_C_PC)) && + (is_fxable(sc, arg1)))) { + fx_annotate_args(sc, cdr(expr), e); + if (!safe_c_aa_to_ag_ga(sc, expr, hop)) { + set_safe_optimize_op(expr, hop + OP_SAFE_C_AA); + set_opt3_pair(expr, cddr(expr)); + } + } else { + set_safe_optimize_op(expr, hop + op); + if ((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) { + opt_sp_1(sc, c_function_call(func), expr); + set_opt3_any(cdr(expr), arg1); + } else if (op == OP_SAFE_C_PC) + set_opt3_con(cdr(expr), arg2); + } + choose_c_function(sc, expr, func, 2); + return (OPT_T); + } + + if ((symbols == 1) && + (is_normal_symbol(arg1)) && (is_safe_c_s(arg2))) { + set_unsafe_optimize_op(expr, + hop + + ((is_semisafe(func)) ? OP_CL_S_opSq + : OP_C_S_opSq)); + set_opt1_sym(cdr(expr), cadr(arg2)); + choose_c_function(sc, expr, func, 2); + return (OPT_F); + } + } + + if ((bad_pairs == 1) && (quotes == 1)) { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) { + if (symbols == 1) { + set_optimized(expr); + if (is_normal_symbol(arg1)) { + set_opt2_con(cdr(expr), cadr(arg2)); + set_optimize_op(expr, hop + OP_SAFE_C_SC); + } else { + set_opt1_con(cdr(expr), cadr(arg1)); + set_opt2_sym(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_SAFE_C_CS); + } + choose_c_function(sc, expr, func, 2); + return (OPT_T); + } + if ((pairs == 1) && (is_pair(arg2))) { /* QC never happens */ + set_safe_optimize_op(expr, hop + OP_SAFE_C_CQ); + set_opt2_con(cdr(expr), cadr(arg2)); + choose_c_function(sc, expr, func, 2); + return (OPT_T); + } + if (!is_safe_c_s(arg1)) { + if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) + return (check_c_aa(sc, expr, func, hop, e)); + } + } else if (pairs == 1) { + set_unsafe_optimize_op(expr, + hop + + ((is_semisafe(func)) ? OP_CL_AA : + OP_C_AA)); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_two); + choose_c_function(sc, expr, func, 2); + return (OPT_F); + } + } + + if (quotes == 2) { + if (func_is_safe) { + set_safe_optimize_op(expr, hop + OP_SAFE_C_AA); /* op_safe_c_nc -> fx_c_nc appears to leave quoted pairs quoted? */ + set_opt3_pair(expr, cddr(expr)); + } else { + set_unsafe_optimize_op(expr, + hop + + ((is_semisafe(func)) ? OP_CL_AA : + OP_C_AA)); + set_opt3_arglen(cdr(expr), int_two); + } + fx_annotate_args(sc, cdr(expr), e); + choose_c_function(sc, expr, func, 2); + return ((func_is_safe) ? OPT_T : OPT_F); + } + + if ((pairs == 1) && + (quotes == 0) && + ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e))))) { + if (symbols == 1) { + set_optimized(expr); + if (is_normal_symbol(arg1)) { /* this is what optimize_expression uses to count symbols */ + set_optimize_op(expr, hop + OP_SAFE_C_SP); + opt_sp_1(sc, c_function_call(func), expr); + } else + set_optimize_op(expr, hop + OP_SAFE_C_PS); + choose_c_function(sc, expr, func, 2); + if (bad_pairs == 0) + return (OPT_T); + set_unsafe(expr); + return (OPT_F); + } + if (symbols == 0) { + set_optimized(expr); + if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) + return (check_c_aa(sc, expr, func, hop, e)); + if (is_pair(arg1)) { + set_optimize_op(expr, hop + OP_SAFE_C_PC); + set_opt3_con(cdr(expr), arg2); + } else { + set_optimize_op(expr, hop + OP_SAFE_C_CP); + opt_sp_1(sc, c_function_call(func), expr); + set_opt3_any(cdr(expr), arg1); + } + choose_c_function(sc, expr, func, 2); + if (bad_pairs == 0) + return (OPT_T); + set_unsafe(expr); + return (OPT_F); + } + } + + if ((pairs == 2) && + ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e))))) { + if ((bad_pairs == 1) && (is_safe_c_s(arg1))) { + /* unsafe func here won't work unless we check that later and make the new arg list (for list-values etc) + * (and it has to be the last pair else the unknown_g stuff can mess up) + */ + if ((car(arg2) == sc->quote_symbol) && + (is_global(sc->quote_symbol))) { + if (!is_proper_list_1(sc, cdr(arg2))) + return (OPT_OOPS); + set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_C); + set_opt1_sym(cdr(expr), cadr(arg1)); + set_opt2_con(cdr(expr), cadr(arg2)); + choose_c_function(sc, expr, func, 2); + return (OPT_T); + } + set_unsafe_optimize_op(expr, hop + OP_SAFE_C_opSq_P); + opt_sp_1(sc, c_function_call(func), expr); + choose_c_function(sc, expr, func, 2); + return (OPT_F); + } + if (quotes == 0) { + set_unsafely_optimized(expr); + if (is_fxable(sc, arg1)) { + if (is_fxable(sc, arg2)) + return (check_c_aa(sc, expr, func, hop, e)); + set_optimize_op(expr, hop + OP_SAFE_C_AP); + opt_sp_1(sc, c_function_call(func), expr); + fx_annotate_arg(sc, cdr(expr), e); + gx_annotate_arg(sc, cddr(expr), e); + } else if (is_fxable(sc, arg2)) { + set_optimize_op(expr, hop + OP_SAFE_C_PA); + fx_annotate_arg(sc, cddr(expr), e); + gx_annotate_arg(sc, cdr(expr), e); + } else { + set_optimize_op(expr, hop + OP_SAFE_C_PP); + opt_sp_1(sc, c_function_call(func), expr); + gx_annotate_args(sc, cdr(expr), e); + } + choose_c_function(sc, expr, func, 2); + return (OPT_F); + } + if (quotes == 1) { + if ((car(arg1) == sc->quote_symbol) && + (is_global(sc->quote_symbol))) { + if (!is_proper_list_1(sc, cdr(arg1))) + return (OPT_OOPS); + set_optimize_op(expr, hop + OP_SAFE_C_CP); + opt_sp_1(sc, c_function_call(func), expr); + set_opt3_any(cdr(expr), cadr(arg1)); + } else { + set_optimize_op(expr, hop + OP_SAFE_C_PC); + set_opt3_con(cdr(expr), cadr(arg2)); + } + set_unsafely_optimized(expr); + choose_c_function(sc, expr, func, 2); + return (OPT_F); + } + } + + if (func_is_safe) { + if (fx_count(sc, expr) == 2) + return (check_c_aa(sc, expr, func, hop, e)); + } else { + if (is_fxable(sc, arg1)) { + if (is_fxable(sc, arg2)) { + if ((c_function_call(func) == g_apply) && + (is_normal_symbol(arg1))) { + set_optimize_op(expr, OP_APPLY_SA); + if ((is_pair(arg2)) && (is_normal_symbol(car(arg2)))) { /* arg2 might be ((if expr op1 op2) ...) */ + s7_pointer lister; + lister = lookup(sc, car(arg2)); + if ((is_c_function(lister)) && + (is_pair(c_function_signature(lister))) && + (car(c_function_signature(lister)) == + sc->is_proper_list_symbol)) + set_optimize_op(expr, OP_APPLY_SL); + } + set_opt1_cfunc(expr, func); /* not quite set_c_function */ + } else + set_unsafe_optimize_op(expr, + hop + + ((is_semisafe(func)) ? + OP_CL_AA : OP_C_AA)); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_two); + } else { + if (((c_function_call(func) == g_with_input_from_string) || (c_function_call(func) == g_with_input_from_file) || (c_function_call(func) == g_with_output_to_file)) && (is_ok_lambda(sc, arg2)) && (is_null(cadr(arg2))) && (!direct_memq(car(arg2), e))) { /* lambda is redefined?? */ + set_unsafe_optimize_op(expr, + (is_string(arg1)) ? + OP_WITH_IO_C : OP_WITH_IO); + set_opt2_pair(expr, cddr(arg2)); + set_opt1_any(expr, + (s7_pointer) io_function(sc, + c_function_call + (func))); + return (OPT_F); + } + if (((c_function_call(func) == g_call_with_input_string) || (c_function_call(func) == g_call_with_input_file) || (c_function_call(func) == g_call_with_output_file)) && (is_ok_lambda(sc, arg2)) && (is_proper_list_1(sc, cadr(arg2))) && (is_symbol(caadr(arg2))) && (!is_probably_constant(caadr(arg2))) && (!direct_memq(sc->lambda_symbol, e))) { /* lambda is redefined?? */ + set_unsafe_optimize_op(expr, + (is_string(arg1)) ? + OP_WITH_IO_C : OP_WITH_IO); + set_opt2_pair(expr, cddr(arg2)); + set_opt3_sym(expr, caadr(arg2)); + set_opt1_any(expr, + (s7_pointer) io_function(sc, + c_function_call + (func))); + return (OPT_F); + } + set_unsafe_optimize_op(expr, hop + OP_C_AP); + fx_annotate_arg(sc, cdr(expr), e); + } + choose_c_function(sc, expr, func, 2); + return (OPT_F); + } + + if ((is_semisafe(func)) && + (is_symbol(car(expr))) && + (car(expr) != sc->values_symbol) && + (is_fxable(sc, arg2)) && + (is_pair(arg1)) && (car(arg1) == sc->lambda_symbol)) { + s7_pointer p; + fx_annotate_arg(sc, cddr(expr), e); + set_unsafe_optimize_op(expr, hop + OP_CL_FA); + check_lambda(sc, arg1, true); /* this changes symbol_list */ + + clear_symbol_list(sc); /* so restore it */ + for (p = e; is_pair(p); p = cdr(p)) + if (is_normal_symbol(car(p))) + add_symbol_to_list(sc, car(p)); + + /* two seq args can't happen here (func_2_args = map + lambda + seq, arg1 is the lambda form, arg2 is fxable (see above) */ + choose_c_function(sc, expr, func, 2); + if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && ((is_proper_list_1(sc, cadr(arg1))) && /* one parameter */ + (!is_possibly_constant(caadr(arg1))))) { /* parameter name not trouble */ + /* built-in permanent closure here was not much faster */ + set_fn(expr, + (fn_proc(expr) == + g_for_each) ? g_for_each_closure : NULL); + set_opt3_pair(expr, cdr(arg1)); + set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FA); + } + return (OPT_F); + } + } + return (set_any_c_np(sc, func, expr, e, 2, hop + OP_ANY_C_NP)); /* OP_C_PP doesn't exist */ + /* TODO: gx_annotate */ + } + + if (is_closure(func)) { + int32_t arit; + bool one_form, safe_case; + s7_pointer body; + + arit = closure_arity_to_int(sc, func); + if (arit != 2) { + if ((arit == -1) && (is_symbol(closure_args(func)))) + return (optimize_closure_dotted_args + (sc, expr, func, hop, 2, e)); + return (OPT_F); + } + if (is_immutable(func)) + hop = 1; + + body = closure_body(func); + one_form = is_null(cdr(body)); + safe_case = is_safe_closure(func); + + if ((pairs == 0) && (symbols >= 1)) { + set_unsafely_optimized(expr); + set_opt1_lambda_add(expr, func); + if (symbols == 2) { + set_opt2_sym(expr, arg2); + if (!one_form) + set_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_SS : + OP_CLOSURE_SS)); + else if (!safe_case) + set_optimize_op(expr, hop + OP_CLOSURE_SS_O); + else if (!is_fxable(sc, car(body))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_O); + else { + fx_annotate_arg(sc, body, e); + fx_tree(sc, body, car(closure_args(func)), + cadr(closure_args(func)), NULL, false); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_A); + /* fx_annotate_args(sc, cdr(expr), e); */ + set_closure_one_form_fx_arg(func); + return (OPT_T); + } + return (OPT_F); + } + if (is_normal_symbol(arg1)) { + if (one_form) + set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC_O : OP_CLOSURE_SC_O)); /* _A case is very rare */ + else + set_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_SC : + OP_CLOSURE_SC)); + set_opt2_con(expr, arg2); + return (OPT_F); + } + } + + if ((!arglist_has_rest(sc, closure_args(func))) && + (fx_count(sc, expr) == 2)) { + if (!one_form) + set_safe_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_AA : + OP_CLOSURE_AA)); + else if (!safe_case) + set_optimize_op(expr, hop + OP_CLOSURE_AA_O); + else if (!is_fxable(sc, car(body))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_O); + else { + fx_annotate_arg(sc, body, e); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_A); /* safe_closure_as|sa_a? */ + set_closure_one_form_fx_arg(func); + fx_annotate_args(sc, cdr(expr), e); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), int_two); + return (OPT_T); + } + fx_annotate_args(sc, cdr(expr), e); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), int_two); + return (OPT_F); + } + + if (is_fxable(sc, arg1)) { + set_unsafely_optimized(expr); + fx_annotate_arg(sc, cdr(expr), e); + set_safe_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_AP : + OP_CLOSURE_AP)); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), int_two); /* for op_unknown_np */ + return (OPT_F); + } + + if ((is_pair(arg1)) && (car(arg1) == sc->lambda_symbol) && (is_pair(cdr(arg1))) && /* not (lambda) */ + (is_fxable(sc, arg2)) && (is_null(cdr(closure_body(func))))) { + s7_pointer p; + fx_annotate_arg(sc, cddr(expr), e); + set_opt2_pair(expr, cdr(arg1)); + set_unsafe_optimize_op(expr, hop + OP_CLOSURE_FA); + check_lambda(sc, arg1, false); + + clear_symbol_list(sc); + for (p = e; is_pair(p); p = cdr(p)) + if (is_normal_symbol(car(p))) + add_symbol_to_list(sc, car(p)); + + /* check_lambda calls optimize_lambda if define in progress, else just optimize on the body */ + clear_safe_closure_body(cddr(arg1)); /* otherwise we need to fixup the local let for the optimizer -- what is this about? */ + set_opt1_lambda_add(expr, func); + return (OPT_F); + } + + if (is_fxable(sc, arg2)) { + set_unsafely_optimized(expr); + fx_annotate_arg(sc, cddr(expr), e); + set_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_PA : + OP_CLOSURE_PA)); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), int_two); /* for op_unknown_np */ + return (OPT_F); + } + + if (is_safe_closure(func)) /* clo* too */ + return (set_any_closure_np + (sc, func, expr, e, 2, hop + OP_SAFE_CLOSURE_PP)); + + set_unsafely_optimized(expr); + set_optimize_op(expr, hop + OP_CLOSURE_PP); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), int_two); /* for op_unknown_np */ + return (OPT_F); + } + + if (is_closure_star(func)) { + if (is_immutable(func)) + hop = 1; + if (fx_count(sc, expr) == 2) { + fixup_closure_star_aa(sc, func, expr, hop); + fx_annotate_args(sc, cdr(expr), e); + set_opt1_lambda_add(expr, func); + return (OPT_F); + } + } + + if ((is_c_function_star(func)) && + (fx_count(sc, expr) == 2) && + (c_function_all_args(func) >= 1) && (!is_keyword(arg2))) { + if ((hop == 0) + && ((is_immutable(func)) + || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) + hop = 1; + set_optimized(expr); + set_optimize_op(expr, hop + OP_SAFE_C_STAR_AA); /* k+c? = cc */ + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_two); + set_c_function(expr, func); + return (OPT_T); + } + + if (((is_any_vector(func)) || (is_pair(func))) && + (is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) { + set_unsafe_optimize_op(expr, + ((is_pair(func)) ? OP_IMPLICIT_PAIR_REF_AA : + OP_IMPLICIT_VECTOR_REF_AA)); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_two); + return (OPT_T); + } + return ((is_optimized(expr)) ? OPT_T : OPT_F); +} + +static opt_t optimize_safe_c_func_three_args(s7_scheme * sc, + s7_pointer expr, + s7_pointer func, int32_t hop, + int32_t pairs, + int32_t symbols, + int32_t quotes, s7_pointer e) +{ + s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); + if (pairs == 0) { + set_optimized(expr); + if (symbols == 0) + set_optimize_op(expr, hop + OP_SAFE_C_NC); + else if (symbols == 3) { + set_optimize_op(expr, hop + OP_SAFE_C_SSS); + set_opt1_sym(cdr(expr), arg2); + set_opt2_sym(cdr(expr), arg3); + } else if (symbols == 2) + if (!is_normal_symbol(arg1)) { + set_optimize_op(expr, hop + OP_SAFE_C_CSS); + set_opt1_sym(cdr(expr), arg2); + set_opt2_sym(cdr(expr), arg3); + } else if (!is_normal_symbol(arg3)) { + set_opt2_con(cdr(expr), arg3); + set_opt1_sym(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_SAFE_C_SSC); + } else { + set_opt1_con(cdr(expr), arg2); + set_opt2_sym(cdr(expr), arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCS); + } else if (is_normal_symbol(arg1)) { + set_opt1_con(cdr(expr), arg2); + set_opt2_con(cdr(expr), arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCC); + } else if (is_normal_symbol(arg2)) { + set_opt1_sym(cdr(expr), arg2); + set_opt2_con(cdr(expr), arg3); + set_opt3_con(cdr(expr), arg1); + set_optimize_op(expr, hop + OP_SAFE_C_CSC); + } else { + set_opt1_sym(cdr(expr), arg3); + set_opt2_con(cdr(expr), arg2); + set_opt3_con(cdr(expr), arg1); + set_optimize_op(expr, hop + OP_SAFE_C_CCS); + } + choose_c_function(sc, expr, func, 3); + return (OPT_T); + } + + /* pairs != 0 */ + if (fx_count(sc, expr) == 3) { + set_optimized(expr); + if (quotes == 1) { + if ((symbols == 2) && + (is_normal_symbol(arg1)) && (is_normal_symbol(arg3))) { + set_opt1_con(cdr(expr), cadr(arg2)); /* fx_c_scs uses opt1_con */ + set_opt2_sym(cdr(expr), arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCS); /* used to be SQS */ + choose_c_function(sc, expr, func, 3); + return (OPT_T); + } + if (symbols == 1) { + if ((is_normal_symbol(arg3)) && + (is_proper_quote(sc, arg2)) && (is_safe_c_s(arg1))) { + set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_CS); /* lg */ + set_opt1_con(cdr(expr), cadr(arg2)); /* opt1_con is T_Pos (unchecked) */ + set_opt2_sym(cdr(expr), arg3); + set_opt3_sym(cdr(expr), cadr(arg1)); + choose_c_function(sc, expr, func, 3); + return (OPT_T); + } + if ((is_normal_symbol(arg2)) && + (is_proper_quote(sc, arg1)) && (!is_pair(arg3))) { + set_optimize_op(expr, hop + OP_SAFE_C_CSC); + set_opt1_sym(cdr(expr), arg2); + set_opt2_con(cdr(expr), arg3); + set_opt3_con(cdr(expr), cadr(arg1)); + choose_c_function(sc, expr, func, 3); + return (OPT_T); + } + } + } + + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_three); + set_opt3_pair(expr, cddr(expr)); + set_optimize_op(expr, hop + OP_SAFE_C_AAA); + + if (pairs == 1) { + if (is_pair(arg1)) + set_optimize_op(expr, hop + OP_SAFE_C_AGG); + + if ((symbols == 0) && (is_pair(arg2))) + set_optimize_op(expr, hop + OP_SAFE_C_CAC); + else { + if ((symbols == 1) && (is_pair(arg3))) + set_optimize_op(expr, + hop + + ((is_normal_symbol(arg2)) ? + OP_SAFE_C_CSA : OP_SAFE_C_SCA)); + else { + if (symbols == 2) { + if (is_normal_symbol(arg1)) { + if (is_normal_symbol(arg2)) { + if ((hop == 1) + && (s7_p_ppp_function(func))) { + set_optimize_op(expr, HOP_SSA_DIRECT); + clear_has_fx(cdr(expr)); + set_opt2_direct(cdr(expr), (s7_pointer) + (s7_p_ppp_function + (func))); + } else + set_optimize_op(expr, + hop + OP_SAFE_C_SSA); + } else + set_optimize_op(expr, hop + OP_SAFE_C_SAS); + } else if (is_pair(arg1)) + set_optimize_op(expr, hop + OP_SAFE_C_ASS); + } + } + } + } else if ((is_normal_symbol(arg1)) && (pairs == 2)) + set_optimize_op(expr, hop + OP_SAFE_C_SAA); + + choose_c_function(sc, expr, func, 3); + return (OPT_T); + } + return (OPT_F); /* tell caller to try something else */ +} + +static opt_t optimize_func_three_args(s7_scheme * sc, s7_pointer expr, + s7_pointer func, int32_t hop, + int32_t pairs, int32_t symbols, + int32_t quotes, int32_t bad_pairs, + s7_pointer e) +{ + s7_pointer arg1, arg2, arg3; + if ((quotes > 0) && (direct_memq(sc->quote_symbol, e))) + return (OPT_OOPS); + + arg1 = cadr(expr); + arg2 = caddr(expr); + arg3 = cadddr(expr); + + if (((is_symbol(arg1)) && + (!arg_findable(sc, arg1, e))) || + ((is_symbol(arg2)) && + (!arg_findable(sc, arg2, e))) || + ((is_symbol(arg3)) && (!arg_findable(sc, arg3, e)))) { + /* wrap bad args */ + if ((is_fxable(sc, arg1)) && + (is_fxable(sc, arg2)) && + (is_fxable(sc, arg3)) && (s7_is_aritable(sc, func, 3))) { + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_three); + if (is_c_function(func)) { + if (is_safe_procedure(func)) { + set_safe_optimize_op(expr, hop + OP_SAFE_C_AAA); + set_opt3_pair(cdr(expr), cdddr(expr)); + set_opt3_pair(expr, cddr(expr)); + } else + set_safe_optimize_op(expr, + hop + + ((is_semisafe(func)) ? OP_CL_NA : + OP_C_NA)); + set_c_function(expr, func); + return (OPT_T); + } + if ((is_closure(func)) && + (closure_arity_to_int(sc, func) == 3) && + (!arglist_has_rest(sc, closure_args(func)))) { + set_unsafely_optimized(expr); + set_optimize_op(expr, + hop + + ((is_safe_closure(func)) ? + OP_SAFE_CLOSURE_3A : OP_CLOSURE_3A)); + set_opt1_lambda_add(expr, func); + return (OPT_F); + } + if ((is_closure_star(func)) && + (lambda_has_simple_defaults(func)) && + (closure_star_arity_to_int(sc, func) != 0) && + (closure_star_arity_to_int(sc, func) != 1)) { + set_unsafely_optimized(expr); + if ((is_safe_closure(func)) + && (closure_star_arity_to_int(sc, func) == 3)) + set_optimize_op(expr, OP_SAFE_CLOSURE_STAR_3A); + else + set_optimize_op(expr, + ((is_safe_closure(func)) ? + OP_SAFE_CLOSURE_STAR_NA : + OP_CLOSURE_STAR_NA)); + set_opt1_lambda_add(expr, func); + } + } + return (OPT_F); + } /* end of bad symbol wrappers */ + + if ((bad_pairs == quotes) && + (is_symbol(car(expr))) && (is_constant_symbol(sc, car(expr)))) + hop = 1; + + if (is_c_function(func) && + (c_function_required_args(func) <= 3) && + (c_function_all_args(func) >= 3)) { + if ((hop == 0) + && ((is_immutable(func)) + || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) + hop = 1; + if ((is_safe_procedure(func)) || + ((is_maybe_safe(func)) && (unsafe_is_safe(sc, arg3, e)))) { + if (optimize_safe_c_func_three_args + (sc, expr, func, hop, pairs, symbols, quotes, e) == OPT_T) + return (OPT_T); + if ((is_normal_symbol(arg1)) && (is_normal_symbol(arg2))) { + set_opt3_pair(expr, arg3); + set_unsafe_optimize_op(expr, hop + OP_SAFE_C_SSP); + choose_c_function(sc, expr, func, 3); + return (OPT_F); + } + return (set_any_c_np + (sc, func, expr, e, 3, hop + OP_SAFE_C_3P)); + } + /* func is not safe */ + if (fx_count(sc, expr) == 3) { + set_optimized(expr); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_three); + if (is_semisafe(func)) + set_optimize_op(expr, hop + (((is_normal_symbol(arg1)) + && (is_normal_symbol(arg3))) + ? OP_CL_SAS : OP_CL_NA)); + else + set_optimize_op(expr, hop + OP_C_NA); + choose_c_function(sc, expr, func, 3); + set_unsafe(expr); + return (OPT_F); + } + + /* (define (hi) (catch #t (lambda () 1) (lambda args 2))) + * first arg list must be (), second a symbol + */ + if (c_function_call(func) == g_catch) { + if (((bad_pairs == 2) && (!is_pair(arg1))) || + ((bad_pairs == 3) && (car(arg1) == sc->quote_symbol))) { + s7_pointer body_lambda = arg2, error_lambda = arg3; + if ((is_ok_lambda(sc, body_lambda)) && (is_ok_lambda(sc, error_lambda)) && (is_null(cadr(body_lambda))) && (((is_symbol(cadr(error_lambda))) && /* (lambda args ... */ + (!is_probably_constant(cadr(error_lambda)))) || ((is_pair(cadr(error_lambda))) && /* (lambda (type info) ... */ + (is_pair(cdadr(error_lambda))) && (is_null(cddadr(error_lambda))) && (!is_probably_constant(caadr(error_lambda))) && /* (lambda (pi ...) ...) */ + (!is_probably_constant(cadadr(error_lambda)))))) { + s7_pointer error_result = caddr(error_lambda); + set_unsafely_optimized(expr); + if ((arg1 == sc->T) && /* tag is #t */ + (is_null(cdddr(error_lambda))) && /* error lambda body is one expr */ + ((!is_symbol(error_result)) || /* (lambda args #f) */ + ((is_pair(cadr(error_lambda))) && (error_result == caadr(error_lambda)))) && /* (lambda (type info) type) */ + ((!is_pair(error_result)) || (car(error_result) == sc->quote_symbol) || /* (lambda args 'a) */ + ((car(error_result) == sc->car_symbol) && (cadr(error_result) == cadr(error_lambda))))) { /* (lambda args (car args) -> error-type */ + set_optimize_op(expr, hop + OP_C_CATCH_ALL); /* catch_all* = #t tag, error handling can skip to the simple lambda body */ + set_c_function(expr, func); + set_opt2_con(expr, error_result); + set_opt1_pair(cdr(expr), cddr(body_lambda)); + if (is_null(cdddr(body_lambda))) { + if (is_fxable(sc, caddr(body_lambda))) { + set_optimize_op(expr, + hop + OP_C_CATCH_ALL_A); + set_fx_direct(cddr(body_lambda), + fx_choose(sc, + cddr(body_lambda), + sc->curlet, + let_symbol_is_safe)); + } else { + set_opt1_pair(cdr(expr), + caddr(body_lambda)); + set_optimize_op(expr, + hop + OP_C_CATCH_ALL_O); + /* fn got no hits */ + } + } + } else { + set_optimize_op(expr, hop + OP_C_CATCH); /* mainly c_catch_p, but this is not a common case */ + choose_c_function(sc, expr, func, 3); + } + return (OPT_F); + } + } + } + + if ((is_semisafe(func)) && + (is_symbol(car(expr))) && + (car(expr) != sc->values_symbol) && + (is_fxable(sc, arg2)) && + (is_fxable(sc, arg3)) && + (is_pair(arg1)) && (car(arg1) == sc->lambda_symbol)) { + choose_c_function(sc, expr, func, 3); + if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && (is_proper_list_2(sc, cadr(arg1))) && /* two parameters */ + (!is_possibly_constant(caadr(arg1))) && /* parameter name not trouble */ + (!is_possibly_constant(cadadr(arg1)))) { + s7_pointer p; + fx_annotate_args(sc, cddr(expr), e); + check_lambda(sc, arg1, true); /* this changes symbol_list */ + + clear_symbol_list(sc); /* so restore it */ + for (p = e; is_pair(p); p = cdr(p)) + if (is_normal_symbol(car(p))) + add_symbol_to_list(sc, car(p)); + + set_fn(expr, + (fn_proc(expr) == + g_for_each) ? g_for_each_closure_2 : NULL); + set_opt3_pair(expr, cdr(arg1)); + set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FAA); + return (OPT_F); + } + } + + if ((is_safe_procedure(func)) || + ((is_semisafe(func)) && (((car(expr) != sc->assoc_symbol) + && (car(expr) != sc->member_symbol)) + || (unsafe_is_safe(sc, arg3, e))))) + return (set_any_c_np + (sc, func, expr, e, 3, hop + OP_SAFE_C_3P)); + return (set_any_c_np(sc, func, expr, e, 3, hop + OP_ANY_C_NP)); + } + + /* not c func */ + if (is_closure(func)) { + int32_t arit; + + arit = closure_arity_to_int(sc, func); + if (arit != 3) { + if ((arit == -1) && (is_symbol(closure_args(func)))) + return (optimize_closure_dotted_args + (sc, expr, func, hop, 3, e)); + return (OPT_F); + } + if (is_immutable(func)) + hop = 1; + + if (symbols == 3) { + s7_pointer body = closure_body(func); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), int_three); + + if (is_safe_closure(func)) { + if ((is_null(cdr(body))) && (is_fxable(sc, car(body)))) { + set_opt2_sym(expr, arg2); + set_opt3_sym(expr, arg3); + fx_annotate_arg(sc, body, e); + fx_tree(sc, body, car(closure_args(func)), + cadr(closure_args(func)), + caddr(closure_args(func)), false); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S_A); + set_closure_one_form_fx_arg(func); + } else + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S); + return (OPT_T); + } + set_unsafe_optimize_op(expr, hop + OP_CLOSURE_3S); + return (OPT_F); + } + + if (fx_count(sc, expr) == 3) { + if (is_safe_closure(func)) { + if ((!is_pair(arg2)) && (!is_pair(arg3))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AGG); + else if (is_normal_symbol(arg1)) + set_optimize_op(expr, + hop + + ((is_normal_symbol(arg2)) ? + OP_SAFE_CLOSURE_SSA : + OP_SAFE_CLOSURE_SAA)); + else + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3A); + } else + if ((is_normal_symbol(arg2)) && (is_normal_symbol(arg3))) + set_optimize_op(expr, hop + OP_CLOSURE_ASS); + else if (is_normal_symbol(arg1)) + set_optimize_op(expr, + hop + + ((is_normal_symbol(arg3)) ? OP_CLOSURE_SAS + : OP_CLOSURE_SAA)); + else if (is_normal_symbol(arg3)) + set_optimize_op(expr, hop + OP_CLOSURE_AAS); + else if (is_normal_symbol(arg2)) + set_optimize_op(expr, hop + OP_CLOSURE_ASA); + else + set_optimize_op(expr, hop + OP_CLOSURE_3A); + set_unsafely_optimized(expr); + fx_annotate_args(sc, cdr(expr), e); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), int_three); + return (OPT_F); + } + return (set_any_closure_np + (sc, func, expr, e, 3, hop + OP_ANY_CLOSURE_3P)); + } + + if (is_closure_star(func)) { + if ((!lambda_has_simple_defaults(func)) || + (closure_star_arity_to_int(sc, func) == 0) || + (closure_star_arity_to_int(sc, func) == 1)) + return (OPT_F); + if (fx_count(sc, expr) == 3) { + if (is_immutable(func)) + hop = 1; + if ((is_safe_closure(func)) + && (closure_star_arity_to_int(sc, func) == 3)) + set_optimize_op(expr, OP_SAFE_CLOSURE_STAR_3A); + else + set_unsafe_optimize_op(expr, + hop + + ((is_safe_closure(func) ? + OP_SAFE_CLOSURE_STAR_NA : + OP_CLOSURE_STAR_NA))); + fx_annotate_args(sc, cdr(expr), e); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), int_three); + return (OPT_F); + } + } + + if ((is_c_function_star(func)) && + (fx_count(sc, expr) == 3) && (c_function_all_args(func) >= 2)) { + set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_NA); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), int_three); + set_c_function(expr, func); + return (OPT_T); + } + /* implicit_vector_3a doesn't happen */ + + if (bad_pairs > quotes) + return (OPT_F); + return ((is_optimized(expr)) ? OPT_T : OPT_F); +} + +static bool symbols_are_safe(s7_scheme * sc, s7_pointer args, s7_pointer e) +{ + s7_pointer p; + for (p = args; is_pair(p); p = cdr(p)) { + s7_pointer arg; + arg = car(p); + if ((is_normal_symbol(arg)) && (!arg_findable(sc, arg, e))) + return (false); + } + return (true); +} + +static opt_t optimize_func_many_args(s7_scheme * sc, s7_pointer expr, + s7_pointer func, int32_t hop, + int32_t args, int32_t pairs, + int32_t symbols, int32_t quotes, + int32_t bad_pairs, s7_pointer e) +{ + bool func_is_closure; + if (quotes > 0) { + if (direct_memq(sc->quote_symbol, e)) + return (OPT_OOPS); + if ((bad_pairs == quotes) && + (is_symbol(car(expr))) && (is_constant_symbol(sc, car(expr)))) + hop = 1; + } + + if ((is_c_function(func)) && + (c_function_required_args(func) <= args) && + (c_function_all_args(func) >= args)) { + if ((hop == 0) + && ((is_immutable(func)) + || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) + hop = 1; + if (is_safe_procedure(func)) { + if (pairs == 0) { + if (symbols == 0) { + set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); + choose_c_function(sc, expr, func, args); + return (OPT_T); + } + if (symbols == args) { + if (symbols_are_safe(sc, cdr(expr), e)) + set_safe_optimize_op(expr, hop + OP_SAFE_C_NS); + else { + set_safe_optimize_op(expr, + hop + + ((args == + 4) ? OP_SAFE_C_4A : + OP_SAFE_C_NA)); + fx_annotate_args(sc, cdr(expr), e); + } + set_opt3_arglen(cdr(expr), + make_permanent_integer(args)); + choose_c_function(sc, expr, func, args); + return (OPT_T); + } + } + + if (fx_count(sc, expr) == args) { + s7_pointer p; + set_optimized(expr); + set_optimize_op(expr, + hop + + ((args == + 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA)); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), make_permanent_integer(args)); + choose_c_function(sc, expr, func, args); + + for (p = cdr(expr); (is_pair(p)) && (is_pair(cdr(p))); + p = cddr(p)) { + if (is_normal_symbol(car(p))) + break; + if ((is_pair(car(p))) && ((!is_pair(cdar(p))) + || (caar(p) != + sc->quote_symbol))) + break; + } + if (is_null(p)) { + set_optimize_op(expr, hop + OP_SAFE_C_ALL_CA); + for (p = cdr(expr); is_pair(p); p = cddr(p)) { + clear_has_fx(p); + set_opt2_con(p, + (is_pair(car(p))) ? cadar(p) : + car(p)); + } + } + return (OPT_T); + } + return (set_any_c_np + (sc, func, expr, e, args, hop + OP_ANY_C_NP)); + } else { /* c_func is not safe */ + if (fx_count(sc, expr) == args) { /* trigger_size doesn't matter for unsafe funcs */ + set_unsafe_optimize_op(expr, + hop + + ((is_semisafe(func)) ? OP_CL_NA : + OP_C_NA)); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), make_permanent_integer(args)); + choose_c_function(sc, expr, func, args); + return (OPT_F); + } + return (set_any_c_np(sc, func, expr, e, args, hop + OP_ANY_C_NP)); /* was num_args=3! 2-Sep-20 */ + } + return ((is_optimized(expr)) ? OPT_T : OPT_F); + } + + func_is_closure = is_closure(func); + if (func_is_closure) { + int32_t arit; + + arit = closure_arity_to_int(sc, func); + if (arit != args) { + if ((arit == -1) && (is_symbol(closure_args(func)))) + return (optimize_closure_dotted_args + (sc, expr, func, hop, args, e)); + return (OPT_F); + } + if (is_immutable(func)) + hop = 1; + + if (fx_count(sc, expr) == args) { + bool safe_case = is_safe_closure(func); + set_unsafely_optimized(expr); + set_unsafe_optimize_op(expr, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_NA + : ((args == + 4) ? OP_CLOSURE_4A : + OP_CLOSURE_NA))); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), make_permanent_integer(args)); + set_opt1_lambda_add(expr, func); + + if ((symbols == args) && (symbols_are_safe(sc, cdr(expr), e))) { + if (safe_case) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_NS); + else + set_optimize_op(expr, + hop + + ((args == + 4) ? OP_CLOSURE_4S : OP_CLOSURE_NS)); + } + return (OPT_F); + } + if (args == 4) + return (set_any_closure_np + (sc, func, expr, e, 4, hop + OP_ANY_CLOSURE_4P)); + return (set_any_closure_np + (sc, func, expr, e, args, hop + OP_ANY_CLOSURE_NP)); + } + + if ((is_closure_star(func)) && + ((!lambda_has_simple_defaults(func)) || + (closure_star_arity_to_int(sc, func) == 0) || + (closure_star_arity_to_int(sc, func) == 1))) + return (OPT_F); + + if ((is_c_function_star(func)) && + (fx_count(sc, expr) == args) && + (c_function_all_args(func) >= (args / 2))) { + if (is_immutable(func)) + hop = 1; + set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_NA); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), make_permanent_integer(args)); + set_c_function(expr, func); + return (OPT_T); + } + if (((func_is_closure) || + (is_closure_star(func))) && (fx_count(sc, expr) == args)) { + set_unsafely_optimized(expr); + if (func_is_closure) + set_optimize_op(expr, + hop + + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_NA + : ((args == + 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA))); + else + set_optimize_op(expr, + hop + + ((is_safe_closure(func)) ? + OP_SAFE_CLOSURE_STAR_NA : + OP_CLOSURE_STAR_NA)); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), make_permanent_integer(args)); + set_opt1_lambda_add(expr, func); + return (OPT_F); + } + return ((is_optimized(expr)) ? OPT_T : OPT_F); +} + +static bool vars_syntax_ok(s7_pointer vars) +{ + s7_pointer p; + for (p = vars; is_pair(p); p = cdr(p)) { + s7_pointer var; + var = car(p); + if ((!is_pair(var)) || + (!is_symbol(car(var))) || (!is_pair(cdr(var)))) + return (false); + } + return (true); +} + +static opt_t optimize_expression(s7_scheme * sc, s7_pointer expr, + int32_t hop, s7_pointer e, + bool export_ok); + +static bool vars_opt_ok(s7_scheme * sc, s7_pointer vars, int32_t hop, + s7_pointer e) +{ + s7_pointer p; + for (p = vars; is_pair(p); p = cdr(p)) { + s7_pointer init; + init = cadar(p); + if ((is_pair(init)) && + (!is_checked(init)) && + (optimize_expression(sc, init, hop, e, false) == OPT_OOPS)) + return (false); + } + return (true); +} + +static opt_t optimize_syntax(s7_scheme * sc, s7_pointer expr, + s7_pointer func, int32_t hop, s7_pointer e, + bool export_ok) +{ + opcode_t op = (opcode_t) syntax_opcode(func); + s7_pointer p, body = cdr(expr), vars; + bool body_export_ok = true; + + sc->w = e; + switch (op) { + case OP_QUOTE: + case OP_MACROEXPAND: + return ((is_proper_list_1(sc, body)) ? OPT_F : OPT_OOPS); + + case OP_LET: + case OP_LETREC: + case OP_LET_STAR: + case OP_LETREC_STAR: + if (is_symbol(cadr(expr))) { + if (!is_pair(cddr(expr))) /* (let name . x) */ + return (OPT_F); + vars = caddr(expr); + if (!is_list(vars)) + return (OPT_OOPS); + body = cdddr(expr); + } else { + vars = cadr(expr); + body = cddr(expr); + if (is_null(vars)) + e = cons(sc, sc->nil, e); /* () in e = empty let */ + else if (!is_pair(vars)) + return (OPT_OOPS); + } + if (!is_pair(body)) + return (OPT_OOPS); + + if (!vars_syntax_ok(vars)) + return (OPT_OOPS); + + if ((op == OP_LETREC) || (op == OP_LETREC_STAR)) { + e = collect_variables(sc, vars, e); + if (!vars_opt_ok(sc, vars, hop, e)) + return (OPT_OOPS); + } else if (op == OP_LET) { + if (!vars_opt_ok(sc, vars, hop, e)) + return (OPT_OOPS); + e = collect_variables(sc, vars, e); + } else + for (p = vars; is_pair(p); p = cdr(p)) { + s7_pointer var = car(p); + if ((is_pair(cadr(var))) && + (!is_checked(cadr(var))) && + (optimize_expression(sc, cadr(var), hop, e, false) == + OPT_OOPS)) + return (OPT_OOPS); + e = cons(sc, add_symbol_to_list(sc, car(var)), e); + sc->w = e; + } + if (is_symbol(cadr(expr))) { + e = cons(sc, add_symbol_to_list(sc, cadr(expr)), e); + sc->w = e; + } + break; + + case OP_LET_TEMPORARILY: + vars = cadr(expr); + if (!is_list(vars)) + return (OPT_OOPS); + body = cddr(expr); + for (p = vars; is_pair(p); p = cdr(p)) { + s7_pointer var = car(vars); + if ((is_pair(var)) && + (is_pair(cdr(var))) && + (is_pair(cadr(var))) && + (!is_checked(cadr(var))) && + (optimize_expression(sc, cadr(var), hop, e, false) == + OPT_OOPS)) + return (OPT_OOPS); + } + /* e = cons(sc, sc->nil, e); *//* !? currently let-temporarily does not make a new let, so it is like begin? */ + body_export_ok = export_ok; /* (list x (let-temporarily () (define x 0))) just as in begin */ + break; + + case OP_DO: + vars = cadr(expr); + if (is_null(vars)) + e = cons(sc, sc->nil, e); + else if (!is_pair(vars)) + return (OPT_OOPS); + body = cddr(expr); + + for (p = vars; is_pair(p); p = cdr(p)) { + s7_pointer var = car(p); + if ((!is_pair(var)) || + (!is_symbol(car(var))) || (!is_pair(cdr(var)))) + return (OPT_OOPS); + if ((is_pair(cadr(var))) && (!is_checked(cadr(var))) && (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) /* the init field -- locals are not defined yet */ + return (OPT_OOPS); + } + e = collect_variables(sc, vars, e); + for (p = vars; is_pair(p); p = cdr(p)) { + s7_pointer var = cddar(p); + if ((is_pair(var)) && (is_pair(car(var))) && (!is_checked(car(var))) && (optimize_expression(sc, car(var), hop, e, false) == OPT_OOPS)) /* the step field -- locals are defined */ + return (OPT_OOPS); + } + break; + + case OP_BEGIN: + body_export_ok = export_ok; /* (list x (begin (define x 0))) */ + break; + + case OP_WITH_BAFFLE: + e = cons(sc, sc->nil, e); + break; + + case OP_DEFINE_BACRO: + case OP_DEFINE_BACRO_STAR: + case OP_BACRO: + case OP_BACRO_STAR: + return (OPT_F); + + case OP_DEFINE_MACRO: + case OP_DEFINE_MACRO_STAR: + case OP_DEFINE_CONSTANT: + case OP_DEFINE_EXPANSION: + case OP_DEFINE_EXPANSION_STAR: + case OP_DEFINE: + case OP_DEFINE_STAR: + /* define adds a name to the incoming let (e), the added name is inserted into e after the first, so the caller + * can flush added symbols by maintaining its own pointer into the list if blockers set the car. + * the list is used both to see local symbols and to catch "complicated" functions (find_uncomplicated_symbol). + * In cases like (if expr (define...)) we can't tell at this level whether the define takes place, so + * its name should not be in "e", but it needs to be marked for find_uncomplicated_symbol in a way + * that can be distinguished from members of "e". So in that (rare) case, we use the associated keyword. + * Then find_uncomplicated_symbol can use has_keyword to tell if the keyword search is needed. + * export_ok is trying to protect against optimizing (list x (define x 0)) as op_safe_c_sp and all related cases + */ + vars = cadr(expr); + body = cddr(expr); + if (is_pair(vars)) { + if ((export_ok) && (is_symbol(car(vars)))) { + add_symbol_to_list(sc, car(vars)); + if (is_pair(e)) { + if (car(e) != sc->key_if_symbol) + set_cdr(e, cons(sc, car(vars), cdr(e))); /* export it */ + else + add_symbol_to_list(sc, + symbol_to_keyword(sc, + car(vars))); + } else + e = cons(sc, car(vars), e); + } + e = collect_parameters(sc, cdr(vars), e); + body_export_ok = export_ok; + } else { + if ((export_ok) && (is_symbol(vars))) { + /* actually if this is defining a function, the name should probably be included in the local let + * but that's next-to-impossible to guarantee unless it's (define x (lambda...)) of course. + */ + sc->temp9 = e; + for (p = body; is_pair(p); p = cdr(p)) + if ((is_pair(car(p))) && (!is_checked(car(p))) && /* ((full_type(p) & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */ + (optimize_expression(sc, car(p), hop, e, false) == OPT_OOPS)) /* "body" here is not body in terms of export_ok */ + return (OPT_OOPS); + sc->temp9 = sc->nil; + + add_symbol_to_list(sc, vars); + if (is_pair(e)) { + if (car(e) != sc->key_if_symbol) + set_cdr(e, cons(sc, vars, cdr(e))); /* export it */ + else + add_symbol_to_list(sc, + symbol_to_keyword(sc, vars)); + } + /* else e = cons(sc, vars, e); *//* ?? should this be set-cdr etc? */ + return (OPT_F); + } + body_export_ok = false; + } + break; + + case OP_LAMBDA: + case OP_LAMBDA_STAR: + case OP_MACRO: + case OP_MACRO_STAR: + vars = cadr(expr); + if (is_null(vars)) + e = cons(sc, sc->nil, e); + else if ((!is_pair(vars)) && (!is_symbol(vars))) + return (OPT_OOPS); + e = collect_parameters(sc, vars, e); + body = cddr(expr); + break; + + case OP_SET: + if ((is_pair(cadr(expr))) && (caadr(expr) == sc->outlet_symbol)) + return (OPT_OOPS); + + if (!is_pair(cddr(expr))) + return (OPT_OOPS); + + if ((is_pair(cadr(expr))) && (!is_checked(cadr(expr)))) { + s7_pointer lp; + set_checked(cadr(expr)); + for (lp = cdadr(expr); is_pair(lp); lp = cdr(lp)) + if ((is_pair(car(lp))) && + (!is_checked(car(lp))) && + (optimize_expression + (sc, car(lp), hop, e, body_export_ok) == OPT_OOPS)) + return (OPT_OOPS); + } + + if ((is_pair(caddr(expr))) && + (!is_checked(caddr(expr))) && + (optimize_expression(sc, caddr(expr), hop, e, body_export_ok) + == OPT_OOPS)) + return (OPT_OOPS); + return (OPT_F); + + case OP_WITH_LET: + /* we usually can't trust anything here, so hop ought to be off. For example, + * (define (hi) (let ((e (sublet (curlet) :abs (lambda (a) (- a 1))))) (with-let e (abs -1)))) + * returns 1 if hop is 1, but -2 otherwise. (with-let (unlet)...) is safe however. + */ + { + bool old_with_let = sc->in_with_let; + sc->in_with_let = (old_with_let) || (!is_pair(body)) + || (!is_pair(car(body))) + || ((caar(body) != sc->unlet_symbol) + && (caar(body) != sc->rootlet_symbol) + && (caar(body) != sc->curlet_symbol)); + for (p = body; is_pair(p); p = cdr(p)) + if ((is_pair(car(p))) && + (!is_checked(car(p))) && + (optimize_expression + (sc, car(p), 0, sc->nil, + body_export_ok) == OPT_OOPS)) { + sc->in_with_let = old_with_let; + return (OPT_OOPS); + } + sc->in_with_let = old_with_let; + return (OPT_F); + } + + case OP_CASE: + if ((is_pair(cadr(expr))) && + (!is_checked(cadr(expr))) && + (optimize_expression(sc, cadr(expr), hop, e, false) == + OPT_OOPS)) + return (OPT_OOPS); + for (p = cddr(expr); is_pair(p); p = cdr(p)) + if ((is_pair(car(p))) && (is_pair(cdar(p)))) { + s7_pointer rst; + for (rst = cdar(p); is_pair(rst); rst = cdr(rst)) + if ((is_pair(car(rst))) && + (!is_checked(car(rst))) && + (optimize_expression(sc, car(rst), hop, e, false) + == OPT_OOPS)) + return (OPT_OOPS); + } + return (OPT_F); + + case OP_COND: /* split opt is necessary: (cond (lambda (x) ...)) */ + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (is_pair(car(p))) { + s7_pointer test = caar(p), rst; + e = cons(sc, sc->key_if_symbol, e); /* I think this is a marker in case define is encountered? (see above) */ + if ((is_pair(test)) && + (!is_checked(test)) && + (optimize_expression(sc, test, hop, e, false) == + OPT_OOPS)) + return (OPT_OOPS); + for (rst = cdar(p); is_pair(rst); rst = cdr(rst)) + if ((is_pair(car(rst))) && + (!is_checked(car(rst))) && + (optimize_expression(sc, car(rst), hop, e, false) + == OPT_OOPS)) + return (OPT_OOPS); + } + for (p = cdr(expr); is_pair(p); p = cdr(p)) { + s7_pointer q; + if ((!is_pair(car(p))) || (!is_fxable(sc, caar(p)))) + break; + if (!is_pair(cdar(p))) + break; + for (q = cdar(p); is_pair(q); q = cdr(q)) + if ((car(q) == sc->feed_to_symbol) + || (!is_fxable(sc, car(q)))) + break; + if (!is_null(q)) + break; + } + if (!is_null(p)) + return (OPT_F); + set_safe_optimize_op(expr, OP_COND_FX_FX); + for (p = cdr(expr); is_pair(p); p = cdr(p)) { + s7_pointer q; + set_fx_direct(car(p), + fx_choose(sc, car(p), e, pair_symbol_is_safe)); + for (q = cdar(p); is_pair(q); q = cdr(q)) + set_fx_direct(q, fx_choose(sc, q, e, pair_symbol_is_safe)); + } + return (OPT_T); + + case OP_IF: + case OP_WHEN: + case OP_UNLESS: + if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) + return (OPT_OOPS); + case OP_OR: + case OP_AND: + e = cons(sc, sc->key_if_symbol, e); + break; + + default: + break; + } + + sc->temp9 = e; + for (p = body; is_pair(p); p = cdr(p)) + if ((is_pair(car(p))) && (!is_checked(car(p))) && /* ((full_type(p) & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */ + (optimize_expression(sc, car(p), hop, e, body_export_ok) == + OPT_OOPS)) { + sc->temp9 = sc->nil; + return (OPT_OOPS); + } + sc->temp9 = sc->nil; + + if ((hop == 1) && + ((is_syntax(car(expr))) || (symbol_id(car(expr)) == 0))) { + if (op == OP_IF) { + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + break; + + if (is_null(p)) { + s7_pointer test = cdr(expr), b1, b2; + if ((is_pair(cdr(test))) && (is_pair(cddr(test))) + && (!is_null(cdddr(test)))) + return (OPT_OOPS); + + for (p = cdr(expr); is_pair(p); p = cdr(p)) + set_fx_direct(p, + fx_choose(sc, p, e, + pair_symbol_is_safe)); + + b1 = cdr(test); + b2 = cdr(b1); + if ((fx_proc(b1) == fx_q) && (is_pair(b2))) { + set_opt3_con(test, cadar(b1)); + if (fx_proc(b2) == fx_q) { + set_safe_optimize_op(expr, OP_IF_A_C_C); + set_opt1_con(expr, cadar(b1)); + set_opt2_con(expr, cadar(b2)); + return (OPT_T); + } + set_opt1_pair(expr, b1); + set_opt2_pair(expr, b2); + set_safe_optimize_op(expr, OP_IF_A_A_A); + } else { + if ((is_pair(car(test))) && + (caar(test) == sc->not_symbol) && + (is_fxable(sc, cadar(test)))) { + set_fx_direct(cdar(test), + fx_choose(sc, cdar(test), e, + pair_symbol_is_safe)); + set_opt1_pair(expr, cdar(test)); + set_opt2_pair(expr, b1); + if (is_pair(b2)) + set_opt3_pair(expr, b2); + set_safe_optimize_op(expr, + (is_null(b2)) ? OP_IF_NOT_A_A + : OP_IF_NOT_A_A_A); + } else { + if ((is_pair(b2)) && (fx_proc(b1) == fx_c) + && (fx_proc(b2) == fx_c)) { + set_safe_optimize_op(expr, OP_IF_A_C_C); + set_opt1_con(expr, car(b1)); + set_opt2_con(expr, car(b2)); + return (OPT_T); + } + if ((fx_proc(test) == fx_and_2a) + && (fx_proc(b1) == fx_s)) { + set_opt1_pair(expr, cdadr(expr)); + set_opt2_pair(expr, cddadr(expr)); + set_opt3_sym(expr, car(b1)); + set_safe_optimize_op(expr, OP_IF_AND2_S_A); + return (OPT_T); + } + set_opt1_pair(expr, b1); + if (is_pair(b2)) + set_opt2_pair(expr, b2); + set_safe_optimize_op(expr, + (is_null(b2)) ? OP_IF_A_A + : ((fx_proc(test) == + fx_s) ? OP_IF_S_A_A : + OP_IF_A_A_A)); + } + } + return (OPT_T); + } + } else { + if ((op == OP_OR) || (op == OP_AND)) { + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + break; + + if (is_null(p)) { /* catch the syntax error later: (or #f . 2) etc */ + int32_t args, pairs = 0; + s7_pointer sym = NULL; + bool c_s_is_ok = true; + + for (args = 0, p = cdr(expr); is_pair(p); p = cdr(p), args++) /* this only applies to or/and */ + if (is_pair(car(p))) { + pairs++; + if ((c_s_is_ok) && + ((!is_h_safe_c_s(car(p))) || + ((sym) && (sym != cadar(p))))) + c_s_is_ok = false; + else + sym = + (is_pair(cdar(p))) ? cadar(p) : + sc->unspecified; + } + + if ((c_s_is_ok) && (args == 2) && (pairs == 2)) { + if (op == OP_OR) { + set_opt3_sym(cdr(expr), cadadr(expr)); + if ((is_symbol(caadr(expr))) + && (symbol_type(caadr(expr)) > 0) + && (is_global(caadr(expr))) + && ((is_symbol(caaddr(expr))) + && (symbol_type(caaddr(expr)) > 0) + && (is_global(caaddr(expr))))) { + set_opt3_int(expr, + small_int(symbol_type + (caadr(expr)))); + set_opt2_int(cdr(expr), + small_int(symbol_type + (caaddr(expr)))); + set_safe_optimize_op(expr, OP_OR_S_TYPE_2); + } else + set_safe_optimize_op(expr, OP_OR_S_2); + } else { + set_opt3_sym(cdr(expr), cadadr(expr)); + set_safe_optimize_op(expr, OP_AND_S_2); + } + return (OPT_T); + } + + for (p = cdr(expr); is_pair(p); p = cdr(p)) + set_fx_direct(p, + fx_choose(sc, p, e, + pair_symbol_is_safe)); + if (op == OP_OR) { + if (args == 2) + set_safe_optimize_op(expr, OP_OR_2A); + else { + if (args == 3) + set_safe_optimize_op(expr, OP_OR_3A); + else + set_safe_optimize_op(expr, OP_OR_N); + } + return (OPT_T); + } + if (args == 2) + set_safe_optimize_op(expr, OP_AND_2A); + else if (args == 3) + set_safe_optimize_op(expr, OP_AND_3A); + else + set_safe_optimize_op(expr, OP_AND_N); + return (OPT_T); + } + } else if (op == OP_BEGIN) { + if (!is_pair(cdr(expr))) + return (OPT_F); + + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + break; + if (is_null(p)) { + for (p = cdr(expr); is_pair(p); p = cdr(p)) + set_fx_direct(p, + fx_choose(sc, p, e, + pair_symbol_is_safe)); + + if ((is_pair(cddr(expr))) && (is_null(cdddr(expr)))) + set_safe_optimize_op(expr, OP_BEGIN_AA); + else + set_safe_optimize_op(expr, OP_BEGIN_NA); + return (OPT_T); + } + } + } + } /* fully fxable lets don't happen much: even op_let_2a_a is scarcely used */ + return (OPT_F); +} + + +static opt_t optimize_funcs(s7_scheme * sc, s7_pointer expr, + s7_pointer func, int32_t hop, int32_t orig_hop, + s7_pointer e) +{ + int32_t pairs = 0, symbols = 0, args = 0, bad_pairs = 0, quotes = 0; + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cdr(p), args++) { /* check the args (the calling expression) */ + s7_pointer car_p = car(p); + if (is_normal_symbol(car_p)) /* for opt func */ + symbols++; + else if (is_pair(car_p)) { + pairs++; + if (!is_checked(car_p)) { + opt_t res; + res = optimize_expression(sc, car_p, orig_hop, e, false); + if (res == OPT_F) { + bad_pairs++; + if (is_proper_quote(sc, car_p)) + quotes++; + } else if (res == OPT_OOPS) + return (OPT_OOPS); + } else if ((!is_optimized(car_p)) || (is_unsafe(car_p))) { + bad_pairs++; + if (is_proper_quote(sc, car_p)) + quotes++; + } + } + } + if (is_null(p)) { /* if not null, dotted list of args? */ + switch (args) { + case 0: + return (optimize_thunk(sc, expr, func, hop, e)); + case 1: + return (optimize_func_one_arg + (sc, expr, func, hop, pairs, symbols, quotes, + bad_pairs, e)); + case 2: + return (optimize_func_two_args + (sc, expr, func, hop, pairs, symbols, quotes, + bad_pairs, e)); + case 3: + return (optimize_func_three_args + (sc, expr, func, hop, pairs, symbols, quotes, + bad_pairs, e)); + default: + return (optimize_func_many_args + (sc, expr, func, hop, args, pairs, symbols, quotes, + bad_pairs, e)); + } + } + return (OPT_F); +} + +static opt_t optimize_expression(s7_scheme * sc, s7_pointer expr, + int32_t hop, s7_pointer e, bool export_ok) +{ + s7_pointer car_expr = car(expr); + int32_t orig_hop = hop; + set_checked(expr); + + if (is_symbol(car_expr)) { + s7_pointer slot; + if (is_syntactic_symbol(car_expr)) { + if (!is_pair(cdr(expr))) + return (OPT_OOPS); + return (optimize_syntax + (sc, expr, T_Syn(global_value(car_expr)), hop, e, + export_ok)); + } + slot = find_uncomplicated_symbol(sc, car_expr, e); /* local vars (recursive calls too??) are considered "complicated" */ + if (is_slot(slot)) { + s7_pointer func = slot_value(slot); + if (is_syntax(func)) /* 12-8-16 was is_syntactic, but that is only appropriate above -- here we have the value */ + return ((is_pair(cdr(expr))) ? optimize_syntax(sc, expr, func, hop, e, export_ok) : OPT_OOPS); /* e can be extended via set-cdr! here */ + + if (is_any_macro(func)) + return (OPT_F); + + /* we miss implicit indexing here because at this time, the data are not set */ + if ((is_t_procedure(func)) || /* t_procedure_p: c_funcs, closures, etc */ + /* (is_any_closure(func)) || *//* added 11-Mar-20, but it's redundant!? */ + ((is_applicable(func)) && (is_safe_procedure(func)))) { /* built-in applicable objects like vectors */ + if ((hop != 0) && ((is_any_closure(func)) || /* see use-redef in s7test -- I'm not sure about this */ + ((!is_global(car_expr)) && ((!is_slot(global_slot(car_expr))) || (global_value(car_expr) != func)))) && (!is_immutable(car_expr)) && /* list|apply-values -- can't depend on opt1 here because it might not be global, or might be redefined locally */ + (!is_immutable(slot))) { /* (define-constant...) */ + /* (let () (define (f2 a) (+ a 1)) (define (f1 a) (f2 a)) (define (f2 a) (- a)) (f1 12)) + * (let () (define (f2 a) (+ a 1)) (define (f1 a) (f2 a)) (define (f2 a) (- a 1)) (f1 12)) + * and similar define* cases + */ + hop = 0; + /* this is very tricky! See s7test for some cases. Basically, we need to protect a recursive call + * of the current function being optimized from being confused with some previous definition + * of the same name. But method lists have global names so the global bit is off even though the + * thing is actually a safe global. But no closure can be considered safe in the hop sense -- + * even a global function might be redefined at any time, and previous uses of it in other functions + * need to reflect its new value. + * So, closures are always checked, but built-in functions are used as if never redefined until that redefinition. + * Syntax handling is already impure in s7, so the special handling of built-in functions doesn't + * offend me much. Consider each a sort of reader macro until someone redefines it -- previous + * uses might not be affected because they might have been optimized away -- the result depends on the + * current optimizer. + * Another case (from K Matheussen): + * (define (call-func func arg1 arg2) (define (call) (func arg1 arg2)) (call)) (call-func + 1 2.5) (call-func - 5 2) + * when we get here originally "func" is +, hop=1, but just checking for !is_global(car_expr) is + * not good enough -- if we load mockery.scm, nothing is global! + * Yet another case (define (test-abs) (define (abs x) (+ x 1)) (format *stderr* "abs ~A~%" (abs -1))) + * when optimize_syntax sees the (define abs ...), it inserts abs into e so that the caller's e is extended (set-cdr!) + * so that find_uncomplicated_symbol above will be unhappy when we reach (abs -1) as the format arg. + * This can be confused if lambda is redefined at some point, but... + */ + } + return (optimize_funcs(sc, expr, func, hop, orig_hop, e)); + } + } else if ((sc->undefined_identifier_warnings) && (slot == sc->undefined) && /* car_expr is not in e or global */ + (symbol_tag(car_expr) == 0)) { /* and we haven't looked it up earlier */ + s7_pointer p = current_input_port(sc); + if ((is_input_port(p)) && + (port_file(p) != stdin) && + (!port_is_closed(p)) && (port_filename(p))) + s7_warn(sc, 1024, "%s might be undefined (%s %u)\n", + display(car_expr), port_filename(p), + port_line_number(p)); + else + s7_warn(sc, 1024, "; %s might be undefined\n", + display(car_expr)); + symbol_set_tag(car_expr, 1); /* one warning is enough */ + } + + /* car_expr is a symbol but it's not a built-in procedure or a "safe" case = vector etc */ + { + /* else maybe it's something like a let variable binding: (sqrtfreq (sqrt frequency)) */ + s7_pointer p; + int32_t len = 0, pairs = 0, symbols = 0; + + for (p = cdr(expr); is_pair(p); p = cdr(p), len++) { + s7_pointer car_p; + car_p = car(p); + if (is_pair(car_p)) { + pairs++; + if ((!is_checked(car_p)) && + (optimize_expression(sc, car_p, hop, e, false) == + OPT_OOPS)) + return (OPT_OOPS); + } else if (is_symbol(car_p)) + symbols++; + } + + if ((is_null(p)) && /* (+ 1 . 2) */ + (!is_optimized(expr))) { + /* len=0 case is almost entirely arglists */ + set_opt1_con(expr, sc->unused); + + if (pairs == 0) { + if (len == 0) { + /* hoping to catch object application here, as in readers in Snd */ + set_unsafe_optimize_op(expr, OP_UNKNOWN); + return (OPT_F); + } + + if (len == 1) { + if (car_expr != sc->quote_symbol) /* !! quote can be redefined locally, unsetting the T_SYNTACTIC flag -- can this happen elsewhere? */ + set_unsafe_optimize_op(expr, + (symbols == + 1) ? OP_UNKNOWN_G : + OP_UNKNOWN_A); + fx_annotate_arg(sc, cdr(expr), e); /* g->a later if closure */ + return (OPT_F); + } + + if (len == 2) { + set_unsafely_optimized(expr); + set_optimize_op(expr, OP_UNKNOWN_GG); + return (OPT_F); + } + + if (len >= 3) { + if (len == symbols) { + set_unsafe_optimize_op(expr, OP_UNKNOWN_NS); + set_opt3_arglen(cdr(expr), + make_permanent_integer(len)); + return (OPT_F); + } + if (fx_count(sc, expr) == len) { + set_unsafe_optimize_op(expr, OP_UNKNOWN_NA); + set_opt3_arglen(cdr(expr), + make_permanent_integer(len)); + return (OPT_F); + } + } + } else { /* pairs != 0 */ + s7_pointer arg1 = cadr(expr); + if ((pairs == 1) && (len == 1)) { + if ((car_expr == sc->quote_symbol) && + (direct_memq(sc->quote_symbol, e))) + return (OPT_OOPS); + + if (is_fxable(sc, arg1)) { + set_opt3_arglen(cdr(expr), int_one); + fx_annotate_arg(sc, cdr(expr), e); + set_unsafe_optimize_op(expr, OP_UNKNOWN_A); + return (OPT_F); + } + } + if (fx_count(sc, expr) == len) { + set_unsafe_optimize_op(expr, + (len == + 1) ? OP_UNKNOWN_A : ((len + == + 2) ? + OP_UNKNOWN_AA + : + OP_UNKNOWN_NA)); + set_opt3_arglen(cdr(expr), + make_permanent_integer(len)); + if (len <= 2) + fx_annotate_args(sc, cdr(expr), e); + return (OPT_F); + } + set_unsafe_optimize_op(expr, OP_UNKNOWN_NP); + set_opt3_arglen(cdr(expr), + make_permanent_integer(len)); + return (OPT_F); + } + } + } + } else { + /* car(expr) is not a symbol, but there might be interesting stuff here */ + /* (define (hi a) (case 1 ((1) (if (> a 2) a 2)))) */ + s7_pointer p; + + if (is_c_function(car_expr)) /* (#_abs x) etc */ + return (optimize_funcs(sc, expr, car_expr, 1, orig_hop, e)); + + if (is_syntax(car_expr)) { /* (#_cond ...) */ + if (!is_pair(cdr(expr))) + return (OPT_OOPS); + return (optimize_syntax + (sc, expr, car_expr, orig_hop, e, export_ok)); + } + if (is_any_macro(car_expr)) + return (OPT_F); + + /* if car is a pair, we can't easily tell whether its value is (say) + or cond, so we need to catch this case and fixup fx settings */ + for (p = expr; is_pair(p); p = cdr(p)) + if ((is_pair(car(p))) && + (!is_checked(car(p))) && + (optimize_expression(sc, car(p), hop, e, false) == + OPT_OOPS)) + return (OPT_OOPS); + /* here we get for example: + * ((if (not (let? p)) write write-to-vector) obj p) ; not uncomplicated/c-function [((if 3d fourth third) p) in index] + * ((if (symbol? (cadr f)) cadr (if (pair? (cadr f)) caadr not)) f) ; fx not symbol -- opif_a_aaq_a + * ((if (input-port? port) call-with-input-file call-with-output-file) port proc) ; not safe I guess + */ + } + return (OPT_F); +} + +static opt_t optimize(s7_scheme * sc, s7_pointer code, int32_t hop, + s7_pointer e) +{ + s7_pointer x; + for (x = code; (is_pair(x)) && (!is_checked(x)); x = cdr(x)) { + s7_pointer obj = car(x); + set_checked(x); + if (is_pair(obj)) { + if ((!is_checked(obj)) && + (optimize_expression(sc, obj, hop, e, true) == OPT_OOPS)) { + s7_pointer p; + for (p = cdr(x); is_pair(p); p = cdr(p)); + if (!is_null(p)) + eval_error(sc, "stray dot in function body: ~S", 30, + code); + return (OPT_OOPS); + } + } else + /* new 22-Sep-19, but I don't think this saves anything over falling into trailers */ + if (is_symbol(obj)) + set_optimize_op(obj, + (is_keyword(obj)) ? OP_CON : ((is_global(obj)) + ? OP_GLOBAL_SYM : + OP_SYM)); + else + set_optimize_op(obj, OP_CON); + } + if (!is_list(x)) + eval_error(sc, "stray dot in function body: ~S", 30, code); + return (OPT_F); +} + + +static bool symbol_is_in_arg_list(s7_pointer sym, s7_pointer lst) +{ + s7_pointer x; + for (x = lst; is_pair(x); x = cdr(x)) + if ((sym == car(x)) || ((is_pair(car(x))) && (sym == caar(x)))) + return (true); + return (sym == x); +} + +static void check_lambda_args(s7_scheme * sc, s7_pointer args, + int32_t * arity) +{ + s7_pointer x; + int32_t i; + + if (!is_list(args)) { + if (is_constant(sc, args)) /* (lambda :a ...) */ + eval_error(sc, "lambda parameter '~S is a constant", 34, args); /* not ~A here, (lambda #\null do) for example */ + + /* we currently accept (lambda i i . i) (lambda quote i) (lambda : : . #()) (lambda : 1 . "") + * at this level, but when the lambda form is evaluated, it will trigger an error. + */ + if (is_symbol(args)) + set_local(args); + + if (arity) + (*arity) = -1; + return; + } + + for (i = 0, x = args; is_pair(x); i++, x = cdr(x)) { + s7_pointer car_x = car(x); + if (is_constant(sc, car_x)) { /* (lambda (pi) pi), constant here means not a symbol */ + if (is_pair(car_x)) /* (lambda ((:hi . "hi") . "hi") 1) */ + eval_error(sc, + "lambda parameter '~S is a pair (perhaps you want define* or lambda*?)", + 69, car_x); + eval_error(sc, "lambda parameter '~S is a constant", 34, + car_x); + } + if (symbol_is_in_arg_list(car_x, cdr(x))) /* (lambda (a a) ...) or (lambda (a . a) ...) */ + eval_error(sc, + "lambda parameter '~S is used twice in the parameter list", + 56, car_x); + set_local(car_x); + } + if (is_not_null(x)) { + if (is_constant(sc, x)) /* (lambda (a . 0.0) a) or (lambda (a . :b) a) */ + eval_error(sc, "lambda :rest parameter '~S is a constant", 40, + x); + i = -i - 1; + } + + if (arity) + (*arity) = i; +} + +static s7_pointer check_lambda_star_args(s7_scheme * sc, s7_pointer args, + s7_pointer body) +{ /* checks closure*, macro*, and bacro* */ + s7_pointer top, v, w; + int32_t i; + bool has_defaults; + + if (!is_list(args)) { + if (is_constant(sc, args)) /* (lambda* :a ...) */ + eval_error(sc, "lambda* parameter '~S is a constant", 35, + args); + if (is_symbol(args)) + set_local(args); + return (args); + } + + has_defaults = false; + top = args; + for (i = 0, v = args, w = args; is_pair(w); i++, v = w, w = cdr(w)) { + s7_pointer car_w = car(w); + if (is_pair(car_w)) { + has_defaults = true; + if (is_constant(sc, car(car_w))) /* (lambda* ((:a 1)) ...) */ + eval_error(sc, "lambda* parameter '~A is a constant", 35, + car(car_w)); + if (symbol_is_in_arg_list(caar(w), cdr(w))) /* (lambda* ((a 1) a) ...) */ + eval_error(sc, + "lambda* parameter '~A is used twice in the argument list", + 56, car(car_w)); + + if (!is_pair(cdr(car_w))) { /* (lambda* ((a . 0.0)) a) */ + if (is_null(cdr(car_w))) /* (lambda* ((a)) ...) */ + eval_error(sc, + "lambda* parameter default value missing? '~A", + 44, car_w); + eval_error(sc, "lambda* parameter is a dotted pair? '~A", + 39, car_w); + } + if ((is_pair(cadr(car_w))) && /* (lambda* ((a (quote . -1))) ...) */ + (s7_list_length(sc, cadr(car_w)) < 0)) + eval_error(sc, + "lambda* parameter default value is improper? ~A", + 47, car_w); + + if (is_not_null(cddr(car_w))) /* (lambda* ((a 0.0 'hi)) a) */ + eval_error(sc, + "lambda* parameter has multiple default values? '~A", + 50, car_w); + + set_local(car(car_w)); + } else { + if (car_w != sc->key_rest_symbol) { + if (is_constant(sc, car_w)) { + if (car_w == sc->key_allow_other_keys_symbol) { + if (is_not_null(cdr(w))) /* (lambda* (:allow-other-keys x) x) */ + eval_error(sc, + ":allow-other-keys should be the last parameter: ~A", + 50, args); + if (w == top) + eval_error(sc, + ":allow-other-keys can't be the only parameter: ~A", + 49, args); + set_allow_other_keys(top); + set_cdr(v, sc->nil); + } else /* (lambda* (pi) ...) */ + eval_error(sc, + "lambda* parameter '~A is a constant", + 35, car_w); + } + if (symbol_is_in_arg_list(car_w, cdr(w))) /* (lambda* (a a) ...) or (lambda* (a . a) ...) */ + eval_error(sc, + "lambda* parameter '~A is used twice in the argument list", + 56, car_w); + + if (!is_keyword(car_w)) + set_local(car_w); + } else { + has_defaults = true; + if (!is_pair(cdr(w))) /* (lambda* (:rest) ...) */ + eval_error(sc, "lambda* :rest parameter missing? ~A", + 35, w); + if (!is_symbol(cadr(w))) { /* (lambda* (:rest (a 1)) ...) */ + if (!is_pair(cadr(w))) /* (lambda* (:rest 1) ...) */ + eval_error(sc, + "lambda* :rest parameter is not a symbol? ~A", + 43, w); + eval_error(sc, + "lambda* :rest parameter can't have a default value. ~A", + 54, w); + } + if (is_constant(sc, cadr(w))) /* (lambda* (a :rest x)...) where x is locally a constant */ + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, cant_bind_immutable_string, + w))); + set_local(cadr(w)); + } + } + } + if (is_not_null(w)) { + if (is_constant(sc, w)) /* (lambda* (a . 0.0) a) or (lambda* (a . :b) a) */ + eval_error(sc, "lambda* :rest parameter '~A is a constant", 41, + w); + if (is_symbol(w)) + set_local(w); + } else if ((body) && (!has_defaults) && (is_pair(args))) + set_has_no_defaults(body); + return (top); +} + +static void set_rec_tc_args(s7_scheme * sc, s7_int args) +{ + if (sc->rec_tc_args == -1) + sc->rec_tc_args = args; + else if (sc->rec_tc_args != args) + sc->rec_tc_args = -2; +} + +typedef enum { UNSAFE_BODY = 0, RECUR_BODY, SAFE_BODY, VERY_SAFE_BODY +} body_t; +static body_t min_body(body_t b1, body_t b2) +{ + return ((b1 < b2) ? b1 : b2); +} + +static body_t body_is_safe(s7_scheme * sc, s7_pointer func, + s7_pointer body, bool at_end); + +static body_t form_is_safe(s7_scheme * sc, s7_pointer func, s7_pointer x, + bool at_end) +{ /* called only from body_is_safe */ + s7_pointer expr = car(x); + body_t result = VERY_SAFE_BODY; + + if (is_symbol_and_syntactic(expr)) { + if (!is_pair(cdr(x))) + return (UNSAFE_BODY); + /* lambda_unchecked, if_d_p_p define_funchecked */ + switch (symbol_syntax_op_checked(x)) { + case OP_OR: + case OP_AND: + case OP_BEGIN: + case OP_WITH_BAFFLE: + return (body_is_safe(sc, func, cdr(x), at_end)); + + case OP_MACROEXPAND: + return (UNSAFE_BODY); + + case OP_QUOTE: + return (((!is_pair(cdr(x))) || (!is_null(cddr(x)))) ? UNSAFE_BODY : VERY_SAFE_BODY); /* (quote . 1) or (quote 1 2) etc */ + + case OP_IF: + if (!is_pair(cddr(x))) + return (UNSAFE_BODY); + if (is_pair(cadr(x))) { + result = form_is_safe(sc, func, cadr(x), false); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } + if (is_pair(caddr(x))) { + result = + min_body(result, + form_is_safe(sc, func, caddr(x), at_end)); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } + if ((is_pair(cdddr(x))) && (is_pair(cadddr(x)))) + return (min_body + (result, + form_is_safe(sc, func, cadddr(x), at_end))); + return (result); + + case OP_WHEN: + case OP_UNLESS: + if (!is_pair(cddr(x))) + return (UNSAFE_BODY); + if (is_pair(cadr(x))) { + result = form_is_safe(sc, func, cadr(x), false); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } + return (min_body + (result, body_is_safe(sc, func, cddr(x), at_end))); + + case OP_COND: + { + bool follow = false; + s7_pointer sp, p; + for (p = cdr(x), sp = x; is_pair(p); p = cdr(p)) { + s7_pointer ex; + ex = car(p); + if (!is_pair(ex)) + return (UNSAFE_BODY); + if (is_pair(car(ex))) { + result = + min_body(result, + form_is_safe(sc, func, car(ex), + false)); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } + if (is_pair(cdr(ex))) { + result = + min_body(result, + body_is_safe(sc, func, cdr(ex), + at_end)); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } + if (follow) { + sp = cdr(sp); + if (p == sp) + return (UNSAFE_BODY); + } + follow = (!follow); + } + return ((is_null(p)) ? result : UNSAFE_BODY); + } + + case OP_CASE: + { + bool follow = false; + s7_pointer sp, p; + if (!is_pair(cddr(x))) + return (UNSAFE_BODY); + if (is_pair(cadr(x))) { + result = form_is_safe(sc, func, cadr(x), false); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } + sp = cdr(x); + p = cdr(sp); + for (; is_pair(p); p = cdr(p)) { + if (!is_pair(car(p))) + return (UNSAFE_BODY); + if (is_pair(cdar(p))) { + result = min_body(result, body_is_safe(sc, func, cdar(p), at_end)); /* null cdar(p) ok here */ + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } + if (follow) { + sp = cdr(sp); + if (p == sp) + return (UNSAFE_BODY); + } + follow = (!follow); + } + return (result); + } + + case OP_SET: + /* if we set func, we have to abandon the tail call scan: (let () (define (hi a) (let ((v (vector 1 2 3))) (set! hi v) (hi a))) (hi 1)) */ + if (!is_pair(cddr(x))) + return (UNSAFE_BODY); + if (cadr(x) == func) + return (UNSAFE_BODY); + + /* car(x) is set!, cadr(x) is settee or obj, caddr(x) is val */ + if (is_pair(caddr(x))) { + result = form_is_safe(sc, func, caddr(x), false); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } + return ((is_pair(cadr(x))) ? + min_body(result, + form_is_safe(sc, func, cadr(x), + false)) : result); + /* not OP_DEFINE even in simple cases (safe_closure assumes constant funclet) */ + + case OP_WITH_LET: + if (!is_pair(cddr(x))) + return (UNSAFE_BODY); + return ((is_pair(cadr(x))) ? UNSAFE_BODY : + min_body(body_is_safe(sc, sc->F, cddr(x), at_end), + SAFE_BODY)); + /* shadowing can happen in with-let -- symbols are global so local_slots are shadowable */ + + case OP_LET_TEMPORARILY: + { + s7_pointer p; + if (!is_pair(cadr(x))) + return (UNSAFE_BODY); + for (p = cadr(x); is_pair(p); p = cdr(p)) { + if ((!is_pair(car(p))) || (!is_pair(cdar(p)))) + return (UNSAFE_BODY); + if (is_pair(cadar(p))) { + result = + min_body(result, + form_is_safe(sc, sc->F, cadar(p), + false)); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } + } + return (min_body + (result, + body_is_safe(sc, sc->F, cddr(x), at_end))); + } + + /* in the name binders, we first have to check that "func" actually is the same thing as the caller's func */ + case OP_LET: + case OP_LET_STAR: + case OP_LETREC: + case OP_LETREC_STAR: + { + bool follow = false; + s7_pointer let_name, sp, vars = cadr(x), body = cddr(x); + if (is_symbol(vars)) { + if (!is_pair(body)) + return (UNSAFE_BODY); /* (let name . res) */ + if (vars == func) /* named let shadows caller */ + return (UNSAFE_BODY); + let_name = vars; + vars = caddr(x); + body = cdddr(x); + if (is_symbol(func)) + add_symbol_to_list(sc, func); + } else + let_name = func; + + for (sp = NULL; is_pair(vars); vars = cdr(vars)) { + s7_pointer let_var = car(vars), var_name; + + if ((!is_pair(let_var)) || (!is_pair(cdr(let_var)))) + return (UNSAFE_BODY); + var_name = car(let_var); + if ((!is_symbol(var_name)) || (var_name == let_name) || /* let var shadows caller */ + (var_name == func)) + return (UNSAFE_BODY); + add_symbol_to_list(sc, var_name); + + if (is_pair(cadr(let_var))) { + result = + min_body(result, + form_is_safe(sc, let_name, + cadr(let_var), false)); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } + follow = (!follow); + if (follow) { + if (!sp) + sp = vars; + else { + sp = cdr(sp); + if (vars == sp) + return (UNSAFE_BODY); + } + } + } + return (min_body + (result, + body_is_safe(sc, let_name, body, + (let_name != func) || at_end))); + } + + case OP_DO: /* (do (...) (...) ...) */ + { + if (!is_pair(cddr(x))) + return (UNSAFE_BODY); + if (is_pair(cadr(x))) { + bool follow = false; + s7_pointer vars = cadr(x), sp; + sp = vars; + for (; is_pair(vars); vars = cdr(vars)) { + s7_pointer do_var = car(vars); + if ((!is_pair(do_var)) || (!is_pair(cdr(do_var))) || /* (do ((a . 1) (b . 2)) ...) */ + (car(do_var) == func) || + (!is_symbol(car(do_var)))) + return (UNSAFE_BODY); + + add_symbol_to_list(sc, car(do_var)); + + if (is_pair(cadr(do_var))) + result = + min_body(result, + form_is_safe(sc, func, + cadr(do_var), + false)); + if ((is_pair(cddr(do_var))) + && (is_pair(caddr(do_var)))) + result = + min_body(result, + form_is_safe(sc, func, + caddr(do_var), + false)); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + if (sp != vars) { + if (follow) { + sp = cdr(sp); + if (vars == sp) + return (UNSAFE_BODY); + } + follow = (!follow); + } + } + } + if (is_pair(caddr(x))) + result = + min_body(result, + body_is_safe(sc, func, caddr(x), at_end)); + return (min_body + (result, body_is_safe(sc, func, cdddr(x), false))); + } + + /* define and friends are not safe: (define (a) (define b 3)...) tries to put b in the current let, + * but in a safe func, that's a constant. See s7test L 1865 for an example. + */ + default: + /* try to catch weird cases like: + * (let () (define (hi1 a) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1)) + * (let () (define (hi1 a) (define (ho1 b) b) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1)) + */ + return (UNSAFE_BODY); + } + } else { /* car(x) is not syntactic */ + if (expr == func) { /* try to catch tail call, expr is car(x) */ + bool follow = false; + s7_pointer sp, p; + sc->got_rec = true; /* (walk (car tree)) lint and almost all others in s7test */ + set_rec_tc_args(sc, proper_list_length(cdr(x))); + if (!at_end) { + result = RECUR_BODY; + sc->not_tc = true; + } + sp = x; + for (p = cdr(x); is_pair(p); p = cdr(p)) { + if (is_pair(car(p))) { + if (caar(p) == func) { /* func called as arg, so not tail call */ + sc->not_tc = true; + result = RECUR_BODY; + } + result = + min_body(result, + form_is_safe(sc, func, car(p), false)); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } else if (car(p) == func) /* func itself as arg */ + return (UNSAFE_BODY); + + if (follow) { + sp = cdr(sp); + if (p == sp) + return (UNSAFE_BODY); + } + follow = (!follow); + } + if ((at_end) && (!sc->not_tc) && (is_null(p))) { /* tail call, so safe */ + sc->got_tc = true; + set_rec_tc_args(sc, proper_list_length(cdr(x))); + return (result); + } + if (result != UNSAFE_BODY) + result = RECUR_BODY; + return (result); + } + + if (is_symbol(expr)) { /* expr=car(x) */ + s7_pointer f, f_slot; + bool c_safe; + + if (symbol_is_in_list(sc, expr)) + return (UNSAFE_BODY); + + f_slot = lookup_slot_from(expr, sc->curlet); + if (!is_slot(f_slot)) + return (UNSAFE_BODY); + f = slot_value(f_slot); + c_safe = (is_c_function(f)) + && (is_safe_or_scope_safe_procedure(f)); + result = ((is_sequence(f)) + || ((is_closure(f)) && (is_very_safe_closure(f))) + || ((c_safe) + && ((is_immutable(f_slot)) + || (is_global(expr))))) ? VERY_SAFE_BODY : + SAFE_BODY; + + if ((c_safe) || + ((is_any_closure(f)) && (is_safe_closure(f))) || + (is_sequence(f))) { + bool follow = false; + s7_pointer sp = x, p = cdr(x); + + for (; is_pair(p); p = cdr(p)) { + if (is_unquoted_pair(car(p))) { + if (caar(p) == func) { + sc->got_rec = true; /* (+ 1 (recur (- x 1))) t123 (and others) */ + set_rec_tc_args(sc, + proper_list_length(cdar(p))); + return (RECUR_BODY); + } + if ((is_c_function(f)) && (is_scope_safe(f)) && + (caar(p) == sc->lambda_symbol)) { + s7_pointer largs, lbody, q; + body_t lresult; + + if (!is_pair(cdar(p))) /* (lambda . /) */ + return (UNSAFE_BODY); + largs = cadar(p); + lbody = cddar(p); + for (q = largs; is_pair(q); q = cdr(q)) { + if (!is_symbol(car(q))) + return (UNSAFE_BODY); + add_symbol_to_list(sc, car(q)); + } + lresult = body_is_safe(sc, func, lbody, false); + result = min_body(result, lresult); + } else + result = + min_body(result, + form_is_safe(sc, func, car(p), + false)); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } else if (car(p) == func) /* the current function passed as an argument to something */ + return (UNSAFE_BODY); + + if (follow) { + sp = cdr(sp); + if (p == sp) + return (UNSAFE_BODY); + } + follow = (!follow); + } + return ((is_null(p)) ? result : UNSAFE_BODY); + } + if ((expr == sc->quote_symbol) && + (is_proper_list_1(sc, cdr(x))) && + (is_global(sc->quote_symbol))) + return (result); + + if (expr == sc->values_symbol) { /* (values) is safe, as is (values x) if x is: (values (define...)) */ + if (is_null(cdr(x))) + return (result); + if ((is_pair(cdr(x))) && (is_null(cddr(x)))) + return ((is_pair(cadr(x))) ? + min_body(result, + form_is_safe(sc, func, cadr(x), + false)) : result); + } + + if ((expr == sc->apply_symbol) && /* (apply + ints) */ + (is_pair(cdr(x))) && + (is_pair(cddr(x))) && + (is_null(cdddr(x))) && + ((!is_pair(caddr(x))) || + (form_is_safe(sc, func, caddr(x), false)))) { + s7_pointer fn = cadr(x); + if (is_symbol(fn)) { + s7_pointer fn_slot; + if (symbol_is_in_list(sc, fn)) + return (UNSAFE_BODY); + fn_slot = lookup_slot_from(fn, sc->curlet); + if (!is_slot(fn_slot)) + return (UNSAFE_BODY); + fn = slot_value(fn_slot); + if ((is_c_function(fn)) && (is_safe_procedure(fn))) + return (result); + if ((is_closure(fn)) && (is_very_safe_closure(fn))) + return (result); + } + } + } + return (UNSAFE_BODY); /* not recur_body here if at_end -- possible defines in body etc */ + } + return (result); +} + +static body_t body_is_safe(s7_scheme * sc, s7_pointer func, + s7_pointer body, bool at_end) +{ + bool follow = false; + s7_pointer p, sp; + body_t result = VERY_SAFE_BODY; + for (p = body, sp = body; is_pair(p); p = cdr(p)) { + if (is_pair(car(p))) { + result = + min_body(result, form_is_safe(sc, func, car(p), (at_end) + && (is_null(cdr(p))))); + if (result == UNSAFE_BODY) + return (UNSAFE_BODY); + } + if (p != body) { + if (follow) { + sp = cdr(sp); + if (p == sp) + return (UNSAFE_BODY); + } + follow = (!follow); + } + } + return ((is_null(p)) ? result : UNSAFE_BODY); +} + +static bool tree_has_definers_or_binders(s7_scheme * sc, s7_pointer tree) +{ + s7_pointer p; + for (p = tree; is_pair(p); p = cdr(p)) + if (tree_has_definers_or_binders(sc, car(p))) + return (true); + return ((is_symbol(tree)) && (is_definer_or_binder(tree))); +} + +static void optimize_lambda(s7_scheme * sc, bool unstarred_lambda, + s7_pointer func, s7_pointer args, + s7_pointer body) +{ /* func is either sc->unused or a symbol */ + s7_int len; + len = s7_list_length(sc, body); + + if (len < 0) /* (define (hi) 1 . 2) */ + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, + wrap_string(sc, + "~A: function body messed up, ~A", + 31), + (unstarred_lambda) ? sc-> + lambda_symbol : sc->lambda_star_symbol, + sc->code)); + + if (len > 0) { /* i.e. not circular */ + body_t result; + s7_pointer p, lst, cleared_args; + + clear_symbol_list(sc); + for (p = args; is_pair(p); p = cdr(p)) + add_symbol_to_list(sc, (is_symbol(car(p))) ? car(p) : caar(p)); + if (!is_null(p)) + add_symbol_to_list(sc, p); + sc->got_tc = false; + sc->not_tc = false; + sc->got_rec = false; + sc->rec_tc_args = -1; + result = ((is_symbol(func)) && (symbol_is_in_list(sc, func))) ? UNSAFE_BODY : body_is_safe(sc, func, body, true); /* (define (f f)...) */ + clear_symbol_list(sc); + + /* if the body is safe, we can optimize the calling sequence */ + if (!unstarred_lambda) { + bool happy = true; + /* check default vals -- if none is an expression or symbol, set simple args */ + for (p = args; is_pair(p); p = cdr(p)) { + s7_pointer arg; + arg = car(p); + if ((is_pair(arg)) && /* has default value */ + (is_pair(cdr(arg))) && /* is not a ridiculous improper list */ + ((is_symbol(cadr(arg))) || /* if default value might involve eval in any way, it isn't simple */ + (is_unquoted_pair(cadr(arg))))) { /* pair as default only ok if it is (quote ...) */ + happy = false; + if ((result > UNSAFE_BODY) && (tree_has_definers_or_binders(sc, cadr(arg)))) /* if the default has a definer, body is not safe (funclet is not stable) */ + result = UNSAFE_BODY; + break; + } + } + if (happy) + lambda_set_simple_defaults(body); + } + if (result >= SAFE_BODY) { /* not RECUR_BODY here (need new let for cons-r in s7test) */ + set_safe_closure_body(body); + if (result == VERY_SAFE_BODY) + set_very_safe_closure_body(body); + } + + if (is_symbol(func)) { + lst = list_1(sc, add_symbol_to_list(sc, func)); + sc->temp1 = lst; + } else + lst = sc->nil; + + if (optimize + (sc, body, 1, cleared_args = + collect_parameters(sc, args, lst)) == OPT_OOPS) + clear_all_optimizations(sc, body); + else { + if (result >= RECUR_BODY) { + int32_t nvars; + for (nvars = 0, p = args; + (is_pair(p)) && (!is_keyword(car(p))); + nvars++, p = cdr(p)); + if ((is_null(p)) && (nvars > 0)) { + fx_annotate_args(sc, body, cleared_args); /* almost useless -- we need a recursive traversal here but that collides with check_if et al */ + fx_tree(sc, body, /* this usually costs more than it saves! */ + (is_pair(car(args))) ? caar(args) : car(args), + (nvars > + 1) ? ((is_pair(cadr(args))) ? caadr(args) : + cadr(args)) : NULL, + (nvars > + 2) ? ((is_pair(caddr(args))) ? caaddr(args) : + caddr(args)) : NULL, nvars > 3); + } + if (((unstarred_lambda) || ((is_null(p)) && (nvars == sc->rec_tc_args))) && (is_null(cdr(body)))) { /* (if #t|#f...) happens only rarely */ + if (sc->got_tc) { + if (check_tc(sc, func, nvars, args, car(body))) + set_safe_closure_body(body); /* (very_)safe_closure set above if > RECUR_BODY */ + /* if not check_tc, car(body) is either not a tc op or it is not optimized so that is_fxable will return false */ + } + if ((sc->got_rec) && + (!is_tc_op(optimize_op(car(body)))) && + (check_recur(sc, func, nvars, args, car(body)))) + set_safe_closure_body(body); + } + } + } + if (is_symbol(func)) { + sc->temp1 = sc->nil; + free_cell(sc, lst); + } + sc->got_tc = false; + sc->not_tc = false; + sc->got_rec = false; + } +} + +static int32_t check_lambda(s7_scheme * sc, s7_pointer form, bool opt) +{ + /* code is a lambda form: (lambda (a b) (+ a b)) */ + /* this includes unevaluated symbols (direct symbol table refs) in macro arg list */ + s7_pointer code, body; + int32_t arity = 0; + + if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, form))) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, "lambda: body is cyclic: ~S", + 26), form)); + + code = cdr(form); + if (!is_pair(code)) /* (lambda) or (lambda . 1) */ + eval_error(sc, "lambda: no arguments? ~A", 24, form); + + body = cdr(code); + if (!is_pair(body)) /* (lambda #f) */ + eval_error(sc, "lambda: no body? ~A", 19, form); + + /* in many cases, this is a no-op -- we already checked at define */ + check_lambda_args(sc, car(code), &arity); + /* clear_symbol_list(sc); *//* not used in check_lambda_args and clobbers optimize_expression find_uncomplicated_symbol check */ + + /* look for (define f (let (...) (lambda ...))) and treat as equivalent to (define (f ...)...) + * one problem the hop=0 fixes is that safe closures assume the old let exists, so we need to check for define below + * I wonder about apply define... + */ + /* OP_LET1 should work here also, (let ((f (lambda...)))), but subsequent calls assume a saved let if safe + * to mimic define, we need to parallel op_define_with_setter + make_funclet, I think + */ + if ((opt) || (main_stack_op(sc) == OP_DEFINE1) || (((sc->stack_end - sc->stack_start) > 4) && (((opcode_t) (sc->stack_end[-5])) == OP_DEFINE1) && /* surely if define is ok, so is define dilambda? 16-Apr-16 */ + (sc->op_stack_now > + sc->op_stack) + && + ((* + (sc->op_stack_now + - 1)) == + (s7_pointer) + global_value + (sc->dilambda_symbol)))) + optimize_lambda(sc, true, sc->unused, car(code), body); + else if (optimize(sc, body, 0, + /* ((sc->op_stack_now > sc->op_stack) && (is_c_function((*(sc->op_stack_now - 1)))) && (is_scope_safe((*(sc->op_stack_now - 1))))) ? 1 : 0, */ + /* this works except when someone resets outlet(curlet) after defining a local function! */ + collect_parameters(sc, car(code), + sc->nil)) == OPT_OOPS) + clear_all_optimizations(sc, body); + pair_set_syntax_op(form, OP_LAMBDA_UNCHECKED); + if (arity < -1) + arity++; /* confusing! at least 0 = (), but (lambda arg...) has same "arity" here as (lambda (a . b)...)? */ + set_opt3_any(code, (s7_pointer) ((intptr_t) arity)); + return (arity); +} + +static s7_pointer op_lambda(s7_scheme * sc, s7_pointer code) +{ + int32_t arity; + arity = check_lambda(sc, code, false); + code = cdr(code); + set_opt3_any(code, (s7_pointer) ((intptr_t) arity)); + return (make_closure + (sc, car(code), cdr(code), + T_CLOSURE | ((arity < 0) ? T_COPY_ARGS : 0), arity)); +} + +static inline s7_pointer op_lambda_unchecked(s7_scheme * sc, + s7_pointer code) +{ + int32_t arity; + arity = (int32_t) ((intptr_t) opt3_any(cdr(code))); + return (inline_make_closure + (sc, cadr(code), cddr(code), + T_CLOSURE | ((arity < 0) ? T_COPY_ARGS : 0), arity)); +} + +static void check_lambda_star(s7_scheme * sc) +{ + s7_pointer code; + if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, sc->code))) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, "lambda*: body is cyclic: ~S", + 27), sc->code)); + + code = cdr(sc->code); + if ((!is_pair(code)) || (!is_pair(cdr(code)))) /* (lambda*) or (lambda* #f) */ + eval_error(sc, "lambda*: no arguments or no body? ~A", 36, + sc->code); + + set_car(code, check_lambda_star_args(sc, car(code), NULL)); + + if ((sc->safety > NO_SAFETY) || (main_stack_op(sc) != OP_DEFINE1)) { + if (optimize + (sc, cdr(code), 0, + collect_parameters(sc, car(code), sc->nil)) == OPT_OOPS) + clear_all_optimizations(sc, cdr(code)); + } else + optimize_lambda(sc, false, sc->unused, car(code), cdr(code)); + + pair_set_syntax_op(sc->code, OP_LAMBDA_STAR_UNCHECKED); + sc->code = code; +} + + +/* -------------------------------- case -------------------------------- */ +static inline bool is_undefined_feed_to(s7_scheme * sc, s7_pointer sym) +{ + return ((sym == sc->feed_to_symbol) && + ((symbol_ctr(sc->feed_to_symbol) == 0) + || (s7_symbol_value(sc, sc->feed_to_symbol) == + sc->undefined))); +} + +static s7_pointer check_case(s7_scheme * sc) +{ + /* we're not checking repeated or ridiculous (non-eqv?) keys here because they aren't errors */ + bool keys_simple = true, has_feed_to = false, keys_single = + true, bodies_simple = true, has_else = false; + int32_t key_type = T_FREE; + s7_pointer x, carc, code = cdr(sc->code); + + if (!is_pair(code)) /* (case) or (case . 1) */ + eval_error(sc, "case has no selector: ~A", 25, sc->code); + if (!is_pair(cdr(code))) /* (case 1) or (case 1 . 1) */ + eval_error(sc, "case has no clauses?: ~A", 25, sc->code); + if (!is_pair(cadr(code))) /* (case 1 1) */ + eval_error(sc, "case clause is not a list? ~A", 29, sc->code); + set_opt3_any(code, sc->unspecified); + + for (x = cdr(code); is_pair(x); x = cdr(x)) { + s7_pointer y, car_x; + if ((!is_pair(x)) || /* (case 1 ((2) 1) . 1) */ + (!is_pair(car(x)))) + eval_error(sc, "case clause ~A messed up", 24, x); + car_x = car(x); + + if (!is_list(cdr(car_x))) /* (case 1 ((1))) */ + eval_error(sc, "case clause result messed up: ~A", 32, car_x); + + if ((bodies_simple) && + ((is_null(cdr(car_x))) || (!is_null(cddr(car_x))))) + bodies_simple = false; + + y = car(car_x); + if (!is_pair(y)) { + if ((y != sc->else_symbol) && /* (case 1 (2 1)) */ + ((!is_symbol(y)) || (s7_symbol_value(sc, y) != sc->else_symbol))) /* "proper list" below because: (case 1 (() 2) ... */ + eval_error(sc, + "case clause key list ~A is not a proper list or 'else'", + 54, y); + else + has_else = true; + if (is_not_null(cdr(x))) /* (case 1 (else 1) ((2) 1)) */ + eval_error(sc, + "case 'else' clause, ~A, is not the last clause", + 46, x); + if (!is_null(cdr(car_x))) { /* else (else) so return selector */ + if (is_pair(cddr(car_x))) { + set_opt3_any(code, cdr(car_x)); + bodies_simple = false; + } else { + if ((bodies_simple) && (keys_single)) + set_opt3_any(code, cadr(car_x)); + else + set_opt3_any(code, cdr(car_x)); + set_opt1_clause(x, cadr(car_x)); + } + } + } else { + if (!is_simple(car(y))) + keys_simple = false; + if (!is_null(cdr(y))) + keys_single = false; + if (key_type == T_FREE) + key_type = type(car(y)); + else if (key_type != type(car(y))) + key_type = NUM_TYPES; + if (key_type == T_SYMBOL) + set_case_key(car(y)); + + for (y = cdr(y); is_pair(y); y = cdr(y)) { + if (!is_simple(car(y))) + keys_simple = false; + if (key_type != type(car(y))) + key_type = NUM_TYPES; + if (key_type == T_SYMBOL) + set_case_key(car(y)); + } + if (!is_null(y)) /* (case () ((1 . 2) . hi) . hi) */ + eval_error(sc, "case key list is improper? ~A", 29, x); + } + y = car_x; + if (!s7_is_proper_list(sc, cdr(y))) + eval_error(sc, "case: stray dot? ~A", 19, y); + if ((is_pair(cdr(y))) && (is_undefined_feed_to(sc, cadr(y)))) { + has_feed_to = true; + if (!is_pair(cddr(y))) /* (case 1 (else =>)) */ + eval_error(sc, "case: '=>' target missing? ~A", 30, y); + if (is_pair(cdddr(y))) /* (case 1 (else => + - *)) */ + eval_error(sc, "case: '=>' has too many targets: ~A", 35, + y); + } + } + if (is_not_null(x)) /* (case x ((1 2)) . 1) */ + eval_error(sc, "case: stray dot? ~A", 19, sc->code); + + if ((keys_single) && (bodies_simple)) { + for (x = cdr(code); is_not_null(x); x = cdr(x)) { + set_opt2_any(x, caar(x)); + if (is_pair(opt2_any(x))) { + set_opt2_any(x, car(opt2_any(x))); + if (is_pair(cdar(x))) + set_opt1_clause(x, cadar(x)); + } + } + } else + for (x = cdr(code); is_not_null(x); x = cdr(x)) { + set_opt2_any(x, caar(x)); + if ((is_pair(opt2_any(x))) && (is_pair(cdar(x)))) + set_opt1_clause(x, cadar(x)); + } + if (key_type == T_INTEGER) + set_has_integer_keys(sc->code); + + pair_set_syntax_op(sc->code, OP_CASE_P_G_G); /* fallback on this */ + if ((has_feed_to) || (!bodies_simple) || /* x_x_g g=general keys or bodies */ + (!keys_single)) { + if (!keys_simple) { /* x_g_g (no int32_t case here) */ + if (is_symbol(car(code))) + pair_set_syntax_op(sc->code, OP_CASE_S_G_G); + else if (is_fxable(sc, car(code))) { + pair_set_syntax_op(sc->code, OP_CASE_A_G_G); + set_fx_direct(code, + fx_choose(sc, code, sc->curlet, + let_symbol_is_safe)); + } else + pair_set_syntax_op(sc->code, OP_CASE_P_G_G); + } else { /* x_e_g */ + if (!has_else) + set_opt3_any(code, sc->unused); /* affects all that goto CASE_E_G */ + if (is_symbol(car(code))) + pair_set_syntax_op(sc->code, + (key_type == + T_SYMBOL) ? OP_CASE_S_S_G : + OP_CASE_S_E_G); + else if (is_fxable(sc, car(code))) { + pair_set_syntax_op(sc->code, + (key_type == + T_SYMBOL) ? OP_CASE_A_S_G : + OP_CASE_A_E_G); + set_fx_direct(code, + fx_choose(sc, code, sc->curlet, + let_symbol_is_safe)); + } else + pair_set_syntax_op(sc->code, + (key_type == + T_SYMBOL) ? OP_CASE_P_S_G : + OP_CASE_P_E_G); + } + } else /* x_x_s */ if (!keys_simple) { /* x_g|i_s */ + if (is_symbol(car(code))) + pair_set_syntax_op(sc->code, ((!WITH_GMP) + && (key_type == + T_INTEGER)) ? OP_CASE_S_I_S : + OP_CASE_S_G_S); + else if (is_fxable(sc, car(code))) { + pair_set_syntax_op(sc->code, ((!WITH_GMP) + && (key_type == + T_INTEGER)) ? OP_CASE_A_I_S : + OP_CASE_A_G_S); + set_fx_direct(code, + fx_choose(sc, code, sc->curlet, + let_symbol_is_safe)); + } else + pair_set_syntax_op(sc->code, ((!WITH_GMP) + && (key_type == + T_INTEGER)) ? OP_CASE_P_I_S : + OP_CASE_P_G_S); + } else /* x_e_s */ if (is_symbol(car(code))) + pair_set_syntax_op(sc->code, + (key_type == + T_SYMBOL) ? OP_CASE_S_S_S : OP_CASE_S_E_S); + else if (is_fxable(sc, car(code))) { + pair_set_syntax_op(sc->code, + (key_type == + T_SYMBOL) ? OP_CASE_A_S_S : OP_CASE_A_E_S); + set_fx_direct(code, + fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); + } else + pair_set_syntax_op(sc->code, + (key_type == + T_SYMBOL) ? OP_CASE_P_S_S : OP_CASE_P_E_S); + + carc = cadr(sc->code); + if (!is_pair(carc)) { + sc->value = (is_symbol(carc)) ? lookup_checked(sc, carc) : carc; + return (NULL); + } + push_stack_no_args_direct(sc, OP_CASE_G_G); + sc->code = carc; + return (carc); +} + +#if (!WITH_GMP) +static bool op_case_i_s(s7_scheme * sc) +{ + s7_pointer x, selector = sc->value, else_clause = + opt3_any(cdr(sc->code)); + if (else_clause != sc->unspecified) { + if (is_t_integer(selector)) { + s7_int val = integer(selector); + for (x = cddr(sc->code); is_pair(x); x = cdr(x)) + if (is_t_integer(opt2_any(x))) { + if (integer(opt2_any(x)) == val) { + sc->code = opt1_clause(x); + return (false); + } + } else + break; + } + sc->code = else_clause; + return (false); + } + if (is_t_integer(selector)) { + s7_int val = integer(selector); + for (x = cddr(sc->code); is_pair(x); x = cdr(x)) + if (integer(opt2_any(x)) == val) { + sc->code = opt1_clause(x); + return (false); + } + } + sc->value = sc->unspecified; + return (true); +} +#endif + +static bool op_case_e_g_1(s7_scheme * sc, s7_pointer selector, bool ok) +{ + s7_pointer x, y; + if (ok) { + for (x = cddr(sc->code); is_pair(x); x = cdr(x)) { + y = opt2_any(x); + if (!is_pair(y)) /* i.e. else? */ + goto ELSE_CASE_1; + do { + if (car(y) == selector) + goto ELSE_CASE_1; + y = cdr(y); + } while (is_pair(y)); + } + sc->value = sc->unspecified; + pop_stack(sc); + return (true); + } + + sc->code = opt3_any(cdr(sc->code)); + if (sc->code == sc->unused) /* set in check_case if no else clause */ + sc->value = sc->unspecified; + else if (is_pair(sc->code)) + goto ELSE_CASE_2; + pop_stack(sc); + return (true); + + ELSE_CASE_1: + /* x is the entire matching clause, (case 2 ((2) 3)), x: (((2) 3)) */ + sc->code = T_Lst(cdar(x)); + if (is_null(sc->code)) { /* sc->value is already the selector */ + pop_stack(sc); + return (true); + } + + ELSE_CASE_2: + if (is_null(cdr(sc->code))) { + sc->code = car(sc->code); + sc->cur_op = optimize_op(sc->code); + return (true); + } + + if (is_undefined_feed_to(sc, car(sc->code))) + return (false); + + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(sc->code); + sc->cur_op = optimize_op(sc->code); + return (true); +} + +static bool op_case_g_g(s7_scheme * sc) +{ + s7_pointer x, y; + if (has_integer_keys(sc->code)) { + s7_int selector; + sc->code = cddr(sc->code); + if (is_t_integer(sc->value)) + selector = integer(sc->value); + else { +#if WITH_GMP + if ((is_t_big_integer(sc->value)) + && (mpz_fits_slong_p(big_integer(sc->value)))) + selector = mpz_get_si(big_integer(sc->value)); + else +#endif + { + for (x = sc->code; is_pair(x); x = cdr(x)) /* maybe preset the else case */ + if (!is_pair(caar(x))) + goto ELSE_CASE; + sc->value = sc->unspecified; + pop_stack(sc); + return (true); + } + } + for (x = sc->code; is_pair(x); x = cdr(x)) { + y = caar(x); + if (!is_pair(y)) + goto ELSE_CASE; + for (; is_pair(y); y = cdr(y)) + if (integer(car(y)) == selector) + goto ELSE_CASE; + } + sc->value = sc->unspecified; + pop_stack(sc); + return (true); + } + sc->code = cddr(sc->code); + if (is_simple(sc->value)) { + for (x = sc->code; is_pair(x); x = cdr(x)) { + y = caar(x); + if (!is_pair(y)) + goto ELSE_CASE; + do { + if (car(y) == sc->value) + goto ELSE_CASE; + y = cdr(y); + } while (is_pair(y)); + } + sc->value = sc->unspecified; + pop_stack(sc); + return (true); + } + + for (x = sc->code; is_pair(x); x = cdr(x)) { + y = caar(x); + if (!is_pair(y)) + goto ELSE_CASE; + for (; is_pair(y); y = cdr(y)) + if (s7_is_eqv(sc, car(y), sc->value)) + goto ELSE_CASE; + } + sc->value = sc->unspecified; /* this was sc->nil but the spec says case value is unspecified if no clauses match */ + pop_stack(sc); + return (true); + + ELSE_CASE: + /* x is the entire matching clause, (case 2 ((2) 3)), x: (((2) 3)) */ + sc->code = T_Lst(cdar(x)); + if (is_null(sc->code)) { /* sc->value is already the selector */ + pop_stack(sc); + return (true); + } + if (is_null(cdr(sc->code))) { + sc->code = car(sc->code); + sc->cur_op = optimize_op(sc->code); + return (true); + } + if (is_undefined_feed_to(sc, car(sc->code))) + return (false); + if (is_pair(cdr(T_Pair(sc->code)))) + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + sc->code = car(sc->code); + sc->cur_op = optimize_op(sc->code); + return (true); +} + +static void op_case_e_s(s7_scheme * sc) +{ + s7_pointer selector = sc->value; + if (is_simple(selector)) { + s7_pointer x; + for (x = cddr(sc->code); is_pair(x); x = cdr(x)) + if (opt2_any(x) == selector) { + sc->code = opt1_clause(x); + return; + } + } + sc->code = opt3_any(cdr(sc->code)); +} + +static void op_case_s_s(s7_scheme * sc) +{ + s7_pointer selector = sc->value; + if (is_symbol(selector)) { + s7_pointer x; + for (x = cddr(sc->code); is_pair(x); x = cdr(x)) + if (opt2_any(x) == selector) { + sc->code = opt1_clause(x); + return; + } + } + sc->code = opt3_any(cdr(sc->code)); +} + +static void op_case_g_s(s7_scheme * sc) +{ + s7_pointer x, selector = sc->value; + for (x = cddr(sc->code); is_pair(x); x = cdr(x)) + if (s7_is_eqv(sc, opt2_any(x), selector)) { + sc->code = opt1_clause(x); + return; + } + sc->code = opt3_any(cdr(sc->code)); +} + + +/* -------------------------------- let -------------------------------- */ +static void check_let_a_body(s7_scheme * sc, s7_pointer form) +{ + s7_pointer code = cdr(form); + if (is_fxable(sc, cadr(code))) { + fx_annotate_arg(sc, cdr(code), set_plist_1(sc, caaar(code))); /* was sc->curlet) ? */ + fx_tree(sc, cdr(code), caaar(code), NULL, NULL, false); + pair_set_syntax_op(form, OP_LET_A_A_OLD); + } else if (is_pair(cadr(code))) + pair_set_syntax_op(form, OP_LET_A_P_OLD); +} + +static void check_let_one_var(s7_scheme * sc, s7_pointer form, + s7_pointer start) +{ + s7_pointer binding = car(start), code = cdr(form); + if (is_pair(cadr(binding))) { + /* this is not a named let */ + pair_set_syntax_op(form, ((is_pair(cdr(code))) + && (is_null(cddr(code)))) ? + OP_LET_ONE_P_OLD : OP_LET_ONE_OLD); + set_opt2_sym(cdr(code), car(binding)); /* these don't collide -- cdr(code) and code */ + set_opt2_pair(code, cadr(binding)); + + if (is_optimized(cadr(binding))) { + if (is_null(cddr(code))) { /* one statement body */ + if (optimize_op(cadr(binding)) == HOP_SAFE_C_SS) { + /* no lt fx here, 4 s7test */ + if (fn_proc(cadr(binding)) == g_assq) { + set_opt2_sym(code, cadadr(binding)); + pair_set_syntax_op(form, OP_LET_opaSSq_E_OLD); + } else + pair_set_syntax_op(form, OP_LET_opSSq_E_OLD); + set_opt3_sym(cdr(code), caddadr(binding)); + set_opt1_sym(code, car(binding)); + return; + } + if (is_fxable(sc, cadr(binding))) { + set_opt2_pair(code, binding); + pair_set_syntax_op(form, OP_LET_A_OLD); + fx_annotate_arg(sc, cdr(binding), sc->curlet); + check_let_a_body(sc, form); + return; + } + } + if (optimize_op(cadr(binding)) == HOP_SAFE_C_SS) { + if (fn_proc(cadr(binding)) == g_assq) { + set_opt2_sym(code, cadadr(binding)); + pair_set_syntax_op(form, OP_LET_opaSSq_OLD); + } else + pair_set_syntax_op(form, OP_LET_opSSq_OLD); + set_opt3_sym(cdr(code), caddadr(binding)); + set_opt1_sym(code, car(binding)); + } else if (is_fxable(sc, cadr(binding))) { + set_opt2_pair(code, binding); + pair_set_syntax_op(form, OP_LET_A_OLD); + fx_annotate_arg(sc, cdr(binding), sc->curlet); + if (is_null(cddr(code))) + check_let_a_body(sc, form); + else { + s7_pointer p; + for (p = cdr(code); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + break; + if (is_null(p)) { + pair_set_syntax_op(form, OP_LET_A_FX_OLD); + fx_annotate_args(sc, cdr(code), + set_plist_1(sc, car(binding))); + fx_tree(sc, cdr(code), car(binding), NULL, NULL, + false); + return; + } + } + } + } + } else { + set_opt2_pair(code, binding); + pair_set_syntax_op(form, OP_LET_A_OLD); + fx_annotate_arg(sc, cdr(binding), sc->curlet); + if (is_null(cddr(code))) + check_let_a_body(sc, form); + } + if ((optimize_op(form) == OP_LET_A_OLD) && + (is_pair(cddr(code))) && (is_null(cdddr(code)))) + pair_set_syntax_op(form, OP_LET_A_OLD_2); +} + +static s7_pointer check_named_let(s7_scheme * sc, int32_t vars) +{ + s7_pointer code = cdr(sc->code); + set_opt2_int(code, make_permanent_integer(vars)); + if (vars == 0) { + pair_set_syntax_op(sc->code, OP_NAMED_LET_NO_VARS); + set_opt1_pair(sc->code, cddr(code)); + optimize_lambda(sc, true, car(code), sc->nil, cddr(code)); + } else { + s7_pointer ex, exp; + bool fx_ok = true; + pair_set_syntax_op(sc->code, OP_NAMED_LET); + /* this is (let name ...) so the initial values need to be removed from the closure arg list */ + + sc->args = T_Pair(safe_list_if_possible(sc, vars)); + for (ex = cadr(code), exp = sc->args; is_pair(ex); + ex = cdr(ex), exp = cdr(exp)) { + s7_function fx; + s7_pointer val = cdar(ex); + fx = fx_choose(sc, val, sc->curlet, let_symbol_is_safe); + if (fx) + set_fx_direct(val, fx); + else + fx_ok = false; + car(exp) = caar(ex); + } + if (fx_ok) { + set_opt1_pair(code, caadr(code)); + if (vars == 2) + set_opt3_pair(code, cadadr(code)); + pair_set_syntax_op(sc->code, + (vars == + 1) ? OP_NAMED_LET_A : ((vars == + 2) ? + OP_NAMED_LET_AA : + OP_NAMED_LET_FX)); + } + optimize_lambda(sc, true, car(code), sc->args, cddr(code)); /* car(code) is the name */ + clear_list_in_use(sc->args); + sc->args = sc->nil; + } + return (code); +} + +static s7_pointer check_let(s7_scheme * sc) +{ /* called only from op_let */ + s7_pointer x, start, code = cdr(sc->code); + bool named_let; + int32_t vars; + + if (!is_pair(code)) { /* (let . 1) */ + if (is_null(code)) /* (let) */ + eval_error(sc, "let has no variables or body: ~A", 32, + sc->code); + eval_error(sc, "let form is an improper list? ~A", 32, sc->code); + } + + if (!is_pair(cdr(code))) /* (let () ) or (let () . 1) */ + eval_error(sc, "let has no body: ~A", 19, sc->code); + + if ((!is_list(car(code))) && /* (let 1 ...) */ + (!is_normal_symbol(car(code)))) + eval_error(sc, "let variable list is messed up or missing: ~A", 45, + sc->code); + + named_let = (is_symbol(car(code))); + if (named_let) { + if (!is_list(cadr(code))) /* (let hi #t) */ + eval_error(sc, "let variable list is messed up: ~A", 34, + sc->code); + if (!is_pair(cddr(code))) { /* (let hi () . =>) or (let hi () ) */ + if (is_null(cddr(code))) + eval_error(sc, "named let has no body: ~A", 25, sc->code); + else + eval_error(sc, "named let stray dot? ~A", 23, sc->code); + } + if (is_constant_symbol(sc, car(code))) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, cant_bind_immutable_string, + sc->code))); + set_local(car(code)); + start = cadr(code); + } else + start = car(code); + + clear_symbol_list(sc); + for (vars = 0, x = start; is_pair(x); vars++, x = cdr(x)) { + s7_pointer y, carx; + carx = car(x); + + if ((!is_pair(carx)) || (is_null(cdr(carx)))) /* (let ((x)) ...) or (let ((x 1) . (y 2)) ...) */ + eval_error(sc, "let variable declaration, but no value?: ~A", + 43, x); + + if (!(is_pair(cdr(carx)))) /* (let ((x . 1))...) */ + eval_error(sc, + "let variable declaration is not a proper list?: ~A", + 50, x); + + if (is_not_null(cddr(carx))) /* (let ((x 1 2 3)) ...) */ + eval_error(sc, + "let variable declaration has more than one value?: ~A", + 53, x); + + y = car(carx); + if (!(is_symbol(y))) + eval_error(sc, "bad variable ~S in let (it is not a symbol)", + 43, carx); + + if (is_constant_symbol(sc, y)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, cant_bind_immutable_string, x))); + + /* check for name collisions -- not sure this is required by Scheme */ + if (symbol_is_in_list(sc, y)) + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, + wrap_string(sc, + "duplicate identifier in let: ~S in ~S", + 37), y, sc->code)); + add_symbol_to_list(sc, y); + set_local(y); + } + /* (let ('1) quote) -> 1 */ + + if (is_not_null(x)) /* (let* ((a 1) . b) a) */ + eval_error(sc, "let variable list improper?: ~A", 31, sc->code); + + if (!s7_is_proper_list(sc, cdr(code))) /* (let ((a 1)) a . 1) */ + eval_error(sc, "stray dot in let body: ~S", 25, cdr(code)); + + if (named_let) + return (check_named_let(sc, vars)); + + if (vars == 0) /* !in_heap does not happen much here */ + pair_set_syntax_op(sc->code, OP_LET_NO_VARS); + else { + pair_set_syntax_op(sc->code, OP_LET_UNCHECKED); + if (vars == 1) + check_let_one_var(sc, sc->code, start); + else { + s7_pointer p; + /* this used to check that vars < gc_trigger_size, but I can't see why */ + opcode_t opt = OP_UNOPT; + for (p = start; is_pair(p); p = cdr(p)) { + x = car(p); + if (is_fxable(sc, cadr(x))) { + set_fx_direct(cdr(x), + fx_choose(sc, cdr(x), sc->curlet, + let_symbol_is_safe)); + if (opt == OP_UNOPT) + opt = OP_LET_FX_OLD; + } else + opt = OP_LET_UNCHECKED; + } + pair_set_syntax_op(sc->code, opt); + if ((opt == OP_LET_FX_OLD) && (is_null(cddr(code)))) { /* 1 form in body */ + /* if (is_fxable(sc, cadr(code))) fprintf(stderr, "%s\n", display(code)); */ + if (vars == 2) { + pair_set_syntax_op(sc->code, OP_LET_2A_OLD); + set_opt1_pair(code, caar(code)); + set_opt2_pair(code, cadar(code)); + } else if (vars == 3) { + pair_set_syntax_op(sc->code, OP_LET_3A_OLD); + set_opt1_pair(code, cadar(code)); + set_opt2_pair(code, caddar(code)); + } + } + } + } + + /* if safe_c or safe_closure as car(body), null cdr(body), see if only vars as args + * symbol_list is intact?? + */ + if (optimize_op(sc->code) >= OP_LET_FX_OLD) { + if ((!in_heap(sc->code)) && (body_is_safe(sc, sc->unused, cdr(code), true) >= SAFE_BODY)) /* recur_body is apparently never hit */ + set_opt3_let(code, make_permanent_let(sc, car(code))); + else { + set_optimize_op(sc->code, optimize_op(sc->code) + 1); /* *_old -> *_new */ + set_opt3_let(code, sc->nil); + } + } + + if ((is_pair(car(code))) && + (is_let(sc->curlet)) && (is_funclet(sc->curlet)) + && (tis_slot(let_slots(sc->curlet)))) { + /* apparently works because a safe closure will have old-let -> funclet?? */ + s7_pointer p, s1 = let_slots(sc->curlet), s2 = NULL, s3 = NULL; + if (tis_slot(next_slot(s1))) + s2 = slot_symbol(next_slot(s1)); + if ((s2) && (tis_slot(next_slot(next_slot(s1))))) + s3 = slot_symbol(next_slot(next_slot(s1))); + s1 = slot_symbol(s1); + for (p = car(code); is_pair(p); p = cdr(p)) { + s7_pointer init = cdar(p); + fx_tree(sc, init, s1, s2, s3, s3); + } + } + return (code); +} + +static bool op_named_let_1(s7_scheme * sc, s7_pointer args) +{ /* args = vals in decl order */ + s7_pointer body = cddr(sc->code), x; + s7_int n = integer(opt2_int(sc->code)); + sc->w = sc->nil; + for (x = cadr(sc->code); is_pair(x); x = cdr(x)) { + sc->w = cons(sc, caar(x), sc->w); + x = cdr(x); + if (!is_pair(x)) + break; + sc->w = cons_unchecked(sc, caar(x), sc->w); + } + sc->w = proper_list_reverse_in_place(sc, sc->w); /* init values (args) are also in "reversed" order */ + sc->curlet = make_let_slowly(sc, sc->curlet); + sc->x = make_closure_unchecked(sc, sc->w, body, T_CLOSURE, n); + add_slot(sc, sc->curlet, car(sc->code), sc->x); + sc->curlet = make_let_slowly(sc, sc->curlet); + + for (x = sc->w; is_not_null(args); x = cdr(x)) { /* reuse the value cells as the new let slots */ + s7_pointer sym = car(x), new_args = cdr(args); + reuse_as_slot(sc, args, sym, unchecked_car(args)); /* args=slot, sym=symbol, car(args)=value */ + slot_set_next(args, let_slots(sc->curlet)); + let_set_slots(sc->curlet, args); + symbol_set_local_slot(sym, let_id(sc->curlet), args); + args = new_args; + } + closure_set_let(sc->x, sc->curlet); + let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); + sc->x = sc->nil; + sc->code = T_Pair(body); + sc->w = sc->nil; + return (true); +} + +static bool op_let1(s7_scheme * sc) +{ + s7_pointer x, y, e; + uint64_t id; + /* building a list, then reusing it below as the let/slots seems stupid, but if we make the let first, and + * add slots, there are other problems. The let/slot ids (and symbol_set_local_slot) need to wait + * until the args are evaluated, if an arg invokes call/cc, the let on the stack needs to be copied + * including let_dox_code if it is used to save sc->code (there are 3 things that need to be protected), + * (we win currently because copy_stack copies the list), and make-circular-iterator if called twice (s7test) + * hangs -- I can't see why! Otherwise, the let/slots approach is slightly faster (less than 1% however). + */ + while (true) { + sc->args = cons(sc, sc->value, sc->args); + if (is_pair(sc->code)) { + x = cdar(sc->code); + if (has_fx(x)) + sc->value = fx_call(sc, x); + else { + check_stack_size(sc); + push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); + sc->code = car(x); + return (false); + } + sc->code = cdr(sc->code); + } else + break; + } + + x = proper_list_reverse_in_place(sc, sc->args); + sc->code = car(x); /* restore the original form */ + y = cdr(x); /* use sc->args as the new let */ + sc->y = y; + set_curlet(sc, reuse_as_let(sc, x, sc->curlet)); + + if (is_symbol(car(sc->code))) + return (op_named_let_1(sc, y)); + + e = sc->curlet; + id = let_id(e); + + for (x = car(sc->code); is_not_null(y); x = cdr(x)) { + s7_pointer sym = caar(x), args = cdr(y); + /* reuse the value cells as the new let slots */ + reuse_as_slot(sc, y, sym, unchecked_car(y)); + symbol_set_local_slot(sym, id, y); + slot_set_next(y, let_slots(e)); + let_set_slots(e, y); + y = args; + } + sc->code = T_Pair(cdr(sc->code)); + sc->y = sc->nil; + return (true); +} + +static bool op_let(s7_scheme * sc) +{ + /* sc->code is everything after the let: (let ((a 1)) a) so sc->code is (((a 1)) a) */ + /* car can be either a list or a symbol ("named let") */ + bool named_let; + + sc->code = check_let(sc); + sc->value = sc->code; + named_let = is_symbol(car(sc->code)); + sc->code = (named_let) ? cadr(sc->code) : car(sc->code); + if (is_null(sc->code)) { /* (let [name] () ...): no bindings, so skip that step */ + sc->code = sc->value; + sc->curlet = make_let(sc, sc->curlet); + if (named_let) { /* see also below -- there are 3 cases */ + s7_pointer body = cddr(sc->code); + set_opt2_int(cdr(sc->code), int_zero); + sc->x = + make_closure_unchecked(sc, sc->nil, body, T_CLOSURE, 0); + /* args = () in new closure, see NAMED_LET_NO_VARS above */ + /* if this is a safe closure, we can build its let in advance and name it (a thunk in this case) */ + set_funclet(closure_let(sc->x)); + funclet_set_function(closure_let(sc->x), car(sc->code)); + add_slot_checked(sc, sc->curlet, car(sc->code), sc->x); + sc->code = T_Pair(body); + sc->x = sc->nil; + } else + sc->code = T_Pair(cdr(sc->code)); + return (true); + } + sc->args = sc->nil; + return (op_let1(sc)); +} + +static bool op_let_unchecked(s7_scheme * sc) +{ /* not named, but has vars */ + s7_pointer x, code = cadr(sc->code); + sc->args = list_1(sc, cdr(sc->code)); + x = cdar(code); + if (has_fx(x)) + sc->value = fx_call(sc, x); + else { + push_stack(sc, OP_LET1, sc->args, cdr(code)); + sc->code = car(x); + return (false); /* goto EVAL */ + } + sc->code = cdr(code); + return (op_let1(sc)); +} + +static bool op_named_let(s7_scheme * sc) +{ + sc->args = sc->nil; + sc->value = cdr(sc->code); + sc->code = cadr(sc->value); + return (op_let1(sc)); +} + +static void op_named_let_no_vars(s7_scheme * sc) +{ + s7_pointer arg = cadr(sc->code); + sc->code = opt1_pair(sc->code); /* cdddr(sc->code) */ + sc->curlet = make_let(sc, sc->curlet); + sc->args = make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE, 0); /* sc->args is a temp here */ + add_slot_checked(sc, sc->curlet, arg, sc->args); +} + +static void op_named_let_a(s7_scheme * sc) +{ + s7_pointer args; + args = cdr(sc->code); + sc->code = cddr(args); + sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) */ + sc->curlet = make_let_slowly(sc, sc->curlet); + sc->w = list_1_unchecked(sc, car(opt1_pair(args))); /* caaadr(args), subsequent calls will need a normal list of pars in closure_args */ + sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 1); /* picks up curlet (this is the funclet?) */ + add_slot(sc, sc->curlet, car(args), sc->x); /* the function */ + sc->curlet = make_let_with_slot(sc, sc->curlet, car(sc->w), sc->args); /* why the second let? */ + closure_set_let(sc->x, sc->curlet); + sc->x = sc->nil; + sc->w = sc->nil; +} + +static void op_named_let_aa(s7_scheme * sc) +{ + s7_pointer args; + args = cdr(sc->code); + sc->code = cddr(args); + sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) == init val of first par */ + sc->value = fx_call(sc, cdr(opt3_pair(args))); /* cdadadr = init val of second */ + sc->curlet = make_let_slowly(sc, sc->curlet); + sc->w = list_2_unchecked(sc, car(opt1_pair(args)), car(opt3_pair(args))); /* subsequent calls will need a normal list of pars in closure_args */ + sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 2); /* picks up curlet (this is the funclet?) */ + add_slot(sc, sc->curlet, car(args), sc->x); /* the function */ + sc->curlet = + make_let_with_two_slots(sc, sc->curlet, car(sc->w), sc->args, + cadr(sc->w), sc->value); + closure_set_let(sc->x, sc->curlet); + sc->x = sc->nil; + sc->w = sc->nil; +} + +static bool op_named_let_fx(s7_scheme * sc) +{ + s7_pointer p; + sc->code = cdr(sc->code); + for (p = cadr(sc->code), sc->args = sc->nil; is_pair(p); p = cdr(p)) { + sc->args = cons(sc, sc->value = fx_call(sc, cdar(p)), sc->args); + p = cdr(p); + if (!is_pair(p)) + break; + sc->args = cons_unchecked(sc, sc->value = + fx_call(sc, cdar(p)), sc->args); + } + sc->args = proper_list_reverse_in_place(sc, sc->args); + return (op_named_let_1(sc, sc->args)); /* sc->code = (name vars . body), args = vals in decl order */ +} + +static void op_let_no_vars(s7_scheme * sc) +{ + sc->curlet = make_let(sc, sc->curlet); + sc->code = T_Pair(cddr(sc->code)); /* ignore the () */ +} + +static void op_let_one_new(s7_scheme * sc) +{ + sc->code = cdr(sc->code); + push_stack_no_args(sc, OP_LET_ONE_NEW_1, cdr(sc->code)); + sc->code = opt2_pair(sc->code); +} + +static void op_let_one_p_new(s7_scheme * sc) +{ + sc->code = cdr(sc->code); + push_stack_no_args(sc, OP_LET_ONE_P_NEW_1, cdr(sc->code)); + sc->code = T_Pair(opt2_pair(sc->code)); +} + +static void op_let_one_old(s7_scheme * sc) +{ + sc->code = cdr(sc->code); + push_stack_no_args_direct(sc, OP_LET_ONE_OLD_1); + sc->code = opt2_pair(sc->code); +} + +static void op_let_one_old_1(s7_scheme * sc) +{ + s7_pointer let; + let = update_let_with_slot(sc, opt3_let(sc->code), sc->value); + let_set_outlet(let, sc->curlet); + set_curlet(sc, let); + sc->code = cdr(sc->code); +} + +static void op_let_one_p_old(s7_scheme * sc) +{ + sc->code = cdr(sc->code); + push_stack_no_args_direct(sc, OP_LET_ONE_P_OLD_1); + sc->code = T_Pair(opt2_pair(sc->code)); +} + +static void op_let_one_p_old_1(s7_scheme * sc) +{ + s7_pointer let; + let = update_let_with_slot(sc, opt3_let(sc->code), sc->value); + let_set_outlet(let, sc->curlet); + set_curlet(sc, let); + sc->code = cadr(sc->code); +} + +static Inline void op_let_a_new(s7_scheme * sc) +{ + sc->code = cdr(sc->code); + sc->curlet = + make_let_with_slot(sc, sc->curlet, car(opt2_pair(sc->code)), + fx_call(sc, cdr(opt2_pair(sc->code)))); +} + +static Inline void op_let_a_old(s7_scheme * sc) +{ + s7_pointer let; + sc->code = cdr(sc->code); + let = + update_let_with_slot(sc, opt3_let(sc->code), + fx_call(sc, cdr(opt2_pair(sc->code)))); + let_set_outlet(let, sc->curlet); + set_curlet(sc, let); +} + +static void op_let_a_a_new(s7_scheme * sc) +{ + s7_pointer binding; + sc->code = cdr(sc->code); + binding = opt2_pair(sc->code); + sc->curlet = + make_let_with_slot(sc, sc->curlet, car(binding), + fx_call(sc, cdr(binding))); + sc->value = fx_call(sc, cdr(sc->code)); + free_cell(sc, let_slots(sc->curlet)); + free_cell(sc, sc->curlet); + /* upon return, we goto START, so sc->curlet should be ok */ +} + +static void op_let_a_a_old(s7_scheme * sc) +{ /* these are not called as fx*, and restoring sc->curlet has noticeable cost (e.g. 8 in thash) */ + s7_pointer let; + sc->code = cdr(sc->code); + let = + update_let_with_slot(sc, opt3_let(sc->code), + fx_call(sc, cdr(opt2_pair(sc->code)))); + let_set_outlet(let, sc->curlet); + set_curlet(sc, let); + sc->value = fx_call(sc, cdr(sc->code)); +} + +static void op_let_a_fx_new(s7_scheme * sc) +{ + s7_pointer binding, p; + sc->code = cdr(sc->code); + binding = opt2_pair(sc->code); + sc->curlet = + make_let_with_slot(sc, sc->curlet, car(binding), + fx_call(sc, cdr(binding))); + for (p = cdr(sc->code); is_pair(cdr(p)); p = cdr(p)) + fx_call(sc, p); + sc->value = fx_call(sc, p); + free_cell(sc, let_slots(sc->curlet)); + free_cell(sc, sc->curlet); +} + +/* this and others like it could easily be fx funcs, but check_let is called too late, so it's never seen as fxable */ +static void op_let_a_fx_old(s7_scheme * sc) +{ + s7_pointer let, p; + sc->code = cdr(sc->code); + let = + update_let_with_slot(sc, opt3_let(sc->code), + fx_call(sc, cdr(opt2_pair(sc->code)))); + let_set_outlet(let, sc->curlet); + set_curlet(sc, let); + for (p = cdr(sc->code); is_pair(cdr(p)); p = cdr(p)) + fx_call(sc, p); + sc->value = fx_call(sc, p); +} + +static inline void op_let_opssq(s7_scheme * sc) +{ + s7_pointer largs, in_val; + sc->code = cdr(sc->code); + largs = T_Pair(opt2_pair(sc->code)); /* cadr(caar(sc->code)); */ + in_val = lookup(sc, cadr(largs)); + set_car(sc->t2_2, lookup(sc, opt3_sym(cdr(sc->code)))); /* caddr(largs)); */ + set_car(sc->t2_1, in_val); + sc->value = fn_proc(largs) (sc, sc->t2_1); +} + +static inline void op_let_opassq(s7_scheme * sc) +{ + s7_pointer in_val, lst; + sc->code = cdr(sc->code); + in_val = lookup(sc, opt2_sym(sc->code)); /* cadadr(caar(sc->code)); */ + lst = lookup(sc, opt3_sym(cdr(sc->code))); + if (is_pair(lst)) + sc->value = s7_assq(sc, in_val, lst); + else + sc->value = + (is_null(lst)) ? sc->F : g_assq(sc, + set_plist_2(sc, in_val, lst)); +} + +static void op_let_opssq_old(s7_scheme * sc) +{ + s7_pointer let; + op_let_opssq(sc); + let = update_let_with_slot(sc, opt3_let(sc->code), sc->value); + let_set_outlet(let, sc->curlet); + set_curlet(sc, let); + sc->code = T_Pair(cdr(sc->code)); +} + +static void op_let_opssq_new(s7_scheme * sc) +{ + op_let_opssq(sc); + sc->curlet = + make_let_with_slot(sc, sc->curlet, opt1_sym(sc->code), sc->value); + sc->code = T_Pair(cdr(sc->code)); +} + +static void op_let_opssq_e_old(s7_scheme * sc) +{ + s7_pointer let; + op_let_opssq(sc); + let = update_let_with_slot(sc, opt3_let(sc->code), sc->value); + let_set_outlet(let, sc->curlet); + set_curlet(sc, let); + sc->code = cadr(sc->code); +} + +static void op_let_opssq_e_new(s7_scheme * sc) +{ + op_let_opssq(sc); + sc->curlet = + make_let_with_slot(sc, sc->curlet, opt1_sym(sc->code), sc->value); + sc->code = cadr(sc->code); +} + +static void op_let_opassq_old(s7_scheme * sc) +{ + s7_pointer let; + op_let_opassq(sc); + let = update_let_with_slot(sc, opt3_let(sc->code), sc->value); + let_set_outlet(let, sc->curlet); + set_curlet(sc, let); + sc->code = T_Pair(cdr(sc->code)); +} + +static void op_let_opassq_new(s7_scheme * sc) +{ + op_let_opassq(sc); + sc->curlet = + make_let_with_slot(sc, sc->curlet, opt1_sym(sc->code), sc->value); + sc->code = T_Pair(cdr(sc->code)); +} + +static void op_let_opassq_e_old(s7_scheme * sc) +{ + s7_pointer let; + op_let_opassq(sc); + let = update_let_with_slot(sc, opt3_let(sc->code), sc->value); + let_set_outlet(let, sc->curlet); + set_curlet(sc, let); + sc->code = cadr(sc->code); +} + +static void op_let_opassq_e_new(s7_scheme * sc) +{ + op_let_opassq(sc); + sc->curlet = make_let_with_slot(sc, sc->curlet, opt1_sym(sc->code), sc->value); /* caaar(sc->code) = local variable name */ + sc->code = cadr(sc->code); +} + +static Inline void op_let_fx_new(s7_scheme * sc) +{ + s7_pointer p, let; + let = make_simple_let(sc); + sc->args = let; + for (p = cadr(sc->code); is_pair(p); p = cdr(p)) { + s7_pointer arg = cdar(p); + sc->value = fx_call(sc, arg); + add_slot(sc, let, caar(p), sc->value); + } + sc->let_number++; + set_curlet(sc, let); + sc->code = T_Pair(cddr(sc->code)); +} + +static void op_let_fx_old(s7_scheme * sc) +{ + s7_pointer p, slot, let = opt3_let(cdr(sc->code)); + uint64_t id; + sc->args = let; + id = ++sc->let_number; + let_set_id(let, id); + let_set_outlet(let, sc->curlet); + + for (p = cadr(sc->code), slot = let_slots(let); is_pair(p); + p = cdr(p), slot = next_slot(slot)) { + /* GC protected because it's a permanent let? or perhaps use sc->args? */ + slot_set_value(slot, fx_call(sc, cdar(p))); + symbol_set_local_slot_unincremented(slot_symbol(slot), id, slot); + } + set_curlet(sc, let); + sc->code = T_Pair(cddr(sc->code)); +} + +static void op_let_2a_new(s7_scheme * sc) +{ /* 2 vars, 1 expr in body */ + /* opt1|2 free */ + s7_pointer a1, a2, code = cdr(sc->code); + a1 = opt1_pair(code); /* caar(code) */ + a2 = opt2_pair(code); /* cadar(code) */ + sc->curlet = + make_let_with_two_slots(sc, sc->curlet, car(a1), + fx_call(sc, cdr(a1)), car(a2), fx_call(sc, + cdr + (a2))); + sc->code = cadr(code); +} + +static inline void op_let_2a_old(s7_scheme * sc) +{ /* 2 vars, 1 expr in body */ + s7_pointer let, code = cdr(sc->code); + let = + update_let_with_two_slots(sc, opt3_let(code), + fx_call(sc, cdr(opt1_pair(code))), + fx_call(sc, cdr(opt2_pair(code)))); + let_set_outlet(let, sc->curlet); + set_curlet(sc, let); + sc->code = cadr(code); +} + +static void op_let_3a_new(s7_scheme * sc) +{ /* 3 vars, 1 expr in body */ + s7_pointer a1, a2, a3, code = cdr(sc->code); + a1 = caar(code); + a2 = opt1_pair(code); /* cadar */ + a3 = opt2_pair(code); /* caddar */ + sc->curlet = + make_let_with_two_slots(sc, sc->curlet, car(a1), + fx_call(sc, cdr(a1)), car(a2), fx_call(sc, + cdr + (a2))); + add_slot(sc, sc->curlet, car(a3), fx_call(sc, cdr(a3))); + sc->code = cadr(code); +} + +static void op_let_3a_old(s7_scheme * sc) +{ /* 3 vars, 1 expr in body */ + s7_pointer let, code = cdr(sc->code); + let = + update_let_with_three_slots(sc, opt3_let(code), + fx_call(sc, cdr(caar(code))), + fx_call(sc, cdr(opt1_pair(code))), + fx_call(sc, cdr(opt2_pair(code)))); + let_set_outlet(let, sc->curlet); + set_curlet(sc, let); + sc->code = cadr(code); +} + + +/* -------------------------------- let* -------------------------------- */ +static bool check_let_star(s7_scheme * sc) +{ + s7_pointer vars, form = sc->code, code; + bool named_let, fxable = true; + + code = cdr(form); + if (!is_pair(code)) /* (let* . 1) */ + eval_error(sc, "let* variable list is messed up: ~A", 35, form); + if (!is_pair(cdr(code))) /* (let* ()) */ + eval_error(sc, "let* has no body: ~A", 20, form); + + named_let = (is_symbol(car(code))); + + if (named_let) { + if (!is_list(cadr(code))) /* (let* hi #t) */ + eval_error(sc, "let* variable list is messed up: ~A", 35, + form); + if (!is_pair(cddr(code))) { /* (let* hi () . =>) or (let* hi () ) */ + if (is_null(cddr(code))) + eval_error(sc, "named let* has no body: ~A", 26, form); + else + eval_error(sc, "named let* stray dot? ~A", 24, form); + } + if (is_constant_symbol(sc, car(code))) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, cant_bind_immutable_string, form)); + set_local(car(code)); + } else if (!is_list(car(code))) /* (let* x ... ) */ + eval_error(sc, "let* variable declaration value is missing: ~A", + 46, form); + + for (vars = ((named_let) ? cadr(code) : car(code)); is_pair(vars); + vars = cdr(vars)) { + s7_pointer var_and_val, var; + var_and_val = car(vars); + + if (!is_pair(var_and_val)) /* (let* (3) ... */ + eval_error(sc, "let* variable list is messed up? ~A", 35, + var_and_val); + + /* no check for repeated var (unlike lambda* and named let*) */ + if (!(is_pair(cdr(var_and_val)))) { /* (let* ((x . 1))...) */ + if (is_null(cdr(var_and_val))) + eval_error(sc, + "let* variable declaration, but no value?: ~A", + 44, var_and_val); + else + eval_error(sc, + "let* variable declaration is not a proper list?: ~A", + 51, var_and_val); + } + if (!is_null(cddr(var_and_val))) /* (let* ((c 1 2)) ...) */ + eval_error(sc, + "let* variable declaration has more than one value?: ~A", + 54, var_and_val); + + var = car(var_and_val); + + if (!(is_symbol(var))) /* (let* ((3 1)) 1) */ + eval_error(sc, "bad variable ~S in let* (it is not a symbol)", + 44, var); + + if (is_constant_symbol(sc, var)) /* (let* ((pi 3)) ...) */ + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, cant_bind_immutable_string, + var_and_val)); + + if ((named_let) && (symbol_is_in_arg_list(var, cdr(vars)))) /* (let* loop ((a 1) (a 2)) ...) -- added 2-Dec-19 */ + eval_error(sc, + "named let* parameter '~A is used twice in the parameter list", + 60, var); + /* currently (let* ((a 1) (a (+ a 1))) a) is 2, not an error. */ + + set_local(var); + } + if (!is_null(vars)) + eval_error(sc, "let* variable list is not a proper list?: ~A", 44, + vars); + + if (!s7_is_proper_list(sc, cdr(code))) + eval_error(sc, "stray dot in let* body: ~S", 26, cdr(code)); + + for (vars = (named_let) ? cadr(code) : car(code); is_pair(vars); + vars = cdr(vars)) + if (is_fxable(sc, cadar(vars))) + set_fx_direct(cdar(vars), + fx_choose(sc, cdar(vars), sc->curlet, + let_star_symbol_is_safe)); + else + fxable = false; + + if (named_let) { + if (is_null(cadr(code))) { + pair_set_syntax_op(form, OP_NAMED_LET_NO_VARS); + set_opt1_pair(form, cdddr(form)); + } else { + pair_set_syntax_op(form, OP_NAMED_LET_STAR); + set_opt2_con(code, cadr(caadr(code))); + } + } else if (is_null(car(code))) + pair_set_syntax_op(form, OP_LET_NO_VARS); /* (let* () ...) */ + else if (is_null(cdar(code))) { + check_let_one_var(sc, form, car(code)); /* (let* ((var...))...) -> (let ((var...))...) */ + if (optimize_op(form) >= OP_LET_FX_OLD) { + if ((!in_heap(form)) && + (body_is_safe(sc, sc->unused, cdr(code), true) >= + SAFE_BODY)) + set_opt3_let(code, make_permanent_let(sc, car(code))); + else { + set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ + set_opt3_let(code, sc->nil); + } + } + } else { /* multiple variables */ + s7_pointer last_var; + if (fxable) { + pair_set_syntax_op(form, OP_LET_STAR_FX); + if ((is_null(cddr(code))) && (is_fxable(sc, cadr(code)))) { + fx_annotate_arg(sc, cdr(code), sc->curlet); + pair_set_syntax_op(form, OP_LET_STAR_FX_A); + } + } else + pair_set_syntax_op(form, OP_LET_STAR2); + set_opt2_con(code, cadaar(code)); + for (last_var = caaar(code), vars = cdar(code); is_pair(vars); + last_var = caar(vars), vars = cdr(vars)) + if (has_fx(cdar(vars))) + fx_tree(sc, cdar(vars), last_var, NULL, NULL, true); /* actually there's isn't a new let unless it's needed */ + } + + /* let_star_unchecked... */ + if (named_let) { /* (is_symbol(car(code))) */ + sc->value = cdr(code); + if (is_null(car(sc->value))) { + s7_pointer cx = car(code); + sc->curlet = make_let_slowly(sc, sc->curlet); + sc->code = T_Pair(cdr(sc->value)); + add_slot_checked(sc, sc->curlet, cx, + make_closure_unchecked(sc, sc->nil, sc->code, + T_CLOSURE_STAR, 0)); + return (false); + } + } else if (is_null(car(code))) { + sc->curlet = make_let_slowly(sc, sc->curlet); + sc->code = T_Pair(cdr(code)); + return (false); + } + + if (named_let) { /* is_symbol(car(code))) */ + push_stack(sc, OP_LET_STAR1, code, cadr(code)); + sc->code = cadr(caadr(code)); + } else { + push_stack(sc, OP_LET_STAR1, code, car(code)); + /* args is the let body, saved for later, code is the list of vars+initial-values */ + sc->code = cadr(caar(code)); + /* caar(code) = first var/val pair, we've checked that all these guys are legit, so cadr of that is the value */ + } + return (true); +} + +static inline bool op_let_star1(s7_scheme * sc) +{ + uint64_t let_counter = S7_INT64_MAX; + while (true) { + if (let_counter == sc->capture_let_counter) + add_slot_checked(sc, sc->curlet, caar(sc->code), sc->value); + else { + sc->curlet = + make_let_with_slot(sc, sc->curlet, caar(sc->code), + sc->value); + let_counter = sc->capture_let_counter; + } + sc->code = cdr(sc->code); + if (is_pair(sc->code)) { + s7_pointer x = cdar(sc->code); + if (has_fx(x)) + sc->value = fx_call(sc, x); + else { + push_stack_direct(sc, OP_LET_STAR1); + sc->code = car(x); + return (true); + } + } else + break; + } + sc->code = sc->args; /* original sc->code set in push_stack above */ + if (is_symbol(car(sc->code))) { + /* now we need to declare the new function */ + s7_pointer body = cddr(sc->code), args = cadr(sc->code); + add_slot_checked(sc, sc->curlet, car(sc->code), + make_closure_unchecked(sc, args, body, + T_CLOSURE_STAR, + (is_null(args)) ? 0 : + CLOSURE_ARITY_NOT_SET)); + sc->code = body; + } else + sc->code = T_Pair(cdr(sc->code)); + return (false); +} + +static void op_let_star_fx(s7_scheme * sc) +{ + /* fx safe does not mean we can dispense with the inner lets (curlet is safe for example) */ + s7_pointer p; + uint64_t let_counter = S7_INT64_MAX; + sc->code = cdr(sc->code); + for (p = car(sc->code); is_pair(p); p = cdr(p)) { + s7_pointer val; + val = fx_call(sc, cdar(p)); /* eval in outer let */ + if (let_counter == sc->capture_let_counter) + add_slot_checked(sc, sc->curlet, caar(p), val); + else { + sc->curlet = make_let_with_slot(sc, sc->curlet, caar(p), val); + let_counter = sc->capture_let_counter; + } + } + sc->code = T_Pair(cdr(sc->code)); +} + +static void op_let_star_fx_a(s7_scheme * sc) +{ + s7_pointer p; + uint64_t let_counter = S7_INT64_MAX; + sc->code = cdr(sc->code); + for (p = car(sc->code); is_pair(p); p = cdr(p)) { + s7_pointer val; + val = fx_call(sc, cdar(p)); + if (let_counter == sc->capture_let_counter) + add_slot_checked(sc, sc->curlet, caar(p), val); + else { + sc->curlet = make_let_with_slot(sc, sc->curlet, caar(p), val); + let_counter = sc->capture_let_counter; + } + } + sc->value = fx_call(sc, cdr(sc->code)); +} + +static void op_named_let_star(s7_scheme * sc) +{ + s7_pointer code = cdr(sc->code); + push_stack(sc, OP_LET_STAR1, code, cadr(code)); + sc->code = opt2_con(code); +} + +static void op_let_star2(s7_scheme * sc) +{ + s7_pointer code = cdr(sc->code); + push_stack(sc, OP_LET_STAR1, code, car(code)); + sc->code = opt2_con(code); +} + + +/* -------------------------------- letrec, letrec* -------------------------------- */ +static void check_letrec(s7_scheme * sc, bool letrec) +{ + s7_pointer x, caller, code = cdr(sc->code); + caller = (letrec) ? sc->letrec_symbol : sc->letrec_star_symbol; + + if ((!is_pair(code)) || /* (letrec . 1) */ + (!is_list(car(code)))) /* (letrec 1 ...) */ + eval_error_with_caller(sc, "~A: variable list is messed up: ~A", + 34, caller, sc->code); + + if (!is_pair(cdr(code))) /* (letrec ()) */ + eval_error_with_caller(sc, "~A has no body: ~A", 18, caller, + sc->code); + + clear_symbol_list(sc); + for (x = car(code); is_not_null(x); x = cdr(x)) { + s7_pointer y, carx; + if (!is_pair(x)) /* (letrec ((a 1) . 2) ...) */ + eval_error_with_caller(sc, + "~A: improper list of variables? ~A", + 34, caller, sc->code); + + carx = car(x); + if (!is_pair(carx)) /* (letrec (1 2) #t) */ + eval_error_with_caller(sc, + "~A: bad variable ~S (should be a pair (name value))", + 51, caller, carx); + if (!(is_symbol(car(carx)))) + eval_error_with_caller(sc, + "~A: bad variable ~S (it is not a symbol)", + 40, caller, carx); + + y = car(carx); + if (is_constant_symbol(sc, y)) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, cant_bind_immutable_string, x)); + + if (!is_pair(cdr(carx))) { /* (letrec ((x . 1))...) */ + if (is_null(cdr(carx))) /* (letrec ((x)) x) -- perhaps this is legal? */ + eval_error_with_caller(sc, + "~A: variable declaration has no value?: ~A", + 42, caller, carx); + eval_error_with_caller(sc, + "~A: variable declaration is not a proper list?: ~A", + 50, caller, carx); + } + if (is_not_null(cddr(carx))) /* (letrec ((x 1 2 3)) ...) */ + eval_error_with_caller(sc, + "~A: variable declaration has more than one value?: ~A", + 53, caller, carx); + + /* check for name collisions -- this is needed in letrec* else which of the two legit values does our "rec" refer to, so to speak */ + if (symbol_is_in_list(sc, y)) + eval_error_with_caller(sc, "~A: duplicate identifier: ~A", 28, + caller, y); + add_symbol_to_list(sc, y); + set_local(y); + } + + if (!s7_is_proper_list(sc, cdr(code))) + eval_error_with_caller(sc, "stray dot in ~A body: ~S", 24, caller, + cdr(code)); + + for (x = car(code); is_pair(x); x = cdr(x)) + if (is_fxable(sc, cadar(x))) + set_fx_direct(cdar(x), + fx_choose(sc, cdar(x), sc->curlet, + let_symbol_is_safe_or_listed)); + + pair_set_syntax_op(sc->code, + (letrec) ? OP_LETREC_UNCHECKED : + OP_LETREC_STAR_UNCHECKED); +} + +static s7_pointer make_funclet(s7_scheme * sc, s7_pointer new_func, + s7_pointer func_name, s7_pointer outer_let); + +static void letrec_setup_closures(s7_scheme * sc) +{ + s7_pointer slot; + for (slot = let_slots(sc->curlet); tis_slot(slot); + slot = next_slot(slot)) + if (is_closure(slot_value(slot))) { + s7_pointer func = slot_value(slot); + if ((!is_safe_closure(func)) || + (!is_optimized(car(closure_body(func))))) + optimize_lambda(sc, true, slot_symbol(slot), + closure_args(func), closure_body(func)); + if (is_safe_closure_body(closure_body(func))) { + set_safe_closure(func); + if (is_very_safe_closure_body(closure_body(func))) + set_very_safe_closure(func); + } + make_funclet(sc, func, slot_symbol(slot), closure_let(func)); + /* else closure_set_let(new_func, sc->curlet); -- maybe funclet not needed here? */ + } +} + +static void op_letrec2(s7_scheme * sc) +{ + s7_pointer slot; + for (slot = let_slots(sc->curlet); tis_slot(slot); + slot = next_slot(slot)) + if (is_checked_slot(slot)) + slot_set_value(slot, slot_pending_value(slot)); + letrec_setup_closures(sc); +} + +static bool op_letrec_unchecked(s7_scheme * sc) +{ + s7_pointer code = cdr(sc->code); + /* get all local vars and set to # + * get parallel list of values + * eval each member of values list with let still full of #'s + * assign each value to its variable + * eval body + * which means that (letrec ((x x)) x) is not an error! + * but this assumes the environment is not changed by evaluating the exprs? + * (letrec ((a (define b 1))) b) -- if let, the define takes place in the calling let, not the current let + * (letrec ((f1 (lambda (x) (f2 (* 2 x))))) (define (f2 y) (- y 1)) (f1 3)) -> 5 (Guile says unbound f2) + * I think I need to check here that slot_pending_value is set (using the is_checked bit below): + * (letrec ((i (begin (define xyz 37) 0))) (curlet)): (inlet 'i 0 'xyz 37) -- is this correct? + */ + sc->curlet = make_let_slowly(sc, sc->curlet); + if (is_pair(car(code))) { + s7_pointer x, slot; + for (x = car(code); is_not_null(x); x = cdr(x)) { + slot = + add_slot_checked(sc, sc->curlet, caar(x), sc->undefined); + slot_set_pending_value(slot, sc->undefined); + slot_set_expression(slot, cdar(x)); + set_checked_slot(slot); + } + for (slot = let_slots(sc->curlet); + tis_slot(slot) && (has_fx(slot_expression(slot))); + slot = next_slot(slot)) + slot_set_pending_value(slot, + fx_call(sc, slot_expression(slot))); + if (tis_slot(slot)) { + push_stack(sc, OP_LETREC1, slot, code); + sc->code = car(slot_expression(slot)); + return (true); + } + op_letrec2(sc); + } + sc->code = T_Pair(cdr(code)); + return (false); +} + +static bool op_letrec1(s7_scheme * sc) +{ + s7_pointer slot; + slot_set_pending_value(sc->args, sc->value); + for (slot = next_slot(sc->args); + tis_slot(slot) && (has_fx(slot_expression(slot))); + slot = next_slot(slot)) + slot_set_pending_value(slot, fx_call(sc, slot_expression(slot))); + if (tis_slot(slot)) { + push_stack(sc, OP_LETREC1, slot, sc->code); + sc->code = car(slot_expression(slot)); + return (true); + } + op_letrec2(sc); + sc->code = T_Pair(cdr(sc->code)); + return (false); +} + + +static bool op_letrec_star_unchecked(s7_scheme * sc) +{ + s7_pointer slot, code = cdr(sc->code); + /* get all local vars and set to # + * eval each member of values list and assign immediately, as in let* + * eval body + */ + sc->curlet = make_let_slowly(sc, sc->curlet); + if (is_pair(car(code))) { + s7_pointer x; + for (x = car(code); is_not_null(x); x = cdr(x)) { + slot = + add_slot_checked(sc, sc->curlet, caar(x), sc->undefined); + slot_set_expression(slot, cdar(x)); + } + let_set_slots(sc->curlet, + reverse_slots(sc, let_slots(sc->curlet))); + + for (slot = let_slots(sc->curlet); + tis_slot(slot) && (has_fx(slot_expression(slot))); + slot = next_slot(slot)) + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + if (tis_slot(slot)) { + push_stack(sc, OP_LETREC_STAR1, slot, code); + sc->code = car(slot_expression(slot)); + return (true); + } + } + sc->code = T_Pair(cdr(code)); + return (false); +} + +static bool op_letrec_star1(s7_scheme * sc) +{ + s7_pointer slot = sc->args; + slot_set_value(slot, sc->value); + + for (slot = next_slot(slot); + tis_slot(slot) && (has_fx(slot_expression(slot))); + slot = next_slot(slot)) + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + if (tis_slot(slot)) { + push_stack(sc, OP_LETREC_STAR1, slot, sc->code); + sc->code = car(slot_expression(slot)); + return (true); + } + letrec_setup_closures(sc); + sc->code = T_Pair(cdr(sc->code)); + return (false); +} + + +/* -------------------------------- let-temporarily -------------------------------- */ +static void check_let_temporarily(s7_scheme * sc) +{ + s7_pointer x, form = sc->code, code; + bool all_fx, all_s7; + code = cdr(form); + + if ((!is_pair(code)) || /* (let-temporarily . 1) */ + (!is_list(car(code)))) /* (let-temporarily 1 ...) */ + eval_error(sc, "let-temporarily: variable list is messed up: ~A", + 47, form); + /* cdr(code) = body can be nil */ + + all_fx = is_pair(car(code)); + all_s7 = all_fx; + + for (x = car(code); is_not_null(x); x = cdr(x)) { + s7_pointer carx; + if (!is_pair(x)) /* (let-temporarily ((a 1) . 2) ...) */ + eval_error(sc, + "let-temporarily: improper list of variables? ~A", + 47, form); + + carx = car(x); + if (!is_pair(carx)) /* (let-temporarily (1 2) #t) */ + eval_error(sc, + "let-temporarily: bad variable ~S (it should be a pair (name value))", + 67, carx); + + if (is_symbol(car(carx))) { + if (is_constant_symbol(sc, car(carx))) /* (let-temporarily ((pi 3)) ...) */ + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, cant_bind_immutable_string, x)); + if (is_syntactic_symbol(car(carx))) /* (let-temporarily ((if 3)) ...) */ + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, + wrap_string(sc, "can't set! ~A", 13), + car(carx))); + } else if (!is_pair(car(carx))) /* (let-temporarily ((1 2)) ...) */ + eval_error(sc, + "let-temporarily: bad variable ~S (the name should be a symbol or a pair)", + 73, carx); + + if (!is_pair(cdr(carx))) /* (let-temporarily ((x . 1))...) */ + eval_error(sc, + "let-temporarily: variable declaration value is messed up: ~S", + 60, carx); + + if (is_not_null(cddr(carx))) /* (let-temporarily ((x 1 2 3)) ...) */ + eval_error(sc, + "let-temporarily: variable declaration has more than one value?: ~A", + 66, carx); + + if ((all_fx) && + ((!is_symbol(car(carx))) || (!is_fxable(sc, cadr(carx))))) + all_fx = false; + if ((all_s7) && + ((!is_pair(car(carx))) || (caar(carx) != sc->s7_let_symbol) || + (!is_quoted_symbol(cadar(carx))) + || (is_keyword(cadr(cadar(carx)))) + || (!is_fxable(sc, cadr(carx))))) + all_s7 = false; + } + if (!s7_is_proper_list(sc, cdr(code))) + eval_error(sc, "stray dot in let-temporarily body: ~S", 37, + cdr(code)); + + if ((all_fx) || (all_s7)) { + pair_set_syntax_op(form, + (all_fx) ? ((is_null(cdar(code))) ? + OP_LET_TEMP_FX_1 : OP_LET_TEMP_FX) : + OP_LET_TEMP_S7); + for (x = car(code); is_pair(x); x = cdr(x)) + fx_annotate_arg(sc, cdar(x), sc->curlet); + + if ((optimize_op(form) == OP_LET_TEMP_FX_1) && (is_pair(cdr(code))) + && (is_null(cddr(code))) && (is_fxable(sc, cadr(code)))) { + fx_annotate_arg(sc, cdr(code), sc->curlet); + pair_set_syntax_op(form, OP_LET_TEMP_A_A); + } + } else { + pair_set_syntax_op(form, OP_LET_TEMP_UNCHECKED); + if ((is_pair(car(code))) && (is_null(cdar(code))) + && (is_pair(caar(code)))) { + s7_pointer var = caar(code), val; + val = cadr(var); + var = car(var); + if ((is_pair(var)) && (car(var) == sc->setter_symbol) + && (is_pair(cdr(var))) && (is_pair(cddr(var))) + && (val == sc->F)) { + optimize_expression(sc, cadr(var), 0, sc->curlet, false); + optimize_expression(sc, caddr(var), 0, sc->curlet, false); + if ((is_fxable(sc, cadr(var))) + && (is_fxable(sc, caddr(var)))) { + fx_annotate_args(sc, cdr(var), sc->curlet); + pair_set_syntax_op(form, OP_LET_TEMP_SETTER); + } + } + } + } +} + +static void op_let_temp_unchecked(s7_scheme * sc) +{ + sc->code = cdr(sc->code); /* step past let-temporarily */ + sc->args = list_4(sc, car(sc->code), sc->nil, sc->nil, sc->nil); + push_stack_direct(sc, OP_GC_PROTECT); + /* sc->args: varlist, settees, old_values, new_values */ +} + +static bool op_let_temp_init1(s7_scheme * sc) +{ + while (is_pair(car(sc->args))) { + /* eval car, add result to old-vals list, if any vars undefined, error */ + s7_pointer binding = caar(sc->args), settee, new_value; + settee = car(binding); + new_value = cadr(binding); + cadr(sc->args) = cons(sc, settee, cadr(sc->args)); + binding = cdddr(sc->args); + set_car(binding, cons_unchecked(sc, new_value, car(binding))); + car(sc->args) = cdar(sc->args); + if (is_symbol(settee)) /* get initial values */ + set_caddr(sc->args, + cons_unchecked(sc, lookup_checked(sc, settee), + caddr(sc->args))); + else { + if (is_pair(settee)) { + push_stack_direct(sc, OP_LET_TEMP_INIT1); + sc->code = settee; + return (true); + } + set_caddr(sc->args, + cons_unchecked(sc, new_value, caddr(sc->args))); + } + } + car(sc->args) = cadr(sc->args); + return (false); +} + +typedef enum { goto_start, goto_begin, fall_through, goto_do_end_clauses, + goto_safe_do_end_clauses, + goto_eval, goto_apply_lambda, goto_do_end, goto_top_no_pop, goto_apply, + goto_eval_args, goto_eval_args_top, goto_do_unchecked, + goto_pop_read_list, + goto_read_tok, goto_feed_to +} goto_t; + +static goto_t op_let_temp_init2(s7_scheme * sc) +{ + /* now eval set car new-val, cadr=settees, cadddr=new_values */ + while (is_pair(car(sc->args))) { + s7_pointer settee = caar(sc->args), new_value, slot, p = + cdddr(sc->args); + new_value = caar(p); + set_car(p, cdar(p)); + car(sc->args) = cdar(sc->args); + if ((!is_symbol(settee)) || (is_pair(new_value))) { + if (is_symbol(settee)) { + push_stack_direct(sc, OP_LET_TEMP_INIT2); /* (let-temporarily (((*s7* 'print-length) 32)) ...) */ + push_stack_no_args(sc, OP_SET_FROM_LET_TEMP, settee); + sc->code = new_value; + return (goto_eval); + } + sc->code = set_plist_3(sc, sc->set_symbol, settee, new_value); + push_stack_direct(sc, OP_EVAL_DONE); + eval(sc, OP_SET_UNCHECKED); + continue; + } + slot = lookup_slot_from(settee, sc->curlet); + if (!is_slot(slot)) + unbound_variable_error(sc, settee); + if (is_immutable_slot(slot)) + immutable_object_error(sc, + set_elist_3(sc, immutable_error_string, + sc->let_temporarily_symbol, + settee)); + if (is_symbol(new_value)) + new_value = lookup_checked(sc, new_value); + /* if ((symbol_has_setter(settee)) && (!slot_has_setter(slot))) settee is local with no setter, but its global binding does have a setter */ + if (slot_has_setter(slot)) + slot_set_value(slot, call_setter(sc, slot, new_value)); + else + slot_set_value(slot, new_value); + } + car(sc->args) = cadr(sc->args); + pop_stack(sc); + sc->code = cdr(sc->code); + if (is_pair(sc->code)) { + push_stack_direct(sc, OP_LET_TEMP_DONE); + return (goto_begin); + } + sc->value = sc->nil; /* so (let-temporarily ( () like begin I guess */ + return (fall_through); +} + +static bool op_let_temp_done1(s7_scheme * sc) +{ + while (is_pair(car(sc->args))) { + s7_pointer settee = caar(sc->args), p = cddr(sc->args); + sc->value = caar(p); + set_car(p, cdar(p)); + car(sc->args) = cdar(sc->args); + + if ((is_pair(settee)) && (car(settee) == sc->s7_let_symbol) && /* (let-temporarily (((*s7* (symbol "print-length")) 43))...) */ + ((is_keyword(cadr(settee))) || ((is_pair(cadr(settee))) + && (caadr(settee) == + sc->quote_symbol) + && + (is_symbol(cadadr(settee)))))) + { + s7_pointer sym = cadr(settee); + if (is_pair(sym)) + sym = cadr(sym); + g_s7_let_set_fallback(sc, + set_plist_3(sc, sc->s7_let, sym, + sc->value)); + } else { + s7_pointer slot; + if (!is_symbol(settee)) { + if ((is_pair(sc->value)) || (is_symbol(sc->value))) + sc->code = + set_plist_3(sc, sc->set_symbol, settee, + set_plist_2(sc, sc->quote_symbol, + sc->value)); + else + sc->code = + set_plist_3(sc, sc->set_symbol, settee, sc->value); + push_stack_direct(sc, OP_EVAL_DONE); + eval(sc, OP_SET_UNCHECKED); + continue; + } + slot = lookup_slot_from(settee, sc->curlet); + if (is_immutable_slot(slot)) + immutable_object_error(sc, + set_elist_3(sc, + immutable_error_string, + sc->let_temporarily_symbol, + settee)); + if (slot_has_setter(slot)) /* maybe setter changed in let-temp body? else setter has already checked the init value */ + slot_set_value(slot, call_setter(sc, slot, sc->value)); + else + slot_set_value(slot, sc->value); + } + } + pop_stack(sc); /* remove the gc_protect */ + sc->value = sc->code; + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return (true); /* goto start */ +} + +static bool op_let_temp_s7(s7_scheme * sc) +{ /* all entries are of the form ((*s7* 'field) fx-able-value) */ + s7_pointer p; + s7_pointer *end = sc->stack_end; + sc->code = cdr(sc->code); + for (p = car(sc->code); is_pair(p); p = cdr(p)) { + s7_pointer old_value, field = cadadr(caar(p)); /* p: (((*s7* 'expansions?) #f)) -- no keywords here (see check_let_temporarily) */ + old_value = + g_s7_let_ref_fallback(sc, set_plist_2(sc, sc->s7_let, field)); + push_stack(sc, OP_LET_TEMP_S7_UNWIND, old_value, field); + } + for (p = car(sc->code); is_pair(p); p = cdr(p), end += 4) + g_s7_let_set_fallback(sc, + set_plist_3(sc, sc->s7_let, end[0], + fx_call(sc, cdar(p)))); + sc->code = cdr(sc->code); + return (is_pair(sc->code)); /* sc->code can be null if no body */ +} + +static void let_temp_done(s7_scheme * sc, s7_pointer args, s7_pointer code, + s7_pointer let) +{ + /* called in call/cc, call-with-exit and, catch (unwind to catch) */ + /* check_stack_size(sc); *//* 4-May-21 t101 36/38, but this is an infinite loop if stack resize raises an error (hit if eval is passed a circular list!) */ + push_stack_direct(sc, OP_EVAL_DONE); + sc->args = T_Pos(args); + sc->code = code; + set_curlet(sc, let); + eval(sc, OP_LET_TEMP_DONE); +} + +static void let_temp_unwind(s7_scheme * sc, s7_pointer slot, + s7_pointer new_value) +{ + if (slot_has_setter(slot)) { /* setter has to be called because it might affect other vars (*clm-srate* -> mus-srate etc), but it should not change sc->value */ + s7_pointer old_value = sc->value; + slot_set_value(slot, call_setter(sc, slot, new_value)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, slot_symbol(slot), new_value))); */ + sc->value = old_value; + } else + slot_set_value(slot, new_value); +} + +static bool op_let_temp_fx(s7_scheme * sc) +{ /* all entries are of the form (symbol fx-able-value) */ + s7_pointer p, var, settee, new_val, slot; + s7_pointer *end = sc->stack_end; + sc->code = cdr(sc->code); + + for (p = car(sc->code); is_pair(p); p = cdr(p)) { + var = car(p); + settee = car(var); + slot = lookup_slot_from(settee, sc->curlet); + if (!is_slot(slot)) + unbound_variable_error(sc, settee); + if (is_immutable_slot(slot)) + immutable_object_error(sc, + set_elist_3(sc, immutable_error_string, + sc->let_temporarily_symbol, + settee)); + push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot); + } + for (p = car(sc->code); is_pair(p); p = cdr(p), end += 4) { + var = car(p); + settee = car(var); + new_val = fx_call(sc, cdr(var)); + slot = end[0]; + if (slot_has_setter(slot)) + slot_set_value(slot, call_setter(sc, slot, new_val)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); */ + else + slot_set_value(slot, new_val); + } + sc->code = cdr(sc->code); + return (is_pair(sc->code)); /* sc->code can be null if no body */ +} + +static bool op_let_temp_fx_1(s7_scheme * sc) +{ /* one entry */ + s7_pointer var, settee, new_val, slot; + sc->code = cdr(sc->code); + var = caar(sc->code); + settee = car(var); + slot = lookup_slot_from(settee, sc->curlet); + if (!is_slot(slot)) + unbound_variable_error(sc, settee); + if (is_immutable_slot(slot)) + immutable_object_error(sc, + set_elist_3(sc, immutable_error_string, + sc->let_temporarily_symbol, + settee)); + push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot); + new_val = fx_call(sc, cdr(var)); + if (slot_has_setter(slot)) + slot_set_value(slot, call_setter(sc, slot, new_val)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); */ + else + slot_set_value(slot, new_val); + sc->code = cdr(sc->code); + return (is_pair(sc->code)); /* sc->code can be null if no body */ +} + +static s7_pointer fx_let_temp_a_a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer result; + op_let_temp_fx_1(sc); + result = fx_call(sc, sc->code); + pop_stack(sc); + let_temp_unwind(sc, sc->code, sc->args); + return (result); +} + +static bool op_let_temp_setter(s7_scheme * sc) +{ + s7_pointer var, slot, sym, e; + sc->code = cdr(sc->code); + var = caaar(sc->code); + sym = fx_call(sc, cdr(var)); + e = sc->curlet; + set_curlet(sc, fx_call(sc, cddr(var))); + slot = lookup_slot_from(sym, sc->curlet); + set_curlet(sc, e); + push_stack(sc, OP_LET_TEMP_SETTER_UNWIND, slot_setter(slot), slot); + slot_set_setter(slot, sc->F); + sc->code = cdr(sc->code); + return (is_pair(sc->code)); /* sc->code can be null if no body */ +} + +static void op_let_temp_unwind(s7_scheme * sc) +{ + let_temp_unwind(sc, sc->code, sc->args); + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); +} + +static void op_let_temp_s7_unwind(s7_scheme * sc) +{ + g_s7_let_set_fallback(sc, + set_plist_3(sc, sc->s7_let, sc->code, sc->args)); + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); +} + +static void op_let_temp_setter_unwind(s7_scheme * sc) +{ + slot_set_setter(sc->code, sc->args); + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); +} + + +/* -------------------------------- quote -------------------------------- */ +static inline s7_pointer check_quote(s7_scheme * sc, s7_pointer code) +{ + if (!is_pair(cdr(code))) { /* (quote . -1) */ + if (is_null(cdr(code))) + eval_error(sc, "quote: not enough arguments: ~A", 31, code); + eval_error(sc, "quote: stray dot?: ~A", 21, code); + } + if (is_not_null(cddr(code))) /* (quote . (1 2)) or (quote 1 1) */ + eval_error(sc, "quote: too many arguments ~A", 28, code); + pair_set_syntax_op(code, OP_QUOTE_UNCHECKED); + return (cadr(code)); +} + + +/* -------------------------------- and -------------------------------- */ +static bool check_and(s7_scheme * sc, s7_pointer expr) +{ + /* this and check_or and check_if might not be called -- optimize_syntax can short-circuit it to return fx* choices */ + s7_pointer p, code = cdr(expr); + int32_t any_nils = 0, len; + + if (is_null(code)) { + sc->value = sc->T; + return (true); + } + for (len = 0, p = code; is_pair(p); p = cdr(p), len++) { + s7_function callee; + callee = (has_fx(p)) ? fx_proc(p) : fx_choose(sc, p, sc->curlet, let_symbol_is_safe); /* fx_proc can be nil! */ + if (!callee) + any_nils++; + set_fx(p, callee); + } + if (is_not_null(p)) /* (and . 1) (and #t . 1) */ + eval_error(sc, "and: stray dot?: ~A", 19, expr); + + if ((fx_proc(code)) && (is_proper_list_1(sc, cdr(code)))) { + if ((fx_proc(code) == fx_is_pair_s) + || (fx_proc(code) == fx_is_pair_t)) { + pair_set_syntax_op(expr, OP_AND_PAIR_P); + set_opt3_sym(expr, cadar(code)); + set_opt2_con(expr, cadr(code)); + } else + pair_set_syntax_op(expr, + (any_nils > 0) ? OP_AND_AP : OP_AND_2A); + } else { + pair_set_syntax_op(expr, (any_nils > 0) ? OP_AND_P : OP_AND_N); + if ((any_nils == 1) && (len > 2)) { + if (!has_fx(code)) + pair_set_syntax_op(expr, OP_AND_SAFE_P1); + else if (!has_fx(cdr(code))) + pair_set_syntax_op(expr, OP_AND_SAFE_P2); + else if ((!has_fx(cddr(code))) && (len == 3)) + pair_set_syntax_op(expr, OP_AND_SAFE_P3); + } + } + return (false); +} + +static bool op_and_pair_p(s7_scheme * sc) +{ + if (!is_pair(lookup(sc, opt3_sym(sc->code)))) { /* cadadr(sc->code) */ + sc->value = sc->F; + return (true); + } + sc->code = opt2_con(sc->code); /* caddr(sc->code); */ + return (false); +} + +static bool op_and_ap(s7_scheme * sc) +{ + /* we know fx_proc is set on sc->code, and there are only two branches */ + if (is_false(sc, fx_call(sc, cdr(sc->code)))) { + sc->value = sc->F; + return (true); + } + sc->code = caddr(sc->code); + return (false); +} + +static void op_and_safe_p1(s7_scheme * sc) +{ /* sc->code: (and (func...) (fx...)...) */ + sc->code = cdr(sc->code); /* new value will be pushed below */ + push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST); + sc->code = car(sc->code); +} + +static bool op_and_safe_p2(s7_scheme * sc) +{ + sc->value = fx_call(sc, cdr(sc->code)); + if (is_false(sc, sc->value)) + return (true); + sc->code = cddr(sc->code); + push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST); + sc->code = car(sc->code); + return (false); +} + +static bool op_and_safe_p3(s7_scheme * sc) +{ + sc->value = fx_call(sc, cdr(sc->code)); + if (is_false(sc, sc->value)) + return (true); + sc->code = cddr(sc->code); + sc->value = fx_call(sc, sc->code); + if (is_false(sc, sc->value)) + return (true); + sc->code = cadr(sc->code); + return (false); +} + + +/* -------------------------------- or -------------------------------- */ +static bool check_or(s7_scheme * sc, s7_pointer expr) +{ + s7_pointer p, code = cdr(expr); + bool any_nils = false; + + if (is_null(code)) { + sc->value = sc->F; + return (true); + } + + for (p = code; is_pair(p); p = cdr(p)) { + s7_function callee; + callee = + (has_fx(p)) ? fx_proc(p) : fx_choose(sc, p, sc->curlet, + let_symbol_is_safe); + if (!callee) + any_nils = true; + set_fx(p, callee); + } + if (is_not_null(p)) + eval_error(sc, "or: stray dot?: ~A", 18, expr); + + if ((fx_proc(code)) && (is_proper_list_1(sc, cdr(code)))) /* list_1 of cdr so there are 2 exprs */ + pair_set_syntax_op(expr, (any_nils) ? OP_OR_AP : OP_OR_2A); + else + pair_set_syntax_op(expr, (any_nils) ? OP_OR_P : OP_OR_N); + return (false); +} + +static bool op_or_ap(s7_scheme * sc) +{ + /* we know fx_proc is set on sc->code, and there are only two branches */ + sc->value = fx_call(sc, cdr(sc->code)); + if (is_true(sc, sc->value)) + return (true); + sc->code = caddr(sc->code); + return (false); +} + + +/* -------------------------------- if -------------------------------- */ + +static void fx_safe_closure_tree(s7_scheme * sc) +{ + s7_pointer e = sc->curlet; + if ((is_let(e)) && /* e might be sc->nil */ + (is_funclet(e)) && (tis_slot(let_slots(e)))) { /* let_slots might be NULL */ + s7_pointer f; + f = lookup(sc, funclet_function(e)); + if (is_safe_closure(f)) { + s7_pointer slot1 = let_slots(e), slot2; + slot2 = next_slot(slot1); + fx_tree(sc, closure_body(f), + slot_symbol(slot1), + (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, + ((tis_slot(slot2)) + && (tis_slot(next_slot(slot2)))) ? + slot_symbol(next_slot(slot2)) : NULL, + ((tis_slot(slot2)) && (tis_slot(next_slot(slot2))))); + } + } +} + +static void fb_annotate(s7_scheme * sc, s7_pointer form, s7_function fx, + opcode_t op) +{ + s7_pointer bfunc; + bfunc = fx_to_fb(sc, fx); + if (bfunc) { + set_opt3_any(cdr(form), bfunc); + pair_set_syntax_op(form, op); + } +#if 0 + else + fprintf(stderr, "%s %s: %s\n", op_names[op], + op_names[optimize_op + ((op == + OP_IF_B_N_N) ? cadadr(form) : cadr(form))], + display_80(form)); +#endif +} + +#define choose_if_optc(Opc, One, Reversed, Not) ((One) ? ((Reversed) ? OP_ ## Opc ## _R : ((Not) ? OP_ ## Opc ## _N : OP_ ## Opc ## _P)) : ((Not) ? OP_ ## Opc ## _N_N : OP_ ## Opc ## _P_P)) + +static void set_if_opts(s7_scheme * sc, s7_pointer form, bool one_branch, + bool reversed) +{ /* cdr(form) == sc->code */ + s7_pointer test, code = cdr(form); + bool not_case = false; + + test = car(code); + if ((!reversed) && (is_pair(test)) && (car(test) == sc->not_symbol)) { + if (!is_proper_list_1(sc, cdr(test))) + return; /* (not) or (not a b) */ + not_case = true; + test = cadr(test); + } + + set_opt1_any(form, cadr(code)); + if (!one_branch) + set_opt2_any(form, caddr(code)); + + if (is_pair(test)) { + if (is_optimized(test)) { + if (is_h_safe_c_d(test)) { /* replace these with fx_and* */ + pair_set_syntax_op(form, + choose_if_optc(IF_A, one_branch, + reversed, not_case)); + if (not_case) { + set_fx(cdar(code), + fx_choose(sc, cdar(code), sc->curlet, + let_symbol_is_safe)); + if (!reversed) + set_opt3_pair(form, cdadr(form)); + } else + set_fx(code, + fx_choose(sc, code, sc->curlet, + let_symbol_is_safe)); + return; + } + if ((is_h_safe_c_s(test)) && (is_symbol(car(test)))) { + uint8_t typ; + typ = symbol_type(car(test)); + if (typ > 0) { + pair_set_syntax_op(form, + choose_if_optc(IF_IS_TYPE_S, + one_branch, reversed, + not_case)); + set_opt3_byte(code, typ); + + if ((optimize_op(form) == OP_IF_IS_TYPE_S_P_P) && + (is_fxable(sc, caddr(code)))) { + set_opt2_pair(form, cddr(code)); + if (is_fxable(sc, cadr(code))) { + fx_annotate_arg(sc, cdr(code), sc->curlet); + pair_set_syntax_op(form, OP_IF_IS_TYPE_S_A_A); + } else + pair_set_syntax_op(form, OP_IF_IS_TYPE_S_P_A); + fx_annotate_arg(sc, cddr(code), sc->curlet); + fx_safe_closure_tree(sc); + } + } else { + pair_set_syntax_op(form, + choose_if_optc(IF_opSq, one_branch, + reversed, not_case)); + if (not_case) + set_opt1_pair(code, cadar(code)); /* code is cdr(if...): ((not (f sym)) ...) */ + } + clear_has_fx(code); + set_opt2_sym(code, cadr(test)); + return; + } + if (is_fxable(sc, test)) { + if (optimize_op(test) == OP_OR_2A) { + pair_set_syntax_op(form, + choose_if_optc(IF_OR2, one_branch, + reversed, not_case)); + clear_has_fx(code); + set_opt2_pair(code, cdr(test)); + set_opt3_pair(code, cddr(test)); + return; + } + if (optimize_op(test) == OP_AND_2A) { + pair_set_syntax_op(form, + choose_if_optc(IF_AND2, one_branch, + reversed, not_case)); + clear_has_fx(code); + set_opt2_pair(code, cdr(test)); + set_opt3_pair(code, cddr(test)); + return; + } + if (optimize_op(test) == OP_AND_3A) { + pair_set_syntax_op(form, + choose_if_optc(IF_AND3, one_branch, + reversed, not_case)); + clear_has_fx(code); + set_opt2_pair(code, cdr(test)); + set_opt3_pair(code, cddr(test)); + set_opt1_pair(code, cdddr(test)); + return; + } + + pair_set_syntax_op(form, + choose_if_optc(IF_A, one_branch, + reversed, not_case)); + if (not_case) { + set_fx_direct(cdar(code), + fx_choose(sc, cdar(code), sc->curlet, + let_symbol_is_safe)); + if (!reversed) + set_opt3_pair(form, cdadr(form)); + } else + set_fx_direct(code, + fx_choose(sc, code, sc->curlet, + let_symbol_is_safe)); + + if (optimize_op(form) == OP_IF_A_P) { + if (is_fxable(sc, cadr(code))) { + pair_set_syntax_op(form, OP_IF_A_A); + fx_annotate_arg(sc, cdr(code), sc->curlet); + set_opt1_pair(form, cdr(code)); + fx_safe_closure_tree(sc); + fb_annotate(sc, form, fx_proc(code), OP_IF_B_A); + } else + fb_annotate(sc, form, fx_proc(code), OP_IF_B_P); + } + if (optimize_op(form) == OP_IF_A_R) + fb_annotate(sc, form, fx_proc(code), OP_IF_B_R); + if (optimize_op(form) == OP_IF_A_N_N) + fb_annotate(sc, form, fx_proc(cdar(code)), + OP_IF_B_N_N); + if (optimize_op(form) == OP_IF_A_P_P) { + if (is_fxable(sc, cadr(code))) { + set_opt1_pair(form, cdr(code)); + if (is_fxable(sc, caddr(code))) { + pair_set_syntax_op(form, OP_IF_A_A_A); /* b_a_a never happens? */ + set_opt2_pair(form, cddr(code)); + } else { + pair_set_syntax_op(form, OP_IF_A_A_P); + fb_annotate(sc, form, fx_proc(code), + OP_IF_B_A_P); + } + fx_annotate_args(sc, cdr(code), sc->curlet); + fx_safe_closure_tree(sc); + } else if (is_fxable(sc, caddr(code))) { + pair_set_syntax_op(form, OP_IF_A_P_A); + fx_annotate_args(sc, cdr(code), sc->curlet); + set_opt2_pair(form, cddr(code)); + fx_safe_closure_tree(sc); + fb_annotate(sc, form, fx_proc(code), OP_IF_B_P_A); + } else + fb_annotate(sc, form, fx_proc(code), OP_IF_B_P_P); + } + } else { + pair_set_syntax_op(form, + choose_if_optc(IF_P, one_branch, + reversed, not_case)); + set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); + set_opt3_any(code, (not_case) ? cadar(code) : car(code)); + } + } else { + pair_set_syntax_op(form, + choose_if_optc(IF_P, one_branch, reversed, + not_case)); + clear_has_fx(code); + set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); + set_opt3_any(code, (not_case) ? cadar(code) : car(code)); + if (is_symbol_and_syntactic(car(test))) { + pair_set_syntax_op(test, symbol_syntax_op_checked(test)); + if ((symbol_syntax_op(car(test)) == OP_AND) || + (symbol_syntax_op(car(test)) == OP_OR)) { + opcode_t new_op; + if (symbol_syntax_op(car(test)) == OP_AND) + check_and(sc, test); + else + check_or(sc, test); + new_op = symbol_syntax_op_checked(test); + if ((new_op == OP_AND_P) || (new_op == OP_AND_AP) + || (new_op == OP_AND_PAIR_P) + || (new_op == OP_AND_N) + || (new_op == OP_AND_SAFE_P1) + || (new_op == OP_AND_SAFE_P2) + || (new_op == OP_AND_SAFE_P3)) { + pair_set_syntax_op(form, + choose_if_optc(IF_ANDP, + one_branch, + reversed, + not_case)); + set_opt2_any(code, + (one_branch) ? cadr(code) : + cdr(code)); + set_opt3_pair(code, + (not_case) ? cdadar(code) : + cdar(code)); + } else if ((new_op == OP_OR_P) || (new_op == OP_OR_AP)) { + pair_set_syntax_op(form, + choose_if_optc(IF_ORP, + one_branch, + reversed, + not_case)); + set_opt2_any(code, + (one_branch) ? cadr(code) : + cdr(code)); + set_opt3_pair(code, + (not_case) ? cdadar(code) : + cdar(code)); + } + } + } + } + } else /* test is symbol or constant, but constant here is nutty */ + if (is_safe_symbol(test)) { + pair_set_syntax_op(form, + choose_if_optc(IF_S, one_branch, reversed, + not_case)); + if (not_case) + set_opt1_sym(code, cadar(code)); /* code is cdr(if...): ((not sym) ...) */ + if ((optimize_op(form) == OP_IF_S_P_P) && + (is_fxable(sc, caddr(code)))) { + pair_set_syntax_op(form, OP_IF_S_P_A); + fx_annotate_arg(sc, cddr(code), sc->curlet); + set_opt2_pair(form, cddr(code)); + fx_safe_closure_tree(sc); + } + } +} + +/* (cond <> (else <>)) only happens in old-fashioned code, so set_if_opts covers if/when/unless but not cond */ + +static s7_pointer check_if(s7_scheme * sc, s7_pointer form) +{ + s7_pointer cdr_code, code = cdr(form); + if (!is_pair(code)) /* (if) or (if . 1) */ + eval_error(sc, "(if): if needs at least 2 expressions: ~A", 41, + form); + + cdr_code = cdr(code); + if (!is_pair(cdr_code)) /* (if 1) */ + eval_error(sc, "~S: if needs another clause", 27, form); + + if (is_pair(cdr(cdr_code))) { + if (is_not_null(cddr(cdr_code))) /* (if 1 2 3 4) */ + eval_error(sc, "too many clauses for if: ~A", 27, form); + } else if (is_not_null(cdr(cdr_code))) /* (if 1 2 . 3) */ + eval_error(sc, "if: ~A has improper list?", 25, form); + + pair_set_syntax_op(form, OP_IF_UNCHECKED); + set_if_opts(sc, form, is_null(cdr(cdr_code)), false); + return (code); +} + +static void op_if(s7_scheme * sc) +{ + sc->code = check_if(sc, sc->code); + push_stack_no_args(sc, OP_IF1, cdr(sc->code)); + sc->code = car(sc->code); +} + +static void op_if_unchecked(s7_scheme * sc) +{ + push_stack_no_args(sc, OP_IF1, cddr(sc->code)); + sc->code = cadr(sc->code); +} + +static bool op_if1(s7_scheme * sc) +{ + sc->code = + (is_true(sc, sc->value)) ? car(sc->code) : + unchecked_car(cdr(sc->code)); + /* even pre-optimization, (if #f #f) ==> # because unique_car(sc->nil) = sc->unspecified */ + if (is_pair(sc->code)) + return (true); + sc->value = + (is_symbol(sc->code)) ? lookup_checked(sc, sc->code) : sc->code; + return (false); +} + + + +/* -------------------------------- when -------------------------------- */ +static void check_when(s7_scheme * sc) +{ + s7_pointer form = sc->code, code = cdr(sc->code); + + if (!is_pair(code)) /* (when) or (when . 1) */ + eval_error(sc, "when has no expression or body: ~A", 35, form); + if (!is_pair(cdr(code))) /* (when 1) or (when 1 . 1) */ + eval_error(sc, "when has no body?: ~A", 22, form); + else if (!s7_is_proper_list(sc, cddr(code))) + eval_error(sc, "when: stray dot?", 16, form); + + pair_set_syntax_op(form, OP_WHEN_P); + if (is_null(cddr(code))) + set_if_opts(sc, form, true, false); /* use if where possible */ + else { + s7_pointer test = car(code); + if (is_safe_symbol(test)) { + pair_set_syntax_op(form, OP_WHEN_S); + set_opt2_con(form, cadr(code)); + set_opt3_pair(form, cddr(code)); + } else + /* fxable body doesn't happen very often -- a dozen or so hits in the standard tests */ + if (is_fxable(sc, test)) { + pair_set_syntax_op(form, OP_WHEN_A); + if (is_pair(car(code))) + set_opt2_pair(form, cdar(code)); + set_opt3_pair(form, cdr(code)); + set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); /* "A" in when_a */ + + if (fx_proc(code) == fx_and_2a) + pair_set_syntax_op(form, OP_WHEN_AND_2A); + else if (fx_proc(code) == fx_and_3a) + pair_set_syntax_op(form, OP_WHEN_AND_3A); + } else if ((is_pair(test)) && (car(test) == sc->and_symbol)) { + opcode_t new_op; + pair_set_syntax_op(test, symbol_syntax_op_checked(test)); + check_and(sc, test); + new_op = symbol_syntax_op_checked(test); + if (new_op == OP_AND_AP) + pair_set_syntax_op(form, OP_WHEN_AND_AP); + } + } + push_stack_no_args(sc, OP_WHEN_PP, cdr(code)); + sc->code = car(code); +} + +static bool op_when_s(s7_scheme * sc) +{ + if (is_true(sc, lookup(sc, cadr(sc->code)))) { + push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */ + sc->code = opt2_con(sc->code); /* caddr(sc->code) */ + return (false); + } + sc->value = sc->unspecified; + return (true); +} + +static bool op_when_a(s7_scheme * sc) +{ + if (is_true(sc, fx_call(sc, cdr(sc->code)))) { + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */ + sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */ + return (false); + } + sc->value = sc->unspecified; + return (true); +} + +static bool op_when_and_2a(s7_scheme * sc) +{ + if ((is_true(sc, fx_call(sc, opt2_pair(sc->code)))) + && (is_true(sc, fx_call(sc, cdr(opt2_pair(sc->code)))))) { + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */ + sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */ + return (false); + } + sc->value = sc->unspecified; + return (true); +} + +static bool op_when_and_3a(s7_scheme * sc) +{ + if ((is_true(sc, fx_call(sc, opt2_pair(sc->code)))) + && (is_true(sc, fx_call(sc, cdr(opt2_pair(sc->code))))) + && (is_true(sc, fx_call(sc, cddr(opt2_pair(sc->code)))))) { + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */ + sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */ + return (false); + } + sc->value = sc->unspecified; + return (true); +} + +static void op_when_p(s7_scheme * sc) +{ + push_stack_no_args(sc, OP_WHEN_PP, cddr(sc->code)); + sc->code = cadr(sc->code); +} + +static bool op_when_and_ap(s7_scheme * sc) +{ + s7_pointer andp = cdadr(sc->code); + if (is_true(sc, fx_call(sc, andp))) { + push_stack_no_args(sc, OP_WHEN_PP, cddr(sc->code)); + sc->code = cadr(andp); + return (false); + } + sc->value = sc->unspecified; + return (true); +} + +static bool op_when_pp(s7_scheme * sc) +{ + if (is_true(sc, sc->value)) { + if (is_pair(cdr(sc->code))) + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + sc->code = car(sc->code); + return (false); + } + sc->value = sc->unspecified; + return (true); +} + + +/* -------------------------------- unless -------------------------------- */ +static void check_unless(s7_scheme * sc) +{ + s7_pointer form = sc->code, code = cdr(sc->code); + + if (!is_pair(code)) /* (unless) or (unless . 1) */ + eval_error(sc, "unless has no expression or body: ~A", 37, form); + if (!is_pair(cdr(code))) /* (unless 1) or (unless 1 . 1) */ + eval_error(sc, "unless has no body?: ~A", 24, form); + else if (!s7_is_proper_list(sc, cddr(code))) + eval_error(sc, "unless: stray dot?", 18, form); + + pair_set_syntax_op(form, OP_UNLESS_P); + if (is_null(cddr(code))) + set_if_opts(sc, form, true, true); + else if (is_safe_symbol(car(code))) { + pair_set_syntax_op(form, OP_UNLESS_S); + set_opt2_con(form, cadr(code)); + set_opt3_pair(form, cddr(code)); + } else if (is_fxable(sc, car(code))) { + pair_set_syntax_op(form, OP_UNLESS_A); + set_opt2_con(form, cadr(code)); + set_opt3_pair(form, cddr(code)); + set_fx_direct(code, + fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); + } + push_stack_no_args(sc, OP_UNLESS_PP, cdr(code)); + sc->code = car(code); +} + +static bool op_unless_s(s7_scheme * sc) +{ + if (is_false(sc, lookup(sc, cadr(sc->code)))) { + push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */ + sc->code = opt2_con(sc->code); /* caddr(sc->code) */ + return (false); + } + sc->value = sc->unspecified; + return (true); +} + +static bool op_unless_a(s7_scheme * sc) +{ + if (is_false(sc, fx_call(sc, cdr(sc->code)))) { + push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */ + sc->code = opt2_con(sc->code); /* caddr(sc->code) */ + return (false); + } + sc->value = sc->unspecified; + return (true); +} + +static void op_unless_p(s7_scheme * sc) +{ + push_stack_no_args(sc, OP_UNLESS_PP, cddr(sc->code)); + sc->code = cadr(sc->code); +} + +static bool op_unless_pp(s7_scheme * sc) +{ + if (is_false(sc, sc->value)) { + if (is_pair(cdr(sc->code))) + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + sc->code = car(sc->code); + return (false); + } + sc->value = sc->unspecified; + return (true); +} + + +/* -------------------------------- begin -------------------------------- */ +static bool op_begin(s7_scheme * sc, s7_pointer code) +{ + s7_pointer form = cdr(code); + if (!s7_is_proper_list(sc, form)) /* proper list includes () */ + eval_error(sc, "unexpected dot? ~A", 18, code); + if (is_null(form)) { /* (begin) -> () */ + sc->value = sc->nil; + return (true); + } + if ((is_pair(cdr(form))) && (is_null(cddr(form)))) /* begin_1 doesn't happen much */ + pair_set_syntax_op(code, OP_BEGIN_2_UNCHECKED); + else + pair_set_syntax_op(code, OP_BEGIN_UNCHECKED); + return (false); +} + + +/* -------------------------------- define -------------------------------- */ +static s7_pointer print_truncate(s7_scheme * sc, s7_pointer code) +{ + if (tree_len(sc, code) > sc->print_length) + return (object_to_truncated_string + (sc, code, sc->print_length * 10)); + return (code); +} + +static void check_define(s7_scheme * sc) +{ + s7_pointer func, caller, code = cdr(sc->code); + bool starred = (sc->cur_op == OP_DEFINE_STAR); + if (starred) { + caller = sc->define_star_symbol; + sc->cur_op = OP_DEFINE_STAR_UNCHECKED; + } else + caller = + (sc->cur_op == + OP_DEFINE) ? sc->define_symbol : sc->define_constant_symbol; + + if (!is_pair(code)) + eval_error_with_caller(sc, "~A: nothing to define? ~A", 25, caller, sc->code); /* (define) */ + + if (!is_pair(cdr(code))) { + if (is_null(cdr(code))) + eval_error_with_caller(sc, "~A: no value? ~A", 16, caller, sc->code); /* (define var) */ + eval_error_with_caller(sc, "~A: stray dot? ~A", 17, caller, sc->code); /* (define var . 1) */ + } + if (!is_pair(car(code))) { + if (is_not_null(cddr(code))) /* (define var 1 . 2) */ + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, + wrap_string(sc, + "~A: more than one value? ~A", + 27), caller, + print_truncate(sc, sc->code))); + if (starred) + eval_error(sc, + "define* is restricted to functions: (define* ~{~S~^ ~})", + 55, sc->code); + + func = car(code); + if (!is_symbol(func)) /* (define 3 a) */ + eval_error_with_caller2(sc, + "~A: can't define ~S, ~A (should be a symbol)", + 44, caller, func, + prepackaged_type_name(sc, func)); + if (is_keyword(func)) /* (define :hi 1) */ + eval_error_with_caller(sc, "~A ~A: keywords are constants", 29, + caller, func); + if (is_syntactic_symbol(func)) { /* (define and a) */ + if (sc->safety > NO_SAFETY) + s7_warn(sc, 128, + "%s: syntactic keywords tend to behave badly if redefined\n", + display(func)); + set_local(func); + } + if ((is_pair(cadr(code))) && /* look for (define sym (lambda ...)) and treat it like (define (sym ...)...) */ + ((caadr(code) == sc->lambda_symbol) || + (caadr(code) == sc->lambda_star_symbol)) && + (symbol_id(caadr(code)) == 0)) { + /* not is_global here because that bit might not be set for initial symbols (why not? -- redef as method etc) */ + if (!is_pair(cdadr(code))) /* (define x (lambda . 1)) */ + eval_error_with_caller(sc, "~A: stray dot? ~A", 17, caller, + sc->code); + if (!is_pair(cddr(cadr(code)))) /* (define f (lambda (arg))) */ + eval_error_with_caller(sc, "~A: no body: ~A", 15, caller, + sc->code); + if (caadr(code) == sc->lambda_star_symbol) + check_lambda_star_args(sc, cadadr(code), cddr(cadr(code))); + else + check_lambda_args(sc, cadadr(code), NULL); + optimize_lambda(sc, caadr(code) == sc->lambda_symbol, func, + cadadr(code), cddr(cadr(code))); + } + } else { + func = caar(code); + if (!is_symbol(func)) /* (define (3 a) a) */ + eval_error_with_caller2(sc, + "~A: can't define ~S, ~A (should be a symbol)", + 44, caller, func, + prepackaged_type_name(sc, func)); + if (is_syntactic_symbol(func)) { /* (define (and a) a) */ + if (sc->safety > NO_SAFETY) + s7_warn(sc, 128, + "%s: syntactic keywords tend to behave badly if redefined\n", + display(func)); + set_local(func); + } + if (starred) + set_cdar(code, + check_lambda_star_args(sc, cdar(code), cdr(code))); + else + check_lambda_args(sc, cdar(code), NULL); + optimize_lambda(sc, !starred, func, cdar(code), cdr(code)); + } + + if ((sc->cur_op == OP_DEFINE) || (sc->cur_op == OP_DEFINE_CONSTANT)) { /* ?? 10-May-18 */ + if ((is_pair(car(code))) && + (!symbol_has_setter(func)) && (!is_possibly_constant(func))) + pair_set_syntax_op(sc->code, OP_DEFINE_FUNCHECKED); + else + pair_set_syntax_op(sc->code, OP_DEFINE_UNCHECKED); + } else if (starred) + pair_set_syntax_op(sc->code, OP_DEFINE_STAR_UNCHECKED); + else + pair_set_syntax_op(sc->code, OP_DEFINE_CONSTANT_UNCHECKED); +} + +static bool op_define_unchecked(s7_scheme * sc) +{ + s7_pointer code = cdr(sc->code), locp; + + if ((is_pair(car(code))) && (has_location(car(code)))) + locp = car(code); + else if ((is_pair(cadr(code))) && (has_location(cadr(code)))) + locp = cadr(code); + else + locp = sc->nil; + + if ((sc->cur_op == OP_DEFINE_STAR_UNCHECKED) && /* sc->cur_op changed above if define* */ + (is_pair(cdar(code)))) { + sc->value = + make_closure(sc, cdar(code), cdr(code), T_CLOSURE_STAR, + CLOSURE_ARITY_NOT_SET); + /* closure_body might not be cdr(code) after make_closure (add_trace) */ + if ((is_pair(locp)) && (has_location(locp))) { + pair_set_location(closure_body(sc->value), + pair_location(locp)); + set_has_location(closure_body(sc->value)); + } + sc->code = caar(code); + return (false); + } + + if (!is_pair(car(code))) { + s7_pointer x = car(code); + sc->code = cadr(code); + if (is_pair(sc->code)) { + push_stack_no_args(sc, OP_DEFINE1, x); + sc->cur_op = optimize_op(sc->code); + return (true); + } + sc->value = + (is_symbol(sc->code)) ? lookup_global(sc, sc->code) : sc->code; + sc->code = x; + } else { + s7_pointer x, args = cdar(code); + /* a closure. If we called this same code earlier (a local define), the only thing + * that is new here is the environment -- we can't blithely save the closure object + * in opt2 somewhere, and pick it up the next time around (since call/cc might take + * us back to the previous case). We also can't re-use opt2(sc->code) because opt2 + * is not cleared in the gc. + */ + x = make_closure(sc, args, cdr(code), + T_CLOSURE | ((!s7_is_proper_list(sc, args)) ? + T_COPY_ARGS : 0), + (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET); + if ((is_pair(locp)) && (has_location(locp))) { + pair_set_location(closure_body(x), pair_location(locp)); + set_has_location(closure_body(x)); + } + sc->value = T_Pos(x); + sc->code = caar(code); + } + return (false); +} + +static s7_pointer make_funclet(s7_scheme * sc, s7_pointer new_func, + s7_pointer func_name, s7_pointer outer_let) +{ + s7_pointer new_let, arg; + new_cell_no_check(sc, new_let, T_LET | T_FUNCLET); + let_set_id(new_let, ++sc->let_number); + let_set_outlet(new_let, outer_let); + closure_set_let(new_func, new_let); + funclet_set_function(new_let, func_name); /* *function* returns at least funclet_function */ + let_set_slots(new_let, slot_end(sc)); + + arg = closure_args(new_func); + if (is_null(arg)) { + let_set_slots(new_let, slot_end(sc)); + return (new_let); + } + + if (is_safe_closure(new_func)) { + s7_pointer last_slot = NULL; + if (is_closure(new_func)) { + if (is_pair(arg)) { + last_slot = make_slot(sc, car(arg), sc->nil); + slot_set_next(last_slot, slot_end(sc)); + let_set_slots(new_let, last_slot); + symbol_set_local_slot(car(arg), let_id(new_let), + last_slot); + for (arg = cdr(arg); is_pair(arg); arg = cdr(arg)) + last_slot = + add_slot_at_end(sc, let_id(new_let), last_slot, + car(arg), sc->nil); + } + if (is_symbol(arg)) { + if (last_slot) + last_slot = + add_slot_at_end(sc, let_id(new_let), last_slot, + arg, sc->nil); + else { + last_slot = make_slot(sc, arg, sc->nil); + slot_set_next(last_slot, slot_end(sc)); + let_set_slots(new_let, last_slot); + symbol_set_local_slot(arg, let_id(new_let), last_slot); + } + set_is_rest_slot(last_slot); + } + } else { /* closure_star */ + s7_pointer slot, first_default = sc->nil; + let_set_slots(new_let, slot_end(sc)); + for (; is_pair(arg); arg = cdr(arg)) { + s7_pointer par = car(arg); + if (is_pair(par)) { + s7_pointer val = cadr(par); + slot = + add_slot_checked(sc, new_let, car(par), sc->nil); + slot_set_expression(slot, val); + if ((is_symbol(val)) || (is_pair(val))) { + if (is_null(first_default)) + first_default = slot; + set_slot_defaults(slot); + } + } else if (is_keyword(par)) { + if (par == sc->key_rest_symbol) { + arg = cdr(arg); + slot = + add_slot_checked(sc, new_let, car(arg), + sc->nil); + slot_set_expression(slot, sc->nil); + } + } else { + slot = add_slot_checked(sc, new_let, par, sc->nil); + slot_set_expression(slot, sc->F); + } + } + if (is_symbol(arg)) { + slot = add_slot_checked(sc, new_let, arg, sc->nil); /* set up rest arg */ + set_is_rest_slot(slot); + slot_set_expression(slot, sc->nil); + } + if (tis_slot(let_slots(new_let))) { + let_set_slots(new_let, + reverse_slots(sc, let_slots(new_let))); + slot_set_pending_value(let_slots(new_let), first_default); + } + } + set_immutable_let(new_let); + } else + let_set_slots(new_let, slot_end(sc)); /* if unsafe closure, arg-holding-let will be created on each call */ + return (new_let); +} + +static bool op_define_constant(s7_scheme * sc) +{ + s7_pointer code = cdr(sc->code); + if ((!is_pair(code)) || (!is_pair(cdr(code)))) /* (define-constant) */ + eval_error(sc, "define-constant: not enough arguments: ~S", 41, + sc->code); + + if (is_keyword(car(code))) { /* (define-constant :rest :allow-other-keys) */ + if (car(code) == cadr(code)) { /* (define-constant pi pi) returns pi */ + sc->value = car(code); + return (true); + } + eval_error_with_caller(sc, "~A ~A: keywords are constants", 29, + sc->define_constant_symbol, car(code)); + } + if ((is_symbol(car(code))) && /* (define-constant abs abs): "abs will not be touched" */ + (car(code) == cadr(code)) && (symbol_id(car(code)) == 0) && /* else (let iter ... (define-constant iter iter) ...) -> segfault on later calls */ + (is_null(cddr(code)))) { + s7_pointer sym = car(code); + set_immutable(global_slot(sym)); /* id == 0 so its global */ + set_possibly_constant(sym); + sc->value = lookup_checked(sc, car(code)); + return (true); + } + push_stack_no_args(sc, OP_DEFINE_CONSTANT1, car(code)); + return (false); +} + +static void op_define_constant1(s7_scheme * sc) +{ + if (is_pair(sc->code)) + sc->code = car(sc->code); /* (define-constant (ex3 a)...) */ + if (is_symbol(sc->code)) { + s7_pointer slot; + slot = lookup_slot_from(sc->code, sc->curlet); + set_possibly_constant(sc->code); + set_immutable(slot); + if (is_any_closure(slot_value(slot))) + set_immutable(slot_value(slot)); /* for the optimizer mainly */ + } +} + +static inline void define_funchecked(s7_scheme * sc) +{ + s7_pointer new_func, code = cdr(sc->code); + sc->value = caar(code); /* func name */ + + new_cell(sc, new_func, + T_CLOSURE | ((!s7_is_proper_list(sc, cdar(code))) ? + T_COPY_ARGS : 0)); + closure_set_args(new_func, cdar(code)); + closure_set_body(new_func, cdr(code)); + if (is_pair(cddr(code))) + set_closure_has_multiform(new_func); + else + set_closure_has_one_form(new_func); + closure_set_setter(new_func, sc->F); + closure_set_arity(new_func, CLOSURE_ARITY_NOT_SET); + sc->capture_let_counter++; + + if (is_safe_closure_body(cdr(code))) { + set_safe_closure(new_func); + if (is_very_safe_closure_body(cdr(code))) + set_very_safe_closure(new_func); + make_funclet(sc, new_func, sc->value, sc->curlet); + } else + closure_set_let(new_func, sc->curlet); /* unsafe closures created by other functions do not support *function* */ + + if (let_id(sc->curlet) < symbol_id(sc->value)) + sc->let_number++; /* dummy let, force symbol lookup */ + add_slot_unchecked(sc, sc->curlet, sc->value, new_func, + sc->let_number); + sc->value = new_func; +} + +static s7_pointer cur_op_to_caller(s7_scheme * sc, opcode_t op) +{ + switch (op) { + case OP_DEFINE_MACRO: + return (sc->define_macro_symbol); + case OP_DEFINE_MACRO_STAR: + return (sc->define_macro_star_symbol); + case OP_DEFINE_BACRO: + return (sc->define_bacro_symbol); + case OP_DEFINE_BACRO_STAR: + return (sc->define_bacro_star_symbol); + case OP_DEFINE_EXPANSION: + return (sc->define_expansion_symbol); + case OP_DEFINE_EXPANSION_STAR: + return (sc->define_expansion_star_symbol); + case OP_MACRO: + return (sc->macro_symbol); + case OP_MACRO_STAR: + return (sc->macro_star_symbol); + case OP_BACRO: + return (sc->bacro_symbol); + case OP_BACRO_STAR: + return (sc->bacro_star_symbol); + } + return (sc->define_macro_symbol); +} + +static s7_pointer check_define_macro(s7_scheme * sc, opcode_t op) +{ + s7_pointer mac_name, args, caller; + caller = cur_op_to_caller(sc, op); + + if (!is_pair(sc->code)) /* (define-macro . 1) */ + eval_error_with_caller(sc, "~A name missing (stray dot?): ~A", 32, + caller, sc->code); + if (!is_pair(car(sc->code))) /* (define-macro a ...) */ + return (wrong_type_argument_with_type + (sc, caller, 1, car(sc->code), + wrap_string(sc, "a list: (name ...)", 18))); + + mac_name = caar(sc->code); + if (!is_symbol(mac_name)) + eval_error_with_caller(sc, "~A: ~S is not a symbol?", 23, caller, + mac_name); + if (is_syntactic_symbol(mac_name)) { + if (sc->safety > NO_SAFETY) + s7_warn(sc, 128, + "%s: syntactic keywords tend to behave badly if redefined\n", + display(mac_name)); + set_local(mac_name); + } + if (is_constant_symbol(sc, mac_name)) + eval_error_with_caller(sc, "~A: ~S is constant", 18, caller, + mac_name); + + if (!is_pair(cdr(sc->code))) /* (define-macro (...)) */ + eval_error_with_caller(sc, "~A ~A, but no body?", 19, caller, + mac_name); + + args = cdar(sc->code); + if ((!is_list(args)) && (!is_symbol(args))) + return (s7_error(sc, sc->syntax_error_symbol, /* (define-macro (mac . 1) ...) */ + set_elist_3(sc, + wrap_string(sc, + "macro ~A argument list is ~S?", + 29), mac_name, args))); + + if ((op == OP_DEFINE_MACRO) || (op == OP_DEFINE_BACRO) + || (op == OP_DEFINE_EXPANSION)) { + for (; is_pair(args); args = cdr(args)) + if (!is_symbol(car(args))) + return (s7_error(sc, sc->syntax_error_symbol, /* (define-macro (mac 1) ...) */ + set_elist_3(sc, + wrap_string(sc, + "~A parameter name, ~A, is not a symbol", + 38), caller, + car(args)))); + check_lambda_args(sc, cdar(sc->code), NULL); + } else + set_cdar(sc->code, + check_lambda_star_args(sc, cdar(sc->code), NULL)); + return (sc->code); +} + +static s7_pointer check_macro(s7_scheme * sc, opcode_t op) +{ + s7_pointer args, caller; + caller = cur_op_to_caller(sc, op); + + if (!is_pair(sc->code)) /* (define-macro . 1) */ + eval_error_with_caller(sc, "~A name missing (stray dot?): ~A", 32, + caller, sc->code); + if (!is_pair(cdr(sc->code))) /* (define-macro (...)) */ + eval_error_with_caller(sc, "(~A ~A) has no body?", 20, caller, + car(sc->code)); + + args = car(sc->code); + if ((!is_list(args)) && (!is_symbol(args))) + return (s7_error(sc, sc->syntax_error_symbol, /* (define-macro (mac . 1) ...) */ + set_elist_2(sc, + wrap_string(sc, + "macro argument list is ~S?", + 26), args))); + + if ((op == OP_MACRO) || (op == OP_BACRO)) { + for (; is_pair(args); args = cdr(args)) + if (!is_symbol(car(args))) + return (s7_error(sc, sc->syntax_error_symbol, /* (define-macro (mac 1) ...) */ + set_elist_3(sc, + wrap_string(sc, + "~A parameter name, ~A, is not a symbol", + 38), caller, + car(args)))); + check_lambda_args(sc, car(sc->code), NULL); + } else + set_car(sc->code, check_lambda_star_args(sc, car(sc->code), NULL)); + return (sc->code); +} + +static void op_define_macro(s7_scheme * sc) +{ + sc->code = cdr(sc->code); + check_define_macro(sc, sc->cur_op); + if ((is_immutable(sc->curlet)) && (is_let(sc->curlet))) /* not () */ + eval_error(sc, "define-macro ~S: let is immutable", 33, caar(sc->code)); /* need eval_error_any_with_caller? */ + sc->value = make_macro(sc, sc->cur_op, true); +} + +static void op_macro(s7_scheme * sc) +{ /* (macro (x) `(+ ,x 1)) */ + sc->code = cdr(sc->code); + if ((!is_pair(sc->code)) || (!mac_is_ok(sc->code))) { /* (macro)? or (macro . #\a)? */ + check_macro(sc, sc->cur_op); + if (is_pair(sc->code)) + set_mac_is_ok(sc->code); + } + sc->value = make_macro(sc, sc->cur_op, false); +} + +static bool unknown_any(s7_scheme * sc, s7_pointer f, s7_pointer code); +static void apply_macro_star_1(s7_scheme * sc); + +static inline bool op_macro_d(s7_scheme * sc) +{ + sc->value = lookup(sc, car(sc->code)); + if (!is_macro(sc->value)) /* for-each (etc) called a macro before, now it's something else -- a very rare case */ + return (unknown_any(sc, sc->value, sc->code)); + sc->args = cdr(sc->code); /* sc->args = copy_proper_list(sc, cdr(sc->code)); */ + sc->code = sc->value; /* the macro */ + check_stack_size(sc); /* (define-macro (f) (f)) (f) */ + push_stack_op_let(sc, OP_EVAL_MACRO); + sc->curlet = make_let(sc, closure_let(sc->code)); + return (false); /* fall into apply_lambda */ +} + +static bool op_macro_star_d(s7_scheme * sc) +{ + sc->value = lookup(sc, car(sc->code)); + if (!is_macro_star(sc->value)) + return (unknown_any(sc, sc->value, sc->code)); + sc->args = cdr(sc->code); /* sc->args = copy_proper_list(sc, cdr(sc->code)); */ + sc->code = sc->value; + check_stack_size(sc); + push_stack_op_let(sc, OP_EVAL_MACRO); + sc->curlet = make_let(sc, closure_let(sc->code)); + apply_macro_star_1(sc); + return (false); +} + +static void transfer_macro_info(s7_scheme * sc, s7_pointer mac) +{ + s7_pointer body = closure_body(mac); + if (has_pair_macro(mac)) { + set_maclet(sc->curlet); + funclet_set_function(sc->curlet, pair_macro(body)); + } + if (has_location(body)) { + let_set_file(sc->curlet, pair_file_number(body)); + let_set_line(sc->curlet, pair_line_number(body)); + set_has_let_file(sc->curlet); + } +} + +static goto_t op_expansion(s7_scheme * sc) +{ + int64_t loc = current_stack_top(sc) - 1; + s7_pointer caller; + caller = (is_pair(stack_args(sc->stack, loc))) ? car(stack_args(sc->stack, loc)) : sc->F; /* this can be garbage */ + if ((loc >= 3) && (stack_op(sc->stack, loc) != OP_READ_QUOTE) && /* '(expansion ...) */ + (stack_op(sc->stack, loc) != OP_READ_VECTOR) && /* #(expansion ...) */ + (caller != sc->quote_symbol) && /* (quote (expansion ...)) */ + (caller != sc->macroexpand_symbol) && /* (macroexpand (expansion ...)) */ + (caller != sc->define_expansion_symbol) && /* (define-expansion ...) being reloaded/redefined */ + (caller != sc->define_expansion_star_symbol)) { /* (define-expansion* ...) being reloaded/redefined */ + s7_pointer symbol = car(sc->value), slot; + /* we're playing fast and loose with sc->curlet in the reader, so here we need a disaster check */ + if (!is_let(sc->curlet)) + sc->curlet = sc->nil; + + if ((symbol_id(symbol) == 0) || (sc->curlet == sc->nil)) + slot = global_slot(symbol); + else + slot = lookup_slot_from(symbol, sc->curlet); + + sc->code = (is_slot(slot)) ? slot_value(slot) : sc->undefined; + if ((!is_either_macro(sc->code)) || (!is_expansion(sc->code))) + clear_expansion(symbol); + else { + /* call the reader macro */ + sc->args = cdr(sc->value); + push_stack_no_code(sc, OP_EXPANSION, sc->nil); + sc->curlet = make_let(sc, closure_let(sc->code)); + transfer_macro_info(sc, sc->code); + if (!is_macro_star(sc->code)) + return (goto_apply_lambda); + apply_macro_star_1(sc); + return (goto_begin); + /* bacros don't seem to make sense here -- they are tied to the run-time environment, + * procedures would need to evaluate their arguments in rootlet + */ + } + } + return (fall_through); +} + +static void macroexpand_c_macro(s7_scheme * sc) +{ /* callgrind shows this when it's actually calling apply_c_function (code is identical) */ + s7_int len; + len = proper_list_length(sc->args); + if (len < c_macro_required_args(sc->code)) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, not_enough_arguments_string, sc->code, + sc->args)); + if (c_macro_all_args(sc->code) < len) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, sc->code, + sc->args)); + sc->value = c_macro_call(sc->code) (sc, sc->args); +} + +static goto_t macroexpand(s7_scheme * sc) +{ + switch (type(sc->code)) { + case T_MACRO: + sc->curlet = make_let(sc, closure_let(sc->code)); + return (goto_apply_lambda); + + case T_BACRO: + sc->curlet = make_let(sc, sc->curlet); + return (goto_apply_lambda); + + case T_MACRO_STAR: + sc->curlet = make_let(sc, closure_let(sc->code)); + apply_macro_star_1(sc); + return (goto_begin); + + case T_BACRO_STAR: + sc->curlet = make_let(sc, sc->curlet); + apply_macro_star_1(sc); + return (goto_begin); + + case T_C_MACRO: + macroexpand_c_macro(sc); + return (goto_start); + + default: + eval_error(sc, "macroexpand argument is not a macro call: ~A", 44, + sc->args); + } + return (fall_through); /* for the compiler */ +} + +static goto_t op_macroexpand(s7_scheme * sc) +{ + s7_pointer form = sc->code; + sc->code = cdr(sc->code); + /* mimic APPLY, but don't push OP_EVAL_MACRO or OP_EXPANSION + * (define-macro (mac a) `(+ ,a 1)) (macroexpand (mac 3)), sc->code: ((mac 3)) + */ + if ((!is_pair(sc->code)) || (!is_pair(car(sc->code)))) + eval_error(sc, "macroexpand argument is not a macro call: ~A", 44, + form); + + if (!is_null(cdr(sc->code))) + eval_error(sc, "macroexpand: too many arguments: ~A", 35, form); + + if (is_pair(caar(sc->code))) { /* (macroexpand ((symbol->value 'mac) (+ 1 2))) */ + push_stack_no_args_direct(sc, OP_MACROEXPAND_1); + sc->code = caar(sc->code); + return (goto_eval); + } + + sc->args = cdar(sc->code); + if (!is_list(sc->args)) /* (macroexpand (mac . 7)) */ + eval_error(sc, + "can't macroexpand ~S: the macro's argument list is not a list", + 61, car(sc->code)); + + if (!is_symbol(caar(sc->code))) { + if (!is_any_macro(caar(sc->code))) + eval_error(sc, "macroexpand argument is not a macro call: ~A", + 44, sc->code); + sc->code = caar(sc->code); + return (macroexpand(sc)); + } + sc->code = lookup_checked(sc, caar(sc->code)); + return (macroexpand(sc)); +} + +static goto_t op_macroexpand_1(s7_scheme * sc) +{ + sc->args = cdar(sc->code); + sc->code = sc->value; + return (macroexpand(sc)); +} + +static void op_eval_macro(s7_scheme * sc) +{ /* after (scheme-side) macroexpansion, evaluate the resulting expression */ + /* (define-macro (hi a) `(+ ,a 1)), (hi 2), here with value: (+ 2 1) */ + if (is_multiple_value(sc->value)) { + /* a normal macro's result is evaluated (below) and its value replaces the macro invocation, + * so if a macro returns multiple values, evaluate each one, then replace the macro + * invocation with (apply values evaluated-results-in-a-list). We need to save the + * new list of results, and where we are in the macro's output list, so code=macro output, + * args=new list. If it returns (values), should we use #? I think that + * happens now without generating a multiple_value object: + * (define-macro (hi) (values)) (hi) -> # + * (define-macro (ho) (values '(+ 1 2) '(* 3 4))) (+ 1 (ho) 3) -> 19 + * (define-macro (ha) (values '(define a 1) '(define b 2))) (let () (ha) (+ a b)) -> 3 + */ + push_stack(sc, OP_EVAL_MACRO_MV, sc->nil, cdr(sc->value)); + sc->code = car(sc->value); + } else + sc->code = sc->value; +} + +static bool op_eval_macro_mv(s7_scheme * sc) +{ + if (is_null(sc->code)) { /* end of values list */ + sc->value = + splice_in_values(sc, + multiple_value(proper_list_reverse_in_place + (sc, + cons(sc, sc->value, + sc->args)))); + return (true); + } + push_stack(sc, OP_EVAL_MACRO_MV, cons(sc, sc->value, sc->args), + cdr(sc->code)); + sc->code = car(sc->code); + return (false); +} + +static void op_finish_expansion(s7_scheme * sc) +{ + /* after the expander has finished, if a list was returned, we need to add some annotations. + * if the expander returned (values), the list-in-progress vanishes! (This mimics map and *#readers*). + */ + if (sc->value == sc->no_value) + sc->stack_end[-1] = (s7_pointer) OP_READ_NEXT; + else if (is_pair(sc->value)) + sc->value = copy_body(sc, sc->value); +} + + +/* -------------------------------- with-let -------------------------------- */ +static void check_with_let(s7_scheme * sc) +{ + s7_pointer form = cdr(sc->code); + + if (!is_pair(form)) /* (with-let . "hi") */ + eval_error(sc, "with-let takes an environment argument: ~A", 42, + sc->code); + if (!is_pair(cdr(form))) /* (with-let e) -> an error? */ + eval_error(sc, "with-let body is messed up: ~A", 30, sc->code); + if (!s7_is_proper_list(sc, cdr(form))) /* (with-let e . 3) */ + eval_error(sc, "stray dot in with-let body: ~S", 30, sc->code); + + if ((is_pair(car(form))) && (caar(form) == sc->unlet_symbol) && /* a constant, (with-let (unlet) ...) */ + (is_null(cdar(form))) && (is_symbol(cadr(form))) && (is_null(cddr(form)))) /* (with-let (unlet) symbol) */ + pair_set_syntax_op(sc->code, OP_WITH_UNLET_S); + else if (is_symbol(car(form))) + pair_set_syntax_op(sc->code, OP_WITH_LET_S); + else + pair_set_syntax_op(sc->code, OP_WITH_LET_UNCHECKED); +} + +static bool op_with_let_unchecked(s7_scheme * sc) +{ + sc->code = cdr(sc->code); + sc->value = car(sc->code); + if (!is_pair(sc->value)) { + if (is_symbol(sc->value)) + sc->value = lookup_checked(sc, sc->value); + sc->code = cdr(sc->code); + return (false); + } + push_stack_no_args(sc, OP_WITH_LET1, cdr(sc->code)); + sc->code = sc->value; /* eval let arg */ + return (true); +} + +static inline bool op_with_let_s(s7_scheme * sc) +{ + s7_pointer e; + sc->code = cdr(sc->code); + e = lookup_checked(sc, car(sc->code)); + if ((!is_let(e)) && (e != sc->rootlet)) + eval_error_any(sc, sc->wrong_type_arg_symbol, + "with-let takes an environment argument: ~A", 42, + e); + if ((is_null(cddr(sc->code))) && (is_symbol(cadr(sc->code)))) { + sc->value = s7_let_ref(sc, e, cadr(sc->code)); /* (with-let e s) -> (let-ref e s) */ + return (false); + } + if (e == sc->rootlet) + sc->curlet = sc->nil; + else { + set_with_let_let(e); + let_set_id(e, ++sc->let_number); + set_curlet(sc, e); + update_symbol_ids(sc, e); + } + sc->code = T_Pair(cdr(sc->code)); + return (true); +} + +static s7_pointer with_unlet_s(s7_scheme * sc) +{ + s7_pointer sym = caddr(sc->code); + if (is_slot(initial_slot(sym))) + return (initial_value(sym)); + return (lookup(sc, sym)); +} + +static void activate_with_let(s7_scheme * sc, s7_pointer e) +{ + if (!is_let(e)) /* (with-let . "hi") */ + eval_error_any(sc, sc->wrong_type_arg_symbol, + "with-let takes an environment argument: ~A", 42, + e); + if (e == sc->rootlet) + sc->curlet = sc->nil; /* (with-let (rootlet) ...) */ + else { + set_with_let_let(e); + let_set_id(e, ++sc->let_number); + set_curlet(sc, e); + update_symbol_ids(sc, e); + } +} + + +/* -------------------------------- cond -------------------------------- */ +static void check_cond(s7_scheme * sc) +{ + bool has_feed_to = false, result_fx = true, result_single = true; + s7_pointer x, code = cdr(sc->code), form = sc->code; + + if (!is_pair(code)) /* (cond) or (cond . 1) */ + eval_error(sc, "cond, but no body: ~A", 21, form); + + for (x = code; is_pair(x); x = cdr(x)) + if (!is_pair(car(x))) /* (cond 1) or (cond (#t 1) 3) */ + eval_error(sc, "every clause in cond must be a list: ~A", 39, + car(x)); + else { + s7_pointer y = car(x); + if (!s7_is_proper_list(sc, cdr(y))) + eval_error(sc, "stray dot? ~A", 13, y); + if (is_pair(cdr(y))) { + if (is_pair(cddr(y))) + result_single = false; + if (is_undefined_feed_to(sc, cadr(y))) { + has_feed_to = true; + if (!is_pair(cddr(y))) /* (cond (#t =>)) or (cond (#t => . 1)) */ + eval_error(sc, "cond: '=>' target missing? ~A", + 30, x); + if (is_pair(cdddr(y))) /* (cond (1 => + abs)) */ + eval_error(sc, + "cond: '=>' has too many targets: ~A", + 35, x); + } + } else + result_single = false; + } + if (is_not_null(x)) /* (cond ((1 2)) . 1) */ + eval_error(sc, "cond: stray dot? ~A", 19, form); + + for (x = code; is_pair(x); x = cdr(x)) { + s7_pointer p = car(x); + if (is_fxable(sc, car(p))) + fx_annotate_arg(sc, p, sc->curlet); + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!has_fx(p)) { + s7_function f; + f = fx_choose(sc, p, sc->curlet, let_symbol_is_safe); + if (f) + set_fx_direct(p, f); + else + result_fx = false; + } + } + + if (has_feed_to) { + pair_set_syntax_op(form, OP_COND_UNCHECKED); + if (is_null(cdr(code))) { + s7_pointer expr = car(code), f; + f = caddr(expr); + if ((is_proper_list_3(sc, f)) && (car(f) == sc->lambda_symbol)) { + s7_pointer arg = cadr(f); + if ((is_pair(arg)) && (is_null(cdr(arg))) && (is_symbol(car(arg)))) { /* (define (hi) (cond (#t => (lambda (s) s)))) */ + set_opt2_lambda(code, caddar(code)); /* (lambda ...) above */ + pair_set_syntax_op(form, OP_COND_FEED); + } + } + } + } else { + s7_pointer p; + bool xopt = true; + int32_t i; + + pair_set_syntax_op(form, OP_COND_SIMPLE); + for (i = 0, p = code; xopt && (is_pair(p)); i++, p = cdr(p)) + xopt = ((has_fx(car(p))) && (is_pair(cdar(p)))); + if (xopt) { + pair_set_syntax_op(form, + (result_fx) ? OP_COND_FX_FX + : ((result_single) ? OP_COND_FX_NP_O : + OP_COND_FX_NP)); + if (result_single) { + if (i == 2) { + p = caadr(code); + if ((p == sc->else_symbol) || (p == sc->T)) + pair_set_syntax_op(form, OP_COND_FX_2E); + } else if (i == 3) { + p = caaddr(code); + if ((p == sc->else_symbol) || (p == sc->T)) + pair_set_syntax_op(form, OP_COND_FX_3E); + } + } + } else if (result_single) + pair_set_syntax_op(form, OP_COND_SIMPLE_O); + } + set_opt3_any(code, caar(code)); +} + +static bool op_cond_unchecked(s7_scheme * sc) +{ + sc->code = cdr(sc->code); + if (has_fx(car(sc->code))) { + sc->value = fx_call(sc, car(sc->code)); /* false -> fall through into cond1 */ + return (false); + } + push_stack_no_args_direct(sc, OP_COND1); /* true -> push cond1, goto eval */ + sc->code = opt3_any(sc->code); /* caar */ + return (true); +} + +static bool op_cond_simple(s7_scheme * sc) +{ /* no => */ + sc->code = cdr(sc->code); + if (has_fx(car(sc->code))) { + sc->value = fx_call(sc, car(sc->code)); + return (false); + } + push_stack_no_args_direct(sc, OP_COND1_SIMPLE); + sc->code = opt3_any(sc->code); /* caar */ + return (true); +} + +static bool op_cond_simple_o(s7_scheme * sc) +{ /* no =>, no null or multiform consequent */ + sc->code = cdr(sc->code); + if (has_fx(car(sc->code))) { + sc->value = fx_call(sc, car(sc->code)); + return (false); + } + push_stack_no_args_direct(sc, OP_COND1_SIMPLE_O); + sc->code = opt3_any(sc->code); /* caar */ + return (true); +} + +static bool op_cond1(s7_scheme * sc) +{ + while (true) { + if (is_true(sc, sc->value)) { /* test is true, so evaluate result */ + sc->code = cdar(sc->code); + if (is_pair(sc->code)) { + if (is_null(cdr(sc->code))) { + if (has_fx(sc->code)) { + sc->value = fx_call(sc, sc->code); + pop_stack(sc); + return (true); /* goto top_no_pop */ + } + sc->code = car(sc->code); + sc->cur_op = optimize_op(sc->code); + return (true); + } + /* check_cond catches stray dots */ + if (is_undefined_feed_to(sc, car(sc->code))) + return (false); + if (has_fx(sc->code)) { + sc->value = fx_call(sc, sc->code); + sc->code = cdr(sc->code); + if (is_pair(cdr(sc->code))) + push_stack_no_args(sc, sc->begin_op, + cdr(sc->code)); + } else + push_stack_no_args(sc, sc->begin_op, + T_Pair(cdr(sc->code))); + sc->code = car(sc->code); + sc->cur_op = optimize_op(sc->code); + return (true); + } + /* sc->code is () */ + if (is_multiple_value(sc->value)) /* (+ 1 (cond ((values 2 3)))) */ + sc->value = + splice_in_values(sc, multiple_value(sc->value)); + /* no result clause, so return test, (cond (#t)) -> #t, (cond ((+ 1 2))) -> 3 */ + pop_stack(sc); + return (true); + } + sc->code = cdr(sc->code); /* go to next clause */ + if (is_null(sc->code)) { + sc->value = sc->unspecified; /* changed 31-Dec-15 */ + /* r7rs sez the value if no else clause is unspecified, and this choice makes cond consistent with if and case, + * and rewrite choices between the three are simpler if they are consistent. + */ + pop_stack(sc); + return (true); + } + if (has_fx(car(sc->code))) + sc->value = fx_call(sc, car(sc->code)); + else { + push_stack_no_args_direct(sc, OP_COND1); + sc->code = caar(sc->code); + sc->cur_op = optimize_op(sc->code); + return (true); + } + } + return (true); /* make the compiler happy */ +} + +static bool op_cond1_simple(s7_scheme * sc) +{ + while (true) { + if (is_true(sc, sc->value)) { + sc->code = T_Lst(cdar(sc->code)); + if (is_null(sc->code)) { + if (is_multiple_value(sc->value)) + sc->value = + splice_in_values(sc, multiple_value(sc->value)); + pop_stack(sc); + return (true); + } + if (!has_fx(sc->code)) + return (false); + sc->value = fx_call(sc, sc->code); + sc->code = cdr(sc->code); + if (is_pair(sc->code)) + return (false); /* goto begin */ + pop_stack(sc); + return (true); /* goto top_no_pop */ + } + sc->code = cdr(sc->code); + if (is_null(sc->code)) { + sc->value = sc->unspecified; + pop_stack(sc); + return (true); + } + if (has_fx(car(sc->code))) + sc->value = fx_call(sc, car(sc->code)); + else { + push_stack_no_args_direct(sc, OP_COND1_SIMPLE); + sc->code = caar(sc->code); + sc->cur_op = optimize_op(sc->code); + return (true); + } + } +} + +static bool op_cond1_simple_o(s7_scheme * sc) +{ + while (true) { + if (is_true(sc, sc->value)) { + sc->code = cdar(sc->code); + if (has_fx(sc->code)) { + sc->value = fx_call(sc, sc->code); + return (true); /* goto start */ + } + sc->code = car(sc->code); + return (false); + } + sc->code = cdr(sc->code); + if (is_null(sc->code)) { + sc->value = sc->unspecified; + return (true); + } + if (has_fx(car(sc->code))) + sc->value = fx_call(sc, car(sc->code)); + else { + check_stack_size(sc); /* 4-May-21 snd-test */ + push_stack_no_args_direct(sc, OP_COND1_SIMPLE_O); + sc->code = caar(sc->code); + return (false); + } + } +} + +static bool op_cond_fx_np(s7_scheme * sc) +{ /* all tests are fxable, results may be a mixture, no =>, no missing results */ + s7_pointer p; + for (p = cdr(sc->code); is_pair(p); p = cdr(p)) + if (is_true(sc, fx_call(sc, car(p)))) { + for (p = T_Lst(cdar(p)); is_pair(p); p = cdr(p)) + if (has_fx(T_Pair(p))) + sc->value = fx_call(sc, p); + else { + if (is_pair(cdr(p))) + push_stack_no_args(sc, OP_COND_FX_NP_1, cdr(p)); + sc->code = car(p); + return (false); + } + return (true); + } + sc->value = sc->unspecified; + return (true); +} + +static bool op_cond_fx_np_1(s7_scheme * sc) +{ /* continuing to handle a multi-statement result from cond_fx_np */ + s7_pointer p; + for (p = sc->code; is_pair(p); p = cdr(p)) + if (has_fx(T_Pair(p))) + sc->value = fx_call(sc, p); + else { + if (is_pair(cdr(p))) + push_stack_no_args(sc, OP_COND_FX_NP_1, cdr(p)); + sc->code = car(p); + return (false); + } + return (true); +} + +static Inline bool op_cond_fx_np_o(s7_scheme * sc) +{ /* all tests are fxable, results may be a mixture, no =>, no missing results, all result one expr */ + s7_pointer p; + for (p = cdr(sc->code); is_pair(p); p = cdr(p)) + if (is_true(sc, fx_call(sc, car(p)))) { + p = cdar(p); + if (has_fx(T_Pair(p))) { + sc->value = fx_call(sc, p); + return (true); + } + sc->code = car(p); + return (false); + } + sc->value = sc->unspecified; + return (true); +} + +static inline bool fx_cond_value(s7_scheme * sc, s7_pointer p) +{ + if (has_fx(p)) { + sc->value = fx_call(sc, p); + return (true); + } + sc->code = car(p); + return (false); +} + +static bool op_cond_fx_2e(s7_scheme * sc) +{ + s7_pointer p = cdr(sc->code); + return (fx_cond_value + (sc, (is_true(sc, fx_call(sc, car(p)))) ? cdar(p) : cdadr(p))); +} + +static bool op_cond_fx_3e(s7_scheme * sc) +{ + s7_pointer p = cdr(sc->code); + if (is_true(sc, fx_call(sc, car(p)))) + return (fx_cond_value(sc, cdar(p))); + p = cdr(p); + return (fx_cond_value + (sc, (is_true(sc, fx_call(sc, car(p)))) ? cdar(p) : cdadr(p))); +} + +static bool op_cond_feed(s7_scheme * sc) +{ + /* (cond (expr => p)) where p is (lambda (s) ...) -- see check_cond */ + sc->code = cdr(sc->code); + if (has_fx(car(sc->code))) + sc->value = fx_call(sc, car(sc->code)); + else { + push_stack_no_args_direct(sc, OP_COND_FEED_1); + sc->code = caar(sc->code); + return (true); + } + return (false); +} + +static bool op_cond_feed_1(s7_scheme * sc) +{ + if (is_true(sc, sc->value)) { + if (is_multiple_value(sc->value)) + sc->code = + cons(sc, opt2_lambda(sc->code), multiple_value(sc->value)); + else { + sc->curlet = + make_let_with_slot(sc, sc->curlet, + caadr(opt2_lambda(sc->code)), + sc->value); + sc->code = caddr(opt2_lambda(sc->code)); + } + return (true); + } + sc->value = sc->unspecified; /* it's cond -- perhaps push as sc->args above; this was nil until 21-Feb-17! */ + return (false); +} + +static bool feed_to(s7_scheme * sc) +{ + if (is_multiple_value(sc->value)) { + sc->args = multiple_value(sc->value); + clear_multiple_value(sc->args); + if (is_symbol(cadr(sc->code))) { + sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */ + return (true); + } + } else { + if (is_symbol(cadr(sc->code))) { + sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */ + sc->args = + (needs_copied_args(sc->code)) ? list_1(sc, + sc->value) : + set_plist_1(sc, sc->value); + return (true); + } + sc->args = list_1(sc, sc->value); /* not plist here */ + } + push_stack_direct(sc, OP_FEED_TO_1); + sc->code = cadr(sc->code); /* need to evaluate the target function */ + return (false); +} + + +/* -------------------------------- set! -------------------------------- */ +static void set_dilambda_opt(s7_scheme * sc, s7_pointer form, opcode_t opt, + s7_pointer expr) +{ + s7_pointer func; + func = lookup_checked(sc, car(expr)); + if ((is_closure(func)) && + (is_closure(closure_setter(func))) && + (is_safe_closure(closure_setter(func)))) { + s7_pointer setter = closure_setter(func); + pair_set_syntax_op(form, opt); + if ((!(is_let(closure_let(setter)))) || + (!(is_funclet(closure_let(setter))))) + make_funclet(sc, setter, car(expr), closure_let(setter)); + } +} + +static void check_set(s7_scheme * sc) +{ + s7_pointer form = sc->code, code = cdr(sc->code); + if (!is_pair(code)) { + if (is_null(code)) /* (set!) */ + eval_error(sc, "set!: not enough arguments: ~A", 30, form); + eval_error(sc, "set!: stray dot? ~A", 19, form); /* (set! . 1) */ + } + if (!is_pair(cdr(code))) { + if (is_null(cdr(code))) /* (set! var) */ + eval_error(sc, "set!: not enough arguments: ~A", 30, form); + eval_error(sc, "set!: stray dot? ~A", 19, form); /* (set! var . 1) */ + } + if (is_not_null(cddr(code))) /* (set! var 1 2) */ + eval_error(sc, "~A: too many arguments to set!", 30, form); + + /* cadr (the value) has not yet been evaluated */ + if (is_pair(car(code))) { + if ((is_pair(caar(code))) && (!is_list(cdar(code)))) /* (set! ('(1 2) . 0) 1) */ + eval_error(sc, "improper list of arguments to set!: ~A", 38, + form); + if (!s7_is_proper_list(sc, car(code))) /* (set! ("hi" . 1) #\a) or (set! (#(1 2) . 1) 0) */ + eval_error(sc, + "set! target is an improper list: (set! ~A ...)", + 46, car(code)); + } else if (!is_symbol(car(code))) /* (set! 12345 1) */ + eval_error(sc, "set! can't change ~S", 20, car(code)); + else if (is_constant_symbol(sc, car(code))) /* (set! pi 3) */ + eval_error(sc, + (is_keyword(car(code))) ? + "set!: can't change keyword's value: ~S" : + "set!: can't alter constant's value: ~S", 38, + car(code)); + + if (is_pair(car(code))) { + /* here we have (set! (...) ...) */ + s7_pointer inner = car(code), value = cadr(code); + + pair_set_syntax_op(form, OP_SET_UNCHECKED); /* if not pair car, op_set_normal below */ + if (is_symbol(car(inner))) { + if ((is_null(cdr(inner))) && + (!is_pair(value)) && + (is_global(car(inner))) && + (is_c_function(global_value(car(inner)))) && + (c_function_required_args(global_value(car(inner))) == 0)) + pair_set_syntax_op(form, OP_SET_PWS); + else { + if ((is_pair(cdr(inner))) && (!is_pair(cddr(inner)))) { /* we check cddr(code) above */ + /* this leaves (set! (vect i j) 1) unhandled so we go to OP_SET_UNCHECKED */ + if (!is_pair(cadr(inner))) { + /* (set! (f s) ...) */ + if (!is_pair(value)) { + pair_set_syntax_op(form, OP_SET_PAIR); + if (is_symbol(car(inner))) + set_dilambda_opt(sc, form, OP_SET_DILAMBDA, + inner); + } else + pair_set_syntax_op(form, OP_SET_PAIR_P); /* splice_in_values protects us here from values */ + + if (!is_fxable(sc, value)) { + if (is_symbol(car(inner))) + set_dilambda_opt(sc, form, + OP_SET_DILAMBDA_P, inner); + } else { + s7_pointer obj; + if ((car(inner) == sc->s7_let_symbol) && + (is_keyword(cadr(inner)))) { + pair_set_syntax_op(form, + OP_IMPLICIT_S7_LET_SET_SA); + fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */ + set_opt3_sym(cdr(form), + keyword_symbol(cadr(inner))); + return; + } + + obj = lookup_checked(sc, car(inner)); /* might be (set! (undefined-var ...)...) */ + if (((is_c_function(obj)) + && (car(inner) != + make_symbol(sc, + c_function_name(obj)))) + || ((is_closure(obj)) + && (car(inner) != + closure_name(sc, obj))) + || ((!is_c_function(obj)) + && (!is_closure(obj)))) + return; + + fx_annotate_arg(sc, cdr(code), sc->curlet); + pair_set_syntax_op(form, OP_SET_PAIR_ZA); + if ((is_c_function(obj)) && + (is_c_function(c_function_setter(obj)))) + pair_set_syntax_op(form, OP_SET_PAIR_A); + else if (is_symbol(cadr(inner))) { + if (!has_fx(cdr(code))) + fx_annotate_arg(sc, cdr(code), + sc->curlet); + + if ((is_closure(obj)) && + (is_closure(closure_setter(obj))) && + (is_safe_closure(closure_setter(obj)))) + { + s7_pointer setter = + closure_setter(obj), body; + body = closure_body(setter); + if ((is_proper_list_1(sc, body)) && + ((has_fx(body)) + || (is_fxable(sc, car(body))))) { + s7_pointer setter_args; + if (!has_fx(body)) { + fx_annotate_arg(sc, body, + sc->curlet); + set_closure_one_form_fx_arg + (setter); + } + setter_args = closure_args(setter); + if ((is_pair(setter_args)) + && (is_pair(cdr(setter_args))) + && + (is_null(cddr(setter_args)))) + fx_tree(sc, body, + car(setter_args), + cadr(setter_args), + NULL, false); + + pair_set_syntax_op(form, + OP_SET_DILAMBDA_SA_A); + if ((!(is_let(closure_let(setter)))) || /* ?? not sure this can happen */ + (!(is_funclet + (closure_let(setter))))) + make_funclet(sc, setter, + car(inner), + closure_let + (setter)); + } + } + } + } + } else /* is_pair(cadr(inner)) */ + if ((caadr(inner) == sc->quote_symbol) && + (is_global(sc->quote_symbol)) && /* (call/cc (lambda* 'x) ... (set! (setter 'y) ...)...) should return y */ + (is_symbol(car(inner))) && + ((is_normal_symbol(value)) || + (is_fxable(sc, value)))) { + if ((car(inner) == sc->s7_let_symbol) && + (is_symbol(cadadr(inner)))) { + pair_set_syntax_op(form, + OP_IMPLICIT_S7_LET_SET_SA); + fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */ + set_opt3_sym(cdr(form), cadadr(inner)); + return; + } + if (is_safe_symbol(value)) + pair_set_syntax_op(form, OP_SET_LET_S); + else { + pair_set_syntax_op(form, OP_SET_LET_FX); + set_fx(cdr(code), + fx_choose(sc, cdr(code), sc->curlet, + let_symbol_is_safe)); + } + } + } + } + } + return; + } + + pair_set_syntax_op(form, OP_SET_NORMAL); + if (is_symbol(car(code))) { + s7_pointer settee = car(code), value = cadr(code); + + if ((!symbol_has_setter(settee)) && (!is_syntactic_symbol(settee))) { + if (is_normal_symbol(value)) { + if (is_slot(lookup_slot_from(value, sc->curlet))) { + pair_set_syntax_op(form, OP_SET_SYMBOL_S); + set_opt2_sym(code, value); + } + } else { + if ((!is_pair(value)) || ((car(value) == sc->quote_symbol) && (is_pair(cdr(value))))) { /* (quote . 1) ? */ + pair_set_syntax_op(form, OP_SET_SYMBOL_C); + set_opt2_con(code, + (is_pair(value)) ? cadr(value) : value); + } else { + /* if cadr(cadr) == car, or cdr(cadr) not null and cadr(cadr) == car, and cddr(cadr) == null, + * it's (set! ( val)) or ( val ) or ( ) + * in the set code, we get the slot as usual, then in case 1 above, + * car(sc->t2_1) = slot_value(slot), car(sc->t2_2) = increment, call , set slot_value(slot) + * + * (define (hi) (let ((x 1)) (set! x (+ x 1)))) + * but the value might be values: + * (let () (define (hi) (let ((x 0)) (set! x (values 1 2)) x)) (catch #t hi (lambda a a)) (hi)) + * which is caught in splice_in_values + */ + pair_set_syntax_op(form, OP_SET_SYMBOL_P); + if (is_optimized(value)) { + if (optimize_op(value) == HOP_SAFE_C_NC) { + pair_set_syntax_op(form, OP_SET_SYMBOL_A); + fx_annotate_arg(sc, cdr(code), sc->curlet); + } else { + if (optimize_op(value) == HOP_SAFE_C_SS) { + if (settee == cadr(value)) { + pair_set_syntax_op(form, + OP_INCREMENT_SS); + set_opt2_sym(code, caddr(value)); + } else { + pair_set_syntax_op(form, + OP_SET_SYMBOL_A); + fx_annotate_arg(sc, cdr(code), + sc->curlet); + } + } else { + if (is_fxable(sc, value)) { /* value = cadr(code) */ + pair_set_syntax_op(form, + OP_SET_SYMBOL_A); + fx_annotate_arg(sc, cdr(code), + sc->curlet); + } + if ((is_safe_c_op(optimize_op(value))) && + (is_pair(cdr(value))) && + (settee == cadr(value)) && + (!is_null(cddr(value)))) { + if (is_null(cdddr(value))) { + if (is_fxable(sc, caddr(value))) { + pair_set_syntax_op(form, + OP_INCREMENT_SA); + fx_annotate_arg(sc, cddr(value), sc->curlet); /* this sets fx_proc(arg) */ + set_opt2_pair(code, + cddr(value)); + } else { + pair_set_syntax_op(form, + OP_INCREMENT_SP); + set_opt2_pair(code, + caddr(value)); + } + } else + if ((is_null(cddddr(value))) && + (is_fxable(sc, caddr(value))) + && + (is_fxable(sc, cadddr(value)))) + { + pair_set_syntax_op(form, + OP_INCREMENT_SAA); + fx_annotate_arg(sc, cddr(value), + sc->curlet); + fx_annotate_arg(sc, cdddr(value), + sc->curlet); + set_opt2_pair(code, cddr(value)); + } + } + } + } + } + if ((is_h_optimized(value)) && (!is_unsafe(value)) && /* is_unsafe(value) can happen! */ + (is_not_null(cdr(value)))) { /* (set! x (y)) */ + if (is_not_null(cddr(value))) { + if ((caddr(value) == int_one) && + (cadr(value) == settee)) { + if (opt1_cfunc(value) == sc->add_x1) + pair_set_syntax_op(form, + OP_INCREMENT_BY_1); + else if (opt1_cfunc(value) == + sc->subtract_x1) + pair_set_syntax_op(form, + OP_DECREMENT_BY_1); + } else if ((cadr(value) == int_one) + && (caddr(value) == settee) + && (opt1_cfunc(value) == + sc->add_1x)) + pair_set_syntax_op(form, + OP_INCREMENT_BY_1); + else if ((settee == caddr(value)) + && (is_safe_symbol(cadr(value))) + && (caadr(code) == sc->cons_symbol)) { + pair_set_syntax_op(form, OP_SET_CONS); + set_opt2_sym(code, cadr(value)); + } + } + } + } + } + } + } +} + +static void op_set_symbol_c(s7_scheme * sc) +{ + s7_pointer slot; + slot = lookup_slot_from(cadr(sc->code), sc->curlet); + slot_set_value(slot, sc->value = opt2_con(cdr(sc->code))); +} + +static void op_set_symbol_s(s7_scheme * sc) +{ + s7_pointer slot; + slot = lookup_slot_from(cadr(sc->code), sc->curlet); + slot_set_value(slot, sc->value = lookup(sc, opt2_sym(cdr(sc->code)))); +} + +static void op_set_symbol_a(s7_scheme * sc) +{ + s7_pointer slot; + slot = lookup_slot_from(cadr(sc->code), sc->curlet); + slot_set_value(slot, sc->value = fx_call(sc, cddr(sc->code))); +} + +static void op_set_from_let_temp(s7_scheme * sc) +{ + s7_pointer settee = sc->code, slot; + slot = lookup_slot_from(settee, sc->curlet); + if (!is_slot(slot)) + unbound_variable_error(sc, settee); + if (is_immutable_slot(slot)) + immutable_object_error(sc, + set_elist_3(sc, immutable_error_string, + sc->let_temporarily_symbol, + settee)); + if (slot_has_setter(slot)) + slot_set_value(slot, call_setter(sc, slot, sc->value)); + else + slot_set_value(slot, sc->value); +} + +static inline void op_set_cons(s7_scheme * sc) +{ + s7_pointer slot; + slot = lookup_slot_from(cadr(sc->code), sc->curlet); + slot_set_value(slot, sc->value = cons(sc, lookup(sc, opt2_sym(cdr(sc->code))), slot_value(slot))); /* ([set!] bindings (cons v bindings)) */ +} + +static void op_increment_ss(s7_scheme * sc) +{ + s7_pointer slot; + sc->code = cdr(sc->code); + slot = lookup_slot_from(car(sc->code), sc->curlet); + set_car(sc->t2_1, slot_value(slot)); + set_car(sc->t2_2, lookup(sc, opt2_sym(sc->code))); + slot_set_value(slot, sc->value = + fn_proc(cadr(sc->code)) (sc, sc->t2_1)); +} + +static void op_increment_saa(s7_scheme * sc) +{ + s7_pointer slot, arg, val; + sc->code = cdr(sc->code); + slot = lookup_slot_from(car(sc->code), sc->curlet); + arg = opt2_pair(sc->code); /* cddr(value) */ + val = fx_call(sc, cdr(arg)); + set_car(sc->t3_2, fx_call(sc, arg)); + set_car(sc->t3_3, val); + set_car(sc->t3_1, slot_value(slot)); + slot_set_value(slot, sc->value = + fn_proc(cadr(sc->code)) (sc, sc->t3_1)); +} + +static void op_increment_sa(s7_scheme * sc) +{ + s7_pointer slot, arg; + sc->code = cdr(sc->code); + slot = lookup_slot_from(car(sc->code), sc->curlet); + arg = opt2_pair(sc->code); + set_car(sc->t2_2, fx_call(sc, arg)); + set_car(sc->t2_1, slot_value(slot)); + slot_set_value(slot, sc->value = + fn_proc(cadr(sc->code)) (sc, sc->t2_1)); +} + +static inline void op_set_pair_a(s7_scheme * sc) +{ + s7_pointer obj, setter, code = cdr(sc->code); + obj = lookup_checked(sc, caar(code)); + setter = c_function_setter(obj); + obj = fx_call(sc, cdr(code)); + set_car(sc->t2_1, cadar(code)); /* might be a constant: (set! (mus-sound-srate "oboe.snd") 12345) */ + if (is_symbol(car(sc->t2_1))) + set_car(sc->t2_1, lookup_checked(sc, cadar(code))); + set_car(sc->t2_2, obj); + sc->value = c_function_call(setter) (sc, sc->t2_1); +} + +static void op_set_pair_p(s7_scheme * sc) +{ + /* ([set!] (car a) (cadr a)) */ + /* here the pair can't generate multiple values, or if it does, it's an error (caught below) + * splice_in_values will notice the OP_SET_PAIR_P_1 and complain. + * (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a)) str)) (hi) (hi)) is "a23" + * (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a #\b)) str)) (hi) (hi)) is an error from the first call (caught elsewhere) + * (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a #\b)) str)) (catch #t hi (lambda a a)) (hi)) is an error from the second call + * (let ((v (make-vector '(2 3) 0))) (set! (v (values 0 1)) 23) v) -> #2D((0 23 0) (0 0 0)) + */ + push_stack_no_args(sc, OP_SET_PAIR_P_1, cdr(sc->code)); + sc->code = caddr(sc->code); +} + +static bool set_pair_p_3(s7_scheme * sc, s7_pointer obj, s7_pointer arg, + s7_pointer value) +{ + if (is_slot(obj)) + obj = slot_value(obj); + else + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, no_setter_string, caar(sc->code), + sc->prepackaged_type_names[type(obj)])); + + switch (type(obj)) { + case T_C_OBJECT: + set_car(sc->t3_1, obj); + set_car(sc->t3_2, arg); + set_car(sc->t3_3, value); + sc->value = (*(c_object_set(sc, obj))) (sc, sc->t3_1); + break; + + /* some of these are wasteful -- we know the object type! (list hash-table) */ + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + case T_BYTE_VECTOR: +#if WITH_GMP + set_car(sc->t3_1, obj); + set_car(sc->t3_2, arg); + set_car(sc->t3_3, value); + sc->value = g_vector_set(sc, sc->t3_1); +#else + if (vector_rank(obj) > 1) { + set_car(sc->t3_1, obj); + set_car(sc->t3_2, arg); + set_car(sc->t3_3, value); + sc->value = g_vector_set(sc, sc->t3_1); + } else { + s7_int index; + if (!is_t_integer(arg)) + eval_error_any(sc, sc->wrong_type_arg_symbol, + "vector-set!: index must be an integer: ~S", + 41, sc->code); + index = integer(arg); + if (index < 0) + eval_error_any(sc, sc->out_of_range_symbol, + "vector-set!: index must not be negative: ~S", + 43, sc->code); + if (index >= vector_length(obj)) + eval_error_any(sc, sc->out_of_range_symbol, + "vector-set!: index must be less than vector length: ~S", + 54, sc->code); + if (is_immutable(obj)) + immutable_object_error(sc, + set_elist_3(sc, + immutable_error_string, + sc->vector_set_symbol, + obj)); + if (is_typed_vector(obj)) { + if ((sc->safety < NO_SAFETY) || /* or == NO_SAFETY?? */ + (typed_vector_typer_call + (sc, obj, set_plist_1(sc, value)) != sc->F)) + vector_element(obj, index) = value; + else + return (s7_wrong_type_arg_error + (sc, "vector-set!", 3, value, + make_type_name(sc, + typed_vector_typer_name(sc, + obj), + INDEFINITE_ARTICLE))); + } else + vector_setter(obj) (sc, obj, index, value); + sc->value = T_Pos(value); + } +#endif + break; + + case T_STRING: +#if WITH_GMP + set_car(sc->t3_1, obj); + set_car(sc->t3_2, arg); + set_car(sc->t3_3, value); + sc->value = g_string_set(sc, sc->t3_1); +#else + { + s7_int index; + if (!is_t_integer(arg)) + eval_error_any(sc, sc->wrong_type_arg_symbol, + "index must be an integer: ~S", 28, + sc->code); + index = integer(arg); + if (index < 0) + eval_error_any(sc, sc->out_of_range_symbol, + "index must not be negative: ~S", 30, + sc->code); + if (index >= string_length(obj)) + eval_error_any(sc, sc->out_of_range_symbol, + "index must be less than sequence length: ~S", + 43, sc->code); + if (is_immutable(obj)) + immutable_object_error(sc, + set_elist_3(sc, + immutable_error_string, + sc->string_set_symbol, + obj)); + + if (!is_character(value)) + eval_error_any(sc, sc->wrong_type_arg_symbol, + "(string-)set!: value must be a character: ~S", + 44, sc->code); + string_value(obj)[index] = (char) s7_character(value); + sc->value = value; + } +#endif + break; + + case T_PAIR: + set_car(sc->t3_1, obj); + set_car(sc->t3_2, arg); + set_car(sc->t3_3, value); + sc->value = g_list_set(sc, sc->t3_1); + break; + + case T_HASH_TABLE: + if (is_immutable(obj)) + immutable_object_error(sc, + set_elist_3(sc, immutable_error_string, + sc->hash_table_set_symbol, + obj)); + sc->value = s7_hash_table_set(sc, obj, arg, value); + break; + + case T_LET: + sc->value = s7_let_set(sc, obj, arg, value); /* this checks immutable */ + break; + + case T_C_OPT_ARGS_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: /* (let ((lst (list 1 2))) (set! (list-ref lst 1) 2) lst) */ + case T_C_FUNCTION: + case T_C_FUNCTION_STAR: /* obj here is a c_function, but its setter could be a closure and vice versa below */ + if (!is_any_procedure(c_function_setter(obj))) + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, no_setter_string, caar(sc->code), + sc->prepackaged_type_names[type(obj)])); + if (is_c_function(c_function_setter(obj))) { + set_car(sc->t2_1, arg); + set_car(sc->t2_2, value); + sc->value = + c_function_call(c_function_setter(obj)) (sc, sc->t2_1); + } else { + sc->code = c_function_setter(obj); + sc->args = + (needs_copied_args(sc->code)) ? list_2(sc, arg, + value) : + set_plist_2(sc, arg, value); + return (true); /* goto APPLY; */ + } + break; + + case T_MACRO: + case T_MACRO_STAR: + case T_BACRO: + case T_BACRO_STAR: + case T_CLOSURE: + case T_CLOSURE_STAR: + if (!is_any_procedure(closure_setter(obj))) + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, no_setter_string, caar(sc->code), + sc->prepackaged_type_names[type(obj)])); + if (is_c_function(closure_setter(obj))) { + set_car(sc->t2_1, arg); + set_car(sc->t2_2, value); + sc->value = + c_function_call(closure_setter(obj)) (sc, sc->t2_1); + } else { + sc->code = closure_setter(obj); + sc->args = + (needs_copied_args(sc->code)) ? list_2(sc, arg, + value) : + set_plist_2(sc, arg, value); + return (true); /* goto APPLY; */ + } + break; + + default: /* (set! (1 2) 3) */ + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, no_setter_string, caar(sc->code), + sc->prepackaged_type_names[type(obj)])); + } + return (false); +} + +static Inline bool op_set_pair_p_1(s7_scheme * sc) +{ + /* car(sc->code) is a pair, caar(code) is the object with a setter, it has one (safe) argument, and one safe value to set + * (set! (str i) #\a) in a function (both inner things need to be symbols (or the second can be a quoted symbol) to get here) + * the inner list is a proper list, with no embedded list at car. + */ + s7_pointer value = sc->value, arg = cadar(sc->code); + if (is_symbol(arg)) + arg = lookup_checked(sc, arg); + else if (is_pair(arg)) + arg = cadr(arg); /* can only be (quote ...) in this case */ + return (set_pair_p_3 + (sc, lookup_slot_from(caar(sc->code), sc->curlet), arg, + value)); +} + +static bool op_set_pair(s7_scheme * sc) +{ + /* ([set!] (setter g) s) or ([set!] (str 0) #\a) */ + s7_pointer obj, arg, value; + sc->code = cdr(sc->code); + value = cadr(sc->code); + if (is_symbol(value)) + value = lookup_checked(sc, value); + + arg = cadar(sc->code); + if (is_symbol(arg)) + arg = lookup_checked(sc, arg); + else if (is_pair(arg)) + arg = cadr(arg); /* can only be (quote ...) in this case */ + + obj = caar(sc->code); + if (is_symbol(obj)) + obj = lookup_slot_from(obj, sc->curlet); + return (set_pair_p_3(sc, obj, arg, value)); +} + +static void op_set_safe(s7_scheme * sc) +{ + s7_pointer lx; + lx = lookup_slot_from(sc->code, sc->curlet); /* SET_CASE above looks for car(sc->code) */ + if (is_slot(lx)) + slot_set_value(lx, sc->value); + else + unbound_variable_error(sc, sc->code); +} + +static s7_pointer op_set1(s7_scheme * sc) +{ + s7_pointer lx; + /* if unbound variable hook here, we need the binding, not the current value */ + lx = lookup_slot_from(sc->code, sc->curlet); + if (is_slot(lx)) { + if (is_immutable(lx)) + immutable_object_error(sc, + set_elist_3(sc, immutable_error_string, + sc->set_symbol, + slot_symbol(lx))); + if (slot_has_setter(lx)) { + s7_pointer func = slot_setter(lx); + if (is_c_function(func)) + sc->value = + call_c_function_setter(sc, func, sc->code, sc->value); + else if (is_any_procedure(func)) { + /* don't push OP_EVAL_DONE here and call eval(sc, OP_APPLY) below -- setter might hit an error */ + push_stack_no_args(sc, OP_SET_FROM_SETTER, lx); + if (has_let_arg(func)) + sc->args = list_3(sc, sc->code, sc->value, sc->curlet); + else + sc->args = list_2(sc, sc->code, sc->value); /* these lists are reused as the closure_let slots in apply_lambda via apply_closure */ + sc->code = func; + return (NULL); /* goto APPLY */ + } + } else if ((is_syntactic_symbol(sc->code)) || /* (set! case 3) */ + ((global_slot(sc->code) == lx) && /* (begin (let ((case 2)) case) (set! case 3)) */ + (is_syntax(slot_value(lx))) && + (sc->code == syntax_symbol(slot_value(lx))))) + eval_error(sc, "can't set! ~A", 13, sc->code); + slot_set_value(lx, sc->value); + symbol_increment_ctr(sc->code); /* see define setfib example in s7test.scm -- I'm having second thoughts about this... */ + return (sc->value); /* goto START */ + } + if (has_let_set_fallback(sc->curlet)) /* (with-let (mock-hash-table 'b 2) (set! b 3)) */ + return (call_let_set_fallback + (sc, sc->curlet, sc->code, sc->value)); + return (s7_error + (sc, sc->unbound_variable_symbol, + set_elist_4(sc, + wrap_string(sc, "~S is unbound in (set! ~S ~S)", + 29), sc->code, sc->code, sc->value))); +} + +static goto_t set_implicit(s7_scheme * sc); + +static goto_t op_set2(s7_scheme * sc) +{ + if (is_pair(sc->value)) { + /* (let ((L '((1 2 3)))) (set! ((L 0) 1) 32) L) + * (let ((L '(((1 2 3))))) (set! ((L 0) 0 1) 32) L) + * any deeper nesting was handled already by the first eval + * set! looks at its first argument, if it's a symbol, it sets the associated value, + * if it's a list, it looks at the car of that list to decide which setter to call, + * if it's a list of lists, it passes the embedded lists to eval, then looks at the + * car of the result. This means that we can do crazy things like: + * (let ((x '(1)) (y '(2))) (set! ((if #t x y) 0) 32) x) + * the other args need to be evaluated (but not the list as if it were code): + * (let ((L '((1 2 3))) (index 1)) (set! ((L 0) index) 32) L) + */ + if (!s7_is_proper_list(sc, sc->args)) /* (set! ('(1 2) 1 . 2) 1) */ + eval_error(sc, + "set! target arguments are an improper list: ~A", + 46, sc->args); + + if (is_multiple_value(sc->value)) /* this has to be at least 2 args, sc->args and sc->code make 2 more, so... */ + eval_error(sc, "set!: too many arguments: ~S", 28, + set_ulist_1(sc, sc->set_symbol, + pair_append(sc, + multiple_value(sc->value), + pair_append(sc, sc->args, + sc->code)))); + + if (sc->args == sc->nil) + eval_error(sc, "list set!: not enough arguments: ~S", 35, + sc->code); + + push_op_stack(sc, sc->list_set_function); + if (!is_null(cdr(sc->args))) + sc->code = pair_append(sc, cdr(sc->args), sc->code); + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, sc->value), + T_Pair(sc->code)); + sc->code = car(sc->args); + return (goto_eval); + } + if (is_any_vector(sc->value)) { + /* (let ((L #(#(1 2 3) #(4 5 6)))) (set! ((L 1) 0) 32) L) + * bad case when args is nil: (let ((L #(#(1 2 3) #(4 5 6)))) (set! ((L 1)) 32) L) + */ + if (sc->args == sc->nil) + eval_error(sc, "vector set!: not enough arguments: ~S", 37, + sc->code); + push_op_stack(sc, sc->vector_set_function); + if (!is_null(cdr(sc->args))) + sc->code = pair_append(sc, cdr(sc->args), sc->code); + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, sc->value), + T_Pair(sc->code)); + sc->code = car(sc->args); + return (goto_eval); + } +#if 0 + sc->code = cons_unchecked(sc, sc->set_symbol, cons_unchecked(sc, cons(sc, sc->value, sc->args), sc->code)); /* (let ((x 32)) (set! ((curlet) 'x) 3) x) */ +#else + sc->code = + set_ulist_2(sc, sc->set_symbol, + set_ulist_1(sc, sc->value, sc->args), sc->code); +#endif + return (set_implicit(sc)); +} + +static bool op_set_with_let_1(s7_scheme * sc) +{ + s7_pointer e, b, x; + /* from the T_SYNTAX branch of op_set_pair: (set! (with-let e b) x) as in let-temporarily + * here sc->value is the new value for the settee = x, args has the (as yet unevaluated) let and settee-expression. + * 'b above can be a pair = generalized set in the 'e environment. + */ + if (!is_pair(sc->args)) /* (set! (with-let) ...) */ + eval_error(sc, "set! (with-let)? ~A", 19, current_code(sc)); + if (!is_pair(cdr(sc->args))) /* (set! (with-let e) ...) */ + eval_error(sc, "set! (with-let ...) has no symbol to set? ~A", 44, + current_code(sc)); + e = car(sc->args); + b = cadr(sc->args); + x = sc->value; + if (is_symbol(e)) { + if (is_symbol(b)) { + e = lookup_checked(sc, e); /* the let */ + if (!is_let(e)) + wrong_type_argument_with_type(sc, sc->let_set_symbol, 1, e, + a_let_string); + sc->value = let_set_1(sc, e, b, x); + pop_stack(sc); + return (true); + } + sc->value = lookup_checked(sc, e); + sc->code = set_plist_3(sc, sc->set_symbol, b, ((is_symbol(x)) + || (is_pair(x))) ? + set_plist_2(sc, sc->quote_symbol, x) : x); + /* (let* ((x (vector 1 2)) (lt (curlet))) (set! (with-let lt (x 0)) 32) x) here: (set! (x 0) 32) */ + return (false); /* goto SET_WITH_LET */ + } + sc->code = e; /* 'e above, an expression we need to evaluate */ + sc->args = set_plist_2(sc, b, x); /* can't reuse sc->args here via set-car! etc */ + push_stack_direct(sc, OP_SET_WITH_LET_2); + sc->cur_op = optimize_op(sc->code); + return (true); /* goto top_no_pop */ +} + +static bool op_set_with_let_2(s7_scheme * sc) +{ + s7_pointer b, x; + /* here sc->value = let = 'e, args = '(b x) where 'b might be a pair */ + if (!is_let(sc->value)) + wrong_type_argument_with_type(sc, sc->let_set_symbol, 1, sc->value, + a_let_string); + b = car(sc->args); + x = cadr(sc->args); + if (is_symbol(b)) { /* b is a symbol -- everything else is ready so call let-set! */ + sc->value = let_set_1(sc, sc->value, b, x); + return (true); /* goto START */ + } + if ((is_symbol(x)) || (is_pair(x))) /* (set! (with-let (inlet :v (vector 1 2)) (v 0)) 'a) */ + sc->code = set_plist_3(sc, sc->set_symbol, b, ((is_symbol(x)) + || (is_pair(x))) ? + set_plist_2(sc, sc->quote_symbol, x) : x); + else + sc->code = set_ulist_1(sc, sc->set_symbol, sc->args); /* (set! (with-let (curlet) (*s7* 'print-length)) 16), x=16 b=(*s7* 'print-length) */ + return (false); /* fall into SET_WITH_LET */ +} + +static bool op_set_normal(s7_scheme * sc) +{ + s7_pointer x; + sc->code = cdr(sc->code); + x = cadr(sc->code); + if (is_pair(x)) { + push_stack_no_args(sc, OP_SET1, car(sc->code)); + sc->code = x; + return (true); + } + sc->value = (is_symbol(x)) ? lookup_checked(sc, x) : T_Pos(x); + sc->code = car(sc->code); + return (false); +} + +static void op_set_symbol_p(s7_scheme * sc) +{ + check_stack_size(sc); + push_stack_no_args(sc, OP_SET_SAFE, cadr(sc->code)); + sc->code = caddr(sc->code); +} + +static void op_increment_sp(s7_scheme * sc) +{ + s7_pointer sym; + sc->code = cdr(sc->code); + sym = lookup_slot_from(car(sc->code), sc->curlet); + push_stack(sc, OP_INCREMENT_SP_1, sym, sc->code); + sc->code = T_Pair(opt2_pair(sc->code)); /* caddadr(sc->code); */ +} + +static void op_increment_sp_1(s7_scheme * sc) +{ + set_car(sc->t2_1, slot_value(sc->args)); + set_car(sc->t2_2, sc->value); + sc->value = fn_proc(cadr(sc->code)) (sc, sc->t2_1); + slot_set_value(sc->args, sc->value); +} + +static void op_increment_sp_mv(s7_scheme * sc) +{ + sc->value = + fn_proc(cadr(sc->code)) (sc, + set_ulist_1(sc, slot_value(sc->args), + sc->value)); + set_car(sc->u1_1, sc->F); + slot_set_value(sc->args, sc->value); +} + +static goto_t op_set_dilambda_p_1(s7_scheme * sc) +{ + s7_pointer obj, func, arg = cadar(sc->code); + if (is_symbol(arg)) + arg = lookup_checked(sc, arg); + else if (is_pair(arg)) + arg = cadr(arg); /* can only be (quote ...) in this case */ + + obj = lookup_slot_from(caar(sc->code), sc->curlet); + func = slot_value(obj); + if ((is_closure(func)) && (is_safe_closure(closure_setter(func)))) { + s7_pointer setter = closure_setter(func); + if (is_pair(closure_args(setter))) { + sc->curlet = + update_let_with_two_slots(sc, closure_let(setter), arg, + sc->value); + sc->code = T_Pair(closure_body(setter)); + return (goto_begin); + } + } + return ((set_pair_p_3(sc, obj, arg, sc->value)) ? goto_apply : + goto_start); +} + + +/* ---------------- implicit ref/set ---------------- */ +static Inline goto_t op_implicit_vector_ref_a(s7_scheme * sc) +{ + s7_pointer v, x; + v = lookup_checked(sc, car(sc->code)); + if (!is_any_vector(v)) { + sc->last_function = v; + return (fall_through); + } + x = fx_call(sc, cdr(sc->code)); + if ((s7_is_integer(x)) && (vector_rank(v) == 1)) { + s7_int index = s7_integer_checked(sc, x); + if ((index < vector_length(v)) && (index >= 0)) { + sc->value = + (is_float_vector(v)) ? make_real(sc, + float_vector(v, + index)) : + vector_getter(v) (sc, v, index); + return (goto_start); + } + } + sc->value = vector_ref_1(sc, v, set_plist_1(sc, x)); + return (goto_start); +} + +static goto_t op_implicit_vector_ref_aa(s7_scheme * sc) +{ + s7_pointer v, x, y, code; + v = lookup_checked(sc, car(sc->code)); + if (!is_any_vector(v)) { + sc->last_function = v; + return (fall_through); + } + code = cdr(sc->code); + x = fx_call(sc, code); + y = fx_call(sc, cdr(code)); + if ((s7_is_integer(x)) && (s7_is_integer(y)) && (vector_rank(v) == 2)) { + s7_int ix = s7_integer_checked(sc, x), iy = + s7_integer_checked(sc, y); + if ((ix >= 0) && (iy >= 0) && (ix < vector_dimension(v, 0)) + && (iy < vector_dimension(v, 1))) { + s7_int index; + index = (ix * vector_offset(v, 0)) + iy; + sc->value = vector_getter(v) (sc, v, index); /* check for normal vector saves in some cases, costs in others */ + return (goto_start); + } + } + sc->value = vector_ref_1(sc, v, set_plist_2(sc, x, y)); + return (goto_start); +} + +static inline bool op_implicit_vector_set_3(s7_scheme * sc) +{ + s7_pointer v, i1, code = cdr(sc->code); + v = lookup(sc, caar(code)); + if (!is_any_vector(v)) { + /* this could be improved -- set_pair_p_3 perhaps: pair_p_3 set opt3? but this calls g_vector_set_3 */ + pair_set_syntax_op(sc->code, OP_SET_UNCHECKED); + return (true); + } + i1 = fx_call(sc, cdar(code)); /* gc protect? */ + set_car(sc->t3_3, fx_call(sc, cdr(code))); + set_car(sc->t3_1, v); + set_car(sc->t3_2, i1); + sc->value = g_vector_set_3(sc, sc->t3_1); /* calls vector_setter handling any vector type whereas vector_set_p_ppp wants a normal vector */ + /* sc->value = vector_set_p_ppp(sc, v, i1, fx_call(sc, cdr(code))); */ + return (false); +} + +static bool op_implicit_vector_set_4(s7_scheme * sc) +{ + s7_pointer v, i1, i2, code = cdr(sc->code); + v = lookup(sc, caar(code)); + if (!is_any_vector(v)) { + pair_set_syntax_op(sc->code, OP_SET_UNCHECKED); + return (true); + } + i1 = fx_call(sc, cdar(code)); + i2 = fx_call(sc, opt3_pair(sc->code)); /* cddar(code) */ + set_car(sc->t3_3, fx_call(sc, cdr(code))); + set_car(sc->t4_1, v); + set_car(sc->t3_1, i1); + set_car(sc->t3_2, i2); + sc->value = g_vector_set_4(sc, sc->t4_1); + set_car(sc->t4_1, sc->F); + return (false); +} + +static goto_t set_implicit_vector(s7_scheme * sc, s7_pointer cx, + s7_pointer form) +{ + /* cx is the vector, sc->code is expr without the set!, form is the full expr, args have not been evaluated! */ + s7_pointer settee = car(sc->code), index; + s7_int argnum; + + if (!implicit_set_ok(sc->code)) { + if (!is_pair(cdr(sc->code))) /* (set! (v 0)) */ + s7_wrong_number_of_args_error(sc, + "no value for vector-set!: ~S", + form); + if (!is_null(cddr(sc->code))) /* (set! (v 0) 1 2) */ + s7_wrong_number_of_args_error(sc, + "too many values for vector-set!: ~S", + form); + if (!is_pair(cdr(settee))) + s7_wrong_number_of_args_error(sc, + "no index for vector-set!: ~S", + form); + set_implicit_set_ok(sc->code); + } + if (is_immutable(cx)) + immutable_object_error(sc, + set_elist_3(sc, immutable_error_string, + sc->vector_set_symbol, cx)); + + argnum = proper_list_length(cdr(settee)); + if ((argnum > 1) && + (is_normal_vector(cx)) && (argnum != vector_rank(cx))) { + /* this block needs to be first to handle (eg): + * (let ((v (vector (inlet 'a 0)))) (set! (v 0 'a) 32) v): #((inlet 'a 32)) + */ + push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code)); + sc->code = list_2(sc, car(settee), cadr(settee)); + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); + } + + if ((argnum > 1) || (vector_rank(cx) > 1)) { + if ((argnum == 2) && (is_fxable(sc, cadr(settee))) && (is_fxable(sc, caddr(settee))) && (is_fxable(sc, cadr(sc->code)))) { /* (set! (v fx fx) fx) */ + fx_annotate_args(sc, cdr(settee), sc->curlet); + fx_annotate_arg(sc, cdr(sc->code), sc->curlet); + set_opt3_pair(form, cddr(settee)); + pair_set_syntax_op(form, OP_IMPLICIT_VECTOR_SET_4); + } + if ((argnum == vector_rank(cx)) && (!is_pair(cadr(sc->code)))) { + s7_pointer p; + for (p = cdr(settee); is_pair(p); p = cdr(p)) + if (is_pair(car(p))) + break; + if (is_null(p)) { + s7_pointer args, pa; + args = safe_list_if_possible(sc, argnum + 2); + if (in_heap(args)) + gc_protect_via_stack(sc, args); + car(args) = cx; + for (p = cdr(settee), pa = cdr(args); is_pair(p); + p = cdr(p), pa = cdr(pa)) { + index = car(p); + if (is_symbol(index)) + index = lookup_checked(sc, index); + if (!s7_is_integer(index)) + eval_error_any(sc, sc->wrong_type_arg_symbol, + "vector-set!: index must be an integer: ~S", + 41, form); + car(pa) = index; + } + car(pa) = cadr(sc->code); + if (is_symbol(car(pa))) + car(pa) = lookup_checked(sc, car(pa)); + sc->value = g_vector_set(sc, args); + if (in_heap(args)) + unstack(sc); + else + clear_list_in_use(args); + return (goto_start); + } + } + push_op_stack(sc, sc->vector_set_function); /* vector_setter(cx) has wrong args */ + sc->code = (is_null(cddr(settee))) ? cdr(sc->code) : pair_append(sc, cddr(settee), cdr(sc->code)); /* i.e. rest(args) + val */ + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), sc->code); + sc->code = cadr(settee); + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); + } + + /* one index, rank == 1 */ + index = cadr(settee); + if ((is_fxable(sc, index)) && (is_fxable(sc, cadr(sc->code)))) { + fx_annotate_arg(sc, cdr(settee), sc->curlet); + fx_annotate_arg(sc, cdr(sc->code), sc->curlet); + pair_set_syntax_op(form, OP_IMPLICIT_VECTOR_SET_3); + } + if (!is_pair(index)) { + s7_int ind; + s7_pointer val; + + if (is_symbol(index)) + index = lookup_checked(sc, index); + if (!s7_is_integer(index)) + eval_error_any(sc, sc->wrong_type_arg_symbol, + "vector-set!: index must be an integer: ~S", 41, + sc->code); + ind = s7_integer_checked(sc, index); + if ((ind < 0) || (ind >= vector_length(cx))) + out_of_range(sc, sc->vector_set_symbol, int_two, index, + (ind < + 0) ? its_negative_string : its_too_large_string); + val = cadr(sc->code); + if (!is_pair(val)) { + if (is_symbol(val)) + val = lookup_checked(sc, val); + if (is_typed_vector(cx)) + typed_vector_setter(sc, cx, ind, val); + else + vector_setter(cx) (sc, cx, ind, val); + sc->value = T_Pos(val); + return (goto_start); + } + push_op_stack(sc, sc->vector_set_function); + sc->args = list_2(sc, index, cx); + sc->code = cdr(sc->code); + return (goto_eval_args); + } + /* here the index calc might be trivial -- (+ i 1) or (- j 1) but this branch hardly ever happens */ + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), cdr(sc->code)); + push_op_stack(sc, sc->vector_set_function); + sc->code = cadr(settee); + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); +} + +static goto_t set_implicit_c_object(s7_scheme * sc, s7_pointer cx, + s7_pointer form) +{ + s7_pointer settee, index, val; + + if (!implicit_set_ok(sc->code)) { + if (!is_pair(cdr(sc->code))) + s7_wrong_number_of_args_error(sc, + "no value for object-set!: ~S", + form); + if (!is_null(cddr(sc->code))) + s7_wrong_number_of_args_error(sc, + "too many values for object-set!: ~S", + form); + set_implicit_set_ok(sc->code); + } + settee = car(sc->code); + if ((!is_pair(cdr(settee))) || (!is_null(cddr(settee)))) { + push_op_stack(sc, sc->c_object_set_function); + if (is_null(cdr(settee))) { + push_stack(sc, OP_EVAL_ARGS1, list_1(sc, cx), sc->nil); + sc->code = cadr(sc->code); + } else { + sc->code = pair_append(sc, cddr(settee), cdr(sc->code)); + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), sc->code); + sc->code = cadr(settee); + } + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); + } + index = cadr(settee); + if (!is_pair(index)) { + if (is_symbol(index)) + index = lookup_checked(sc, index); + + val = cadr(sc->code); + if (!is_pair(val)) { + if (is_symbol(val)) + val = lookup_checked(sc, val); + set_car(sc->t3_1, cx); + set_car(sc->t3_2, index); + set_car(sc->t3_3, val); + sc->value = (*(c_object_set(sc, cx))) (sc, sc->t3_1); + return (goto_start); + } + push_op_stack(sc, sc->c_object_set_function); + sc->args = list_2(sc, index, cx); + sc->code = cdr(sc->code); + return (goto_eval_args); + } + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), cdr(sc->code)); + push_op_stack(sc, sc->c_object_set_function); + sc->code = cadr(settee); + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); +} + +static goto_t op_implicit_string_ref_a(s7_scheme * sc) +{ + s7_int index; + s7_pointer s, x; + s = lookup_checked(sc, car(sc->code)); + x = fx_call(sc, cdr(sc->code)); + if (!is_string(s)) { + sc->last_function = s; + return (fall_through); + } + if (!s7_is_integer(x)) { + sc->value = string_ref_1(sc, s, set_plist_1(sc, x)); + return (goto_start); + } + index = s7_integer_checked(sc, x); + if ((index < string_length(s)) && (index >= 0)) { + sc->value = chars[((uint8_t *) string_value(s))[index]]; + return (goto_start); + } + sc->value = string_ref_1(sc, s, x); + return (goto_start); +} + +static goto_t set_implicit_string(s7_scheme * sc, s7_pointer cx, + s7_pointer form) +{ + /* here only one index makes sense, and it is required, so (set! ("str") #\a), (set! ("str" . 1) #\a) and (set! ("str" 1 2) #\a) are all errors (but see below!) */ + s7_pointer settee = car(sc->code), index, val; + + if (!implicit_set_ok(sc->code)) { + if (!is_pair(cdr(sc->code))) + s7_wrong_number_of_args_error(sc, + "no value for string-set!: ~S", + form); + if (!is_null(cddr(sc->code))) + s7_wrong_number_of_args_error(sc, + "too many values for string-set!: ~S", + form); + if (!is_pair(cdr(settee))) + s7_wrong_number_of_args_error(sc, + "no index for string-set!: ~S", + form); + if (!is_null(cddr(settee))) + s7_wrong_number_of_args_error(sc, + "too many indices for string-set!: ~S", + form); + set_implicit_set_ok(sc->code); + } + /* if there's one index (the standard case), and it is not a pair, and there's one value (also standard) + * and it is not a pair, let's optimize this thing! + * cx is what we're setting, cadar is the index, cadr is the new value + */ + index = cadr(settee); + if (!is_pair(index)) { + s7_int ind; + + if (is_symbol(index)) + index = lookup_checked(sc, index); + if (!s7_is_integer(index)) + eval_error_any(sc, sc->wrong_type_arg_symbol, + "index must be an integer: ~S", 28, form); + ind = s7_integer_checked(sc, index); + if ((ind < 0) || (ind >= string_length(cx))) + out_of_range(sc, sc->string_set_symbol, int_two, index, + (ind < + 0) ? its_negative_string : its_too_large_string); + if (is_immutable(cx)) + immutable_object_error(sc, + set_elist_3(sc, immutable_error_string, + sc->string_set_symbol, cx)); + + val = cadr(sc->code); + if (!is_pair(val)) { + if (is_symbol(val)) + val = lookup_checked(sc, val); + if (is_character(val)) { + string_value(cx)[ind] = character(val); + sc->value = val; + return (goto_start); + } + eval_error_any(sc, sc->wrong_type_arg_symbol, + "value must be a character: ~S", 29, form); + } + push_op_stack(sc, sc->string_set_function); + sc->args = list_2(sc, index, cx); + sc->code = cdr(sc->code); + return (goto_eval_args); + } + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), cdr(sc->code)); /* args4 not 1 because we know cdr(sc->code) is a pair */ + push_op_stack(sc, sc->string_set_function); + sc->code = cadar(sc->code); + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); +} + +static goto_t set_implicit_pair(s7_scheme * sc, s7_pointer cx, + s7_pointer form) +{ /* code: ((lst 1) 32) from (let ((lst (list 1 2 3))) (set! (lst 1) 32)) */ + s7_pointer settee = car(sc->code), index, val; + + if (!implicit_set_ok(sc->code)) { + if (!is_pair(cdr(sc->code))) + s7_wrong_number_of_args_error(sc, "no value for list-set!: ~S", + form); + if (!is_null(cddr(sc->code))) + s7_wrong_number_of_args_error(sc, + "too many values for list-set!: ~S", + form); + if (!is_pair(cdr(settee))) + s7_wrong_number_of_args_error(sc, "no index for list-set!: ~S", + form); + set_implicit_set_ok(sc->code); + } + if (!is_null(cddr(settee))) { + /* split (set! (a b c...) v) into (set! ((a b) c ...) v), eval (a b), return + * (let ((L (list (list 1 2)))) (set! (L 0 0) 3) L) + */ + push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code)); + sc->code = list_2(sc, car(settee), cadr(settee)); + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); + } + + index = cadr(settee); + val = cadr(sc->code); + + if ((is_pair(index)) || (is_pair(val))) { + push_op_stack(sc, sc->list_set_function); + sc->code = + (is_null(cddr(settee))) ? cdr(sc->code) : pair_append(sc, + cddr + (settee), + cdr + (sc->code)); + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), sc->code); + sc->code = index; + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); + } + + if (is_symbol(index)) + index = lookup_checked(sc, index); + if (is_symbol(val)) + val = lookup_checked(sc, val); + + set_car(sc->t2_1, index); + set_car(sc->t2_2, val); + sc->value = g_list_set_1(sc, cx, sc->t2_1, 2); + return (goto_start); +} + +static goto_t set_implicit_hash_table(s7_scheme * sc, s7_pointer cx, + s7_pointer form) +{ + s7_pointer settee = car(sc->code), key; + + if (!implicit_set_ok(sc->code)) { + if (!is_pair(cdr(sc->code))) + s7_wrong_number_of_args_error(sc, + "no value for hash-table-set!: ~S", + form); + if (!is_null(cddr(sc->code))) + s7_wrong_number_of_args_error(sc, + "too many values for hash-table-set!: ~S", + form); + if (!is_pair(cdr(settee))) + s7_wrong_number_of_args_error(sc, + "no key for hash-table-set!: ~S", + form); + set_implicit_set_ok(sc->code); + } + if (is_immutable(cx)) + immutable_object_error(sc, + set_elist_3(sc, immutable_error_string, + sc->hash_table_set_symbol, cx)); + + if (!is_null(cddr(settee))) { + push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code)); + sc->code = list_2(sc, car(settee), cadr(settee)); + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); + } + + key = cadr(settee); + if (!is_pair(key)) { + s7_pointer val; + if (is_symbol(key)) + key = lookup_checked(sc, key); + val = cadr(sc->code); + if (!is_pair(val)) { + if (is_symbol(val)) + val = lookup_checked(sc, val); + sc->value = s7_hash_table_set(sc, cx, key, val); + return (goto_start); + } + push_op_stack(sc, sc->hash_table_set_function); + sc->args = list_2(sc, key, cx); + sc->code = cdr(sc->code); + return (goto_eval_args); + } + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), cdr(sc->code)); + push_op_stack(sc, sc->hash_table_set_function); + sc->code = cadar(sc->code); + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); +} + +static goto_t set_implicit_let(s7_scheme * sc, s7_pointer cx, + s7_pointer form) +{ + s7_pointer settee = car(sc->code), key; + /* code: ((gen 'input) input) from (set! (gen 'input) input) */ + + if (!implicit_set_ok(sc->code)) { + if (!is_pair(cdr(sc->code))) + s7_wrong_number_of_args_error(sc, "no value for let-set!: ~S", + form); + if (!is_null(cddr(sc->code))) + s7_wrong_number_of_args_error(sc, + "too many values for let-set!: ~S", + form); + if (!is_pair(cdr(settee))) + s7_wrong_number_of_args_error(sc, + "no symbol (variable name) for let-set!: ~S", + form); + set_implicit_set_ok(sc->code); + } + if (!is_null(cddr(settee))) { + push_stack(sc, OP_SET2, cddr(settee), cdr(sc->code)); + sc->code = list_2(sc, car(settee), cadr(settee)); + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); + } + key = cadr(settee); + if (is_proper_quote(sc, key)) { + s7_pointer val = cadr(sc->code); + key = cadr(key); + if (!is_pair(val)) { + if (is_symbol(val)) + val = lookup_checked(sc, val); + sc->value = s7_let_set(sc, cx, key, val); + return (goto_start); + } + push_op_stack(sc, sc->let_set_function); + sc->args = list_2(sc, key, cx); + sc->code = cdr(sc->code); + return (goto_eval_args); + } + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, cx), cdr(sc->code)); + push_op_stack(sc, sc->let_set_function); + sc->code = cadar(sc->code); + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); +} + +static goto_t set_implicit_function(s7_scheme * sc, s7_pointer cx) +{ /* (let ((lst (list 1 2))) (set! (list-ref lst 0) 2) lst) */ + if (!is_t_procedure(c_function_setter(cx))) { + if (!is_any_macro(c_function_setter(cx))) + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, no_setter_string, caar(sc->code), + sc->prepackaged_type_names[type(cx)])); + if (is_null(cdar(sc->code))) + sc->args = cdr(sc->code); + else + sc->args = pair_append(sc, cdar(sc->code), cdr(sc->code)); + sc->code = c_function_setter(cx); + return (goto_apply); + } + /* here the setter can be anything, so we need to check the needs_copied_args bit. (set! ((dilambda / (let ((x 3)) (lambda (y) (+ x y))))) 3)! */ + if (is_pair(cdar(sc->code))) { + if ((is_symbol(cadr(sc->code))) && (is_symbol(cadar(sc->code)))) { + if (is_null(cddar(sc->code))) { + if (needs_copied_args(c_function_setter(cx))) + sc->args = + list_2(sc, lookup_checked(sc, cadar(sc->code)), + lookup_checked(sc, cadr(sc->code))); + else { + s7_pointer val1, val2; + val1 = lookup_checked(sc, cadar(sc->code)); + val2 = lookup_checked(sc, cadr(sc->code)); + set_car(sc->t2_1, val1); + set_car(sc->t2_2, val2); + sc->args = sc->t2_1; + } + sc->code = c_function_setter(cx); + return (goto_apply); /* check arg num etc */ + } + if ((is_symbol(caddar(sc->code))) && + (is_null(cdddar(sc->code)))) { + if (needs_copied_args(c_function_setter(cx))) + sc->args = list_3(sc, + lookup_checked(sc, cadar(sc->code)), + lookup_checked(sc, caddar(sc->code)), + lookup_checked(sc, cadr(sc->code))); + else { + s7_pointer val1, val2, val3; + val1 = lookup_checked(sc, cadar(sc->code)); + val2 = lookup_checked(sc, caddar(sc->code)); + val3 = lookup_checked(sc, cadr(sc->code)); + set_car(sc->t3_1, val1); + set_car(sc->t3_2, val2); + set_car(sc->t3_3, val3); + sc->args = sc->t3_1; + } + sc->code = c_function_setter(cx); + return (goto_apply); /* check arg num etc */ + } + } + push_op_stack(sc, c_function_setter(cx)); + sc->value = + (is_null(cddar(sc->code))) ? cdr(sc->code) : pair_append(sc, + cddar + (sc->code), + cdr + (sc->code)); + push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->value); + sc->code = cadar(sc->code); + } else { + if ((is_null(cddr(sc->code))) && (!is_pair(cadr(sc->code)))) { + if (needs_copied_args(c_function_setter(cx))) + sc->args = + list_1(sc, + (is_symbol(cadr(sc->code))) ? lookup_checked(sc, + cadr + (sc->code)) + : cadr(sc->code)); + else { + if (is_symbol(cadr(sc->code))) + set_car(sc->t1_1, lookup_checked(sc, cadr(sc->code))); + else + set_car(sc->t1_1, cadr(sc->code)); + sc->args = sc->t1_1; + } + sc->code = c_function_setter(cx); + return (goto_apply); /* check arg num etc */ + } + push_op_stack(sc, c_function_setter(cx)); + push_stack(sc, OP_EVAL_ARGS1, sc->nil, cddr(sc->code)); + sc->code = cadr(sc->code); + } + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); +} + +static goto_t set_implicit_closure(s7_scheme * sc, s7_pointer cx) +{ + s7_pointer setter = closure_setter(cx); + if ((setter == sc->F) && (!closure_no_setter(cx))) + setter = g_setter(sc, set_plist_1(sc, cx)); + if (is_t_procedure(setter)) { + /* (set! (o g) ...), here cx = o, sc->code = ((o g) ...) */ + push_op_stack(sc, setter); + if (is_null(cdar(sc->code))) { + push_stack(sc, OP_EVAL_ARGS1, sc->nil, cddr(sc->code)); + sc->code = cadr(sc->code); + } else { + if (is_null(cddar(sc->code))) + push_stack(sc, OP_EVAL_ARGS1, sc->nil, cdr(sc->code)); + else { + sc->value = + pair_append(sc, cddar(sc->code), cdr(sc->code)); + push_stack(sc, OP_EVAL_ARGS4, sc->nil, sc->value); + } + sc->code = cadar(sc->code); + } + } else { + if (!is_any_macro(setter)) + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, no_setter_string, caar(sc->code), + sc->prepackaged_type_names[type(cx)])); + if (is_null(cdar(sc->code))) + sc->args = cdr(sc->code); + else + sc->args = pair_append(sc, cdar(sc->code), cdr(sc->code)); + sc->code = setter; + return (goto_apply); + } + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); +} + +static goto_t set_implicit_iterator(s7_scheme * sc, s7_pointer cx) +{ + s7_pointer setter = iterator_sequence(cx); + if ((is_any_closure(setter)) || (is_any_macro(setter))) + setter = closure_setter(iterator_sequence(cx)); + else + setter = sc->F; + if (is_procedure(setter)) { + push_op_stack(sc, setter); + push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->nil); + sc->code = cadr(sc->code); /* the (as yet unevaluated) value, incoming code was ((obj) val) */ + } else { + if (!is_any_macro(setter)) + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, no_setter_string, caar(sc->code), + sc->prepackaged_type_names[type(cx)])); + sc->args = cdr(sc->code); + sc->code = setter; + return (goto_apply); + } + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); +} + +static goto_t set_implicit_syntax(s7_scheme * sc, s7_pointer cx) +{ + if (cx != global_value(sc->with_let_symbol)) + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, no_setter_string, caar(sc->code), + sc->prepackaged_type_names[type(cx)])); + + /* (set! (with-let a b) x), cx = with-let, sc->code = ((with-let a b) x) + * a and x are in the current let, b is in a, we need to evaluate a and x, then + * call (with-let a-value (set! b x-value)) + */ + sc->args = cdar(sc->code); + sc->code = cadr(sc->code); + push_stack_direct(sc, OP_SET_WITH_LET_1); + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); +} + +static goto_t set_implicit(s7_scheme * sc) +{ /* sc->code incoming is (set! (...) ...) */ + s7_pointer caar_code, cx, form = sc->code; + sc->code = cdr(sc->code); + caar_code = caar(sc->code); + if (is_symbol(caar_code)) { + /* this was cx = s7_symbol_value(sc, caar_code) but the function call overhead is noticeable */ + cx = lookup_slot_from(caar_code, sc->curlet); + if (is_slot(cx)) + cx = slot_value(cx); + else + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, no_setter_string, caar_code, + sc->prepackaged_type_names[type(cx)])); + } else if (is_pair(caar_code)) { + push_stack(sc, OP_SET2, cdar(sc->code), T_Pair(cdr(sc->code))); + sc->code = caar_code; + sc->cur_op = optimize_op(sc->code); + return (goto_top_no_pop); + } else + cx = caar_code; + + /* code here is the setter and the value without the "set!": ((window-width) 800) */ + /* (set! (hi 0) (* 2 3)) -> ((hi 0) (* 2 3)) */ + /* for gmp case, indices need to be decoded via s7_integer, not just integer */ + + switch (type(cx)) { + case T_STRING: + return (set_implicit_string(sc, cx, form)); + case T_PAIR: + return (set_implicit_pair(sc, cx, form)); + case T_HASH_TABLE: + return (set_implicit_hash_table(sc, cx, form)); + case T_LET: + return (set_implicit_let(sc, cx, form)); + case T_C_OBJECT: + return (set_implicit_c_object(sc, cx, form)); + case T_ITERATOR: + return (set_implicit_iterator(sc, cx)); /* not sure this makes sense */ + case T_SYNTAX: + return (set_implicit_syntax(sc, cx)); + + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + case T_BYTE_VECTOR: + return (set_implicit_vector(sc, cx, form)); + + case T_C_MACRO: + case T_C_OPT_ARGS_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + case T_C_FUNCTION: + case T_C_FUNCTION_STAR: + return (set_implicit_function(sc, cx)); + + case T_MACRO: + case T_MACRO_STAR: + case T_BACRO: + case T_BACRO_STAR: + case T_CLOSURE: + case T_CLOSURE_STAR: + return (set_implicit_closure(sc, cx)); + + default: /* (set! (1 2) 3) */ + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, no_setter_string, caar_code, + sc->prepackaged_type_names[type(cx)])); + } + return (goto_top_no_pop); +} + + +/* -------------------------------- do -------------------------------- */ +static bool safe_stepper_expr(s7_pointer expr, s7_pointer var) +{ + /* for now, just look for stepper as last element of any list + * any embedded set is handled by do_is_safe, so we don't need to descend into the depths + */ + s7_pointer p; + if (cadr(expr) == var) + return (false); + for (p = cdr(expr); is_pair(cdr(p)); p = cdr(p)); + + if (is_pair(p)) { + if ((is_optimized(p)) && + (op_has_hop(p)) && (is_safe_c_op(optimize_op(p)))) + return (true); + if (car(p) == var) + return (false); + } else if (p == var) + return (false); + return (true); +} + +static bool tree_match(s7_pointer tree) +{ + if (is_symbol(tree)) + return (is_matched_symbol(tree)); + return ((is_pair(tree)) && + ((tree_match(car(tree))) || (tree_match(cdr(tree))))); +} + +static bool do_is_safe(s7_scheme * sc, s7_pointer body, s7_pointer stepper, + s7_pointer var_list, bool *has_set) +{ + /* here any (unsafe?) closure or jumping-op (call/cc) or shadowed variable is trouble + * we can free var_list if return(false) not after (!do_is_safe...), but it seems to make no difference, or be slightly slower + */ + s7_pointer p; + /* sc->code is the complete do form (do ...) */ + for (p = body; is_pair(p); p = cdr(p)) { + s7_pointer expr = car(p); + if (is_pair(expr)) { + s7_pointer x = car(expr); + if ((is_symbol(x)) + || ((is_c_function(x)) && (is_safe_procedure(x)))) { + if (is_symbol_and_syntactic(x)) { + opcode_t op; + s7_pointer func = global_value(x), vars, cp; + op = (opcode_t) syntax_opcode(func); + switch (op) { + case OP_MACROEXPAND: + return (false); + + case OP_QUOTE: + if ((!is_pair(cdr(expr))) || (!is_null(cddr(expr)))) /* (quote . 1) or (quote 1 2) etc */ + return (false); + break; + + case OP_LET: + case OP_LET_STAR: + case OP_LETREC: + case OP_LETREC_STAR: + if ((!is_pair(cdr(expr))) || + (!is_list(cadr(expr))) || + (!is_pair(cddr(expr)))) + return (false); + cp = var_list; + + for (vars = cadr(expr); is_pair(vars); + vars = cdr(vars)) { + s7_pointer var; + if (!is_pair(car(vars))) + return (false); + var = caar(vars); + if (direct_memq(var, ((op == OP_LET) + || (op == + OP_LETREC)) ? cp : + var_list)) + return (false); + if ((!is_symbol(var)) || (is_keyword(var))) + return (false); + cp = cons(sc, var, cp); + sc->x = cp; + } + sc->x = sc->nil; + if (!do_is_safe + (sc, cddr(expr), stepper, cp, has_set)) + return (false); + break; + + case OP_DO: + if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (do) or (do (...)) */ + return (false); + cp = var_list; + for (vars = cadr(expr); is_pair(vars); + vars = cdr(vars)) { + s7_pointer var; + if (!is_pair(car(vars))) + return (false); + var = caar(vars); + if ((direct_memq(var, cp)) || (var == stepper)) + return (false); + cp = cons(sc, var, cp); + sc->x = cp; + if ((is_pair(cdar(vars))) && + (!do_is_safe + (sc, cdar(vars), stepper, cp, has_set))) { + sc->x = sc->nil; + return (false); + } + } + sc->x = sc->nil; + if (!do_is_safe + (sc, caddr(expr), stepper, cp, has_set)) + return (false); + if ((is_pair(cdddr(expr))) && + (!do_is_safe + (sc, cdddr(expr), stepper, cp, has_set))) + return (false); + break; + + case OP_SET: + { + s7_pointer settee; + if (!is_pair(cdr(expr))) /* (set!) */ + return (false); + settee = cadr(expr); + if (!is_symbol(settee)) { /* (set! (...) ...) which is tricky due to setter functions/macros */ + s7_pointer setv; + if ((!is_pair(settee)) || + (!is_symbol(car(settee)))) + return (false); + setv = lookup_unexamined(sc, car(settee)); + if (!((setv) && + ((is_sequence(setv)) || + ((is_c_function(setv)) && + (is_safe_procedure + (c_function_setter(setv))))))) + return (false); + if (has_set) + (*has_set) = true; + } else { + if ((is_pair(caddr(sc->code))) && /* sc->code = do-form (formerly (cdr(do-form)) causing a bug here) */ + (is_pair(caaddr(sc->code)))) { + bool res; + set_match_symbol(settee); + res = tree_match(caaddr(sc->code)); /* (set! end ...) in some fashion */ + clear_match_symbol(settee); + if (res) + return (false); + } + if ((has_set) && (!direct_memq(cadr(expr), var_list))) /* is some non-local variable being set? */ + (*has_set) = true; + } + if (!do_is_safe + (sc, cddr(expr), stepper, var_list, + has_set)) + return (false); + if (!safe_stepper_expr(expr, stepper)) /* is step var's value used as the stored value by set!? */ + return (false); + } + break; + + case OP_LET_TEMPORARILY: + if ((!is_pair(cdr(expr))) || + (!is_pair(cadr(expr))) || + (!is_pair(cddr(expr)))) + return (false); + for (cp = cadr(expr); is_pair(cp); cp = cdr(cp)) + if ((!is_pair(car(cp))) || + (!is_pair(cdar(cp))) || + (!do_is_safe + (sc, cdar(cp), stepper, var_list, + has_set))) + return (false); + if (!do_is_safe + (sc, cddr(expr), stepper, var_list, has_set)) + return (false); + break; + + case OP_COND: + for (cp = cdr(expr); is_pair(cp); cp = cdr(cp)) + if (!do_is_safe + (sc, car(cp), stepper, var_list, has_set)) + return (false); + break; + + case OP_CASE: + if ((!is_pair(cdr(expr))) || + (!do_is_safe + (sc, cadr(expr), stepper, var_list, has_set))) + return (false); + for (cp = cddr(expr); is_pair(cp); cp = cdr(cp)) + if ((!is_pair(car(cp))) || /* (case x #(123)...) */ + (!do_is_safe + (sc, cdar(cp), stepper, var_list, + has_set))) + return (false); + break; + + case OP_IF: + case OP_WHEN: + case OP_UNLESS: + case OP_AND: + case OP_OR: + case OP_BEGIN: + case OP_WITH_BAFFLE: + if (!do_is_safe + (sc, cdr(expr), stepper, var_list, has_set)) + return (false); + break; + + case OP_WITH_LET: + return (true); /* ?? did I mean false here?? */ + + default: + return (false); + } + } /* is_syntax(x=car(expr)) */ + else { + /* if a macro, we'll eventually expand it (if *_optimize), but that requires a symbol lookup here and macroexpand */ + if ((!is_optimized(expr)) || + (optimize_op(expr) == OP_UNKNOWN_NP) || + (!do_is_safe + (sc, cdr(expr), stepper, var_list, has_set))) + return (false); + + if ((is_symbol(x)) && (is_setter(x))) { /* "setter" includes stuff like cons and vector -- x is a symbol */ + /* (hash-table-set! ht i 0) -- caddr is being saved, so this is not safe + * similarly (vector-set! v 0 i) etc + */ + if (is_null(cdr(expr))) /* (vector) for example */ + return ((x == sc->vector_symbol) || + (x == sc->list_symbol) || + (x == sc->string_symbol)); + + if ((has_set) && (!direct_memq(cadr(expr), var_list)) && /* non-local is being changed */ + ((cadr(expr) == stepper) || /* stepper is being set? */ + (!is_pair(cddr(expr))) || + (!is_pair(cdddr(expr))) || + (is_pair(cddddr(expr))) || + ((x == sc->hash_table_set_symbol) && + (is_symbol(caddr(expr))) && + (caddr(expr) == stepper)) || + ((is_symbol(cadddr(expr))) && + (cadddr(expr) == stepper)) || + ((is_pair(cadddr(expr))) && + (s7_tree_memq(sc, stepper, cadddr(expr)))))) + (*has_set) = true; + + if (!do_is_safe + (sc, cddr(expr), stepper, var_list, has_set)) + return (false); + if (!safe_stepper_expr(expr, stepper)) + return (false); + } + } + } /* is_symbol(x=car(expr)) */ + else + return (false); + /* car(expr) ("x") is not a symbol: ((mus-data loc) chan) for example + * but that's actually safe since it's just in effect vector-ref + * there are several examples in dlocsig: ((group-speakers group) i) etc + */ + } + } + return (true); +} + +static bool preserves_type(s7_scheme * sc, uint32_t x) +{ + return ((x == sc->add_class) || + (x == sc->subtract_class) || (x == sc->multiply_class)); +} + +static s7_pointer simple_stepper(s7_scheme * sc, s7_pointer v) +{ + if ((is_proper_list_3(sc, v)) && (is_fxable(sc, cadr(v)))) { + s7_pointer step_expr = caddr(v); + if ((is_optimized(step_expr)) && (((optimize_op(step_expr) == HOP_SAFE_C_SC) && (car(v) == cadr(step_expr))) || ((is_h_safe_c_d(step_expr)) && /* replace with is_fxable? */ + (is_pair(cdr(step_expr))) && /* ((v 0 (+))) */ + (car(v) == cadr(step_expr)) && ((opt1_cfunc(step_expr) == sc->add_x1) || (opt1_cfunc(step_expr) == sc->subtract_x1))) || ((optimize_op(step_expr) == HOP_SAFE_C_CS) && (car(v) == caddr(step_expr))))) + return (step_expr); + } + return (NULL); +} + +static bool is_simple_end(s7_scheme * sc, s7_pointer end) +{ + return ((is_optimized(end)) && (is_safe_c_op(optimize_op(end))) && (is_pair(cddr(end))) && /* end: (zero? n) */ + (cadr(end) != caddr(end)) && + ((opt1_cfunc(end) == sc->num_eq_xi) || + (optimize_op(end) == HOP_SAFE_C_SS) + || (optimize_op(end) == HOP_SAFE_C_SC))); +} + +static s7_pointer fxify_step_exprs(s7_scheme * sc, s7_pointer code) +{ + s7_pointer p, e, vars = car(code); + e = collect_variables(sc, vars, sc->nil); /* only valid in step exprs, not in inits */ + + for (p = vars; is_pair(p); p = cdr(p)) { + s7_function callee = NULL; + s7_pointer expr = cdar(p); /* init */ + if (is_pair(expr)) { + callee = fx_choose(sc, expr, sc->nil, do_symbol_is_safe); /* not vars -- they aren't defined yet */ + if (callee) + set_fx(expr, callee); + } + expr = cddar(p); /* step */ + if (is_pair(expr)) { + if ((is_pair(car(expr))) && (!is_checked(car(expr)))) + optimize_expression(sc, car(expr), 0, e, false); + callee = fx_choose(sc, expr, vars, do_symbol_is_safe); /* fx_proc can be nil! */ + if (callee) + set_fx(expr, callee); + } + } + if ((is_pair(cdr(code))) && (is_pair(cadr(code)))) { + s7_pointer result; + result = cdadr(code); + if ((is_pair(result)) && (is_fxable(sc, car(result)))) + set_fx_direct(result, + fx_choose(sc, result, vars, do_symbol_is_safe)); + } + return (code); +} + +static bool do_vector_has_definers(s7_scheme * sc, s7_pointer v) +{ + s7_int i, len = vector_length(v); + s7_pointer *els = vector_elements(v); + for (i = 0; i < len; i++) + if ((is_pair(els[i])) && (is_symbol(car(els[i]))) && (is_definer(car(els[i])))) /* this is a desperate kludge */ + return (true); + return (false); +} + +static inline bool do_tree_has_definers(s7_scheme * sc, s7_pointer tree) +{ + /* we can't be very fancy here because quote gloms up everything: (cond '(define x 0) ...) etc, and the tree here can + * be arbitrarily messed up, and we need to be reasonably fast. So we accept some false positives: (case ((define)...)...) or '(define...) + * but what about ((f...)...) where (f...) returns a macro that defines something? Or (for-each or ...) where for-each and or might be + * obfuscated and the args might contain a definer? + */ + s7_pointer p; + for (p = tree; is_pair(p); p = cdr(p)) { + s7_pointer pp = car(p); + if (is_symbol(pp)) { + if ((is_definer(pp)) && ((pp != sc->varlet_symbol) || ((is_pair(cdr(p))) && /* if varlet, is target let local? */ + (is_symbol(cadr(p))) && (!symbol_is_in_list(sc, cadr(p)))))) + return (true); + } else if (is_pair(pp)) { + if (do_tree_has_definers(sc, pp)) + return (true); + } else if ((is_applicable(pp)) && (((is_normal_vector(pp)) + && + (do_vector_has_definers + (sc, pp))) + || ((is_c_function(pp)) + && (is_func_definer(pp))) + || ((is_syntax(pp)) + && + (is_syntax_definer(pp))))) + return (true); + } + return (false); +} + +static void check_do_for_obvious_errors(s7_scheme * sc, s7_pointer form) +{ + s7_pointer x, code = cdr(form); + + if ((!is_pair(code)) || /* (do . 1) */ + ((!is_pair(car(code))) && /* (do 123) */ + (is_not_null(car(code))))) /* (do () ...) is ok */ + eval_error(sc, "do: variable list is not a list: ~S", 35, form); + + if (!is_pair(cdr(code))) /* (do () . 1) */ + eval_error(sc, "do body is messed up: ~A", 24, form); + + if ((!is_pair(cadr(code))) && /* (do ((i 0)) 123) */ + (is_not_null(cadr(code)))) /* no end-test? */ + eval_error(sc, "do: end-test and end-value list is not a list: ~A", + 49, form); + + if (is_pair(car(code))) { + clear_symbol_list(sc); + for (x = car(code); is_pair(x); x = cdr(x)) { + s7_pointer y; + y = car(x); + if (!(is_pair(y))) /* (do (4) (= 3)) */ + eval_error(sc, "do: variable name missing? ~A", 29, form); + + if (!is_symbol(car(y))) /* (do ((3 2)) ()) */ + eval_error(sc, "do step variable: ~S is not a symbol?", 37, + y); + + if (is_constant_symbol(sc, car(y))) /* (do ((pi 3 (+ pi 1))) ((= pi 4)) pi) */ + eval_error(sc, "do step variable: ~S is immutable", 33, y); + + if (!is_pair(cdr(y))) + eval_error(sc, + "do: step variable has no initial value: ~A", + 42, x); + if (!is_pair(cddr(y))) { + if (is_not_null(cddr(y))) /* (do ((i 0 . 1)) ...) */ + eval_error(sc, + "do: step variable info is an improper list?: ~A", + 47, x); + } else if (is_not_null(cdddr(y))) /* (do ((i 0 1 (+ i 1))) ...) */ + eval_error(sc, + "do: step variable info has extra stuff after the increment: ~A", + 62, x); + set_local(car(y)); + + if (symbol_is_in_list(sc, car(y))) /* (do ((i 0 (+ i 1)) (i 2))...) */ + eval_error(sc, "duplicate identifier in do: ~A", 30, x); + add_symbol_to_list(sc, car(y)); + } + if (is_not_null(x)) /* (do ((i 0 i) . 1) ((= i 1))) */ + eval_error(sc, "do: list of variables is improper: ~A", 37, + form); + } + if (is_pair(cadr(code))) { + for (x = cadr(code); is_pair(x); x = cdr(x)); + if (is_not_null(x)) + eval_error(sc, "stray dot in do end section? ~A", 31, form); + } + for (x = cddr(code); is_pair(x); x = cdr(x)); + if (is_not_null(x)) + eval_error(sc, "stray dot in do body? ~A", 24, form); +} + +static s7_pointer do_end_bad(s7_scheme * sc, s7_pointer form) +{ + s7_pointer code = cdr(form); + if (is_null(cddr(code))) { + s7_pointer p; + /* no body, end not fxable (if eval car(end) might be unopt) */ + for (p = car(code); is_pair(p); p = cdr(p)) { /* gather var names */ + s7_pointer var = car(p); + if (is_pair(cddr(var))) /* if no step expr it's safe in other step exprs 16-Apr-19 */ + set_match_symbol(car(var)); + } + for (p = car(code); is_pair(p); p = cdr(p)) { /* look for stuff like (do ((i 0 j) (j 0 (+ j 1))) ((= j 3) i)) */ + s7_pointer var = car(p), val; + val = cddr(var); + if (is_pair(val)) { + clear_match_symbol(car(var)); /* ignore current var */ + if (tree_match(car(val))) { + s7_pointer q; + for (q = car(code); is_pair(q); q = cdr(q)) + clear_match_symbol(caar(q)); + return (code); + } + } + set_match_symbol(car(var)); + } + for (p = car(code); is_pair(p); p = cdr(p)) /* clear var names */ + clear_match_symbol(caar(p)); + + if (is_null(p)) { + if ((is_null(cadr(code))) && /* (do () ()) or (do (fxable vars) ()) */ + (is_null(cddr(code)))) { + if (sc->safety > 0) + s7_warn(sc, 256, "%s: infinite do loop: %s\n", + __func__, display(form)); + return (code); + } + + fxify_step_exprs(sc, code); + for (p = car(code); is_pair(p); p = cdr(p)) { + s7_pointer var = car(p); + if ((!has_fx(cdr(var))) || + ((is_pair(cddr(var))) && (!has_fx(cddr(var))))) + return (code); + } + pair_set_syntax_op(form, OP_DO_NO_BODY_FX_VARS); + return (sc->nil); + } + } + return (fxify_step_exprs(sc, code)); +} + +static bool do_expr_tree(s7_scheme * sc, s7_pointer expr) +{ + if ((!expr) || (!is_pair(expr))) + return (false); + if ((is_funclet(sc->curlet)) && (tis_slot(let_slots(sc->curlet)))) { + s7_pointer s1 = let_slots(sc->curlet), s2; + s2 = next_slot(s1); + fx_tree_in(sc, expr, + slot_symbol(s1), + (tis_slot(s2)) ? slot_symbol(s2) : NULL, ((tis_slot(s2)) + && + (tis_slot + (next_slot + (s2)))) ? + slot_symbol(next_slot(s2)) : NULL, ((tis_slot(s2)) + && + (tis_slot + (next_slot(s2))))); + + } + return (true); +} + +static s7_pointer check_do(s7_scheme * sc) +{ + /* returns nil if optimizable */ + s7_pointer form = sc->code, code, vars, end, body, p, e; + + check_do_for_obvious_errors(sc, form); + pair_set_syntax_op(form, OP_DO_UNCHECKED); + code = cdr(form); + end = cadr(code); + + if ((!is_pair(end)) || (!is_fxable(sc, car(end)))) + return (do_end_bad(sc, form)); + + set_fx_direct(end, + fx_choose(sc, end, sc->curlet, + let_symbol_is_safe_or_listed)); + if ((is_pair(cdr(end))) && (is_fxable(sc, cadr(end)))) + set_fx_direct(cdr(end), + fx_choose(sc, cdr(end), sc->curlet, + let_symbol_is_safe_or_listed)); + + vars = car(code); + if (is_null(vars)) { + pair_set_syntax_op(form, OP_DO_NO_VARS); + return (sc->nil); + } + if (do_tree_has_definers(sc, form)) /* we don't want definers in body, vars, or end test */ + return (fxify_step_exprs(sc, code)); + + if ((is_pair(vars)) && (is_null(cdr(vars)))) + fx_tree(sc, end, caar(vars), NULL, NULL, false); + + for (e = sc->curlet; (is_let(e)) && (e != sc->rootlet); + e = let_outlet(e)) + if ((is_funclet(e)) || (is_maclet(e))) { + s7_pointer fname, fval; + fname = funclet_function(e); + fval = s7_symbol_local_value(sc, fname, e); + if ((is_closure(fval)) && (is_safe_closure(fval))) { + if ((is_pair(vars)) && (is_null(cdr(vars))) && /* so do var is always == t (see mk2 in s7test) */ + (tis_slot(let_slots(sc->curlet))) && /* let + 1 var, or funclet (so var order is guaranteed */ + ((!tis_slot(next_slot(let_slots(sc->curlet)))) || + (is_funclet(sc->curlet)))) { + s7_pointer var1, var2 = NULL, var3 = NULL; + p = let_slots(sc->curlet); + var1 = slot_symbol(p); + if (tis_slot(next_slot(p))) + var2 = slot_symbol(next_slot(p)); + if ((var2) && (tis_slot(next_slot(next_slot(p))))) + var3 = slot_symbol(next_slot(next_slot(p))); + fx_tree_outer(sc, end, var1, var2, var3, var3); + + for (p = vars; is_pair(p); p = cdr(p)) { + s7_pointer var = car(p); + if (is_pair(cdr(var))) { + fx_tree(sc, cadr(var), var1, var2, var3, var3); + if (is_pair(cddr(var))) + fx_tree_outer(sc, caddr(var), var1, var2, + var3, var3); + } + } + } + } + break; + } + + body = cddr(code); + if ((is_pair(end)) && (is_pair(car(end))) && + (is_pair(vars)) && (is_null(cdr(vars))) && + (is_pair(body)) && (is_pair(car(body))) && ((is_symbol(caar(body))) + || + ((is_c_function + (caar(body))) + && + (is_safe_procedure + (caar(body)))))) { + /* loop has one step variable, and normal-looking end test */ + s7_pointer v = car(vars), step_expr; + + step_expr = simple_stepper(sc, v); + if (step_expr) { + s7_pointer orig_end = end; + set_fx(cdr(v), fx_choose(sc, cdr(v), vars, do_symbol_is_safe)); /* v is (i 0 (+ i 1)) or the like */ + + /* step var is (var const|symbol (op var const)|(op const var)) */ + end = car(end); + if ((is_simple_end(sc, end)) && (car(v) == cadr(end))) { + /* end var is (op var const|symbol) using same var as step so at least we can use SIMPLE_DO */ + bool has_set = false, one_line; + one_line = ((is_null(cdr(body))) && (is_pair(car(body)))); + + if ((car(end) == sc->num_eq_symbol) + && (is_symbol(cadr(end))) + && (is_t_integer(caddr(end)))) { + set_c_function(end, sc->num_eq_2); + set_opt2_con(cdr(end), caddr(end)); + set_fx_direct(orig_end, + (integer(caddr(end)) == + 0) ? fx_num_eq_s0 : fx_num_eq_si); + } + set_opt1_any(code, caddr(end)); /* symbol or int(?) */ + set_opt2_pair(code, step_expr); /* caddr(caar(code)) */ + pair_set_syntax_op(form, OP_SIMPLE_DO); /* simple_do: 1 var easy step/end */ + + if ((c_function_class(opt1_cfunc(step_expr)) == sc->add_class) && /* we check above that (car(v) == cadr(step_expr)) and (car(v) == cadr(end)) */ + ((c_function_class(opt1_cfunc(end)) == + sc->num_eq_class) + || (opt1_cfunc(end) == sc->geq_2))) { + if ((one_line) && ((!is_optimized(car(body))) || (op_no_hop(car(body)) != OP_SAFE_C_NC)) && /* this does happen: (if (= i 3) (vector-set! j 0 i)) */ + (is_symbol_and_syntactic(caar(body))) && (s7_is_integer(caddr(step_expr))) && /* this currently blocks s7_optimize of float steppers */ + (s7_integer_checked(sc, caddr(step_expr)) == 1)) { + pair_set_syntax_op(car(body), + symbol_syntax_op_checked(car + (body))); + pair_set_syntax_op(form, OP_DOTIMES_P); /* dotimes_p: simple + syntax body + 1 expr */ + } + + if (((caddr(step_expr) == int_one) + || (cadr(step_expr) == int_one)) + && + (do_is_safe(sc, body, car(v), sc->nil, &has_set))) + { + pair_set_syntax_op(form, OP_SAFE_DO); /* safe_do: body is safe, step by 1 */ + /* no permanent let here because apparently do_is_safe accepts recursive calls? */ + if ((!has_set) && + (c_function_class(opt1_cfunc(end)) == + sc->num_eq_class)) { + pair_set_syntax_op(form, OP_SAFE_DOTIMES); /* safe_dotimes: end is = */ + if (is_fxable(sc, car(body))) + fx_annotate_arg(sc, body, + collect_variables(sc, vars, + sc->nil)); + } + fx_tree(sc, body, car(v), NULL, NULL, false); + /* an experiment (this never works...) */ + if (stack_op(sc->stack, current_stack_top(sc) - 1) + == OP_SAFE_DO_STEP) + fx_tree_outer(sc, body, + caaar(stack_code + (sc->stack, + (current_stack_top(sc) - + 1))), NULL, NULL, true); + } + } + return (sc->nil); + } + } + } + + /* we get here if there is more than one local var or anything "non-simple" about the rest */ + for (p = vars; is_pair(p); p = cdr(p)) { + s7_pointer var = car(p); + if ((!is_fxable(sc, cadr(var))) || + ((is_pair(cddr(var))) && (!is_fxable(sc, caddr(var)))) || + ((is_symbol(cadr(var))) && (is_definer_or_binder(cadr(var))))) + { + s7_pointer q; + for (q = vars; q != p; q = cdr(q)) + clear_match_symbol(caar(q)); + return (fxify_step_exprs(sc, code)); + } + if (is_pair(cddr(var))) /* if no step expr it's safe in other step exprs 16-Apr-19 */ + set_match_symbol(car(var)); + } + + { + s7_pointer stepper0 = NULL, stepper1 = NULL, stepper2 = + NULL, stepper3 = NULL, last_expr = NULL, previous_expr = NULL; + bool got_pending = false; + + for (p = vars; is_pair(p); p = cdr(p)) { + s7_pointer var = car(p), val; + stepper3 = stepper2; + stepper2 = stepper1; + stepper1 = stepper0; + previous_expr = last_expr; + stepper0 = car(var); + last_expr = cdr(var); /* inits refer to the outer let */ + val = cdr(last_expr); + if (is_pair(val)) { + var = car(var); + clear_match_symbol(var); /* ignore current var */ + if (tree_match(car(val))) { + s7_pointer q; + for (q = vars; is_pair(q); q = cdr(q)) + clear_match_symbol(caar(q)); + if (is_null(body)) + got_pending = true; + else + return (fxify_step_exprs(sc, code)); + } + set_match_symbol(var); + } + } + for (p = vars; is_pair(p); p = cdr(p)) + clear_match_symbol(caar(p)); + + /* end and steps look ok! */ + for (p = vars; is_pair(p); p = cdr(p)) { + s7_pointer var = car(p); + set_fx_direct(cdr(var), fx_choose(sc, cdr(var), sc->curlet, let_symbol_is_safe)); /* init val */ + if (is_pair(cddr(var))) { + s7_pointer step_expr = caddr(var); + set_fx_direct(cddr(var), fx_choose(sc, cddr(var), vars, do_symbol_is_safe)); /* sets opt2(cddr(var)), not opt1 */ + if (!is_pair(step_expr)) { /* (i 0 0) */ + if (cadr(var) == caddr(var)) /* not types match: (i x y) etc */ + set_safe_stepper_expr(cddr(var)); + } else { + s7_pointer endp, var1; + if ((car(step_expr) != sc->quote_symbol) && /* opt1_cfunc(==opt1) might not be set in this case (sigh) */ + (is_safe_c_op(optimize_op(step_expr))) && ((preserves_type(sc, c_function_class(opt1_cfunc(step_expr)))) || /* add etc */ + (car(step_expr) == sc->cdr_symbol) || (car(step_expr) == sc->cddr_symbol) || ((is_pair(cadr(var))) && (is_pair(c_function_signature(c_function_base(opt1_cfunc(step_expr))))) && (car(c_function_signature(c_function_base(opt1_cfunc(step_expr)))) != sc->T) && (caadr(var) == car(step_expr))))) /* i.e. accept char-position as init/step, but not iterate */ + set_safe_stepper_expr(cddr(var)); + + endp = car(end); + var1 = car(var); + if ((is_proper_list_3(sc, endp)) + && (is_proper_list_3(sc, step_expr)) + && ((car(endp) == sc->num_eq_symbol) + || (car(endp) == sc->geq_symbol)) + && (is_symbol(cadr(endp))) + && ((is_t_integer(caddr(endp))) + || (is_symbol(caddr(endp)))) + && (car(step_expr) == sc->add_symbol) + && (var1 == cadr(endp)) + && (var1 == cadr(step_expr)) + && ((car(endp) != sc->num_eq_symbol) + || ((caddr(step_expr) == int_one)))) + set_step_end_ok(end); + } + } + } + pair_set_syntax_op(form, + (got_pending) ? OP_DOX_PENDING_NO_BODY : + OP_DOX); + /* there are only a couple of cases in snd-test where a multi-statement do body is completely fx-able */ + + if ((is_null(body)) && + (is_null(cdr(vars))) && + (is_pair(cdr(end))) && + (is_null(cddr(end))) && + (has_fx(cdr(end))) && + (is_pair(cdar(vars))) && (is_pair(cddar(vars)))) { + s7_pointer var, step; + if (!in_heap(cdr(form))) + set_opt3_any(cdr(form), make_permanent_let(sc, vars)); + else + set_opt3_any(cdr(form), sc->F); + + if (!got_pending) + pair_set_syntax_op(form, OP_DOX_NO_BODY); + + var = caar(vars); + step = cddar(vars); + + if (is_safe_stepper_expr(step)) { + step = car(step); + if ((is_pair(step)) && (is_proper_list_3(sc, step))) { + if ((car(step) == sc->add_symbol) && + (((cadr(step) == var) && (caddr(step) == int_one)) + || (caddr(step) == var)) + && (cadr(step) == int_one)) + set_opt2_con(cdr(form), int_one); + else if ((car(step) == sc->subtract_symbol) && + (cadr(step) == var) && + (caddr(step) == int_one)) + set_opt2_con(cdr(form), minus_one); + else + set_opt2_con(cdr(form), int_zero); + } else + set_opt2_con(cdr(form), int_zero); + } else + set_opt2_con(cdr(form), int_zero); + } + if (do_passes_safety_check(sc, body, sc->nil, NULL)) { + if (stepper0) { + if ((is_pair(car(end))) && (has_fx(end)) && (!(is_syntax(caar(end)))) && (!((is_symbol(caar(end))) && (is_definer_or_binder(caar(end))))) && (!fx_tree_in(sc, end, stepper0, stepper1, stepper2, stepper3))) /* just the end-test, not the results */ + fx_tree(sc, car(end), stepper0, stepper1, stepper2, stepper3); /* car(end) might be (or ...) */ + + if ((is_pair(cdr(end))) && + (is_pair(cadr(end))) && + (is_null(cddr(end))) && + (has_fx(cdr(end))) && + (!fx_tree_in + (sc, cdr(end), stepper0, stepper1, stepper2, + stepper3))) + fx_tree(sc, cadr(end), stepper0, stepper1, stepper2, + stepper3); + + /* the bad case for results: (let ((vals3t with-baffle)) func+do+ (vals3t (* 2 i 3 4))) -> fx_t|u trouble */ + if (do_expr_tree(sc, last_expr)) { + last_expr = cdr(last_expr); + if (is_pair(last_expr)) + fx_tree(sc, last_expr, stepper0, stepper1, + stepper2, stepper3); + if (do_expr_tree(sc, previous_expr)) { + previous_expr = cdr(previous_expr); + if (is_pair(previous_expr)) + fx_tree(sc, previous_expr, stepper0, stepper1, + stepper2, stepper3); + } + } + } + if ((is_pair(body)) && (is_null(cdr(body))) && + (is_fxable(sc, car(body)))) { + fx_annotate_arg(sc, body, + collect_variables(sc, vars, sc->nil)); + fx_tree(sc, body, stepper0, stepper1, stepper2, stepper3); + } + } + } + return (sc->nil); +} + +static bool has_safe_steppers(s7_scheme * sc, s7_pointer let) +{ + s7_pointer slot; + for (slot = let_slots(let); tis_slot(slot); slot = next_slot(slot)) { + s7_pointer val = slot_value(slot); + if (slot_has_expression(slot)) { + s7_pointer step_expr = slot_expression(slot); + if (!is_pair(step_expr)) { + if ((is_null(step_expr)) || (type(step_expr) == type(val))) + set_safe_stepper(slot); + else + clear_safe_stepper(slot); + } else { + if (is_safe_stepper_expr(step_expr)) { + if (is_t_integer(val)) { + if (is_int_optable(step_expr)) + set_safe_stepper(slot); + else if (no_int_opt(step_expr)) + clear_safe_stepper(slot); + else { + sc->pc = 0; + if (int_optimize(sc, step_expr)) { + set_safe_stepper(slot); + set_is_int_optable(step_expr); + } else { + clear_safe_stepper(slot); + set_no_int_opt(step_expr); + } + } + } else if (is_small_real(val)) { + if (is_float_optable(step_expr)) + set_safe_stepper(slot); + else if (no_float_opt(step_expr)) + clear_safe_stepper(slot); + else { + sc->pc = 0; + if (float_optimize(sc, step_expr)) { + set_safe_stepper(slot); + set_is_float_optable(step_expr); + } else { + clear_safe_stepper(slot); + set_no_float_opt(step_expr); + } + } + } else + set_safe_stepper(slot); /* ?? shouldn't this check types ?? */ + } + } + } else { + if (is_t_real(val)) + slot_set_value(slot, s7_make_mutable_real(sc, real(val))); + if (is_t_integer(val)) + slot_set_value(slot, + make_mutable_integer(sc, integer(val))); + set_safe_stepper(slot); + } + if (!is_safe_stepper(slot)) + return (false); + } + return (true); +} + +static bool copy_if_end_ok(s7_scheme * sc, s7_pointer dest, + s7_pointer source, s7_int i, s7_pointer endp, + s7_pointer stepper, opt_info * o) +{ + if ((fn_proc(endp) == g_num_eq_2) && (is_symbol(cadr(endp))) + && (is_symbol(caddr(endp)))) { + s7_pointer end_slot; + end_slot = + lookup_slot_from((cadr(endp) == + slot_symbol(stepper)) ? caddr(endp) : + cadr(endp), sc->curlet); + if ((is_slot(end_slot)) && (is_t_integer(slot_value(end_slot)))) { + copy_to_same_type(sc, dest, source, i, + integer(slot_value(end_slot)), i); + return (true); + } + } + return (false); +} + +static bool op_dox_init(s7_scheme * sc) +{ + s7_pointer let, vars, test, code = cdr(sc->code); + let = make_let(sc, sc->curlet); + sc->temp1 = let; + for (vars = car(code); is_pair(vars); vars = cdr(vars)) { + add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars))); + if (is_pair(cddar(vars))) + slot_set_expression(let_slots(let), cddar(vars)); + else + slot_just_set_expression(let_slots(let), sc->nil); + } + set_curlet(sc, let); + sc->temp1 = sc->nil; + test = cadr(code); + if (is_true(sc, sc->value = fx_call(sc, test))) { + sc->code = cdr(test); + return (true); /* goto DO_END_CLAUSES */ + } + sc->code = T_Pair(cddr(code)); + push_stack_no_args(sc, + (intptr_t) ((is_null(cdr(sc->code))) ? OP_DOX_STEP_O + : OP_DOX_STEP), code); + return (false); /* goto BEGIN */ +} + +static goto_t op_dox_no_body_1(s7_scheme * sc, s7_pointer slots, + s7_pointer end, int32_t steppers, + s7_pointer stepper) +{ + s7_function endf; + s7_pointer endp = car(end); + endf = fx_proc(end); + if (endf == fx_c_nc) { + endf = fn_proc(endp); + endp = cdr(endp); + } + if (steppers == 1) { + s7_function f; + s7_pointer a; + f = fx_proc(slot_expression(stepper)); /* e.g. fx_add_s1 */ + a = car(slot_expression(stepper)); + if (f == fx_c_nc) { + f = fn_proc(a); + a = cdr(a); + } + if (((f == fx_cdr_s) || (f == fx_cdr_t)) && + (cadr(a) == slot_symbol(stepper))) { + do { + slot_set_value(stepper, cdr(slot_value(stepper))); + } while (endf(sc, endp) == sc->F); + sc->value = sc->T; + } else { + /* (- n 1) tpeak dup */ + if (((f == fx_add_t1) || (f == fx_add_u1)) + && (is_t_integer(slot_value(stepper)))) { + s7_pointer p; + p = make_mutable_integer(sc, integer(slot_value(stepper))); + slot_set_value(stepper, p); + if (!no_bool_opt(end)) { + sc->pc = 0; + if (bool_optimize(sc, end)) { /* in dup.scm this costs more than the fb(o) below saves (search is short) */ + /* but tc is much slower (and bool|int_optimize dominates) */ + opt_info *o = sc->opts[0]; + bool (*fb)(opt_info * o); + fb = o->v[0].fb; + do { + integer(p)++; + } while (!fb(o)); /* do {integer(p)++;} while ((sc->value = optf(sc, endp)) == sc->F); */ + clear_mutable_integer(p); + sc->value = sc->T; + sc->code = cdr(end); + return (goto_do_end_clauses); + } else + set_no_bool_opt(end); + } + do { + integer(p)++; + } while ((sc->value = endf(sc, endp)) == sc->F); + clear_mutable_integer(p); + } else + do { + slot_set_value(stepper, f(sc, a)); + } while ((sc->value = endf(sc, endp)) == sc->F); + } + sc->code = cdr(end); + return (goto_do_end_clauses); + } + if ((steppers == 2) && (!tis_slot(next_slot(next_slot(slots))))) { + s7_pointer step1 = slots, step2, expr1, expr2; + expr1 = slot_expression(step1); + step2 = next_slot(step1); + expr2 = slot_expression(step2); /* presetting fx_proc/car(expr) is not faster */ + if ((fx_proc(expr2) == fx_subtract_u1) && + (is_t_integer(slot_value(step2))) && (endf == fx_num_eq_ui)) { + s7_int i, lim = integer(caddr(endp)); + for (i = integer(slot_value(step2)) - 1; i >= lim; i--) + slot_set_value(step1, fx_call(sc, expr1)); + } else + do { + slot_set_value(step1, fx_call(sc, expr1)); + slot_set_value(step2, fx_call(sc, expr2)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + if (!is_symbol(car(sc->code))) + return (goto_do_end_clauses); + step1 = lookup_slot_from(car(sc->code), sc->curlet); + sc->value = slot_value(step1); + if (is_t_real(sc->value)) + clear_mutable_number(sc->value); + return (goto_start); + } + do { + s7_pointer slt = slots; + do { + if (slot_has_expression(slt)) + slot_set_value(slt, fx_call(sc, slot_expression(slt))); + slt = next_slot(slt); + } while (tis_slot(slt)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return (goto_do_end_clauses); +} + +static goto_t op_dox(s7_scheme * sc) +{ + /* any number of steppers using dox exprs, end also dox, body and end result arbitrary. + * since all these exprs are local, we don't need to jump until the body + */ + int64_t id, steppers = 0; + s7_pointer let, vars, code, end, endp, stepper = NULL, form = + sc->code, slots; + s7_function endf; +#if WITH_GMP + bool got_bignum = false; +#endif + + sc->code = cdr(sc->code); + let = make_let(sc, sc->curlet); /* new let is not tied into the symbol lookup process yet */ + sc->temp1 = let; + for (vars = car(sc->code); is_pair(vars); vars = cdr(vars)) { + s7_pointer expr = cdar(vars), val, stp, slot; + val = fx_call(sc, expr); +#if WITH_GMP + if (!got_bignum) + got_bignum = is_big_number(val); +#endif + new_cell_no_check(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, caar(vars), val); + stp = cdr(expr); /* cddar(vars) */ + if (is_pair(stp)) { + steppers++; + stepper = slot; + slot_set_expression(slot, stp); + } else + slot_just_set_expression(slot, sc->nil); + slot_set_next(slot, let_slots(let)); + let_set_slots(let, slot); + } + set_curlet(sc, let); + slots = let_slots(sc->curlet); + sc->temp1 = sc->nil; + id = let_id(let); + /* the fn_calls above could have redefined a previous stepper, so that its symbol_id is > let let_id when we get here, + * so we use symbol_set_local_slot_unchecked below to sidestep the debugger (see zauto.scm: i is a stepper, but then mock-vector-ref uses i as its index) + */ + { + s7_pointer slot; + for (slot = slots; tis_slot(slot); slot = next_slot(slot)) + symbol_set_local_slot_unchecked_and_unincremented(slot_symbol + (slot), id, + slot); + } + end = cadr(sc->code); + endp = car(end); + endf = fx_proc(end); + + /* an experiment */ + if ((step_end_ok(end)) && (steppers == 1) && + (is_t_integer(slot_value(stepper)))) { + s7_pointer stop_slot; + stop_slot = + (is_symbol(caddr(endp))) ? opt_integer_symbol(sc, + caddr(endp)) : + sc->nil; + if (stop_slot) { /* sc->nil -> it's an integer */ + set_step_end(stepper); + set_do_loop_end(slot_value(stepper), + (is_slot(stop_slot)) ? + integer(slot_value(stop_slot)) : + integer(caddr(endp))); + } + } + + if (is_true(sc, sc->value = endf(sc, endp))) { + sc->code = cdr(end); + return (goto_do_end_clauses); + } + code = cddr(sc->code); + if (is_null(code)) /* no body -- how does this happen? */ + return (op_dox_no_body_1(sc, slots, end, steppers, stepper)); + + if ((is_null(cdr(code))) && /* 1 expr, code is cdddr(form) here */ + (is_pair(car(code)))) { + s7_pointer body = car(code); + s7_pfunc bodyf = NULL; + if ((!no_cell_opt(code)) && +#if WITH_GMP + (!got_bignum) && +#endif + (has_safe_steppers(sc, sc->curlet))) + bodyf = s7_optimize_nr(sc, code); + + if ((!bodyf) && (is_fxable(sc, body)) && /* happens very rarely, #_* as car etc */ + (is_c_function(car(body)))) + bodyf = + s7_optimize_nr(sc, + set_dlist_1(sc, + set_ulist_1(sc, + make_symbol(sc, + c_function_name + (car + (body))), + cdr(body)))); + + if (bodyf) { + if (steppers == 1) { /* one expr body, 1 stepper */ + s7_pointer stepa = car(slot_expression(stepper)); + s7_function stepf; + stepf = fx_proc(slot_expression(stepper)); + if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) + && (is_t_integer(slot_value(stepper)))) { + s7_int i = integer(slot_value(stepper)); + opt_info *o = sc->opts[0]; + if (bodyf == opt_cell_any_nr) { + s7_pointer(*fp) (opt_info * o); + fp = o->v[0].fp; + + /* a laborious experiment... */ + if (!((fp == opt_p_pip_sso) + && (o->v[2].p == o->v[4].p) + && + (((o->v[5].p_pip_f == + string_set_p_pip_unchecked) + && (o->v[6].p_pi_f == + string_ref_p_pi_unchecked)) + || + ((o->v[5].p_pip_f == string_set_unchecked) + && (o->v[6].p_pi_f == + string_ref_unchecked)) + || + ((o->v[5].p_pip_f == + vector_set_p_pip_unchecked) + && (o->v[6].p_pi_f == + normal_vector_ref_p_pi_unchecked)) + || + ((o->v[5].p_pip_f == vector_set_unchecked) + && (o->v[6].p_pi_f == + vector_ref_unchecked)) + || + ((o->v[5].p_pip_f == + list_set_p_pip_unchecked) + && (o->v[6].p_pi_f == + list_ref_p_pi_unchecked))) + && + (copy_if_end_ok + (sc, slot_value(o->v[1].p), + slot_value(o->v[3].p), i, endp, stepper, + o)))) { + if (is_step_end(stepper)) { + s7_int lim; + lim = do_loop_end(slot_value(stepper)); + do { + fp(o); + slot_set_value(stepper, + make_integer(sc, ++i)); + } while (i < lim); + sc->value = sc->T; + } else + do { + fp(o); + slot_set_value(stepper, + make_integer(sc, ++i)); + } while ((sc->value = + endf(sc, endp)) == sc->F); + } + } else if (!(((bodyf == opt_float_any_nr) + && (o->v[0].fd == opt_d_7pid_ss_ss) + && (o->v[2].p == o->v[6].p) + && + ((o->v[4].d_7pid_f == + float_vector_set_d_7pid) + || (o->v[4].d_7pid_f == + float_vector_set_unchecked)) + && (o->v[3].d_7pi_f == + float_vector_ref_d_7pi) + && + (copy_if_end_ok + (sc, slot_value(o->v[1].p), + slot_value(o->v[5].p), i, endp, + stepper, o))) + || ((bodyf == opt_int_any_nr) + && ((o->v[0].fi == opt_i_7pii_ssf) + || (o->v[0].fi == + opt_i_7pii_ssf_vset)) + && (o->v[2].p == o->v[4].o1->v[2].p) + && + (((o->v[3].i_7pii_f == + int_vector_set_i_7pii) + && (o->v[4].o1->v[3].i_7pi_f == + int_vector_ref_i_7pi)) + || + ((o->v[3].i_7pii_f == + int_vector_set_unchecked) + && (o->v[4].o1->v[3].i_7pi_f == + int_vector_ref_unchecked))) + && + (copy_if_end_ok + (sc, slot_value(o->v[1].p), + slot_value(o->v[4].o1->v[1].p), + i, endp, stepper, o))))) + /* here the is_step_end business doesn't happen much */ + do { + bodyf(sc); + slot_set_value(stepper, make_integer(sc, ++i)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return (goto_do_end_clauses); + } + do { + bodyf(sc); + slot_set_value(stepper, stepf(sc, stepa)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return (goto_do_end_clauses); + } + + if ((steppers == 2) && + (!tis_slot(next_slot(next_slot(slots))))) { + s7_pointer s1 = slots, s2, p1, p2; + s7_function f1, f2; + s2 = next_slot(s1); + f1 = fx_proc(slot_expression(s1)); + f2 = fx_proc(slot_expression(s2)); + p1 = car(slot_expression(s1)); + p2 = car(slot_expression(s2)); + /* split out opt_float_any_nr gained nothing (see tmp), same for opt_cell_any_nr */ + if (bodyf == opt_cell_any_nr) { + s7_pointer(*fp) (opt_info * o); + opt_info *o = sc->opts[0]; + fp = o->v[0].fp; + /* maybe this can be generalized (thash:79) -- explicit integer stepper, but there must be a simpler way */ + if ((f2 == fx_add_u1) && (is_t_integer(slot_value(s2))) + && (endf == fx_num_eq_ui) + && (is_symbol(cadr(endp))) + && (cadr(endp) == slot_symbol(s2)) + && (is_t_integer(caddr(endp))) + && (!s7_tree_memq(sc, cadr(endp), body))) { + s7_int i = integer(slot_value(s2)), endi = + integer(caddr(endp)); + do { + fp(o); + slot_set_value(s1, f1(sc, p1)); + i++; + } while (i < endi); + } else + do { + fp(o); + slot_set_value(s1, f1(sc, p1)); + slot_set_value(s2, f2(sc, p2)); + } while ((sc->value = endf(sc, endp)) == sc->F); + } else + do { + bodyf(sc); + slot_set_value(s1, f1(sc, p1)); + slot_set_value(s2, f2(sc, p2)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return (goto_do_end_clauses); + } + if (bodyf == opt_cell_any_nr) { + s7_pointer(*fp) (opt_info * o); + opt_info *o = sc->opts[0]; + fp = o->v[0].fp; + do { + s7_pointer slot1; + fp(o); + slot1 = slots; + do { + if (slot_has_expression(slot1)) + slot_set_value(slot1, + fx_call(sc, + slot_expression + (slot1))); + slot1 = next_slot(slot1); + } while (tis_slot(slot1)); + } while ((sc->value = endf(sc, endp)) == sc->F); + } else + do { + s7_pointer slot1; + bodyf(sc); + slot1 = slots; + do { + if (slot_has_expression(slot1)) + slot_set_value(slot1, + fx_call(sc, + slot_expression + (slot1))); + slot1 = next_slot(slot1); + } while (tis_slot(slot1)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return (goto_do_end_clauses); + } + + if ((steppers == 1) && + (car(body) == sc->set_symbol) && + (is_pair(cdr(body))) && + (is_symbol(cadr(body))) && + (is_pair(cddr(body))) && + ((has_fx(cddr(body))) || (is_fxable(sc, caddr(body)))) && + (is_null(cdddr(body)))) { + s7_pointer val = cddr(body), slot, stepa; + s7_function stepf, valf; + + if (!has_fx(val)) + set_fx(val, + fx_choose(sc, val, sc->curlet, let_symbol_is_safe)); + valf = fx_proc(val); + val = car(val); + slot = lookup_slot_from(cadr(body), sc->curlet); + if (slot == sc->undefined) + unbound_variable_error(sc, cadr(body)); + stepf = fx_proc(slot_expression(stepper)); + stepa = car(slot_expression(stepper)); + do { + slot_set_value(slot, valf(sc, val)); + slot_set_value(stepper, stepf(sc, stepa)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return (goto_do_end_clauses); + } + + /* not fxable body (bodyf nil) but body might be gxable here: is_gxable(body) */ + if ((has_gx(body)) || (gx_annotate_arg(sc, code, sc->curlet))) { + s7_function f; + f = fx_proc_unchecked(code); + do { + s7_pointer slot1; + f(sc, body); + slot1 = slots; + do { + if (slot_has_expression(slot1)) + slot_set_value(slot1, + fx_call(sc, + slot_expression(slot1))); + slot1 = next_slot(slot1); + } while (tis_slot(slot1)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return (goto_do_end_clauses); + } + } else { /* more than one expr */ + s7_pointer p = code; + bool use_opts = false; + int32_t body_len = 0; + opt_info *body[32]; +#define MAX_OPT_BODY_SIZE 32 + + if ((!no_cell_opt(code)) && +#if WITH_GMP + (!got_bignum) && +#endif + (has_safe_steppers(sc, sc->curlet))) { + int32_t k; + sc->pc = 0; + for (k = 0; (is_pair(p)) && (k < MAX_OPT_BODY_SIZE); + k++, p = cdr(p), body_len++) { + opt_info *start = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) { + set_no_cell_opt(code); + p = code; + break; + } + oo_idp_nr_fixup(start); + body[k] = start; + } + use_opts = is_null(p); + } + + if (p == code) + for (; is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + break; + + if (is_null(p)) { + int32_t i; + s7_pointer stepa = NULL; + s7_function stepf = NULL; + if (!use_opts) + fx_annotate_args(sc, code, sc->curlet); + + if (stepper) { + stepf = fx_proc(slot_expression(stepper)); + stepa = car(slot_expression(stepper)); + } + while (true) { + if (use_opts) + for (i = 0; i < body_len; i++) + body[i]->v[0].fp(body[i]); + else + for (p = code; is_pair(p); p = cdr(p)) + fx_call(sc, p); + + if (steppers == 1) + slot_set_value(stepper, stepf(sc, stepa)); + else { + s7_pointer slot = slots; + do { + if (slot_has_expression(slot)) + slot_set_value(slot, + fx_call(sc, + slot_expression(slot))); + slot = next_slot(slot); + } while (tis_slot(slot)); + } + if (is_true(sc, sc->value = endf(sc, endp))) { + sc->code = cdr(end); + return (goto_do_end_clauses); + } + } + } + } + if ((is_null(cdr(code))) && /* one expr */ + (is_pair(car(code)))) { + code = car(code); + if ((is_syntactic_pair(code)) || + (is_symbol_and_syntactic(car(code)))) { + push_stack_no_args_direct(sc, OP_DOX_STEP_O); + if (is_syntactic_pair(code)) + sc->cur_op = (opcode_t) optimize_op(code); + else { + sc->cur_op = (opcode_t) symbol_syntax_op_checked(code); + pair_set_syntax_op(code, sc->cur_op); + } + sc->code = code; + return (goto_top_no_pop); + } + } + pair_set_syntax_op(form, OP_DOX_INIT); + sc->code = T_Pair(cddr(sc->code)); + push_stack_no_args(sc, + (intptr_t) ((is_null(cdr(sc->code))) ? OP_DOX_STEP_O + : OP_DOX_STEP), cdr(form)); + return (goto_begin); +} + +static bool op_dox_step(s7_scheme * sc) +{ + s7_pointer slot = let_slots(sc->curlet); + do { + if (slot_has_expression(slot)) + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + slot = next_slot(slot); + } while (tis_slot(slot)); + sc->value = fx_call(sc, cadr(sc->code)); + if (is_true(sc, sc->value)) { + sc->code = cdadr(sc->code); + return (true); + } + push_stack_no_args_direct(sc, OP_DOX_STEP); + sc->code = T_Pair(cddr(sc->code)); + return (false); +} + +static bool op_dox_step_o(s7_scheme * sc) +{ /* every dox case has vars (else op_do_no_vars) */ + s7_pointer slot = let_slots(sc->curlet); + do { + if (slot_has_expression(slot)) + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + slot = next_slot(slot); + } while (tis_slot(slot)); + sc->value = fx_call(sc, cadr(sc->code)); + if (is_true(sc, sc->value)) { + sc->code = cdadr(sc->code); + return (true); + } + push_stack_no_args_direct(sc, OP_DOX_STEP_O); + sc->code = caddr(sc->code); + return (false); +} + +static void op_dox_no_body(s7_scheme * sc) +{ + s7_pointer slot, var, test, result; + s7_function testf; + + sc->code = cdr(sc->code); + var = caar(sc->code); + testf = fx_proc(cadr(sc->code)); + test = caadr(sc->code); + result = cdadr(sc->code); + + if ((!in_heap(sc->code)) && (is_let(opt3_any(sc->code)))) { /* (*repl* 'keymap) anything -> segfault because opt3_any here is #f. (see line 80517) */ + s7_pointer let; + let = + update_let_with_slot(sc, opt3_any(sc->code), + fx_call(sc, cdr(var))); + let_set_outlet(let, sc->curlet); + set_curlet(sc, let); + } else + sc->curlet = + make_let_with_slot(sc, sc->curlet, car(var), + fx_call(sc, cdr(var))); + + slot = let_slots(sc->curlet); + if ((is_t_integer(slot_value(slot))) && + ((integer(opt2_con(sc->code))) != 0)) { + s7_int incr = integer(opt2_con(sc->code)); + s7_pointer istep; + istep = make_mutable_integer(sc, integer(slot_value(slot))); + /* this can cause unexpected, but correct behavior: (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (memq x '(0)))) -> #f + * because (eq? 0 x) here is false -- memv will return '(0). tree-count is similar. + */ + slot_set_value(slot, istep); + if (testf == fx_or_2a) { + s7_pointer t1 = cadr(test), t2 = caddr(test); + s7_function f1, f2; + f1 = fx_proc(cdr(test)); + f2 = fx_proc(cddr(test)); + while ((f1(sc, t1) == sc->F) && (f2(sc, t2) == sc->F)) + integer(istep) += incr; + } else + while (testf(sc, test) == sc->F) { + integer(istep) += incr; + } + if (is_small_int(integer(istep))) + slot_set_value(slot, small_int(integer(istep))); + else + clear_mutable_integer(istep); + sc->value = fx_call(sc, result); + } else { + s7_function stepf = fx_proc(cddr(var)); + s7_pointer step = caddr(var); + if (testf == fx_or_and_2a) { + s7_pointer f1_arg = cadr(test), p = + opt3_pair(test) /* cdadr(p) */ , f2_arg = car(p), f3_arg = + cadr(p); + s7_function f1, f2, f3; + f1 = fx_proc(cdr(test)); + f2 = fx_proc(p); + f3 = fx_proc(cdr(p)); + if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) + && (is_t_integer(slot_value(slot)))) { + s7_pointer ip; + ip = make_mutable_integer(sc, integer(slot_value(slot))); + slot_set_value(slot, ip); + while ((f1(sc, f1_arg) == sc->F) && + ((f2(sc, f2_arg) == sc->F) + || (f3(sc, f3_arg) == sc->F))) + integer(ip)++; + clear_mutable_integer(ip); + } else + while ((f1(sc, f1_arg) == sc->F) && + ((f2(sc, f2_arg) == sc->F) + || (f3(sc, f3_arg) == sc->F))) + slot_set_value(slot, stepf(sc, step)); + } else + while (testf(sc, test) == sc->F) { + slot_set_value(slot, stepf(sc, step)); + } + sc->value = fx_call(sc, result); + } +} + +static void op_dox_pending_no_body(s7_scheme * sc) +{ + s7_pointer let, vars, test, slots; + bool all_steps = true; + + sc->code = cdr(sc->code); + let = make_let(sc, sc->curlet); + sc->temp1 = let; + for (vars = car(sc->code); is_pair(vars); vars = cdr(vars)) { + add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars))); + if (is_pair(cddar(vars))) + slot_set_expression(let_slots(let), cddar(vars)); + else { + all_steps = false; + slot_just_set_expression(let_slots(let), sc->nil); + } + } + slots = let_slots(let); + set_curlet(sc, let); + sc->temp1 = sc->nil; + test = cadr(sc->code); + + let_set_has_pending_value(sc->curlet); + if ((all_steps) && + (!tis_slot(next_slot(next_slot(slots)))) && (is_pair(cdr(test)))) { + s7_pointer slot1 = slots, slot2, expr1, expr2; + expr1 = slot_expression(slot1); + slot2 = next_slot(slot1); + expr2 = slot_expression(slot2); + while (fx_call(sc, test) == sc->F) { + slot_simply_set_pending_value(slot1, fx_call(sc, expr1)); /* use pending_value for GC protection */ + slot_set_value(slot2, fx_call(sc, expr2)); + slot_set_value(slot1, slot_pending_value(slot1)); + } + sc->code = cdr(test); + let_clear_has_pending_value(sc->curlet); + return; + } + while ((sc->value = fx_call(sc, test)) == sc->F) { + s7_pointer slt = slots; + do { + if (slot_has_expression(slt)) + slot_simply_set_pending_value(slt, + fx_call(sc, + slot_expression + (slt))); + slt = next_slot(slt); + } while (tis_slot(slt)); + slt = slots; + do { + if (slot_has_expression(slt)) + slot_set_value(slt, slot_pending_value(slt)); + slt = next_slot(slt); + } while (tis_slot(slt)); + } + sc->code = cdr(test); + let_clear_has_pending_value(sc->curlet); +} + +static bool op_do_no_vars(s7_scheme * sc) +{ + s7_pointer p, form = sc->code; + int32_t i; + opt_info *body[32]; + sc->code = cdr(sc->code); + sc->pc = 0; + + for (i = 0, p = cddr(sc->code); (is_pair(p)) && (i < 32); + i++, p = cdr(p)) { + body[i] = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } + if (is_null(p)) { + s7_pointer end = cadr(sc->code); + sc->curlet = make_let(sc, sc->curlet); + if (i == 1) { + while ((sc->value = fx_call(sc, end)) == sc->F) + body[0]->v[0].fp(body[0]); + sc->code = cdr(end); + return (true); + } + if (i == 0) { /* null body! */ + s7_function endf; + s7_pointer endp = car(end); + endf = fx_proc(end); + while (!is_true(sc, sc->value = endf(sc, endp))); /* the assignment is (normally) in the noise */ + sc->code = cdr(end); + return (true); + } + while ((sc->value = fx_call(sc, end)) == sc->F) { + int32_t k; + for (k = 0; k < i; k++) + body[k]->v[0].fp(body[k]); + } + sc->code = cdr(end); + return (true); + } + /* back out */ + pair_set_syntax_op(form, OP_DO_NO_VARS_NO_OPT); + sc->curlet = make_let_slowly(sc, sc->curlet); + sc->value = fx_call(sc, cadr(sc->code)); + if (is_true(sc, sc->value)) { + sc->code = cdadr(sc->code); + return (true); + } + push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1); + sc->code = T_Pair(cddr(sc->code)); + return (false); +} + +static void op_do_no_vars_no_opt(s7_scheme * sc) +{ + sc->code = cdr(sc->code); + sc->curlet = make_let(sc, sc->curlet); +} + +static bool op_do_no_vars_no_opt_1(s7_scheme * sc) +{ + sc->value = fx_call(sc, cadr(sc->code)); + if (is_true(sc, sc->value)) { + sc->code = cdadr(sc->code); + return (true); + } + push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1); + sc->code = T_Pair(cddr(sc->code)); + return (false); +} + +static void op_do_no_body_fx_vars(s7_scheme * sc) +{ + s7_pointer let, vars, stepper = NULL; + s7_int steppers = 0; + sc->code = cdr(sc->code); + let = make_let(sc, sc->curlet); + sc->temp1 = let; + for (vars = car(sc->code); is_pair(vars); vars = cdr(vars)) { + add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars))); + if (is_pair(cddar(vars))) { + slot_set_expression(let_slots(let), cddar(vars)); + steppers++; + stepper = let_slots(let); + } else + slot_just_set_expression(let_slots(let), sc->nil); + } + if (steppers == 1) + let_set_dox_slot1(let, stepper); + set_curlet(sc, let); + sc->temp1 = sc->nil; + push_stack_no_args_direct(sc, + (intptr_t) ((steppers == + 1) ? + OP_DO_NO_BODY_FX_VARS_STEP_1 : + OP_DO_NO_BODY_FX_VARS_STEP)); + sc->code = caadr(sc->code); +} + +static bool op_do_no_body_fx_vars_step(s7_scheme * sc) +{ + s7_pointer slot; + if (sc->value != sc->F) { + sc->code = cdadr(sc->code); + return (true); + } + for (slot = let_slots(sc->curlet); tis_slot(slot); + slot = next_slot(slot)) + if (slot_has_expression(slot)) + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + + push_stack_no_args_direct(sc, OP_DO_NO_BODY_FX_VARS_STEP); + sc->code = caadr(sc->code); + return (false); +} + +static bool op_do_no_body_fx_vars_step_1(s7_scheme * sc) +{ + if (sc->value != sc->F) { + sc->code = cdadr(sc->code); + return (true); + } + slot_set_value(let_dox_slot1(sc->curlet), + fx_call(sc, + slot_expression(let_dox_slot1(sc->curlet)))); + push_stack_no_args_direct(sc, OP_DO_NO_BODY_FX_VARS_STEP_1); + sc->code = caadr(sc->code); + return (false); +} + +static bool do_step1(s7_scheme * sc) +{ + while (true) { + s7_pointer code; + if (is_null(sc->args)) { /* after getting the new values, transfer them into the slot_values */ + s7_pointer x; + for (x = sc->code; is_pair(x); x = cdr(x)) { /* sc->code here is the original sc->args list */ + slot_set_value(car(x), slot_pending_value(car(x))); + slot_clear_has_pending_value(car(x)); + } + pop_stack_no_op(sc); + return (true); + } + code = slot_expression(car(sc->args)); /* get the next stepper new value */ + if (has_fx(code)) { + sc->value = fx_call(sc, code); + slot_set_pending_value(car(sc->args), sc->value); /* consistently slower if slot_simply_set... here? */ + sc->args = cdr(sc->args); /* go to next step var */ + } else { + push_stack_direct(sc, OP_DO_STEP2); + sc->code = car(code); + return (false); + } + } +} + +static bool op_do_step2(s7_scheme * sc) +{ + if (is_multiple_value(sc->value)) + eval_error(sc, "do: variable step value can't be ~S", 35, + set_ulist_1(sc, sc->values_symbol, sc->value)); + slot_set_pending_value(car(sc->args), sc->value); /* save current value */ + sc->args = cdr(sc->args); /* go to next step var */ + return (do_step1(sc)); +} + +static bool op_do_step(s7_scheme * sc) +{ + /* increment all vars, return to endtest + * these are also updated in parallel at the end, so we gather all the incremented values first + * + * here we know car(sc->args) is not null, args is the list of steppable vars, + * any unstepped vars in the do var section are not in this list, so + * (do ((i 0 (+ i 1)) (j 2)) ...) arrives here with sc->args: '(slot<((+ i 1)=expr, 0=pending_value>)) + */ + push_stack_direct(sc, OP_DO_END); + sc->args = car(sc->args); /* the var data lists */ + sc->code = sc->args; /* save the top of the list */ + return (do_step1(sc)); +} + +static goto_t do_end_code(s7_scheme * sc) +{ + if (is_pair(cdr(sc->code))) { + if (is_undefined_feed_to(sc, car(sc->code))) + return (goto_feed_to); + /* never has_fx(sc->code) here (first of a body) */ + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + sc->code = car(sc->code); + return (goto_eval); + } + if (has_fx(sc->code)) { + sc->value = fx_call(sc, sc->code); + return (goto_start); + } + sc->code = T_Pair(car(sc->code)); + return (goto_eval); +} + +static bool do_end_clauses(s7_scheme * sc) +{ + if (!is_null(sc->code)) + return (false); + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return (true); +} + +static bool opt_do_copy(s7_scheme * sc, opt_info * o, s7_int start, + s7_int stop) +{ + s7_pointer(*fp) (opt_info * o); + if (start >= stop) + return (true); + fp = o->v[0].fp; /* o->v[6].p_pi_f is getter, o->v[5].p_pip_f is setter */ + if ((fp == opt_p_pip_sso) && + (type(slot_value(o->v[1].p)) == type(slot_value(o->v[3].p))) && + (o->v[2].p == o->v[4].p)) { + s7_pointer dest, source, caller = NULL; + dest = slot_value(o->v[1].p); + source = slot_value(o->v[3].p); + if ((is_normal_vector(dest)) && + (((o->v[5].p_pip_f == vector_set_p_pip_unchecked) + || (o->v[5].p_pip_f == vector_set_unchecked)) + && ((o->v[6].p_pi_f == normal_vector_ref_p_pi_unchecked) + || (o->v[6].p_pi_f == vector_ref_p_pi_unchecked) + || (o->v[6].p_pi_f == vector_ref_unchecked)))) + caller = sc->vector_set_symbol; + else if ((is_string(dest)) && + (((o->v[5].p_pip_f == string_set_p_pip_unchecked) + || (o->v[5].p_pip_f == string_set_unchecked)) + && ((o->v[6].p_pi_f == string_ref_p_pi_unchecked) + || (o->v[6].p_pi_f == string_ref_unchecked)))) + caller = sc->string_set_symbol; + else if ((is_pair(dest)) && + ((o->v[5].p_pip_f == list_set_p_pip_unchecked) + && (o->v[6].p_pi_f == list_ref_p_pi_unchecked))) + caller = sc->list_set_symbol; + else + return (false); + if (start < 0) + return (out_of_range + (sc, caller, wrap_integer1(sc, 2), + wrap_integer2(sc, start), its_negative_string)); + if ((stop > integer(s7_length(sc, source))) + || (stop > integer(s7_length(sc, dest)))) + return (out_of_range + (sc, caller, wrap_integer1(sc, 2), + wrap_integer2(sc, stop), its_too_large_string)); + if ((caller) + && (copy_to_same_type(sc, dest, source, start, stop, start))) + return (true); + } + return (false); +} + +static bool op_simple_do_1(s7_scheme * sc, s7_pointer code) +{ + s7_pointer step_expr, step_var, ctr_slot, end_slot; + s7_function stepf, endf; + s7_pfunc func; + + code = cdr(code); + if (no_cell_opt(cddr(code))) + return (false); + + func = s7_optimize_nr(sc, cddr(code)); + if (!func) { + set_no_cell_opt(cddr(code)); + return (false); + } + + /* func must be set */ + step_expr = opt2_pair(code); /* caddr(caar(code)) */ + stepf = fn_proc(step_expr); + endf = fn_proc(caadr(code)); + ctr_slot = let_dox_slot1(sc->curlet); + end_slot = let_dox_slot2(sc->curlet); + step_var = caddr(step_expr); + /* use g* funcs (not fx) because we're passing the actual values, not the expressions */ + + if ((stepf == g_add_x1) && + (is_t_integer(slot_value(ctr_slot))) && + ((endf == g_num_eq_2) || (endf == g_num_eq_xi) + || (endf == g_geq_2)) && (is_t_integer(slot_value(end_slot)))) { + s7_int i, start, stop; + start = integer(slot_value(ctr_slot)); + stop = integer(slot_value(end_slot)); + + if (func == opt_cell_any_nr) { + opt_info *o = sc->opts[0]; + s7_pointer(*fp) (opt_info * o); + fp = o->v[0].fp; + if ((fp == opt_p_ppp_sss) || (fp == opt_p_ppp_sss_mul) + || (fp == opt_p_ppp_sss_hset)) { + s7_p_ppp_t fpt; + fpt = o->v[4].p_ppp_f; + for (i = start; i < stop; i++) { + slot_set_value(ctr_slot, make_integer(sc, i)); + fpt(sc, slot_value(o->v[1].p), slot_value(o->v[2].p), + slot_value(o->v[3].p)); + } + } else if (fp == opt_p_ppp_sfs) { + s7_p_ppp_t fpt; + fpt = o->v[3].p_ppp_f; + for (i = start; i < stop; i++) { + slot_set_value(ctr_slot, make_integer(sc, i)); + fpt(sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), + slot_value(o->v[2].p)); + } + } else if ((fp == opt_p_pip_sss_vset) && (start >= 0) + && (stop <= vector_length(slot_value(o->v[1].p)))) { + s7_pointer v; + v = slot_value(o->v[1].p); + for (i = start; i < stop; i++) { + slot_set_value(ctr_slot, make_integer(sc, i)); + vector_element(v, integer(slot_value(o->v[2].p))) = + slot_value(o->v[3].p); + } + } else + for (i = start; i < stop; i++) { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + } + } else + /* splitting out opt_float_any_nr here saves almost nothing */ + for (i = start; i < stop; i++) { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc); + } + sc->value = sc->T; + sc->code = cdadr(code); + return (true); + } + if ((stepf == g_subtract_x1) && + (is_t_integer(slot_value(ctr_slot))) && + ((endf == g_less_x0) || (endf == g_less_2) || (endf == g_less_xi)) + && (is_t_integer(slot_value(end_slot)))) { + s7_int i, start = integer(slot_value(ctr_slot)), stop = + integer(slot_value(end_slot)); + if (func == opt_cell_any_nr) { + opt_info *o = sc->opts[0]; + if (!opt_do_copy(sc, o, stop, start + 1)) { + s7_pointer(*fp) (opt_info * o); + fp = o->v[0].fp; + for (i = start; i >= stop; i--) { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + } + } + } else + for (i = start; i >= stop; i--) { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc); + } + sc->value = sc->T; + sc->code = cdadr(code); + return (true); + } + if ((stepf == g_add_2_xi) && + (is_t_integer(slot_value(ctr_slot))) && + ((endf == g_num_eq_2) || (endf == g_num_eq_xi) + || (endf == g_geq_2)) && (is_t_integer(slot_value(end_slot)))) { + s7_int i, start = integer(slot_value(ctr_slot)), stop = + integer(slot_value(end_slot)), incr = + integer(caddr(step_expr)); + if (func == opt_cell_any_nr) { + s7_pointer(*fp) (opt_info * o); + opt_info *o = sc->opts[0]; + fp = o->v[0].fp; + for (i = start; i < stop; i += incr) { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + } + } else + for (i = start; i < stop; i += incr) { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc); + } + sc->value = sc->T; + sc->code = cdadr(code); + return (true); + } + if (func == opt_cell_any_nr) { + opt_info *o = sc->opts[0]; + s7_pointer(*fp) (opt_info * o); + fp = o->v[0].fp; + if ((stepf == g_add_x1) && (is_t_integer(slot_value(ctr_slot))) && + (endf == g_greater_2) && (is_t_integer(slot_value(end_slot)))) + { + s7_int i, start = integer(slot_value(ctr_slot)), stop = + integer(slot_value(end_slot)); + for (i = start; i <= stop; i++) { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + } + } else + do { + fp(o); + set_car(sc->t2_1, slot_value(ctr_slot)); + set_car(sc->t2_2, step_var); + slot_set_value(ctr_slot, stepf(sc, sc->t2_1)); + set_car(sc->t2_1, slot_value(ctr_slot)); + set_car(sc->t2_2, slot_value(end_slot)); + } while ((sc->value = endf(sc, sc->t2_1)) == sc->F); + } else + do { + func(sc); + set_car(sc->t2_1, slot_value(ctr_slot)); + set_car(sc->t2_2, step_var); + slot_set_value(ctr_slot, stepf(sc, sc->t2_1)); + set_car(sc->t2_1, slot_value(ctr_slot)); + set_car(sc->t2_2, slot_value(end_slot)); + } while ((sc->value = endf(sc, sc->t2_1)) == sc->F); + + sc->code = cdadr(code); + return (true); +} + +static bool op_simple_do(s7_scheme * sc) +{ + /* body might not be safe in this case, but the step and end exprs are easy + * simple_do: set up local let, check end (c_c?), goto op_simple_do_1 + * if latter gets s7_optimize, run locally, else goto simple_do_step. + */ + s7_pointer end, body, code = cdr(sc->code); + sc->curlet = make_let_slowly(sc, sc->curlet); + sc->value = fx_call(sc, cdaar(code)); + let_set_dox_slot1(sc->curlet, + add_slot_checked(sc, sc->curlet, caaar(code), + sc->value)); + + end = opt1_any(code); /* caddr(caadr(code)) */ + if (is_symbol(end)) + let_set_dox_slot2(sc->curlet, lookup_slot_from(end, sc->curlet)); + else + let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end)); + + set_car(sc->t2_1, let_dox1_value(sc->curlet)); + set_car(sc->t2_2, let_dox2_value(sc->curlet)); + sc->value = fn_proc(caadr(code)) (sc, sc->t2_1); + if (is_true(sc, sc->value)) { + sc->code = cdadr(code); + return (true); /* goto DO_END_CLAUSES */ + } + body = cddr(code); + if ((is_null(cdr(body))) && /* one expr in body */ + (is_pair(car(body))) && /* and it is a pair */ + (is_symbol(cadr(opt2_pair(code)))) && /* caddr(caar(code)), caar=(i 0 (+ i 1)), caddr=(+ i 1), so this is apparently checking that the stepf is reasonable? */ + (is_t_integer(caddr(opt2_pair(code)))) && + (op_simple_do_1(sc, sc->code))) + return (true); /* goto DO_END_CLAUSES */ + + push_stack_no_args(sc, OP_SIMPLE_DO_STEP, code); + sc->code = body; + return (false); /* goto BEGIN */ +} + +static bool op_simple_do_step(s7_scheme * sc) +{ + s7_pointer step, ctr = let_dox_slot1(sc->curlet), end = + let_dox_slot2(sc->curlet), code = sc->code; + step = opt2_pair(code); /* caddr(caar(code)) */ + if (is_symbol(cadr(step))) { + set_car(sc->t2_1, slot_value(ctr)); + set_car(sc->t2_2, caddr(step)); + } else { + set_car(sc->t2_2, slot_value(ctr)); + set_car(sc->t2_1, cadr(step)); + } + slot_set_value(ctr, fn_proc(step) (sc, sc->t2_1)); + set_car(sc->t2_1, slot_value(ctr)); + set_car(sc->t2_2, slot_value(end)); + end = cadr(code); + sc->value = fn_proc(car(end)) (sc, sc->t2_1); + if (is_true(sc, sc->value)) { + sc->code = cdr(end); + return (true); + } + push_stack_direct(sc, OP_SIMPLE_DO_STEP); + sc->code = T_Pair(cddr(code)); + return (false); +} + +static bool op_safe_do_step(s7_scheme * sc) +{ + s7_int step, end = integer(let_dox2_value(sc->curlet)); + s7_pointer slot = let_dox_slot1(sc->curlet); + step = integer(slot_value(slot)) + 1; + slot_set_value(slot, make_integer(sc, step)); + if ((step == end) || + ((step > end) && (opt1_cfunc(caadr(sc->code)) == sc->geq_2))) { + sc->value = sc->T; + sc->code = cdadr(sc->code); + return (true); + } + push_stack_direct(sc, OP_SAFE_DO_STEP); + sc->code = T_Pair(opt2_pair(sc->code)); + return (false); +} + +static bool op_safe_dotimes_step(s7_scheme * sc) +{ + s7_pointer arg = slot_value(sc->args); + numerator(arg)++; + if (numerator(arg) == do_loop_end(arg)) { + sc->value = sc->T; + sc->code = cdadr(sc->code); + return (true); + } + push_stack_direct(sc, OP_SAFE_DOTIMES_STEP); + sc->code = opt2_pair(sc->code); /* here we know the body has more than one form */ + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(sc->code); + return (false); +} + +static bool op_safe_dotimes_step_o(s7_scheme * sc) +{ + s7_pointer arg = slot_value(sc->args); + numerator(arg)++; + if (numerator(arg) == do_loop_end(arg)) { + sc->value = sc->T; + sc->code = cdadr(sc->code); + return (true); + } + push_stack_direct(sc, OP_SAFE_DOTIMES_STEP_O); + sc->code = opt2_pair(sc->code); + return (false); +} + +static Inline bool op_dotimes_step_o(s7_scheme * sc) +{ + s7_pointer now, end, end_test, code = sc->code, ctr = + let_dox_slot1(sc->curlet); + now = slot_value(ctr); + end = let_dox2_value(sc->curlet); + end_test = opt2_pair(code); + + if (is_t_integer(now)) { + slot_set_value(ctr, make_integer(sc, integer(now) + 1)); + now = slot_value(ctr); + if (is_t_integer(end)) { + if ((integer(now) == integer(end)) || + ((integer(now) > integer(end)) + && (opt1_cfunc(end_test) == sc->geq_2))) { + sc->value = sc->T; + sc->code = cdadr(code); + return (true); + } + } else { + set_car(sc->t2_1, now); + set_car(sc->t2_2, end); + end = cadr(code); + sc->value = fn_proc(car(end)) (sc, sc->t2_1); + if (is_true(sc, sc->value)) { + sc->code = cdr(end); + return (true); + } + } + } else { + set_car(sc->t1_1, now); + slot_set_value(ctr, g_add_x1(sc, sc->t1_1)); + /* (define (hi) (let ((x 0.0) (y 1.0)) (do ((i y (+ i 1))) ((= i 6)) (do ((i i (+ i 1))) ((>= i 7)) (set! x (+ x i)))) x)) */ + set_car(sc->t2_1, slot_value(ctr)); + set_car(sc->t2_2, end); + end = cadr(code); + sc->value = fn_proc(car(end)) (sc, sc->t2_1); + if (is_true(sc, sc->value)) { + sc->code = cdr(end); + return (true); + } + } + push_stack_direct(sc, OP_DOTIMES_STEP_O); + sc->code = caddr(code); + return (false); +} + +static bool opt_dotimes(s7_scheme * sc, s7_pointer code, s7_pointer scc, + bool safe_step) +{ + s7_int end; + end = do_loop_end(slot_value(sc->args)); /* s7_optimize below can step on this value! */ + + if (safe_step) + set_safe_stepper(sc->args); + else + set_safe_stepper(let_dox_slot1(sc->curlet)); + /* I think safe_step means the stepper is completely unproblematic */ + + if (is_null(cdr(code))) { + s7_pfunc func; + if (no_cell_opt(code)) + return (false); + func = s7_optimize_nr(sc, code); + if (!func) { + set_no_cell_opt(code); + return (false); + } + if (safe_step) { + s7_pointer stepper; + slot_set_value(sc->args, stepper = + make_mutable_integer(sc, + integer(slot_value + (sc->args)))); + if ((func == opt_float_any_nr) || (func == opt_cell_any_nr)) { + opt_info *o = sc->opts[0]; + if (func == opt_float_any_nr) { + s7_double(*fd) (opt_info * o); + fd = o->v[0].fd; + if ((fd == opt_d_id_sf) && /* by far the most common case in clm: (outa i ...) etc */ + (is_slot(o->v[1].p)) && + (stepper == slot_value(o->v[1].p))) { + opt_info *o1; + s7_int end8 = end - 8; + s7_d_id_t f0; + f0 = o->v[3].d_id_f; + o1 = sc->opts[1]; + fd = o1->v[0].fd; + while (integer(stepper) < end8) + LOOP_8(f0(integer(stepper), fd(o1)); + integer(stepper)++); + while (integer(stepper) < end) { + f0(integer(stepper), fd(o1)); + integer(stepper)++; + } + } else if ((o->v[0].fd == opt_d_7pid_ss_ss) + && (o->v[4].d_7pid_f == + float_vector_set_unchecked) + && (o->v[3].d_7pi_f == + float_vector_ref_d_7pi) + && (o->v[2].p == o->v[6].p)) + copy_to_same_type(sc, slot_value(o->v[1].p), + slot_value(o->v[5].p), + integer(stepper), end, + integer(stepper)); + else if ((o->v[0].fd == opt_d_7pid_ssc) + && (o->v[4].d_7pid_f == + float_vector_set_unchecked) + && (stepper == slot_value(o->v[2].p))) + s7_fill(sc, + set_elist_4(sc, slot_value(o->v[1].p), + make_real(sc, o->v[3].x), + stepper, make_integer(sc, + end))); + else + for (; integer(stepper) < end; integer(stepper)++) + fd(o); + } else { + s7_pointer(*fp) (opt_info * o); + fp = o->v[0].fp; + if ((fp == opt_p_pip_ssc) && (stepper == slot_value(o->v[2].p)) && /* i.e. index by do counter */ + ((o->v[3].p_pip_f == string_set_unchecked) + || (o->v[3].p_pip_f == vector_set_unchecked) + || (o->v[3].p_pip_f == list_set_p_pip_unchecked))) + s7_fill(sc, + set_elist_4(sc, slot_value(o->v[1].p), + o->v[4].p, stepper, + make_integer(sc, end))); + else { + if (fp == opt_if_bp) { + for (; integer(stepper) < end; + integer(stepper)++) + if (o->v[3].fb(o->v[2].o1)) + o->v[5].fp(o->v[4].o1); + } else if (fp == opt_if_nbp_fs) { + for (; integer(stepper) < end; + integer(stepper)++) + if (! + (o-> + v[2].b_pi_f(sc, + o->v[5].fp(o->v[4].o1), + integer(slot_value + (o->v[3].p))))) + o->v[11].fp(o->v[10].o1); + } else if (fp == opt_unless_p_1) { + for (; integer(stepper) < end; + integer(stepper)++) + if (!(o->v[4].fb(o->v[3].o1))) + o->v[5].o1->v[0].fp(o->v[5].o1); + } else + for (; integer(stepper) < end; + integer(stepper)++) + fp(o); + } + } + } else { + if (func == opt_int_any_nr) { + s7_int(*fi) (opt_info * o); + opt_info *o = sc->opts[0]; + fi = o->v[0].fi; + if ((fi == opt_i_7pii_ssc) + && (stepper == slot_value(o->v[2].p)) + && (o->v[3].i_7pii_f == int_vector_set_unchecked)) + s7_fill(sc, + set_elist_4(sc, slot_value(o->v[1].p), + make_integer(sc, o->v[4].i), + stepper, make_integer(sc, + end))); + else if ((o->v[3].i_7pii_f == int_vector_set_unchecked) + && (o->v[5].fi == opt_7pi_ss_ivref) + && (o->v[2].p == o->v[4].o1->v[2].p)) + copy_to_same_type(sc, slot_value(o->v[1].p), + slot_value(o->v[4].o1->v[1].p), + integer(stepper), end, + integer(stepper)); + else + for (; integer(stepper) < end; integer(stepper)++) + fi(o); + } else /* what cases are here? */ + for (; integer(stepper) < end; integer(stepper)++) + func(sc); + } + clear_mutable_integer(stepper); + } else { /* not safe_step */ + s7_int step, stop; + s7_pointer step_slot = let_dox_slot1(sc->curlet), end_slot = + let_dox_slot2(sc->curlet); + step = integer(slot_value(step_slot)); + stop = integer(slot_value(end_slot)); + if (func == opt_cell_any_nr) { + opt_info *o = sc->opts[0]; + s7_pointer(*fp) (opt_info * o); + fp = o->v[0].fp; + if (!opt_do_copy(sc, o, step, stop)) { + if ((step >= 0) && (stop < NUM_SMALL_INTS)) { + if (fp == opt_when_p_2) { + while (step < stop) { + slot_set_value(step_slot, small_int(step)); + if (o->v[4].fb(o->v[3].o1)) { + o->v[6].fp(o->v[5].o1); + o->v[8].fp(o->v[7].o1); + } + step = integer(slot_value(step_slot)) + 1; + } + } else + while (step < stop) { + slot_set_value(step_slot, small_int(step)); + fp(o); + step = integer(slot_value(step_slot)) + 1; + } + } else + while (step < stop) { + slot_set_value(step_slot, + make_integer(sc, step)); + fp(o); + step = integer(slot_value(step_slot)) + 1; + } + } + } else if ((step >= 0) && (stop < NUM_SMALL_INTS)) + while (step < stop) { + slot_set_value(step_slot, small_int(step)); + func(sc); + step = integer(slot_value(step_slot)) + 1; + } else if (func == opt_int_any_nr) { + s7_int(*fi) (opt_info * o); + opt_info *o = sc->opts[0]; + fi = o->v[0].fi; + while (step < stop) { + slot_set_value(step_slot, make_integer(sc, step)); + fi(o); + step = integer(slot_value(step_slot)) + 1; + } + } else + while (step < stop) { + slot_set_value(step_slot, make_integer(sc, step)); + func(sc); + step = integer(slot_value(step_slot)) + 1; + } + if ((S7_DEBUGGING) && (stop != integer(slot_value(end_slot)))) + fprintf(stderr, "end: %" ld64 " %" ld64 "\n", stop, + integer(slot_value(end_slot))); + } + sc->value = sc->T; + sc->code = cdadr(scc); + return (true); + } + { + s7_pointer p; + s7_int body_len; + opt_info *body[32]; + int32_t k; + + body_len = s7_list_length(sc, code); + sc->pc = 0; + if (body_len >= 32) + return (false); + + if (!no_float_opt(code)) { + for (k = 0, p = code; is_pair(p); k++, p = cdr(p)) { + body[k] = sc->opts[sc->pc]; + if (!float_optimize(sc, p)) + break; + } + if (is_pair(p)) { + pc_fallback(sc, 0); + set_no_float_opt(code); + } else { + int32_t i; + end = do_loop_end(slot_value(sc->args)); + if (safe_step) { + s7_pointer stepper; + slot_set_value(sc->args, stepper = + make_mutable_integer(sc, + integer(slot_value + (sc->args)))); + for (; integer(stepper) < end; integer(stepper)++) + for (i = 0; i < body_len; i++) + body[i]->v[0].fd(body[i]); + clear_mutable_integer(stepper); + } else { + s7_int step, stop; + s7_pointer step_slot = + let_dox_slot1(sc->curlet), end_slot = + let_dox_slot2(sc->curlet); + stop = integer(slot_value(end_slot)); + for (step = integer(slot_value(step_slot)); + step < stop; + step = integer(slot_value(step_slot)) + 1) { + slot_set_value(step_slot, make_integer(sc, step)); + for (i = 0; i < body_len; i++) + body[i]->v[0].fd(body[i]); + } + } + sc->value = sc->T; + sc->code = cdadr(scc); + return (true); + } + } + + /* not float opt */ + sc->pc = 0; + for (k = 0, p = code; is_pair(p); k++, p = cdr(p)) { + opt_info *start = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + oo_idp_nr_fixup(start); + body[k] = start; + } + if (is_null(p)) { + int32_t i; + end = do_loop_end(slot_value(sc->args)); + if (safe_step) { + s7_pointer stepper; + slot_set_value(sc->args, stepper = + make_mutable_integer(sc, + integer(slot_value + (sc->args)))); + for (; integer(stepper) < end; integer(stepper)++) + for (i = 0; i < body_len; i++) + body[i]->v[0].fp(body[i]); + clear_mutable_integer(stepper); + } else { + s7_int step, stop; + s7_pointer step_slot = + let_dox_slot1(sc->curlet), end_slot = + let_dox_slot2(sc->curlet); + stop = integer(slot_value(end_slot)); + for (step = integer(slot_value(step_slot)); step < stop; + step = integer(slot_value(step_slot)) + 1) { + slot_set_value(step_slot, make_integer(sc, step)); + for (i = 0; i < body_len; i++) + body[i]->v[0].fp(body[i]); + } + } + sc->value = sc->T; + sc->code = cdadr(scc); + return (true); + } + } + return (false); +} + +static goto_t do_let(s7_scheme * sc, s7_pointer step_slot, s7_pointer scc) +{ + s7_pointer let_body, p = NULL, let_vars, let_code, ip; + bool let_star; + s7_pointer old_e, stepper; + s7_int body_len, var_len, k, end; +#define O_SIZE 32 + opt_info *body[O_SIZE], *vars[O_SIZE]; + + memset((void *) body, 0, O_SIZE * sizeof(opt_info *)); /* placate the damned compiler */ + memset((void *) vars, 0, O_SIZE * sizeof(opt_info *)); + + /* do_let with non-float vars doesn't get many fixable hits */ + let_code = caddr(scc); + if ((!is_pair(cdr(let_code))) || (!is_list(cadr(let_code)))) /* (do ((j 0 (+ j 1))) ((= j 1)) (let name 123)) */ + return (fall_through); + let_body = cddr(let_code); + body_len = s7_list_length(sc, let_body); + if ((body_len <= 0) || (body_len >= 32)) + return (fall_through); + let_star = (symbol_syntax_op_checked(let_code) == OP_LET_STAR); + let_vars = cadr(let_code); + set_safe_stepper(step_slot); + stepper = slot_value(step_slot); + + old_e = sc->curlet; + sc->curlet = make_let_slowly(sc, sc->curlet); + + sc->pc = 0; + for (var_len = 0, p = let_vars; (is_pair(p)) && (var_len < 32); + var_len++, p = cdr(p)) { + if ((!is_pair(car(p))) || (!is_normal_symbol(caar(p))) + || (!is_pair(cdar(p)))) + return (fall_through); + vars[var_len] = sc->opts[sc->pc]; + if (!float_optimize(sc, cdar(p))) { /* each of these needs to set the associated variable */ + set_curlet(sc, old_e); + return (fall_through); + } + if (let_star) + add_slot_checked(sc, sc->curlet, caar(p), + s7_make_mutable_real(sc, 1.5)); + } + + if (!let_star) + for (p = let_vars; is_pair(p); p = cdr(p)) + add_slot_checked(sc, sc->curlet, caar(p), + s7_make_mutable_real(sc, 1.5)); + + for (k = 0, p = let_body; is_pair(p); k++, p = cdr(p)) { + body[k] = sc->opts[sc->pc]; + if (!float_optimize(sc, p)) { + set_curlet(sc, old_e); + return (fall_through); + } + } + if (!is_null(p)) { /* no hits in s7test or snd-test */ + set_curlet(sc, old_e); + return (fall_through); + } + + end = do_loop_end(stepper); + let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); + ip = slot_value(step_slot); + + if (body_len == 1) { + if (var_len == 1) { + s7_pointer xp; + opt_info *first, *o; + s7_double(*f1) (opt_info * o); + s7_double(*f2) (opt_info * o); + xp = t_lookup(sc, caar(let_vars), let_vars); + first = sc->opts[0]; + f1 = first->v[0].fd; + integer(ip) = numerator(stepper); + set_real(xp, f1(first)); + o = body[0]; + f2 = o->v[0].fd; + f2(o); + if ((f2 == opt_fmv) && + (f1 == opt_d_dd_ff_o2) && + (first->v[3].d_dd_f == add_d_dd) && + (slot_symbol(step_slot) == slot_symbol(o->v[2].p))) { + opt_info *o1, *o2, *o3; + s7_d_v_t vf1, vf2, vf3, vf4; + s7_d_vd_t vf5, vf6; + s7_d_vid_t vf7; + void *obj1, *obj2, *obj3, *obj4, *obj5, *obj6, *obj7; + o1 = o->v[12].o1; + o2 = o->v[13].o1; + o3 = o->v[14].o1; + vf1 = first->v[4].d_v_f; + vf2 = first->v[5].d_v_f; + vf3 = o1->v[2].d_v_f; + vf4 = o3->v[5].d_v_f; + vf5 = o2->v[3].d_vd_f; + vf6 = o3->v[6].d_vd_f; + vf7 = o->v[4].d_vid_f; + obj1 = first->v[1].obj; + obj2 = first->v[2].obj; + obj3 = o1->v[1].obj; + obj4 = o3->v[1].obj; + obj5 = o->v[5].obj; + obj6 = o2->v[5].obj; + obj7 = o3->v[2].obj; + + for (k = numerator(stepper) + 1; k < end; k++) { + s7_double amp_env, vib; + vib = vf1(obj1) + vf2(obj2); + amp_env = vf3(obj3); + vf7(obj5, k, + amp_env * vf5(obj6, + vib + (vf4(obj4) * vf6(obj7, vib)))); + } + } else + for (k = numerator(stepper) + 1; k < end; k++) { + integer(ip) = k; + set_real(xp, f1(first)); + f2(o); + } + } /* body_len == 1 and var_len == 1 */ + else { + if (var_len == 2) { + s7_pointer s1 = let_slots(sc->curlet), s2; + s2 = next_slot(s1); + for (k = numerator(stepper); k < end; k++) { + integer(ip) = k; + set_real(slot_value(s1), vars[0]->v[0].fd(vars[0])); + set_real(slot_value(s2), vars[1]->v[0].fd(vars[1])); + body[0]->v[0].fd(body[0]); + } + } /* body_len == 1 and var_len == 2 */ + else + for (k = numerator(stepper); k < end; k++) { + int32_t n; + integer(ip) = k; + for (n = 0, p = let_slots(sc->curlet); tis_slot(p); + n++, p = next_slot(p)) + set_real(slot_value(p), vars[n]->v[0].fd(vars[n])); + body[0]->v[0].fd(body[0]); + } + } + } /* end body_len == 1 */ + else if ((body_len == 2) && (var_len == 1)) { + s7_pointer s1 = let_slots(sc->curlet); + for (k = numerator(stepper); k < end; k++) { + integer(ip) = k; + set_real(slot_value(s1), vars[0]->v[0].fd(vars[0])); + body[0]->v[0].fd(body[0]); + body[1]->v[0].fd(body[1]); + } + } else + for (k = numerator(stepper); k < end; k++) { + int32_t i; + integer(ip) = k; + for (i = 0, p = let_slots(sc->curlet); tis_slot(p); + i++, p = next_slot(p)) + set_real(slot_value(p), vars[i]->v[0].fd(vars[i])); + for (i = 0; i < body_len; i++) + body[i]->v[0].fd(body[i]); + } + set_curlet(sc, old_e); + sc->value = sc->T; + sc->code = cdadr(scc); + return (goto_safe_do_end_clauses); +} + +static bool dotimes(s7_scheme * sc, s7_pointer code, bool safe_case) +{ + s7_pointer body = caddr(code); /* here we assume one expr in body */ + if (((is_syntactic_pair(body)) || + (is_symbol_and_syntactic(car(body)))) && + ((symbol_syntax_op_checked(body) == OP_LET) || + (symbol_syntax_op(car(body)) == OP_LET_STAR))) + return (do_let(sc, sc->args, code) == goto_safe_do_end_clauses); + return (opt_dotimes(sc, cddr(code), code, safe_case)); +} + +static goto_t op_safe_dotimes(s7_scheme * sc) +{ + s7_pointer init_val, form = sc->code; + sc->code = cdr(sc->code); + + init_val = fx_call(sc, cdaar(sc->code)); + if (s7_is_integer(init_val)) { + s7_pointer end_expr, end_val, code = sc->code; + end_expr = caadr(code); + end_val = caddr(end_expr); + if (is_symbol(end_val)) + end_val = lookup_checked(sc, end_val); + + if (s7_is_integer(end_val)) { + sc->code = cddr(code); + sc->curlet = make_let_slowly(sc, sc->curlet); + sc->args = + add_slot_checked(sc, sc->curlet, caaar(code), + make_mutable_integer(sc, + s7_integer_checked + (sc, init_val))); + set_do_loop_end(slot_value(sc->args), + s7_integer_checked(sc, end_val)); + set_step_end(sc->args); /* safe_dotimes step is by 1 */ + + /* (define (hi) (do ((i 1 (+ 1 i))) ((= i 1) i))) -- we need the let even if the loop is not evaluated */ + + /* safe_dotimes: (car(body) is known to be a pair here) + * if 1-expr body look for syntactic case, if let(*) goto do_let, else opt_dotimes + * if they are unhappy, got safe_dotimes_step_o + * else goto opt_dotimes then safe_dotimes_step_o + * if multi-line body, check opt_dotimes, then safe_dotimes_step + */ + + if (s7_integer_checked(sc, init_val) == + s7_integer_checked(sc, end_val)) { + sc->value = sc->T; + sc->code = cdadr(code); + return (goto_safe_do_end_clauses); + } + + if ((is_null(cdr(sc->code))) && (is_pair(car(sc->code)))) { + sc->code = car(sc->code); + set_opt2_pair(code, sc->code); /* is_pair above */ + + if ((is_syntactic_pair(sc->code)) || + (is_symbol_and_syntactic(car(sc->code)))) { + if (!is_unsafe_do(code)) { + if (dotimes(sc, code, true)) + return (goto_safe_do_end_clauses); + set_unsafe_do(code); + } + push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code); + if (is_syntactic_pair(sc->code)) + sc->cur_op = (opcode_t) optimize_op(sc->code); + else { + sc->cur_op = + (opcode_t) symbol_syntax_op_checked(sc->code); + pair_set_syntax_op(sc->code, sc->cur_op); + } + return (goto_top_no_pop); + } + /* car not syntactic? */ + if ((!is_unsafe_do(code)) && + (opt_dotimes(sc, cddr(code), code, true))) + return (goto_safe_do_end_clauses); + set_unsafe_do(code); + + if (has_fx(cddr(code))) { /* this almost never happens and the func case below is only in timing tests */ + s7_int end = s7_integer_checked(sc, end_val); + s7_pointer body = cddr(code), stepper = + slot_value(sc->args); + for (; integer(stepper) < end; integer(stepper)++) + fx_call(sc, body); + sc->value = sc->T; + sc->code = cdadr(code); + return (goto_safe_do_end_clauses); + } + push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code); /* arg is local step var slot, code is do form - do, sc->code is the body */ + return (goto_eval); + } + /* multi-line body */ + if ((!is_unsafe_do(code)) && + (opt_dotimes(sc, sc->code, code, true))) + return (goto_safe_do_end_clauses); + set_unsafe_do(code); + set_opt2_pair(code, sc->code); + push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, code); + return (goto_begin); + } + } + pair_set_syntax_op(form, OP_SIMPLE_DO); + sc->code = form; + if (op_simple_do(sc)) + return (goto_do_end_clauses); + return (goto_begin); +} + +static goto_t op_safe_do(s7_scheme * sc) +{ + /* body is safe, step = +1, end is = or >=, but stepper and end might be set (or at least indirectly exported) in the body: + * (let ((lst ())) (do ((i 0 (+ i 1))) ((= i 10)) (let ((j (min i 100))) (set! lst (cons j lst)))) lst) + * however, we're very restrictive about this in check_do and do_is_safe; even this is considered trouble: + * (let ((x 0)) (do ((i i (+ i 1))) ((= i 7)) (set! x (+ x i))) x) + * but end might not be an integer -- need to catch this earlier. + */ + s7_pointer end, init_val, end_val, code, form = sc->code; + + /* inits, if not >= opt_dotimes else safe_do_step */ + sc->code = cdr(sc->code); + code = sc->code; + init_val = fx_call(sc, cdaar(code)); + end = opt1_any(code); /* caddr(caadr(code)) */ + end_val = (is_symbol(end)) ? lookup_checked(sc, end) : end; + + if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val))) { /* this almost never happens */ + pair_set_syntax_op(form, OP_DO_UNCHECKED); + return (goto_do_unchecked); + } + + /* (let ((sum 0)) (define (hi) (do ((i 10 (+ i 1))) ((= i 10) i) (set! sum (+ sum i)))) (hi)) */ + sc->curlet = make_let_slowly(sc, sc->curlet); + let_set_dox_slot1(sc->curlet, add_slot_checked(sc, sc->curlet, caaar(code), init_val)); /* define the step var -- might be needed in the end clauses */ + + if ((s7_integer_checked(sc, init_val) == + s7_integer_checked(sc, end_val)) + || + ((s7_integer_checked(sc, init_val) > + s7_integer_checked(sc, end_val)) + && (opt1_cfunc(caadr(code)) == sc->geq_2))) { + sc->value = sc->T; + sc->code = cdadr(code); + return (goto_safe_do_end_clauses); + } + + if (is_symbol(end)) + let_set_dox_slot2(sc->curlet, lookup_slot_from(end, sc->curlet)); + else + let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end)); + sc->args = let_dox_slot2(sc->curlet); /* the various safe steps assume sc->args is the end slot */ + + { + s7_pointer step_slot = let_dox_slot1(sc->curlet); + set_step_end(step_slot); + slot_set_value(step_slot, + make_mutable_integer(sc, + integer(slot_value + (step_slot)))); + set_do_loop_end(slot_value(step_slot), + s7_integer_checked(sc, end_val)); + } + + if (!is_unsafe_do(sc->code)) { + s7_pointer old_let = sc->curlet; + sc->temp7 = old_let; + if (opt_dotimes(sc, cddr(sc->code), sc->code, false)) + return (goto_safe_do_end_clauses); + set_curlet(sc, old_let); /* apparently s7_optimize can step on sc->curlet? */ + } + if (is_null(cdddr(sc->code))) { + s7_pointer body = caddr(sc->code); + if ((car(body) == sc->set_symbol) && + (is_pair(cdr(body))) && + (is_symbol(cadr(body))) && + (is_pair(cddr(body))) && + (has_fx(cddr(body))) && (is_null(cdddr(body)))) { + s7_pointer step_slot = let_dox_slot1(sc->curlet); + if (slot_symbol(step_slot) != cadr(body)) { + s7_int step, endi; + s7_pointer val_slot, fx_p, step_val; + + endi = integer(let_dox2_value(sc->curlet)); + val_slot = lookup_slot_from(cadr(body), sc->curlet); + fx_p = cddr(body); + step = integer(slot_value(step_slot)); + slot_set_value(step_slot, step_val = + make_mutable_integer(sc, step)); + + do { + slot_set_value(val_slot, fx_call(sc, fx_p)); + integer(step_val) = ++step; + } while (step != endi); /* geq not needed here -- we're leq endi and stepping by +1 all ints */ + clear_mutable_integer(step_val); + sc->value = sc->T; + sc->code = cdadr(code); + return (goto_safe_do_end_clauses); + } + } + } + sc->code = cddr(code); + set_unsafe_do(sc->code); + set_opt2_pair(code, sc->code); + push_stack_no_args(sc, OP_SAFE_DO_STEP, code); /* (do ((i 0 (+ i 1))) ((= i 2)) (set! (str i) #\a)) */ + return (goto_begin); +} + +static goto_t op_dotimes_p(s7_scheme * sc) +{ + s7_pointer end, code = cdr(sc->code), init_val, end_val, slot, old_e; + /* (do ... (set! args ...)) -- one line, syntactic */ + + init_val = fx_call(sc, cdaar(code)); + sc->value = init_val; + set_opt2_pair(code, caadr(code)); + end = opt1_any(code); /* caddr(opt2_pair(code)) */ + if (is_symbol(end)) { + slot = lookup_slot_from(end, sc->curlet); + end_val = slot_value(slot); + } else { + slot = make_slot(sc, make_symbol(sc, "___end___"), end); /* name is ignored, but needs to be > 8 chars for gcc's benefit (version 10.2.1)! */ + end_val = end; + } + if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val))) { + pair_set_syntax_op(sc->code, OP_DO_UNCHECKED); + sc->code = cdr(sc->code); + return (goto_do_unchecked); + } + + old_e = sc->curlet; + sc->curlet = make_let_slowly(sc, sc->curlet); + let_set_dox_slot1(sc->curlet, + add_slot_checked(sc, sc->curlet, caaar(code), + init_val)); + let_set_dox_slot2(sc->curlet, slot); + + set_car(sc->t2_1, let_dox1_value(sc->curlet)); + set_car(sc->t2_2, let_dox2_value(sc->curlet)); + if (is_true(sc, sc->value = fn_proc(caadr(code)) (sc, sc->t2_1))) { + sc->code = cdadr(code); + return (goto_do_end_clauses); + } + if ((!is_unsafe_do(code)) && (opt1_cfunc(caadr(code)) != sc->geq_2)) { + s7_pointer old_args = sc->args, old_init = + let_dox1_value(sc->curlet); + sc->args = T_Slt(let_dox_slot1(sc->curlet)); /* used in opt_dotimes */ + slot_set_value(sc->args, + make_mutable_integer(sc, + integer(let_dox1_value + (sc->curlet)))); + set_do_loop_end(slot_value(sc->args), + integer(let_dox2_value(sc->curlet))); + set_step_end(sc->args); /* dotimes step is by 1 */ + sc->code = cdr(sc->code); + if (dotimes(sc, code, false)) + return (goto_do_end_clauses); /* not safe_do here */ + slot_set_value(sc->args, old_init); + set_curlet(sc, old_e); /* free_cell(sc, sc->curlet) beforehand is not safe */ + sc->args = old_args; + set_unsafe_do(code); + return (goto_do_unchecked); + } + push_stack_no_args(sc, OP_DOTIMES_STEP_O, code); + sc->code = caddr(code); + return (goto_eval); +} + +static goto_t op_do_init_1(s7_scheme * sc) +{ + s7_pointer x, y, z; + while (true) { /* at start, first value is the loop (for GC protection?), returning sc->value is the next value */ + s7_pointer init; + sc->args = cons(sc, sc->value, sc->args); /* code will be last element (first after reverse), these cons's will be used below for the new let/slots */ + if (!is_pair(sc->code)) + break; + /* here sc->code is a list like: ((i 0 (+ i 1)) ...) so cadar gets the init value. */ + init = cdar(sc->code); + if (has_fx(init)) + sc->value = fx_call(sc, init); + else { + init = car(init); + if (is_pair(init)) { + push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code)); /* OP_DO_INIT only used here */ + sc->code = init; + return (goto_eval); + } + sc->value = + (is_symbol(init)) ? lookup_checked(sc, init) : init; + } + sc->code = cdr(sc->code); + } + + /* all the initial values are now in the args list */ + sc->args = proper_list_reverse_in_place(sc, sc->args); + sc->code = car(sc->args); /* saved at the start */ + + z = sc->args; + sc->args = cdr(sc->args); /* init values */ + + /* sc->args was cons'd above, so it should be safe to reuse it as the new let */ + set_curlet(sc, reuse_as_let(sc, z, sc->curlet)); /* sc->curlet = make_let_slowly(sc, sc->curlet); */ + + /* run through sc->code and sc->args adding '( caar(car(code)) . car(args) ) to sc->curlet, also reuse sc->args as the new let slots */ + sc->value = sc->nil; + y = sc->args; + for (x = car(sc->code); is_not_null(y); x = cdr(x)) { + s7_pointer sym = caar(x), args = cdr(y); + reuse_as_slot(sc, y, sym, unchecked_car(y)); + slot_set_next(y, let_slots(sc->curlet)); + let_set_slots(sc->curlet, y); + symbol_set_local_slot(sym, let_id(sc->curlet), y); + if (is_pair(cddar(x))) { /* else no incr expr, so ignore it henceforth */ + slot_set_expression(y, cddar(x)); + sc->value = cons_unchecked(sc, y, sc->value); + } + y = args; + } + sc->args = cons(sc, sc->value = + proper_list_reverse_in_place(sc, sc->value), + cadr(sc->code)); + sc->code = cddr(sc->code); + return (fall_through); +} + +static bool op_do_init(s7_scheme * sc) +{ + if (is_multiple_value(sc->value)) /* (do ((i (values 1 2)))...) */ + eval_error_any(sc, sc->wrong_type_arg_symbol, + "do: variable initial value can't be ~S", 38, + set_ulist_1(sc, sc->values_symbol, sc->value)); + return (op_do_init_1(sc) != goto_eval); +} + +static void op_do_unchecked(s7_scheme * sc) +{ + push_stack_no_code(sc, OP_GC_PROTECT, sc->code); + sc->code = cdr(sc->code); +} + +static bool do_unchecked(s7_scheme * sc) +{ + if (is_null(car(sc->code))) { /* (do () ...) -- (let ((i 0)) (do () ((= i 1)) (set! i 1))) */ + sc->curlet = make_let_slowly(sc, sc->curlet); + sc->args = cons_unchecked(sc, sc->nil, cadr(sc->code)); + sc->code = cddr(sc->code); + return (false); + } + /* eval each init value, then set up the new let (like let, not let*) */ + sc->args = sc->nil; /* the evaluated var-data */ + sc->value = sc->code; /* protect it */ + sc->code = car(sc->code); /* the vars */ + return (op_do_init_1(sc) == goto_eval); +} + +static bool op_do_end(s7_scheme * sc) +{ + /* car(sc->args) here is the var list used by do_end2 */ + if (is_pair(cdr(sc->args))) { + if (!has_fx(cdr(sc->args))) { + push_stack_direct(sc, OP_DO_END1); + sc->code = cadr(sc->args); /* evaluate the end expr */ + return (true); + } + sc->value = fx_call(sc, cdr(sc->args)); + } else + sc->value = sc->F; /* goto "if (is_pair(sc->code))..." below */ + return (false); +} + +static goto_t op_do_end1(s7_scheme * sc) +{ + if (is_true(sc, sc->value)) { /* sc->value is the result of end-test evaluation */ + /* we're done -- deal with result exprs, if there isn't an end test, there also isn't a result (they're in the same list) + * multiple-value end-test result is ok + */ + sc->code = T_Lst(cddr(sc->args)); /* result expr (a list -- implicit begin) */ + free_cell(sc, sc->args); + sc->args = sc->nil; + if (is_null(sc->code)) { + if (is_multiple_value(sc->value)) /* (define (f) (+ 1 (do ((i 2 (+ i 1))) ((values i (+ i 1)))))) -> 6 */ + sc->value = + splice_in_values(sc, multiple_value(sc->value)); + /* similarly, if the result is a multiple value: (define (f) (+ 1 (do ((i 2 (+ i 1))) ((= i 3) (values i (+ i 1)))))) -> 8 */ + return (goto_start); + } + /* might be => here as in cond and case */ + if (is_null(cdr(sc->code))) { + if (has_fx(sc->code)) { + sc->value = fx_call(sc, sc->code); + return (goto_start); + } + sc->code = car(sc->code); + return (goto_eval); + } + if (is_undefined_feed_to(sc, car(sc->code))) + return (goto_feed_to); + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + sc->code = car(sc->code); + return (goto_eval); + } + if (!is_pair(sc->code)) + return ((is_null(car(sc->args))) ? /* no steppers */ goto_do_end : + fall_through); + if (is_null(car(sc->args))) + push_stack_direct(sc, OP_DO_END); + else + push_stack_direct(sc, OP_DO_STEP); + return (goto_begin); +} + +/* -------------------------------------------------------------------------------- */ + +static void op_unwind_output(s7_scheme * sc) +{ + bool is_file = is_file_port(sc->code); + + if ((is_output_port(sc->code)) && (!port_is_closed(sc->code))) + s7_close_output_port(sc, sc->code); /* may call fflush */ + + if (((is_output_port(sc->args)) && + (!port_is_closed(sc->args))) || (sc->args == sc->F)) + set_current_output_port(sc, sc->args); + + if ((is_file) && (is_multiple_value(sc->value))) + sc->value = splice_in_values(sc, multiple_value(sc->value)); +} + +static void op_unwind_input(s7_scheme * sc) +{ + /* sc->code is an input port */ + if (!port_is_closed(sc->code)) + s7_close_input_port(sc, sc->code); + + if ((is_input_port(sc->args)) && (!port_is_closed(sc->args))) + set_current_input_port(sc, sc->args); + + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); +} + +static goto_t op_dynamic_wind(s7_scheme * sc) +{ + if (dynamic_wind_state(sc->code) == DWIND_INIT) { + dynamic_wind_state(sc->code) = DWIND_BODY; + push_stack(sc, OP_DYNAMIC_WIND, sc->nil, sc->code); + sc->code = dynamic_wind_body(sc->code); + sc->args = sc->nil; + return (goto_apply); + } + if (dynamic_wind_state(sc->code) == DWIND_BODY) { + dynamic_wind_state(sc->code) = DWIND_FINISH; + if (dynamic_wind_out(sc->code) != sc->F) { + push_stack(sc, OP_DYNAMIC_WIND, sc->value, sc->code); + sc->code = dynamic_wind_out(sc->code); + sc->args = sc->nil; + return (goto_apply); + } + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return (goto_start); + } + if (is_multiple_value(sc->args)) /* (+ 1 (dynamic-wind (lambda () #f) (lambda () (values 2 3 4)) (lambda () #f)) 5) */ + sc->value = splice_in_values(sc, multiple_value(sc->args)); + else + sc->value = sc->args; /* value saved above */ + return (goto_start); +} + +static goto_t op_read_s(s7_scheme * sc) +{ + /* another lint opt */ + s7_pointer port; + + port = lookup(sc, cadr(sc->code)); + if (!is_input_port(port)) { /* was also not stdin */ + sc->value = g_read(sc, set_plist_1(sc, port)); + return (goto_start); + } + if (port_is_closed(port)) /* I guess the port_is_closed check is needed because we're going down a level below */ + simple_wrong_type_argument_with_type(sc, sc->read_symbol, port, + an_open_port_string); + + if (is_function_port(port)) { + sc->value = (*(port_input_function(port))) (sc, S7_READ, port); + if (is_multiple_value(sc->value)) { + clear_multiple_value(sc->value); + s7_error(sc, sc->bad_result_symbol, + set_elist_2(sc, + wrap_string(sc, + "input-function-port read returned: ~S", + 37), sc->value)); + } + } else + if ((is_string_port(port)) && + (port_data_size(port) <= port_position(port))) + sc->value = eof_object; + else { + push_input_port(sc, port); + push_stack_op(sc, OP_READ_DONE); /* this stops the internal read process so we only get one form */ + sc->tok = token(sc); + switch (sc->tok) { + case TOKEN_EOF: + return (goto_start); + case TOKEN_RIGHT_PAREN: + read_error(sc, "unexpected close paren"); + case TOKEN_COMMA: + read_error(sc, "unexpected comma"); + default: + sc->value = read_expression(sc); + sc->current_line = port_line_number(current_input_port(sc)); /* this info is used to track down missing close parens */ + sc->current_file = port_filename(current_input_port(sc)); + } + } + /* equally read-done and read-list here */ + return (goto_start); +} + +static Inline void op_increment_by_1(s7_scheme * sc) +{ /* ([set!] ctr (+ ctr 1)) */ + s7_pointer val, y; + + y = lookup_slot_from(cadr(sc->code), sc->curlet); + if (!is_slot(y)) + s7_error(sc, sc->unbound_variable_symbol, + set_elist_3(sc, wrap_string(sc, "~S in ~S", 8), + cadr(sc->code), sc->code)); + val = slot_value(y); + if (is_t_integer(val)) + sc->value = make_integer(sc, integer(val) + 1); + else + switch (type(val)) { + case T_RATIO: + new_cell(sc, sc->value, T_RATIO); + numerator(sc->value) = numerator(val) + denominator(val); + denominator(sc->value) = denominator(val); + break; + case T_REAL: + sc->value = make_real(sc, real(val) + 1.0); + break; + case T_COMPLEX: + new_cell(sc, sc->value, T_COMPLEX); + set_real_part(sc->value, real_part(val) + 1.0); + set_imag_part(sc->value, imag_part(val)); + break; + default: + sc->value = add_p_pp(sc, val, int_one); + break; + } + slot_set_value(y, sc->value); +} + +static void op_decrement_by_1(s7_scheme * sc) +{ /* ([set!] ctr (- ctr 1)) */ + s7_pointer val, y; + + y = lookup_slot_from(cadr(sc->code), sc->curlet); + if (!is_slot(y)) + s7_error(sc, sc->unbound_variable_symbol, + set_elist_3(sc, wrap_string(sc, "~S in ~S", 8), + cadr(sc->code), sc->code)); + val = slot_value(y); + if (is_t_integer(val)) + sc->value = make_integer(sc, integer(val) - 1); /* increment (set!) returns the new value in sc->value */ + else + switch (type(val)) { + case T_RATIO: + new_cell(sc, sc->value, T_RATIO); + numerator(sc->value) = numerator(val) - denominator(val); + denominator(sc->value) = denominator(val); + break; + case T_REAL: + sc->value = make_real(sc, real(val) - 1.0); + break; + case T_COMPLEX: + new_cell(sc, sc->value, T_COMPLEX); + set_real_part(sc->value, real_part(val) - 1.0); + set_imag_part(sc->value, imag_part(val)); + break; + default: + sc->value = g_subtract(sc, set_plist_2(sc, val, int_one)); + break; + } + slot_set_value(y, sc->value); +} + +static void op_set_pws(s7_scheme * sc) +{ + /* this is (set! (getter) val) where getter is a global c_function (a built-in pws) and val is not a pair: (set! (mus-clipping) #f) */ + s7_pointer obj, code = cdr(sc->code); + obj = caar(code); + if (is_symbol(obj)) { + obj = lookup_slot_from(obj, sc->curlet); + if (is_slot(obj)) + obj = slot_value(obj); + else + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, no_setter_string, caar(code), + sc->prepackaged_type_names[type(obj)])); + } + if ((is_c_function(obj)) && (is_procedure(c_function_setter(obj)))) { + s7_pointer value = cadr(code); + if (is_symbol(value)) + value = lookup_checked(sc, value); + set_car(sc->t1_1, value); + sc->value = c_function_call(c_function_setter(obj)) (sc, sc->t1_1); + } else + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, no_setter_string, caar(sc->code), + sc->prepackaged_type_names[type(obj)])); +} + + +/* -------------------------------- apply functions -------------------------------- */ + +static void apply_c_function(s7_scheme * sc) +{ /* -------- C-based function -------- */ + s7_int len; + len = proper_list_length(sc->args); + if (len < c_function_required_args(sc->code)) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, not_enough_arguments_string, sc->code, + sc->args)); + if (c_function_all_args(sc->code) < len) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, sc->code, + sc->args)); + sc->value = c_function_call(sc->code) (sc, sc->args); + /* just by chance, this code is identical to macroexpand_c_macro's code (after macro expansion)! So, + * gcc -O2 uses the macroexpand code, but then valgrind shows us calling macros all the time, and + * gdb with break apply_c_function breaks at macroexpand -- confusing! + */ +} + +static void apply_c_opt_args_function(s7_scheme * sc) +{ /* -------- C-based function that has n optional arguments -------- */ + s7_int len; + len = proper_list_length(sc->args); + if (c_function_all_args(sc->code) < len) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, sc->code, + sc->args)); + sc->value = c_function_call(sc->code) (sc, sc->args); +} + +static void apply_c_rst_args_function(s7_scheme * sc) +{ /* -------- C-based function that has n required args, then any others -------- */ + s7_int len; + len = proper_list_length(sc->args); + if (len < c_function_required_args(sc->code)) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, not_enough_arguments_string, sc->code, + sc->args)); + sc->value = c_function_call(sc->code) (sc, sc->args); + /* sc->code here need not match sc->code before the function call (map for example) */ +} + +static void apply_c_any_args_function(s7_scheme * sc) +{ /* -------- C-based function that can take any number of arguments -------- */ + sc->value = c_function_call(sc->code) (sc, sc->args); +} + +static void apply_c_macro(s7_scheme * sc) +{ /* -------- C-based macro -------- */ + s7_int len; + len = proper_list_length(sc->args); + if (len < c_macro_required_args(sc->code)) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, not_enough_arguments_string, sc->code, + sc->args)); + if (c_macro_all_args(sc->code) < len) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, sc->code, + sc->args)); + sc->code = c_macro_call(sc->code) (sc, sc->args); +} + +static void apply_syntax(s7_scheme * sc) +{ /* -------- syntactic keyword as applicable object -------- */ + /* current reader-cond macro uses this via (map quote ...) */ + s7_int len; /* ((apply lambda '((x) (+ x 1))) 4) */ + if (is_pair(sc->args)) { /* this is ((pars) . body) */ + len = s7_list_length(sc, sc->args); + if (len == 0) + eval_error(sc, "attempt to evaluate a circular list: ~S", 39, + sc->args); + if ((sc->safety > NO_SAFETY) && (tree_is_cyclic(sc, sc->args))) + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, + wrap_string(sc, + "apply ~S: body is circular: ~S", + 30), sc->code, sc->args)); + } else + len = 0; + + if (len < syntax_min_args(sc->code)) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, not_enough_arguments_string, sc->code, + sc->args)); + + if ((syntax_max_args(sc->code) < len) && + (syntax_max_args(sc->code) != -1)) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, sc->code, + sc->args)); + + sc->cur_op = (opcode_t) syntax_opcode(sc->code); /* (apply begin '((define x 3) (+ x 2))) */ + /* I had elaborate checks here for embedded circular lists, but now I think that is the caller's problem */ + sc->code = cons(sc, sc->code, sc->args); + pair_set_syntax_op(sc->code, sc->cur_op); +} + +static void apply_vector(s7_scheme * sc) +{ /* -------- vector as applicable object -------- */ + /* sc->code is the vector, sc->args is the list of indices */ + if (is_null(sc->args)) /* (#2d((1 2) (3 4))) */ + s7_wrong_number_of_args_error(sc, + "not enough arguments for vector-ref: ~A", + sc->args); + + if ((is_null(cdr(sc->args))) && + (s7_is_integer(car(sc->args))) && (vector_rank(sc->code) == 1)) { + s7_int index = s7_integer_checked(sc, car(sc->args)); + if ((index >= 0) && (index < vector_length(sc->code))) + sc->value = vector_getter(sc->code) (sc, sc->code, index); + else + out_of_range(sc, sc->vector_ref_symbol, int_two, car(sc->args), + (index < + 0) ? its_negative_string : its_too_large_string); + } else + sc->value = vector_ref_1(sc, sc->code, sc->args); +} + +static void apply_string(s7_scheme * sc) +{ /* -------- string as applicable object -------- */ + if ((is_pair(sc->args)) && (is_null(cdr(sc->args)))) { + if (s7_is_integer(car(sc->args))) { + s7_int index = s7_integer_checked(sc, car(sc->args)); + if ((index >= 0) && (index < string_length(sc->code))) { + sc->value = + chars[((uint8_t *) string_value(sc->code))[index]]; + return; + } + } + sc->value = string_ref_1(sc, sc->code, car(sc->args)); + } else + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, + (is_null(sc->args)) ? + not_enough_arguments_string : + too_many_arguments_string, sc->code, + sc->args)); +} + +static bool apply_pair(s7_scheme * sc) +{ /* -------- list as applicable object -------- */ + if (is_multiple_value(sc->code)) { /* ((values 1 2 3) 0) */ + /* car of values can be anything, so conjure up a new expression, and apply again */ + sc->x = multiple_value(sc->code); /* ((values + 1 2) 3) */ + sc->code = car(sc->x); + sc->args = pair_append(sc, cdr(sc->x), sc->args); + sc->x = sc->nil; + return (false); + } + if (is_null(sc->args)) + s7_wrong_number_of_args_error(sc, + "not enough arguments for list-ref (via list as applicable object): ~A", + sc->args); + sc->value = list_ref_1(sc, sc->code, car(sc->args)); /* (L 1) */ + if (!is_null(cdr(sc->args))) + sc->value = implicit_index(sc, sc->value, cdr(sc->args)); /* (L 1 2) */ + return (true); +} + +static void apply_hash_table(s7_scheme * sc) +{ /* -------- hash-table as applicable object -------- */ + if (is_null(sc->args)) + s7_wrong_number_of_args_error(sc, + "not enough arguments for hash-table-ref (via hash table as applicable object): ~A", + sc->args); + sc->value = s7_hash_table_ref(sc, sc->code, car(sc->args)); + if (!is_null(cdr(sc->args))) + sc->value = implicit_index(sc, sc->value, cdr(sc->args)); +} + +static void apply_let(s7_scheme * sc) +{ /* -------- environment as applicable object -------- */ + if (is_null(sc->args)) + wrong_type_argument_with_type(sc, sc->let_ref_symbol, 2, sc->args, + a_symbol_string); + sc->value = s7_let_ref(sc, sc->code, car(sc->args)); + if (is_pair(cdr(sc->args))) + sc->value = implicit_index(sc, sc->value, cdr(sc->args)); + /* (let ((v #(1 2 3))) (let ((e (curlet))) ((e 'v) 1))) -> 2 + * so (let ((v #(1 2 3))) (let ((e (curlet))) (e 'v 1))) -> 2 + */ +} + +static void apply_iterator(s7_scheme * sc) +{ /* -------- iterator as applicable object -------- */ + if (!is_null(sc->args)) + s7_wrong_number_of_args_error(sc, + "too many arguments for iterator: ~A", + sc->args); + sc->value = s7_iterate(sc, sc->code); +} + +static Inline void apply_lambda(s7_scheme * sc) +{ /* -------- normal function (lambda), or macro -------- */ + /* load up the current args into the ((args) (lambda)) layout [via the current environment] */ + s7_pointer x, z, e = sc->curlet, sym, slot, last_slot; + uint64_t id; + + id = let_id(e); + last_slot = slot_end(sc); + + for (x = closure_args(sc->code), z = T_Lst(sc->args); is_pair(x); x = cdr(x), z = cdr(z)) { /* closure_args can be a symbol, for example */ + if (is_null(z)) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, not_enough_arguments_string, sc->code, + sc->args)); + + sym = car(x); + slot = make_slot(sc, sym, T_Pos(unchecked_car(z))); +#if S7_DEBUGGING + slot->debugger_bits = 0; +#endif + symbol_set_local_slot(sym, id, slot); + if (tis_slot(last_slot)) + slot_set_next(last_slot, slot); + else + let_set_slots(e, slot); + last_slot = slot; + slot_set_next(slot, slot_end(sc)); + } + if (is_null(x)) { + if (is_not_null(z)) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, sc->code, + sc->args)); + } else { + sym = x; + slot = make_slot(sc, sym, z); + symbol_set_local_slot(sym, id, slot); + if (tis_slot(last_slot)) + slot_set_next(last_slot, slot); + else + let_set_slots(e, slot); + slot_set_next(slot, slot_end(sc)); + } + sc->code = closure_body(sc->code); +} + + +/* lambda* */ +static void op_lambda_star(s7_scheme * sc) +{ + check_lambda_star(sc); + if (!is_pair(car(sc->code))) + sc->value = + make_closure(sc, car(sc->code), cdr(sc->code), + (is_symbol(car(sc->code))) ? (T_CLOSURE | + T_COPY_ARGS) : + T_CLOSURE, CLOSURE_ARITY_NOT_SET); + else + sc->value = + make_closure(sc, car(sc->code), cdr(sc->code), + (!arglist_has_rest(sc, car(sc->code))) ? + T_CLOSURE_STAR : (T_CLOSURE_STAR | T_COPY_ARGS), + CLOSURE_ARITY_NOT_SET); +} + +static void op_lambda_star_unchecked(s7_scheme * sc) +{ + s7_pointer code = cdr(sc->code); + if (!is_pair(car(code))) + sc->value = + make_closure(sc, car(code), cdr(code), + (is_symbol(car(code))) ? (T_CLOSURE | T_COPY_ARGS) + : T_CLOSURE, CLOSURE_ARITY_NOT_SET); + else + sc->value = + make_closure(sc, car(code), cdr(code), + (!arglist_has_rest(sc, car(code))) ? + T_CLOSURE_STAR : (T_CLOSURE_STAR | T_COPY_ARGS), + CLOSURE_ARITY_NOT_SET); +} + +static s7_pointer star_set(s7_scheme * sc, s7_pointer slot, s7_pointer val, + bool check_rest) +{ + if (is_checked_slot(slot)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, parameter_set_twice_string, + slot_symbol(slot), sc->args))); + if ((check_rest) && (is_rest_slot(slot))) + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, + wrap_string(sc, + "can't set rest argument ~S to ~S via keyword", + 44), slot_symbol(slot), + val))); + set_checked_slot(slot); + slot_set_value(slot, val); + return (val); +} + +static s7_pointer lambda_star_argument_set_value(s7_scheme * sc, + s7_pointer sym, + s7_pointer val, + s7_pointer slot, + bool check_rest) +{ + s7_pointer x; + if (val == sc->no_value) + val = sc->unspecified; + if (sym == slot_symbol(slot)) + return (star_set(sc, slot, val, check_rest)); + for (x = let_slots(sc->curlet) /* presumably the arglist */ ; + tis_slot(x); x = next_slot(x)) + if (slot_symbol(x) == sym) + return (star_set(sc, x, val, check_rest)); + return (sc->no_value); +} + +static s7_pointer lambda_star_set_args(s7_scheme * sc) +{ + bool allow_other_keys; + s7_pointer lx = sc->args, cx, zx = sc->nil, code = sc->code, args = + sc->args, slot = let_slots(sc->curlet); + + cx = closure_args(code); + allow_other_keys = ((is_pair(cx)) && (allows_other_keys(cx))); + + while ((is_pair(cx)) && (is_pair(lx))) { + if (car(cx) == sc->key_rest_symbol) { /* the rest arg: a default is not allowed here (see check_lambda_star_args) */ + /* next arg is bound to trailing args from this point as a list */ + zx = sc->key_rest_symbol; + cx = cdr(cx); + if ((is_keyword(car(lx))) && + (is_pair(cdr(lx))) && (keyword_symbol(car(lx)) == car(cx))) + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, + wrap_string(sc, + "can't set rest argument ~S to ~S via keyword", + 44), car(cx), + cadr(lx)))); + lambda_star_argument_set_value(sc, car(cx), lx, slot, false); + lx = cdr(lx); + cx = cdr(cx); + slot = next_slot(slot); + } else { + s7_pointer car_lx = car(lx); + if (is_keyword(car_lx)) { + if (!is_pair(cdr(lx))) { + if (!sc->accept_all_keyword_arguments) + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, + wrap_string(sc, + "~A: keyword argument's value is missing: ~S in ~S", + 49), + closure_name(sc, + code), + lx, args))); + slot_set_value(slot, car_lx); + set_checked_slot(slot); + lx = cdr(lx); + } else { + s7_pointer sym = keyword_symbol(car_lx); + if (lambda_star_argument_set_value + (sc, sym, cadr(lx), slot, true) == sc->no_value) { + /* if default value is a key, go ahead and use this value. + * (define* (f (a :b)) a) (f :c) + * this has become much trickier than I anticipated... + */ + if (allow_other_keys) { + /* in CL: (defun hi (&key (a 1) &allow-other-keys) a) (hi :b :a :a 3) -> 3 + * in s7: (define* (hi (a 1) :allow-other-keys) a) (hi :b :a :a 3) -> 3 + */ + lx = cddr(lx); + } else { + if (!sc->accept_all_keyword_arguments) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, + wrap_string(sc, + "~A: unknown key: ~S in ~S", + 25), + closure_name(sc, + code), + lx, args))); + slot_set_value(slot, car_lx); + set_checked_slot(slot); + lx = cdr(lx); + cx = cdr(cx); + slot = next_slot(slot); + } + continue; + } + lx = cddr(lx); + } + slot = next_slot(slot); + } else { /* not a key/value pair */ + if (is_checked_slot(slot)) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, parameter_set_twice_string, + slot_symbol(slot), sc->args))); + set_checked_slot(slot); + slot_set_value(slot, car(lx)); + slot = next_slot(slot); + lx = cdr(lx); + } + cx = cdr(cx); + } + } + /* (let () (define* (hi (a 1) :allow-other-keys) a) (hi :a 2 32)) -> 'error */ + /* (let () (define* (f (a :b)) a) (list (f) (f 1) (f :c) (f :a :c) (f :a 1) (f))) -> 'error */ + + /* check for trailing args with no :rest arg */ + if (is_not_null(lx)) { + if ((is_not_null(cx)) || (zx == sc->key_rest_symbol)) { + if (is_symbol(cx)) { + if ((is_keyword(car(lx))) && + (is_pair(cdr(lx))) && (keyword_symbol(car(lx)) == cx)) + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, + wrap_string(sc, + "can't set rest argument ~S to ~S via keyword", + 44), cx, + cadr(lx)))); + slot_set_value(slot, lx); + } + } else { + if (!allow_other_keys) /* ((lambda* (a) a) :a 1 2) */ + return (s7_error + (sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, + closure_name(sc, code), args))); + /* check trailing args for repeated keys or keys with no values or values with no keys */ + while (is_pair(lx)) { + if ((!is_keyword(car(lx))) || /* ((lambda* (a :allow-other-keys) a) :a 1 :b 2 3) */ + (!is_pair(cdr(lx)))) /* ((lambda* (a :allow-other-keys) a) :a 1 :b) */ + return (s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, + wrap_string(sc, + "~A: not a key/value pair: ~S", + 28), + closure_name(sc, code), + lx))); + slot = + symbol_to_local_slot(sc, keyword_symbol(car(lx)), + sc->curlet); + if ((is_slot(slot)) && (is_checked_slot(slot))) + return (s7_error + (sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, parameter_set_twice_string, + slot_symbol(slot), sc->args))); + lx = cddr(lx); + } + } + } + return (sc->nil); +} + +static inline goto_t lambda_star_default(s7_scheme * sc) +{ + while (true) { + s7_pointer z = sc->args; +#if S7_DEBUGGING + if ((z) && (!is_slot(z))) + fprintf(stderr, "%s: z is %s\n", __func__, + s7_type_names[unchecked_type(z)]); +#endif + if (tis_slot(z)) { + if ((slot_value(z) == sc->undefined) && /* trouble: (lambda* ((e #))...) */ + (slot_has_expression(z)) && /* if default val is not a pair or a symbol, this is false */ + (!is_checked_slot(z))) { + s7_pointer val = slot_expression(z); + if (is_symbol(val)) { + slot_set_value(z, lookup_checked(sc, val)); + if (slot_value(z) == sc->undefined) { + /* the current environment here contains the function parameters which + * defaulted to # (or maybe #?) earlier in apply_*_closure_star_1, + * so (define (f f) (define* (f (f f)) f) (f)) (f 0) looks for the + * default f, finds itself currently undefined, and raises an error! + * So, before claiming it is unbound, we need to check outlet as well. + * But in the case above, the inner define* shadows the caller's + * parameter before checking the default arg values, so the default f + * refers to the define* -- I'm not sure this is a bug. It means + * that (define* (f (a f)) a) returns f: (equal? f (f)) -> #t, so + * any outer f needs an extra let and endless outlets: + * (let ((f 3)) (let () (define* (f (a ((outlet (outlet (outlet (curlet)))) 'f))) a) (f))) -> 3 + * We want the shadowing once the define* is done, so the current mess is simplest. + */ + slot_set_value(z, + s7_symbol_local_value(sc, val, + let_outlet + (sc->curlet))); + if (slot_value(z) == sc->undefined) + eval_error(sc, + "lambda* defaults: ~A is unbound", + 31, slot_symbol(z)); + } + } else if (!is_pair(val)) + slot_set_value(z, val); + else if (car(val) == sc->quote_symbol) { + if ((!is_pair(cdr(val))) || /* (lambda* ((a (quote))) a) or (lambda* ((a (quote 1 1))) a) etc */ + (is_pair(cddr(val)))) + eval_error(sc, "lambda* default: ~A is messed up", + 32, val); + slot_set_value(z, cadr(val)); + } else { + push_stack_direct(sc, OP_LAMBDA_STAR_DEFAULT); + sc->code = val; + return (goto_eval); + } + } + sc->args = next_slot(z); + } else + break; + } + sc->args = sc->nil; + return (fall_through); +} + +static bool op_lambda_star_default(s7_scheme * sc) +{ + /* sc->args is the current let slots position, sc->value is the default expression's value */ + if (is_multiple_value(sc->value)) + eval_error(sc, "lambda*: argument default value can't be ~S", 43, + set_ulist_1(sc, sc->values_symbol, sc->value)); + slot_set_value(sc->args, sc->value); + sc->args = next_slot(sc->args); + if (lambda_star_default(sc) == goto_eval) + return (true); + pop_stack_no_op(sc); + sc->code = T_Pair(closure_body(sc->code)); + return (false); +} + +static inline bool set_star_args(s7_scheme * sc, s7_pointer top) +{ + lambda_star_set_args(sc); /* load up current arg vals */ + sc->args = top; + if (is_slot(sc->args)) { + /* get default values, which may involve evaluation -- see also OP_LAMBDA_STAR_DEFAULT */ + push_stack_direct(sc, OP_GC_PROTECT); + if (lambda_star_default(sc) == goto_eval) + return (true); /* else fall_through */ + pop_stack_no_op(sc); /* get original args and code back */ + } + sc->code = closure_body(sc->code); + return (false); +} + +static bool apply_safe_closure_star_1(s7_scheme * sc) +{ /* -------- define* (lambda*) -------- */ + s7_pointer z; + /* slots are in "reverse order" -- in the same order as the args, despite let printout (which reverses the order!) */ + + set_curlet(sc, closure_let(sc->code)); + if (has_no_defaults(sc->code)) { + for (z = let_slots(sc->curlet); tis_slot(z); z = next_slot(z)) { + clear_checked_slot(z); + slot_set_value(z, sc->F); + } + if (!is_null(sc->args)) + lambda_star_set_args(sc); /* load up current arg vals */ + sc->code = closure_body(sc->code); + return (false); /* goto BEGIN */ + } + for (z = let_slots(sc->curlet); tis_slot(z); z = next_slot(z)) { + clear_checked_slot(z); + slot_set_value(z, + (slot_defaults(z)) ? sc->undefined : + slot_expression(z)); + } + return (set_star_args(sc, slot_pending_value(let_slots(sc->curlet)))); +} + +static bool apply_unsafe_closure_star_1(s7_scheme * sc) +{ + s7_pointer z, val, top = sc->nil; + for (z = closure_args(sc->code); is_pair(z); z = cdr(z)) { + s7_pointer car_z = car(z); + if (is_pair(car_z)) { /* arg has a default value */ + s7_pointer slot; + val = cadr(car_z); + if ((!is_pair(val)) && (!is_symbol(val))) + slot = add_slot_checked(sc, sc->curlet, car(car_z), val); + else { + add_slot(sc, sc->curlet, car(car_z), sc->undefined); + slot = let_slots(sc->curlet); + slot_set_expression(slot, val); + } + if (is_null(top)) + top = slot; + } else if (!is_keyword(car_z)) + add_slot(sc, sc->curlet, car_z, sc->F); + else if (car_z == sc->key_rest_symbol) { /* else it's :allow-other-keys? */ + set_is_rest_slot(add_slot_checked + (sc, sc->curlet, cadr(z), sc->nil)); + z = cdr(z); + } + } + if (is_symbol(z)) + set_is_rest_slot(add_slot_checked(sc, sc->curlet, z, sc->nil)); /* set up rest arg */ + let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); + return (set_star_args(sc, top)); +} + +static void apply_macro_star_1(s7_scheme * sc) +{ + /* here the defaults (if any) are not evalled, and there is not existing let */ + s7_pointer p; + for (p = closure_args(sc->code); is_pair(p); p = cdr(p)) { + s7_pointer par = car(p); + if (is_pair(par)) + add_slot_checked(sc, sc->curlet, car(par), cadr(par)); + else if (!is_keyword(par)) + add_slot_checked(sc, sc->curlet, par, sc->F); + else if (par == sc->key_rest_symbol) { + set_is_rest_slot(add_slot_checked + (sc, sc->curlet, cadr(p), sc->nil)); + p = cdr(p); + } + } + if (is_symbol(p)) + set_is_rest_slot(add_slot_checked(sc, sc->curlet, p, sc->nil)); + let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); + lambda_star_set_args(sc); + sc->code = T_Pair(closure_body(sc->code)); +} + +static void apply_macro(s7_scheme * sc) +{ + /* this is not from the reader, so treat expansions here as normal macros */ + check_stack_size(sc); + push_stack_op_let(sc, OP_EVAL_MACRO); + sc->curlet = make_let(sc, closure_let(sc->code)); /* closure_let -> sc->curlet, sc->code is the macro */ + transfer_macro_info(sc, sc->code); +} + +static void apply_bacro(s7_scheme * sc) +{ + check_stack_size(sc); + push_stack_op_let(sc, OP_EVAL_MACRO); + sc->curlet = make_let(sc, sc->curlet); /* like let* -- we'll be adding macro args, so might as well sequester things here */ + transfer_macro_info(sc, sc->code); +} + +static void apply_macro_star(s7_scheme * sc) +{ + check_stack_size(sc); + push_stack_op_let(sc, OP_EVAL_MACRO); + sc->curlet = make_let(sc, closure_let(sc->code)); + transfer_macro_info(sc, sc->code); + apply_macro_star_1(sc); +} + +static void apply_bacro_star(s7_scheme * sc) +{ + check_stack_size(sc); + push_stack_op_let(sc, OP_EVAL_MACRO); + sc->curlet = make_let(sc, sc->curlet); + transfer_macro_info(sc, sc->code); + apply_macro_star_1(sc); +} + +static void apply_closure(s7_scheme * sc) +{ + /* we can get safe_closures here, but can't easily determine whether we have the expected saved funclet -- see ~/old/safe-closure-s7.c */ + check_stack_size(sc); + sc->curlet = make_let(sc, closure_let(sc->code)); +} + +static bool apply_closure_star(s7_scheme * sc) +{ + if (is_safe_closure(sc->code)) + return (apply_safe_closure_star_1(sc)); + check_stack_size(sc); + sc->curlet = make_let_slowly(sc, closure_let(sc->code)); + return (apply_unsafe_closure_star_1(sc)); +} + +static Inline s7_pointer op_safe_closure_star_a1(s7_scheme * sc, + s7_pointer code) +{ + s7_pointer val, func = opt1_lambda(code); + val = fx_call(sc, cdr(code)); + if ((is_keyword(val)) && (!sc->accept_all_keyword_arguments)) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, + wrap_string(sc, + "~A: keyword argument's value is missing: ~S in ~S", + 49), closure_name(sc, func), val, + sc->args)); + sc->curlet = update_let_with_slot(sc, closure_let(func), val); + sc->code = T_Pair(closure_body(func)); + return (func); +} + +static void op_safe_closure_star_a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer p, func; + func = op_safe_closure_star_a1(sc, code); + p = cdr(closure_args(func)); + if (is_pair(p)) { + s7_pointer x; + for (x = next_slot(let_slots(closure_let(func))); is_pair(p); + p = cdr(p), x = next_slot(x)) { + if (is_pair(car(p))) { + s7_pointer defval = cadar(p); + if (is_pair(defval)) + slot_set_value(x, cadr(defval)); + else + slot_set_value(x, defval); + } else + slot_set_value(x, sc->F); + symbol_set_local_slot(slot_symbol(x), let_id(sc->curlet), x); + } + } +} + +static void op_safe_closure_star_ka(s7_scheme * sc, s7_pointer code) +{ + s7_pointer func = opt1_lambda(code); + /* two args, but k=arg key, key has been checked. no trailing pars */ + sc->curlet = + update_let_with_slot(sc, closure_let(func), + fx_call(sc, cddr(code))); + sc->code = T_Pair(closure_body(func)); +} + +static void op_safe_closure_star_aa(s7_scheme * sc, s7_pointer code) +{ + /* here closure_arity == 2 and we have 2 args and those args' defaults are simple (no eval or lookup needed) */ + s7_pointer arg1, arg2, func = opt1_lambda(code); + + arg1 = fx_call(sc, cdr(code)); + sc->w = arg1; /* weak GC protection */ + arg2 = fx_call(sc, cddr(code)); + + if (is_keyword(arg1)) { + if (keyword_symbol(arg1) == + slot_symbol(let_slots(closure_let(func)))) { + arg1 = arg2; + arg2 = cadr(closure_args(func)); + if (is_pair(arg2)) + arg2 = (is_pair(cadr(arg2))) ? cadadr(arg2) : cadr(arg2); + else + arg2 = sc->F; + } else + if (keyword_symbol(arg1) == + slot_symbol(next_slot(let_slots(closure_let(func))))) { + arg1 = car(closure_args(func)); + if (is_pair(arg1)) + arg1 = (is_pair(cadr(arg1))) ? cadadr(arg1) : cadr(arg1); + else + arg1 = sc->F; + } else if (!sc->accept_all_keyword_arguments) + s7_error(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "~A: unknown keyword argument: ~S in ~S", 38), closure_name(sc, func), arg1, code)); /* arg1 is already the value */ + } else if ((is_keyword(arg2)) && (!sc->accept_all_keyword_arguments)) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, + wrap_string(sc, + "~A: keyword argument's value is missing: ~S in ~S", + 49), closure_name(sc, func), arg2, + code)); + sc->curlet = + update_let_with_two_slots(sc, closure_let(func), arg1, arg2); + sc->code = T_Pair(closure_body(func)); +} + +#define call_lambda_star(sc) do {sc->code = opt1_lambda(code); target = apply_safe_closure_star_1(sc); clear_list_in_use(arglist);} while (0) + +static bool op_safe_closure_star_aaa(s7_scheme * sc, s7_pointer code) +{ + s7_pointer p, arg1, arg2, arg3, func = opt1_lambda(code); + arg1 = fx_call(sc, cdr(code)); + sc->w = arg1; /* weak GC protection */ + arg2 = fx_call(sc, cddr(code)); + sc->v = arg2; + arg3 = fx_call(sc, cdddr(code)); + if ((is_keyword(arg1)) || (is_keyword(arg2)) || (is_keyword(arg3))) { + bool target; + s7_pointer arglist; + sc->args = make_safe_list(sc, 3); + arglist = sc->args; + set_car(sc->args, arg1); + set_car(cdr(sc->args), arg2); + set_car(cddr(sc->args), arg3); + call_lambda_star(sc); /* this clears list_in_use, sets target */ + return (target); + } + sc->curlet = + update_let_with_three_slots(sc, closure_let(func), arg1, arg2, + arg3); + p = T_Pair(closure_body(func)); + if (is_pair(cdr(p))) + push_stack_no_args(sc, sc->begin_op, cdr(p)); + sc->code = car(p); + return (true); +} + +static bool op_safe_closure_star_na_0(s7_scheme * sc, s7_pointer code) +{ + sc->args = sc->nil; + sc->code = opt1_lambda(code); + return (apply_safe_closure_star_1(sc)); +} + +static bool op_safe_closure_star_na_1(s7_scheme * sc, s7_pointer code) +{ + bool target; + s7_pointer arglist; + sc->args = safe_list_1(sc); + arglist = sc->args; + set_car(sc->args, fx_call(sc, cdr(code))); + call_lambda_star(sc); /* this clears list_in_use, sets target */ + return (target); +} + +static bool op_safe_closure_star_na_2(s7_scheme * sc, s7_pointer code) +{ + bool target; + s7_pointer arglist, p; + sc->args = safe_list_2(sc); + arglist = sc->args; + set_car(sc->args, fx_call(sc, cdr(code))); + p = cddr(code); + set_car(cdr(sc->args), fx_call(sc, p)); + call_lambda_star(sc); /* this clears list_in_use, sets target */ + return (target); +} + +static Inline bool op_safe_closure_star_na(s7_scheme * sc, s7_pointer code) +{ + s7_pointer old_args, p, arglist; + bool target; + sc->args = safe_list_if_possible(sc, integer(opt3_arglen(cdr(code)))); + arglist = sc->args; + for (p = sc->args, old_args = cdr(code); is_pair(p); + p = cdr(p), old_args = cdr(old_args)) + set_car(p, fx_call(sc, old_args)); + call_lambda_star(sc); /* this clears list_in_use, sets target */ + return (target); +} + +static void op_closure_star_ka(s7_scheme * sc, s7_pointer code) +{ + s7_pointer val, p, func; + val = fx_call(sc, cddr(code)); + func = opt1_lambda(code); + p = car(closure_args(func)); + sc->curlet = + make_let_with_slot(sc, closure_let(func), + (is_pair(p)) ? car(p) : p, val); + sc->code = T_Pair(closure_body(func)); +} + +static void op_closure_star_a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer val, p, func; + val = fx_call(sc, cdr(code)); + if ((is_keyword(val)) && (!sc->accept_all_keyword_arguments)) + s7_error(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, + wrap_string(sc, + "~A: keyword argument's value is missing: ~S in ~S", + 49), closure_name(sc, + opt1_lambda + (code)), val, + code)); + func = opt1_lambda(code); + p = car(closure_args(func)); + sc->curlet = + make_let_with_slot(sc, closure_let(func), + (is_pair(p)) ? car(p) : p, val); + if (closure_star_arity_to_int(sc, func) > 1) { + s7_pointer last_slot = let_slots(sc->curlet); + s7_int id = let_id(sc->curlet); + for (p = cdr(closure_args(func)); is_pair(p); p = cdr(p)) { + s7_pointer par = car(p); + if (is_pair(par)) + last_slot = add_slot_at_end(sc, id, last_slot, car(par), (is_pair(cadr(par))) ? cadadr(par) : cadr(par)); /* possible quoted list as default value */ + else + last_slot = add_slot_at_end(sc, id, last_slot, par, sc->F); + } + } + sc->code = T_Pair(closure_body(func)); +} + +static inline bool op_closure_star_na(s7_scheme * sc, s7_pointer code) +{ + /* check_stack_size(sc); */ + if (is_pair(cdr(code))) { + s7_pointer old_args, p; + sc->w = cdr(code); /* args aren't evaluated yet */ + sc->args = make_list(sc, integer(opt3_arglen(cdr(code))), sc->F); + for (p = sc->args, old_args = sc->w; is_pair(p); + p = cdr(p), old_args = cdr(old_args)) + set_car(p, fx_call(sc, old_args)); + sc->w = sc->nil; + } else + sc->args = sc->nil; + sc->code = opt1_lambda(code); + sc->curlet = make_let(sc, closure_let(sc->code)); + return (apply_unsafe_closure_star_1(sc)); +} + +static goto_t op_define1(s7_scheme * sc) +{ + /* sc->code is the symbol being defined, sc->value is its value + * if sc->value is a closure, car is of the form ((args...) body...) + * it's not possible to expand and replace macros at this point without evaluating + * the body. Just as examples, say we have a macro "mac", + * (define (hi) (call/cc (lambda (mac) (mac 1)))) + * (define (hi) (quote (mac 1))) or macroexpand etc + * (define (hi mac) (mac 1)) assuming mac here is a function passed as an arg, etc... + * the immutable constant check needs to wait until we have the actual new value because + * we want to ignore the rebinding (not raise an error) if it is the existing value. + * This happens when we reload a file that calls define-constant. + */ + if (is_multiple_value(sc->value)) /* (define x (values 1 2)) */ + eval_error(sc, "define: more than one value: ~S", 31, sc->value); + if (is_constant_symbol(sc, sc->code)) { /* (define pi 3) or (define (pi a) a) */ + s7_pointer x; + x = (is_slot(global_slot(sc->code))) ? global_slot(sc->code) : + lookup_slot_from(sc->code, sc->curlet); + /* local_slot can be free even if sc->code is immutable (local constant now defunct) */ + + if (!((is_slot(x)) && (type(sc->value) == unchecked_type(slot_value(x))) && (s7_is_equivalent(sc, sc->value, slot_value(x))))) /* if value is unchanged, just ignore this (re)definition */ + eval_error(sc, "define: ~S is immutable", 23, sc->code); /* can't use s7_is_equal because value might be NaN, etc */ + } + if (symbol_has_setter(sc->code)) { + s7_pointer x; + x = lookup_slot_from(sc->code, sc->curlet); + if ((is_slot(x)) && (slot_has_setter(x))) { + sc->value = + bind_symbol_with_setter(sc, OP_DEFINE_WITH_SETTER, + sc->code, sc->value); + if (sc->value == sc->no_value) + return (goto_apply); + /* if all goes well, OP_DEFINE_WITH_SETTER will jump to DEFINE2 */ + } + } + return (fall_through); +} + +static void set_let_file_and_line(s7_scheme * sc, s7_pointer new_let, + s7_pointer new_func) +{ + if (port_file(current_input_port(sc)) != stdin) { + /* unbound_variable will be called if *function* is encountered, and will return this info as if *function* had some meaning */ + if ((is_pair(closure_args(new_func))) && + (has_location(closure_args(new_func)))) { + let_set_file(new_let, + pair_file_number(closure_args(new_func))); + let_set_line(new_let, + pair_line_number(closure_args(new_func))); + } else if (has_location(closure_body(new_func))) { + let_set_file(new_let, + pair_file_number(closure_body(new_func))); + let_set_line(new_let, + pair_line_number(closure_body(new_func))); + } else { + s7_pointer p; + for (p = cdr(closure_body(new_func)); is_pair(p); p = cdr(p)) + if ((is_pair(car(p))) && (has_location(car(p)))) + break; + let_set_file(new_let, + (is_pair(p)) ? pair_file_number(car(p)) : + port_file_number(current_input_port(sc))); + let_set_line(new_let, + (is_pair(p)) ? pair_line_number(car(p)) : + port_line_number(current_input_port(sc))); + } + set_has_let_file(new_let); + } else { + let_set_file(new_let, 0); + let_set_line(new_let, 0); + clear_has_let_file(new_let); + } +} + +static void op_define_with_setter(s7_scheme * sc) +{ + s7_pointer code = sc->code; + if ((is_immutable(sc->curlet)) && (is_let(sc->curlet))) /* not () */ + s7_error(sc, sc->immutable_error_symbol, + set_elist_2(sc, + wrap_string(sc, + "can't define ~S: curlet is immutable", + 36), code)); + + if ((is_any_closure(sc->value)) && ((!(is_let(closure_let(sc->value)))) || (!(is_funclet(closure_let(sc->value)))))) { /* otherwise it's (define f2 f1) or something similar */ + s7_pointer new_func = sc->value, new_let; + + if (is_safe_closure_body(closure_body(new_func))) { + set_safe_closure(new_func); + if (is_very_safe_closure_body(closure_body(new_func))) + set_very_safe_closure(new_func); + } + new_let = make_funclet(sc, new_func, code, closure_let(new_func)); + + /* this should happen only if the closure* default values do not refer in any way to + * the enclosing environment (else we can accidentally shadow something that happens + * to share an argument name that is being used as a default value -- kinda dumb!). + * I think I'll check this before setting the safe_closure bit. + */ + set_let_file_and_line(sc, new_let, new_func); + /* add the newly defined thing to the current environment */ + if (is_let(sc->curlet)) { + if (let_id(sc->curlet) < symbol_id(code)) { /* we're adding a later-bound symbol to an old let (?) */ + s7_pointer slot; + sc->let_number++; /* dummy let, force symbol lookup */ + for (slot = let_slots(sc->curlet); tis_slot(slot); + slot = next_slot(slot)) + if (slot_symbol(slot) == code) { + if (is_immutable(slot)) + eval_error(sc, + "define ~S, but it is immutable", + 30, code); + slot_set_value(slot, new_func); + symbol_set_local_slot(code, sc->let_number, slot); + set_local(code); + sc->value = new_func; /* probably not needed? */ + return; + } + new_cell_no_check(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, code, new_func); + symbol_set_local_slot(code, sc->let_number, slot); + slot_set_next(slot, let_slots(sc->curlet)); + let_set_slots(sc->curlet, slot); + } else + add_slot(sc, sc->curlet, code, new_func); + set_local(code); + } else { + if ((is_slot(global_slot(code))) && + (is_immutable(global_slot(code)))) { + s7_pointer old_symbol = code, old_value = + global_value(code); + if ((type(old_value) != type(new_func)) || (!s7_is_equivalent(sc, old_value, new_func))) /* if value is unchanged, just ignore this (re)definition */ + eval_error(sc, "define ~S, but it is immutable", 30, + old_symbol); + } + s7_make_slot(sc, sc->curlet, code, new_func); + } + sc->value = new_func; /* 25-Jul-14 so define returns the value not the name */ + } else { + s7_pointer lx; + lx = symbol_to_local_slot(sc, code, sc->curlet); /* add the newly defined thing to the current environment */ + if (is_slot(lx)) { + if (is_immutable(lx)) { + s7_pointer old_symbol = code, old_value = slot_value(lx); + if ((type(old_value) != type(sc->value)) || (!s7_is_equivalent(sc, old_value, sc->value))) /* if value is unchanged, just ignore this (re)definition */ + eval_error(sc, "define ~S, but it is immutable", 30, + old_symbol); + } + slot_set_value_with_hook(lx, sc->value); + symbol_increment_ctr(code); + } else + s7_make_slot(sc, sc->curlet, code, sc->value); + if ((is_any_macro(sc->value)) && (!is_c_macro(sc->value))) { + set_pair_macro(closure_body(sc->value), code); + set_has_pair_macro(sc->value); + } + } +} + + +/* -------------------------------- eval -------------------------------- */ + +static void check_for_cyclic_code(s7_scheme * sc, s7_pointer code) +{ + if (tree_is_cyclic(sc, code)) + eval_error(sc, "attempt to evaluate a circular list: ~A", 39, + code); + resize_stack(sc); /* we've already checked that resize_stack is needed */ +} + +static void op_thunk(s7_scheme * sc) +{ + s7_pointer p = opt1_lambda(sc->code); + check_stack_size(sc); /* full-test (toward end, grows to 524288!) */ + /* this recursion check is consistent with the other unsafe closure calls, but we're probably in big trouble: + * (letrec ((a (lambda () (cons 1 (b)))) (b (lambda () (a)))) (b)) + */ + sc->curlet = make_let(sc, closure_let(p)); + p = T_Pair(closure_body(p)); + if (is_pair(cdr(p))) + push_stack_no_args(sc, sc->begin_op, cdr(p)); + sc->code = car(p); +} + +static void op_thunk_any(s7_scheme * sc) +{ + s7_pointer p = opt1_lambda(sc->code); + sc->curlet = + make_let_with_slot(sc, closure_let(p), closure_args(p), sc->nil); + sc->code = closure_body(p); +} + +static void op_safe_thunk(s7_scheme * sc) +{ /* no let needed */ + s7_pointer p = opt1_lambda(sc->code); + sc->curlet = closure_let(p); + p = T_Pair(closure_body(p)); + if (is_pair(cdr(p))) + push_stack_no_args(sc, sc->begin_op, cdr(p)); + sc->code = car(p); +} + +static void op_closure_s(s7_scheme * sc) +{ + s7_pointer p = opt1_lambda(sc->code); + check_stack_size(sc); + sc->curlet = + make_let_with_slot(sc, closure_let(p), car(closure_args(p)), + lookup(sc, opt2_sym(sc->code))); + p = T_Pair(closure_body(p)); + if (is_pair(cdr(p))) + push_stack_no_args(sc, sc->begin_op, cdr(p)); + sc->code = car(p); +} + +static inline void op_closure_s_o(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + sc->curlet = + make_let_with_slot(sc, closure_let(f), car(closure_args(f)), + lookup(sc, opt2_sym(sc->code))); + sc->code = car(closure_body(f)); +} + +static void op_safe_closure_s(s7_scheme * sc) +{ + s7_pointer p = opt1_lambda(sc->code); + sc->curlet = + update_let_with_slot(sc, closure_let(p), + lookup(sc, opt2_sym(sc->code))); + p = T_Pair(closure_body(p)); + if (is_pair(cdr(p))) + push_stack_no_args(sc, sc->begin_op, cdr(p)); + sc->code = car(p); +} + +static void op_safe_closure_s_o(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + sc->curlet = + update_let_with_slot(sc, closure_let(f), + lookup(sc, opt2_sym(sc->code))); + sc->code = car(closure_body(f)); +} + +static void op_safe_closure_p(s7_scheme * sc) +{ + check_stack_size(sc); + push_stack_no_args(sc, OP_SAFE_CLOSURE_P_1, opt1_lambda(sc->code)); + sc->code = cadr(sc->code); +} + +static void op_safe_closure_p_1(s7_scheme * sc) +{ + sc->curlet = + update_let_with_slot(sc, closure_let(sc->code), sc->value); + sc->code = T_Pair(closure_body(sc->code)); +} + +static void op_safe_closure_p_a(s7_scheme * sc) +{ + check_stack_size(sc); + push_stack_no_args(sc, OP_SAFE_CLOSURE_P_A_1, opt1_lambda(sc->code)); + sc->code = cadr(sc->code); +} + +static void op_safe_closure_p_a_1(s7_scheme * sc) +{ + sc->curlet = + update_let_with_slot(sc, closure_let(sc->code), sc->value); + sc->value = fx_call(sc, closure_body(sc->code)); +} + +static Inline void op_closure_a(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + sc->value = fx_call(sc, cdr(sc->code)); + sc->curlet = + make_let_with_slot(sc, closure_let(f), car(closure_args(f)), + sc->value); + sc->code = T_Pair(closure_body(f)); +} + +static void op_safe_closure_3s(s7_scheme * sc) +{ + s7_pointer args = cddr(sc->code), f = opt1_lambda(sc->code); + sc->curlet = + update_let_with_three_slots(sc, closure_let(f), + lookup(sc, cadr(sc->code)), lookup(sc, + car + (args)), + lookup(sc, cadr(args))); + sc->code = T_Pair(closure_body(f)); +} + +static void op_safe_closure_ssa(s7_scheme * sc) +{ /* ssa_a is hit once, but is only about 3/4% faster -- there's the fx overhead, etc */ + s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code); + sc->curlet = + update_let_with_three_slots(sc, closure_let(f), + lookup(sc, car(args)), lookup(sc, + cadr + (args)), + fx_call(sc, cddr(args))); + sc->code = T_Pair(closure_body(f)); +} + +static void op_safe_closure_saa(s7_scheme * sc) +{ + s7_pointer arg2, f = opt1_lambda(sc->code), args = cddr(sc->code); + arg2 = lookup(sc, cadr(sc->code)); /* I don't see fx_t|u here? */ + sc->code = fx_call(sc, args); + sc->curlet = + update_let_with_three_slots(sc, closure_let(f), arg2, sc->code, + fx_call(sc, cdr(args))); + sc->code = T_Pair(closure_body(f)); +} + +static void op_safe_closure_agg(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code); + sc->curlet = + update_let_with_three_slots(sc, closure_let(f), fx_call(sc, args), + fx_call(sc, cdr(args)), fx_call(sc, + cddr + (args))); + sc->code = T_Pair(closure_body(f)); +} + +static void op_closure_p(s7_scheme * sc) +{ + check_stack_size(sc); + push_stack_no_args(sc, OP_CLOSURE_P_1, opt1_lambda(sc->code)); + sc->code = cadr(sc->code); +} + +static void op_closure_p_1(s7_scheme * sc) +{ + sc->curlet = + make_let_with_slot(sc, closure_let(sc->code), + car(closure_args(sc->code)), sc->value); + sc->code = T_Pair(closure_body(sc->code)); +} + +static void op_safe_closure_a(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + sc->curlet = + update_let_with_slot(sc, closure_let(f), + fx_call(sc, cdr(sc->code))); + sc->code = T_Pair(closure_body(f)); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(sc->code); +} + +static void op_safe_closure_a_o(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + sc->curlet = + update_let_with_slot(sc, closure_let(f), + fx_call(sc, cdr(sc->code))); + sc->code = car(closure_body(f)); +} + +static void op_closure_ap(s7_scheme * sc) +{ + s7_pointer code = sc->code; + sc->args = fx_call(sc, cdr(code)); + /* (hook-push (undo-hook ind 0) (lambda (hook) (set! u0 #t))) -> # + * g_undo_hook calls s7_eval_c_string so it obviously should be declared unsafe! + */ + push_stack(sc, OP_CLOSURE_AP_1, opt1_lambda(sc->code), sc->args); + sc->code = caddr(code); +} + +static void op_closure_ap_1(s7_scheme * sc) +{ + /* sc->value is presumably the "P" argument value, "A" is sc->args->sc->code above (sc->args here is opt1_lambda(original sc->code)) */ + sc->curlet = + make_let_with_two_slots(sc, closure_let(sc->args), + car(closure_args(sc->args)), sc->code, + cadr(closure_args(sc->args)), sc->value); + sc->code = T_Pair(closure_body(sc->args)); +} + +static void op_closure_pa(s7_scheme * sc) +{ + s7_pointer code = sc->code; + sc->args = fx_call(sc, cddr(code)); + push_stack(sc, OP_CLOSURE_PA_1, sc->args, opt1_lambda(sc->code)); /* "p" can be self-call changing func locally! so pass opt1_lambda(sc->code), not sc->code */ + sc->code = cadr(code); +} + +static void op_closure_pa_1(s7_scheme * sc) +{ + sc->curlet = + make_let_with_two_slots(sc, closure_let(sc->code), + car(closure_args(sc->code)), sc->value, + cadr(closure_args(sc->code)), sc->args); + sc->code = T_Pair(closure_body(sc->code)); +} + +static void op_closure_pp(s7_scheme * sc) +{ + check_stack_size(sc); + push_stack(sc, OP_CLOSURE_PP_1, opt1_lambda(sc->code), sc->code); + sc->code = cadr(sc->code); +} + +static void op_closure_pp_1(s7_scheme * sc) +{ + push_stack(sc, OP_CLOSURE_AP_1, sc->args, sc->value); + sc->code = caddr(sc->code); +} + +static void op_safe_closure_ap(s7_scheme * sc) +{ + check_stack_size(sc); + sc->args = fx_call(sc, cdr(sc->code)); + push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->args, opt1_lambda(sc->code)); + sc->code = caddr(sc->code); +} + +static void op_safe_closure_ap_1(s7_scheme * sc) +{ + sc->curlet = + update_let_with_two_slots(sc, closure_let(sc->code), sc->args, + sc->value); + sc->code = T_Pair(closure_body(sc->code)); +} + +static void op_safe_closure_pa(s7_scheme * sc) +{ + check_stack_size(sc); + sc->args = fx_call(sc, cddr(sc->code)); + push_stack(sc, OP_SAFE_CLOSURE_PA_1, sc->args, opt1_lambda(sc->code)); + sc->code = cadr(sc->code); +} + +static void op_safe_closure_pa_1(s7_scheme * sc) +{ + sc->curlet = + update_let_with_two_slots(sc, closure_let(sc->code), sc->value, + sc->args); + sc->code = T_Pair(closure_body(sc->code)); +} + +static void op_safe_closure_pp(s7_scheme * sc) +{ + check_stack_size(sc); + push_stack(sc, OP_SAFE_CLOSURE_PP_1, opt1_lambda(sc->code), sc->code); + sc->code = cadr(sc->code); +} + +static void op_safe_closure_pp_1(s7_scheme * sc) +{ + push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->value, sc->args); + sc->code = caddr(sc->code); +} + +static void op_any_closure_3p(s7_scheme * sc) +{ + s7_pointer p = cdr(sc->code); + if (has_fx(p)) { + sc->args = fx_call(sc, p); + p = cdr(p); + if (has_fx(p)) { + sc->stack_end[0] = sc->code; /* push_stack_direct(sc, OP_ANY_CLOSURE_3P_3) here but trying to be too clever? */ + sc->stack_end[2] = sc->args; /* stack[args] == arg1 to closure) */ + sc->stack_end[3] = (s7_pointer) (OP_ANY_CLOSURE_3P_3); + sc->stack_end += 4; + stack_protected3(sc) = fx_call(sc, p); /* (i.e. stack[curlet] == arg2 of closure), fx_call might push_stack gc_protect etc, so push_stack via +4 before it */ + sc->code = cadr(p); + } else { + push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); /* arg1 == stack[args] */ + sc->code = car(p); + } + } else { + push_stack_no_args(sc, OP_ANY_CLOSURE_3P_1, sc->code); + sc->code = car(p); + } +} + +static bool closure_3p_end(s7_scheme * sc, s7_pointer p) +{ + /* sc->args == arg1, sc->value == arg2 */ + if (has_fx(p)) { + s7_pointer func = opt1_lambda(sc->code), arg2 = sc->value, arg3; + arg3 = fx_call(sc, p); + if (is_safe_closure(func)) + sc->curlet = + update_let_with_three_slots(sc, closure_let(func), + sc->args, arg2, arg3); + else { + sc->value = arg2; + sc->code = arg3; + make_let_with_three_slots(sc, func, sc->args, arg2, arg3); + } + sc->code = T_Pair(closure_body(func)); + return (true); + } + push_stack_direct(sc, OP_ANY_CLOSURE_3P_3); + stack_protected3(sc) = sc->value; /* arg2 == curlet stack loc */ + sc->code = car(p); + return (false); +} + +static bool op_any_closure_3p_1(s7_scheme * sc) +{ + s7_pointer p; + sc->args = sc->value; /* (arg1 of closure) sc->value can be clobbered by fx_call? */ + p = cddr(sc->code); + if (has_fx(p)) { + sc->value = fx_call(sc, p); + return (closure_3p_end(sc, cdr(p))); + } + push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); + sc->code = car(p); + return (false); +} + +static bool op_any_closure_3p_2(s7_scheme * sc) +{ + return (closure_3p_end(sc, cdddr(sc->code))); +} + +static void op_any_closure_3p_3(s7_scheme * sc) +{ + /* display(obj) will not work here because sc->curlet is being used as arg2 of the closure3 */ + s7_pointer func; /* incoming args (from pop_stack): sc->args, sc->curlet, and sc->value from last evaluation */ + func = opt1_lambda(sc->code); + if (is_safe_closure(func)) + sc->curlet = + update_let_with_three_slots(sc, closure_let(func), sc->args, + sc->curlet, sc->value); + else + make_let_with_three_slots(sc, func, sc->args, sc->curlet, + sc->value); + sc->code = T_Pair(closure_body(func)); +} + +static void op_any_closure_4p(s7_scheme * sc) +{ + s7_pointer p = cdr(sc->code); + check_stack_size(sc); + if (has_fx(p)) { + gc_protect_via_stack(sc, fx_call(sc, p)); + p = cdr(p); + if (has_fx(p)) { + stack_protected2(sc) = fx_call(sc, p); + p = cdr(p); + if (has_fx(p)) { + stack_protected3(sc) = fx_call(sc, p); + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4); + sc->code = cadr(p); + } else { + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); + sc->code = car(p); + } + } else { + sc->stack_end[2] = sc->unused; /* copy_stack dangling pair */ + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2); + sc->code = car(p); + } + } else { + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_1); + sc->code = car(p); + } +} + +static bool closure_4p_end(s7_scheme * sc, s7_pointer p) +{ + if (has_fx(p)) { + s7_pointer func = opt1_lambda(sc->code); + sc->args = fx_call(sc, p); + if (is_safe_closure(func)) + sc->curlet = + update_let_with_four_slots(sc, closure_let(func), + stack_protected1(sc), + stack_protected2(sc), + stack_protected3(sc), sc->args); + else + make_let_with_four_slots(sc, func, stack_protected1(sc), + stack_protected2(sc), + stack_protected3(sc), sc->args); + sc->code = T_Pair(closure_body(func)); + unstack(sc); + return (true); + } + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4); + sc->code = car(p); + return (false); +} + +static bool op_any_closure_4p_1(s7_scheme * sc) +{ + s7_pointer p = cddr(sc->code); + gc_protect_via_stack(sc, sc->value); + if (has_fx(p)) { + stack_protected2(sc) = fx_call(sc, p); + p = cdr(p); + if (has_fx(p)) { + stack_protected3(sc) = fx_call(sc, p); + return (closure_4p_end(sc, cdr(p))); + } + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); + sc->code = car(p); + } else { + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2); + sc->code = car(p); + } + return (false); +} + +static bool op_any_closure_4p_2(s7_scheme * sc) +{ + s7_pointer p = cdddr(sc->code); + stack_protected2(sc) = sc->value; + if (has_fx(p)) { + stack_protected3(sc) = fx_call(sc, p); + return (closure_4p_end(sc, cdr(p))); + } + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); + sc->code = car(p); + return (false); +} + +static bool op_any_closure_4p_3(s7_scheme * sc) +{ + stack_protected3(sc) = sc->value; + return (closure_4p_end(sc, cddddr(sc->code))); +} + +static inline void op_any_closure_4p_4(s7_scheme * sc) +{ + s7_pointer func = opt1_lambda(sc->code); + if (is_safe_closure(func)) + sc->curlet = + update_let_with_four_slots(sc, closure_let(func), + stack_protected1(sc), + stack_protected2(sc), + stack_protected3(sc), sc->value); + else + make_let_with_four_slots(sc, func, stack_protected1(sc), + stack_protected2(sc), + stack_protected3(sc), sc->value); + sc->code = T_Pair(closure_body(func)); + unstack(sc); +} + +static void op_safe_closure_ss(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + sc->curlet = + update_let_with_two_slots(sc, closure_let(f), + lookup(sc, cadr(sc->code)), lookup(sc, + opt2_sym + (sc->code))); + sc->code = T_Pair(closure_body(f)); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(sc->code); +} + +static void op_safe_closure_ss_o(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + sc->curlet = + update_let_with_two_slots(sc, closure_let(f), + lookup(sc, cadr(sc->code)), lookup(sc, + opt2_sym + (sc->code))); + sc->code = car(closure_body(f)); +} + +static inline void op_closure_ss(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + check_stack_size(sc); + sc->curlet = + make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), + lookup(sc, cadr(sc->code)), + cadr(closure_args(f)), lookup(sc, + opt2_sym + (sc->code))); + sc->code = T_Pair(closure_body(f)); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(sc->code); +} + +static inline void op_closure_ss_o(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + sc->curlet = + make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), + lookup(sc, cadr(sc->code)), + cadr(closure_args(f)), lookup(sc, + opt2_sym + (sc->code))); + sc->code = car(closure_body(f)); +} + +static void op_safe_closure_sc(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + sc->curlet = + update_let_with_two_slots(sc, closure_let(f), + lookup(sc, cadr(sc->code)), + opt2_con(sc->code)); + sc->code = T_Pair(closure_body(f)); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(sc->code); +} + +static void op_safe_closure_sc_o(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + sc->curlet = + update_let_with_two_slots(sc, closure_let(f), + lookup(sc, cadr(sc->code)), + opt2_con(sc->code)); + sc->code = car(closure_body(f)); +} + +static void op_closure_sc(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + check_stack_size(sc); + sc->curlet = + make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), + lookup(sc, cadr(sc->code)), + cadr(closure_args(f)), opt2_con(sc->code)); + sc->code = T_Pair(closure_body(f)); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(sc->code); +} + +static void op_closure_sc_o(s7_scheme * sc) +{ + s7_pointer f = opt1_lambda(sc->code); + check_stack_size(sc); + sc->curlet = + make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), + lookup(sc, cadr(sc->code)), + cadr(closure_args(f)), opt2_con(sc->code)); + sc->code = car(closure_body(f)); +} + +#define if_pair_set_up_begin(Sc) if (is_pair(cdr(Sc->code))) {check_stack_size(Sc); push_stack_no_args(Sc, Sc->begin_op, cdr(Sc->code));} Sc->code = car(Sc->code); + +static inline void op_closure_3s(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code), v1; + v1 = lookup(sc, car(args)); + args = cdr(args); + sc->code = opt1_lambda(sc->code); + make_let_with_three_slots(sc, sc->code, v1, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ + sc->code = T_Pair(closure_body(sc->code)); + if_pair_set_up_begin(sc); +} + +static void op_closure_4s(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code), v1, v2; + v1 = lookup(sc, car(args)); + args = cdr(args); + v2 = lookup(sc, car(args)); + args = cdr(args); + sc->code = opt1_lambda(sc->code); + make_let_with_four_slots(sc, sc->code, v1, v2, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ + sc->code = T_Pair(closure_body(sc->code)); + if_pair_set_up_begin(sc); +} + +static void op_safe_closure_aa(s7_scheme * sc) +{ + s7_pointer p = cdr(sc->code), f = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(p)); /* fx_call can affect sc->value, but not sc->code, I think */ + sc->curlet = + update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), + sc->code); + p = T_Pair(closure_body(f)); + /* check_stack_size(sc); *//* pretty-print if cycles=#f? */ + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(p))); + sc->code = car(p); +} + +static inline void op_safe_closure_aa_o(s7_scheme * sc) +{ + s7_pointer p = cdr(sc->code), f = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(p)); + sc->curlet = + update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), + sc->code); + sc->code = car(closure_body(f)); +} + +static void op_closure_aa(s7_scheme * sc) +{ + s7_pointer p = cdr(sc->code), f = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(p)); + sc->value = fx_call(sc, p); + sc->curlet = + make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), + sc->value, cadr(closure_args(f)), + sc->code); + p = T_Pair(closure_body(f)); + check_stack_size(sc); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(p))); + sc->code = car(p); +} + +static Inline void op_closure_aa_o(s7_scheme * sc) +{ + s7_pointer p = cdr(sc->code), f = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(p)); + sc->value = fx_call(sc, p); + sc->curlet = + make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), + sc->value, cadr(closure_args(f)), + sc->code); + sc->code = car(closure_body(f)); +} + +static inline void op_closure_fa(s7_scheme * sc) +{ + s7_pointer farg, new_clo, aarg, func, func_args, code = sc->code; + farg = opt2_pair(code); /* cdadr(code); */ + aarg = fx_call(sc, cddr(code)); + new_clo = + make_closure(sc, car(farg), cdr(farg), + T_CLOSURE | ((is_symbol(car(farg))) ? T_COPY_ARGS : + 0), CLOSURE_ARITY_NOT_SET); + func = opt1_lambda(code); /* outer func */ + func_args = closure_args(func); + sc->curlet = + make_let_with_two_slots(sc, closure_let(func), car(func_args), + new_clo, cadr(func_args), aarg); + sc->code = car(closure_body(func)); +} + +static void op_safe_closure_ns(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code), let, x; + uint64_t id; + + sc->code = opt1_lambda(sc->code); + id = ++sc->let_number; + let = closure_let(sc->code); + let_set_id(let, id); + + for (x = let_slots(let); tis_slot(x); + x = next_slot(x), args = cdr(args)) { + slot_set_value(x, lookup(sc, car(args))); + symbol_set_local_slot(slot_symbol(x), id, x); + } + set_curlet(sc, let); + sc->code = closure_body(sc->code); + if (is_pair(cdr(sc->code))) + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + sc->code = car(sc->code); +} + +static void op_safe_closure_3a(s7_scheme * sc) +{ + s7_pointer p = cdr(sc->code), f = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(p)); /* fx_call can affect sc->value, but not sc->code, I think */ + sc->args = fx_call(sc, cddr(p)); /* is sc->args safe here? */ + sc->curlet = + update_let_with_three_slots(sc, closure_let(f), fx_call(sc, p), + sc->code, sc->args); + p = closure_body(f); + if (is_pair(cdr(p))) + push_stack_no_args(sc, sc->begin_op, cdr(p)); + sc->code = car(p); +} + +static void op_safe_closure_na(s7_scheme * sc) +{ + s7_pointer args, p, let, x, z; + uint64_t id; + + sc->args = + safe_list_if_possible(sc, integer(opt3_arglen(cdr(sc->code)))); + for (args = cdr(sc->code), p = sc->args; is_pair(args); + args = cdr(args), p = cdr(p)) + set_car(p, fx_call(sc, args)); + sc->code = opt1_lambda(sc->code); + id = ++sc->let_number; + let = closure_let(sc->code); + let_set_id(let, id); + + for (x = let_slots(let), z = sc->args; tis_slot(x); + x = next_slot(x), z = cdr(z)) { + slot_set_value(x, car(z)); + symbol_set_local_slot(slot_symbol(x), id, x); + } + clear_list_in_use(sc->args); + set_curlet(sc, let); + sc->code = closure_body(sc->code); + if (is_pair(cdr(sc->code))) + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + sc->code = car(sc->code); +} + +static Inline void op_closure_ns(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code), p, e, last_slot; + s7_int id; + /* in this case, we have just lambda (not lambda*), and no dotted arglist, + * and no accessed symbols in the arglist, and we know the arglist matches the parameter list. + */ + sc->code = opt1_lambda(sc->code); + e = make_let(sc, closure_let(sc->code)); + sc->z = e; + id = let_id(e); + p = closure_args(sc->code); + add_slot_unchecked(sc, e, car(p), lookup(sc, car(args)), id); + last_slot = let_slots(e); + for (p = cdr(p), args = cdr(args); is_pair(p); + p = cdr(p), args = cdr(args)) + last_slot = add_slot_at_end(sc, id, last_slot, car(p), lookup(sc, car(args))); /* main such call in lt (fx_s is 1/2, this is 1/5 of all calls) */ + set_curlet(sc, e); + sc->z = sc->nil; + sc->code = T_Pair(closure_body(sc->code)); + if_pair_set_up_begin(sc); +} + +static void op_closure_ass(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code); + make_let_with_three_slots(sc, f, fx_call(sc, args), + lookup(sc, cadr(args)), lookup(sc, + caddr(args))); + sc->code = T_Pair(closure_body(f)); + if_pair_set_up_begin(sc); +} + +static void op_closure_aas(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code); + sc->z = fx_call(sc, args); + make_let_with_three_slots(sc, f, sc->z, fx_call(sc, cdr(args)), + lookup(sc, caddr(args))); + sc->code = T_Pair(closure_body(f)); + if_pair_set_up_begin(sc); +} + +static void op_closure_saa(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code); + sc->z = fx_call(sc, cdr(args)); + make_let_with_three_slots(sc, f, lookup(sc, car(args)), sc->z, + fx_call(sc, cddr(args))); + sc->code = T_Pair(closure_body(f)); + if_pair_set_up_begin(sc); +} + +static void op_closure_asa(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code); + sc->z = fx_call(sc, args); + make_let_with_three_slots(sc, f, sc->z, lookup(sc, cadr(args)), + fx_call(sc, cddr(args))); + sc->code = T_Pair(closure_body(f)); + if_pair_set_up_begin(sc); +} + +static void op_closure_sas(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code); + make_let_with_three_slots(sc, f, lookup(sc, car(args)), + fx_call(sc, cdr(args)), lookup(sc, + caddr(args))); + sc->code = T_Pair(closure_body(f)); + if_pair_set_up_begin(sc); +} + +static void op_closure_3a(s7_scheme * sc) +{ /* if inlined, tlist -50 */ + s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code); + gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cdr(args))); + make_let_with_three_slots(sc, f, stack_protected1(sc), + stack_protected2(sc), fx_call(sc, + cddr(args))); + unstack(sc); + sc->code = T_Pair(closure_body(f)); + if_pair_set_up_begin(sc); +} + +static void op_closure_4a(s7_scheme * sc) +{ /* sass */ + s7_pointer args = cdr(sc->code), f = opt1_lambda(sc->code); + gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cddr(args))); + args = cdr(args); + stack_protected3(sc) = fx_call(sc, args); /* [-3]=second */ + make_let_with_four_slots(sc, f, stack_protected1(sc), + stack_protected3(sc), stack_protected2(sc), + fx_call(sc, cddr(args))); + unstack(sc); + sc->code = T_Pair(closure_body(f)); + if_pair_set_up_begin(sc); +} + +static void op_closure_na(s7_scheme * sc) +{ + s7_pointer e, exprs = cdr(sc->code), pars, func = + opt1_lambda(sc->code), slot, last_slot; + s7_int id; + + e = make_let(sc, closure_let(func)); + sc->z = e; + pars = closure_args(func); + sc->value = fx_call(sc, exprs); + new_cell_no_check(sc, last_slot, T_SLOT); + slot_set_symbol_and_value(last_slot, car(pars), sc->value); + slot_set_next(last_slot, let_slots(e)); /* i.e. slot_end */ + let_set_slots(e, last_slot); + for (pars = cdr(pars), exprs = cdr(exprs); is_pair(pars); + pars = cdr(pars), exprs = cdr(exprs)) { + sc->value = fx_call(sc, exprs); /* before new_cell since it might call the GC */ + new_cell(sc, slot, T_SLOT); /* args < GC_TRIGGER checked in optimizer, but we're calling fx_call? */ + slot_set_symbol_and_value(slot, car(pars), sc->value); + /* setting up the let might use unrelated-but-same-name symbols, so wait to set the symbol ids */ + slot_set_next(slot, slot_end(sc)); + slot_set_next(last_slot, slot); + last_slot = slot; + } + set_curlet(sc, e); + sc->z = sc->nil; + let_set_id(e, ++sc->let_number); + for (id = let_id(e), slot = let_slots(e); tis_slot(slot); + slot = next_slot(slot)) { + symbol_set_local_slot(slot_symbol(slot), id, slot); + set_local(slot_symbol(slot)); + } + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static bool check_closure_any(s7_scheme * sc) +{ + /* can't use closure_is_fine -- (lambda args 1) and (lambda (name . args) 1) are both arity -1 for the internal arity checkers! */ + if ((symbol_ctr(car(sc->code)) != 1) || + (unchecked_local_value(car(sc->code)) != + opt1_lambda_unchecked(sc->code))) { + s7_pointer f; + f = lookup_unexamined(sc, car(sc->code)); + if ((f != opt1_lambda_unchecked(sc->code)) && + ((!f) || + ((typesflag(f) & (TYPE_MASK | T_SAFE_CLOSURE)) != T_CLOSURE) + || (!is_symbol(closure_args(f))))) { + sc->last_function = f; + return (false); + } + set_opt1_lambda(sc->code, f); + } + return (true); +} + +static void op_any_closure_na(s7_scheme * sc) +{ /* for (lambda a ...) ? */ + s7_pointer func, p, old_args = cdr(sc->code); /* args aren't evaluated yet */ + s7_int num_args; + func = opt1_lambda(sc->code); + num_args = integer(opt3_arglen(old_args)); + + if (num_args == 1) + sc->args = ((is_safe_closure(func)) + && (!sc->debug_or_profile)) ? set_plist_1(sc, + fx_call(sc, + old_args)) + : list_1(sc, sc->value = fx_call(sc, old_args)); + else if (num_args == 2) { + gc_protect_via_stack(sc, fx_call(sc, old_args)); /* not sc->value as GC protection! -- fx_call below can clobber it */ + sc->args = fx_call(sc, cdr(old_args)); + sc->args = ((is_safe_closure(func)) + && (!sc->debug_or_profile)) ? set_plist_2(sc, + stack_protected1 + (sc), + sc->args) : + list_2(sc, stack_protected1(sc), sc->args); + unstack(sc); + } else { + sc->args = make_list(sc, num_args, sc->F); + for (p = sc->args; is_pair(p); + p = cdr(p), old_args = cdr(old_args)) + set_car(p, fx_call(sc, old_args)); + } + sc->curlet = + make_let_with_slot(sc, closure_let(func), closure_args(func), + sc->args); + sc->code = T_Pair(closure_body(func)); +} + +/* -------- */ +#if S7_DEBUGGING +#define TC_REC_SIZE NUM_OPS +#define TC_REC_LOW_OP OP_TC_AND_A_OR_A_LA + +static void init_tc_rec(s7_scheme * sc) +{ + sc->tc_rec_calls = (int *) calloc(TC_REC_SIZE, sizeof(int)); + add_saved_pointer(sc, sc->tc_rec_calls); +} + +static s7_pointer g_report_missed_calls(s7_scheme * sc, s7_pointer args) +{ + int i; + for (i = TC_REC_LOW_OP; i < NUM_OPS; i++) + if (sc->tc_rec_calls[i] == 0) + fprintf(stderr, "%s missed\n", op_names[i]); + return (sc->F); +} + +static void tick_tc(s7_scheme * sc, int op) +{ + sc->tc_rec_calls[op]++; +} +#else +#define tick_tc(Sc, Op) +#endif + +static bool op_tc_case_la(s7_scheme * sc, s7_pointer code) +{ + /* opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */ + s7_pointer clauses = cddr(code), la_slot = + let_slots(sc->curlet), endp, selp = cdr(code); + s7_int len = integer(opt3_arglen(cdr(code))); + if (len == 3) { + while (true) { + s7_pointer selector; + selector = fx_call(sc, selp); + if (selector == opt1_any(clauses)) + endp = opt2_any(clauses); + else { + s7_pointer p = cdr(clauses); + endp = + (selector == + opt1_any(p)) ? opt2_any(p) : opt2_any(cdr(p)); + } + if (has_tc(endp)) + slot_set_value(la_slot, fx_call(sc, cdr(endp))); + else + break; + } + } else + while (true) { + s7_pointer selector, p; + selector = fx_call(sc, selp); + for (p = clauses; is_pair(cdr(p)); p = cdr(p)) + if (selector == opt1_any(p)) { + endp = opt2_any(p); + goto CASE_ALA_END; + } + endp = opt2_any(p); + CASE_ALA_END: + if (has_tc(endp)) + slot_set_value(la_slot, fx_call(sc, cdr(endp))); + else + break; + } + if (has_fx(endp)) { + sc->value = fx_call(sc, endp); + return (true); /* goto START */ + } + sc->code = endp; + return (false); /* goto BEGIN (not like op_tc_z below) */ +} + +static s7_pointer fx_tc_case_la(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_CASE_LA); + op_tc_case_la(sc, arg); + return (sc->value); +} + +static bool op_tc_z(s7_scheme * sc, s7_pointer expr) +{ + if (has_fx(expr)) { + sc->value = fx_call(sc, expr); + return (true); + } + sc->code = car(expr); + return (false); +} + +static void op_tc_and_a_or_a_la(s7_scheme * sc, s7_pointer code) +{ + s7_pointer fx_and = cdr(code), fx_or, fx_la, la_slot = + let_slots(sc->curlet); + fx_or = cdadr(fx_and); + fx_la = cdadr(fx_or); + /* cell_optimize here is slower! */ + while (true) { + s7_pointer p; + if (fx_call(sc, fx_and) == sc->F) { + sc->value = sc->F; + return; + } + p = fx_call(sc, fx_or); + if (p != sc->F) { + sc->value = p; + return; + } + slot_set_value(la_slot, fx_call(sc, fx_la)); + } +} + +static s7_pointer fx_tc_and_a_or_a_la(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_AND_A_OR_A_LA); + op_tc_and_a_or_a_la(sc, arg); + return (sc->value); +} + +static void op_tc_or_a_and_a_la(s7_scheme * sc, s7_pointer code) +{ + s7_pointer fx_and, fx_or = cdr(code), fx_la, la_slot = + let_slots(sc->curlet); + fx_and = cdadr(fx_or); + fx_la = cdadr(fx_and); + while (true) { + s7_pointer p; + p = fx_call(sc, fx_or); + if (p != sc->F) { + sc->value = p; + return; + } + if (fx_call(sc, fx_and) == sc->F) { + sc->value = sc->F; + return; + } + slot_set_value(la_slot, fx_call(sc, fx_la)); + } +} + +static s7_pointer fx_tc_or_a_and_a_la(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_OR_A_AND_A_LA); + op_tc_or_a_and_a_la(sc, arg); + return (sc->value); +} + +static void op_tc_and_a_or_a_a_la(s7_scheme * sc, s7_pointer code) +{ + s7_pointer fx_and = cdr(code), fx_or1, fx_or2, fx_la, la_slot = + let_slots(sc->curlet); + fx_or1 = cdadr(fx_and); + fx_or2 = cdr(fx_or1); + fx_la = cdadr(fx_or2); + while (true) { + s7_pointer p; + if (fx_call(sc, fx_and) == sc->F) { + sc->value = sc->F; + return; + } + p = fx_call(sc, fx_or1); + if (p != sc->F) { + sc->value = p; + return; + } + p = fx_call(sc, fx_or2); + if (p != sc->F) { + sc->value = p; + return; + } + slot_set_value(la_slot, fx_call(sc, fx_la)); + } +} + +static s7_pointer fx_tc_and_a_or_a_a_la(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_AND_A_OR_A_A_LA); + op_tc_and_a_or_a_a_la(sc, arg); + return (sc->value); +} + +static void op_tc_or_a_and_a_a_la(s7_scheme * sc, s7_pointer code) +{ + s7_pointer fx_or = cdr(code), fx_and1, fx_and2, fx_la, la_slot = + let_slots(sc->curlet); + fx_and1 = cdadr(fx_or); + fx_and2 = cdr(fx_and1); + fx_la = cdadr(fx_and2); + while (true) { + s7_pointer p; + p = fx_call(sc, fx_or); + if (p != sc->F) { + sc->value = p; + return; + } + if ((fx_call(sc, fx_and1) == sc->F) || + (fx_call(sc, fx_and2) == sc->F)) { + sc->value = sc->F; + return; + } + slot_set_value(la_slot, fx_call(sc, fx_la)); + } +} + +static s7_pointer fx_tc_or_a_and_a_a_la(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_OR_A_AND_A_A_LA); + op_tc_or_a_and_a_a_la(sc, arg); + return (sc->value); +} + +static void op_tc_or_a_a_and_a_a_la(s7_scheme * sc, s7_pointer code) +{ + s7_pointer fx_and1, fx_and2, fx_or1 = + cdr(code), fx_or2, fx_la, la_slot = let_slots(sc->curlet); + fx_or2 = cdr(fx_or1); + fx_and1 = cdadr(fx_or2); + fx_and2 = cdr(fx_and1); + fx_la = cdadr(fx_and2); + while (true) { + s7_pointer p; + p = fx_call(sc, fx_or1); + if (p != sc->F) { + sc->value = p; + return; + } + p = fx_call(sc, fx_or2); + if (p != sc->F) { + sc->value = p; + return; + } + if (fx_call(sc, fx_and1) == sc->F) { + sc->value = sc->F; + return; + } + if (fx_call(sc, fx_and2) == sc->F) { + sc->value = sc->F; + return; + } + slot_set_value(la_slot, fx_call(sc, fx_la)); + } +} + +static s7_pointer fx_tc_or_a_a_and_a_a_la(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_OR_A_A_AND_A_A_LA); + op_tc_or_a_a_and_a_a_la(sc, arg); + return (sc->value); +} + +static void op_tc_and_a_or_a_laa(s7_scheme * sc, s7_pointer code) +{ + s7_pointer fx_and = cdr(code), fx_or, fx_la, la_slot = + let_slots(sc->curlet), fx_laa, laa_slot; + fx_or = cdadr(fx_and); + fx_la = cdadr(fx_or); + fx_laa = cdr(fx_la); + laa_slot = next_slot(la_slot); + + if ((fx_proc(fx_and) == fx_not_is_null_u) + && (fx_proc(fx_or) == fx_is_null_t) && (fx_proc(fx_la) == fx_cdr_t) + && (fx_proc(fx_laa) == fx_cdr_u)) { + s7_pointer la_val = slot_value(la_slot), laa_val = + slot_value(laa_slot); + while (true) { + if (is_null(laa_val)) { + sc->value = sc->F; + return; + } + if (is_null(la_val)) { + sc->value = sc->T; + return; + } + la_val = cdr(la_val); + laa_val = cdr(laa_val); + } + } + while (true) { + s7_pointer p; + if (fx_call(sc, fx_and) == sc->F) { + sc->value = sc->F; + return; + } + p = fx_call(sc, fx_or); + if (p != sc->F) { + sc->value = p; + return; + } + sc->rec_p1 = fx_call(sc, fx_la); + slot_set_value(laa_slot, fx_call(sc, fx_laa)); + slot_set_value(la_slot, sc->rec_p1); + } +} + +static s7_pointer fx_tc_and_a_or_a_laa(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_AND_A_OR_A_LAA); + op_tc_and_a_or_a_laa(sc, arg); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static void op_tc_or_a_and_a_laa(s7_scheme * sc, s7_pointer code) +{ + s7_pointer fx_and, fx_or = cdr(code), fx_la, la_slot = + let_slots(sc->curlet), fx_laa, laa_slot; + fx_and = cdadr(fx_or); + fx_la = cdadr(fx_and); + fx_laa = cdr(fx_la); + laa_slot = next_slot(la_slot); + while (true) { + s7_pointer p; + p = fx_call(sc, fx_or); + if (p != sc->F) { + sc->value = p; + return; + } + if (fx_call(sc, fx_and) == sc->F) { + sc->value = sc->F; + return; + } + sc->rec_p1 = fx_call(sc, fx_la); + slot_set_value(laa_slot, fx_call(sc, fx_laa)); + slot_set_value(la_slot, sc->rec_p1); + } +} + +static s7_pointer fx_tc_or_a_and_a_laa(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_OR_A_AND_A_LAA); + op_tc_or_a_and_a_laa(sc, arg); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static void op_tc_or_a_and_a_a_l3a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer fx_and1, fx_and2, fx_or = + cdr(code), fx_la, fx_laa, laa_slot, fx_l3a, l3a_slot, la_slot = + let_slots(sc->curlet); + fx_and1 = opt3_pair(fx_or); /* (or_case) ? cdadr(fx_or) : cdaddr(fx_or); */ + fx_and2 = cdr(fx_and1); + fx_la = cdadr(fx_and2); + fx_laa = cdr(fx_la); + laa_slot = next_slot(la_slot); + fx_l3a = cdr(fx_laa); + l3a_slot = next_slot(laa_slot); + if ((fx_proc(fx_and1) == fx_not_a) && (fx_proc(fx_and2) == fx_not_a)) { + fx_and1 = cdar(fx_and1); + fx_and2 = cdar(fx_and2); + while (true) { + s7_pointer p; + p = fx_call(sc, fx_or); + if (p != sc->F) { + sc->value = p; + return; + } + if ((fx_call(sc, fx_and1) != sc->F) + || (fx_call(sc, fx_and2) != sc->F)) { + sc->value = sc->F; + return; + } + sc->rec_p1 = fx_call(sc, fx_la); + sc->rec_p2 = fx_call(sc, fx_laa); + slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); + slot_set_value(la_slot, sc->rec_p1); + slot_set_value(laa_slot, sc->rec_p2); + } + } + while (true) { + s7_pointer p; + p = fx_call(sc, fx_or); + if (p != sc->F) { + sc->value = p; + return; + } + if ((fx_call(sc, fx_and1) == sc->F) + || (fx_call(sc, fx_and2) == sc->F)) { + sc->value = sc->F; + return; + } + sc->rec_p1 = fx_call(sc, fx_la); + sc->rec_p2 = fx_call(sc, fx_laa); + slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); + slot_set_value(la_slot, sc->rec_p1); + slot_set_value(laa_slot, sc->rec_p2); + } +} + +static s7_pointer fx_tc_or_a_and_a_a_l3a(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_OR_A_AND_A_A_L3A); + op_tc_or_a_and_a_a_l3a(sc, arg); + sc->rec_p1 = sc->F; + sc->rec_p2 = sc->F; + return (sc->value); +} + +static bool op_tc_if_a_z_la(s7_scheme * sc, s7_pointer code, bool cond) +{ + s7_pointer if_test, if_true, la, la_slot = let_slots(sc->curlet); + if_test = (cond) ? cadr(code) : cdr(code); + if_true = (cond) ? opt1_pair(cdr(code)) : opt1_pair(if_test); + la = (cond) ? opt3_pair(cdr(code)) : opt3_pair(if_test); + if (is_t_integer(slot_value(la_slot))) { + sc->pc = 0; + if (bool_optimize(sc, if_test)) { + opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc]; + if (int_optimize(sc, la)) { + s7_pointer val; + slot_set_value(la_slot, val = + make_mutable_integer(sc, + integer(slot_value + (la_slot)))); + while (!(o->v[0].fb(o))) { + integer(val) = o1->v[0].fi(o1); + } + return (op_tc_z(sc, if_true)); + } + } + } + while (fx_call(sc, if_test) == sc->F) { + slot_set_value(la_slot, fx_call(sc, la)); + } + return (op_tc_z(sc, if_true)); +} + +static s7_pointer fx_tc_if_a_z_la(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_Z_LA); + op_tc_if_a_z_la(sc, arg, false); + return (sc->value); +} + +static s7_pointer fx_tc_cond_a_z_la(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_Z_LA); + op_tc_if_a_z_la(sc, arg, true); + return (sc->value); +} + +static bool op_tc_if_a_la_z(s7_scheme * sc, s7_pointer code, bool cond) +{ + s7_pointer if_test, if_false, la, la_slot = let_slots(sc->curlet); + if_test = (cond) ? cadr(code) : cdr(code); + if_false = (cond) ? opt1_pair(cdr(code)) : opt1_pair(if_test); + la = (cond) ? opt3_pair(cdr(code)) : opt3_pair(if_test); + if (is_t_integer(slot_value(la_slot))) { + sc->pc = 0; + if (bool_optimize(sc, if_test)) { + opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc]; + if (int_optimize(sc, la)) { + s7_pointer val; + slot_set_value(la_slot, val = + make_mutable_integer(sc, + integer(slot_value + (la_slot)))); + while (o->v[0].fb(o)) { + integer(val) = o1->v[0].fi(o1); + } + return (op_tc_z(sc, if_false)); + } + } + } + while (fx_call(sc, if_test) != sc->F) { + slot_set_value(la_slot, fx_call(sc, la)); + } + return (op_tc_z(sc, if_false)); +} + +static s7_pointer fx_tc_if_a_la_z(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_LA_Z); + op_tc_if_a_la_z(sc, arg, false); + return (sc->value); +} + +static s7_pointer fx_tc_cond_a_la_z(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_LA_Z); + op_tc_if_a_la_z(sc, arg, true); + return (sc->value); +} + +typedef enum { TC_IF, TC_COND, TC_AND } tc_choice_t; + +static bool op_tc_if_a_z_laa(s7_scheme * sc, s7_pointer code, bool z_first, + tc_choice_t cond) +{ + s7_pointer if_test, if_z, la, laa, laa_slot, la_slot = + let_slots(sc->curlet); + s7_function tf; + if (cond == TC_IF) { + if_test = cdr(code); + if_z = opt1_pair(if_test); /* if_z = (z_first) ? cdr(if_test) : cddr(if_test) */ + la = opt3_pair(if_test); /* la = (z_first) ? cdaddr(if_test) : cdadr(if_test) */ + } else { + if_test = cadr(code); + if_z = opt1_pair(cdr(code)); /* if_z = (z_first) ? cdr(if_test) : cdr(caddr(code)) */ + la = opt3_pair(cdr(code)); /* la = (z_first) ? cdr(cadaddr(code)) : cdadr(if_test) */ + } + laa = cdr(la); + laa_slot = next_slot(la_slot); +#if (!WITH_GMP) + if (!no_bool_opt(code)) { + sc->pc = 0; + if (bool_optimize(sc, if_test)) { + opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc], *o2; + int32_t start_pc = sc->pc; + if ((is_t_integer(slot_value(la_slot))) && + (is_t_integer(slot_value(laa_slot)))) { + if (int_optimize(sc, la)) { + o2 = sc->opts[sc->pc]; + if (int_optimize(sc, laa)) { + s7_pointer val1, val2; + s7_int(*fi1) (opt_info * o); + s7_int(*fi2) (opt_info * o); + bool (*fb)(opt_info * o); + slot_set_value(la_slot, val1 = + make_mutable_integer(sc, + integer + (slot_value + (la_slot)))); + slot_set_value(laa_slot, val2 = + make_mutable_integer(sc, + integer + (slot_value + (laa_slot)))); + fb = o->v[0].fb; + fi1 = o1->v[0].fi; + fi2 = o2->v[0].fi; + if ((z_first) && ((fb == opt_b_ii_sc_lt) + || (fb == opt_b_ii_sc_lt_0)) + && (fi1 == opt_i_ii_sc_sub)) { + s7_int lim = o->v[2].i, m = o1->v[2].i; + s7_pointer slot1 = o->v[1].p, slot2 = + o1->v[1].p; + while (integer(slot_value(slot1)) >= lim) { + s7_int i1 = integer(slot_value(slot2)) - m; + integer(val2) = fi2(o2); + integer(val1) = i1; + } + } else + while (fb(o) != z_first) { + s7_int i1; + i1 = fi1(o1); + integer(val2) = fi2(o2); + integer(val1) = i1; + } + return (op_tc_z(sc, if_z)); + } + } + } + + if ((is_t_real(slot_value(la_slot))) && + (is_t_real(slot_value(laa_slot)))) { + sc->pc = start_pc; + if (float_optimize(sc, la)) { + o2 = sc->opts[sc->pc]; + if (float_optimize(sc, laa)) { + s7_pointer val1, val2; + s7_double(*fd1) (opt_info * o); + s7_double(*fd2) (opt_info * o); + bool (*fb)(opt_info * o); + slot_set_value(la_slot, val1 = + s7_make_mutable_real(sc, + real(slot_value + (la_slot)))); + slot_set_value(laa_slot, val2 = + s7_make_mutable_real(sc, + real(slot_value + (laa_slot)))); + fb = o->v[0].fb; + fd1 = o1->v[0].fd; + fd2 = o2->v[0].fd; + if ((z_first) && + (fb == opt_b_dd_sc_lt) && + (fd1 == opt_d_dd_sc_sub)) { + s7_double lim = o->v[2].x, m = o1->v[2].x; + s7_pointer slot1 = o->v[1].p, slot2 = + o1->v[1].p; + while (real(slot_value(slot1)) >= lim) { + s7_double x1 = real(slot_value(slot2)) - m; + real(val2) = fd2(o2); + real(val1) = x1; + } + } else + while (fb(o) != z_first) { + s7_double x1; + x1 = fd1(o1); + real(val2) = fd2(o2); + real(val1) = x1; + } + return (op_tc_z(sc, if_z)); + } + } + } + } + set_no_bool_opt(code); + } +#endif + tf = fx_proc(if_test); + if_test = car(if_test); + if (z_first) { + if ((fx_proc(la) == fx_cdr_t) && (fx_proc(laa) == fx_subtract_u1) && (fn_proc(if_test) == g_num_eq_xi) && /* was also (fx_proc(if_test) == fx_num_eq_ui) but we cloberred if_test above */ + (is_pair(slot_value(la_slot))) && (is_t_integer(slot_value(laa_slot)))) { /* list-tail ferchrissake */ + s7_int start, end = integer(caddr(if_test)); + s7_pointer lst = slot_value(la_slot); + for (start = integer(slot_value(laa_slot)); start > end; + start--) + lst = cdr(lst); + slot_set_value(la_slot, lst); + } else + while (tf(sc, if_test) == sc->F) { + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + } + } else + while (tf(sc, if_test) != sc->F) { + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + } + return (op_tc_z(sc, if_z)); +} + +static s7_pointer fx_tc_if_a_z_laa(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_Z_LAA); + op_tc_if_a_z_laa(sc, arg, true, TC_IF); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static s7_pointer fx_tc_cond_a_z_laa(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_Z_LAA); + op_tc_if_a_z_laa(sc, arg, true, TC_COND); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static s7_pointer fx_tc_if_a_laa_z(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_LAA_Z); + op_tc_if_a_z_laa(sc, arg, false, TC_IF); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static s7_pointer fx_tc_cond_a_laa_z(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_LAA_Z); + op_tc_if_a_z_laa(sc, arg, false, TC_COND); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static void op_tc_when_laa(s7_scheme * sc, s7_pointer code) +{ + s7_pointer if_test = cadr(code), body = + cddr(code), la_call, la, laa, laa_slot, la_slot = + let_slots(sc->curlet); + s7_function tf; + tf = fx_proc(cdr(code)); + for (la_call = body; is_pair(cdr(la_call)); la_call = cdr(la_call)); + la = cdar(la_call); + laa = cdr(la); + laa_slot = next_slot(la_slot); + while (tf(sc, if_test) != sc->F) { + s7_pointer p; + for (p = body; p != la_call; p = cdr(p)) + fx_call(sc, p); + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + } + sc->value = sc->unspecified; +} + +static bool op_tc_if_a_z_l3a(s7_scheme * sc, s7_pointer code, bool z_first) +{ + s7_pointer if_test = + cdr(code), f_z, la, laa, l3a, laa_slot, l3a_slot, la_slot = + let_slots(sc->curlet); + s7_function tf; + f_z = opt1_pair(if_test); /* if_z = (z_first) ? cdr(if_test) : cddr(if_test) */ + la = opt3_pair(if_test); /* la = (z_first) ? cdaddr(if_test) : cdadr(if_test) */ + laa = cdr(la); + l3a = cdr(laa); + laa_slot = next_slot(la_slot); + l3a_slot = next_slot(laa_slot); + tf = fx_proc(if_test); + if_test = car(if_test); + while ((tf(sc, if_test) == sc->F) == z_first) { + sc->rec_p1 = fx_call(sc, la); + sc->rec_p2 = fx_call(sc, laa); + slot_set_value(l3a_slot, fx_call(sc, l3a)); + slot_set_value(laa_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } + return (op_tc_z(sc, f_z)); +} + +static s7_pointer fx_tc_if_a_z_l3a(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_Z_L3A); + op_tc_if_a_z_l3a(sc, arg, true); + sc->rec_p1 = sc->F; + sc->rec_p2 = sc->F; + return (sc->value); +} + +static s7_pointer fx_tc_if_a_l3a_z(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_L3A_Z); + op_tc_if_a_z_l3a(sc, arg, false); + sc->rec_p1 = sc->F; + sc->rec_p2 = sc->F; + return (sc->value); +} + +static bool op_tc_if_a_z_if_a_z_la(s7_scheme * sc, s7_pointer code, + bool z_first, tc_choice_t cond) +{ + s7_pointer if_test, if_true, if_false, f_test, f_z, la, endp, la_slot = + let_slots(sc->curlet); + bool tc_and = (cond == TC_AND); + if (cond != TC_COND) { + if_test = cdr(code); + if_true = (!tc_and) ? cdr(if_test) : sc->F; + if_false = (!tc_and) ? cadr(if_true) : cadr(if_test); + f_test = cdr(if_false); + f_z = (z_first) ? cdr(f_test) : cddr(f_test); + la = (z_first) ? cdaddr(f_test) : cdadr(f_test); + } else { + if_test = cadr(code); /* code: (cond (a1 z1) (a2 z2|la) (else la|z2)) */ + if_true = cdr(if_test); + if_false = caddr(code); /* (a2 z2|la) */ + f_test = if_false; + f_z = (z_first) ? cdr(f_test) : cdr(cadddr(code)); + la = (z_first) ? cdadr(cadddr(code)) : cdadr(caddr(code)); + } +#if (!WITH_GMP) + if (is_t_integer(slot_value(la_slot))) { + opt_info *o = sc->opts[0]; + sc->pc = 0; + if (bool_optimize_nw(sc, if_test)) { + opt_info *o1 = sc->opts[sc->pc]; + if (bool_optimize_nw(sc, f_test)) { + opt_info *o2 = sc->opts[sc->pc]; + if (int_optimize(sc, la)) { + s7_pointer val; + slot_set_value(la_slot, val = + make_mutable_integer(sc, + integer(slot_value + (la_slot)))); + if (tc_and) + while (true) { + if (!o->v[0].fb(o)) { + sc->value = sc->F; + return (true); + } + if (o1->v[0].fb(o1) == z_first) { + endp = f_z; + break; + } + integer(val) = o2->v[0].fi(o2); + } else + while (true) { + if (o->v[0].fb(o)) { + endp = if_true; + break; + } + if (o1->v[0].fb(o1) == z_first) { + endp = f_z; + break; + } + integer(val) = o2->v[0].fi(o2); + } + return (op_tc_z(sc, endp)); + } + } + } + } +#endif + while (true) { + if ((fx_call(sc, if_test) == sc->F) == tc_and) { + if (tc_and) { + sc->value = sc->F; + return (true); + } else { + endp = if_true; + break; + } + } + if ((fx_call(sc, f_test) == sc->F) != z_first) { + endp = f_z; + break; + } + slot_set_value(la_slot, fx_call(sc, la)); + } + return (op_tc_z(sc, endp)); +} + +static s7_pointer fx_tc_if_a_z_if_a_z_la(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LA); + op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_IF); + return (sc->value); +} + +static s7_pointer fx_tc_if_a_z_if_a_la_z(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_Z_IF_A_LA_Z); + op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_IF); + return (sc->value); +} + +static s7_pointer fx_tc_cond_a_z_a_z_la(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_Z_A_Z_LA); + op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_COND); + return (sc->value); +} + +static s7_pointer fx_tc_cond_a_z_a_la_z(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_Z_A_LA_Z); + op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_COND); + return (sc->value); +} + +static s7_pointer fx_tc_and_a_if_a_z_la(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_AND_A_IF_A_Z_LA); + op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_AND); + return (sc->value); +} + +static s7_pointer fx_tc_and_a_if_a_la_z(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_AND_A_IF_A_LA_Z); + op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_AND); + return (sc->value); +} + +static bool op_tc_if_a_z_if_a_z_laa(s7_scheme * sc, bool cond, + s7_pointer code) +{ + s7_pointer if_test, if_true, if_false, f_test, f_true, la, laa, + laa_slot, endp, slot1, la_slot = let_slots(sc->curlet); + if_test = (cond) ? cadr(code) : cdr(code); + if_true = cdr(if_test); + if (!cond) + if_false = cadr(if_true); + f_test = (cond) ? caddr(code) : cdr(if_false); + f_true = cdr(f_test); + la = (cond) ? opt3_pair(code) : cdadr(f_true); /* cdadr(cadddr(code)) */ + laa = cdr(la); + laa_slot = next_slot(la_slot); + slot1 = + (fx_proc(if_test) == + fx_is_null_t) ? la_slot : ((fx_proc(if_test) == + fx_is_null_u) ? laa_slot : NULL); + if (slot1) { + if ((slot1 == laa_slot) && (fx_proc(f_test) == fx_is_null_t) + && (fx_proc(la) == fx_cdr_t) && (fx_proc(laa) == fx_cdr_u) + && (s7_is_boolean(car(if_true))) + && (s7_is_boolean(car(f_true)))) { + s7_pointer la_val = slot_value(la_slot), laa_val = + slot_value(laa_slot); + while (true) { + if (is_null(laa_val)) { + sc->value = car(if_true); + return (true); + } + if (is_null(la_val)) { + sc->value = car(f_true); + return (true); + } + la_val = cdr(la_val); + laa_val = cdr(laa_val); + } + } + while (true) { + if (is_null(slot_value(slot1))) { + endp = if_true; + break; + } + if (fx_call(sc, f_test) != sc->F) { + endp = f_true; + break; + } + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + } + } else + while (true) { + if (fx_call(sc, if_test) != sc->F) { + endp = if_true; + break; + } + if (fx_call(sc, f_test) != sc->F) { + endp = f_true; + break; + } + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + } + return (op_tc_z(sc, endp)); +} + +static s7_pointer fx_tc_if_a_z_if_a_z_laa(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LAA); + op_tc_if_a_z_if_a_z_laa(sc, false, arg); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static s7_pointer fx_tc_cond_a_z_a_z_laa(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_Z_A_Z_LAA); + op_tc_if_a_z_if_a_z_laa(sc, true, arg); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static bool op_tc_if_a_z_if_a_laa_z(s7_scheme * sc, bool cond, + s7_pointer code) +{ + s7_pointer if_test, if_true, if_false, f_test, f_true, f_false, la, + laa, laa_slot, endp, la_slot = let_slots(sc->curlet); + if_test = (cond) ? cadr(code) : cdr(code); + if_true = cdr(if_test); + if (!cond) + if_false = cadr(if_true); + f_test = (cond) ? caddr(code) : cdr(if_false); + f_true = cdr(f_test); + f_false = (cond) ? cdr(cadddr(code)) : cdr(f_true); + la = (cond) ? opt3_pair(code) : cdar(f_true); /* cdadr(caddr(code)) */ + laa = cdr(la); + laa_slot = next_slot(la_slot); + while (true) { + if (fx_call(sc, if_test) != sc->F) { + endp = if_true; + break; + } + if (fx_call(sc, f_test) == sc->F) { + endp = f_false; + break; + } + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + } + return (op_tc_z(sc, endp)); +} + +static s7_pointer fx_tc_if_a_z_if_a_laa_z(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_Z_IF_A_LAA_Z); + op_tc_if_a_z_if_a_laa_z(sc, false, arg); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static s7_pointer fx_tc_cond_a_z_a_laa_z(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_Z_A_LAA_Z); + op_tc_if_a_z_if_a_laa_z(sc, true, arg); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static bool op_tc_if_a_z_if_a_l3a_l3a(s7_scheme * sc, s7_pointer code) +{ + s7_pointer if_test = + cdr(code), if_true, if_false, f_test, f_true, f_false, la1, la2, + laa1, laa2, laa_slot, l3a1, l3a2, l3a_slot, endp, la_slot = + let_slots(sc->curlet); + if_true = cdr(if_test); + if_false = cadr(if_true); + f_test = cdr(if_false); + f_true = cdr(f_test); + f_false = cdr(f_true); + la1 = cdar(f_true); + la2 = cdar(f_false); + laa1 = cdr(la1); + laa2 = cdr(la2); + laa_slot = next_slot(la_slot); + l3a1 = cdr(laa1); + l3a2 = cdr(laa2); + l3a_slot = next_slot(laa_slot); + while (true) { + if (fx_call(sc, if_test) != sc->F) { + endp = if_true; + break; + } + if (fx_call(sc, f_test) != sc->F) { + sc->rec_p1 = fx_call(sc, la1); + sc->rec_p2 = fx_call(sc, laa1); + slot_set_value(l3a_slot, fx_call(sc, l3a1)); + } else { + sc->rec_p1 = fx_call(sc, la2); + sc->rec_p2 = fx_call(sc, laa2); + slot_set_value(l3a_slot, fx_call(sc, l3a2)); + } + slot_set_value(laa_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } + return (op_tc_z(sc, endp)); +} + +static s7_pointer fx_tc_if_a_z_if_a_l3a_l3a(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_Z_IF_A_L3A_L3A); + op_tc_if_a_z_if_a_l3a_l3a(sc, arg); + sc->rec_p1 = sc->F; + sc->rec_p2 = sc->F; + return (sc->value); +} + +static bool op_tc_let_if_a_z_la(s7_scheme * sc, s7_pointer code) +{ + s7_pointer body = + caddr(code), if_test, if_true, if_false, la, la_slot, let_slot, + let_var = caadr(code), outer_let = sc->curlet, inner_let; + sc->curlet = + make_let_with_slot(sc, sc->curlet, car(let_var), + fx_call(sc, cdr(let_var))); + inner_let = sc->curlet; + s7_gc_protect_via_stack(sc, inner_let); + let_slot = let_slots(sc->curlet); + let_var = cdr(let_var); + if_test = cdr(body); + if_true = cddr(body); + if_false = cadddr(body); + la = cdr(if_false); + la_slot = let_slots(outer_let); + while (fx_call(sc, if_test) == sc->F) { + slot_set_value(la_slot, fx_call(sc, la)); + set_curlet(sc, outer_let); + slot_set_value(let_slot, fx_call(sc, let_var)); + set_curlet(sc, inner_let); + } + unstack(sc); + if (!op_tc_z(sc, if_true)) + return (false); + free_cell(sc, let_slots(inner_let)); + free_cell(sc, inner_let); + return (true); +} + +static s7_pointer fx_tc_let_if_a_z_la(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_LET_IF_A_Z_LA); + op_tc_let_if_a_z_la(sc, arg); + return (sc->value); +} + +static bool op_tc_let_if_a_z_laa(s7_scheme * sc, s7_pointer code) +{ + s7_pointer body = + caddr(code), if_test, if_true, if_false, la, la_slot, let_slot, + laa, laa_slot, let_var = caadr(code), outer_let = + sc->curlet, inner_let; + sc->curlet = + make_let_with_slot(sc, sc->curlet, car(let_var), + fx_call(sc, cdr(let_var))); + inner_let = sc->curlet; + s7_gc_protect_via_stack(sc, inner_let); + let_slot = let_slots(sc->curlet); + let_var = cdr(let_var); + if_test = cdr(body); + if_true = cddr(body); + if_false = cadddr(body); + la = cdr(if_false); + la_slot = let_slots(outer_let); + laa = cddr(if_false); + laa_slot = next_slot(la_slot); +#if (!WITH_GMP) + if (!no_bool_opt(code)) { + sc->pc = 0; + if (bool_optimize(sc, if_test)) { + opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc], *o2, *o3; + if ((is_t_integer(slot_value(la_slot))) && + (is_t_integer(slot_value(laa_slot)))) { + if (int_optimize(sc, la)) { + o2 = sc->opts[sc->pc]; + if (int_optimize(sc, laa)) { + o3 = sc->opts[sc->pc]; + set_curlet(sc, outer_let); + if (int_optimize(sc, let_var)) { + s7_pointer val1, val2, val3; + set_curlet(sc, inner_let); + slot_set_value(la_slot, val1 = + make_mutable_integer(sc, + integer + (slot_value + (la_slot)))); + slot_set_value(laa_slot, val2 = + make_mutable_integer(sc, + integer + (slot_value + (laa_slot)))); + slot_set_value(let_slot, val3 = + make_mutable_integer(sc, + integer + (slot_value + (let_slot)))); + while (!(o->v[0].fb(o))) { + s7_int i1; + i1 = o1->v[0].fi(o1); + integer(val2) = o2->v[0].fi(o2); + integer(val1) = i1; + integer(val3) = o3->v[0].fi(o3); + } + unstack(sc); + if (!op_tc_z(sc, if_true)) /* sc->inner_let in effect here since it was the last set above */ + return (false); + free_cell(sc, let_slots(inner_let)); + free_cell(sc, inner_let); + return (true); + } + } + } + } + } + set_no_bool_opt(code); + } +#endif + while (fx_call(sc, if_test) == sc->F) { + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + set_curlet(sc, outer_let); + slot_set_value(let_slot, fx_call(sc, let_var)); + set_curlet(sc, inner_let); + } + unstack(sc); + if (!op_tc_z(sc, if_true)) + return (false); + free_cell(sc, let_slots(inner_let)); + free_cell(sc, inner_let); + return (true); +} + +static s7_pointer fx_tc_let_if_a_z_laa(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_LET_IF_A_Z_LAA); + op_tc_let_if_a_z_laa(sc, arg); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static void op_tc_let_when_laa(s7_scheme * sc, bool when, s7_pointer code) +{ + s7_pointer p, body = + caddr(code), if_test, if_true, la, let_slot, laa, let_var = + caadr(code), outer_let = sc->curlet, inner_let; + sc->curlet = + make_let_with_slot(sc, sc->curlet, car(let_var), + fx_call(sc, cdr(let_var))); + inner_let = sc->curlet; + s7_gc_protect_via_stack(sc, inner_let); + let_slot = let_slots(sc->curlet); + let_var = cdr(let_var); + if_test = cdr(body); + if_true = cddr(body); + for (p = if_true; is_pair(cdr(p)); p = cdr(p)); + la = cdar(p); + laa = cddar(p); + if ((car(la) == slot_symbol(let_slots(outer_let))) && + (car(laa) == slot_symbol(next_slot(let_slots(outer_let))))) { + if ((cdr(if_true) == p) && (!when)) { + s7_pointer a1, a2; + a1 = slot_value(let_slots(outer_let)); + a2 = slot_value(next_slot(let_slots(outer_let))); + if ((is_input_port(a1)) && (is_output_port(a2)) + && (is_string_port(a1)) && (is_file_port(a2)) + && (!port_is_closed(a1)) && (!port_is_closed(a2)) + && (fx_proc(if_true) == fx_c_tU_direct) + && (fx_proc(let_var) == fx_c_t_direct) + && (((s7_p_pp_t) opt3_direct(cdar(if_true))) == + write_char_p_pp) + && (((s7_p_p_t) opt2_direct(cdar(let_var))) == + read_char_p_p) && (fx_proc(if_test) == fx_is_eof_t)) { + int32_t c; + a1 = slot_value(let_slots(outer_let)); + a2 = slot_value(next_slot(let_slots(outer_let))); + c = (int32_t) + s7_character(slot_value(let_slots(inner_let))); + while (c != EOF) { + inline_file_write_char(sc, (uint8_t) c, a2); + c = string_read_char(sc, a1); + } + } else + while (fx_call(sc, if_test) == sc->F) { + fx_call(sc, if_true); + set_curlet(sc, outer_let); + slot_set_value(let_slot, fx_call(sc, let_var)); + set_curlet(sc, inner_let); + } + } else + while (true) { + p = fx_call(sc, if_test); + if (when) { + if (p == sc->F) + break; + } else { + if (p != sc->F) + break; + } + for (p = if_true; is_pair(cdr(p)); p = cdr(p)) + fx_call(sc, p); + set_curlet(sc, outer_let); + slot_set_value(let_slot, fx_call(sc, let_var)); + set_curlet(sc, inner_let); + } + } else { + s7_pointer laa_slot, la_slot = let_slots(outer_let); + laa_slot = next_slot(la_slot); + while (true) { + p = fx_call(sc, if_test); + if (when) { + if (p == sc->F) + break; + } else { + if (p != sc->F) + break; + } + for (p = if_true; is_pair(cdr(p)); p = cdr(p)) + fx_call(sc, p); + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + set_curlet(sc, outer_let); + slot_set_value(let_slot, fx_call(sc, let_var)); + set_curlet(sc, inner_let); + } + } + unstack(sc); + free_cell(sc, let_slots(inner_let)); + free_cell(sc, inner_let); + sc->value = sc->unspecified; +} + +static s7_pointer fx_tc_let_when_laa(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_LET_WHEN_LAA); + op_tc_let_when_laa(sc, true, arg); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static s7_pointer fx_tc_let_unless_laa(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_LET_WHEN_LAA); + op_tc_let_when_laa(sc, false, arg); + sc->rec_p1 = sc->F; + return (sc->value); +} + +static bool op_tc_if_a_z_let_if_a_z_laa(s7_scheme * sc, s7_pointer code) +{ + s7_pointer if1_test = + cdr(code), if1_true, if2, if2_test, if2_true, la, laa, laa_slot, + endp, let_expr, let_vars, inner_let, outer_let = + sc->curlet, slot, var, la_slot = let_slots(sc->curlet); + if1_true = cdr(if1_test); /* cddr(code) */ + let_expr = cadr(if1_true); /* cadddr(code) */ + let_vars = cadr(let_expr); + if2 = caddr(let_expr); + if2_test = cdr(if2); + if2_true = cdr(if2_test); /* cddr(if2) */ + la = cdadr(if2_true); /* cdr(cadddr(if2)) */ + laa = cdr(la); + laa_slot = next_slot(la_slot); + inner_let = make_let(sc, sc->curlet); + s7_gc_protect_via_stack(sc, inner_let); + slot = make_slot(sc, caar(let_vars), sc->F); + slot_set_next(slot, slot_end(sc)); + let_set_slots(inner_let, slot); + symbol_set_local_slot_unincremented(caar(let_vars), let_id(inner_let), + slot); + for (var = cdr(let_vars); is_pair(var); var = cdr(var)) + slot = + add_slot_at_end(sc, let_id(inner_let), slot, caar(var), sc->F); + while (true) { + if (fx_call(sc, if1_test) != sc->F) { + endp = if1_true; + break; + } + slot = let_slots(inner_let); + slot_set_value(slot, fx_call(sc, cdar(let_vars))); + set_curlet(sc, inner_let); + for (var = cdr(let_vars), slot = next_slot(slot); is_pair(var); + var = cdr(var), slot = next_slot(slot)) + slot_set_value(slot, fx_call(sc, cdar(var))); + + if (fx_call(sc, if2_test) != sc->F) { + endp = if2_true; + break; + } + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + set_curlet(sc, outer_let); + } + unstack(sc); + if (!op_tc_z(sc, endp)) /* might refer to inner_let slots */ + return (false); + free_cell(sc, let_slots(inner_let)); /* true = has_fx, so we should be done with the let */ + free_cell(sc, inner_let); + return (true); +} + +static bool op_tc_let_cond(s7_scheme * sc, s7_pointer code) +{ + s7_pointer outer_let = sc->curlet, inner_let, let_var = + caadr(code), let_slot, cond_body, slots, result; + s7_function letf; + bool read_case; + /* code here == body in check_tc */ + sc->curlet = + make_let_with_slot(sc, sc->curlet, car(let_var), + fx_call(sc, cdr(let_var))); + inner_let = sc->curlet; + s7_gc_protect_via_stack(sc, inner_let); + let_slot = let_slots(sc->curlet); + let_var = cdr(let_var); + letf = fx_proc(let_var); + let_var = car(let_var); + if ((letf == fx_c_s_direct) && /* an experiment */ + (symbol_id(cadr(let_var)) != let_id(outer_let))) { /* i.e. not an argument to the recursive function, and not set! (safe closure body) */ + letf = (s7_p_p_t) opt2_direct(cdr(let_var)); + let_var = lookup(sc, cadr(let_var)); + } + cond_body = cdaddr(code); + slots = let_slots(outer_let); + /* in the named let no-var case slots may contain the let name (it's the funclet) */ + + if (integer(opt3_arglen(cdr(code))) == 0) /* (loop) etc -- no args */ + while (true) { + s7_pointer p; + for (p = cond_body; is_pair(p); p = cdr(p)) + if (fx_call(sc, car(p)) != sc->F) { + result = cdar(p); + if (has_tc(result)) { + set_curlet(sc, outer_let); + slot_set_value(let_slot, letf(sc, let_var)); + set_curlet(sc, inner_let); + break; + } else + goto TC_LET_COND_DONE; + } + } + if (integer(opt3_arglen(cdr(code))) == 1) + while (true) { + s7_pointer p; + for (p = cond_body; is_pair(p); p = cdr(p)) + if (fx_call(sc, car(p)) != sc->F) { + result = cdar(p); + if (has_tc(result)) { + slot_set_value(slots, fx_call(sc, cdar(result))); /* arg to recursion */ + set_curlet(sc, outer_let); + slot_set_value(let_slot, letf(sc, let_var)); /* inner let var */ + set_curlet(sc, inner_let); + break; + } else + goto TC_LET_COND_DONE; + } + } + + let_set_has_pending_value(outer_let); + read_case = ((letf == read_char_p_p) && (is_input_port(let_var)) + && (is_string_port(let_var)) + && (!port_is_closed(let_var))); + while (true) { + s7_pointer p; + for (p = cond_body; is_pair(p); p = cdr(p)) + if (fx_call(sc, car(p)) != sc->F) { + result = cdar(p); + if (has_tc(result)) { + s7_pointer slot, arg; + for (slot = slots, arg = cdar(result); is_pair(arg); + slot = next_slot(slot), arg = cdr(arg)) + slot_simply_set_pending_value(slot, + fx_call(sc, arg)); + for (slot = slots; tis_slot(slot); slot = next_slot(slot)) /* using two swapping lets instead is slightly slower */ + slot_set_value(slot, slot_pending_value(slot)); + + if (read_case) + slot_set_value(let_slot, + chars[string_read_char + (sc, let_var)]); + else { + set_curlet(sc, outer_let); + slot_set_value(let_slot, letf(sc, let_var)); + set_curlet(sc, inner_let); + } + break; + } else + goto TC_LET_COND_DONE; + } + } + let_clear_has_pending_value(outer_let); + + TC_LET_COND_DONE: + unstack(sc); + if (has_fx(result)) { + sc->value = fx_call(sc, result); + free_cell(sc, let_slots(inner_let)); + free_cell(sc, inner_let); + return (true); + } + sc->code = car(result); + return (false); +} + +static s7_pointer fx_tc_let_cond(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_LET_COND); + op_tc_let_cond(sc, arg); + return (sc->value); +} + +static bool op_tc_cond_a_z_a_laa_laa(s7_scheme * sc, s7_pointer code) +{ + s7_pointer c1 = cadr(code), c2 = + caddr(code), c3, la1, la2, laa1, laa2, laa_slot, la_slot = + let_slots(sc->curlet); + la1 = cdadr(c2); + laa1 = cddadr(c2); + c3 = opt3_pair(code); /* cadr(cadddr(code)) = cadr(else_clause) */ + la2 = cdr(c3); + laa2 = cddr(c3); + laa_slot = next_slot(la_slot); + while (true) { + if (fx_call(sc, c1) != sc->F) { + c1 = cdr(c1); + break; + } + if (fx_call(sc, c2) != sc->F) { + sc->rec_p1 = fx_call(sc, la1); + slot_set_value(laa_slot, fx_call(sc, laa1)); + } else { + sc->rec_p1 = fx_call(sc, la2); + slot_set_value(laa_slot, fx_call(sc, laa2)); + } + slot_set_value(la_slot, sc->rec_p1); + } + return (op_tc_z(sc, c1)); +} + +static s7_pointer fx_tc_cond_a_z_a_laa_laa(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_COND_A_Z_A_LAA_LAA); + op_tc_cond_a_z_a_laa_laa(sc, arg); + sc->rec_p1 = sc->F; + return (sc->value); +} + + +#define RECUR_INITIAL_STACK_SIZE 1024 + +static void recur_resize(s7_scheme * sc) +{ + s7_pointer stack; + block_t *ob, *nb; + stack = sc->rec_stack; + vector_length(stack) = sc->rec_len * 2; + ob = vector_block(stack); + nb = reallocate(sc, ob, vector_length(stack) * sizeof(s7_pointer)); + block_info(nb) = NULL; + vector_block(stack) = nb; + vector_elements(stack) = (s7_pointer *) block_data(nb); /* GC looks only at elements within sc->rec_loc */ + sc->rec_len = vector_length(stack); + sc->rec_els = vector_elements(stack); +} + +static inline void recur_push(s7_scheme * sc, s7_pointer value) +{ + if (sc->rec_loc == sc->rec_len) + recur_resize(sc); + sc->rec_els[sc->rec_loc] = value; + sc->rec_loc++; +} + +static inline void recur_push_unchecked(s7_scheme * sc, s7_pointer value) +{ + sc->rec_els[sc->rec_loc++] = value; +} + +static s7_pointer recur_pop(s7_scheme * sc) +{ + return (sc->rec_els[--sc->rec_loc]); +} + +static s7_pointer recur_ref(s7_scheme * sc, s7_int loc) +{ + return (sc->rec_els[sc->rec_loc - loc]); +} + +static s7_pointer recur_pop2(s7_scheme * sc) +{ + sc->rec_loc -= 2; + return (sc->rec_els[sc->rec_loc + 1]); +} + +static s7_pointer recur_swap(s7_scheme * sc, s7_pointer value) +{ + s7_pointer res; + res = sc->rec_els[sc->rec_loc - 1]; + sc->rec_els[sc->rec_loc - 1] = value; + return (res); +} + +static s7_pointer recur_make_stack(s7_scheme * sc) +{ + if (!sc->rec_stack) { + sc->rec_stack = make_simple_vector(sc, RECUR_INITIAL_STACK_SIZE); + sc->rec_els = vector_elements(sc->rec_stack); + sc->rec_len = RECUR_INITIAL_STACK_SIZE; + } + sc->rec_loc = 0; + return (sc->rec_stack); +} + +static void rec_set_test(s7_scheme * sc, s7_pointer p) +{ + sc->rec_testp = p; + sc->rec_testf = fx_proc(sc->rec_testp); + sc->rec_testp = car(sc->rec_testp); +} + +static void rec_set_res(s7_scheme * sc, s7_pointer p) +{ + sc->rec_resp = p; + sc->rec_resf = fx_proc(sc->rec_resp); + sc->rec_resp = car(sc->rec_resp); +} + +static void rec_set_f1(s7_scheme * sc, s7_pointer p) +{ + sc->rec_f1p = p; + sc->rec_f1f = fx_proc(sc->rec_f1p); + sc->rec_f1p = car(sc->rec_f1p); +} + +static void rec_set_f2(s7_scheme * sc, s7_pointer p) +{ + sc->rec_f2p = p; + sc->rec_f2f = fx_proc(sc->rec_f2p); + sc->rec_f2p = car(sc->rec_f2p); +} + +static void rec_set_f3(s7_scheme * sc, s7_pointer p) +{ + sc->rec_f3p = p; + sc->rec_f3f = fx_proc(sc->rec_f3p); + sc->rec_f3p = car(sc->rec_f3p); +} + +static void rec_set_f4(s7_scheme * sc, s7_pointer p) +{ + sc->rec_f4p = p; + sc->rec_f4f = fx_proc(sc->rec_f4p); + sc->rec_f4p = car(sc->rec_f4p); +} + +static void rec_set_f5(s7_scheme * sc, s7_pointer p) +{ + sc->rec_f5p = p; + sc->rec_f5f = fx_proc(sc->rec_f5p); + sc->rec_f5p = car(sc->rec_f5p); +} + +static void rec_set_f6(s7_scheme * sc, s7_pointer p) +{ + sc->rec_f6p = p; + sc->rec_f6f = fx_proc(sc->rec_f6p); + sc->rec_f6p = car(sc->rec_f6p); +} + +/* -------- if_a_a_opa_laq and if_a_opa_laq_a -------- */ +typedef enum { OPT_PTR, OPT_INT, OPT_DBL, OPT_INT_0 } opt_pid_t; + +static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme * sc, bool a_op, + bool la_op, s7_pointer code) +{ + s7_pointer caller = opt3_pair(code); /* false_p in check_recur */ +#if (!WITH_GMP) + s7_pointer c_op; + c_op = car(caller); + if ((is_symbol(c_op)) && + ((is_global(c_op)) || + ((is_slot(global_slot(c_op))) && + (lookup_slot_from(c_op, sc->curlet) == global_slot(c_op))))) { + s7_pointer s_func = global_value(c_op), slot = + let_slots(sc->curlet); + if (is_c_function(s_func)) { + sc->pc = 0; + sc->rec_test_o = sc->opts[0]; + if (bool_optimize(sc, cdr(code))) { + int32_t start_pc = sc->pc; + sc->rec_result_o = sc->opts[start_pc]; + if (is_t_integer(slot_value(slot))) { + sc->rec_i_ii_f = s7_i_ii_function(s_func); + if ((sc->rec_i_ii_f) && + (int_optimize + (sc, (a_op) ? cddr(code) : cdddr(code)))) { + sc->rec_a1_o = sc->opts[sc->pc]; + if (int_optimize(sc, (la_op) ? cdr(caller) : cddr(caller))) { /* cdadr? */ + sc->rec_a2_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(opt3_pair(caller)))) { + sc->rec_val1 = + make_mutable_integer(sc, + integer(slot_value + (slot))); + slot_set_value(slot, sc->rec_val1); + return (OPT_INT); + } + } + } + } + } + } + } +#endif + rec_set_test(sc, cdr(code)); + rec_set_res(sc, (a_op) ? cddr(code) : cdddr(code)); + rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller)); + rec_set_f2(sc, cdr(opt3_pair(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); + return (OPT_PTR); +} + +static s7_int oprec_i_if_a_a_opa_laq(s7_scheme * sc) +{ + s7_int i1; + if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) + return (sc->rec_result_o->v[0].fi(sc->rec_result_o)); + i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); + integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); + return (sc->rec_i_ii_f(i1, oprec_i_if_a_a_opa_laq(sc))); +} + +static s7_int oprec_i_if_a_opa_laq_a(s7_scheme * sc) +{ + s7_int i1; + if (!sc->rec_test_o->v[0].fb(sc->rec_test_o)) + return (sc->rec_result_o->v[0].fi(sc->rec_result_o)); + i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); + integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); + return (sc->rec_i_ii_f(i1, oprec_i_if_a_opa_laq_a(sc))); +} + +static s7_pointer oprec_if_a_a_opa_laq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); + + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); + else { + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); + set_car(sc->t2_2, oprec_if_a_a_opa_laq(sc)); + set_car(sc->t2_1, recur_pop(sc)); + set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); + } + set_car(sc->t2_1, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer oprec_if_a_a_opla_aq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); + set_car(sc->t2_1, oprec_if_a_a_opla_aq(sc)); + set_car(sc->t2_2, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer oprec_if_a_opa_laq_a(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) == sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); + + if (sc->rec_testf(sc, sc->rec_testp) == sc->F) + set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); + else { + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); + set_car(sc->t2_2, oprec_if_a_opa_laq_a(sc)); + set_car(sc->t2_1, recur_pop(sc)); + set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); + } + set_car(sc->t2_1, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer oprec_if_a_opla_aq_a(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) == sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); + set_car(sc->t2_1, oprec_if_a_opla_aq_a(sc)); + set_car(sc->t2_2, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static void wrap_recur_if_a_a_opa_laq(s7_scheme * sc, bool a_op, + bool la_op) +{ + opt_pid_t choice; + tick_tc(sc, sc->cur_op); + choice = opinit_if_a_a_opa_laq(sc, a_op, la_op, sc->code); + if (choice == OPT_INT) + sc->value = + make_integer(sc, + (a_op) ? oprec_i_if_a_a_opa_laq(sc) : + oprec_i_if_a_opa_laq_a(sc)); + else { + sc->rec_stack = recur_make_stack(sc); + if (a_op) + sc->value = + (la_op) ? oprec_if_a_a_opa_laq(sc) : + oprec_if_a_a_opla_aq(sc); + else + sc->value = + (la_op) ? oprec_if_a_opa_laq_a(sc) : + oprec_if_a_opla_aq_a(sc); + sc->rec_loc = 0; + } +} + +static s7_pointer fx_recur_if_a_a_opa_laq(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_RECUR_IF_A_A_opA_LAq); + if (opinit_if_a_a_opa_laq(sc, true, true, arg) == OPT_INT) + sc->value = make_integer(sc, oprec_i_if_a_a_opa_laq(sc)); + else { + sc->rec_stack = recur_make_stack(sc); + sc->value = oprec_if_a_a_opa_laq(sc); + sc->rec_loc = 0; + } + return (sc->value); +} + +static s7_pointer fx_recur_if_a_opa_laq_a(s7_scheme * sc, s7_pointer arg) +{ + tick_tc(sc, OP_RECUR_IF_A_opA_LAq_A); + if (opinit_if_a_a_opa_laq(sc, false, true, arg) == OPT_INT) + sc->value = make_integer(sc, oprec_i_if_a_opa_laq_a(sc)); + else { + sc->rec_stack = recur_make_stack(sc); + sc->value = oprec_if_a_opa_laq_a(sc); + sc->rec_loc = 0; + } + return (sc->value); +} + +/* -------- cond_a_a_opa_laq -------- */ +static void opinit_cond_a_a_opa_laq(s7_scheme * sc) +{ + s7_pointer caller = opt3_pair(sc->code); + rec_set_test(sc, cadr(sc->code)); + rec_set_res(sc, cdadr(sc->code)); + rec_set_f1(sc, cdr(caller)); + rec_set_f2(sc, cdr(opt3_pair(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); +} + +static s7_pointer op_recur_cond_a_a_opa_laq(s7_scheme * sc) +{ + opinit_cond_a_a_opa_laq(sc); + return (oprec_if_a_a_opa_laq(sc)); +} + +/* -------- if_a_a_opa_laaq and if_a_opa_laaq_a and cond_a_a_opa_laaq -------- */ +enum { IF1A_LA2, IF2A_LA2, COND2A_LA2 }; + +static void opinit_if_a_a_opa_laaq(s7_scheme * sc, int32_t a_op) +{ + s7_pointer caller = opt3_pair(sc->code); + rec_set_test(sc, + (a_op == COND2A_LA2) ? cadr(sc->code) : cdr(sc->code)); + rec_set_res(sc, + (a_op == + IF2A_LA2) ? cddr(sc->code) : ((a_op == + IF1A_LA2) ? cdddr(sc->code) + : cdadr(sc->code))); + rec_set_f1(sc, cdr(caller)); + rec_set_f2(sc, cdr(opt3_pair(caller))); + rec_set_f3(sc, cddr(opt3_pair(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_fn = fn_proc(caller); +} + +static s7_pointer oprec_if_a_a_opa_laaq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); + else { + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + set_car(sc->t2_2, oprec_if_a_a_opa_laaq(sc)); + set_car(sc->t2_1, recur_pop(sc)); + set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); + } + set_car(sc->t2_1, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer oprec_if_a_opa_laaq_a(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) == sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + set_car(sc->t2_2, oprec_if_a_opa_laaq_a(sc)); + set_car(sc->t2_1, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_opa_laaq(s7_scheme * sc) +{ + opinit_if_a_a_opa_laaq(sc, IF2A_LA2); + return (oprec_if_a_a_opa_laaq(sc)); +} + +static s7_pointer op_recur_if_a_opa_laaq_a(s7_scheme * sc) +{ + opinit_if_a_a_opa_laaq(sc, IF1A_LA2); + return (oprec_if_a_opa_laaq_a(sc)); +} + +static s7_pointer op_recur_cond_a_a_opa_laaq(s7_scheme * sc) +{ + opinit_if_a_a_opa_laaq(sc, COND2A_LA2); + return (oprec_if_a_a_opa_laaq(sc)); +} + + +/* -------- if_a_a_opa_l3aq -------- */ +static void opinit_if_a_a_opa_l3aq(s7_scheme * sc) +{ + s7_pointer caller = opt3_pair(sc->code), l3a = cdr(opt3_pair(caller)); + rec_set_test(sc, cdr(sc->code)); + rec_set_res(sc, cddr(sc->code)); + rec_set_f1(sc, cdr(caller)); + rec_set_f2(sc, l3a); + rec_set_f3(sc, cdr(l3a)); + rec_set_f4(sc, cddr(l3a)); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_slot3 = next_slot(sc->rec_slot2); + sc->rec_fn = fn_proc(caller); +} + +static s7_pointer oprec_if_a_a_opa_l3aq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot3, sc->rec_f4f(sc, sc->rec_f4p)); + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); + else { + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot3, sc->rec_f4f(sc, sc->rec_f4p)); + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + set_car(sc->t2_2, oprec_if_a_a_opa_l3aq(sc)); + set_car(sc->t2_1, recur_pop(sc)); + set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); + } + set_car(sc->t2_1, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_opa_l3aq(s7_scheme * sc) +{ + opinit_if_a_a_opa_l3aq(sc); + return (oprec_if_a_a_opa_l3aq(sc)); +} + +/* -------- if_a_a_opla_laq and if_a_opla_laq_a -------- */ +static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme * sc, bool a_op) +{ + s7_pointer caller = opt3_pair(sc->code); +#if (!WITH_GMP) + s7_pointer c_op; + c_op = car(caller); + if ((is_symbol(c_op)) && + ((is_global(c_op)) || + ((is_slot(global_slot(c_op))) && + (lookup_slot_from(c_op, sc->curlet) == global_slot(c_op))))) { + s7_pointer s_func = global_value(c_op), slot = + let_slots(sc->curlet); + if (is_c_function(s_func)) { + sc->pc = 0; + sc->rec_test_o = sc->opts[0]; + if (bool_optimize(sc, cdr(sc->code))) { + int32_t start_pc = sc->pc; + sc->rec_result_o = sc->opts[start_pc]; + if (is_t_integer(slot_value(slot))) { + sc->rec_i_ii_f = s7_i_ii_function(s_func); + if ((sc->rec_i_ii_f) && + (int_optimize + (sc, + (a_op) ? cddr(sc->code) : cdddr(sc->code)))) { + sc->rec_a1_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdadr(caller))) { + sc->rec_a2_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(opt3_pair(caller)))) { + sc->rec_val1 = + make_mutable_integer(sc, + integer(slot_value + (slot))); + slot_set_value(slot, sc->rec_val1); + if (sc->pc != 4) + return (OPT_INT); + sc->rec_fb1 = sc->rec_test_o->v[0].fb; + sc->rec_fi1 = sc->rec_result_o->v[0].fi; + sc->rec_fi2 = sc->rec_a1_o->v[0].fi; + sc->rec_fi3 = sc->rec_a2_o->v[0].fi; + return (OPT_INT_0); + } + } + } + } + if (is_t_real(slot_value(slot))) { + sc->rec_d_dd_f = s7_d_dd_function(s_func); + if (sc->rec_d_dd_f) { + sc->pc = start_pc; + sc->rec_result_o = sc->opts[start_pc]; + if (float_optimize + (sc, + (a_op) ? cddr(sc->code) : cdddr(sc->code))) { + sc->rec_a1_o = sc->opts[sc->pc]; + if (float_optimize(sc, cdadr(caller))) { + sc->rec_a2_o = sc->opts[sc->pc]; + if (float_optimize + (sc, cdr(opt3_pair(caller)))) { + sc->rec_val1 = + s7_make_mutable_real(sc, + real + (slot_value + (slot))); + slot_set_value(slot, sc->rec_val1); + return (OPT_DBL); + } + } + } + } + } + } + } + } +#endif + rec_set_test(sc, cdr(sc->code)); + rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)); + rec_set_f1(sc, cdadr(caller)); + rec_set_f2(sc, cdr(opt3_pair(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); + return (OPT_PTR); +} + +static s7_int oprec_i_if_a_a_opla_laq(s7_scheme * sc) +{ + s7_int i1, i2; + if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) /* if_(A) */ + return (sc->rec_result_o->v[0].fi(sc->rec_result_o)); /* if_a_(A) */ + i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); /* save a1 */ + integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); /* slot1 = a2 */ + i2 = oprec_i_if_a_a_opla_laq(sc); /* save la2 */ + integer(sc->rec_val1) = i1; /* slot1 = a1 */ + return (sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq(sc), i2)); /* call op(la1, la2) */ +} + +static s7_int oprec_i_if_a_a_opla_laq_0(s7_scheme * sc) +{ + s7_int i1, i2; + if (sc->rec_fb1(sc->rec_test_o)) + return (sc->rec_fi1(sc->rec_result_o)); + i1 = sc->rec_fi2(sc->rec_a1_o); + integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); + if (sc->rec_fb1(sc->rec_test_o)) + i2 = sc->rec_fi1(sc->rec_result_o); + else { + s7_int i3; + i2 = sc->rec_fi2(sc->rec_a1_o); + integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); + i3 = oprec_i_if_a_a_opla_laq_0(sc); + integer(sc->rec_val1) = i2; + i2 = sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i3); + } + integer(sc->rec_val1) = i1; + return (sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i2)); +} + +static s7_double oprec_d_if_a_a_opla_laq(s7_scheme * sc) +{ + s7_double x1, x2; + if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) + return (sc->rec_result_o->v[0].fd(sc->rec_result_o)); + x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); + real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); + if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) + x2 = sc->rec_result_o->v[0].fd(sc->rec_result_o); + else { + s7_double x3; + x2 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); + real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); + x3 = oprec_d_if_a_a_opla_laq(sc); + real(sc->rec_val1) = x2; + x2 = sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x3); + } + real(sc->rec_val1) = x1; + return (sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x2)); +} + +static s7_pointer oprec_if_a_a_opla_laq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot1, + recur_swap(sc, oprec_if_a_a_opla_laq(sc))); + set_car(sc->t2_1, oprec_if_a_a_opla_laq(sc)); + set_car(sc->t2_2, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static s7_int oprec_i_if_a_opla_laq_a(s7_scheme * sc) +{ + s7_int i1, i2; + if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) + return (sc->rec_result_o->v[0].fi(sc->rec_result_o)); + i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); + integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); + i2 = oprec_i_if_a_opla_laq_a(sc); + integer(sc->rec_val1) = i1; + return (sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a(sc), i2)); +} + +static s7_int oprec_i_if_a_opla_laq_a_0(s7_scheme * sc) +{ + s7_int i1, i2; + if (!sc->rec_fb1(sc->rec_test_o)) + return (sc->rec_fi1(sc->rec_result_o)); + i1 = sc->rec_fi2(sc->rec_a1_o); + integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); + if (!sc->rec_fb1(sc->rec_test_o)) + i2 = sc->rec_fi1(sc->rec_result_o); + else { + s7_int i3; + i2 = sc->rec_fi2(sc->rec_a1_o); + integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); + i3 = oprec_i_if_a_opla_laq_a_0(sc); + integer(sc->rec_val1) = i2; + i2 = sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i3); + } + integer(sc->rec_val1) = i1; + return (sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i2)); +} + +static s7_double oprec_d_if_a_opla_laq_a(s7_scheme * sc) +{ + s7_double x1, x2; + if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) + return (sc->rec_result_o->v[0].fd(sc->rec_result_o)); + x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); + real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); + x2 = oprec_d_if_a_opla_laq_a(sc); + real(sc->rec_val1) = x1; + return (sc->rec_d_dd_f(oprec_d_if_a_opla_laq_a(sc), x2)); +} + +static s7_pointer oprec_if_a_opla_laq_a(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) == sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot1, + recur_swap(sc, oprec_if_a_opla_laq_a(sc))); + set_car(sc->t2_1, oprec_if_a_opla_laq_a(sc)); + set_car(sc->t2_2, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static void wrap_recur_if_a_a_opla_laq(s7_scheme * sc, bool a_op) +{ + opt_pid_t choice; + tick_tc(sc, sc->cur_op); + choice = opinit_if_a_a_opla_laq(sc, a_op); + if ((choice == OPT_INT) || (choice == OPT_INT_0)) { + if (choice == OPT_INT_0) + sc->value = + make_integer(sc, + (a_op) ? oprec_i_if_a_a_opla_laq_0(sc) : + oprec_i_if_a_opla_laq_a_0(sc)); + else + sc->value = + make_integer(sc, + (a_op) ? oprec_i_if_a_a_opla_laq(sc) : + oprec_i_if_a_opla_laq_a(sc)); + } else if (choice == OPT_PTR) { + sc->rec_stack = recur_make_stack(sc); + sc->value = + (a_op) ? oprec_if_a_a_opla_laq(sc) : oprec_if_a_opla_laq_a(sc); + sc->rec_loc = 0; + } else + sc->value = + make_real(sc, + (a_op) ? oprec_d_if_a_a_opla_laq(sc) : + oprec_d_if_a_opla_laq_a(sc)); +} + + +/* -------- if_a_a_opa_la_laq and if_a_opa_la_laq_a -------- */ +static void opinit_if_a_a_opa_la_laq(s7_scheme * sc, bool a_op) +{ + s7_pointer caller = opt3_pair(sc->code); + rec_set_test(sc, cdr(sc->code)); + rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)); + rec_set_f1(sc, cdr(caller)); + rec_set_f2(sc, cdaddr(caller)); + rec_set_f3(sc, cdr(opt3_pair(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); +} + +static s7_pointer oprec_if_a_a_opa_la_laq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot1, + recur_swap(sc, oprec_if_a_a_opa_la_laq(sc))); + set_car(sc->t3_2, oprec_if_a_a_opa_la_laq(sc)); + set_car(sc->t3_3, recur_pop(sc)); + set_car(sc->t3_1, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t3_1)); +} + +static s7_pointer oprec_if_a_opa_la_laq_a(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) == sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot1, + recur_swap(sc, oprec_if_a_opa_la_laq_a(sc))); + set_car(sc->t3_2, oprec_if_a_opa_la_laq_a(sc)); + set_car(sc->t3_3, recur_pop(sc)); + set_car(sc->t3_1, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t3_1)); +} + +static s7_pointer op_recur_if_a_a_opa_la_laq(s7_scheme * sc) +{ + opinit_if_a_a_opa_la_laq(sc, true); + return (oprec_if_a_a_opa_la_laq(sc)); +} + +static s7_pointer op_recur_if_a_opa_la_laq_a(s7_scheme * sc) +{ + opinit_if_a_a_opa_la_laq(sc, false); + return (oprec_if_a_opa_la_laq_a(sc)); +} + +/* -------- if_a_a_opla_la_laq -------- */ +static void opinit_if_a_a_opla_la_laq(s7_scheme * sc, bool a_op) +{ + s7_pointer caller = opt3_pair(sc->code); + rec_set_test(sc, cdr(sc->code)); + rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)); + rec_set_f1(sc, cdadr(caller)); + rec_set_f2(sc, cdaddr(caller)); + rec_set_f3(sc, cdr(opt3_pair(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); +} + +static s7_pointer oprec_if_a_a_opla_la_laq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot1, + recur_swap(sc, oprec_if_a_a_opla_la_laq(sc))); + recur_push(sc, oprec_if_a_a_opla_la_laq(sc)); + slot_set_value(sc->rec_slot1, recur_ref(sc, 3)); + set_car(sc->t3_1, oprec_if_a_a_opla_la_laq(sc)); + set_car(sc->t3_2, recur_pop(sc)); + set_car(sc->t3_3, recur_pop2(sc)); + return (sc->rec_fn(sc, sc->t3_1)); +} + +static s7_pointer op_recur_if_a_a_opla_la_laq(s7_scheme * sc) +{ + opinit_if_a_a_opla_la_laq(sc, true); + return (oprec_if_a_a_opla_la_laq(sc)); +} + +/* -------- if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) -------- + * esteemed reader, please ignore this nonsense! + * The opt_info version was not a lot faster -- ~/old/tak-st.c: say 10% faster. The current fx-based + * version has immediate lookups, and since the data is (ahem) simple, the GC is not a factor. + * The opt version has its own overheads, and has to do the same amount of stack manipulations. + */ +static s7_pointer rec_x(s7_scheme * sc, s7_pointer code) +{ + return (slot_value(sc->rec_slot1)); +} + +static s7_pointer rec_y(s7_scheme * sc, s7_pointer code) +{ + return (slot_value(sc->rec_slot2)); +} + +static s7_pointer rec_z(s7_scheme * sc, s7_pointer code) +{ + return (slot_value(sc->rec_slot3)); +} + +static s7_pointer rec_sub_z1(s7_scheme * sc, s7_pointer code) +{ + s7_pointer x = slot_value(sc->rec_slot3); + return ((is_t_integer(x)) ? make_integer(sc, integer(x) - 1) : + minus_c1(sc, x)); +} + +static void opinit_if_a_a_lopl3a_l3a_l3aq(s7_scheme * sc) +{ + s7_pointer la1, la2, la3, caller = opt3_pair(sc->code); + rec_set_test(sc, cdr(sc->code)); + rec_set_res(sc, cddr(sc->code)); + la1 = cadr(caller); + la2 = caddr(caller); + la3 = opt3_pair(caller); + rec_set_f1(sc, cdr(la1)); + rec_set_f2(sc, cddr(la1)); + if (sc->rec_f2f == fx_u) + sc->rec_f2f = rec_y; + rec_set_f3(sc, cdddr(la1)); + rec_set_f4(sc, cdr(la2)); + rec_set_f5(sc, cddr(la2)); + rec_set_f6(sc, cdddr(la2)); + if (sc->rec_f6f == fx_t) + sc->rec_f6f = rec_x; + + sc->rec_f7p = cdr(la3); + sc->rec_f7f = fx_proc(sc->rec_f7p); + sc->rec_f7p = car(sc->rec_f7p); + + sc->rec_f8p = cddr(la3); + sc->rec_f8f = fx_proc(sc->rec_f8p); + if (sc->rec_f8f == fx_t) + sc->rec_f8f = rec_x; + sc->rec_f8p = car(sc->rec_f8p); + + sc->rec_f9p = cdddr(la3); + sc->rec_f9f = fx_proc(sc->rec_f9p); + if (sc->rec_f9f == fx_u) + sc->rec_f9f = rec_y; + sc->rec_f9p = car(sc->rec_f9p); + + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_slot3 = next_slot(sc->rec_slot2); + if (cadddr(la1) == slot_symbol(sc->rec_slot3)) + sc->rec_f3f = rec_z; + if (caddr(la2) == slot_symbol(sc->rec_slot3)) + sc->rec_f5f = rec_z; + if ((sc->rec_f7f == fx_subtract_s1) + && (cadadr(la3) == slot_symbol(sc->rec_slot3))) + sc->rec_f7f = rec_sub_z1; +} + +static s7_pointer oprec_if_a_a_lopl3a_l3a_l3aq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); + recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); + recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); + recur_push(sc, sc->rec_f6f(sc, sc->rec_f6p)); + recur_push(sc, sc->rec_f7f(sc, sc->rec_f7p)); + recur_push(sc, sc->rec_f8f(sc, sc->rec_f8p)); + slot_set_value(sc->rec_slot3, sc->rec_f9f(sc, sc->rec_f9p)); + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + recur_push(sc, oprec_if_a_a_lopl3a_l3a_l3aq(sc)); + slot_set_value(sc->rec_slot3, recur_ref(sc, 2)); + slot_set_value(sc->rec_slot2, recur_ref(sc, 3)); + slot_set_value(sc->rec_slot1, recur_ref(sc, 4)); + recur_push(sc, oprec_if_a_a_lopl3a_l3a_l3aq(sc)); + slot_set_value(sc->rec_slot3, recur_ref(sc, 6)); + slot_set_value(sc->rec_slot2, recur_ref(sc, 7)); + slot_set_value(sc->rec_slot1, recur_ref(sc, 8)); + slot_set_value(sc->rec_slot1, oprec_if_a_a_lopl3a_l3a_l3aq(sc)); + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot3, recur_pop(sc)); + sc->rec_loc -= 6; + return (oprec_if_a_a_lopl3a_l3a_l3aq(sc)); +} + +static s7_pointer op_recur_if_a_a_lopl3a_l3a_l3aq(s7_scheme * sc) +{ + opinit_if_a_a_lopl3a_l3a_l3aq(sc); + return (oprec_if_a_a_lopl3a_l3a_l3aq(sc)); +} + +/* -------- if_a_a_and_a_laa_laa -------- */ + +static void opinit_if_a_a_and_a_laa_laa(s7_scheme * sc, s7_pointer code) +{ + s7_pointer la1, la2, caller = opt3_pair(code); + rec_set_test(sc, cdr(code)); + rec_set_res(sc, cddr(code)); + la1 = caddr(caller); + la2 = cadddr(caller); + rec_set_f1(sc, cdr(caller)); + rec_set_f2(sc, cdr(la1)); + rec_set_f3(sc, cddr(la1)); + rec_set_f4(sc, cdr(la2)); + rec_set_f5(sc, cddr(la2)); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); +} + +static s7_pointer oprec_if_a_a_and_a_laa_laa(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + if (sc->rec_f1f(sc, sc->rec_f1p) == sc->F) + return (sc->F); + recur_push(sc, slot_value(sc->rec_slot1)); + recur_push(sc, slot_value(sc->rec_slot2)); + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + if (oprec_if_a_a_and_a_laa_laa(sc) == sc->F) { + sc->rec_loc -= 2; + return (sc->F); + } + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); + slot_set_value(sc->rec_slot2, sc->rec_f5f(sc, sc->rec_f5p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + return (oprec_if_a_a_and_a_laa_laa(sc)); +} + +static s7_pointer op_recur_if_a_a_and_a_laa_laa(s7_scheme * sc) +{ + opinit_if_a_a_and_a_laa_laa(sc, sc->code); + return (oprec_if_a_a_and_a_laa_laa(sc)); +} + +static s7_pointer fx_recur_if_a_a_and_a_laa_laa(s7_scheme * sc, + s7_pointer arg) +{ + tick_tc(sc, OP_RECUR_IF_A_A_AND_A_LAA_LAA); + /* sc->curlet is set already and will be restored by the caller */ + sc->rec_stack = recur_make_stack(sc); + opinit_if_a_a_and_a_laa_laa(sc, arg); + sc->value = oprec_if_a_a_and_a_laa_laa(sc); + sc->rec_loc = 0; + return (sc->value); +} + +/* -------- cond_a_a_a_a_opla_laq -------- */ +static void opinit_cond_a_a_a_a_opla_laq(s7_scheme * sc, s7_pointer code, + bool cond_case) +{ + s7_pointer caller = opt3_pair(code); + if (cond_case) { + rec_set_test(sc, cadr(code)); + rec_set_res(sc, cdadr(code)); + rec_set_f1(sc, caddr(code)); + rec_set_f2(sc, cdaddr(code)); + } else { + rec_set_test(sc, cdr(code)); + rec_set_res(sc, cddr(code)); /* (if a b...) */ + rec_set_f1(sc, opt1_pair(code)); /* cdr(cadddr(code)), (if a b (if c d...)) */ + rec_set_f2(sc, cdr(opt1_pair(code))); + } + rec_set_f3(sc, cdadr(caller)); + rec_set_f4(sc, opt3_pair(caller)); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); +} + +static s7_pointer oprec_cond_a_a_a_a_opla_laq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) + return (sc->rec_f2f(sc, sc->rec_f2p)); + recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot1, sc->rec_f4f(sc, sc->rec_f4p)); + slot_set_value(sc->rec_slot1, + recur_swap(sc, oprec_cond_a_a_a_a_opla_laq(sc))); + set_car(sc->t2_1, oprec_cond_a_a_a_a_opla_laq(sc)); + set_car(sc->t2_2, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_cond_a_a_a_a_opla_laq(s7_scheme * sc) +{ + opinit_cond_a_a_a_a_opla_laq(sc, sc->code, true); + return (oprec_cond_a_a_a_a_opla_laq(sc)); +} + +static s7_pointer op_recur_if_a_a_if_a_a_opla_laq(s7_scheme * sc) +{ + opinit_cond_a_a_a_a_opla_laq(sc, sc->code, false); + return (oprec_cond_a_a_a_a_opla_laq(sc)); +} + +static s7_pointer fx_recur_cond_a_a_a_a_opla_laq(s7_scheme * sc, + s7_pointer arg) +{ + tick_tc(sc, OP_RECUR_COND_A_A_A_A_opLA_LAq); + sc->rec_stack = recur_make_stack(sc); + opinit_cond_a_a_a_a_opla_laq(sc, arg, true); + sc->value = oprec_cond_a_a_a_a_opla_laq(sc); + sc->rec_loc = 0; + return (sc->value); +} + + +/* -------- cond_a_a_a_a_oplaa_laaq -------- */ + +static void opinit_cond_a_a_a_a_oplaa_laaq(s7_scheme * sc, bool cond_case) +{ + s7_pointer caller = opt3_pair(sc->code); /* cadr(cadddr(sc->code)) = (cfunc laa laa) */ + if (cond_case) { + rec_set_test(sc, cadr(sc->code)); + rec_set_res(sc, cdadr(sc->code)); + rec_set_f1(sc, caddr(sc->code)); + rec_set_f2(sc, cdaddr(sc->code)); + } else { + rec_set_test(sc, cdr(sc->code)); + rec_set_res(sc, cddr(sc->code)); /* (if a b...) */ + rec_set_f1(sc, opt1_pair(sc->code)); /* cdr(cadddr(sc->code)), (if a b (if c d...)) */ + rec_set_f2(sc, cdr(opt1_pair(sc->code))); + } + sc->rec_f3p = cdadr(caller); + rec_set_f4(sc, cdr(sc->rec_f3p)); + sc->rec_f3f = fx_proc(sc->rec_f3p); + sc->rec_f3p = car(sc->rec_f3p); + sc->rec_f5p = opt3_pair(caller); + rec_set_f6(sc, cdr(sc->rec_f5p)); + sc->rec_f5f = fx_proc(sc->rec_f5p); + sc->rec_f5p = car(sc->rec_f5p); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_fn = fn_proc(caller); +} + +static s7_pointer oprec_cond_a_a_a_a_oplaa_laaq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) + return (sc->rec_f2f(sc, sc->rec_f2p)); + recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); + recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); + recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); + slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + sc->value = oprec_cond_a_a_a_a_oplaa_laaq(sc); /* second laa arg */ + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + recur_push_unchecked(sc, sc->value); + set_car(sc->t2_1, oprec_cond_a_a_a_a_oplaa_laaq(sc)); /* first laa arg */ + set_car(sc->t2_2, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_cond_a_a_a_a_oplaa_laaq(s7_scheme * sc) +{ + opinit_cond_a_a_a_a_oplaa_laaq(sc, true); + return (oprec_cond_a_a_a_a_oplaa_laaq(sc)); +} + +static s7_pointer op_recur_if_a_a_if_a_a_oplaa_laaq(s7_scheme * sc) +{ + opinit_cond_a_a_a_a_oplaa_laaq(sc, false); + return (oprec_cond_a_a_a_a_oplaa_laaq(sc)); +} + + +/* -------- cond_a_a_a_a_opa_laaq -------- */ +static void opinit_cond_a_a_a_a_opa_laaq(s7_scheme * sc) +{ + s7_pointer caller = opt3_pair(sc->code); + rec_set_test(sc, cadr(sc->code)); + rec_set_res(sc, cdadr(sc->code)); + sc->rec_f1p = caddr(sc->code); + rec_set_f2(sc, cdr(sc->rec_f1p)); + sc->rec_f1f = fx_proc(sc->rec_f1p); + sc->rec_f1p = car(sc->rec_f1p); + rec_set_f3(sc, cdr(caller)); + rec_set_f4(sc, opt3_pair(caller)); + rec_set_f5(sc, cdr(opt3_pair(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_fn = fn_proc(caller); +} + +static s7_pointer oprec_cond_a_a_a_a_opa_laaq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) + return (sc->rec_f2f(sc, sc->rec_f2p)); + recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); + recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); + slot_set_value(sc->rec_slot2, sc->rec_f5f(sc, sc->rec_f5p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + set_car(sc->t2_2, oprec_cond_a_a_a_a_opa_laaq(sc)); + set_car(sc->t2_1, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_cond_a_a_a_a_opa_laaq(s7_scheme * sc) +{ + opinit_cond_a_a_a_a_opa_laaq(sc); + return (oprec_cond_a_a_a_a_opa_laaq(sc)); +} + + +/* -------- cond_a_a_a_laa_opa_laaq -------- */ + +static void opinit_cond_a_a_a_laa_opa_laaq(s7_scheme * sc, bool cond) +{ + s7_pointer caller = opt3_pair(sc->code); /* opA_LAA */ + rec_set_test(sc, (cond) ? cadr(sc->code) : cdr(sc->code)); + rec_set_res(sc, (cond) ? cdadr(sc->code) : cddr(sc->code)); + sc->rec_f1p = (cond) ? caddr(sc->code) : cdr(cadddr(sc->code)); + sc->rec_f2p = cdadr(sc->rec_f1p); + rec_set_f3(sc, cdr(sc->rec_f2p)); + sc->rec_f1f = fx_proc(sc->rec_f1p); + sc->rec_f1p = car(sc->rec_f1p); + sc->rec_f2f = fx_proc(sc->rec_f2p); + sc->rec_f2p = car(sc->rec_f2p); + rec_set_f4(sc, cdr(caller)); + sc->rec_f5p = cdr(opt3_pair(caller)); /* (L)AA */ + rec_set_f6(sc, cdr(sc->rec_f5p)); + sc->rec_f5f = fx_proc(sc->rec_f5p); + sc->rec_f5p = car(sc->rec_f5p); + sc->rec_fn = fn_proc(caller); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); +} + +static s7_pointer oprec_cond_a_a_a_laa_opa_laaq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) { + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + return (oprec_cond_a_a_a_laa_opa_laaq(sc)); /* first laa above */ + } + recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); + recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); + slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); + else if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) { + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + set_car(sc->t2_2, oprec_cond_a_a_a_laa_opa_laaq(sc)); /* first laa above */ + } else { + recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); + recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); + slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + set_car(sc->t2_2, oprec_cond_a_a_a_laa_opa_laaq(sc)); + set_car(sc->t2_1, recur_pop(sc)); + set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); + } + set_car(sc->t2_1, recur_pop(sc)); + return (sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_cond_a_a_a_laa_opa_laaq(s7_scheme * sc) +{ + opinit_cond_a_a_a_laa_opa_laaq(sc, true); + return (oprec_cond_a_a_a_laa_opa_laaq(sc)); +} + +static s7_pointer op_recur_if_a_a_if_a_laa_opa_laaq(s7_scheme * sc) +{ /* if version, same logic as cond above */ + opinit_cond_a_a_a_laa_opa_laaq(sc, false); + return (oprec_cond_a_a_a_laa_opa_laaq(sc)); +} + +/* -------- cond_a_a_a_laa_lopa_laaq -------- */ + +static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme * sc) +{ + s7_pointer caller = opt3_pair(sc->code); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + +#if (!WITH_GMP) + if ((is_t_integer(slot_value(sc->rec_slot1))) && + (is_t_integer(slot_value(sc->rec_slot2)))) { + sc->pc = 0; + sc->rec_test_o = sc->opts[0]; + if (bool_optimize(sc, cadr(sc->code))) { + sc->rec_result_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdadr(sc->code))) { + s7_pointer laa1 = caddr(sc->code); + sc->rec_a1_o = sc->opts[sc->pc]; + if (bool_optimize(sc, laa1)) { + sc->rec_a2_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdadr(laa1))) { + sc->rec_a3_o = sc->opts[sc->pc]; + if (int_optimize(sc, cddadr(laa1))) { + s7_pointer laa2 = + cadr(cadddr(sc->code)), laa3 = caddr(laa2); + sc->rec_a4_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(laa2))) { + sc->rec_a5_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(laa3))) { + sc->rec_a6_o = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(laa3))) { + sc->rec_val1 = + make_mutable_integer(sc, + integer + (slot_value + (sc->rec_slot1))); + slot_set_value(sc->rec_slot1, + sc->rec_val1); + sc->rec_val2 = + make_mutable_integer(sc, + integer + (slot_value + (sc->rec_slot2))); + slot_set_value(sc->rec_slot2, + sc->rec_val2); + if (sc->pc != 8) + return (OPT_INT); + sc->rec_fb1 = + sc->rec_test_o->v[0].fb; + sc->rec_fb2 = + sc->rec_a1_o->v[0].fb; + sc->rec_fi1 = + sc->rec_result_o->v[0].fi; + sc->rec_fi2 = + sc->rec_a2_o->v[0].fi; + sc->rec_fi3 = + sc->rec_a3_o->v[0].fi; + sc->rec_fi4 = + sc->rec_a4_o->v[0].fi; + sc->rec_fi5 = + sc->rec_a5_o->v[0].fi; + sc->rec_fi6 = + sc->rec_a6_o->v[0].fi; + return (OPT_INT_0); + } + } + } + } + } + } + } + } + } +#endif + rec_set_test(sc, cadr(sc->code)); + rec_set_res(sc, cdadr(sc->code)); + sc->rec_f1p = caddr(sc->code); + sc->rec_f2p = cdadr(sc->rec_f1p); + rec_set_f3(sc, cdr(sc->rec_f2p)); + sc->rec_f1f = fx_proc(sc->rec_f1p); + sc->rec_f1p = car(sc->rec_f1p); + sc->rec_f2f = fx_proc(sc->rec_f2p); + sc->rec_f2p = car(sc->rec_f2p); + rec_set_f4(sc, cdr(caller)); + sc->rec_f5p = opt3_pair(caller); + rec_set_f6(sc, cdr(sc->rec_f5p)); + sc->rec_f5f = fx_proc(sc->rec_f5p); + sc->rec_f5p = car(sc->rec_f5p); + return (OPT_PTR); +} + +static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq(s7_scheme * sc) +{ + s7_int i1, i2; + if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) + return (sc->rec_result_o->v[0].fi(sc->rec_result_o)); + if (sc->rec_a1_o->v[0].fb(sc->rec_a1_o)) { + i1 = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); + integer(sc->rec_val2) = sc->rec_a3_o->v[0].fi(sc->rec_a3_o); + integer(sc->rec_val1) = i1; + return (oprec_i_cond_a_a_a_laa_lopa_laaq(sc)); + } + i1 = sc->rec_a4_o->v[0].fi(sc->rec_a4_o); + i2 = sc->rec_a5_o->v[0].fi(sc->rec_a5_o); + integer(sc->rec_val2) = sc->rec_a6_o->v[0].fi(sc->rec_a6_o); + integer(sc->rec_val1) = i2; + integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq(sc); + integer(sc->rec_val1) = i1; + return (oprec_i_cond_a_a_a_laa_lopa_laaq(sc)); +} + +static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq_0(s7_scheme * sc) +{ + s7_int i1, i2; + if (sc->rec_fb1(sc->rec_test_o)) + return (sc->rec_fi1(sc->rec_result_o)); + if (sc->rec_fb2(sc->rec_a1_o)) { + i1 = sc->rec_fi2(sc->rec_a2_o); + integer(sc->rec_val2) = sc->rec_fi3(sc->rec_a3_o); + integer(sc->rec_val1) = i1; + return (oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); + } + i1 = sc->rec_fi4(sc->rec_a4_o); + i2 = sc->rec_fi5(sc->rec_a5_o); + integer(sc->rec_val2) = sc->rec_fi6(sc->rec_a6_o); + integer(sc->rec_val1) = i2; + integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc); + integer(sc->rec_val1) = i1; + return (oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); +} + +static s7_pointer oprec_cond_a_a_a_laa_lopa_laaq(s7_scheme * sc) +{ + if (sc->rec_testf(sc, sc->rec_testp) != sc->F) + return (sc->rec_resf(sc, sc->rec_resp)); + if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) { + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + return (oprec_cond_a_a_a_laa_lopa_laaq(sc)); + } + recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); + recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); + slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + slot_set_value(sc->rec_slot2, oprec_cond_a_a_a_laa_lopa_laaq(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + return (oprec_cond_a_a_a_laa_lopa_laaq(sc)); +} + +static void wrap_recur_cond_a_a_a_laa_lopa_laaq(s7_scheme * sc) +{ + opt_pid_t choice; + tick_tc(sc, sc->cur_op); + choice = opinit_cond_a_a_a_laa_lopa_laaq(sc); + if (choice != OPT_PTR) + sc->value = + make_integer(sc, + (choice == + OPT_INT) ? oprec_i_cond_a_a_a_laa_lopa_laaq(sc) : + oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); + else { + sc->rec_stack = recur_make_stack(sc); + sc->value = oprec_cond_a_a_a_laa_lopa_laaq(sc); + sc->rec_loc = 0; + } +} + + +/* -------- and_a_or_a_laa_laa -------- */ + +static void opinit_and_a_or_a_laa_laa(s7_scheme * sc, s7_pointer code) +{ + s7_pointer orp = cdr(opt3_pair(code)); + rec_set_test(sc, cdr(code)); + rec_set_res(sc, orp); + rec_set_f1(sc, cdr(cadr(orp))); + rec_set_f2(sc, cddr(cadr(orp))); + rec_set_f3(sc, cdr(caddr(orp))); + rec_set_f4(sc, cddr(caddr(orp))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); +} + +static s7_pointer oprec_and_a_or_a_laa_laa(s7_scheme * sc) +{ + s7_pointer p; + if (sc->rec_testf(sc, sc->rec_testp) == sc->F) + return (sc->F); + p = sc->rec_resf(sc, sc->rec_resp); + if (p != sc->F) + return (p); + + recur_push(sc, slot_value(sc->rec_slot1)); + recur_push(sc, slot_value(sc->rec_slot2)); + recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); + slot_set_value(sc->rec_slot2, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + p = oprec_and_a_or_a_laa_laa(sc); + if (p != sc->F) { + sc->rec_loc -= 2; + return (p); + } + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot2, sc->rec_f4f(sc, sc->rec_f4p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + return (oprec_and_a_or_a_laa_laa(sc)); +} + +static s7_pointer op_recur_and_a_or_a_laa_laa(s7_scheme * sc) +{ + opinit_and_a_or_a_laa_laa(sc, sc->code); + return (oprec_and_a_or_a_laa_laa(sc)); +} + +static s7_pointer fx_recur_and_a_or_a_laa_laa(s7_scheme * sc, + s7_pointer arg) +{ + tick_tc(sc, OP_RECUR_AND_A_OR_A_LAA_LAA); + sc->rec_stack = recur_make_stack(sc); + opinit_and_a_or_a_laa_laa(sc, arg); + sc->value = oprec_and_a_or_a_laa_laa(sc); + sc->rec_loc = 0; + return (sc->value); +} + +static void wrap_recur(s7_scheme * sc, s7_pointer(*recur) (s7_scheme * sc)) +{ + tick_tc(sc, sc->cur_op); + sc->rec_stack = recur_make_stack(sc); + sc->value = recur(sc); + sc->rec_loc = 0; +} + + +/* -------------------------------- */ +static void op_safe_c_p(s7_scheme * sc) +{ + check_stack_size(sc); + push_stack_no_args_direct(sc, OP_SAFE_C_P_1); + sc->code = T_Pair(cadr(sc->code)); +} + +static void op_safe_c_p_1(s7_scheme * sc) +{ + set_car(sc->t1_1, sc->value); + sc->value = fn_proc(sc->code) (sc, sc->t1_1); +} + +static void op_safe_c_ssp(s7_scheme * sc) +{ + check_stack_size(sc); + push_stack_no_args_direct(sc, OP_SAFE_C_SSP_1); + sc->code = opt3_pair(sc->code); +} + +static void op_safe_c_ssp_1(s7_scheme * sc) +{ + set_car(sc->t3_3, sc->value); + set_car(sc->t3_1, lookup(sc, cadr(sc->code))); + set_car(sc->t3_2, lookup(sc, caddr(sc->code))); + sc->value = fn_proc(sc->code) (sc, sc->t3_1); +} + +static void op_safe_c_ssp_mv_1(s7_scheme * sc) +{ + sc->args = cons_unchecked(sc, lookup(sc, cadr(sc->code)), cons(sc, lookup(sc, caddr(sc->code)), sc->value)); /* not ulist here */ + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static s7_pointer op_c_s_opsq(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code), val; + val = lookup(sc, car(args)); + set_car(sc->t1_1, lookup(sc, opt1_sym(args))); + sc->args = list_2(sc, val, fn_proc(cadr(args)) (sc, sc->t1_1)); + return (fn_proc(sc->code) (sc, sc->args)); +} + +static inline void op_s(s7_scheme * sc) +{ + sc->code = lookup(sc, car(sc->code)); + if (!is_applicable(sc->code)) + apply_error(sc, sc->code, sc->nil); + sc->args = sc->nil; /* op_s -> apply, so we'll apply sc->code to sc->args */ +} + +static s7_pointer op_s_c(s7_scheme * sc) +{ + s7_pointer code = sc->code; + sc->code = lookup_checked(sc, car(code)); + if (!is_applicable(sc->code)) + apply_error(sc, sc->code, cdr(code)); + sc->args = + (needs_copied_args(sc->code)) ? list_1(sc, + cadr(code)) : + set_plist_1(sc, cadr(code)); + return (NULL); +} + +static Inline bool op_s_s(s7_scheme * sc) +{ + s7_pointer code = sc->code; + sc->code = lookup_checked(sc, car(code)); + if ((is_c_function(sc->code)) && + (c_function_required_args(sc->code) == 1) && + (!needs_copied_args(sc->code))) { + set_car(sc->t1_1, lookup(sc, cadr(code))); + sc->value = c_function_call(sc->code) (sc, sc->t1_1); + return (true); /* goto START; */ + } + if (!is_applicable(sc->code)) + apply_error(sc, sc->code, cdr(code)); + if (dont_eval_args(sc->code)) + sc->args = list_1(sc, cadr(code)); + else + sc->args = + (needs_copied_args(sc->code)) ? list_1(sc, + lookup(sc, + cadr(code))) : + set_plist_1(sc, lookup(sc, cadr(code))); + return (false); /* goto APPLY; */ +} + +static void op_x_a(s7_scheme * sc, s7_pointer f) +{ + s7_pointer code = sc->code; + sc->code = f; + if (!is_applicable(sc->code)) + apply_error(sc, sc->code, cdr(code)); + if (dont_eval_args(sc->code)) + sc->args = list_1(sc, cadr(code)); + else if (!needs_copied_args(sc->code)) + sc->args = set_plist_1(sc, fx_call(sc, cdr(code))); + else { + sc->args = fx_call(sc, cdr(code)); + sc->args = list_1(sc, sc->args); + } +} + +static void op_x_aa(s7_scheme * sc, s7_pointer f) +{ + s7_pointer code = sc->code; + sc->code = f; + if (!is_applicable(sc->code)) + apply_error(sc, sc->code, cdr(code)); + if (dont_eval_args(sc->code)) + sc->args = list_2(sc, cadr(code), caddr(code)); + else { + sc->args = fx_call(sc, cddr(code)); + if (!needs_copied_args(sc->code)) + sc->args = set_plist_2(sc, fx_call(sc, cdr(code)), sc->args); + else { + sc->args = list_1(sc, sc->args); + sc->value = fx_call(sc, cdr(code)); + sc->args = cons(sc, sc->value, sc->args); + } + } +} + +static void op_p_s_1(s7_scheme * sc) +{ + /* we get multiple values here (from op calc = "p" not "s") but don't need to handle it ourselves: + * let v be #(#_abs), so ((v 0) -2), (v 0 -2), ((values v 0) -2), and (((values v 0)) -2) are all 2 + * or: (define (f1) (values vector-ref (vector 1 2 3))) (define arg 1) (define (f2) ((f1) arg)) (f2) (f2) + * so apply calls apply_pair which handles multiple values explicitly. + */ + if (dont_eval_args(sc->value)) + sc->args = cdr(sc->code); + else { + sc->args = lookup_checked(sc, cadr(sc->code)); + if (needs_copied_args(sc->value)) + sc->args = list_1(sc, sc->args); + else + sc->args = set_plist_1(sc, sc->args); + } + sc->code = sc->value; /* goto APPLY */ +} + +static void op_safe_c_star_na(s7_scheme * sc) +{ + s7_pointer args, p; + sc->args = + safe_list_if_possible(sc, integer(opt3_arglen(cdr(sc->code)))); + for (args = cdr(sc->code), p = sc->args; is_pair(args); + args = cdr(args), p = cdr(p)) + set_car(p, fx_call(sc, args)); + sc->code = opt1_cfunc(sc->code); + apply_c_function_star(sc); + clear_list_in_use(sc->args); +} + +static void op_safe_c_star(s7_scheme * sc) +{ + sc->code = opt1_cfunc(sc->code); + apply_c_function_star_fill_defaults(sc, 0); +} + +static void op_safe_c_star_a(s7_scheme * sc) +{ + s7_pointer p; + p = fx_call(sc, cdr(sc->code)); + if (is_keyword(p)) + s7_error(sc, sc->syntax_error_symbol, + set_elist_3(sc, value_is_missing_string, car(sc->code), + p)); + /* scheme-level define* here also gives "not a parameter name" */ + sc->args = list_1(sc, p); + sc->code = opt1_cfunc(sc->code); + /* one arg, so it's not a keyword; all we need to do is fill in the default */ + apply_c_function_star_fill_defaults(sc, 1); +} + +static void op_safe_c_star_aa(s7_scheme * sc) +{ + sc->temp1 = fx_call(sc, cdr(sc->code)); /* temp1 use in optimizer, various do loops */ + set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); + set_car(sc->t2_1, sc->temp1); + sc->temp1 = sc->nil; + sc->args = sc->t2_1; + sc->code = opt1_cfunc(sc->code); + apply_c_function_star(sc); +} + + +static void op_safe_c_ps(s7_scheme * sc) +{ + push_stack_no_args_direct(sc, OP_SAFE_C_PS_1); /* got to wait in this case */ + sc->code = cadr(sc->code); +} + +static void op_safe_c_ps_1(s7_scheme * sc) +{ + set_car(sc->t2_2, lookup(sc, caddr(sc->code))); + set_car(sc->t2_1, sc->value); + sc->value = fn_proc(sc->code) (sc, sc->t2_1); +} + +static void op_safe_c_ps_mv(s7_scheme * sc) +{ /* (define (hi a) (+ (values 1 2) a)) */ + sc->args = + pair_append(sc, sc->value, + list_1(sc, lookup(sc, caddr(sc->code)))); + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static void op_safe_c_sp(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code); + check_stack_size(sc); + push_stack(sc, (opcode_t) opt1_any(args), lookup(sc, car(args)), + sc->code); + sc->code = cadr(args); +} + +static void op_safe_c_sp_1(s7_scheme * sc) +{ + /* we get here from many places (op_safe_c_sp for example), but all are safe */ + set_car(sc->t2_1, sc->args); + set_car(sc->t2_2, sc->value); + sc->value = fn_proc(sc->code) (sc, sc->t2_1); +} + +static void op_safe_c_sp_mv(s7_scheme * sc) +{ + sc->args = cons(sc, sc->args, sc->value); /* not ulist */ + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static void op_safe_add_sp_1(s7_scheme * sc) +{ + if ((is_t_integer(sc->args)) && (is_t_integer(sc->value))) + sc->value = + add_if_overflow_to_real_or_big_integer(sc, integer(sc->args), + integer(sc->value)); + else + sc->value = add_p_pp(sc, sc->args, sc->value); +} + +static void op_safe_multiply_sp_1(s7_scheme * sc) +{ + if ((is_t_real(sc->args)) && (is_t_real(sc->value))) + sc->value = make_real(sc, real(sc->args) * real(sc->value)); + else + sc->value = multiply_p_pp(sc, sc->args, sc->value); +} + +static void op_safe_c_pc(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code); + check_stack_size(sc); /* b dyn */ + push_stack(sc, OP_SAFE_C_PC_1, opt3_con(args), sc->code); + sc->code = car(args); +} + +static void op_safe_c_pc_mv(s7_scheme * sc) +{ + sc->args = pair_append(sc, sc->value, list_1(sc, sc->args)); /* not plist! */ + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static void op_safe_c_pc_1(s7_scheme * sc) +{ + set_car(sc->t2_1, sc->value); + set_car(sc->t2_2, sc->args); + sc->value = fn_proc(sc->code) (sc, sc->t2_1); +} + +static void op_safe_c_cp(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code); + /* it's possible in a case like this to overflow the stack -- s7test has a deeply + * nested expression involving (+ c (+ c (+ ... ))) all opt'd as safe_c_cp -- if we're close + * to the stack end at the start, it runs off the end. Normally the stack increase in + * the reader protects us, but a call/cc can replace the original stack with a much smaller one. + */ + check_stack_size(sc); + push_stack(sc, (opcode_t) opt1_any(args), opt3_any(args), sc->code); /* to safe_add_sp_1 for example */ + sc->code = cadr(args); +} + +static Inline void op_safe_c_s(s7_scheme * sc) +{ + set_car(sc->t1_1, lookup(sc, cadr(sc->code))); + sc->value = fn_proc(sc->code) (sc, sc->t1_1); +} + +static Inline void op_safe_c_ss(s7_scheme * sc) +{ + set_car(sc->t2_1, lookup(sc, cadr(sc->code))); + set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(sc->code)))); + sc->value = fn_proc(sc->code) (sc, sc->t2_1); +} + +static void op_safe_c_sc(s7_scheme * sc) +{ + set_car(sc->t2_1, lookup(sc, cadr(sc->code))); + set_car(sc->t2_2, opt2_con(cdr(sc->code))); + sc->value = fn_proc(sc->code) (sc, sc->t2_1); +} + +static void op_cl_a(s7_scheme * sc) +{ + set_car(sc->t1_1, fx_call(sc, cdr(sc->code))); + sc->value = fn_proc(sc->code) (sc, sc->t1_1); +} + +static void op_cl_aa(s7_scheme * sc) +{ + gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code))); + set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); + set_car(sc->t2_1, T_Pos(stack_protected1(sc))); + unstack(sc); + sc->value = fn_proc(sc->code) (sc, sc->t2_1); +} + +static void op_cl_fa(s7_scheme * sc) +{ + s7_pointer code = cdadr(sc->code); + set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); + set_car(sc->t2_1, + make_closure(sc, car(code), cdr(code), + T_CLOSURE | ((is_symbol(car(code))) ? T_COPY_ARGS + : 0), CLOSURE_ARITY_NOT_SET)); + /* arg1 lambda can be any arity, but it must be applicable to one arg (the "a" above) */ + sc->value = fn_proc(sc->code) (sc, sc->t2_1); +} + +static void op_map_for_each_fa(s7_scheme * sc) +{ + s7_pointer f = cddr(sc->code), code = sc->code; + sc->value = fx_call(sc, f); + if (is_null(sc->value)) + sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil; + else { + sc->code = opt3_pair(code); /* cdadr(code); */ + f = inline_make_closure(sc, car(sc->code), cdr(sc->code), T_CLOSURE, 1); /* arity=1 checked in optimizer */ + sc->value = + (fn_proc_unchecked(code)) ? g_for_each_closure(sc, f, + sc->value) : + g_map_closure(sc, f, sc->value); + } +} + +static void op_map_for_each_faa(s7_scheme * sc) +{ + s7_pointer f = cddr(sc->code), code = sc->code; + sc->value = fx_call(sc, f); + sc->args = fx_call(sc, cdr(f)); + if ((is_null(sc->value)) || (is_null(sc->args))) + sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil; + else { + sc->code = opt3_pair(code); /* cdadr(code); */ + f = inline_make_closure(sc, car(sc->code), cdr(sc->code), T_CLOSURE, 2); /* arity=2 checked in optimizer */ + sc->value = + (fn_proc_unchecked(code)) ? g_for_each_closure_2(sc, f, + sc->value, + sc->args) : + g_map_closure_2(sc, f, sc->value, sc->args); + } +} + +static void op_cl_na(s7_scheme * sc) +{ + s7_pointer args, p, val; + val = safe_list_if_possible(sc, integer(opt3_arglen(cdr(sc->code)))); + if (in_heap(val)) + gc_protect_via_stack(sc, val); + for (args = cdr(sc->code), p = val; is_pair(args); + args = cdr(args), p = cdr(p)) + set_car(p, fx_call(sc, args)); + sc->value = fn_proc(sc->code) (sc, val); + if (in_heap(val)) { + /* the fn_proc call might push its own op (e.g. for-each/map) so we have to check for that */ + if (main_stack_op(sc) == OP_GC_PROTECT) + unstack(sc); + } else + clear_list_in_use(val); +} + +static void op_cl_sas(s7_scheme * sc) +{ + set_car(sc->t3_2, fx_call(sc, cddr(sc->code))); + set_car(sc->t3_1, lookup(sc, cadr(sc->code))); + set_car(sc->t3_3, lookup(sc, cadddr(sc->code))); + sc->value = fn_proc(sc->code) (sc, sc->t3_1); +} + +static void op_safe_c_pp(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code); + check_stack_size(sc); + /* has_fx check here is slower, we assume car(args) below is a pair (else cp/sp/ap?) */ + if ((has_gx(args)) && (symbol_ctr(caar(args)) == 1)) { + sc->args = fx_proc_unchecked(args) (sc, car(args)); + push_stack_direct(sc, (opcode_t) opt1_any(args)); /* args = first value, func(args, value) if no mv */ + sc->code = cadr(args); + } else { + push_stack_no_args_direct(sc, OP_SAFE_C_PP_1); /* first arg = p, if mv -> op_safe_c_pp_3 */ + sc->code = car(args); + } +} + +static void op_safe_c_pp_1(s7_scheme * sc) +{ + /* it is much slower to check has_gx here! */ + push_stack(sc, (opcode_t) opt1_any(cdr(sc->code)), sc->value, sc->code); /* args[i.e. sc->value] = first value, func(args, value) if no mv */ + sc->code = caddr(sc->code); +} + +static void op_safe_c_pp_3_mv(s7_scheme * sc) +{ + /* we get here if the first arg returned multiple values */ + push_stack(sc, OP_SAFE_C_PP_5, copy_proper_list(sc, sc->value), sc->code); /* copy is needed here */ + sc->code = caddr(sc->code); +} + +static void op_safe_c_pp_5(s7_scheme * sc) +{ + /* 1 mv, 2 normal (else mv->6), sc->args was copied above (and this is a safe c function so its args are in no danger) */ + if (is_null(sc->args)) + sc->args = list_1(sc, sc->value); /* plist here and below, but this is almost never called */ + else { + s7_pointer p; + for (p = sc->args; is_pair(cdr(p)); p = cdr(p)); + set_cdr(p, list_1(sc, sc->value)); + } + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static void op_safe_c_pp_6_mv(s7_scheme * sc) +{ + /* both args mv */ + sc->args = pair_append(sc, sc->args, sc->value); + /* + * fn_proc(sc->code) here is g_add_2, but we have any number of args from a values call + * the original (unoptimized) function is (hopefully) c_function_base(opt1_cfunc(sc->code))? + * (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) -> 10 + */ + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static void op_safe_c_3p(s7_scheme * sc) +{ + /* check_stack_size(sc); */ + push_stack_no_args_direct(sc, OP_SAFE_C_3P_1); + sc->code = cadr(sc->code); +} + +static void op_safe_c_3p_1(s7_scheme * sc) +{ + sc->args = sc->value; /* possibly fx/gx? and below */ + push_stack_direct(sc, OP_SAFE_C_3P_2); + sc->code = caddr(sc->code); +} + +static void op_safe_c_3p_1_mv(s7_scheme * sc) +{ /* here only if sc->value is mv */ + sc->args = sc->value; + push_stack_direct(sc, OP_SAFE_C_3P_2_MV); + sc->code = caddr(sc->code); +} + +static void op_safe_c_3p_2(s7_scheme * sc) +{ + gc_protect_via_stack(sc, sc->value); + push_stack_direct(sc, OP_SAFE_C_3P_3); + sc->code = cadddr(sc->code); +} + +static void op_safe_c_3p_2_mv(s7_scheme * sc) +{ /* here from 1 + 2mv, or 1_mv with 2 or 2mv */ + gc_protect_via_stack(sc, sc->value); + push_stack_direct(sc, OP_SAFE_C_3P_3_MV); + sc->code = cadddr(sc->code); +} + +static void op_safe_c_3p_3(s7_scheme * sc) +{ + set_car(sc->t3_3, sc->value); + set_car(sc->t3_1, sc->args); + set_car(sc->t3_2, stack_protected1(sc)); + unstack(sc); + sc->value = fn_proc(sc->code) (sc, sc->t3_1); +} + +static void op_safe_c_3p_3_mv(s7_scheme * sc) +{ + s7_pointer p1, p2, p3, p, ps1; + if ((is_pair(sc->args)) && (car(sc->args) == sc->unused)) + p1 = cdr(sc->args); + else + p1 = list_1(sc, sc->args); + ps1 = stack_protected1(sc); + if ((is_pair(ps1)) && (car(ps1) == sc->unused)) + p2 = cdr(ps1); + else + p2 = list_1(sc, ps1); + if ((is_pair(sc->value)) && (car(sc->value) == sc->unused)) + p3 = cdr(sc->value); + else + p3 = list_1(sc, sc->value); + unstack(sc); + for (p = p1; is_pair(cdr(p)); p = cdr(p)); + set_cdr(p, p2); + for (p = cdr(p); is_pair(cdr(p)); p = cdr(p)); + set_cdr(p, p3); + sc->args = p1; + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static Inline bool collect_np_args(s7_scheme * sc, opcode_t op, + s7_pointer args) +{ + s7_pointer p; + sc->args = args; + for (p = sc->code; is_pair(p); p = cdr(p)) + if (has_fx(p)) + sc->args = cons(sc, sc->value = fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */ + else if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1)) + sc->args = cons(sc, sc->value = + fx_proc_unchecked(p) (sc, car(p)), sc->args); + else { + push_stack(sc, op, sc->args, cdr(p)); + sc->code = T_Pair(car(p)); + return (true); + } + return (false); +} + +static bool op_any_c_np(s7_scheme * sc) +{ /* code: (func . args) where at least one arg is not fxable */ + s7_pointer p; + sc->args = sc->nil; + for (p = cdr(sc->code); is_pair(p); p = cdr(p)) + if (has_fx(p)) + sc->args = cons(sc, sc->value = fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */ + else if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1)) + sc->args = cons(sc, sc->value = + fx_proc_unchecked(p) (sc, car(p)), sc->args); + else { + if (sc->op_stack_now >= sc->op_stack_end) + resize_op_stack(sc); + push_op_stack(sc, sc->code); + check_stack_size(sc); + push_stack(sc, ((intptr_t) + ((is_pair(cdr(p))) ? OP_ANY_C_NP_1 : + OP_ANY_C_NP_2)), sc->args, cdr(p)); + sc->code = T_Pair(car(p)); + return (true); + } + /* here fx/gx got all the args */ + sc->args = proper_list_reverse_in_place(sc, sc->args); + sc->value = fn_proc(sc->code) (sc, sc->args); + return (false); +} + +static Inline bool op_any_c_np_1(s7_scheme * sc) +{ + /* in-coming sc->value has the current arg value, sc->args is all previous args, sc->code is on op-stack */ + if (collect_np_args(sc, OP_ANY_C_NP_1, cons(sc, sc->value, sc->args))) + return (true); + sc->args = proper_list_reverse_in_place(sc, sc->args); + sc->code = pop_op_stack(sc); + sc->value = fn_proc(sc->code) (sc, sc->args); + return (false); +} + +static void op_any_c_np_2(s7_scheme * sc) +{ + sc->args = proper_list_reverse_in_place(sc, sc->args = + cons(sc, sc->value, sc->args)); + sc->code = pop_op_stack(sc); + sc->value = fn_proc(sc->code) (sc, sc->args); +} + +static s7_pointer revappend(s7_scheme * sc, s7_pointer a, s7_pointer b) +{ + /* (map (lambda (x) (if (odd? x) (apply values '(1 2 3)) (values))) (list 1 2 3 4)) is a bad case -- we have to copy the incoming list (in op_map_gather) */ + s7_pointer p = b, q; + if (is_not_null(a)) { + a = copy_proper_list(sc, a); + do { /* while (is_not_null(a)) */ + q = cdr(a); + set_cdr(a, p); + p = a; + a = q; + } + while (is_pair(a)); + } + return (p); +} + +static bool op_any_c_np_mv_1(s7_scheme * sc) +{ + /* we're looping through fp cases here, so sc->value can be non-mv after the first */ + if (collect_np_args + (sc, OP_ANY_C_NP_MV_1, + (is_multiple_value(sc->value)) ? revappend(sc, sc->value, + sc->args) : cons(sc, + sc->value, + sc->args))) + return (true); + sc->args = proper_list_reverse_in_place(sc, sc->args); + sc->code = pop_op_stack(sc); + sc->code = c_function_base(opt1_cfunc(sc->code)); + return (false); +} + +static void op_any_closure_np(s7_scheme * sc) +{ + s7_pointer p; + check_stack_size(sc); + if (sc->op_stack_now >= sc->op_stack_end) + resize_op_stack(sc); + push_op_stack(sc, sc->code); + p = cdr(sc->code); + if (has_fx(p)) { + sc->args = fx_call(sc, p); + sc->args = list_1(sc, sc->args); + for (p = cdr(p); (is_pair(p)) && (has_fx(p)); p = cdr(p)) + sc->args = cons_unchecked(sc, fx_call(sc, p), sc->args); + } else + sc->args = sc->nil; + push_stack(sc, ((intptr_t) + ((is_pair(cdr(p))) ? OP_ANY_CLOSURE_NP_1 : + OP_ANY_CLOSURE_NP_2)), sc->args, cdr(p)); + sc->code = T_Pair(car(p)); +} + +static void op_any_closure_np_end(s7_scheme * sc) +{ + s7_pointer x, z, f; + uint64_t id; + + sc->args = proper_list_reverse_in_place(sc, sc->args); /* needed in either case -- closure_args(f) is not reversed */ + sc->code = pop_op_stack(sc); + f = opt1_lambda(sc->code); + + if (is_safe_closure(f)) { + id = ++sc->let_number; + set_curlet(sc, closure_let(f)); + let_set_id(sc->curlet, id); + + for (x = let_slots(sc->curlet), z = sc->args; tis_slot(x); + x = next_slot(x)) { + s7_pointer nz; + slot_set_value(x, car(z)); + symbol_set_local_slot(slot_symbol(x), id, x); + nz = cdr(z); + free_cell(sc, z); + z = nz; + } + if (tis_slot(x)) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, not_enough_arguments_string, sc->code, + sc->args)); + } else { + s7_pointer e, p, last_slot; + e = make_let(sc, closure_let(f)); + sc->z = e; + id = let_id(e); + p = closure_args(f); + last_slot = make_slot(sc, car(p), car(sc->args)); + slot_set_next(last_slot, slot_end(sc)); + let_set_slots(e, last_slot); + symbol_set_local_slot(car(p), id, last_slot); + + z = cdr(sc->args); + free_cell(sc, sc->args); + for (p = cdr(p); is_pair(p); p = cdr(p)) { + s7_pointer nz; + last_slot = add_slot_at_end(sc, id, last_slot, car(p), car(z)); /* sets last_slot */ + nz = cdr(z); + free_cell(sc, z); + z = nz; + } + set_curlet(sc, e); + sc->z = sc->nil; + if (is_pair(p)) + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, not_enough_arguments_string, sc->code, + sc->args)); + } + if (is_pair(z)) /* these checks are needed because multiple-values might evade earlier arg num checks */ + s7_error(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, sc->code, + sc->args)); + + f = closure_body(f); + if (is_pair(cdr(f))) + push_stack_no_args(sc, sc->begin_op, cdr(f)); + sc->code = car(f); +} + +static bool op_safe_c_ap(s7_scheme * sc) +{ + s7_pointer val, code = cdr(sc->code); + val = cdr(code); + if ((has_gx(val)) && (symbol_ctr(caar(val)) == 1)) { + val = fx_proc_unchecked(val) (sc, car(val)); + gc_protect_via_stack(sc, val); + set_car(sc->t2_1, fx_call(sc, code)); + set_car(sc->t2_2, val); + unstack(sc); + sc->value = fn_proc(sc->code) (sc, sc->t2_1); + return (false); + } + check_stack_size(sc); + sc->args = fx_call(sc, code); + push_stack_direct(sc, (opcode_t) opt1_any(code)); /* safe_c_sp cases, mv->safe_c_sp_mv */ + sc->code = car(val); + return (true); +} + +static bool op_safe_c_pa(s7_scheme * sc) +{ + s7_pointer args = cdr(sc->code); + if ((has_gx(args)) && (symbol_ctr(caar(args)) == 1)) { + s7_pointer val; + val = fx_proc_unchecked(args) (sc, car(args)); + gc_protect_via_stack(sc, val); + set_car(sc->t2_2, fx_call(sc, cdr(args))); + set_car(sc->t2_1, val); + unstack(sc); + sc->value = fn_proc(sc->code) (sc, sc->t2_1); + return (false); + } + check_stack_size(sc); + push_stack_no_args(sc, OP_SAFE_C_PA_1, sc->code); + sc->code = car(args); + return (true); +} + +static void op_safe_c_pa_1(s7_scheme * sc) +{ + s7_pointer val = sc->value; + gc_protect_via_stack(sc, val); /* not a temp */ + set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); + set_car(sc->t2_1, val); + unstack(sc); + sc->value = fn_proc(sc->code) (sc, sc->t2_1); +} + +static void op_safe_c_pa_mv(s7_scheme * sc) +{ + s7_pointer p, val; + val = copy_proper_list(sc, sc->value); /* this is necessary since the fx_proc below can clobber sc->value */ + gc_protect_via_stack(sc, val); + for (p = val; is_pair(cdr(p)); p = cdr(p)); /* must be more than 1 member of list or it's not mv */ + sc->args = fx_call(sc, cddr(sc->code)); + cdr(p) = set_plist_1(sc, sc->args); /* do we need to copy sc->args if it is immutable (i.e. plist)? */ + sc->args = val; + unstack(sc); + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static void op_safe_c_opsq_p(s7_scheme * sc) +{ + s7_pointer args = cadr(sc->code); + check_stack_size(sc); /* snd-test 23 */ + set_car(sc->t1_1, lookup(sc, cadr(args))); + sc->args = fn_proc(args) (sc, sc->t1_1); + push_stack_direct(sc, (opcode_t) opt1_any(cdr(sc->code))); + sc->code = caddr(sc->code); +} + +static void op_c_na(s7_scheme * sc) +{ /* (set-cdr! lst ()) */ + s7_pointer args, p, new_args; + new_args = make_list(sc, integer(opt3_arglen(cdr(sc->code))), sc->nil); + sc->args = new_args; + for (args = cdr(sc->code), p = new_args; is_pair(args); + args = cdr(args), p = cdr(p)) + set_car(p, fx_call(sc, args)); + sc->value = fn_proc(sc->code) (sc, new_args); +} + +static void op_c_p_mv(s7_scheme * sc) +{ /* op_c_p_1 -> mv case: (define (hi) (format (values #f "~A ~D" 1 2))) */ + sc->code = c_function_base(opt1_cfunc(sc->code)); /* see comment above */ + sc->args = copy_proper_list(sc, sc->value); +} + +static void op_c_a(s7_scheme * sc) +{ + sc->value = fx_call(sc, cdr(sc->code)); /* gc protect result before list_1 */ + sc->args = list_1(sc, sc->value); + sc->value = fn_proc(sc->code) (sc, sc->args); +} + +static void op_c_p(s7_scheme * sc) +{ + push_stack_no_args_direct(sc, OP_C_P_1); + sc->code = T_Pair(cadr(sc->code)); +} + +static inline void op_c_ss(s7_scheme * sc) +{ + sc->args = + list_2(sc, lookup(sc, cadr(sc->code)), + lookup(sc, caddr(sc->code))); + sc->value = fn_proc(sc->code) (sc, sc->args); +} + +static void op_c_ap(s7_scheme * sc) +{ + sc->args = fx_call(sc, cdr(sc->code)); + push_stack_direct(sc, OP_C_AP_1); /* op_c_ap_1 sends us to apply which calls check_stack_size I think */ + sc->code = caddr(sc->code); +} + +static void op_c_ap_mv(s7_scheme * sc) +{ + clear_multiple_value(sc->value); + sc->args = cons(sc, sc->args, sc->value); + sc->code = c_function_base(opt1_cfunc(sc->code)); +} + +static void op_c_aa(s7_scheme * sc) +{ + gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code))); + stack_protected2(sc) = fx_call(sc, cddr(sc->code)); + sc->value = list_2(sc, stack_protected1(sc), stack_protected2(sc)); + unstack(sc); /* fn_proc here is unsafe so clear stack first */ + sc->value = fn_proc(sc->code) (sc, sc->value); +} + +static inline void op_c_s(s7_scheme * sc) +{ + sc->args = list_1(sc, lookup(sc, cadr(sc->code))); + sc->value = fn_proc(sc->code) (sc, sc->args); +} + +static Inline void op_apply_ss(s7_scheme * sc) +{ + /* these used to check sc->code (i.e. "apply") if not h_optimized, but that still assumed we'd apply cadr to cddr. + * should we check that apply has not been set!? + */ + sc->args = lookup(sc, opt2_sym(sc->code)); /* is this right if code=macro? */ + sc->code = lookup(sc, cadr(sc->code)); /* global search here was slower (e.g. tauto) */ + if (needs_copied_args(sc->code)) + sc->args = copy_proper_list_with_arglist_error(sc, sc->args); + else if (!s7_is_proper_list(sc, sc->args)) /* (apply + #f) etc */ + apply_list_error(sc, sc->args); +} + +static void op_apply_sa(s7_scheme * sc) +{ + s7_pointer p = cdr(sc->code); + sc->args = fx_call(sc, cdr(p)); + sc->code = lookup_global(sc, car(p)); + if (needs_copied_args(sc->code)) + sc->args = copy_proper_list_with_arglist_error(sc, sc->args); + else if (!s7_is_proper_list(sc, sc->args)) /* (apply + #f) etc */ + apply_list_error(sc, sc->args); +} + +static void op_apply_sl(s7_scheme * sc) +{ + s7_pointer p = cdr(sc->code); + sc->args = fx_call(sc, cdr(p)); + sc->code = lookup_global(sc, car(p)); +} + +static void op_eval_args2(s7_scheme * sc) +{ + sc->code = pop_op_stack(sc); + sc->args = + (is_null(sc->args)) ? list_1(sc, + sc->value) : + proper_list_reverse_in_place(sc, cons(sc, sc->value, sc->args)); +} + +static void op_eval_args3(s7_scheme * sc) +{ + s7_pointer val = sc->code; + if (is_symbol(val)) + val = lookup_checked(sc, val); + sc->args = + proper_list_reverse_in_place(sc, + cons_unchecked(sc, val, + cons(sc, sc->value, + sc->args))); + sc->code = pop_op_stack(sc); +} + +static void op_eval_args5(s7_scheme * sc) +{ /* sc->value is the last arg, sc->code is the previous */ + sc->args = + proper_list_reverse_in_place(sc, + cons_unchecked(sc, sc->value, + cons(sc, sc->code, + sc->args))); + sc->code = pop_op_stack(sc); +} + +static bool eval_args_no_eval_args(s7_scheme * sc) +{ + if ((is_any_macro(sc->value)) /* || (is_syntax(sc->value)) */ ) { + if (!s7_is_proper_list(sc, cdr(sc->code))) + s7_error(sc, sc->syntax_error_symbol, + set_elist_2(sc, + wrap_string(sc, + "improper list of arguments: ~S", + 30), sc->code)); + sc->args = cdr(sc->code); + if (is_symbol(car(sc->code))) { /* not ((f p) args...) where (f p) has returned a macro, op_macro_d assumes car is a symbol */ + if (is_macro(sc->value)) + set_optimize_op(sc->code, OP_MACRO_D); + if (is_macro_star(sc->value)) + set_optimize_op(sc->code, OP_MACRO_STAR_D); + } + sc->code = sc->value; + return (true); + } + /* (define progn begin) (progn (display "hi") (+ 1 23)) */ + if (is_syntactic_pair(sc->code)) + sc->cur_op = optimize_op(sc->code); + else { + sc->cur_op = syntax_opcode(sc->value); + pair_set_syntax_op(sc->code, sc->cur_op); + } + return (false); +} + +static void op_read_internal(s7_scheme * sc) +{ + /* if we're loading a file, and in the file we evaluate something like: + * (let () + * (set-current-input-port (open-input-file "tmp2.r5rs")) + * (close-input-port (current-input-port))) + * ... (with no reset of input port to its original value) + * the load process tries to read the loaded string, but the current-input-port is now closed, + * and the original is inaccessible! So we get a segfault in token. We don't want to put + * a port_is_closed check there because token only rarely is in this danger. I think this + * is the only place where we can be about to call token, and someone has screwed up our port. + */ + if (port_is_closed(current_input_port(sc))) + s7_error(sc, sc->read_error_symbol, /* not read_error here because it paws through the port string which doesn't exist here */ + set_elist_1(sc, + wrap_string(sc, + "our input port got clobbered!", + 29))); + + sc->tok = token(sc); + switch (sc->tok) { + case TOKEN_EOF: + break; + case TOKEN_RIGHT_PAREN: + read_error(sc, "unexpected close paren"); + case TOKEN_COMMA: + read_error(sc, "unexpected comma"); + default: + sc->value = read_expression(sc); + sc->current_line = port_line_number(current_input_port(sc)); /* this info is used to track down missing close parens */ + sc->current_file = port_filename(current_input_port(sc)); + break; + } +} + +static void op_read_done(s7_scheme * sc) +{ + pop_input_port(sc); + if (sc->tok == TOKEN_EOF) + sc->value = eof_object; + sc->current_file = NULL; /* this is for error handling */ +} + +static bool op_read_quasiquote(s7_scheme * sc) +{ + /* this was pushed when the backquote was seen, then eventually we popped back to it */ + sc->value = g_quasiquote_1(sc, sc->value, false); + /* doing quasiquote at read time means there are minor inconsistencies in various combinations or quote/' and quasiquote/`. + * A quoted ` will expand but quoted quasiquote will not (` can't be redefined, but quasiquote can). see s7test.scm for examples. + */ + return (main_stack_op(sc) != OP_READ_LIST); +} + +static bool pop_read_list(s7_scheme * sc) +{ + /* push-stack OP_READ_LIST is always no_code and op is always OP_READ_LIST (and not used), sc->curlet is apparently not needed here */ + unstack_with(sc, OP_READ_LIST); + sc->args = sc->stack_end[2]; + if (!is_null(sc->args)) + return (false); + sc->args = cons(sc, sc->value, sc->args); + pair_set_current_input_location(sc, sc->args); + return (true); +} + +static bool op_load_return_if_eof(s7_scheme * sc) +{ + if (sc->tok != TOKEN_EOF) { + push_stack_op_let(sc, OP_LOAD_RETURN_IF_EOF); + push_stack_op_let(sc, OP_READ_INTERNAL); + sc->code = sc->value; + return (true); /* we read an expression, now evaluate it, and return to read the next */ + } + sc->current_file = NULL; + return (false); +} + +static bool op_load_close_and_pop_if_eof(s7_scheme * sc) +{ + /* (load "file") in scheme: read and evaluate all exprs, then upon EOF, close current and pop input port stack */ + if (sc->tok != TOKEN_EOF) { + push_stack_op_let(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF); /* was push args, code */ + if ((!is_string_port(current_input_port(sc))) || + (port_position(current_input_port(sc)) < + port_data_size(current_input_port(sc)))) + push_stack_op_let(sc, OP_READ_INTERNAL); + else + sc->tok = TOKEN_EOF; + sc->code = sc->value; + return (true); /* we read an expression, now evaluate it, and return to read the next */ + } + if ((S7_DEBUGGING) && (!is_loader_port(current_input_port(sc)))) + fprintf(stderr, "%s not loading?\n", + display(current_input_port(sc))); + /* if *#readers* func hits error, clear_loader_port might not be undone? */ + s7_close_input_port(sc, current_input_port(sc)); + pop_input_port(sc); + sc->current_file = NULL; + if (is_multiple_value(sc->value)) /* (load "file") where "file" is (values 1 2 3) */ + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return (false); +} + +static bool op_read_apply_values(s7_scheme * sc) +{ + sc->value = + list_2_unchecked(sc, sc->unquote_symbol, + list_2(sc, sc->apply_values_symbol, sc->value)); + return (main_stack_op(sc) != OP_READ_LIST); +} + +static goto_t op_read_dot(s7_scheme * sc) +{ + token_t c; + c = token(sc); + if (c != TOKEN_RIGHT_PAREN) { /* '(1 . (2) 3) -> '(1 2 3), Guile says "missing close paren" */ + if (is_pair(sc->value)) { + s7_pointer p; + for (p = sc->value; is_pair(p); p = cdr(p)) + sc->args = cons(sc, car(p), sc->args); + sc->tok = c; + return (goto_read_tok); + } + back_up_stack(sc); + read_error(sc, "stray dot?"); /* (+ 1 . 2 3) or (list . ) */ + } + /* args = previously read stuff, value = thing just after the dot and before the ')': + * (list 1 2 . 3) -> value: 3, args: (2 1 list), '(1 . 2) -> value: 2, args: (1) + * but we also get here in a lambda arg list: (lambda (a b . c) #f) -> value: c, args: (b a) + */ + sc->value = any_list_reverse_in_place(sc, sc->value, sc->args); + return ((main_stack_op(sc) == + OP_READ_LIST) ? goto_pop_read_list : goto_start); +} + +static bool op_read_quote(s7_scheme * sc) +{ + /* can't check for sc->value = sc->nil here because we want ''() to be different from '() */ + if ((sc->safety > IMMUTABLE_VECTOR_SAFETY) && + ((is_pair(sc->value)) || (is_any_vector(sc->value)) + || (is_string(sc->value)))) + set_immutable(sc->value); + sc->value = list_2(sc, sc->quote_symbol, sc->value); + return (main_stack_op(sc) != OP_READ_LIST); +} + +static bool op_read_unquote(s7_scheme * sc) +{ + /* here if sc->value is a constant, the unquote is pointless (should we complain?) + * also currently stray "," can be ignored: (abs , 1) -- scanning the stack for quasiquote or quote seems to be unreliable + */ + if ((is_pair(sc->value)) || (is_symbol(sc->value))) + sc->value = list_2(sc, sc->unquote_symbol, sc->value); + return (main_stack_op(sc) != OP_READ_LIST); +} + +/* safety check is at read time, so (immutable? (let-temporarily (((*s7* 'safety) 2)) #(1 2 3))) is #f + * but (immutable? (let-temporarily (((*s7* 'safety) 2)) (eval-string "#(1 2 3)"))) is #t + * at run time we just see the vector + */ +static bool op_read_vector(s7_scheme * sc) +{ + sc->value = (sc->args == int_one) ? g_vector(sc, sc->value) : g_multivector(sc, integer(sc->args), sc->value); /* sc->args was sc->w earlier from read_sharp */ + /* here and below all of the sc->value list can be freed, but my tests showed no speed up even in large cases */ + if (sc->safety > IMMUTABLE_VECTOR_SAFETY) + set_immutable(sc->value); + return (main_stack_op(sc) != OP_READ_LIST); +} + +static bool op_read_int_vector(s7_scheme * sc) +{ + sc->value = + (sc->args == int_one) ? g_int_vector(sc, + sc->value) : + g_int_multivector(sc, integer(sc->args), sc->value); + if (sc->safety > IMMUTABLE_VECTOR_SAFETY) + set_immutable(sc->value); + return (main_stack_op(sc) != OP_READ_LIST); +} + +static bool op_read_float_vector(s7_scheme * sc) +{ + sc->value = + (sc->args == int_one) ? g_float_vector(sc, + sc->value) : + g_float_multivector(sc, integer(sc->args), sc->value); + if (sc->safety > IMMUTABLE_VECTOR_SAFETY) + set_immutable(sc->value); + return (main_stack_op(sc) != OP_READ_LIST); +} + +static bool op_read_byte_vector(s7_scheme * sc) +{ + sc->value = + (sc->args == int_one) ? g_byte_vector(sc, + sc->value) : + g_byte_multivector(sc, integer(sc->args), sc->value); + if (sc->safety > IMMUTABLE_VECTOR_SAFETY) + set_immutable(sc->value); + return (main_stack_op(sc) != OP_READ_LIST); +} + + +static inline void eval_last_arg(s7_scheme * sc, s7_pointer car_code) +{ + /* here we've reached the last arg (sc->code == nil), it is not a pair */ + if (!is_null(cdr(sc->code))) + improper_arglist_error(sc); + sc->code = (is_symbol(car_code)) ? lookup_checked(sc, car_code) : car_code; /* this has to precede the set_type below */ + sc->args = + (is_null(sc->args)) ? list_1(sc, + sc->code) : + proper_list_reverse_in_place(sc, cons(sc, sc->code, sc->args)); + sc->code = pop_op_stack(sc); +} + +static inline void eval_args_pair_car(s7_scheme * sc) +{ + s7_pointer code = cdr(sc->code); + if (sc->stack_end >= sc->stack_resize_trigger) + check_for_cyclic_code(sc, sc->code); + /* all 3 of these push_stacks can result in stack overflow, see above 64065 */ + if (is_null(code)) + push_stack_no_code(sc, OP_EVAL_ARGS2, sc->args); + else { + if (!is_pair(code)) /* (= 0 '(1 . 2) . 3) */ + improper_arglist_error(sc); + if ((is_null(cdr(code))) && (!is_pair(car(code)))) + push_stack(sc, OP_EVAL_ARGS3, sc->args, car(code)); + else + push_stack(sc, OP_EVAL_ARGS4, sc->args, code); + } + sc->code = car(sc->code); +} + +static bool eval_car_pair(s7_scheme * sc) +{ + s7_pointer code = sc->code, carc = car(code); + /* evaluate the inner list but that list can be circular: carc: #1=(#1# #1#)! + * and the cycle can be well-hidden -- #1=((#1 2) . 2) and other such stuff + */ + if (sc->stack_end >= sc->stack_resize_trigger) + check_for_cyclic_code(sc, code); + push_stack(sc, OP_EVAL_ARGS, sc->nil, code); + + if (is_symbol_and_syntactic(car(carc))) + /* was checking for is_syntactic (pair or symbol) here but that can be confused by successive optimizer passes: (define (hi) (((lambda () list)) 1 2 3)) etc */ + { + if ((car(carc) == sc->quote_symbol) && /* ('and #f) */ + ((!is_pair(cdr(carc))) || /* ((quote . #\h) (2 . #\i)) ! */ + (is_symbol_and_syntactic(cadr(carc))))) /* ('or #f) but not ('#_or #f) */ + apply_error(sc, (is_pair(cdr(carc))) ? cadr(carc) : carc, + cdr(code)); +#if 0 + /* if ((lambda ...)), check for ((lambda () ...)) and unwrap it to ...: need an operator here to skip these checks (and need optimization of lambda body etc) */ + /* this is slower than going to op_lambda via eval_car_pair below, both much slower than code without the idiotic lambda */ + if (car(carc) == sc->lambda_symbol) { + if ((is_null(cadr(carc))) && (is_pair(cddr(carc))) && (is_null(cdddr(carc))) && /* else wrap in (let ()...) */ + (!((is_pair(caddr(carc))) && (is_syntax(caaddr(carc))) + && (is_syntax_definer(caaddr(carc)))))) { + sc->stack_end -= 4; /* avoid debugger complaint */ + sc->code = caddr(carc); + return (true); + } + } +#endif + sc->code = carc; + if (!no_cell_opt(carc)) { + if ((car(carc) == sc->if_symbol) && (is_pair(cdr(code))) && /* check that we got one or two args */ + ((is_null(cddr(code))) || + ((is_pair(cddr(code))) && (is_null(cdddr(code)))))) { + check_if(sc, carc); + if ((fx_function[optimize_op(carc)]) && (is_fxable(sc, cadr(code))) && ((is_null(cddr(code))) || (is_fxable(sc, caddr(code))))) { /* checked cdddr above */ + fx_annotate_args(sc, cdr(code), sc->curlet); + set_fx_direct(code, fx_function[optimize_op(carc)]); + set_optimize_op(code, + (is_null(cddr(code))) ? OP_A_A : + OP_A_AA); + return (false); /* goto eval in trailers */ + } + } + set_no_cell_opt(carc); + } + sc->cur_op = (opcode_t) symbol_syntax_op_checked(sc->code); + pair_set_syntax_op(sc->code, sc->cur_op); + return (true); + } + if ((is_pair(cdr(code))) && (is_optimized(carc))) { + if ((fx_function[optimize_op(carc)]) && + (is_fxable(sc, cadr(code))) && + ((is_null(cddr(code))) || + ((is_fxable(sc, caddr(code))) && (is_null(cdddr(code)))))) { + fx_annotate_args(sc, cdr(code), sc->curlet); + set_fx_direct(code, fx_function[optimize_op(carc)]); + set_optimize_op(code, + (is_null(cddr(code))) ? OP_A_A : OP_A_AA); + sc->code = carc; + return (false); /* goto eval in trailers */ + } + if ((is_null(cddr(code))) && (is_symbol(cadr(code)))) { + set_optimize_op(code, OP_P_S); + set_opt3_sym(code, cadr(code)); + } + /* OP_P_ALL_A runs into opt2 fx overwrites in a case like ((values set!) x 32) */ + else + set_optimize_op(code, OP_PAIR_PAIR); + } else + set_optimize_op(code, OP_PAIR_PAIR); + + push_stack(sc, OP_EVAL_ARGS, sc->nil, carc); + sc->code = car(carc); + return (false); +} + +static inline bool eval_args_last_arg(s7_scheme * sc) +{ + s7_pointer car_code = car(sc->code); /* we're at the last arg, sc->value is the previous one, not yet saved in the args list */ + if (is_pair(car_code)) { + if (sc->stack_end >= sc->stack_resize_trigger) + check_for_cyclic_code(sc, sc->code); + push_stack(sc, OP_EVAL_ARGS5, sc->args, sc->value); + sc->code = car_code; + return (true); + } + /* get the last arg */ + sc->code = + (is_symbol(car_code)) ? lookup_checked(sc, car_code) : car_code; + /* get the current arg, which is not a list */ + sc->args = + proper_list_reverse_in_place(sc, + cons_unchecked(sc, sc->code, + cons(sc, sc->value, + sc->args))); + sc->code = pop_op_stack(sc); + return (false); +} + +static void op_pair_pair(s7_scheme * sc) +{ + if (sc->stack_end >= (sc->stack_resize_trigger - 8)) { + check_for_cyclic_code(sc, sc->code); + resize_stack(sc); + } + push_stack(sc, OP_EVAL_ARGS, sc->nil, sc->code); /* eval args goes immediately to cdr(sc->code) */ + /* don't put check_stack_size here! */ + push_stack(sc, OP_EVAL_ARGS, sc->nil, car(sc->code)); + sc->code = caar(sc->code); +} + +static goto_t trailers(s7_scheme * sc) +{ + s7_pointer code = sc->code; + if (is_pair(code)) { + s7_pointer carc = car(code); + if (is_symbol(carc)) { + /* car is a symbol, sc->code a list */ + if (is_syntactic_symbol(carc)) { + sc->cur_op = (opcode_t) symbol_syntax_op_checked(code); + pair_set_syntax_op(sc->code, sc->cur_op); + return (goto_top_no_pop); + } + sc->value = lookup_global(sc, carc); + set_optimize_op(code, OP_PAIR_SYM); /* mostly stuff outside functions (unopt) */ + return (goto_eval_args_top); + } + if (is_pair(carc)) /* ((if x y z) a b) etc */ + return ((eval_car_pair(sc)) ? goto_top_no_pop : goto_eval); + + /* here we can get syntax objects like quote */ + if (is_syntax(carc)) { + sc->cur_op = (opcode_t) syntax_opcode(carc); + pair_set_syntax_op(sc->code, sc->cur_op); + return (goto_top_no_pop); + } + /* car must be the function to be applied, or (for example) a syntax variable like quote that has been used locally */ + set_optimize_op(code, OP_PAIR_ANY); /* usually an error: (#\a) etc, might be (#(0) 0) */ + sc->value = T_Pos(carc); + return (goto_eval_args_top); + } + if (is_symbol(code)) { + sc->value = lookup_checked(sc, code); + set_optimize_op(code, + (is_keyword(code)) ? OP_CON : ((is_global(code)) ? + OP_GLOBAL_SYM : + OP_SYM)); + } else { + sc->value = T_Pos(code); + set_optimize_op(code, OP_CON); + } + return (goto_start); +} + +static Inline void op_map_gather(s7_scheme * sc) +{ + if (sc->value != sc->no_value) { + if (is_multiple_value(sc->value)) + counter_set_result(sc->args, + revappend(sc, multiple_value(sc->value), + counter_result(sc->args))); + else + counter_set_result(sc->args, + cons(sc, sc->value, + counter_result(sc->args))); + } +} + + +/* ---------------- unknown ops ---------------- */ +static bool fixup_unknown_op(s7_pointer code, s7_pointer func, opcode_t op) +{ + set_optimize_op(code, op); + if (is_any_closure(func)) + set_opt1_lambda(code, func); /* perhaps set_opt1_lambda_add here and throughout op_unknown* */ + return (true); +} + +static bool unknown_unknown(s7_scheme * sc, s7_pointer code, opcode_t op) +{ + if ((is_symbol(car(code))) && + (!is_slot(lookup_slot_from(car(code), sc->curlet)))) + unbound_variable_error(sc, car(code)); + set_optimize_op(code, op); + return (true); +} + +static bool is_immutable_and_stable(s7_scheme * sc, s7_pointer func) +{ + s7_pointer p; + if (symbol_ctr(func) != 1) /* protect against (define-constant (p) (define-constant (p) ...)) */ + return (false); + if ((is_global(func)) && (is_immutable_slot(global_slot(func)))) + return (true); + for (p = sc->curlet; is_let(p); p = let_outlet(p)) + if ((is_funclet(p)) && (funclet_function(p) != func)) + return (false); + p = lookup_slot_from(func, sc->curlet); + return (is_immutable_slot(p)); +} + +static bool op_unknown(s7_scheme * sc) +{ + s7_pointer code, f = sc->last_function; + if (!f) /* can be NULL if unbound variable */ + unbound_variable_error(sc, car(sc->code)); + /* perhaps set op to OP_CLEAR_OPTS and return(true) above */ + +#if SHOW_EVAL_OPS + fprintf(stderr, "%s %s %s\n", __func__, display(f), + s7_type_names[type(f)]); +#endif + + code = sc->code; + switch (type(f)) { + case T_CLOSURE: + case T_CLOSURE_STAR: + if (!has_methods(f)) { + int32_t hop = 0; + if (is_immutable_and_stable(sc, car(code))) + hop = 1; + + if (is_null(closure_args(f))) { + s7_pointer body = closure_body(f); + bool safe_case = is_safe_closure(f); + set_opt1_lambda(code, f); + + if (is_null(cdr(body))) { + if ((safe_case) && (is_fxable(sc, car(body)))) { + set_safe_closure(f); /* safe because no args so no reference to funclet? needed because op_safe_thunk_a will check for it */ + fx_annotate_arg(sc, body, sc->curlet); + set_safe_optimize_op(code, hop + OP_SAFE_THUNK_A); + set_closure_one_form_fx_arg(f); + sc->value = fx_safe_thunk_a(sc, sc->code); + return (false); + } + clear_has_fx(code); + } + set_safe_optimize_op(code, + hop + + ((safe_case) ? OP_SAFE_THUNK : + OP_THUNK)); + return (true); + } + if (is_closure_star(f)) { + set_safe_optimize_op(code, + hop + + ((is_safe_closure(f)) ? + OP_SAFE_CLOSURE_STAR_NA_0 : + OP_CLOSURE_STAR_NA)); + set_opt1_lambda(code, f); + return (true); + } + } + break; + + case T_GOTO: + return (fixup_unknown_op(code, f, OP_IMPLICIT_GOTO)); + case T_ITERATOR: + return (fixup_unknown_op(code, f, OP_IMPLICIT_ITERATE)); + case T_MACRO: + return (fixup_unknown_op(code, f, OP_MACRO_D)); + case T_MACRO_STAR: + return (fixup_unknown_op(code, f, OP_MACRO_STAR_D)); + + default: + if ((is_symbol(car(code))) && + (!is_slot(lookup_slot_from(car(code), sc->curlet)))) + unbound_variable_error(sc, car(code)); + } + return (fixup_unknown_op(code, f, OP_S)); +} + +static bool fxify_closure_star_g(s7_scheme * sc, s7_pointer f, + s7_pointer code) +{ + if ((!has_methods(f)) && (closure_star_arity_to_int(sc, f) != 0)) { + int32_t hop = 0; + bool safe_case; + if (is_immutable_and_stable(sc, car(code))) + hop = 1; + + fx_annotate_arg(sc, cdr(code), sc->curlet); + set_opt3_arglen(cdr(code), int_one); + safe_case = is_safe_closure(f); + + if ((safe_case) && (is_null(cdr(closure_args(f))))) + set_optimize_op(code, hop + OP_SAFE_CLOSURE_STAR_A1); + else if (lambda_has_simple_defaults(f)) { + if (arglist_has_rest(sc, closure_args(f))) + fixup_unknown_op(code, f, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : + OP_CLOSURE_STAR_NA)); + else + fixup_unknown_op(code, f, hop + ((safe_case) ? + ((is_null + (cdr(closure_args(f)))) + ? OP_SAFE_CLOSURE_STAR_A1 + : OP_SAFE_CLOSURE_STAR_A) + : OP_CLOSURE_STAR_A)); + return (true); + } + fixup_unknown_op(code, f, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : + OP_CLOSURE_STAR_NA)); + return (true); + } + return (false); +} + +static bool op_unknown_g(s7_scheme * sc) +{ + s7_pointer code, f = sc->last_function; + bool sym_case; + + if (!f) + unbound_variable_error(sc, car(sc->code)); + if (SHOW_EVAL_OPS) + fprintf(stderr, "%s %s\n", __func__, display(f)); + + code = sc->code; + sym_case = is_normal_symbol(cadr(code)); + + if ((sym_case) && (!is_any_macro(f)) && /* if f is a macro, its argument can be unbound legitimately */ + (!is_slot(lookup_slot_from(cadr(code), sc->curlet)))) + return (unknown_unknown(sc, sc->code, (is_normal_symbol(cadr(sc->code))) ? OP_CLEAR_OPTS : OP_S_C)); /* not OP_S_S here! */ + + if ((is_unknopt(code)) && (!is_closure(f))) + return (fixup_unknown_op(code, f, (sym_case) ? OP_S_S : OP_S_C)); + + switch (type(f)) { + case T_C_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + if ((c_function_required_args(f) > 1) || + (c_function_all_args(f) == 0)) + break; + + case T_C_OPT_ARGS_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + if (sym_case) { + set_c_function(code, f); + if (is_safe_procedure(f)) { + set_optimize_op(code, OP_SAFE_C_S); + sc->value = fx_c_s(sc, sc->code); + } else { + set_optimize_op(code, OP_C_S); + op_c_s(sc); + } + return (false); + } + if (is_safe_procedure(f)) { + set_optimize_op(code, OP_SAFE_C_NC); + set_c_function(code, f); + return (true); + } + break; + + case T_CLOSURE: + if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == 1)) { + s7_pointer body = closure_body(f); + int32_t hop = 0; + set_opt2_sym(code, cadr(code)); + if (is_immutable_and_stable(sc, car(code))) + hop = 1; + + /* code here might be (f x) where f is passed elsewhere as a function parameter, + * first time through we look it up, find a safe-closure and optimize as (say) safe_closure_s_a, + * next time it is something else, etc. Rather than keep optimizing it locally, we need to + * back out: safe_closure_s_* -> safe_closure_s -> closure_s -> op_s_s. Ideally we'd know + * this was a parameter or whatever. The tricky case is local letrec(f) calling f which initially + * thinks it is not safe, then later is set safe correctly, now outer func is called again, + * this time f is safe, and we're ok from then on. + */ + if (is_unknopt(code)) { + /* fprintf(stderr, "unknopt %s %s %s %s %p %d %s\n", + op_names[optimize_op(car(body))], display(f), display(car(body)), display(code), code, is_safe_closure(f), describe_type_bits(sc, f)); + */ + switch (op_no_hop(code)) { + case OP_CLOSURE_S: + set_optimize_op(code, + (is_safe_closure(f)) ? + OP_SAFE_CLOSURE_S : OP_S_S); + break; + case OP_CLOSURE_S_O: + case OP_SAFE_CLOSURE_S: + set_optimize_op(code, OP_CLOSURE_S); + break; + case OP_SAFE_CLOSURE_S_O: + case OP_SAFE_CLOSURE_S_A: + case OP_SAFE_CLOSURE_S_TO_S: + case OP_SAFE_CLOSURE_S_TO_SC: + set_optimize_op(code, + (is_safe_closure(f)) ? + OP_SAFE_CLOSURE_S : OP_CLOSURE_S); + break; + default: + set_optimize_op(code, OP_S_S); + break; + } + set_opt1_lambda(code, f); + return (true); + } + if (is_safe_closure(f)) { + if (is_null(cdr(body))) { + if (is_fxable(sc, car(body))) + fxify_closure_s(sc, f, code, sc->curlet, hop); + else + set_safe_optimize_op(code, + hop + OP_SAFE_CLOSURE_S_O); + /* hop if is_constant(sc, car(code)) is not foolproof here (see t967.scm): + * (define (f) (define-constant (f1) ... (f1))...) where each call on f makes a different f1 + */ + } else + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_S); + } else if (is_null(cdr(body))) + set_optimize_op(code, hop + OP_CLOSURE_S_O); + else + set_optimize_op(code, hop + OP_CLOSURE_S); + set_is_unknopt(code); + set_opt1_lambda(code, f); + return (true); + } + break; + + case T_CLOSURE_STAR: + if (fxify_closure_star_g(sc, f, code)) + return (true); + break; + + case T_GOTO: + fx_annotate_arg(sc, cdr(code), sc->curlet); + set_opt3_arglen(cdr(code), int_one); + return (fixup_unknown_op(code, f, OP_IMPLICIT_GOTO_A)); + + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + case T_BYTE_VECTOR: + if ((sym_case) || /* (v i) */ + (is_t_integer(cadr(code)))) { /* (v 4/3) */ + fx_annotate_arg(sc, cdr(code), sc->curlet); + return (fixup_unknown_op(code, f, OP_IMPLICIT_VECTOR_REF_A)); + } + break; + + case T_STRING: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return (fixup_unknown_op(code, f, OP_IMPLICIT_STRING_REF_A)); + + case T_PAIR: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return (fixup_unknown_op(code, f, OP_IMPLICIT_PAIR_REF_A)); + + case T_C_OBJECT: + if (s7_is_aritable(sc, f, 1)) { + fx_annotate_arg(sc, cdr(code), sc->curlet); + return (fixup_unknown_op(code, f, OP_IMPLICIT_C_OBJECT_REF_A)); + } + break; + + case T_LET: + if (sym_case) { + fx_annotate_arg(sc, cdr(code), sc->curlet); + return (fixup_unknown_op(code, f, OP_IMPLICIT_LET_REF_A)); + } + set_opt3_con(code, cadr(code)); + return (fixup_unknown_op(code, f, OP_IMPLICIT_LET_REF_C)); + + case T_HASH_TABLE: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return (fixup_unknown_op(code, f, OP_IMPLICIT_HASH_TABLE_REF_A)); + + case T_CONTINUATION: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return (fixup_unknown_op(code, f, OP_IMPLICIT_CONTINUATION_A)); + + case T_MACRO: + return (fixup_unknown_op(code, f, OP_MACRO_D)); + case T_MACRO_STAR: + return (fixup_unknown_op(code, f, OP_MACRO_STAR_D)); + + default: + break; + } + if ((is_symbol(car(code))) && + (!is_slot(lookup_slot_from(car(code), sc->curlet)))) + unbound_variable_error(sc, car(code)); + return (fixup_unknown_op(code, f, (sym_case) ? OP_S_S : OP_S_C)); +} + +static bool op_unknown_a(s7_scheme * sc) +{ + s7_pointer code, f = sc->last_function; + if (!f) + unbound_variable_error(sc, car(sc->code)); + if (SHOW_EVAL_OPS) + fprintf(stderr, "%s %s\n", __func__, display(f)); + + code = sc->code; + switch (type(f)) { + case T_C_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + if ((c_function_required_args(f) > 1) || + (c_function_all_args(f) == 0)) + break; + case T_C_OPT_ARGS_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + clear_has_fx(code); + set_c_function(code, f); + if (is_safe_procedure(f)) { + set_optimize_op(code, OP_SAFE_C_A); + sc->value = fx_c_a(sc, code); + } else { + set_optimize_op(code, OP_C_A); + op_c_a(sc); + } + return (false); + + case T_CLOSURE: + if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == 1)) { + s7_pointer body = closure_body(f); + bool one_form, safe_case = is_safe_closure(f); + int32_t hop = 0; + + one_form = is_null(cdr(body)); + if (is_immutable_and_stable(sc, car(code))) + hop = 1; + fxify_closure_a(sc, f, one_form, safe_case, hop, code, + sc->curlet); + + /* we might not be in "f" I think, tree_memq(sc, code, body)?? */ + if ((safe_case) && + (!has_fx(cdr(code))) && + (is_very_safe_closure(f)) && + (!tree_has_definers_or_binders(sc, body)) && + (s7_tree_memq(sc, code, body))) + fx_tree(sc, cdr(code), car(closure_args(f)), NULL, NULL, + false); + + set_opt1_lambda(code, f); + return (true); + } + break; + + case T_CLOSURE_STAR: + if (fxify_closure_star_g(sc, f, code)) + return (true); + break; + + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + case T_BYTE_VECTOR: + return (fixup_unknown_op(code, f, OP_IMPLICIT_VECTOR_REF_A)); + + case T_STRING: + return (fixup_unknown_op(code, f, OP_IMPLICIT_STRING_REF_A)); + case T_PAIR: + return (fixup_unknown_op(code, f, OP_IMPLICIT_PAIR_REF_A)); + case T_C_OBJECT: + return (fixup_unknown_op(code, f, OP_IMPLICIT_C_OBJECT_REF_A)); + case T_HASH_TABLE: + return (fixup_unknown_op(code, f, OP_IMPLICIT_HASH_TABLE_REF_A)); + case T_GOTO: + return (fixup_unknown_op(code, f, OP_IMPLICIT_GOTO_A)); + case T_CONTINUATION: + return (fixup_unknown_op(code, f, OP_IMPLICIT_CONTINUATION_A)); + case T_MACRO: + return (fixup_unknown_op(code, f, OP_MACRO_D)); + case T_MACRO_STAR: + return (fixup_unknown_op(code, f, OP_MACRO_STAR_D)); + + case T_LET: + { + s7_pointer arg1 = cadr(code); + if ((is_pair(arg1)) && (car(arg1) == sc->quote_symbol)) { + set_opt3_con(code, cadadr(code)); + return (fixup_unknown_op(code, f, OP_IMPLICIT_LET_REF_C)); + } + set_opt3_any(code, cadr(code)); + return (fixup_unknown_op(code, f, OP_IMPLICIT_LET_REF_A)); + } + + default: + break; + } + if ((is_symbol(car(code))) && + (!is_slot(lookup_slot_from(car(code), sc->curlet)))) + unbound_variable_error(sc, car(code)); + return (fixup_unknown_op(code, f, OP_S_A)); /* closure with methods etc */ +} + +static bool op_unknown_gg(s7_scheme * sc) +{ + bool s1, s2; + s7_pointer code, f = sc->last_function; + if (!f) + unbound_variable_error(sc, car(sc->code)); + if (SHOW_EVAL_OPS) + fprintf(stderr, "%s %s\n", __func__, display(f)); + + code = sc->code; + s1 = is_normal_symbol(cadr(code)); + s2 = is_normal_symbol(caddr(code)); + + if ((s1) && (!is_slot(lookup_slot_from(cadr(code), sc->curlet)))) + return (unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); + + if ((s2) && (!is_slot(lookup_slot_from(caddr(code), sc->curlet)))) + return (unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); + + switch (type(f)) { + case T_C_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + if ((c_function_required_args(f) > 2) || + (c_function_all_args(f) < 2)) + break; + case T_C_OPT_ARGS_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + if (is_safe_procedure(f)) { + if (s1) { + set_optimize_op(code, (s2) ? OP_SAFE_C_SS : OP_SAFE_C_SC); + if (s2) + set_opt2_sym(cdr(code), caddr(code)); + else + set_opt2_con(cdr(code), caddr(code)); + } else { + set_optimize_op(code, (s2) ? OP_SAFE_C_CS : OP_SAFE_C_NC); + if (s2) { + set_opt1_con(cdr(code), + (is_pair(cadr(code))) ? cadadr(code) : + cadr(code)); + set_opt2_sym(cdr(code), caddr(code)); + } + } + } else { + set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); + fx_annotate_args(sc, cdr(code), sc->curlet); + } + set_opt3_arglen(cdr(code), int_two); + set_c_function(code, f); + return (true); + + case T_CLOSURE: + if (has_methods(f)) + break; + if (closure_arity_to_int(sc, f) == 2) { + s7_pointer body = closure_body(f); + bool one_form, safe_case = is_safe_closure(f); + int32_t hop = 0; + + one_form = is_null(cdr(body)); + if (is_immutable_and_stable(sc, car(code))) + hop = 1; + if ((s1) && (s2)) { + set_opt2_sym(code, caddr(code)); + if (!one_form) + set_optimize_op(code, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_SS : + OP_CLOSURE_SS)); + else if (!safe_case) + set_optimize_op(code, hop + OP_CLOSURE_SS_O); + else if (!is_fxable(sc, car(body))) + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_O); + else { + fx_annotate_arg(sc, body, sc->curlet); + fx_tree(sc, body, car(closure_args(f)), + cadr(closure_args(f)), NULL, false); + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_A); + set_closure_one_form_fx_arg(f); + } + } else if (s1) { + set_opt2_con(code, caddr(code)); + if (one_form) + set_safe_optimize_op(code, + hop + + ((safe_case) ? + OP_SAFE_CLOSURE_SC_O : + OP_CLOSURE_SC_O)); + else + set_optimize_op(code, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_SC : + OP_CLOSURE_SC)); + } else { + set_opt3_arglen(cdr(code), int_two); + fx_annotate_args(sc, cdr(code), sc->curlet); + if (safe_case) + set_safe_optimize_op(code, + hop + + ((one_form) ? OP_SAFE_CLOSURE_AA_O + : OP_SAFE_CLOSURE_AA)); + else + set_safe_optimize_op(code, + hop + + ((one_form) ? OP_CLOSURE_AA_O : + OP_CLOSURE_AA)); + } + set_opt1_lambda(code, f); + return (true); + } + break; + + case T_CLOSURE_STAR: + if ((closure_star_arity_to_int(sc, f) != 0) && + (closure_star_arity_to_int(sc, f) != 1)) { + fx_annotate_args(sc, cdr(code), sc->curlet); + if (!has_methods(f)) { + fixup_closure_star_aa(sc, f, code, + (is_immutable_and_stable + (sc, car(code))) ? 1 : 0); + set_opt1_lambda(code, f); + } else + set_optimize_op(code, OP_S_AA); + return (true); + } + break; + + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + case T_BYTE_VECTOR: + case T_PAIR: + set_opt3_arglen(cdr(code), int_two); + fx_annotate_args(sc, cdr(code), sc->curlet); + return (fixup_unknown_op + (code, f, + (is_pair(f)) ? OP_IMPLICIT_PAIR_REF_AA : + OP_IMPLICIT_VECTOR_REF_AA)); + + case T_MACRO: + return (fixup_unknown_op(code, f, OP_MACRO_D)); + case T_MACRO_STAR: + return (fixup_unknown_op(code, f, OP_MACRO_STAR_D)); + + default: + break; + } + if ((is_symbol(car(code))) && + (!is_slot(lookup_slot_from(car(code), sc->curlet)))) + unbound_variable_error(sc, car(code)); + + fx_annotate_args(sc, cdr(code), sc->curlet); + return (fixup_unknown_op(code, f, OP_S_AA)); +} + +static bool op_unknown_ns(s7_scheme * sc) +{ + s7_pointer code, arg, f = sc->last_function; + int32_t num_args; + + if (!f) + unbound_variable_error(sc, car(sc->code)); + if (SHOW_EVAL_OPS) + fprintf(stderr, "%s %s\n", __func__, display(f)); + + code = sc->code; + num_args = integer(opt3_arglen(cdr(code))); + for (arg = cdr(code); is_pair(arg); arg = cdr(arg)) + if (!is_slot(lookup_slot_from(car(arg), sc->curlet))) + unbound_variable_error(sc, car(arg)); + + switch (type(f)) { + case T_C_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + if ((c_function_required_args(f) > num_args) || + (c_function_all_args(f) < num_args)) + break; + case T_C_OPT_ARGS_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + if (is_safe_procedure(f)) { + if (num_args == 3) { + set_safe_optimize_op(code, OP_SAFE_C_SSS); + set_opt1_sym(cdr(code), caddr(code)); + set_opt2_sym(cdr(code), cadddr(code)); + } else + set_safe_optimize_op(code, OP_SAFE_C_NS); + } else { + set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); + fx_annotate_args(sc, cdr(code), sc->curlet); + } + set_c_function(code, f); + return (true); + + case T_CLOSURE: + if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == num_args)) { + int32_t hop = 0; + if (is_immutable_and_stable(sc, car(code))) + hop = 1; + fx_annotate_args(sc, cdr(code), sc->curlet); + if (num_args == 3) + return (fixup_unknown_op + (code, f, + hop + + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_3S : + OP_CLOSURE_3S))); + if (num_args == 4) + return (fixup_unknown_op + (code, f, + hop + + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_NS : + OP_CLOSURE_4S))); + return (fixup_unknown_op + (code, f, + hop + + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_NS : + OP_CLOSURE_NS))); + } + /* if (is_symbol(closure_args(f))) closure_any in some form? this never happens */ + break; + + case T_CLOSURE_STAR: + if ((!has_methods(f)) && ((closure_star_arity_to_int(sc, f) < 0) + || + ((closure_star_arity_to_int(sc, f) * + 2) >= num_args))) { + int32_t hop = 0; + if (is_immutable_and_stable(sc, car(code))) + hop = 1; + fx_annotate_args(sc, cdr(code), sc->curlet); + if ((is_safe_closure(f)) && (num_args == 3) + && (closure_star_arity_to_int(sc, f) == 3)) + return (fixup_unknown_op + (code, f, OP_SAFE_CLOSURE_STAR_3A)); + return (fixup_unknown_op + (code, f, + hop + + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA : + OP_CLOSURE_STAR_NA))); + } + break; + + case T_MACRO: + return (fixup_unknown_op(code, f, OP_MACRO_D)); + case T_MACRO_STAR: + return (fixup_unknown_op(code, f, OP_MACRO_STAR_D)); + + /* vector/pair */ + default: + break; + } + return (unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); +} + +/* #define op_unknown_aa(Sc) ({fprintf(stderr, "aa: %s[%d]\n", __func__, __LINE__); op_unknown_aa_1(Sc);}) */ +static bool op_unknown_aa(s7_scheme * sc) +{ + s7_pointer code, f = sc->last_function; + + if (!f) + unbound_variable_error(sc, car(sc->code)); + if (SHOW_EVAL_OPS) + fprintf(stderr, "%s %s\n", __func__, display(f)); + + code = sc->code; +#if S7_DEBUGGING + if (!is_t_integer(opt3_arglen(cdr(code)))) { + fprintf(stderr, "not int\n"); + abort(); + } + if (!has_fx(cdr(code))) { + fprintf(stderr, "not fx cdr\n"); + abort(); + } + if (!has_fx(cddr(code))) { + fprintf(stderr, "not fx cddr\n"); + abort(); + } +#endif +#if 0 + set_opt3_arglen(cdr(code), int_two); + fx_annotate_args(sc, cdr(code), sc->curlet); +#endif + + switch (type(f)) { + case T_C_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + if ((c_function_required_args(f) > 2) || + (c_function_all_args(f) < 2)) + break; + case T_C_OPT_ARGS_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + if (is_safe_procedure(f)) { + if (!safe_c_aa_to_ag_ga(sc, code, 0)) { + set_safe_optimize_op(code, OP_SAFE_C_AA); + set_opt3_pair(code, cddr(code)); + } + } else + set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); + set_c_function(code, f); + return (true); + + case T_CLOSURE: + if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == 2)) { + s7_pointer body = closure_body(f); + bool one_form, safe_case = is_safe_closure(f); + int32_t hop = 0; + + if (is_immutable_and_stable(sc, car(code))) + hop = 1; + one_form = is_null(cdr(body)); + if (!one_form) + set_safe_optimize_op(code, + hop + + ((safe_case) ? OP_SAFE_CLOSURE_AA : + OP_CLOSURE_AA)); + else if (!safe_case) + set_optimize_op(code, hop + OP_CLOSURE_AA_O); + else if (!is_fxable(sc, car(body))) + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_O); + else { + fx_annotate_arg(sc, body, sc->curlet); + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_A); + set_closure_one_form_fx_arg(f); + } + set_opt1_lambda(code, f); + return (true); + } + break; + + case T_CLOSURE_STAR: + if (!has_methods(f)) { + fixup_closure_star_aa(sc, f, code, + (is_immutable_and_stable(sc, car(code))) + ? 1 : 0); + set_opt1_lambda(code, f); + } else + set_optimize_op(code, OP_S_AA); + return (true); + + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + case T_BYTE_VECTOR: + case T_PAIR: + return (fixup_unknown_op + (code, f, + (is_pair(f)) ? OP_IMPLICIT_PAIR_REF_AA : + OP_IMPLICIT_VECTOR_REF_AA)); + + case T_MACRO: + return (fixup_unknown_op(code, f, OP_MACRO_D)); + case T_MACRO_STAR: + return (fixup_unknown_op(code, f, OP_MACRO_STAR_D)); + + default: + break; + } + if ((is_symbol(car(code))) && + (!is_slot(lookup_slot_from(car(code), sc->curlet)))) + unbound_variable_error(sc, car(code)); + return (fixup_unknown_op(code, f, OP_S_AA)); +} + +static bool is_normal_happy_symbol(s7_scheme * sc, s7_pointer sym) +{ + if (!is_normal_symbol(sym)) + return (false); + if (!is_slot(lookup_slot_from(sym, sc->curlet))) + unbound_variable_error(sc, sym); + return (true); +} + +static bool op_unknown_na(s7_scheme * sc) +{ + s7_pointer code, f = sc->last_function; + int32_t num_args; + + if (!f) + unbound_variable_error(sc, car(sc->code)); + if (SHOW_EVAL_OPS) + fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(f), + display(sc->code)); + + code = sc->code; + num_args = (is_pair(cdr(code))) ? integer(opt3_arglen(cdr(code))) : 0; + if (num_args == 0) + return (fixup_unknown_op(code, f, OP_S)); /* via op_closure*-fx where original had 0 args, safe case -> op_safe_closure*_0 */ + + switch (type(f)) { + case T_C_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + if ((c_function_required_args(f) > num_args) || + (c_function_all_args(f) < num_args)) + break; + case T_C_OPT_ARGS_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + if (is_safe_procedure(f)) { + if (num_args == 3) { + int32_t pairs = 0, symbols = 0, quotes = 0; /* specialize aaa->ssc etc, this makes less difference than I expected */ + s7_pointer p; + for (p = cdr(code); is_pair(p); p = cdr(p)) { + s7_pointer car_p = car(p); + if (is_normal_happy_symbol(sc, car_p)) + symbols++; + else if (is_pair(car_p)) { + pairs++; + if (is_proper_quote(sc, car_p)) + quotes++; + } + } + if (optimize_safe_c_func_three_args + (sc, code, f, 0 /* hop */ , pairs, symbols, quotes, + sc->curlet) == OPT_T) + return (true); + set_opt3_pair(cdr(code), cdddr(code)); + set_opt3_pair(code, cddr(code)); + set_safe_optimize_op(code, OP_SAFE_C_AAA); + } else + set_safe_optimize_op(code, + (num_args == + 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA); + } else + set_safe_optimize_op(code, + (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); + fx_annotate_args(sc, cdr(code), sc->curlet); + set_c_function(code, f); + return (true); + + case T_CLOSURE: + if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == num_args)) { + int32_t hop = 0; + if (is_immutable_and_stable(sc, car(code))) + hop = 1; + fx_annotate_args(sc, cdr(code), sc->curlet); + if (is_safe_closure(f)) { + if (num_args != 3) + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_NA); + else if (is_normal_happy_symbol(sc, cadr(code))) + set_safe_optimize_op(code, + hop + + ((is_normal_happy_symbol + (sc, + caddr(code))) ? + OP_SAFE_CLOSURE_SSA : + OP_SAFE_CLOSURE_SAA)); + else if ((!is_pair(caddr(code))) + && (!is_pair(cadddr(code)))) + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AGG); + else + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_3A); + } else if (num_args != 3) + set_safe_optimize_op(code, + hop + + ((num_args == + 4) ? OP_CLOSURE_4A : + OP_CLOSURE_NA)); + else if ((is_normal_happy_symbol(sc, caddr(code))) + && (is_normal_happy_symbol(sc, cadddr(code)))) + set_safe_optimize_op(code, hop + OP_CLOSURE_ASS); + else if (is_normal_happy_symbol(sc, cadr(code))) + set_safe_optimize_op(code, + hop + + ((is_normal_happy_symbol + (sc, + cadddr(code))) ? OP_CLOSURE_SAS : + OP_CLOSURE_SAA)); + else if (is_normal_happy_symbol(sc, caddr(code))) + set_safe_optimize_op(code, hop + OP_CLOSURE_ASA); + else if (is_normal_happy_symbol(sc, cadddr(code))) + set_safe_optimize_op(code, hop + OP_CLOSURE_AAS); + else + set_safe_optimize_op(code, hop + OP_CLOSURE_3A); + set_opt1_lambda(code, f); + return (true); + } + if (is_symbol(closure_args(f))) { + optimize_closure_dotted_args(sc, code, f, 0, num_args, + sc->curlet); + if (optimize_op(code) == OP_ANY_CLOSURE_NA) + return (true); + } + break; + + case T_CLOSURE_STAR: + if ((!has_methods(f)) && ((closure_star_arity_to_int(sc, f) < 0) + || + ((closure_star_arity_to_int(sc, f) * + 2) >= num_args))) { + int32_t hop = 0; + if (is_immutable_and_stable(sc, car(code))) + hop = 1; + if (num_args > 0) { + set_opt3_arglen(cdr(code), small_int(num_args)); + fx_annotate_args(sc, cdr(code), sc->curlet); + } + if (is_safe_closure(f)) + switch (num_args) { + case 0: + return (fixup_unknown_op + (code, f, hop + OP_SAFE_CLOSURE_STAR_NA_0)); + case 1: + return (fixup_unknown_op + (code, f, hop + OP_SAFE_CLOSURE_STAR_NA_1)); + case 2: + return (fixup_unknown_op + (code, f, hop + OP_SAFE_CLOSURE_STAR_NA_2)); + case 3: + if (closure_star_arity_to_int(sc, f) == 3) + return (fixup_unknown_op + (code, f, OP_SAFE_CLOSURE_STAR_3A)); + default: + return (fixup_unknown_op + (code, f, hop + OP_SAFE_CLOSURE_STAR_NA)); + } + return (fixup_unknown_op(code, f, hop + OP_CLOSURE_STAR_NA)); + } + break; + + case T_MACRO: + return (fixup_unknown_op(code, f, OP_MACRO_D)); + case T_MACRO_STAR: + return (fixup_unknown_op(code, f, OP_MACRO_STAR_D)); + /* implicit vector doesn't happen */ + + default: + break; + } + /* closure happens if wrong-number-of-args passed -- probably no need for op_s_all_a */ + return (unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); +} + +static bool op_unknown_np(s7_scheme * sc) +{ + s7_pointer code, f = sc->last_function; + int32_t num_args; + + if (!f) + unbound_variable_error(sc, car(sc->code)); + if (SHOW_EVAL_OPS) + fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, + display(f), type_name(sc, f, NO_ARTICLE), + display(sc->code)); + + code = sc->code; + num_args = (is_pair(cdr(code))) ? integer(opt3_arglen(cdr(code))) : 0; + + switch (type(f)) { + case T_C_FUNCTION: + case T_C_RST_ARGS_FUNCTION: + if ((c_function_required_args(f) > num_args) || + (c_function_all_args(f) < num_args)) + break; + case T_C_OPT_ARGS_FUNCTION: + case T_C_ANY_ARGS_FUNCTION: + if (num_args == 1) + set_any_c_np(sc, f, code, sc->curlet, num_args, + (is_safe_procedure(f)) ? OP_SAFE_C_P : OP_C_P); + else if ((num_args == 2) && (is_safe_procedure(f))) { + set_any_c_np(sc, f, code, sc->curlet, 2, OP_SAFE_C_PP); + opt_sp_1(sc, c_function_call(f), code); + gx_annotate_args(sc, cdr(code), sc->curlet); + } else + if ((num_args == 3) && + ((is_safe_procedure(f)) || + ((is_semisafe(f)) && (((car(code) != sc->assoc_symbol) + && (car(code) != + sc->member_symbol)) + || + (unsafe_is_safe + (sc, cadddr(code), sc->curlet)))))) + set_any_c_np(sc, f, code, sc->curlet, 3, OP_SAFE_C_3P); + else + set_any_c_np(sc, f, code, sc->curlet, num_args, OP_ANY_C_NP); + return (true); + + case T_CLOSURE: + if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == num_args)) { + int32_t hop = 0; + if (is_immutable_and_stable(sc, car(code))) + hop = 1; + + switch (num_args) { + case 1: + if (is_safe_closure(f)) { + s7_pointer body = closure_body(f); + if ((is_null(cdr(body))) && (is_fxable(sc, car(body)))) { + set_optimize_op(code, hop + OP_SAFE_CLOSURE_P_A); + fx_annotate_arg(sc, body, sc->curlet); + } else + set_optimize_op(code, hop + OP_SAFE_CLOSURE_P); + } else + set_optimize_op(code, hop + OP_CLOSURE_P); + set_opt1_lambda(code, f); + set_opt3_arglen(cdr(code), int_one); + set_unsafely_optimized(code); + break; + + case 2: + if (is_fxable(sc, cadr(code))) { + fx_annotate_arg(sc, cdr(code), sc->curlet); + set_optimize_op(code, + hop + + ((is_safe_closure(f)) ? + OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP)); + } else if (is_fxable(sc, caddr(code))) { + fx_annotate_arg(sc, cddr(code), sc->curlet); + set_optimize_op(code, + hop + + ((is_safe_closure(f)) ? + OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); + } else + set_optimize_op(code, + hop + + ((is_safe_closure(f)) ? + OP_SAFE_CLOSURE_PP : OP_CLOSURE_PP)); + set_opt1_lambda(code, f); + set_opt3_arglen(cdr(code), int_two); /* for later op_unknown_np */ + set_unsafely_optimized(code); + break; + + case 3: + set_any_closure_np(sc, f, code, sc->curlet, 3, + hop + OP_ANY_CLOSURE_3P); + break; + case 4: + set_any_closure_np(sc, f, code, sc->curlet, 4, + hop + OP_ANY_CLOSURE_4P); + break; + default: + set_any_closure_np(sc, f, code, sc->curlet, num_args, + hop + OP_ANY_CLOSURE_NP); + break; + } + return (true); + } + break; + + case T_MACRO: + return (fixup_unknown_op(code, f, OP_MACRO_D)); + case T_MACRO_STAR: + return (fixup_unknown_op(code, f, OP_MACRO_STAR_D)); + } + return (unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); +} + +static bool unknown_any(s7_scheme * sc, s7_pointer f, s7_pointer code) +{ + sc->last_function = f; + if (is_null(cdr(code))) + return (op_unknown(sc)); + if ((is_null(cddr(code))) && (!is_pair(cadr(code)))) + return (op_unknown_g(sc)); + set_opt3_arglen(cdr(code), + make_integer(sc, proper_list_length(cdr(code)))); + return (op_unknown_np(sc)); +} + + +/* ---------------- eval type checkers ---------------- */ +#if WITH_GCC +#define h_c_function_is_ok(Sc, P) ({s7_pointer _P_; _P_ = P; ((op_has_hop(_P_)) || (c_function_is_ok(Sc, _P_)));}) +#else +#define h_c_function_is_ok(Sc, P) ((op_has_hop(P)) || (c_function_is_ok(Sc, P))) +#endif + +#define c_function_is_ok_cadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P)))) +#define c_function_is_ok_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, caddr(P)))) +#define c_function_is_ok_cadr_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P))) && (h_c_function_is_ok(Sc, caddr(P)))) +#define c_function_is_ok_cadr_cadadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P))) && (h_c_function_is_ok(Sc, opt3_pair(P)))) /* cadadr(P) */ +#define c_function_is_ok_cadr_caddadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P))) && (h_c_function_is_ok(Sc, opt3_pair(P)))) /* caddadr(P) */ + +/* closure_is_ok_1 checks the type and the body length indications + * closure_is_fine_1 just checks the type (safe or unsafe closure) + * closure_is_ok calls _ok_1, closure_is_fine calls _fine_1 + * closure_np_is_ok accepts safe/unsafe etc + */ + +static inline bool closure_is_ok_1(s7_scheme * sc, s7_pointer code, + uint16_t type, int32_t args) +{ + s7_pointer f; + if ((S7_DEBUGGING) && (symbol_ctr(car(code)) == 1)) + fprintf(stderr, "%s ctr is 1, %p != %p\n", display(car(code)), + unchecked_local_value(car(code)), + opt1_lambda_unchecked(code)); + f = lookup_unexamined(sc, car(code)); + if ((f == opt1_lambda_unchecked(code)) || ((f) && (typesflag(f) == type) && ((closure_arity(f) == args) || (closure_arity_to_int(sc, f) == args)) && /* 3 type bits to replace this but not hit enough to warrant them */ + (set_opt1_lambda(code, f)))) + return (true); + sc->last_function = f; + return (false); +} + +static inline bool closure_is_fine_1(s7_scheme * sc, s7_pointer code, + uint16_t type, int32_t args) +{ + s7_pointer f; + f = lookup_unexamined(sc, car(code)); + if ((f == opt1_lambda_unchecked(code)) || + ((f) && + ((typesflag(f) & (TYPE_MASK | T_SAFE_CLOSURE)) == type) && + ((closure_arity(f) == args) + || (closure_arity_to_int(sc, f) == args)) + && (set_opt1_lambda(code, f)))) + return (true); + sc->last_function = f; + return (false); +} + +static inline bool closure_np_is_ok_1(s7_scheme * sc, s7_pointer code, + int32_t args) +{ + s7_pointer f; + f = lookup_unexamined(sc, car(code)); + if ((f == opt1_lambda_unchecked(code)) || + ((f) && (is_closure(f)) && (set_opt1_lambda(code, f)))) + return (true); + sc->last_function = f; + return (false); +} + +#define closure_is_ok(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_is_ok_1(Sc, Code, Type, Args))) +#define closure_np_is_ok(Sc, Code, Args) ((symbol_ctr(car(Code)) == 1) || (closure_np_is_ok_1(Sc, Code, Args))) +#define closure_is_fine(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_is_fine_1(Sc, Code, Type, Args))) +#define closure_star_is_fine(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_star_is_fine_1(Sc, Code, Type, Args))) + +static inline bool closure_is_eq(s7_scheme * sc) +{ + sc->last_function = lookup_unexamined(sc, car(sc->code)); + return (sc->last_function == opt1_lambda_unchecked(sc->code)); +} + +static bool star_arity_is_ok(s7_scheme * sc, s7_pointer val, int32_t args) +{ + int32_t arity; + arity = closure_star_arity_to_int(sc, val); + return ((arity < 0) || ((arity * 2) >= args)); +} + +static bool closure_star_is_fine_1(s7_scheme * sc, s7_pointer code, + uint16_t type, int32_t args) +{ + s7_pointer val; + val = lookup_unexamined(sc, car(code)); + if ((val == opt1_lambda_unchecked(code)) || + ((val) && + ((typesflag(val) & (T_SAFE_CLOSURE | TYPE_MASK)) == type) && + (star_arity_is_ok(sc, val, args)) && + (set_opt1_lambda(code, val)))) + return (true); + sc->last_function = val; + return (false); +} + +/* closure_is_fine: */ +#define FINE_UNSAFE_CLOSURE (T_CLOSURE) +#define FINE_SAFE_CLOSURE (T_CLOSURE | T_SAFE_CLOSURE) + +/* closure_star_is_fine: */ +#define FINE_UNSAFE_CLOSURE_STAR (T_CLOSURE_STAR) +#define FINE_SAFE_CLOSURE_STAR (T_CLOSURE_STAR | T_SAFE_CLOSURE) + +/* closure_is_ok: */ +#define OK_UNSAFE_CLOSURE_P (T_CLOSURE | T_ONE_FORM) +#define OK_SAFE_CLOSURE_P (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM) +#define OK_UNSAFE_CLOSURE_M (T_CLOSURE | T_MULTIFORM) +#define OK_SAFE_CLOSURE_M (T_CLOSURE | T_SAFE_CLOSURE | T_MULTIFORM) +#define OK_SAFE_CLOSURE_A (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM_FX_ARG) +/* since T_HAS_METHODS is on if there might be methods, this can protect us from that case */ + + +/* ---------------- eval ---------------- */ +static s7_pointer eval(s7_scheme * sc, opcode_t first_op) +{ + if (SHOW_EVAL_OPS) + safe_print(fprintf + (stderr, "eval[%d]:, %s %s %s\n", __LINE__, + op_names[first_op], display_80(sc->code), + display_80(sc->args))); + sc->cur_op = first_op; + goto TOP_NO_POP; + + while (true) { /* "continue" in this procedure refers to this loop */ + pop_stack(sc); + goto TOP_NO_POP; + + BEGIN: + if (is_pair(cdr(T_Pair(sc->code)))) + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + sc->code = car(sc->code); + set_current_code(sc, sc->code); + + EVAL: + sc->cur_op = optimize_op(sc->code); /* sc->code can be anything, optimize_op examines a type field (opt_choice) */ + + TOP_NO_POP: + if (SHOW_EVAL_OPS) + safe_print(fprintf + (stderr, "%s (%d), code: %s\n", + op_names[sc->cur_op], (int) (sc->cur_op), + display_80(sc->code))); + + /* it is only slightly faster to use labels as values (computed gotos) here. In my timing tests (June-2018), the best case speedup was in titer.scm + * callgrind numbers 4808 to 4669; another good case was tread.scm: 2410 to 2386. Most timings were a draw. computed-gotos-s7.c has the code, + * macroized so it will work if such gotos aren't available. I think I'll stick with a switch statement. + * Another seductive idea is to put the function in the tree, not an index to it (the optimize_op business above), + * then the switch below is not needed, and we free up 16 type bits. C does not guarantee tail calls (I think) + * so we'd have each function return the next, and eval would be (while (true) f = f(sc) but would the function + * call overhead be less expensive than the switch? (We get most functions inlined in the current code). + * with some fake fx_calls for the P cases, many of these could be + * sc->value = fx_function[sc->cur_op](sc, sc->code); continue; + * so the switch statement is unnecessary -- maybe a table eval_functions[cur_op] eventually + */ + + switch (sc->cur_op) { + /* safe c_functions */ + case OP_SAFE_C_NC: + if (!c_function_is_ok(sc, sc->code)) + break; /* break refers to the switch statement */ + case HOP_SAFE_C_NC: + sc->value = fc_call(sc, sc->code); + continue; /* continue refers to the outer while loop -- unfortunate C ambiguity */ + + case OP_SAFE_C_S: + if (!c_function_is_ok(sc, sc->code)) { + if (op_unknown_g(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_C_S: + op_safe_c_s(sc); + continue; + + case OP_SAFE_C_SS: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_SS: + op_safe_c_ss(sc); + continue; + + case OP_SAFE_C_NS: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_NS: + sc->value = fx_c_ns(sc, sc->code); + continue; + + case OP_SAFE_C_SC: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_SC: + op_safe_c_sc(sc); + continue; + + case OP_SAFE_C_CS: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_CS: + sc->value = fx_c_cs(sc, sc->code); + continue; + + case OP_SAFE_C_CQ: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_CQ: + sc->value = fx_c_cq(sc, sc->code); + continue; + + case OP_SAFE_C_FF: + if (!c_function_is_ok(sc, sc->code)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_C_FF: + sc->value = fx_c_ff(sc, sc->code); + continue; + + case OP_SAFE_C_P: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_P: + op_safe_c_p(sc); + goto EVAL; + case OP_SAFE_C_P_1: + op_safe_c_p_1(sc); + continue; + + case OP_ANY_C_NP: + if (!c_function_is_ok(sc, sc->code)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_ANY_C_NP: + if (op_any_c_np(sc)) + goto EVAL; + continue; + case OP_ANY_C_NP_1: + if (op_any_c_np_1(sc)) + goto EVAL; + continue; + case OP_ANY_C_NP_2: + op_any_c_np_2(sc); + continue; + case OP_ANY_C_NP_MV_1: + if (op_any_c_np_mv_1(sc)) + goto EVAL; + goto APPLY; + + case OP_SAFE_C_SSP: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_SSP: + op_safe_c_ssp(sc); + goto EVAL; + case OP_SAFE_C_SSP_1: + op_safe_c_ssp_1(sc); + continue; + case OP_SAFE_C_SSP_MV_1: + op_safe_c_ssp_mv_1(sc); + goto APPLY; + + case OP_SAFE_C_A: + if (!c_function_is_ok(sc, sc->code)) { + if (op_unknown_a(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_C_A: + sc->value = fx_c_a(sc, sc->code); + continue; + + case OP_SAFE_C_opAq: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_opAq: + sc->value = fx_c_opaq(sc, sc->code); + continue; + + case OP_SAFE_C_opAAq: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_opAAq: + sc->value = fx_c_opaaq(sc, sc->code); + continue; + + case OP_SAFE_C_opAAAq: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_opAAAq: + sc->value = fx_c_opaaaq(sc, sc->code); + continue; + + case OP_SAFE_C_S_opAq: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_S_opAq: + sc->value = fx_c_s_opaq(sc, sc->code); + continue; + + case OP_SAFE_C_opAq_S: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_opAq_S: + sc->value = fx_c_opaq_s(sc, sc->code); + continue; + + case OP_SAFE_C_S_opAAq: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_S_opAAq: + sc->value = fx_c_s_opaaq(sc, sc->code); + continue; + + case OP_SAFE_C_S_opAAAq: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_S_opAAAq: + sc->value = fx_c_s_opaaaq(sc, sc->code); + continue; + + case OP_SAFE_C_AA: + if (!c_function_is_ok(sc, sc->code)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_C_AA: + sc->value = fx_c_aa(sc, sc->code); + continue; + + case OP_SAFE_C_SA: + if (!c_function_is_ok(sc, sc->code)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_C_SA: + sc->value = fx_c_sa(sc, sc->code); + continue; + + case OP_SAFE_C_AS: + if (!c_function_is_ok(sc, sc->code)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_C_AS: + sc->value = fx_c_as(sc, sc->code); + continue; + + case OP_SAFE_C_CA: + if (!c_function_is_ok(sc, sc->code)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_C_CA: + sc->value = fx_c_ca(sc, sc->code); + continue; + + case OP_SAFE_C_AC: + if (!c_function_is_ok(sc, sc->code)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_C_AC: + sc->value = fx_c_ac(sc, sc->code); + continue; + + case OP_SAFE_C_AAA: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_AAA: + sc->value = fx_c_aaa(sc, sc->code); + continue; + + case OP_SAFE_C_SAA: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_SAA: + sc->value = fx_c_saa(sc, sc->code); + continue; + + case OP_SAFE_C_SSA: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_SSA: + sc->value = fx_c_ssa(sc, sc->code); + continue; + case HOP_SSA_DIRECT: + sc->value = op_ssa_direct(sc, sc->code); + continue; + case HOP_HASH_TABLE_INCREMENT: + sc->value = fx_hash_table_increment(sc, sc->code); + continue; /* a placeholder, almost never called */ + + case OP_SAFE_C_SAS: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_SAS: + sc->value = fx_c_sas(sc, sc->code); + continue; + + case OP_SAFE_C_ASS: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_ASS: + sc->value = fx_c_ass(sc, sc->code); + continue; + + case OP_SAFE_C_AGG: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_AGG: + sc->value = fx_c_agg(sc, sc->code); + continue; + + case OP_SAFE_C_CAC: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_CAC: + sc->value = fx_c_cac(sc, sc->code); + continue; + + case OP_SAFE_C_CSA: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_CSA: + sc->value = fx_c_csa(sc, sc->code); + continue; + + case OP_SAFE_C_SCA: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_SCA: + sc->value = fx_c_sca(sc, sc->code); + continue; + + case OP_SAFE_C_4A: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_4A: + sc->value = fx_c_4a(sc, sc->code); + continue; + + case OP_SAFE_C_NA: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_NA: + sc->value = fx_c_na(sc, sc->code); + continue; + + case OP_SAFE_C_ALL_CA: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_ALL_CA: + sc->value = fx_c_all_ca(sc, sc->code); + continue; + + case OP_SAFE_C_SCS: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_SCS: + sc->value = fx_c_scs(sc, sc->code); + continue; + + case OP_SAFE_C_SSC: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_SSC: + sc->value = fx_c_ssc(sc, sc->code); + continue; + + case OP_SAFE_C_SCC: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_SCC: + sc->value = fx_c_scc(sc, sc->code); + continue; + + case OP_SAFE_C_CSC: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_CSC: + sc->value = fx_c_csc(sc, sc->code); + continue; + + case OP_SAFE_C_CCS: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_CCS: + sc->value = fx_c_ccs(sc, sc->code); + continue; + + case OP_SAFE_C_CSS: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_CSS: + sc->value = fx_c_css(sc, sc->code); + continue; + + case OP_SAFE_C_SSS: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_SSS: + sc->value = fx_c_sss(sc, sc->code); + continue; + + case OP_SAFE_C_opNCq: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opNCq: + sc->value = fx_c_opncq(sc, sc->code); + continue; + + case OP_SAFE_C_opSq: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opSq: + sc->value = fx_c_opsq(sc, sc->code); + continue; + + case OP_SAFE_C_op_opSqq: + if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) + break; + case HOP_SAFE_C_op_opSqq: + sc->value = fx_c_op_opsqq(sc, sc->code); + continue; + + case OP_SAFE_C_op_S_opSqq: + if (!c_function_is_ok_cadr_caddadr(sc, sc->code)) + break; + case HOP_SAFE_C_op_S_opSqq: + sc->value = fx_c_op_s_opsqq(sc, sc->code); + continue; + + case OP_SAFE_C_op_opSq_Sq: + if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) + break; + case HOP_SAFE_C_op_opSq_Sq: + sc->value = fx_c_op_opsq_sq(sc, sc->code); + continue; + + case OP_SAFE_C_PS: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_PS: + op_safe_c_ps(sc); + goto EVAL; + case OP_SAFE_C_PS_1: + op_safe_c_ps_1(sc); + continue; + case OP_SAFE_C_PS_MV: + op_safe_c_ps_mv(sc); + goto APPLY; + + case OP_SAFE_C_PC: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_PC: + op_safe_c_pc(sc); + goto EVAL; + case OP_SAFE_C_PC_1: + op_safe_c_pc_1(sc); + continue; + case OP_SAFE_C_PC_MV: + op_safe_c_pc_mv(sc); + goto APPLY; + + case OP_SAFE_C_SP: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_SP: + op_safe_c_sp(sc); + goto EVAL; + case OP_SAFE_C_SP_1: + op_safe_c_sp_1(sc); + continue; + case OP_SAFE_C_SP_MV: + op_safe_c_sp_mv(sc); + goto APPLY; + + case OP_SAFE_CONS_SP_1: + sc->value = cons(sc, sc->args, sc->value); + continue; + case OP_SAFE_LIST_SP_1: + sc->value = list_2(sc, sc->args, sc->value); + continue; + case OP_SAFE_ADD_SP_1: + op_safe_add_sp_1(sc); + continue; + case OP_SAFE_MULTIPLY_SP_1: + op_safe_multiply_sp_1(sc); + continue; + + case OP_SAFE_C_AP: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_AP: + if (op_safe_c_ap(sc)) + goto EVAL; + continue; + + case OP_SAFE_C_PA: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_PA: + if (op_safe_c_pa(sc)) + goto EVAL; + continue; + case OP_SAFE_C_PA_1: + op_safe_c_pa_1(sc); + continue; + case OP_SAFE_C_PA_MV: + op_safe_c_pa_mv(sc); + goto APPLY; + + case OP_SAFE_C_CP: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_CP: + op_safe_c_cp(sc); + goto EVAL; + + case OP_SAFE_C_PP: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_PP: + op_safe_c_pp(sc); + goto EVAL; + case OP_SAFE_C_PP_1: + op_safe_c_pp_1(sc); + goto EVAL; + case OP_SAFE_C_PP_3_MV: + op_safe_c_pp_3_mv(sc); + goto EVAL; + case OP_SAFE_C_PP_5: + op_safe_c_pp_5(sc); + goto APPLY; + case OP_SAFE_C_PP_6_MV: + op_safe_c_pp_6_mv(sc); + goto APPLY; + + case OP_SAFE_C_3P: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_3P: + op_safe_c_3p(sc); + goto EVAL; + case OP_SAFE_C_3P_1: + op_safe_c_3p_1(sc); + goto EVAL; + case OP_SAFE_C_3P_2: + op_safe_c_3p_2(sc); + goto EVAL; + case OP_SAFE_C_3P_3: + op_safe_c_3p_3(sc); + continue; + case OP_SAFE_C_3P_1_MV: + op_safe_c_3p_1_mv(sc); + goto EVAL; + case OP_SAFE_C_3P_2_MV: + op_safe_c_3p_2_mv(sc); + goto EVAL; + case OP_SAFE_C_3P_3_MV: + op_safe_c_3p_3_mv(sc); + goto APPLY; + + case OP_SAFE_C_opSSq: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opSSq: + sc->value = fx_c_opssq(sc, sc->code); + continue; + + case OP_SAFE_C_opSCq: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opSCq: + sc->value = fx_c_opscq(sc, sc->code); + continue; + + case OP_SAFE_C_opCSq: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opCSq: + sc->value = fx_c_opcsq(sc, sc->code); + continue; + + case OP_SAFE_C_S_opSq: + if (!c_function_is_ok_caddr(sc, sc->code)) + break; + case HOP_SAFE_C_S_opSq: + sc->value = fx_c_s_opsq(sc, sc->code); + continue; + + case OP_SAFE_C_C_opSq: + if (!c_function_is_ok_caddr(sc, sc->code)) + break; + case HOP_SAFE_C_C_opSq: + sc->value = fx_c_c_opsq(sc, sc->code); + continue; + + case OP_SAFE_C_C_opSSq: + if (!c_function_is_ok_caddr(sc, sc->code)) + break; + case HOP_SAFE_C_C_opSSq: + sc->value = fx_c_c_opssq(sc, sc->code); + continue; + + case OP_SAFE_C_opCSq_C: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opCSq_C: + sc->value = fx_c_opcsq_c(sc, sc->code); + continue; + + case OP_SAFE_C_opSSq_C: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opSSq_C: + sc->value = fx_c_opssq_c(sc, sc->code); + continue; + + case OP_SAFE_C_opSSq_S: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opSSq_S: + sc->value = fx_c_opssq_s(sc, sc->code); + continue; + + case OP_SAFE_C_op_opSSqq_S: + if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) + break; + case HOP_SAFE_C_op_opSSqq_S: + sc->value = fx_c_op_opssqq_s(sc, sc->code); + continue; + + case OP_SAFE_C_opSCq_C: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opSCq_C: + sc->value = fx_c_opscq_c(sc, sc->code); + continue; + + case OP_SAFE_C_opCSq_S: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opCSq_S: + sc->value = fx_c_opcsq_s(sc, sc->code); + continue; + + case OP_SAFE_C_S_opSCq: + if (!c_function_is_ok_caddr(sc, sc->code)) + break; + case HOP_SAFE_C_S_opSCq: + sc->value = fx_c_s_opscq(sc, sc->code); + continue; + + case OP_SAFE_C_C_opSCq: + if (!c_function_is_ok_caddr(sc, sc->code)) + break; + case HOP_SAFE_C_C_opSCq: + sc->value = fx_c_c_opscq(sc, sc->code); + continue; + + case OP_SAFE_C_S_opSSq: + if (!c_function_is_ok_caddr(sc, sc->code)) + break; + case HOP_SAFE_C_S_opSSq: + sc->value = fx_c_s_opssq(sc, sc->code); + continue; + + case OP_SAFE_C_S_opCSq: + if (!c_function_is_ok_caddr(sc, sc->code)) + break; + case HOP_SAFE_C_S_opCSq: + sc->value = fx_c_s_opcsq(sc, sc->code); + continue; + + case OP_SAFE_C_opSq_S: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opSq_S: + sc->value = fx_c_opsq_s(sc, sc->code); + continue; + + case OP_SAFE_C_opSq_P: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opSq_P: + op_safe_c_opsq_p(sc); + goto EVAL; + + case OP_SAFE_C_opSq_CS: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opSq_CS: + sc->value = fx_c_opsq_cs(sc, sc->code); + continue; + + case OP_SAFE_C_opSq_C: + if (!c_function_is_ok_cadr(sc, sc->code)) + break; + case HOP_SAFE_C_opSq_C: + sc->value = fx_c_opsq_c(sc, sc->code); + continue; + + case OP_SAFE_C_opSq_opSq: + if (!c_function_is_ok_cadr_caddr(sc, sc->code)) + break; + case HOP_SAFE_C_opSq_opSq: + sc->value = fx_c_opsq_opsq(sc, sc->code); + continue; + + case OP_SAFE_C_opSSq_opSSq: + if (!c_function_is_ok_cadr_caddr(sc, sc->code)) + break; + case HOP_SAFE_C_opSSq_opSSq: + sc->value = fx_c_opssq_opssq(sc, sc->code); + continue; + + case OP_SAFE_C_opSSq_opSq: + if (!c_function_is_ok_cadr_caddr(sc, sc->code)) + break; + case HOP_SAFE_C_opSSq_opSq: + sc->value = fx_c_opssq_opsq(sc, sc->code); + continue; + + case OP_SAFE_C_opSq_opSSq: + if (!c_function_is_ok_cadr_caddr(sc, sc->code)) + break; + case HOP_SAFE_C_opSq_opSSq: + sc->value = fx_c_opsq_opssq(sc, sc->code); + continue; + + + /* semisafe c_functions */ + case OP_CL_S: + if (!cl_function_is_ok(sc, sc->code)) + break; + case HOP_CL_S: + op_safe_c_s(sc); + continue; + + case OP_CL_SS: + if (!cl_function_is_ok(sc, sc->code)) + break; + case HOP_CL_SS: + op_safe_c_ss(sc); + continue; /* safe_c case has the code we want */ + + case OP_CL_S_opSq: + if (!c_function_is_ok_caddr(sc, sc->code)) + break; + case HOP_CL_S_opSq: + sc->value = fx_c_s_opsq(sc, sc->code); + continue; + + case OP_CL_A: + if (!cl_function_is_ok(sc, sc->code)) { + set_optimize_op(sc->code, OP_S_A); + goto EVAL; + } + case HOP_CL_A: + op_cl_a(sc); + continue; + + case OP_CL_AA: + if (!cl_function_is_ok(sc, sc->code)) + break; + case HOP_CL_AA: + op_cl_aa(sc); + continue; + + case OP_CL_SAS: + if (!cl_function_is_ok(sc, sc->code)) + break; + case HOP_CL_SAS: + op_cl_sas(sc); + continue; + + case OP_CL_NA: + if (!cl_function_is_ok(sc, sc->code)) + break; + case HOP_CL_NA: + op_cl_na(sc); + continue; + + case OP_CL_FA: + if (!cl_function_is_ok(sc, sc->code)) + break; + case HOP_CL_FA: + op_cl_fa(sc); + continue; /* op_c_fs was not faster if fx_s below */ + case OP_MAP_FOR_EACH_FA: + op_map_for_each_fa(sc); + continue; /* here only if for-each or map + one seq */ + case OP_MAP_FOR_EACH_FAA: + op_map_for_each_faa(sc); + continue; /* here only if for-each or map + twp seqs */ + + + /* unsafe c_functions */ + case OP_C: + if (!c_function_is_ok(sc, sc->code)) { + set_optimize_op(sc->code, OP_S); + goto EVAL; + } + case HOP_C: + sc->value = fn_proc(sc->code) (sc, sc->nil); + continue; + + case OP_C_S: + if (!c_function_is_ok(sc, sc->code)) { + set_optimize_op(sc->code, OP_S_S); + goto EVAL; + } + case HOP_C_S: + op_c_s(sc); + continue; + + case OP_READ_S: + if (!c_function_is_ok(sc, sc->code)) { + set_optimize_op(sc->code, OP_S_S); + goto EVAL; + } + case HOP_READ_S: + op_read_s(sc); + continue; + + case OP_C_A: + if (!c_function_is_ok(sc, sc->code)) { + set_optimize_op(sc->code, OP_S_A); + goto EVAL; + } + case HOP_C_A: + op_c_a(sc); + continue; + + case OP_C_P: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_C_P: + op_c_p(sc); + goto EVAL; + + case OP_C_P_1: + sc->value = fn_proc(sc->code) (sc, list_1(sc, sc->value)); + continue; + case OP_C_P_MV: + op_c_p_mv(sc); + goto APPLY; + + case OP_C_SS: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_C_SS: + op_c_ss(sc); + continue; + + case OP_C_AP: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_C_AP: + op_c_ap(sc); + goto EVAL; + case OP_C_AP_1: + sc->value = fn_proc(sc->code) (sc, sc->args = + list_2(sc, sc->args, + sc->value)); + continue; + case OP_C_AP_MV: + op_c_ap_mv(sc); + goto APPLY; + + case OP_C_AA: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_C_AA: + op_c_aa(sc); + continue; + + case OP_C_S_opSq: + if (!c_function_is_ok_caddr(sc, sc->code)) + break; + case HOP_C_S_opSq: + sc->value = op_c_s_opsq(sc); + continue; + + case OP_C_NA: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_C_NA: + op_c_na(sc); + continue; + + case OP_APPLY_SS: + op_apply_ss(sc); + goto APPLY; + case OP_APPLY_SA: + op_apply_sa(sc); + goto APPLY; + case OP_APPLY_SL: + op_apply_sl(sc); + goto APPLY; + + case OP_CALL_WITH_EXIT: + if (!c_function_is_ok(sc, sc->code)) + break; + check_lambda_args(sc, cadadr(sc->code), NULL); + case HOP_CALL_WITH_EXIT: + op_call_with_exit(sc); + goto BEGIN; + case OP_CALL_CC: + op_call_cc(sc); + goto BEGIN; + + case OP_CALL_WITH_EXIT_O: + if (!c_function_is_ok(sc, sc->code)) + break; + check_lambda_args(sc, cadadr(sc->code), NULL); + case HOP_CALL_WITH_EXIT_O: + op_call_with_exit_o(sc); + goto EVAL; + + case OP_C_CATCH: + if (!c_function_is_ok(sc, sc->code)) + break; + check_lambda_args(sc, cadr(cadddr(sc->code)), NULL); + case HOP_C_CATCH: + op_c_catch(sc); + goto BEGIN; + + case OP_C_CATCH_ALL: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_C_CATCH_ALL: + op_c_catch_all(sc); + goto BEGIN; + + case OP_C_CATCH_ALL_O: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_C_CATCH_ALL_O: + op_c_catch_all(sc); + goto EVAL; + + case OP_C_CATCH_ALL_A: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_C_CATCH_ALL_A: + op_c_catch_all_a(sc); + continue; + + case OP_WITH_IO: + if (op_with_io_op(sc)) + goto EVAL; + goto BEGIN; + case OP_WITH_IO_1: + if (!is_string(sc->value)) { + op_with_io_1_method(sc); + continue; + } + sc->code = op_with_io_1(sc); + goto BEGIN; + + case OP_WITH_IO_C: + sc->value = cadr(sc->code); + sc->code = op_with_io_1(sc); + goto BEGIN; + case OP_WITH_OUTPUT_TO_STRING: + op_with_output_to_string(sc); + goto BEGIN; + case OP_CALL_WITH_OUTPUT_STRING: + op_call_with_output_string(sc); + goto BEGIN; + + + case OP_S: + op_s(sc); + goto APPLY; + case OP_S_C: + op_s_c(sc); + goto APPLY; + case OP_S_S: + if (op_s_s(sc)) + continue; + goto APPLY; + + case OP_S_A: + op_x_a(sc, lookup_checked(sc, car(sc->code))); + goto APPLY; + case OP_A_A: + op_x_a(sc, fx_call(sc, sc->code)); + goto APPLY; + case OP_S_AA: + op_x_aa(sc, lookup_checked(sc, car(sc->code))); + goto APPLY; + case OP_A_AA: + op_x_aa(sc, fx_call(sc, sc->code)); + goto APPLY; + case OP_P_S: + push_stack_no_args(sc, OP_P_S_1, sc->code); + sc->code = car(sc->code); + goto EVAL; + case OP_P_S_1: + op_p_s_1(sc); + goto APPLY; + + case OP_SAFE_C_STAR: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_STAR: + op_safe_c_star(sc); + continue; + + case OP_SAFE_C_STAR_A: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_STAR_A: + op_safe_c_star_a(sc); + continue; + + case OP_SAFE_C_STAR_AA: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_STAR_AA: + op_safe_c_star_aa(sc); + continue; + + case OP_SAFE_C_STAR_NA: + if (!c_function_is_ok(sc, sc->code)) + break; + case HOP_SAFE_C_STAR_NA: + op_safe_c_star_na(sc); + continue; + + + case OP_THUNK: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 0)) { + if (op_unknown(sc)) + goto EVAL; + continue; + } + case HOP_THUNK: + op_thunk(sc); + goto EVAL; + + case OP_SAFE_THUNK: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 0)) { + if (op_unknown(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_THUNK: + op_safe_thunk(sc); + goto EVAL; + + case OP_THUNK_ANY: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) + break; /* symbol as arglist */ + case HOP_THUNK_ANY: + op_thunk_any(sc); + goto BEGIN; + + case OP_SAFE_THUNK_A: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 0)) { + if (op_unknown(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_THUNK_A: + sc->value = op_safe_thunk_a(sc, sc->code); + continue; + + case OP_CLOSURE_S: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) { + if (op_unknown_g(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_S: + op_closure_s(sc); + goto EVAL; + + case OP_CLOSURE_S_O: + if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) { + if (op_unknown_g(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_S_O: + op_closure_s_o(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_S: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) { + if (op_unknown_g(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_S: + op_safe_closure_s(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_S_O: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) { + if (op_unknown_g(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_S_O: + op_safe_closure_s_o(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_S_A: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) { + if (op_unknown_g(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_S_A: + sc->value = op_safe_closure_s_a(sc, sc->code); + continue; + + case OP_SAFE_CLOSURE_S_TO_S: + if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) { + if (op_unknown_g(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_S_TO_S: + sc->value = fx_safe_closure_s_to_s(sc, sc->code); + continue; + + case OP_SAFE_CLOSURE_S_TO_SC: + if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) { + if (op_unknown_g(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_S_TO_SC: + sc->value = fx_proc(cdr(sc->code)) (sc, sc->code); + continue; + + case OP_SAFE_CLOSURE_A_TO_SC: + if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) { + if (op_unknown_a(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_A_TO_SC: + sc->value = fx_proc(sc->code) (sc, sc->code); + continue; + + case OP_CLOSURE_P: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_P: + op_closure_p(sc); + goto EVAL; + case OP_CLOSURE_P_1: + op_closure_p_1(sc); + goto BEGIN; + + case OP_SAFE_CLOSURE_P: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_P: + op_safe_closure_p(sc); + goto EVAL; + case OP_SAFE_CLOSURE_P_1: + op_safe_closure_p_1(sc); + goto BEGIN; + + case OP_SAFE_CLOSURE_P_A: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_P_A: + op_safe_closure_p_a(sc); + goto EVAL; + case OP_SAFE_CLOSURE_P_A_1: + op_safe_closure_p_a_1(sc); + continue; + + case OP_CLOSURE_A: + if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) { + if (op_unknown_a(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_A: + op_closure_a(sc); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(sc->code); + goto EVAL; + + case OP_CLOSURE_A_O: + if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) { + if (op_unknown_a(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_A_O: + op_closure_a(sc); + sc->code = car(sc->code); + goto EVAL; + + case OP_SAFE_CLOSURE_A: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 1)) { + if (op_unknown_a(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_A: + op_safe_closure_a(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_A_O: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) { + if (op_unknown_a(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_A_O: + op_safe_closure_a_o(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_A_A: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) { + if (op_unknown_a(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_A_A: + sc->value = op_safe_closure_a_a(sc, sc->code); + continue; + + case OP_CLOSURE_AP: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_AP: + op_closure_ap(sc); + goto EVAL; + case OP_CLOSURE_AP_1: + op_closure_ap_1(sc); + goto BEGIN; + + case OP_CLOSURE_PA: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_PA: + op_closure_pa(sc); + goto EVAL; + case OP_CLOSURE_PA_1: + op_closure_pa_1(sc); + goto BEGIN; + + case OP_CLOSURE_PP: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_PP: + op_closure_pp(sc); + goto EVAL; + case OP_CLOSURE_PP_1: + op_closure_pp_1(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_AP: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_AP: + op_safe_closure_ap(sc); + goto EVAL; + case OP_SAFE_CLOSURE_AP_1: + op_safe_closure_ap_1(sc); + goto BEGIN; + + case OP_SAFE_CLOSURE_PA: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_PA: + op_safe_closure_pa(sc); + goto EVAL; + case OP_SAFE_CLOSURE_PA_1: + op_safe_closure_pa_1(sc); + goto BEGIN; + + case OP_SAFE_CLOSURE_PP: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_PP: + op_safe_closure_pp(sc); + goto EVAL; + case OP_SAFE_CLOSURE_PP_1: + op_safe_closure_pp_1(sc); + goto EVAL; + + case OP_ANY_CLOSURE_3P: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_ANY_CLOSURE_3P: + op_any_closure_3p(sc); + goto EVAL; + case OP_ANY_CLOSURE_3P_1: + if (!op_any_closure_3p_1(sc)) + goto EVAL; + goto BEGIN; + case OP_ANY_CLOSURE_3P_2: + if (!op_any_closure_3p_2(sc)) + goto EVAL; + goto BEGIN; + case OP_ANY_CLOSURE_3P_3: + op_any_closure_3p_3(sc); + goto BEGIN; + + case OP_ANY_CLOSURE_4P: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 4)) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_ANY_CLOSURE_4P: + op_any_closure_4p(sc); + goto EVAL; + case OP_ANY_CLOSURE_4P_1: + if (!op_any_closure_4p_1(sc)) + goto EVAL; + goto BEGIN; + case OP_ANY_CLOSURE_4P_2: + if (!op_any_closure_4p_2(sc)) + goto EVAL; + goto BEGIN; + case OP_ANY_CLOSURE_4P_3: + if (!op_any_closure_4p_3(sc)) + goto EVAL; + goto BEGIN; + case OP_ANY_CLOSURE_4P_4: + op_any_closure_4p_4(sc); + goto BEGIN; + + case OP_CLOSURE_FA: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) + break; + case HOP_CLOSURE_FA: + op_closure_fa(sc); + goto EVAL; + + case OP_CLOSURE_SS: + if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) { + if (op_unknown_gg(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_SS: + op_closure_ss(sc); + goto EVAL; + + case OP_CLOSURE_SS_O: + if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) { + if (op_unknown_gg(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_SS_O: + op_closure_ss_o(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_SS: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) { + if (op_unknown_gg(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_SS: + op_safe_closure_ss(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_SS_O: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) { + if (op_unknown_gg(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_SS_O: + op_safe_closure_ss_o(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_SS_A: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) { + if (op_unknown_gg(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_SS_A: + sc->value = op_safe_closure_ss_a(sc, sc->code); + continue; + + case OP_CLOSURE_3S: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) { + if (op_unknown_ns(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_3S: + op_closure_3s(sc); + goto EVAL; + + case OP_CLOSURE_4S: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) { + if (op_unknown_ns(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_4S: + op_closure_4s(sc); + goto EVAL; + + case OP_CLOSURE_SC: + if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) { + if (op_unknown_gg(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_SC: + op_closure_sc(sc); + goto EVAL; + + case OP_CLOSURE_SC_O: + if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) { + if (op_unknown_gg(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_SC_O: + op_closure_sc_o(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_SC: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) { + if (op_unknown_gg(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_SC: + op_safe_closure_sc(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_SC_O: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) { + if (op_unknown_gg(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_SC_O: + op_safe_closure_sc_o(sc); + goto EVAL; + + case OP_CLOSURE_AA: + if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_AA: + op_closure_aa(sc); + goto EVAL; + + case OP_CLOSURE_AA_O: + if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_AA_O: + op_closure_aa_o(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_AA: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_AA: + op_safe_closure_aa(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_AA_O: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_AA_O: + op_safe_closure_aa_o(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_AA_A: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_AA_A: + sc->value = fx_safe_closure_aa_a(sc, sc->code); + continue; + + case OP_SAFE_CLOSURE_SSA: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_SSA: + op_safe_closure_ssa(sc); + goto BEGIN; + + case OP_SAFE_CLOSURE_SAA: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_SAA: + op_safe_closure_saa(sc); + goto BEGIN; + + case OP_SAFE_CLOSURE_AGG: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_AGG: + op_safe_closure_agg(sc); + goto BEGIN; + + case OP_SAFE_CLOSURE_3A: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 3)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_3A: + op_safe_closure_3a(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_NS: + if (!closure_is_fine + (sc, sc->code, FINE_SAFE_CLOSURE, + integer(opt3_arglen(cdr(sc->code))))) { + if (op_unknown_ns(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_NS: + op_safe_closure_ns(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_NA: + if (!closure_is_fine + (sc, sc->code, FINE_SAFE_CLOSURE, + integer(opt3_arglen(cdr(sc->code))))) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_NA: + op_safe_closure_na(sc); + goto EVAL; + + case OP_SAFE_CLOSURE_3S: + if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) { + if (op_unknown_ns(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_3S: + op_safe_closure_3s(sc); + goto BEGIN; + + case OP_SAFE_CLOSURE_3S_A: + if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 3)) { + if (op_unknown_ns(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_3S_A: + sc->value = op_safe_closure_3s_a(sc, sc->code); + continue; + + case OP_CLOSURE_NS: + if (!closure_is_fine + (sc, sc->code, FINE_UNSAFE_CLOSURE, + integer(opt3_arglen(cdr(sc->code))))) { + if (op_unknown_ns(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_NS: + op_closure_ns(sc); + goto EVAL; + + case OP_CLOSURE_ASS: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_ASS: + op_closure_ass(sc); + goto EVAL; + + case OP_CLOSURE_AAS: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_AAS: + op_closure_aas(sc); + goto EVAL; + + case OP_CLOSURE_SAA: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_SAA: + op_closure_saa(sc); + goto EVAL; + + case OP_CLOSURE_ASA: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_ASA: + op_closure_asa(sc); + goto EVAL; + + case OP_CLOSURE_SAS: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_SAS: + op_closure_sas(sc); + goto EVAL; + + case OP_CLOSURE_3A: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_3A: + op_closure_3a(sc); + goto EVAL; + + case OP_CLOSURE_4A: + if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_4A: + op_closure_4a(sc); + goto EVAL; + + case OP_CLOSURE_NA: + if (!closure_is_fine + (sc, sc->code, FINE_UNSAFE_CLOSURE, + integer(opt3_arglen(cdr(sc->code))))) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_NA: + op_closure_na(sc); + goto EVAL; + + case OP_ANY_CLOSURE_NA: + if (!check_closure_any(sc)) + break; + case HOP_ANY_CLOSURE_NA: + op_any_closure_na(sc); + goto BEGIN; + + case OP_ANY_CLOSURE_NP: + if (!closure_np_is_ok + (sc, sc->code, integer(opt3_arglen(cdr(sc->code))))) { + if (op_unknown_np(sc)) + goto EVAL; + continue; + } + case HOP_ANY_CLOSURE_NP: + op_any_closure_np(sc); + goto EVAL; + case OP_ANY_CLOSURE_NP_1: + if (! + (collect_np_args + (sc, OP_ANY_CLOSURE_NP_1, cons(sc, sc->value, sc->args)))) + op_any_closure_np_end(sc); + goto EVAL; + case OP_ANY_CLOSURE_NP_2: + sc->args = cons(sc, sc->value, sc->args); + op_any_closure_np_end(sc); + goto EVAL; + case OP_ANY_CLOSURE_NP_MV_1: + if (! + (collect_np_args + (sc, OP_ANY_CLOSURE_NP_MV_1, + (is_multiple_value(sc->value)) ? revappend(sc, sc->value, + sc->args) : + cons(sc, sc->value, sc->args)))) + op_any_closure_np_end(sc); + goto EVAL; + + + case OP_TC_AND_A_OR_A_LA: + tick_tc(sc, sc->cur_op); + op_tc_and_a_or_a_la(sc, sc->code); + continue; + case OP_TC_OR_A_AND_A_LA: + tick_tc(sc, sc->cur_op); + op_tc_or_a_and_a_la(sc, sc->code); + continue; + case OP_TC_AND_A_OR_A_LAA: + tick_tc(sc, sc->cur_op); + op_tc_and_a_or_a_laa(sc, sc->code); + continue; + case OP_TC_OR_A_AND_A_LAA: + tick_tc(sc, sc->cur_op); + op_tc_or_a_and_a_laa(sc, sc->code); + continue; + case OP_TC_AND_A_OR_A_A_LA: + tick_tc(sc, sc->cur_op); + op_tc_and_a_or_a_a_la(sc, sc->code); + continue; + case OP_TC_OR_A_AND_A_A_LA: + tick_tc(sc, sc->cur_op); + op_tc_or_a_and_a_a_la(sc, sc->code); + continue; + case OP_TC_OR_A_A_AND_A_A_LA: + tick_tc(sc, sc->cur_op); + op_tc_or_a_a_and_a_a_la(sc, sc->code); + continue; + case OP_TC_OR_A_AND_A_A_L3A: + tick_tc(sc, sc->cur_op); + op_tc_or_a_and_a_a_l3a(sc, sc->code); + continue; + + case OP_TC_IF_A_Z_LA: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_la(sc, sc->code, false)) + continue; + goto EVAL; + case OP_TC_IF_A_LA_Z: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_la_z(sc, sc->code, false)) + continue; + goto EVAL; + case OP_TC_COND_A_Z_LA: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_la(sc, sc->code, true)) + continue; + goto EVAL; + case OP_TC_COND_A_LA_Z: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_la_z(sc, sc->code, true)) + continue; + goto EVAL; + + case OP_TC_IF_A_LAA_Z: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_laa(sc, sc->code, false, TC_IF)) + continue; + goto EVAL; + case OP_TC_IF_A_Z_LAA: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_laa(sc, sc->code, true, TC_IF)) + continue; + goto EVAL; + case OP_TC_COND_A_Z_LAA: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_laa(sc, sc->code, true, TC_COND)) + continue; + goto EVAL; + case OP_TC_COND_A_LAA_Z: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_laa(sc, sc->code, false, TC_COND)) + continue; + goto EVAL; + case OP_TC_WHEN_LAA: + tick_tc(sc, sc->cur_op); + op_tc_when_laa(sc, sc->code); + continue; + + case OP_TC_IF_A_Z_L3A: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_l3a(sc, sc->code, true)) + continue; + goto EVAL; + case OP_TC_IF_A_L3A_Z: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_l3a(sc, sc->code, false)) + continue; + goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_LA: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_IF)) + continue; + goto EVAL; + case OP_TC_IF_A_Z_IF_A_LA_Z: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_IF)) + continue; + goto EVAL; + case OP_TC_COND_A_Z_A_Z_LA: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_COND)) + continue; + goto EVAL; + case OP_TC_COND_A_Z_A_LA_Z: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_COND)) + continue; + goto EVAL; + case OP_TC_AND_A_IF_A_LA_Z: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_AND)) + continue; + goto EVAL; + case OP_TC_AND_A_IF_A_Z_LA: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_AND)) + continue; + goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_LAA: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_if_a_z_laa(sc, false, sc->code)) + continue; + goto EVAL; + case OP_TC_IF_A_Z_IF_A_LAA_Z: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_if_a_laa_z(sc, false, sc->code)) + continue; + goto EVAL; + case OP_TC_COND_A_Z_A_Z_LAA: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_if_a_z_laa(sc, true, sc->code)) + continue; + goto EVAL; + case OP_TC_COND_A_Z_A_LAA_Z: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_if_a_laa_z(sc, true, sc->code)) + continue; + goto EVAL; + + case OP_TC_LET_IF_A_Z_LA: + tick_tc(sc, sc->cur_op); + if (op_tc_let_if_a_z_la(sc, sc->code)) + continue; + goto EVAL; + case OP_TC_LET_IF_A_Z_LAA: + tick_tc(sc, sc->cur_op); + if (op_tc_let_if_a_z_laa(sc, sc->code)) + continue; + goto EVAL; + case OP_TC_LET_WHEN_LAA: + tick_tc(sc, sc->cur_op); + op_tc_let_when_laa(sc, true, sc->code); + continue; + case OP_TC_LET_UNLESS_LAA: + tick_tc(sc, sc->cur_op); + op_tc_let_when_laa(sc, false, sc->code); + continue; + + case OP_TC_COND_A_Z_A_LAA_LAA: + tick_tc(sc, sc->cur_op); + if (op_tc_cond_a_z_a_laa_laa(sc, sc->code)) + continue; + goto EVAL; + case OP_TC_IF_A_Z_IF_A_L3A_L3A: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_if_a_l3a_l3a(sc, sc->code)) + continue; + goto EVAL; + case OP_TC_IF_A_Z_LET_IF_A_Z_LAA: + tick_tc(sc, sc->cur_op); + if (op_tc_if_a_z_let_if_a_z_laa(sc, sc->code)) + continue; + goto EVAL; + case OP_TC_CASE_LA: + tick_tc(sc, sc->cur_op); + if (op_tc_case_la(sc, sc->code)) + continue; + goto BEGIN; + case OP_TC_LET_COND: + tick_tc(sc, sc->cur_op); + if (op_tc_let_cond(sc, sc->code)) + continue; + goto EVAL; + + case OP_RECUR_IF_A_A_opA_LAq: + wrap_recur_if_a_a_opa_laq(sc, true, true); + continue; + case OP_RECUR_IF_A_A_opLA_Aq: + wrap_recur_if_a_a_opa_laq(sc, true, false); + continue; + case OP_RECUR_IF_A_opA_LAq_A: + wrap_recur_if_a_a_opa_laq(sc, false, true); + continue; + case OP_RECUR_IF_A_opLA_Aq_A: + wrap_recur_if_a_a_opa_laq(sc, false, false); + continue; + case OP_RECUR_IF_A_A_opA_LAAq: + wrap_recur(sc, op_recur_if_a_a_opa_laaq); + continue; + case OP_RECUR_IF_A_A_opA_L3Aq: + wrap_recur(sc, op_recur_if_a_a_opa_l3aq); + continue; + case OP_RECUR_IF_A_opA_LAAq_A: + wrap_recur(sc, op_recur_if_a_opa_laaq_a); + continue; + case OP_RECUR_IF_A_A_opLA_LAq: + wrap_recur_if_a_a_opla_laq(sc, true); + continue; + case OP_RECUR_IF_A_opLA_LAq_A: + wrap_recur_if_a_a_opla_laq(sc, false); + continue; + case OP_RECUR_IF_A_A_opA_LA_LAq: + wrap_recur(sc, op_recur_if_a_a_opa_la_laq); + continue; + case OP_RECUR_IF_A_opA_LA_LAq_A: + wrap_recur(sc, op_recur_if_a_opa_la_laq_a); + continue; + case OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq: + wrap_recur(sc, op_recur_if_a_a_lopl3a_l3a_l3aq); + continue; + case OP_RECUR_IF_A_A_AND_A_LAA_LAA: + wrap_recur(sc, op_recur_if_a_a_and_a_laa_laa); + continue; + case OP_RECUR_IF_A_A_opLA_LA_LAq: + wrap_recur(sc, op_recur_if_a_a_opla_la_laq); + continue; + case OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq: + wrap_recur(sc, op_recur_if_a_a_if_a_laa_opa_laaq); + continue; + case OP_RECUR_IF_A_A_IF_A_A_opLA_LAq: + wrap_recur(sc, op_recur_if_a_a_if_a_a_opla_laq); + continue; + case OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq: + wrap_recur(sc, op_recur_if_a_a_if_a_a_oplaa_laaq); + continue; + case OP_RECUR_COND_A_A_opA_LAq: + wrap_recur(sc, op_recur_cond_a_a_opa_laq); + continue; + case OP_RECUR_COND_A_A_opA_LAAq: + wrap_recur(sc, op_recur_cond_a_a_opa_laaq); + continue; + case OP_RECUR_COND_A_A_A_A_opLA_LAq: + wrap_recur(sc, op_recur_cond_a_a_a_a_opla_laq); + continue; + case OP_RECUR_COND_A_A_A_A_opA_LAAq: + wrap_recur(sc, op_recur_cond_a_a_a_a_opa_laaq); + continue; + case OP_RECUR_COND_A_A_A_A_opLAA_LAAq: + wrap_recur(sc, op_recur_cond_a_a_a_a_oplaa_laaq); + continue; + case OP_RECUR_COND_A_A_A_LAA_opA_LAAq: + wrap_recur(sc, op_recur_cond_a_a_a_laa_opa_laaq); + continue; + case OP_RECUR_COND_A_A_A_LAA_LopA_LAAq: + wrap_recur_cond_a_a_a_laa_lopa_laaq(sc); + continue; + case OP_RECUR_AND_A_OR_A_LAA_LAA: + wrap_recur(sc, op_recur_and_a_or_a_laa_laa); + continue; + + + case OP_SAFE_CLOSURE_STAR_A: + if (!closure_star_is_fine + (sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) { + if (op_unknown_a(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_STAR_A: + op_safe_closure_star_a(sc, sc->code); + goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_A1: + if (!closure_star_is_fine + (sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) { + if (op_unknown_a(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_STAR_A1: + op_safe_closure_star_a1(sc, sc->code); + goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_KA: + if (!closure_star_is_fine + (sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) { + if (op_unknown_a(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_STAR_KA: + op_safe_closure_star_ka(sc, sc->code); + goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_AA: + if (!closure_star_is_fine + (sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_STAR_AA: + op_safe_closure_star_aa(sc, sc->code); + goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_AA_O: + if (!closure_star_is_fine + (sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_STAR_AA_O: + op_safe_closure_star_aa(sc, sc->code); + sc->code = car(sc->code); + goto EVAL; + + case OP_SAFE_CLOSURE_STAR_3A: + if (!closure_star_is_fine + (sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 3)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_STAR_3A: + if (op_safe_closure_star_aaa(sc, sc->code)) + goto EVAL; + goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_NA: + if (!closure_star_is_fine + (sc, sc->code, FINE_SAFE_CLOSURE_STAR, + (is_pair(cdr(sc->code))) ? + integer(opt3_arglen(cdr(sc->code))) : 0)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_STAR_NA: + if (op_safe_closure_star_na(sc, sc->code)) + goto EVAL; + goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_NA_0: + if (!closure_star_is_fine + (sc, sc->code, FINE_SAFE_CLOSURE_STAR, 0)) { + if (op_unknown(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_STAR_NA_0: + if (op_safe_closure_star_na_0(sc, sc->code)) + goto EVAL; + goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_NA_1: + if (!closure_star_is_fine + (sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) { + if (op_unknown_a(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_STAR_NA_1: + if (op_safe_closure_star_na_1(sc, sc->code)) + goto EVAL; + goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_NA_2: + if (!closure_star_is_fine + (sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_SAFE_CLOSURE_STAR_NA_2: + if (op_safe_closure_star_na_2(sc, sc->code)) + goto EVAL; + goto BEGIN; + + + case OP_CLOSURE_STAR_A: + if (!closure_star_is_fine + (sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 1)) { + if (op_unknown_a(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_STAR_A: + op_closure_star_a(sc, sc->code); + goto BEGIN; + + case OP_CLOSURE_STAR_KA: + if (!closure_star_is_fine + (sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 1)) { + if (op_unknown_aa(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_STAR_KA: + op_closure_star_ka(sc, sc->code); + goto BEGIN; + + case OP_CLOSURE_STAR_NA: + if (!closure_star_is_fine + (sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, + (is_pair(cdr(sc->code))) ? + integer(opt3_arglen(cdr(sc->code))) : 0)) { + if (op_unknown_na(sc)) + goto EVAL; + continue; + } + case HOP_CLOSURE_STAR_NA: + if (op_closure_star_na(sc, sc->code)) + goto EVAL; + goto BEGIN; + + + case OP_UNKNOWN: + sc->last_function = lookup_checked(sc, car(sc->code)); + if (op_unknown(sc)) + goto EVAL; + continue; + case OP_UNKNOWN_NS: + sc->last_function = lookup_checked(sc, car(sc->code)); + if (op_unknown_ns(sc)) + goto EVAL; + continue; + case OP_UNKNOWN_G: + sc->last_function = lookup_checked(sc, car(sc->code)); + if (op_unknown_g(sc)) + goto EVAL; + continue; + case OP_UNKNOWN_GG: + sc->last_function = lookup_checked(sc, car(sc->code)); + if (op_unknown_gg(sc)) + goto EVAL; + continue; + case OP_UNKNOWN_A: + sc->last_function = lookup_checked(sc, car(sc->code)); + if (op_unknown_a(sc)) + goto EVAL; + continue; + case OP_UNKNOWN_AA: + sc->last_function = lookup_checked(sc, car(sc->code)); + if (op_unknown_aa(sc)) + goto EVAL; + continue; + case OP_UNKNOWN_NA: + sc->last_function = lookup_checked(sc, car(sc->code)); + if (op_unknown_na(sc)) + goto EVAL; + continue; + case OP_UNKNOWN_NP: + sc->last_function = lookup_checked(sc, car(sc->code)); + if (op_unknown_np(sc)) + goto EVAL; + continue; + + + case OP_IMPLICIT_VECTOR_REF_A: + if (op_implicit_vector_ref_a(sc) != goto_start) { + if (op_unknown_a(sc)) + goto EVAL; + } + continue; + case OP_IMPLICIT_VECTOR_REF_AA: + if (op_implicit_vector_ref_aa(sc) != goto_start) { + if (op_unknown_aa(sc)) + goto EVAL; + } + continue; + case OP_IMPLICIT_STRING_REF_A: + if (op_implicit_string_ref_a(sc) != goto_start) { + if (op_unknown_a(sc)) + goto EVAL; + } + continue; + case OP_IMPLICIT_HASH_TABLE_REF_A: + if (!op_implicit_hash_table_ref_a(sc)) { + if (op_unknown_a(sc)) + goto EVAL; + } + continue; + case OP_IMPLICIT_CONTINUATION_A: + if (!op_implicit_continuation_a(sc)) { + if (op_unknown_a(sc)) + goto EVAL; + } + continue; + case OP_IMPLICIT_ITERATE: + if (!op_implicit_iterate(sc)) { + if (op_unknown(sc)) + goto EVAL; + } + continue; + case OP_IMPLICIT_LET_REF_C: + if (!op_implicit_let_ref_c(sc)) { + if ((has_fx(cdr(sc->code))) && (op_unknown_a(sc))) + goto EVAL; + } + continue; + case OP_IMPLICIT_LET_REF_A: + if (!op_implicit_let_ref_a(sc)) { + if (op_unknown_a(sc)) + goto EVAL; + } + continue; + case OP_IMPLICIT_PAIR_REF_A: + if (!op_implicit_pair_ref_a(sc)) { + if (op_unknown_a(sc)) + goto EVAL; + } + continue; + case OP_IMPLICIT_PAIR_REF_AA: + if (!op_implicit_pair_ref_aa(sc)) { + if (op_unknown_aa(sc)) + goto EVAL; + } + continue; + case OP_IMPLICIT_C_OBJECT_REF_A: + if (!op_implicit_c_object_ref_a(sc)) { + if (op_unknown_a(sc)) + goto EVAL; + } + continue; + case OP_IMPLICIT_GOTO: + if (!op_implicit_goto(sc)) { + if (op_unknown(sc)) + goto EVAL; + } + continue; + case OP_IMPLICIT_GOTO_A: + if (!op_implicit_goto_a(sc)) { + if (op_unknown_a(sc)) + goto EVAL; + } + continue; + case OP_IMPLICIT_VECTOR_SET_3: + if (op_implicit_vector_set_3(sc)) + goto EVAL; + continue; + case OP_IMPLICIT_VECTOR_SET_4: + if (op_implicit_vector_set_4(sc)) + goto EVAL; + continue; + case OP_IMPLICIT_S7_LET_REF_S: + sc->value = s7_let_field(sc, opt3_sym(sc->code)); + continue; + case OP_IMPLICIT_S7_LET_SET_SA: + sc->value = + s7_let_field_set(sc, opt3_sym(cdr(sc->code)), + fx_call(sc, cddr(sc->code))); + continue; + + + case OP_UNOPT: + goto UNOPT; + case OP_SYM: + sc->value = lookup_checked(sc, sc->code); + continue; + case OP_GLOBAL_SYM: + sc->value = lookup_global(sc, sc->code); + continue; + case OP_CON: + sc->value = sc->code; + continue; + case OP_PAIR_PAIR: + op_pair_pair(sc); + goto EVAL; /* car is pair ((if x car cadr) ...) */ + case OP_PAIR_ANY: + sc->value = car(sc->code); + goto EVAL_ARGS_TOP; + case OP_PAIR_SYM: + sc->value = lookup_global(sc, car(sc->code)); + goto EVAL_ARGS_TOP; + + case OP_EVAL_ARGS5: + op_eval_args5(sc); + goto APPLY; + case OP_EVAL_ARGS2: + op_eval_args2(sc); + goto APPLY; /* sc->value is the last arg, [so if is_null(cdr(sc->code) and current is pair, push args2] */ + case OP_EVAL_ARGS3: + op_eval_args3(sc); + goto APPLY; /* sc->value is the next-to-last arg, and we know the last arg is not a list (so values can't mess us up!) */ + case OP_EVAL_ARGS4: + sc->args = cons(sc, sc->value, sc->args); + goto EVAL_ARGS_PAIR; + case OP_EVAL_ARGS1: + sc->args = cons(sc, sc->value, sc->args); + goto EVAL_ARGS; + + EVAL_ARGS_TOP: + case OP_EVAL_ARGS: + if (dont_eval_args(sc->value)) { + if (eval_args_no_eval_args(sc)) + goto APPLY; + goto TOP_NO_POP; + } + sc->code = cdr(sc->code); + /* sc->value is the func (but can be anything if the code is messed up: (#\a 3)) + * we don't have to delay lookup of the func because arg evaluation order is not specified, so + * (let ((func +)) (func (let () (set! func -) 3) 2)) + * can return 5. + */ + push_op_stack(sc, sc->value); + if (sc->op_stack_now >= sc->op_stack_end) + resize_op_stack(sc); + sc->args = sc->nil; + + EVAL_ARGS: /* first time, value = op, args = nil, code is args */ + if (is_pair(sc->code)) { /* evaluate current arg -- must check for pair here, not sc->nil (improper list as args) */ + if ((sc->safety > NO_SAFETY) && + (tree_is_cyclic(sc, sc->code))) + eval_error(sc, + "attempt to evaluate a circular list: ~A", + 39, sc->code); + + EVAL_ARGS_PAIR: + if (is_pair(car(sc->code))) { + eval_args_pair_car(sc); + goto EVAL; + } + if (is_pair(cdr(sc->code))) { + s7_pointer car_code = car(sc->code); /* not a pair */ + sc->code = cdr(sc->code); + sc->value = + (is_symbol(car_code)) ? lookup_checked(sc, + car_code) : + T_Pos(car_code); + /* sc->value is the current arg's value, sc->code is pointing to the next */ + + /* cdr(sc->code) might not be a pair or nil here! (eq? #f . 1) -> sc->code is 1 */ + if (is_null(cdr(sc->code))) { + if (eval_args_last_arg(sc)) + goto EVAL; + /* drop into APPLY */ + } else { + /* here we know sc->code is a pair, cdr(sc->code) is not null, sc->value is the previous arg's value */ + sc->args = cons(sc, sc->value, sc->args); + goto EVAL_ARGS_PAIR; + } + } else + eval_last_arg(sc, car(sc->code)); + /* drop into APPLY */ + } else /* got all args -- go to apply */ + /* *(--sc->op_stack_now) is the "function" (sc->value perhaps), sc->code is the arglist end, sc->args might be the preceding args reversed? */ + if (is_not_null(sc->code)) + improper_arglist_error(sc); + else { + sc->code = pop_op_stack(sc); + sc->args = proper_list_reverse_in_place(sc, sc->args); + } + + /* turning this into a call on an array of functions was not a complete disaster, but tauto.scm was ~1.5% slower. + * the array-index overhead is the same as the current switch statement's, but there was also the boolean+jump overhead, + * and the function-local overhead currently otherwise 0 if inlined. + */ + APPLY: + case OP_APPLY: + /* set_current_code(sc, history_cons(sc, sc->code, sc->args)); */ +#if SHOW_EVAL_OPS + safe_print(fprintf + (stderr, " apply %s (%s) to %s\n", + display_80(sc->code), + s7_type_names[type(sc->code)], + display_80(sc->args))); +#endif + switch (type(sc->code)) { + case T_C_FUNCTION: + apply_c_function(sc); + continue; + case T_C_ANY_ARGS_FUNCTION: + apply_c_any_args_function(sc); + continue; + case T_C_FUNCTION_STAR: + apply_c_function_star(sc); + continue; + case T_C_OPT_ARGS_FUNCTION: + apply_c_opt_args_function(sc); + continue; + case T_C_RST_ARGS_FUNCTION: + apply_c_rst_args_function(sc); + continue; + case T_CONTINUATION: + apply_continuation(sc); + continue; + case T_GOTO: + call_with_exit(sc); + continue; + case T_C_OBJECT: + apply_c_object(sc); + continue; + case T_STRING: + apply_string(sc); + continue; + case T_HASH_TABLE: + apply_hash_table(sc); + continue; + case T_ITERATOR: + apply_iterator(sc); + continue; + case T_LET: + apply_let(sc); + continue; + case T_INT_VECTOR: + case T_BYTE_VECTOR: + case T_FLOAT_VECTOR: + case T_VECTOR: + apply_vector(sc); + continue; + case T_SYNTAX: + apply_syntax(sc); + goto TOP_NO_POP; + case T_PAIR: + if (apply_pair(sc)) + continue; + goto APPLY; + case T_CLOSURE: + apply_closure(sc); + goto APPLY_LAMBDA; + case T_CLOSURE_STAR: + if (apply_closure_star(sc)) + goto EVAL; + goto BEGIN; + case T_C_MACRO: + apply_c_macro(sc); + goto EVAL; + case T_MACRO: + apply_macro(sc); + goto APPLY_LAMBDA; + case T_BACRO: + apply_bacro(sc); + goto APPLY_LAMBDA; + case T_MACRO_STAR: + apply_macro_star(sc); + goto BEGIN; + case T_BACRO_STAR: + apply_bacro_star(sc); + goto BEGIN; + default: + apply_error(sc, sc->code, sc->args); + } + + case OP_MACRO_STAR_D: + if (op_macro_star_d(sc)) + goto EVAL_ARGS_TOP; + goto BEGIN; + case OP_MACRO_D: + if (op_macro_d(sc)) + goto EVAL_ARGS_TOP; + + APPLY_LAMBDA: + case OP_APPLY_LAMBDA: + apply_lambda(sc); + goto BEGIN; + + case OP_LAMBDA_STAR_DEFAULT: + if (op_lambda_star_default(sc)) + goto EVAL; + goto BEGIN; + + case OP_MACROEXPAND_1: + switch (op_macroexpand_1(sc)) { + case goto_begin: + goto BEGIN; + case goto_eval: + goto EVAL; + case goto_start: + continue; + default: + goto APPLY_LAMBDA; + } + case OP_MACROEXPAND: + switch (op_macroexpand(sc)) { + case goto_begin: + goto BEGIN; + case goto_eval: + goto EVAL; + case goto_start: + continue; + default: + goto APPLY_LAMBDA; + } + + + HEAPSORT:if (op_heapsort(sc)) + continue; + if (sc->value != sc->F) + goto APPLY; + case OP_SORT1: + op_sort1(sc); + goto APPLY; + case OP_SORT2: + if (op_sort2(sc)) + continue; + goto HEAPSORT; + case OP_SORT: + if (!op_sort(sc)) + goto HEAPSORT; + case OP_SORT3: + if (op_sort3(sc)) + continue; + goto HEAPSORT; + case OP_SORT_PAIR_END: + sc->value = vector_into_list(sc, sc->value, car(sc->args)); + continue; + case OP_SORT_VECTOR_END: + sc->value = vector_into_fi_vector(sc->value, car(sc->args)); + continue; + case OP_SORT_STRING_END: + sc->value = vector_into_string(sc->value, car(sc->args)); + continue; + + + case OP_MAP_GATHER: + op_map_gather(sc); + case OP_MAP: + if (op_map(sc)) + continue; + goto APPLY; + + case OP_MAP_GATHER_1: + op_map_gather(sc); + case OP_MAP_1: + if (op_map_1(sc)) + continue; + goto BEGIN; + + case OP_MAP_GATHER_2: + case OP_MAP_GATHER_3: + op_map_gather(sc); + case OP_MAP_2: + if (op_map_2(sc)) + continue; + goto EVAL; + + case OP_FOR_EACH: + if (op_for_each(sc)) + continue; + goto APPLY; + case OP_FOR_EACH_1: + if (op_for_each_1(sc)) + continue; + goto BEGIN; + + case OP_FOR_EACH_2: + case OP_FOR_EACH_3: + if (op_for_each_2(sc)) + continue; + goto EVAL; + + case OP_MEMBER_IF: + case OP_MEMBER_IF1: + if (op_member_if(sc)) + continue; + goto APPLY; + + case OP_ASSOC_IF: + case OP_ASSOC_IF1: + if (op_assoc_if(sc)) + continue; + goto APPLY; + + + case OP_SAFE_DOTIMES: + SAFE_DOTIMES: /* check_do */ + switch (op_safe_dotimes(sc)) { + case goto_safe_do_end_clauses: + if (is_null(sc->code)) + continue; + goto DO_END_CODE; + case goto_do_end_clauses: + goto DO_END_CLAUSES; + case goto_eval: + goto EVAL; + case goto_top_no_pop: + goto TOP_NO_POP; + default: + goto BEGIN; + } + + case OP_SAFE_DO: + SAFE_DO: /* from check_do */ + switch (op_safe_do(sc)) { + case goto_safe_do_end_clauses: + if (is_null(sc->code)) /* I don't think multiple values (as test result) can happen here -- all safe do loops involve counters by 1 to some integer end */ + continue; + goto DO_END_CODE; + + case goto_do_unchecked: + goto DO_UNCHECKED; + default: + goto BEGIN; + } + + case OP_DOTIMES_P: + DOTIMES_P: /* from check_do */ + switch (op_dotimes_p(sc)) { + case goto_do_end_clauses: + goto DO_END_CLAUSES; + case goto_do_unchecked: + goto DO_UNCHECKED; + default: + goto EVAL; + } + + case OP_DOX: + DOX: /* from check_do */ + switch (op_dox(sc)) { + case goto_do_end_clauses: + goto DO_END_CLAUSES; + case goto_start: + continue; + case goto_top_no_pop: + goto TOP_NO_POP; /* includes dox_step_o */ + default: + goto BEGIN; + } + + DO_NO_BODY: + case OP_DO_NO_BODY_FX_VARS: + op_do_no_body_fx_vars(sc); + goto EVAL; + case OP_DO_NO_BODY_FX_VARS_STEP: + if (op_do_no_body_fx_vars_step(sc)) + goto DO_END_CLAUSES; + goto EVAL; + case OP_DO_NO_BODY_FX_VARS_STEP_1: + if (op_do_no_body_fx_vars_step_1(sc)) + goto DO_END_CLAUSES; + goto EVAL; + + case OP_DO_NO_VARS_NO_OPT: + op_do_no_vars_no_opt(sc); /* fall through */ + case OP_DO_NO_VARS_NO_OPT_1: + if (op_do_no_vars_no_opt_1(sc)) + goto DO_END_CLAUSES; + goto BEGIN; + case OP_DO_NO_VARS: + if (op_do_no_vars(sc)) + goto DO_END_CLAUSES; + goto BEGIN; + case OP_SAFE_DOTIMES_STEP_O: + if (op_safe_dotimes_step_o(sc)) + goto DO_END_CLAUSES; + goto EVAL; + case OP_SAFE_DOTIMES_STEP: + if (op_safe_dotimes_step(sc)) + goto DO_END_CLAUSES; + goto EVAL; + case OP_SAFE_DO_STEP: + if (op_safe_do_step(sc)) + goto DO_END_CLAUSES; + goto BEGIN; + case OP_SIMPLE_DO: + if (op_simple_do(sc)) + goto DO_END_CLAUSES; + goto BEGIN; + case OP_SIMPLE_DO_STEP: + if (op_simple_do_step(sc)) + goto DO_END_CLAUSES; + goto BEGIN; + case OP_DOTIMES_STEP_O: + if (op_dotimes_step_o(sc)) + goto DO_END_CLAUSES; + goto EVAL; + case OP_DOX_INIT: + if (op_dox_init(sc)) + goto DO_END_CLAUSES; + goto BEGIN; + case OP_DOX_STEP: + if (op_dox_step(sc)) + goto DO_END_CLAUSES; + goto BEGIN; + case OP_DOX_STEP_O: + if (op_dox_step_o(sc)) + goto DO_END_CLAUSES; + goto EVAL; + case OP_DOX_NO_BODY: + op_dox_no_body(sc); + continue; + case OP_DOX_PENDING_NO_BODY: + op_dox_pending_no_body(sc); + goto DO_END_CLAUSES; + + case OP_DO_INIT: + if (op_do_init(sc)) + goto DO_END; + goto EVAL; + + case OP_DO: + if (is_null(check_do(sc))) + switch (optimize_op(sc->code)) { + case OP_DOX: + goto DOX; + case OP_SAFE_DOTIMES: + goto SAFE_DOTIMES; + case OP_DOTIMES_P: + goto DOTIMES_P; + case OP_SAFE_DO: + goto SAFE_DO; + case OP_DO_NO_BODY_FX_VARS: + goto DO_NO_BODY; + case OP_DO_NO_VARS: + if (op_do_no_vars(sc)) + goto DO_END_CLAUSES; + goto BEGIN; + case OP_DOX_NO_BODY: + op_dox_no_body(sc); + continue; + case OP_DOX_PENDING_NO_BODY: + op_dox_pending_no_body(sc); + goto DO_END_CLAUSES; + default: + if (op_simple_do(sc)) + goto DO_END_CLAUSES; + goto BEGIN; + } + + case OP_DO_UNCHECKED: + op_do_unchecked(sc); + + DO_UNCHECKED: + if (do_unchecked(sc)) + goto EVAL; + + DO_END: + case OP_DO_END: + if (op_do_end(sc)) + goto EVAL; + + case OP_DO_END1: + switch (op_do_end1(sc)) { + case goto_start: + continue; + case goto_eval: + goto EVAL; + case goto_begin: + goto BEGIN; + case goto_feed_to: + goto FEED_TO; + case goto_do_end: + goto DO_END; + default: + break; + } + + case OP_DO_STEP: + if (op_do_step(sc)) + goto DO_END; + goto EVAL; + case OP_DO_STEP2: + if (op_do_step2(sc)) + goto DO_END; + goto EVAL; + + DO_END_CLAUSES: + if (do_end_clauses(sc)) + continue; + + DO_END_CODE: + switch (do_end_code(sc)) { + case goto_feed_to: + goto FEED_TO; + case goto_eval: + goto EVAL; + default: + continue; + } + + + case OP_BEGIN_UNCHECKED: + set_current_code(sc, sc->code); + sc->code = T_Pair(cdr(sc->code)); + goto BEGIN; + + case OP_BEGIN: + if (op_begin(sc, sc->code)) + continue; + sc->code = T_Pair(cdr(sc->code)); + + case OP_BEGIN_HOOK: + if (sc->begin_hook) { + /* call_begin_hook might clobber sc->code? via s7_eval_string probably yes */ + set_current_code(sc, sc->code); + if (call_begin_hook(sc)) + return (sc->F); + } + case OP_BEGIN_NO_HOOK: + goto BEGIN; + + case OP_BEGIN_2_UNCHECKED: + push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); + sc->code = cadr(sc->code); + goto EVAL; + + case OP_BEGIN_AA: + sc->value = fx_begin_aa(sc, sc->code); + continue; + case OP_BEGIN_NA: + sc->value = fx_begin_na(sc, sc->code); + continue; + + + case OP_EVAL: + goto EVAL; + case OP_EVAL_STRING: + op_eval_string(sc); + goto EVAL; + + case OP_QUOTE: + sc->value = check_quote(sc, sc->code); + continue; + case OP_QUOTE_UNCHECKED: + sc->value = cadr(sc->code); + continue; + + case OP_DEFINE_FUNCHECKED: + define_funchecked(sc); + continue; + case OP_DEFINE_CONSTANT1: + op_define_constant1(sc); + continue; + + case OP_DEFINE_CONSTANT: + if (op_define_constant(sc)) + continue; + + case OP_DEFINE_STAR: + case OP_DEFINE: + check_define(sc); + + case OP_DEFINE_CONSTANT_UNCHECKED: + case OP_DEFINE_STAR_UNCHECKED: + case OP_DEFINE_UNCHECKED: + if (op_define_unchecked(sc)) + goto TOP_NO_POP; + + case OP_DEFINE1: + if (op_define1(sc) == goto_apply) + goto APPLY; + case OP_DEFINE_WITH_SETTER: + op_define_with_setter(sc); + continue; + + case OP_SET_LET_S: /* (set! (*s7* 'print-length) i) */ + sc->code = cdr(sc->code); + if (set_pair_p_3 + (sc, lookup_slot_from(caar(sc->code), sc->curlet), + cadr(cadar(sc->code)), lookup(sc, cadr(sc->code)))) + goto APPLY; + continue; + + case OP_SET_LET_FX: /* (set! (hook 'result) 123) or (set! (H 'c) 32) */ + sc->code = cdr(sc->code); + if (set_pair_p_3 + (sc, lookup_slot_from(caar(sc->code), sc->curlet), + cadr(cadar(sc->code)), fx_call(sc, cdr(sc->code)))) + goto APPLY; + continue; + + case OP_SET_PAIR_ZA: /* unknown setter pair, but value is easy */ + sc->code = cdr(sc->code); + sc->value = fx_call(sc, cdr(sc->code)); + + case OP_SET_PAIR_P_1: + if (op_set_pair_p_1(sc)) + goto APPLY; + continue; + case OP_SET_PAIR: + if (op_set_pair(sc)) + goto APPLY; + continue; + + case OP_SET_PAIR_P: + op_set_pair_p(sc); + goto EVAL; + case OP_SET_PAIR_A: + op_set_pair_a(sc); + continue; + + case OP_SET_PWS: + op_set_pws(sc); + continue; + case OP_SET_DILAMBDA_SA_A: + op_set_dilambda_sa_a(sc); + continue; + case OP_SET_DILAMBDA_P: + op_set_dilambda_p(sc); + goto EVAL; + case OP_SET_DILAMBDA: + op_set_dilambda(sc); /* fall through */ + case OP_SET_DILAMBDA_P_1: + switch (op_set_dilambda_p_1(sc)) { + case goto_begin: + goto BEGIN; + case goto_apply: + goto APPLY; + default: + continue; + } + + case OP_INCREMENT_BY_1: + op_increment_by_1(sc); + continue; + case OP_DECREMENT_BY_1: + op_decrement_by_1(sc); + continue; + case OP_INCREMENT_SS: + op_increment_ss(sc); + continue; + case OP_INCREMENT_SA: + op_increment_sa(sc); + continue; + case OP_INCREMENT_SAA: + op_increment_saa(sc); + continue; + case OP_INCREMENT_SP: + op_increment_sp(sc); + goto EVAL; + case OP_INCREMENT_SP_1: + op_increment_sp_1(sc); + continue; + case OP_INCREMENT_SP_MV: + op_increment_sp_mv(sc); + continue; + + case OP_SET_SYMBOL_C: + op_set_symbol_c(sc); + continue; + case OP_SET_SYMBOL_S: + op_set_symbol_s(sc); + continue; + case OP_SET_SYMBOL_A: + op_set_symbol_a(sc); + continue; + case OP_SET_SYMBOL_P: + op_set_symbol_p(sc); + goto EVAL; + case OP_SET_CONS: + op_set_cons(sc); + continue; + case OP_SET_SAFE: + op_set_safe(sc); + continue; + case OP_SET_FROM_SETTER: + slot_set_value(sc->code, sc->value); + continue; /* mv caught in splice_in_values */ + case OP_SET_FROM_LET_TEMP: + op_set_from_let_temp(sc); + continue; + + case OP_SET2: + switch (op_set2(sc)) { + case goto_eval: + goto EVAL; + case goto_top_no_pop: + goto TOP_NO_POP; + case goto_start: + continue; + case goto_apply: + goto APPLY; + default: + goto EVAL_ARGS; + } + + case OP_SET: + check_set(sc); + case OP_SET_UNCHECKED: + if (is_pair(cadr(sc->code))) /* has setter */ + switch (set_implicit(sc)) { + case goto_top_no_pop: + goto TOP_NO_POP; + case goto_start: + continue; + case goto_apply: + goto APPLY; + default: + goto EVAL_ARGS; + } + + case OP_SET_NORMAL: + if (op_set_normal(sc)) + goto EVAL; + case OP_SET1: + if (op_set1(sc)) + continue; + goto APPLY; + + case OP_SET_WITH_LET_1: + if (op_set_with_let_1(sc)) + goto TOP_NO_POP; + goto SET_WITH_LET; + case OP_SET_WITH_LET_2: + if (op_set_with_let_2(sc)) + continue; + + SET_WITH_LET: + activate_with_let(sc, sc->value); /* this activates sc->value, so the set! will happen in that environment */ + if (is_pair(cadr(sc->code))) + switch (set_implicit(sc)) { + case goto_top_no_pop: + goto TOP_NO_POP; + case goto_start: + continue; + case goto_apply: + goto APPLY; + default: + goto EVAL_ARGS; + } + s7_error(sc, sc->out_of_range_symbol, + set_elist_2(sc, wrap_string(sc, "can't set ~A", 12), + sc->args)); + + + case OP_IF: + op_if(sc); + goto EVAL; + case OP_IF_UNCHECKED: + op_if_unchecked(sc); + goto EVAL; + case OP_IF1: + if (op_if1(sc)) + goto EVAL; + continue; + +#define if_a_p(sc) if (is_true(sc, fx_call(sc, cdr(sc->code)))) +#define if_not_a_p(sc) if (is_false(sc, fx_call(sc, opt3_pair(sc->code)))) /* cdadr(sc->code) */ + + case OP_IF_A_C_C: + sc->value = + (is_true(sc, fx_call(sc, cdr(sc->code)))) ? + opt1_con(sc->code) + : opt2_con(sc->code); + continue; + case OP_IF_A_A: + sc->value = + (is_true(sc, fx_call(sc, cdr(sc->code)))) ? fx_call(sc, + opt1_pair + (sc->code)) + : sc->unspecified; + continue; + case OP_IF_S_A_A: + sc->value = + (is_true(sc, lookup(sc, cadr(sc->code)))) ? fx_call(sc, + opt1_pair + (sc->code)) + : fx_call(sc, opt2_pair(sc->code)); + continue; + case OP_IF_A_A_A: + sc->value = + (is_true(sc, fx_call(sc, cdr(sc->code)))) ? fx_call(sc, + opt1_pair + (sc->code)) + : fx_call(sc, opt2_pair(sc->code)); + continue; + case OP_IF_A_A_P: + if_a_p(sc) { + sc->value = fx_call(sc, opt1_pair(sc->code)); + continue; + } + sc->code = opt2_any(sc->code); + goto EVAL; + case OP_IF_A_P_A: + if_a_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = fx_call(sc, opt2_pair(sc->code)); + continue; + case OP_IF_NOT_A_A: + sc->value = + (is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ? + fx_call(sc, opt2_pair(sc->code)) : sc->unspecified; + continue; + case OP_IF_NOT_A_A_A: + sc->value = + (is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ? + fx_call(sc, opt2_pair(sc->code)) : fx_call(sc, + opt3_pair + (sc->code)); + continue; + case OP_IF_AND2_S_A: + sc->value = fx_if_and2_s_a(sc, sc->code); + continue; + +#define call_bfunc(Sc, Expr) ((s7_bfunc)opt3_any(cdr(Sc->code)))(Sc, Expr) + case OP_IF_B_A: + sc->value = + (call_bfunc(sc, cadr(sc->code))) ? fx_call(sc, + opt1_pair + (sc->code)) + : sc->unspecified; + continue; + case OP_IF_B_A_P: + if (call_bfunc(sc, cadr(sc->code))) { + sc->value = fx_call(sc, opt1_pair(sc->code)); + continue; + } + sc->code = opt2_any(sc->code); + goto EVAL; + case OP_IF_B_P_A: + if (call_bfunc(sc, cadr(sc->code))) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = fx_call(sc, opt2_pair(sc->code)); + continue; + case OP_IF_B_P_P: + if (call_bfunc(sc, cadr(sc->code))) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + +#define if_s_p(sc) if (is_true(sc, lookup(sc, cadr(sc->code)))) +#define if_not_s_p(sc) if (is_false(sc, lookup(sc, opt1_sym(cdr(sc->code))))) /* cadadr(sc->code) */ + + case OP_IF_S_P: + if_s_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_S_R: + if_s_p(sc) { + sc->value = sc->unspecified; + continue; + } + sc->code = opt1_any(sc->code); + goto EVAL; + case OP_IF_S_P_P: + if_s_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + case OP_IF_S_N: + if_not_s_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_S_N_N: + if_not_s_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + + case OP_IF_S_P_A: + if_s_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = fx_call(sc, opt2_pair(sc->code)); + continue; + + case OP_IF_A_P: + if_a_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_A_R: + if_a_p(sc) { + sc->value = sc->unspecified; + continue; + } + sc->code = opt1_any(sc->code); + goto EVAL; + case OP_IF_A_P_P: + if_a_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + case OP_IF_A_N: + if_not_a_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_A_N_N: + if_not_a_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + + case OP_IF_B_P: + if (call_bfunc(sc, cadr(sc->code))) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_B_R: + if (call_bfunc(sc, cadr(sc->code))) { + sc->value = sc->unspecified; + continue; + } + sc->code = opt1_any(sc->code); + goto EVAL; + case OP_IF_B_N_N: + if (call_bfunc(sc, car(opt3_pair(sc->code)))) { + sc->code = opt2_any(sc->code); + goto EVAL; + } + sc->code = opt1_any(sc->code); + goto EVAL; + +#define if_is_type_s_p(sc) if (gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))) +#define if_is_not_type_s_p(sc) if (!gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))) + + case OP_IF_IS_TYPE_S_P: + if_is_type_s_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_IS_TYPE_S_R: + if_is_type_s_p(sc) { + sc->value = sc->unspecified; + continue; + } + sc->code = opt1_any(sc->code); + goto EVAL; + case OP_IF_IS_TYPE_S_P_P: + if_is_type_s_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + case OP_IF_IS_TYPE_S_N: + if_is_not_type_s_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_IS_TYPE_S_N_N: + if_is_not_type_s_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + + case OP_IF_IS_TYPE_S_A_A: + if_is_type_s_p(sc) sc->value = fx_call(sc, cddr(sc->code)); + else + sc->value = fx_call(sc, opt2_pair(sc->code)); + continue; + case OP_IF_IS_TYPE_S_P_A: + if_is_type_s_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = fx_call(sc, opt2_pair(sc->code)); + continue; + +#define if_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_true(sc, fn_proc(cadr(sc->code))(sc, sc->t1_1))) +#define if_not_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_false(sc, fn_proc(opt1_pair(cdr(sc->code)))(sc, sc->t1_1))) /* cadadr */ + + case OP_IF_opSq_P: + if_opsq_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_opSq_R: + if_opsq_p(sc) { + sc->value = sc->unspecified; + continue; + } + sc->code = opt1_any(sc->code); + goto EVAL; + case OP_IF_opSq_P_P: + if_opsq_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + case OP_IF_opSq_N: + if_not_opsq_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_opSq_N_N: + if_not_opsq_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + +#define if_and2_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) +#define if_not_and2_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) + + case OP_IF_AND2_P: + if_and2_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_AND2_R: + if_and2_p(sc) { + sc->value = sc->unspecified; + continue; + } + sc->code = opt1_any(sc->code); + goto EVAL; + case OP_IF_AND2_P_P: + if_and2_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + case OP_IF_AND2_N: + if_not_and2_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_AND2_N_N: + if_not_and2_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + +#define if_or2_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) +#define if_not_or2_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) + + case OP_IF_OR2_P: + if_or2_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_OR2_R: + if_or2_p(sc) { + sc->value = sc->unspecified; + continue; + } + sc->code = opt1_any(sc->code); + goto EVAL; + case OP_IF_OR2_P_P: + if_or2_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + case OP_IF_OR2_N: + if_not_or2_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_OR2_N_N: + if_not_or2_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + +#define if_and3_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && \ + (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt1_pair(cdr(sc->code)))))) +#define if_not_and3_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || \ + (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt1_pair(cdr(sc->code)))))) + + case OP_IF_AND3_P: + if_and3_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_AND3_R: + if_and3_p(sc) { + sc->value = sc->unspecified; + continue; + } + sc->code = opt1_any(sc->code); + goto EVAL; + case OP_IF_AND3_P_P: + if_and3_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + case OP_IF_AND3_N: + if_not_and3_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->value = sc->unspecified; + continue; + case OP_IF_AND3_N_N: + if_not_and3_p(sc) { + sc->code = opt1_any(sc->code); + goto EVAL; + } + sc->code = opt2_any(sc->code); + goto EVAL; + +#define if_p_push(op) do {push_stack_no_args(sc, op, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code));} while (0) + case OP_IF_P_P: + if_p_push(OP_IF_PP); + goto EVAL; + case OP_IF_P_N: + if_p_push(OP_IF_PR); + goto EVAL; + case OP_IF_P_P_P: + if_p_push(OP_IF_PPP); + goto EVAL; + case OP_IF_P_R: + if_p_push(OP_IF_PR); + goto EVAL; + case OP_IF_P_N_N: + if_p_push(OP_IF_PRR); + goto EVAL; + +#define if_bp_push(op) do {push_stack_no_args(sc, op, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code));} while (0) + case OP_IF_ANDP_P: + if_bp_push(OP_IF_PP); + goto AND_P; + case OP_IF_ANDP_R: + if_bp_push(OP_IF_PR); + goto AND_P; + case OP_IF_ANDP_P_P: + if_bp_push(OP_IF_PPP); + goto AND_P; + case OP_IF_ANDP_N: + if_bp_push(OP_IF_PR); + goto AND_P; + case OP_IF_ANDP_N_N: + if_bp_push(OP_IF_PRR); + goto AND_P; + + case OP_IF_ORP_P: + if_bp_push(OP_IF_PP); + goto OR_P; + case OP_IF_ORP_R: + if_bp_push(OP_IF_PR); + goto OR_P; + case OP_IF_ORP_P_P: + if_bp_push(OP_IF_PPP); + goto OR_P; + case OP_IF_ORP_N: + if_bp_push(OP_IF_PR); + goto OR_P; + case OP_IF_ORP_N_N: + if_bp_push(OP_IF_PRR); + goto OR_P; + + case OP_IF_PP: + if (sc->value != sc->F) + goto EVAL; + sc->value = sc->unspecified; + continue; + case OP_IF_PR: + if (sc->value == sc->F) + goto EVAL; + sc->value = sc->unspecified; + continue; + case OP_IF_PPP: + sc->code = + (sc->value != sc->F) ? car(sc->code) : cadr(sc->code); + goto EVAL; + case OP_IF_PRR: + sc->code = + (sc->value == sc->F) ? car(sc->code) : cadr(sc->code); + goto EVAL; + + case OP_COND_FEED: + if (op_cond_feed(sc)) + goto EVAL; /* else fall through */ + case OP_COND_FEED_1: + if (op_cond_feed_1(sc)) + goto EVAL; + continue; + + + case OP_WHEN: + check_when(sc); + goto EVAL; + case OP_WHEN_S: + if (op_when_s(sc)) + continue; + goto EVAL; + case OP_WHEN_A: + if (op_when_a(sc)) + continue; + goto EVAL; + case OP_WHEN_P: + op_when_p(sc); + goto EVAL; + case OP_WHEN_AND_2A: + if (op_when_and_2a(sc)) + continue; + goto EVAL; + case OP_WHEN_AND_3A: + if (op_when_and_3a(sc)) + continue; + goto EVAL; + case OP_WHEN_AND_AP: + if (op_when_and_ap(sc)) + continue; + goto EVAL; + case OP_WHEN_PP: + if (op_when_pp(sc)) + continue; + goto EVAL; + + case OP_UNLESS: + check_unless(sc); + goto EVAL; + case OP_UNLESS_S: + if (op_unless_s(sc)) + continue; + goto EVAL; + case OP_UNLESS_A: + if (op_unless_a(sc)) + continue; + goto EVAL; + case OP_UNLESS_P: + op_unless_p(sc); + goto EVAL; + case OP_UNLESS_PP: + if (op_unless_pp(sc)) + continue; + goto EVAL; + + + case OP_NAMED_LET_NO_VARS: + op_named_let_no_vars(sc); + goto BEGIN; + case OP_NAMED_LET: + if (op_named_let(sc)) + goto BEGIN; + goto EVAL; + case OP_NAMED_LET_A: + op_named_let_a(sc); + goto BEGIN; + case OP_NAMED_LET_AA: + op_named_let_aa(sc); + goto BEGIN; + case OP_NAMED_LET_FX: + if (op_named_let_fx(sc)) + goto BEGIN; + goto EVAL; + + case OP_LET: + if (op_let(sc)) + goto BEGIN; + goto EVAL; + case OP_LET_UNCHECKED: + if (op_let_unchecked(sc)) + goto BEGIN; + goto EVAL; + case OP_LET1: + if (op_let1(sc)) + goto BEGIN; + goto EVAL; + case OP_LET_NO_VARS: + op_let_no_vars(sc); + goto BEGIN; + + case OP_LET_A_A_OLD: + op_let_a_a_old(sc); + continue; + case OP_LET_A_A_NEW: + op_let_a_a_new(sc); + continue; + case OP_LET_A_FX_OLD: + op_let_a_fx_old(sc); + continue; + case OP_LET_A_FX_NEW: + op_let_a_fx_new(sc); + continue; + case OP_LET_FX_OLD: + op_let_fx_old(sc); + goto BEGIN; + case OP_LET_FX_NEW: + op_let_fx_new(sc); + goto BEGIN; + case OP_LET_2A_OLD: + op_let_2a_old(sc); + goto EVAL; + case OP_LET_2A_NEW: + op_let_2a_new(sc); + goto EVAL; + case OP_LET_3A_OLD: + op_let_3a_old(sc); + goto EVAL; + case OP_LET_3A_NEW: + op_let_3a_new(sc); + goto EVAL; + case OP_LET_ONE_OLD: + op_let_one_old(sc); + goto EVAL; + case OP_LET_ONE_NEW: + op_let_one_new(sc); + goto EVAL; + case OP_LET_ONE_P_OLD: + op_let_one_p_old(sc); + goto EVAL; + case OP_LET_ONE_P_NEW: + op_let_one_p_new(sc); + goto EVAL; + + case OP_LET_A_OLD: + op_let_a_old(sc); + sc->code = cdr(sc->code); + goto BEGIN; + case OP_LET_A_NEW: + op_let_a_new(sc); + sc->code = cdr(sc->code); + goto BEGIN; + case OP_LET_A_OLD_2: + op_let_a_old(sc); + push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); + sc->code = cadr(sc->code); + goto EVAL; + case OP_LET_A_NEW_2: + op_let_a_new(sc); + push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); + sc->code = cadr(sc->code); + goto EVAL; + case OP_LET_A_P_OLD: + op_let_a_old(sc); + sc->code = cadr(sc->code); + goto EVAL; + case OP_LET_A_P_NEW: + op_let_a_new(sc); + sc->code = cadr(sc->code); + goto EVAL; + case OP_LET_ONE_OLD_1: + op_let_one_old_1(sc); + goto BEGIN; + case OP_LET_ONE_P_OLD_1: + op_let_one_p_old_1(sc); + goto EVAL; + case OP_LET_ONE_NEW_1: + sc->curlet = + make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code), + sc->value); + goto BEGIN; + case OP_LET_ONE_P_NEW_1: + sc->curlet = + make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code), + sc->value); + sc->code = car(sc->code); + goto EVAL; + + case OP_LET_opSSq_OLD: + op_let_opssq_old(sc); + goto BEGIN; + case OP_LET_opSSq_NEW: + op_let_opssq_new(sc); + goto BEGIN; + case OP_LET_opSSq_E_OLD: + op_let_opssq_e_old(sc); + goto EVAL; + case OP_LET_opSSq_E_NEW: + op_let_opssq_e_new(sc); + goto EVAL; + case OP_LET_opaSSq_OLD: + op_let_opassq_old(sc); + goto BEGIN; + case OP_LET_opaSSq_NEW: + op_let_opassq_new(sc); + goto BEGIN; + case OP_LET_opaSSq_E_OLD: + op_let_opassq_e_old(sc); + goto EVAL; + case OP_LET_opaSSq_E_NEW: + op_let_opassq_e_new(sc); + goto EVAL; + + case OP_LET_STAR_FX: + op_let_star_fx(sc); + goto BEGIN; + case OP_LET_STAR_FX_A: + op_let_star_fx_a(sc); + continue; + + case OP_NAMED_LET_STAR: + op_named_let_star(sc); + goto EVAL; + case OP_LET_STAR2: + op_let_star2(sc); + goto EVAL; + case OP_LET_STAR: + if (check_let_star(sc)) + goto EVAL; + goto BEGIN; + case OP_LET_STAR1: + if (op_let_star1(sc)) + goto EVAL; + goto BEGIN; + + case OP_LETREC: + check_letrec(sc, true); + case OP_LETREC_UNCHECKED: + if (op_letrec_unchecked(sc)) + goto EVAL; + goto BEGIN; + case OP_LETREC1: + if (op_letrec1(sc)) + goto EVAL; + goto BEGIN; + + case OP_LETREC_STAR: + check_letrec(sc, false); + case OP_LETREC_STAR_UNCHECKED: + if (op_letrec_star_unchecked(sc)) + goto EVAL; + goto BEGIN; + case OP_LETREC_STAR1: + if (op_letrec_star1(sc)) + goto EVAL; + goto BEGIN; + + + case OP_LET_TEMPORARILY: + check_let_temporarily(sc); + case OP_LET_TEMP_UNCHECKED: + op_let_temp_unchecked(sc); + goto LET_TEMP_INIT1; + + case OP_LET_TEMP_INIT1: + set_caddr(sc->args, cons(sc, sc->value, caddr(sc->args))); + LET_TEMP_INIT1: + if (op_let_temp_init1(sc)) + goto EVAL; + case OP_LET_TEMP_INIT2: + switch (op_let_temp_init2(sc)) { + case goto_begin: + goto BEGIN; + case goto_eval: + goto EVAL; + default: + break; + } + + case OP_LET_TEMP_DONE: + push_stack(sc, OP_GC_PROTECT, sc->args, sc->value); /* fall through */ + case OP_LET_TEMP_DONE1: + if (op_let_temp_done1(sc)) + continue; + goto EVAL; + + case OP_LET_TEMP_S7: + if (op_let_temp_s7(sc)) + goto BEGIN; + sc->value = sc->nil; + continue; + case OP_LET_TEMP_FX: + if (op_let_temp_fx(sc)) + goto BEGIN; + sc->value = sc->nil; + continue; + case OP_LET_TEMP_FX_1: + if (op_let_temp_fx_1(sc)) + goto BEGIN; + sc->value = sc->nil; + continue; + case OP_LET_TEMP_SETTER: + if (op_let_temp_setter(sc)) + goto BEGIN; + sc->value = sc->nil; + continue; + case OP_LET_TEMP_A_A: + sc->value = fx_let_temp_a_a(sc, sc->code); + continue; + + case OP_LET_TEMP_UNWIND: + op_let_temp_unwind(sc); + continue; + case OP_LET_TEMP_S7_UNWIND: + op_let_temp_s7_unwind(sc); + continue; + case OP_LET_TEMP_SETTER_UNWIND: + op_let_temp_setter_unwind(sc); + continue; + + + case OP_COND: + check_cond(sc); + case OP_COND_UNCHECKED: + if (op_cond_unchecked(sc)) + goto EVAL; + case OP_COND1: + if (op_cond1(sc)) + goto TOP_NO_POP; + + FEED_TO: + if (feed_to(sc)) + goto APPLY; + goto EVAL; + case OP_FEED_TO_1: + sc->code = sc->value; + goto APPLY; /* sc->args saved in feed_to via push_stack */ + + case OP_COND_SIMPLE: + if (op_cond_simple(sc)) + goto EVAL; + case OP_COND1_SIMPLE: + if (op_cond1_simple(sc)) + goto TOP_NO_POP; + goto BEGIN; + case OP_COND_SIMPLE_O: + if (op_cond_simple_o(sc)) + goto EVAL; + case OP_COND1_SIMPLE_O: + if (op_cond1_simple_o(sc)) + continue; + goto EVAL; + + case OP_COND_FX_FX: + sc->value = fx_cond_fx_fx(sc, sc->code); + continue; + case OP_COND_FX_NP: + if (op_cond_fx_np(sc)) + continue; + goto EVAL; + case OP_COND_FX_NP_1: + if (op_cond_fx_np_1(sc)) + continue; + goto EVAL; + case OP_COND_FX_NP_O: + if (op_cond_fx_np_o(sc)) + continue; + goto EVAL; + case OP_COND_FX_2E: + if (op_cond_fx_2e(sc)) + continue; + goto EVAL; + case OP_COND_FX_3E: + if (op_cond_fx_3e(sc)) + continue; + goto EVAL; + + + case OP_AND: + if (check_and(sc, sc->code)) + continue; + + case OP_AND_P: + sc->code = cdr(sc->code); + AND_P: /* this code (and OR_P below) is ugly, but the pretty version (procedurized) is much slower */ + if (has_fx(sc->code)) { /* all fx_proc's are set via fx_choose which can return nil, but it is not cleared when type is */ + /* so, if (fx_proc(sc->code)) here and in OR_P is not safe */ + sc->value = fx_call(sc, sc->code); + if (is_false(sc, sc->value)) + continue; + sc->code = cdr(sc->code); + if (is_null(sc->code)) /* this order of checks appears to be faster than any of the alternatives */ + continue; + goto AND_P; + } + if (is_not_null(cdr(sc->code))) + push_stack_no_args(sc, OP_AND_P1, cdr(sc->code)); + sc->code = car(sc->code); + goto EVAL; + + case OP_AND_P1: + if ((is_false(sc, sc->value)) || (is_null(sc->code))) + continue; + goto AND_P; + + case OP_AND_AP: + if (op_and_ap(sc)) + continue; + goto EVAL; + case OP_AND_2A: + sc->value = fx_and_2a(sc, sc->code); + continue; + case OP_AND_3A: + sc->value = fx_and_3a(sc, sc->code); + continue; + case OP_AND_N: + sc->value = fx_and_n(sc, sc->code); + continue; + case OP_AND_S_2: + sc->value = fx_and_s_2(sc, sc->code); + continue; + case OP_AND_PAIR_P: + if (op_and_pair_p(sc)) + continue; + goto EVAL; + case OP_AND_SAFE_P1: + op_and_safe_p1(sc); + goto EVAL; + case OP_AND_SAFE_P2: + if (op_and_safe_p2(sc)) + continue; + goto EVAL; + case OP_AND_SAFE_P3: + if (op_and_safe_p3(sc)) + continue; + goto EVAL; + case OP_AND_SAFE_P_REST: + if (is_true(sc, sc->value)) + sc->value = fx_and_n(sc, sc->code); + continue; + + + case OP_OR: + if (check_or(sc, sc->code)) + continue; + + case OP_OR_P: + sc->code = cdr(sc->code); + OR_P: + if (has_fx(sc->code)) { + sc->value = fx_call(sc, sc->code); + if (is_true(sc, sc->value)) + continue; + sc->code = cdr(sc->code); + if (is_null(sc->code)) + continue; + goto OR_P; + } + if (is_not_null(cdr(sc->code))) + push_stack_no_args(sc, OP_OR_P1, cdr(sc->code)); + sc->code = car(sc->code); + goto EVAL; + + case OP_OR_P1: + if ((is_true(sc, sc->value)) || (is_null(sc->code))) + continue; + goto OR_P; + + case OP_OR_AP: + if (op_or_ap(sc)) + continue; + goto EVAL; + case OP_OR_2A: + sc->value = fx_or_2a(sc, sc->code); + continue; + case OP_OR_S_2: + sc->value = fx_or_s_2(sc, sc->code); + continue; + case OP_OR_S_TYPE_2: + sc->value = fx_or_s_type_2(sc, sc->code); + continue; + case OP_OR_3A: + sc->value = fx_or_3a(sc, sc->code); + continue; + case OP_OR_N: + sc->value = fx_or_n(sc, sc->code); + continue; + + + case OP_EVAL_MACRO: + op_eval_macro(sc); + goto EVAL; + case OP_EVAL_MACRO_MV: + if (op_eval_macro_mv(sc)) + continue; + goto EVAL; + case OP_EXPANSION: + op_finish_expansion(sc); + continue; + + case OP_DEFINE_BACRO: + case OP_DEFINE_BACRO_STAR: + case OP_DEFINE_EXPANSION: + case OP_DEFINE_EXPANSION_STAR: + case OP_DEFINE_MACRO: + case OP_DEFINE_MACRO_STAR: + op_define_macro(sc); + continue; + + case OP_MACRO: + case OP_BACRO: + case OP_MACRO_STAR: + case OP_BACRO_STAR: + op_macro(sc); + continue; + + case OP_LAMBDA: + sc->value = op_lambda(sc, sc->code); + continue; + case OP_LAMBDA_UNCHECKED: + sc->value = op_lambda_unchecked(sc, sc->code); + continue; + + case OP_LAMBDA_STAR: + op_lambda_star(sc); + continue; + case OP_LAMBDA_STAR_UNCHECKED: + op_lambda_star_unchecked(sc); + continue; + + + case OP_CASE: /* car(sc->code) is the selector */ + /* selector A, key type: E=eq (symbol/char), I=integer, G=any, S=single keys and single bodies */ + if (check_case(sc)) + goto EVAL; /* else drop into CASE_G_G -- selector is a symbol or constant */ + + case OP_CASE_G_G: + if (op_case_g_g(sc)) + goto TOP_NO_POP; + goto FEED_TO; + case OP_CASE_A_G_G: + sc->value = fx_call(sc, cdr(sc->code)); + if (op_case_g_g(sc)) + goto TOP_NO_POP; + goto FEED_TO; + case OP_CASE_S_G_G: + sc->value = lookup_checked(sc, cadr(sc->code)); + if (op_case_g_g(sc)) + goto TOP_NO_POP; + goto FEED_TO; + + case OP_CASE_P_G_G: + push_stack_no_args_direct(sc, OP_CASE_G_G); + sc->code = cadr(sc->code); + goto EVAL; + case OP_CASE_P_E_S: + push_stack_no_args_direct(sc, OP_CASE_E_S); + sc->code = cadr(sc->code); + goto EVAL; + case OP_CASE_P_S_S: + push_stack_no_args_direct(sc, OP_CASE_S_S); + sc->code = cadr(sc->code); + goto EVAL; + case OP_CASE_P_G_S: + push_stack_no_args_direct(sc, OP_CASE_G_S); + sc->code = cadr(sc->code); + goto EVAL; + case OP_CASE_P_E_G: + push_stack_no_args_direct(sc, OP_CASE_E_G); + sc->code = cadr(sc->code); + goto EVAL; + case OP_CASE_P_S_G: + push_stack_no_args_direct(sc, OP_CASE_S_G); + sc->code = cadr(sc->code); + goto EVAL; + + case OP_CASE_A_E_S: + sc->value = fx_call(sc, cdr(sc->code)); + op_case_e_s(sc); + goto EVAL; + case OP_CASE_S_E_S: + sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */ + case OP_CASE_E_S: + op_case_e_s(sc); + goto EVAL; + + case OP_CASE_A_S_S: + sc->value = fx_call(sc, cdr(sc->code)); + op_case_s_s(sc); + goto EVAL; + case OP_CASE_S_S_S: + sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */ + case OP_CASE_S_S: + op_case_s_s(sc); + goto EVAL; +#if (!WITH_GMP) + case OP_CASE_P_I_S: + push_stack_no_args_direct(sc, OP_CASE_I_S); + sc->code = cadr(sc->code); + goto EVAL; + case OP_CASE_A_I_S: + sc->value = fx_call(sc, cdr(sc->code)); + if (op_case_i_s(sc)) + continue; + goto EVAL; + case OP_CASE_S_I_S: + sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */ + case OP_CASE_I_S: + if (op_case_i_s(sc)) + continue; + goto EVAL; +#endif + case OP_CASE_S_G_S: + sc->value = lookup_checked(sc, cadr(sc->code)); + op_case_g_s(sc); + goto EVAL; + case OP_CASE_A_G_S: + sc->value = fx_call(sc, cdr(sc->code)); /* fall through */ + case OP_CASE_G_S: + op_case_g_s(sc); + goto EVAL; + + case OP_CASE_A_E_G: + sc->value = fx_call(sc, cdr(sc->code)); + if (op_case_e_g_1(sc, sc->value, is_simple(sc->value))) + goto TOP_NO_POP; + goto FEED_TO; + case OP_CASE_S_E_G: + sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */ + case OP_CASE_E_G: + if (op_case_e_g_1(sc, sc->value, is_simple(sc->value))) + goto TOP_NO_POP; + goto FEED_TO; + + case OP_CASE_A_S_G: + sc->value = fx_call(sc, cdr(sc->code)); + if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value))) + goto TOP_NO_POP; + goto FEED_TO; + case OP_CASE_S_S_G: + sc->value = lookup_checked(sc, cadr(sc->code)); /* fall through */ + case OP_CASE_S_G: + if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value))) + goto TOP_NO_POP; + goto FEED_TO; + + + case OP_ERROR_QUIT: + if (sc->stack_end <= sc->stack_start) + stack_reset(sc); /* sets stack_end to stack_start, then pushes op_barrier and op_eval_done */ + return (sc->F); + + case OP_ERROR_HOOK_QUIT: + op_error_hook_quit(sc); + + case OP_FLUSH_VALUES: + if (is_multiple_value(sc->value)) + sc->value = sc->nil; /* cancel int/float_optimize */ + case OP_EVAL_DONE: + return (sc->F); + + case OP_SPLICE_VALUES: /* if splice_in_values hits eval_done, it needs to continue the splice after returning, so we get here */ + splice_in_values(sc, sc->args); + continue; + + case OP_GC_PROTECT: + case OP_BARRIER: + case OP_NO_VALUES: + case OP_CATCH_ALL: + case OP_CATCH: + case OP_CATCH_1: + case OP_CATCH_2: + continue; + + case OP_GET_OUTPUT_STRING: /* from call-with-output-string and with-output-to-string -- return the port string directly */ + op_get_output_string(sc); + /* fall through */ + + case OP_UNWIND_OUTPUT: + op_unwind_output(sc); + continue; + case OP_UNWIND_INPUT: + op_unwind_input(sc); + continue; + case OP_DYNAMIC_UNWIND: + dynamic_unwind(sc, sc->code, sc->args); + continue; + case OP_DYNAMIC_UNWIND_PROFILE: + g_profile_out(sc, set_plist_1(sc, sc->args)); + continue; + case OP_PROFILE_IN: + g_profile_in(sc, set_plist_1(sc, sc->curlet)); + continue; + case OP_DYNAMIC_WIND: + if (op_dynamic_wind(sc) == goto_apply) + goto APPLY; + continue; + case OP_DEACTIVATE_GOTO: + call_exit_active(sc->args) = false; + continue; /* deactivate the exiter */ + + + case OP_WITH_LET_S: + if (op_with_let_s(sc)) + goto BEGIN; + continue; + case OP_WITH_LET: + check_with_let(sc); + case OP_WITH_LET_UNCHECKED: + if (op_with_let_unchecked(sc)) + goto EVAL; + case OP_WITH_LET1: + if (sc->value != sc->curlet) + activate_with_let(sc, sc->value); + goto BEGIN; + case OP_WITH_UNLET_S: + sc->value = with_unlet_s(sc); + continue; + + case OP_WITH_BAFFLE: + check_with_baffle(sc); + case OP_WITH_BAFFLE_UNCHECKED: + if (op_with_baffle_unchecked(sc)) + continue; + goto BEGIN; + + + case OP_READ_INTERNAL: + op_read_internal(sc); + continue; + case OP_READ_DONE: + op_read_done(sc); + continue; + case OP_LOAD_RETURN_IF_EOF: + if (op_load_return_if_eof(sc)) + goto EVAL; + return (sc->F); + case OP_LOAD_CLOSE_AND_POP_IF_EOF: + if (op_load_close_and_pop_if_eof(sc)) + goto EVAL; + continue; + + POP_READ_LIST: + if (pop_read_list(sc)) + goto READ_NEXT; + + READ_LIST: + case OP_READ_LIST: /* sc->args is sc->nil at first */ + sc->args = cons(sc, sc->value, sc->args); + + READ_NEXT: + case OP_READ_NEXT: /* this is 75% of the token calls, so expanding it saves lots of time */ + { + int32_t c; + s7_pointer pt = current_input_port(sc); + c = port_read_white_space(pt) (sc, pt); + + READ_C: + switch (c) { + case '(': + c = port_read_white_space(pt) (sc, pt); /* sc->tok = token(sc) */ + switch (c) { + case '(': + sc->tok = TOKEN_LEFT_PAREN; + break; + case ')': + sc->value = sc->nil; + goto READ_LIST; /* was tok = TOKEN_RIGHT_PAREN */ + case '.': + sc->tok = read_dot(sc, pt); + break; + case '\'': + sc->tok = TOKEN_QUOTE; + break; + case ';': + sc->tok = port_read_semicolon(pt) (sc, pt); + break; + case '"': + sc->tok = TOKEN_DOUBLE_QUOTE; + break; + case '`': + sc->tok = TOKEN_BACK_QUOTE; + break; + case ',': + sc->tok = read_comma(sc, pt); + break; + case '#': + sc->tok = read_sharp(sc, pt); + break; + case '\0': + case EOF: + sc->tok = TOKEN_EOF; + break; + + default: /* read first element of list (ignore callgrind confusion -- this happens a lot) */ + { + sc->strbuf[0] = (unsigned char) c; + push_stack_no_let_no_code(sc, OP_READ_LIST, + sc->args); + check_stack_size(sc); /* s7test */ + sc->value = port_read_name(pt) (sc, pt); + sc->args = list_1(sc, sc->value); + pair_set_current_input_location(sc, sc->args); + c = port_read_white_space(pt) (sc, pt); + goto READ_C; + } + } + + if (sc->tok == TOKEN_ATOM) { + c = read_atom(sc, pt); + goto READ_C; + } + if (sc->tok == TOKEN_RIGHT_PAREN) { + sc->value = sc->nil; + goto READ_LIST; + } + if (sc->tok == TOKEN_DOT) { + do { + c = inchar(pt); + } while ((c != ')') && (c != EOF)); + read_error(sc, "stray dot after '('?"); /* (car '( . )) */ + } + if (sc->tok == TOKEN_EOF) + return (missing_close_paren_error(sc)); + + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil); + /* check_stack_size(sc); */ + sc->value = read_expression(sc); + if (main_stack_op(sc) == OP_READ_LIST) + goto POP_READ_LIST; + continue; + + case ')': + sc->tok = TOKEN_RIGHT_PAREN; + break; + + case '.': + sc->tok = read_dot(sc, pt); /* dot or atom */ + break; + + case '\'': + sc->tok = TOKEN_QUOTE; + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + sc->value = read_expression(sc); + continue; + + case ';': + sc->tok = port_read_semicolon(pt) (sc, pt); + break; + + case '"': + sc->tok = TOKEN_DOUBLE_QUOTE; + read_double_quote(sc); + goto READ_LIST; + + case '`': + sc->tok = TOKEN_BACK_QUOTE; + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + sc->value = read_expression(sc); + if (main_stack_op(sc) == OP_READ_LIST) + goto POP_READ_LIST; + continue; + + case ',': + sc->tok = read_comma(sc, pt); /* at_mark or comma */ + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + sc->value = read_expression(sc); + continue; + + case '#': + sc->tok = read_sharp(sc, pt); + break; + + case '\0': + case EOF: + return (missing_close_paren_error(sc)); + + default: + sc->strbuf[0] = (unsigned char) c; + sc->value = port_read_name(pt) (sc, pt); + goto READ_LIST; + } + } + + READ_TOK: + switch (sc->tok) { + case TOKEN_RIGHT_PAREN: /* sc->args can't be null here */ + sc->value = proper_list_reverse_in_place(sc, sc->args); + if ((is_expansion(car(sc->value))) && (sc->is_expanding)) + switch (op_expansion(sc)) { + case goto_begin: + goto BEGIN; + case goto_apply_lambda: + goto APPLY_LAMBDA; + default: + break; + } + break; + + case TOKEN_EOF: + return (missing_close_paren_error(sc)); /* can't happen, I believe */ + case TOKEN_ATOM: + sc->value = + port_read_name(current_input_port(sc)) (sc, + current_input_port + (sc)); + goto READ_LIST; + case TOKEN_SHARP_CONST: + if (read_sharp_const(sc)) + goto READ_TOK; + goto READ_LIST; + case TOKEN_DOUBLE_QUOTE: + read_double_quote(sc); + goto READ_LIST; + case TOKEN_DOT: + read_dot_and_expression(sc); + break; + default: + read_tok_default(sc); + break; + } + if (main_stack_op(sc) == OP_READ_LIST) + goto POP_READ_LIST; + continue; + + case OP_READ_DOT: + switch (op_read_dot(sc)) { + case goto_start: + continue; + case goto_pop_read_list: + goto POP_READ_LIST; + default: + goto READ_TOK; + } + case OP_READ_QUOTE: + if (op_read_quote(sc)) + continue; + goto POP_READ_LIST; + case OP_READ_QUASIQUOTE: + if (op_read_quasiquote(sc)) + continue; + goto POP_READ_LIST; + case OP_READ_UNQUOTE: + if (op_read_unquote(sc)) + continue; + goto POP_READ_LIST; + case OP_READ_APPLY_VALUES: + if (op_read_apply_values(sc)) + continue; + goto POP_READ_LIST; + case OP_READ_VECTOR: + if (op_read_vector(sc)) + continue; + goto POP_READ_LIST; + case OP_READ_INT_VECTOR: + if (op_read_int_vector(sc)) + continue; + goto POP_READ_LIST; + case OP_READ_FLOAT_VECTOR: + if (op_read_float_vector(sc)) + continue; + goto POP_READ_LIST; + case OP_READ_BYTE_VECTOR: + if (op_read_byte_vector(sc)) + continue; + goto POP_READ_LIST; + + case OP_CLEAR_OPTS: + break; + + default: + fprintf(stderr, "unknown operator: %" p64 " in %s\n", + sc->cur_op, display(current_code(sc))); + return (sc->F); + } + + if (!tree_is_cyclic(sc, sc->code)) + clear_all_optimizations(sc, sc->code); + + UNOPT: + switch (trailers(sc)) { + case goto_top_no_pop: + goto TOP_NO_POP; + case goto_eval_args_top: + goto EVAL_ARGS_TOP; + case goto_eval: + goto EVAL; + default: + break; + } + } + return (sc->F); +} + + +/* -------------------------------- *s7* let -------------------------------- */ +/* maybe features field in *s7*, others are *libraries*, *load-path*, *cload-directory*, *autoload*, *#readers* #-readers? */ + +typedef enum { SL_NO_FIELD = + 0, SL_STACK_TOP, SL_STACK_SIZE, SL_STACKTRACE_DEFAULTS, + SL_HEAP_SIZE, SL_FREE_HEAP_SIZE, + SL_GC_FREED, SL_GC_PROTECTED_OBJECTS, SL_GC_TOTAL_FREED, SL_GC_INFO, + SL_FILE_NAMES, SL_ROOTLET_SIZE, SL_C_TYPES, SL_SAFETY, + SL_UNDEFINED_IDENTIFIER_WARNINGS, SL_UNDEFINED_CONSTANT_WARNINGS, + SL_GC_STATS, SL_MAX_HEAP_SIZE, + SL_MAX_PORT_DATA_SIZE, SL_MAX_STACK_SIZE, SL_CPU_TIME, SL_CATCHES, + SL_STACK, SL_MAX_STRING_LENGTH, + SL_MAX_FORMAT_LENGTH, SL_MAX_LIST_LENGTH, SL_MAX_VECTOR_LENGTH, + SL_MAX_VECTOR_DIMENSIONS, + SL_DEFAULT_HASH_TABLE_LENGTH, SL_INITIAL_STRING_PORT_LENGTH, + SL_DEFAULT_RATIONALIZE_ERROR, + SL_DEFAULT_RANDOM_STATE, SL_EQUIVALENT_FLOAT_EPSILON, + SL_HASH_TABLE_FLOAT_EPSILON, SL_PRINT_LENGTH, + SL_BIGNUM_PRECISION, SL_MEMORY_USAGE, SL_FLOAT_FORMAT_PRECISION, + SL_HISTORY, SL_HISTORY_ENABLED, + SL_HISTORY_SIZE, SL_PROFILE, SL_PROFILE_INFO, SL_AUTOLOADING, + SL_ACCEPT_ALL_KEYWORD_ARGUMENTS, SL_MUFFLE_WARNINGS, + SL_MOST_POSITIVE_FIXNUM, SL_MOST_NEGATIVE_FIXNUM, + SL_OUTPUT_PORT_DATA_SIZE, SL_DEBUG, SL_VERSION, + SL_GC_TEMPS_SIZE, SL_GC_RESIZE_HEAP_FRACTION, + SL_GC_RESIZE_HEAP_BY_4_FRACTION, SL_OPENLETS, SL_EXPANSIONS, + SL_NUM_FIELDS +} s7_let_field_t; + +static const char *s7_let_field_names[SL_NUM_FIELDS] = + { "no-field", "stack-top", "stack-size", "stacktrace-defaults", + "heap-size", "free-heap-size", + "gc-freed", "gc-protected-objects", "gc-total-freed", "gc-info", + "file-names", "rootlet-size", "c-types", "safety", + "undefined-identifier-warnings", "undefined-constant-warnings", + "gc-stats", "max-heap-size", + "max-port-data-size", "max-stack-size", "cpu-time", "catches", "stack", + "max-string-length", + "max-format-length", "max-list-length", "max-vector-length", + "max-vector-dimensions", + "default-hash-table-length", "initial-string-port-length", + "default-rationalize-error", + "default-random-state", "equivalent-float-epsilon", + "hash-table-float-epsilon", "print-length", + "bignum-precision", "memory-usage", "float-format-precision", + "history", "history-enabled", + "history-size", "profile", "profile-info", "autoloading?", + "accept-all-keyword-arguments", "muffle-warnings?", + "most-positive-fixnum", "most-negative-fixnum", + "output-port-data-size", "debug", "version", + "gc-temps-size", "gc-resize-heap-fraction", + "gc-resize-heap-by-4-fraction", "openlets", "expansions?" +}; + +static s7_int s7_let_length(void) +{ + return (SL_NUM_FIELDS - 1); +} + +static s7_pointer s7_let_add_field(s7_scheme * sc, const char *name, + s7_let_field_t field) +{ + s7_pointer sym; + sym = make_symbol(sc, name); + symbol_set_s7_let(sym, field); + return (sym); +} + +static void init_s7_let(s7_scheme * sc) +{ + int32_t i; + for (i = SL_STACK_TOP; i < SL_NUM_FIELDS; i++) + s7_let_add_field(sc, s7_let_field_names[i], (s7_let_field_t) i); +} + +/* handling all *s7* fields via fallbacks lets us use direct field accesses in the rest of s7, and avoids + * using ca 100 cells for the let slots/values. We would need the fallbacks anyway for 'files et al. + * Since most of the fields need special setters, it's actually less code this way. See old/s7-let-s7.c. + */ + +#if (!_WIN32) /* (!MS_WINDOWS) */ +#include +#endif + +static s7_pointer kmg(s7_scheme * sc, s7_int bytes) +{ + block_t *b; + int len = 0; + b = mallocate(sc, 128); + if (bytes < 1000) + len = snprintf((char *) block_data(b), 128, "%" ld64, bytes); + else if (bytes < 1000000) + len = + snprintf((char *) block_data(b), 128, "%.1fk", bytes / 1000.0); + else if (bytes < 1000000000) + len = + snprintf((char *) block_data(b), 128, "%.1fM", + bytes / 1000000.0); + else + len = + snprintf((char *) block_data(b), 128, "%.1fG", + bytes / 1000000000.0); + return (cons + (sc, make_integer(sc, bytes), block_to_string(sc, b, len))); +} + +static s7_pointer memory_usage(s7_scheme * sc) +{ + s7_int gc_loc, i, k, len, in_use = 0, vlen = 0, flen = 0, ilen = + 0, blen = 0, hlen = 0; + s7_pointer mu_let; + gc_list_t *gp; + s7_int ts[NUM_TYPES]; + +#if (!_WIN32) /* (!MS_WINDOWS) */ + struct rusage info; + struct timeval ut; +#endif + + mu_let = s7_inlet(sc, sc->nil); + gc_loc = gc_protect_1(sc, mu_let); + +#if (!_WIN32) /* (!MS_WINDOWS) */ + getrusage(RUSAGE_SELF, &info); + ut = info.ru_utime; + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-time"), + make_real(sc, + ut.tv_sec + + (floor(ut.tv_usec / 1000.0) / + 1000.0))); +#ifdef __APPLE__ + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "process-resident-size"), + kmg(sc, info.ru_maxrss)); + /* apple docs say this is in kilobytes, but apparently that is an error */ +#else + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "process-resident-size"), + kmg(sc, info.ru_maxrss * 1024)); + /* why does this number sometimes have no relation to RES in top? */ +#endif + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "IO"), + cons(sc, make_integer(sc, info.ru_inblock), + make_integer(sc, info.ru_oublock))); +#endif + + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "rootlet-size"), + make_integer(sc, sc->rootlet_entries)); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "heap-size"), + cons(sc, make_integer(sc, sc->heap_size), + kmg(sc, + sc->heap_size * (sizeof(s7_cell) + + 2 * + sizeof + (s7_pointer))))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "cell-size"), + make_integer(sc, sizeof(s7_cell))); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "gc-total-freed"), + make_integer(sc, sc->gc_total_freed)); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "gc-total-time"), + make_real(sc, + (double) (sc->gc_total_time) / + ticks_per_second())); + + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "small_ints"), + cons(sc, make_integer(sc, NUM_SMALL_INTS), + kmg(sc, + NUM_SMALL_INTS * + sizeof(s7_cell)))); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "permanent-cells"), cons(sc, + make_integer + (sc, + sc->permanent_cells), + kmg + (sc, + sc->permanent_cells + * + sizeof + (s7_cell)))); + { + gc_obj_t *g; + for (i = 0, g = sc->permanent_objects; g; + i++, g = (gc_obj_t *) (g->nxt)); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "permanent_objects"), + make_integer(sc, i)); + for (i = 0, g = sc->permanent_lets; g; + i++, g = (gc_obj_t *) (g->nxt)); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "permanent_lets"), + make_integer(sc, i)); + } + + /* show how many active cells there are of each type (this is where all the memory_usage cpu time goes) */ + for (i = 0; i < NUM_TYPES; i++) + ts[i] = 0; + for (k = 0; k < sc->heap_size; k++) + ts[unchecked_type(sc->heap[k])]++; + sc->w = sc->nil; + for (i = 0; i < NUM_TYPES; i++) { + if (i > 0) + in_use += ts[i]; + if (ts[i] > 50) + sc->w = + cons_unchecked(sc, + cons(sc, + make_symbol(sc, + (i == + 0) ? "free" : + type_name_from_type(i, + NO_ARTICLE)), + make_integer(sc, ts[i])), sc->w); + } + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "cells-in-use/free"), + cons(sc, make_integer(sc, in_use), + make_integer(sc, + sc->free_heap_top - + sc->free_heap))); + if (is_pair(sc->w)) + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "types"), + proper_list_reverse_in_place(sc, + sc->w)); + sc->w = sc->nil; + /* same for permanent cells requires traversing saved_pointers and the alloc and big_alloc blocks up to alloc_k, or keeping explicit counts */ + + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "gc-protected-objects"), + cons(sc, + make_integer(sc, + sc->protected_objects_size + - sc->gpofl_loc), + make_integer(sc, + sc->protected_objects_size))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "setters"), + make_integer(sc, + sc->protected_setters_loc)); + + /* check the symbol table, counting gensyms etc */ + { + s7_int syms = 0, gens = 0, keys = 0, mx_list = 0; + s7_pointer *els; + for (i = 0, els = vector_elements(sc->symbol_table); + i < SYMBOL_TABLE_SIZE; i++) { + s7_pointer x; + for (k = 0, x = els[i]; is_not_null(x); x = cdr(x), k++) { + syms++; + if (is_gensym(car(x))) + gens++; + if (is_keyword(car(x))) + keys++; + } + if (k > mx_list) + mx_list = k; + } + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "symbol-table"), + s7_list(sc, 9, + make_integer(sc, + SYMBOL_TABLE_SIZE), + make_symbol(sc, "max-bin"), + make_integer(sc, mx_list), + make_symbol(sc, "symbols"), + cons(sc, make_integer(sc, syms), + make_integer(sc, + syms - gens - + keys)), + make_symbol(sc, "gensyms"), + make_integer(sc, gens), + make_symbol(sc, "keys"), + make_integer(sc, keys))); + } + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "stack"), + cons(sc, + make_integer(sc, + current_stack_top(sc)), + make_integer(sc, sc->stack_size))); + + len = + sc->autoload_names_top * (sizeof(const char **) + sizeof(s7_int) + + sizeof(bool)); + for (i = 0; i < sc->autoload_names_loc; i++) + len += sc->autoload_names_sizes[i]; + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "autoload"), + make_integer(sc, len)); + + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "circle_info"), + make_integer(sc, + sc->circle_info->size * + (sizeof(s7_pointer) + + sizeof(int32_t) + + sizeof(bool)))); + + /* check the gc lists (finalizations) */ + len = + sc->strings->size + sc->vectors->size + sc->input_ports->size + + sc->output_ports->size + sc->input_string_ports->size + + sc->continuations->size + sc->c_objects->size + + sc->hash_tables->size + sc->gensyms->size + sc->undefineds->size + + sc->lambdas->size + sc->multivectors->size + sc->weak_refs->size + + sc->weak_hash_iterators->size + sc->opt1_funcs->size; + { + int loc; + loc = + sc->strings->loc + sc->vectors->loc + sc->input_ports->loc + + sc->output_ports->loc + sc->input_string_ports->loc + + sc->continuations->loc + sc->c_objects->loc + + sc->hash_tables->loc + sc->gensyms->loc + sc->undefineds->loc + + sc->lambdas->loc + sc->multivectors->loc + sc->weak_refs->loc + + sc->weak_hash_iterators->loc + sc->opt1_funcs->loc; + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-lists"), + cons_unchecked(sc, + make_integer(sc, loc), + cons(sc, + make_integer(sc, + len), + make_integer(sc, + len * + sizeof + (s7_pointer))))); + } + /* strings */ + gp = sc->strings; + for (len = 0, i = 0; i < (int32_t) (gp->loc); i++) + len += string_length(gp->list[i]); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "strings"), + cons(sc, make_integer(sc, gp->loc), + make_integer(sc, len))); + + /* vectors */ + for (k = 0, gp = sc->vectors; k < 2; k++, gp = sc->multivectors) + for (i = 0; i < gp->loc; i++) { + s7_pointer v = gp->list[i]; + if (is_float_vector(v)) + flen += vector_length(v); + else if (is_int_vector(v)) + ilen += vector_length(v); + else if (is_byte_vector(v)) + blen += vector_length(v); + else + vlen += vector_length(v); + } + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "vectors"), + s7_list(sc, 9, + make_integer(sc, + sc->vectors->loc + + sc->multivectors->loc), + make_symbol(sc, "vlen"), + make_integer(sc, vlen), + make_symbol(sc, "fvlen"), + make_integer(sc, flen), + make_symbol(sc, "ivlen"), + make_integer(sc, ilen), + make_symbol(sc, "bvlen"), + make_integer(sc, blen))); + /* hash-tables */ + for (i = 0, gp = sc->hash_tables; i < gp->loc; i++) { + s7_pointer v = gp->list[i]; + hlen += ((hash_table_mask(v) + 1) * sizeof(hash_entry_t *)); + hlen += (hash_table_entries(v) * sizeof(hash_entry_t)); + } + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "hash-tables"), + cons(sc, + make_integer(sc, sc->hash_tables->loc), + make_integer(sc, hlen))); + + /* ports */ + gp = sc->input_ports; + for (i = 0, len = 0; i < gp->loc; i++) { + s7_pointer v = gp->list[i]; + if (port_data(v)) + len += port_data_size(v); + } + gp = sc->input_string_ports; + for (i = 0, len = 0; i < gp->loc; i++) { + s7_pointer v = gp->list[i]; + if (port_data(v)) + len += port_data_size(v); + } + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "input-ports"), + cons(sc, + make_integer(sc, + sc->input_ports->loc + + sc-> + input_string_ports->loc), + make_integer(sc, len))); + gp = sc->output_ports; + for (i = 0, len = 0; i < gp->loc; i++) { + s7_pointer v = gp->list[i]; + if (port_data(v)) + len += port_data_size(v); + } + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "output-ports"), + cons(sc, + make_integer(sc, + sc->output_ports->loc), + make_integer(sc, len))); + { + s7_pointer p; + for (i = 0, p = sc->format_ports; p; + p = (s7_pointer) port_next(p)); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "format-ports"), + make_integer(sc, i)); + } + + /* continuations (sketchy!) */ + gp = sc->continuations; + for (i = 0, len = 0; i < gp->loc; i++) + if (is_continuation(gp->list[i])) + len += continuation_stack_size(gp->list[i]); + if (len > 0) + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "continuations"), + cons(sc, + make_integer(sc, + sc-> + continuations->loc), + make_integer(sc, + len * + sizeof(s7_pointer)))); + /* c-objects */ + if (sc->c_objects->loc > 0) + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "c-objects"), + make_integer(sc, sc->c_objects->loc)); +#if WITH_GMP + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "bignums"), + s7_list(sc, 5, + make_integer(sc, + sc->big_integers->loc), + make_integer(sc, + sc->big_ratios->loc), + make_integer(sc, + sc->big_reals->loc), + make_integer(sc, + sc-> + big_complexes->loc), + make_integer(sc, + sc->big_random_states->loc))); +#endif + /* free-lists (mallocate) */ + { + block_t *b; + for (i = 0, len = 0, sc->w = sc->nil; i < TOP_BLOCK_LIST; i++) { + for (b = sc->block_lists[i], k = 0; b; b = block_next(b), k++); + sc->w = cons(sc, make_integer(sc, k), sc->w); + len += ((sizeof(block_t) + (1LL << i)) * k); + } + for (b = sc->block_lists[TOP_BLOCK_LIST], k = 0; b; + b = block_next(b), k++) + len += (sizeof(block_t) + block_size(b)); + sc->w = cons(sc, make_integer(sc, k), sc->w); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "free-lists"), + list_2(sc, + cons(sc, + make_symbol(sc, "bytes"), + kmg(sc, len)), cons(sc, + make_symbol + (sc, + "bins"), + proper_list_reverse_in_place + (sc, + sc->w)))); + sc->w = sc->nil; + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "approximate-s7-size"), + kmg(sc, + ((sc->permanent_cells + + NUM_SMALL_INTS + + sc->heap_size) * + sizeof(s7_cell)) + + ((2 * sc->heap_size + + SYMBOL_TABLE_SIZE + + sc->stack_size) * + sizeof(s7_pointer)) + len + hlen + + (vlen * sizeof(s7_pointer)) + + (flen * sizeof(s7_double)) + + (ilen * sizeof(s7_int)) + blen)); + } + + s7_gc_unprotect_at(sc, gc_loc); + return (mu_let); +} + +static s7_pointer sl_c_types(s7_scheme * sc) +{ + s7_pointer res; + int32_t i; + sc->w = sc->nil; + for (i = 0; i < sc->num_c_object_types; i++) /* c-object type (tag) is i */ + sc->w = cons(sc, sc->c_object_types[i]->scheme_name, sc->w); + res = proper_list_reverse_in_place(sc, sc->w); /* so car(types) has tag 0 */ + sc->w = sc->nil; + return (res); +} + +static s7_pointer sl_file_names(s7_scheme * sc) +{ + int32_t i; + s7_pointer p; + sc->w = sc->nil; + for (i = 0; i <= sc->file_names_top; i++) + sc->w = cons(sc, sc->file_names[i], sc->w); + p = proper_list_reverse_in_place(sc, sc->w); + sc->w = sc->nil; + return (p); +} + +static s7_pointer sl_int_fixup(s7_scheme * sc, s7_pointer val) +{ +#if WITH_GMP + return (s7_int_to_big_integer(sc, s7_integer_checked(sc, val))); +#else + return (val); +#endif +} + +static s7_pointer sl_history(s7_scheme * sc) +{ +#if WITH_HISTORY + return (cull_history + (sc, + (sc->cur_code == + sc->history_sink) ? sc->old_cur_code : sc->cur_code)); +#else + return (sc->cur_code); +#endif +} + +static s7_pointer sl_active_catches(s7_scheme * sc) +{ + int64_t i; + s7_pointer x, lst = sc->nil; + for (i = current_stack_top(sc) - 1; i >= 3; i -= 4) + switch (stack_op(sc->stack, i)) { + case OP_CATCH_ALL: + lst = cons(sc, sc->T, lst); + break; + case OP_CATCH_2: + case OP_CATCH_1: + case OP_CATCH: + x = stack_code(sc->stack, i); + lst = cons(sc, catch_tag(x), lst); + break; + } + return (reverse_in_place_unchecked(sc, sc->nil, lst)); +} + +static s7_pointer sl_stack_entries(s7_scheme * sc, s7_pointer stack, + int64_t top) +{ + int64_t i; + s7_pointer lst = sc->nil; + for (i = top - 1; i >= 3; i -= 4) { + s7_pointer func, args, e; + opcode_t op; + func = stack_code(stack, i); + args = stack_args(stack, i); + e = stack_let(stack, i); + op = stack_op(stack, i); + if ((s7_is_valid(sc, func)) && + (s7_is_valid(sc, args)) && + (s7_is_valid(sc, e)) && (op < NUM_OPS)) { + lst = + cons_unchecked(sc, + list_4(sc, func, args, e, + s7_make_string(sc, op_names[op])), + lst); + sc->w = lst; + } + } + sc->w = sc->nil; + return (reverse_in_place_unchecked(sc, sc->nil, lst)); +} + +static s7_pointer s7_let_field(s7_scheme * sc, s7_pointer sym) +{ + switch (symbol_s7_let(sym)) { + case SL_ACCEPT_ALL_KEYWORD_ARGUMENTS: + return (make_boolean(sc, sc->accept_all_keyword_arguments)); + case SL_AUTOLOADING: + return (s7_make_boolean(sc, sc->is_autoloading)); + case SL_BIGNUM_PRECISION: + return (make_integer(sc, sc->bignum_precision)); + case SL_CATCHES: + return (sl_active_catches(sc)); + case SL_CPU_TIME: + return (s7_make_real + (sc, (double) clock() / (double) CLOCKS_PER_SEC)); + case SL_C_TYPES: + return (sl_c_types(sc)); + case SL_DEBUG: + return (make_integer(sc, sc->debug)); + case SL_DEFAULT_HASH_TABLE_LENGTH: + return (make_integer(sc, sc->default_hash_table_length)); + case SL_DEFAULT_RANDOM_STATE: + return (sc->default_rng); + case SL_DEFAULT_RATIONALIZE_ERROR: + return (make_real(sc, sc->default_rationalize_error)); + case SL_EQUIVALENT_FLOAT_EPSILON: + return (s7_make_real(sc, sc->equivalent_float_epsilon)); + case SL_FILE_NAMES: + return (sl_file_names(sc)); + case SL_FLOAT_FORMAT_PRECISION: + return (make_integer(sc, sc->float_format_precision)); + case SL_FREE_HEAP_SIZE: + return (make_integer(sc, sc->free_heap_top - sc->free_heap)); + case SL_GC_FREED: + return (make_integer(sc, sc->gc_freed)); + case SL_GC_TOTAL_FREED: + return (make_integer(sc, sc->gc_total_freed)); + case SL_GC_INFO: + return (list_3 + (sc, make_integer(sc, sc->gc_calls), + make_integer(sc, sc->gc_total_time), make_integer(sc, + ticks_per_second + ()))); + case SL_GC_PROTECTED_OBJECTS: + return (sc->protected_objects); + case SL_GC_STATS: + return (make_integer(sc, sc->gc_stats)); + case SL_GC_TEMPS_SIZE: + return (make_integer(sc, sc->gc_temps_size)); + case SL_GC_RESIZE_HEAP_FRACTION: + return (make_real(sc, sc->gc_resize_heap_fraction)); + case SL_GC_RESIZE_HEAP_BY_4_FRACTION: + return (make_real(sc, sc->gc_resize_heap_by_4_fraction)); + case SL_HASH_TABLE_FLOAT_EPSILON: + return (s7_make_real(sc, sc->hash_table_float_epsilon)); + case SL_HEAP_SIZE: + return (make_integer(sc, sc->heap_size)); + case SL_HISTORY: + return (sl_history(sc)); + case SL_HISTORY_ENABLED: + return (s7_make_boolean(sc, s7_history_enabled(sc))); + case SL_HISTORY_SIZE: + return (make_integer(sc, sc->history_size)); + case SL_INITIAL_STRING_PORT_LENGTH: + return (make_integer(sc, sc->initial_string_port_length)); + case SL_MAX_FORMAT_LENGTH: + return (make_integer(sc, sc->max_format_length)); + case SL_MAX_HEAP_SIZE: + return (make_integer(sc, sc->max_heap_size)); + case SL_MAX_LIST_LENGTH: + return (make_integer(sc, sc->max_list_length)); + case SL_MAX_PORT_DATA_SIZE: + return (make_integer(sc, sc->max_port_data_size)); + case SL_MAX_STACK_SIZE: + return (make_integer(sc, sc->max_stack_size)); + case SL_MAX_STRING_LENGTH: + return (make_integer(sc, sc->max_string_length)); + case SL_MAX_VECTOR_DIMENSIONS: + return (make_integer(sc, sc->max_vector_dimensions)); + case SL_MAX_VECTOR_LENGTH: + return (make_integer(sc, sc->max_vector_length)); + case SL_MEMORY_USAGE: + return (memory_usage(sc)); + case SL_MOST_NEGATIVE_FIXNUM: + return (sl_int_fixup(sc, leastfix)); + case SL_MOST_POSITIVE_FIXNUM: + return (sl_int_fixup(sc, mostfix)); + case SL_MUFFLE_WARNINGS: + return (s7_make_boolean(sc, sc->muffle_warnings)); + case SL_OPENLETS: + return (s7_make_boolean(sc, sc->has_openlets)); + case SL_EXPANSIONS: + return (s7_make_boolean(sc, sc->is_expanding)); + case SL_OUTPUT_PORT_DATA_SIZE: + return (make_integer(sc, sc->output_port_data_size)); + case SL_PRINT_LENGTH: + return (make_integer(sc, sc->print_length)); + case SL_PROFILE: + return (make_integer(sc, sc->profile)); + case SL_PROFILE_INFO: + return (profile_info_out(sc)); + case SL_ROOTLET_SIZE: + return (make_integer(sc, sc->rootlet_entries)); + case SL_SAFETY: + return (make_integer(sc, sc->safety)); + case SL_STACK: + return (sl_stack_entries(sc, sc->stack, current_stack_top(sc))); + case SL_STACKTRACE_DEFAULTS: + return (sc->stacktrace_defaults); + case SL_STACK_SIZE: + return (make_integer(sc, sc->stack_size)); + case SL_STACK_TOP: + return (make_integer(sc, (sc->stack_end - sc->stack_start) / 4)); + case SL_UNDEFINED_CONSTANT_WARNINGS: + return (s7_make_boolean(sc, sc->undefined_constant_warnings)); + case SL_UNDEFINED_IDENTIFIER_WARNINGS: + return (s7_make_boolean(sc, sc->undefined_identifier_warnings)); + case SL_VERSION: + return (s7_make_string(sc, "s7 " S7_VERSION ", " S7_DATE)); + default: + return (s7_error + (sc, sc->out_of_range_symbol, + set_elist_2(sc, + wrap_string(sc, + "can't get (*s7* '~S); no such field in *s7*", + 43), sym))); + } + return (sc->undefined); +} + +s7_pointer s7_let_field_ref(s7_scheme * sc, s7_pointer sym) +{ + if (is_symbol(sym)) { + if (is_keyword(sym)) + sym = keyword_symbol(sym); + if (symbol_s7_let(sym) != SL_NO_FIELD) + return (s7_let_field(sc, sym)); + } + return (sc->undefined); +} + +static s7_pointer g_s7_let_ref_fallback(s7_scheme * sc, s7_pointer args) +{ + s7_pointer sym = cadr(args); + if (!is_symbol(sym)) + return (simple_wrong_type_argument + (sc, sc->let_ref_symbol, sym, T_SYMBOL)); + if (is_keyword(sym)) + sym = keyword_symbol(sym); + return (s7_let_field(sc, sym)); +} + +static s7_pointer s7_let_iterate(s7_scheme * sc, s7_pointer iterator) +{ + s7_pointer symbol, value, osw; + iterator_position(iterator)++; + if (iterator_position(iterator) >= SL_NUM_FIELDS) + return (iterator_quit(iterator)); + symbol = + make_symbol(sc, s7_let_field_names[iterator_position(iterator)]); + osw = sc->w; /* protect against s7_let_field list making (why?) */ + + if ((iterator_position(iterator) == SL_STACK) || + (iterator_position(iterator) == SL_GC_PROTECTED_OBJECTS) || + (iterator_position(iterator) == SL_MEMORY_USAGE)) + value = sc->F; /* (format #f "~W" (inlet *s7*)) or (let->list *s7*) etc */ + else + value = s7_let_field(sc, symbol); + + sc->w = osw; + if (iterator_let_cons(iterator)) { + s7_pointer p; + p = iterator_let_cons(iterator); + set_car(p, symbol); + set_cdr(p, value); + return (p); + } + return (cons(sc, symbol, value)); +} + +static s7_pointer s7_let_make_iterator(s7_scheme * sc, s7_pointer iter) +{ + iterator_position(iter) = SL_NO_FIELD; + iterator_next(iter) = s7_let_iterate; + iterator_let_cons(iter) = NULL; + return (iter); +} + +static s7_pointer sl_real_geq_0(s7_scheme * sc, s7_pointer sym, + s7_pointer val) +{ + if (!is_real(val)) + return (simple_wrong_type_argument(sc, sym, val, T_REAL)); + return ((s7_real(val) >= 0.0) ? val : simple_out_of_range(sc, sym, val, + wrap_string + (sc, + "should not be negative", + 22))); +} + +static s7_pointer sl_integer_gt_0(s7_scheme * sc, s7_pointer sym, + s7_pointer val) +{ + if (!s7_is_integer(val)) + return (simple_wrong_type_argument(sc, sym, val, T_INTEGER)); + return ((s7_integer_checked(sc, val) > + 0) ? val : simple_out_of_range(sc, sym, val, wrap_string(sc, + "should be positive", + 18))); +} + +static s7_pointer sl_integer_geq_0(s7_scheme * sc, s7_pointer sym, + s7_pointer val) +{ + if (!s7_is_integer(val)) + return (simple_wrong_type_argument(sc, sym, val, T_INTEGER)); + return ((s7_integer_checked(sc, val) >= + 0) ? val : simple_out_of_range(sc, sym, val, wrap_string(sc, + "should not be negative", + 22))); +} + +#if WITH_HISTORY +static void sl_set_history_size(s7_scheme * sc, s7_int iv) +{ + s7_pointer p1, p2, p3; + if (iv > MAX_HISTORY_SIZE) + iv = MAX_HISTORY_SIZE; + if (iv > sc->true_history_size) { + /* splice in the new cells, reattach the circles */ + s7_pointer next1, next2, next3; + next1 = cdr(sc->eval_history1); + next2 = cdr(sc->eval_history2); + next3 = cdr(sc->history_pairs); + set_cdr(sc->eval_history1, + permanent_list(sc, iv - sc->true_history_size)); + set_cdr(sc->eval_history2, + permanent_list(sc, iv - sc->true_history_size)); + set_cdr(sc->history_pairs, + permanent_list(sc, iv - sc->true_history_size)); + for (p3 = cdr(sc->history_pairs); is_pair(cdr(p3)); p3 = cdr(p3)) + set_car(p3, permanent_list(sc, 1)); + set_car(p3, permanent_list(sc, 1)); + set_cdr(p3, next3); + for (p1 = sc->eval_history1, p2 = sc->eval_history2; + is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2)); + set_cdr(p1, next1); + set_cdr(p2, next2); + sc->true_history_size = iv; + } + sc->history_size = iv; + /* clear out both buffers to avoid GC confusion */ + for (p1 = sc->eval_history1, p2 = sc->eval_history2;; p2 = cdr(p2)) { + set_car(p1, sc->nil); + set_car(p2, sc->nil); + p1 = cdr(p1); + if (p1 == sc->eval_history1) + break; + } +} +#endif + +#if WITH_GMP +static s7_pointer set_bignum_precision(s7_scheme * sc, int32_t precision) +{ + mp_prec_t bits; + s7_pointer bpi; + if (precision <= 1) /* (set! (*s7* 'bignum-precision) 1) causes mpfr to segfault! (also 0 and -1) */ + return (s7_out_of_range_error + (sc, "set! (*s7* 'bignum-precision)", 0, + wrap_integer2(sc, precision), + "has to be greater than 1")); + bits = (mp_prec_t) precision; + mpfr_set_default_prec(bits); + mpc_set_default_precision(bits); + bpi = big_pi(sc); + s7_symbol_set_value(sc, sc->pi_symbol, bpi); + slot_set_value(initial_slot(sc->pi_symbol), bpi); /* if #_pi occurs after precision set, make sure #_pi is still legit (not a free cell) */ + return (sc->F); +} +#endif + +static s7_pointer sl_unsettable_error(s7_scheme * sc, s7_pointer sym) +{ + return (s7_error + (sc, sc->immutable_error_symbol, + set_elist_2(sc, wrap_string(sc, "can't set (*s7* '~S)", 20), + sym))); +} + +static s7_pointer g_s7_let_set_fallback(s7_scheme * sc, s7_pointer args) +{ + s7_pointer sym = cadr(args), val = caddr(args); + s7_int iv; + + if (!is_symbol(sym)) + return (simple_wrong_type_argument + (sc, sc->let_set_symbol, sym, T_SYMBOL)); + if (is_keyword(sym)) + sym = keyword_symbol(sym); + + switch (symbol_s7_let(sym)) { + case SL_ACCEPT_ALL_KEYWORD_ARGUMENTS: + if (s7_is_boolean(val)) { + sc->accept_all_keyword_arguments = s7_boolean(sc, val); + return (val); + } + return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN)); + + case SL_AUTOLOADING: + if (s7_is_boolean(val)) { + sc->is_autoloading = s7_boolean(sc, val); + return (val); + } + return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN)); + + case SL_BIGNUM_PRECISION: + iv = s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val)); + sc->bignum_precision = iv; +#if WITH_GMP + set_bignum_precision(sc, sc->bignum_precision); + mpfr_set_prec(sc->mpfr_1, sc->bignum_precision); + mpfr_set_prec(sc->mpfr_2, sc->bignum_precision); + mpc_set_prec(sc->mpc_1, sc->bignum_precision); + mpc_set_prec(sc->mpc_2, sc->bignum_precision); +#endif + return (val); + + case SL_CATCHES: + case SL_CPU_TIME: + case SL_C_TYPES: + return (sl_unsettable_error(sc, sym)); + + case SL_DEBUG: + if (!s7_is_integer(val)) + return (simple_wrong_type_argument(sc, sym, val, T_INTEGER)); + sc->debug = s7_integer_checked(sc, val); + sc->debug_or_profile = ((sc->debug > 1) || (sc->profile > 0)); + if ((sc->debug > 0) && + (!is_memq + (make_symbol(sc, "debug.scm"), + s7_symbol_value(sc, sc->features_symbol)))) + s7_load(sc, "debug.scm"); + return (val); + + case SL_DEFAULT_HASH_TABLE_LENGTH: + sc->default_hash_table_length = + s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val)); + return (val); + + case SL_DEFAULT_RANDOM_STATE: + if (is_random_state(val)) { +#if (!WITH_GMP) + random_seed(sc->default_rng) = random_seed(val); + random_carry(sc->default_rng) = random_carry(val); +#endif + return (val); + } + return (wrong_type_argument_with_type + (sc, sym, 1, val, a_random_state_object_string)); + + case SL_DEFAULT_RATIONALIZE_ERROR: + sc->default_rationalize_error = + s7_real(sl_real_geq_0(sc, sym, val)); + return (val); + + case SL_EQUIVALENT_FLOAT_EPSILON: + sc->equivalent_float_epsilon = + s7_real(sl_real_geq_0(sc, sym, val)); + return (val); + + case SL_FILE_NAMES: + return (sl_unsettable_error(sc, sym)); + + case SL_FLOAT_FORMAT_PRECISION: /* float-format-precision should not be huge => hangs in snprintf -- what's a reasonable limit here? */ + iv = s7_integer_checked(sc, sl_integer_geq_0(sc, sym, val)); + sc->float_format_precision = + (iv < + MAX_FLOAT_FORMAT_PRECISION) ? iv : MAX_FLOAT_FORMAT_PRECISION; + return (val); + + case SL_FREE_HEAP_SIZE: + case SL_GC_FREED: + case SL_GC_TOTAL_FREED: + case SL_GC_PROTECTED_OBJECTS: + return (sl_unsettable_error(sc, sym)); + + case SL_GC_TEMPS_SIZE: + sc->gc_temps_size = + s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val)); + return (val); + case SL_GC_RESIZE_HEAP_FRACTION: + sc->gc_resize_heap_fraction = s7_real(sl_real_geq_0(sc, sym, val)); + return (val); + case SL_GC_RESIZE_HEAP_BY_4_FRACTION: + sc->gc_resize_heap_by_4_fraction = + s7_real(sl_real_geq_0(sc, sym, val)); + return (val); + + case SL_GC_STATS: + if (s7_is_boolean(val)) { + sc->gc_stats = ((val == sc->T) ? GC_STATS : 0); + return (val); + } + if (!s7_is_integer(val)) + return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN)); + sc->gc_stats = s7_integer_checked(sc, val); + if (sc->gc_stats < 16) /* gc_stats is uint32_t */ + return (val); + sc->gc_stats = 0; + return (simple_out_of_range + (sc, sym, val, + wrap_string(sc, "should be between 0 and 15", 26))); + + case SL_GC_INFO: + if (val != sc->F) + return (simple_wrong_type_argument_with_type + (sc, sym, val, + wrap_string(sc, + "#f (to clear gc_calls and gc_total_time)", + 40))); + sc->gc_total_time = 0; + sc->gc_calls = 0; + return (sc->F); + + case SL_HASH_TABLE_FLOAT_EPSILON: + sc->hash_table_float_epsilon = + s7_real(sl_real_geq_0(sc, sym, val)); + return (val); + + case SL_HEAP_SIZE: + iv = s7_integer_checked(sc, sl_integer_geq_0(sc, sym, val)); + if (iv > sc->heap_size) + resize_heap_to(sc, iv); + return (val); + + case SL_HISTORY: /* (set! (*s7* 'history) val) */ + replace_current_code(sc, val); + return (val); + + case SL_HISTORY_ENABLED: /* (set! (*s7* 'history-enabled) #f|#t) */ + if (s7_is_boolean(val)) + return (s7_make_boolean + (sc, s7_set_history_enabled(sc, s7_boolean(sc, val)))); + return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN)); + + case SL_HISTORY_SIZE: + iv = s7_integer_checked(sc, sl_integer_geq_0(sc, sym, val)); +#if WITH_HISTORY + sl_set_history_size(sc, iv); +#else + sc->history_size = iv; +#endif + return (val); + + case SL_INITIAL_STRING_PORT_LENGTH: + sc->initial_string_port_length = + s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val)); + return (val); + case SL_MAX_FORMAT_LENGTH: + sc->max_format_length = + s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val)); + return (val); + case SL_MAX_HEAP_SIZE: + sc->max_heap_size = + s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val)); + return (val); + case SL_MAX_LIST_LENGTH: + sc->max_list_length = + s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val)); + return (val); + case SL_MAX_PORT_DATA_SIZE: + sc->max_port_data_size = + s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val)); + return (val); + + case SL_MAX_STACK_SIZE: + iv = s7_integer_checked(sc, sl_integer_geq_0(sc, sym, val)); + if (iv < INITIAL_STACK_SIZE) + return (simple_out_of_range + (sc, sym, val, + wrap_string(sc, + "should be greater than the initial stack size", + 45))); + sc->max_stack_size = (uint32_t) iv; + return (val); + + case SL_MAX_STRING_LENGTH: + sc->max_string_length = + s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val)); + return (val); + case SL_MAX_VECTOR_DIMENSIONS: + sc->max_vector_dimensions = + s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val)); + return (val); + case SL_MAX_VECTOR_LENGTH: + sc->max_vector_length = + s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val)); + return (val); + + case SL_MEMORY_USAGE: + case SL_MOST_NEGATIVE_FIXNUM: + case SL_MOST_POSITIVE_FIXNUM: + return (sl_unsettable_error(sc, sym)); + + case SL_MUFFLE_WARNINGS: + if (s7_is_boolean(val)) { + sc->muffle_warnings = s7_boolean(sc, val); + return (val); + } + return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN)); + + case SL_OPENLETS: + if (s7_is_boolean(val)) { + sc->has_openlets = s7_boolean(sc, val); + return (val); + } + return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN)); + + case SL_EXPANSIONS: + if (s7_is_boolean(val)) { + sc->is_expanding = s7_boolean(sc, val); + return (val); + } + return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN)); + + case SL_OUTPUT_PORT_DATA_SIZE: + sc->output_port_data_size = + s7_integer_checked(sc, sl_integer_gt_0(sc, sym, val)); + return (val); + case SL_PRINT_LENGTH: + sc->print_length = + s7_integer_checked(sc, sl_integer_geq_0(sc, sym, val)); + return (val); + + case SL_PROFILE: + if (!s7_is_integer(val)) + return (simple_wrong_type_argument(sc, sym, val, T_INTEGER)); + sc->profile = s7_integer_checked(sc, val); + sc->debug_or_profile = ((sc->debug > 1) || (sc->profile > 0)); + if (sc->profile > 0) { + if (!is_memq + (make_symbol(sc, "profile.scm"), + s7_symbol_value(sc, sc->features_symbol))) + s7_load(sc, "profile.scm"); + if (!sc->profile_data) + make_profile_info(sc); + if (!sc->profile_out) + sc->profile_out = + s7_make_function(sc, "profile-out", g_profile_out, 2, + 0, false, NULL); + } + return (val); + + case SL_PROFILE_INFO: + return ((val == + sc->F) ? clear_profile_info(sc) : + simple_wrong_type_argument_with_type(sc, sym, val, + wrap_string(sc, + "#f (to clear the table)", + 23))); + + case SL_ROOTLET_SIZE: + return (sl_unsettable_error(sc, sym)); + + case SL_SAFETY: + if (!s7_is_integer(val)) + return (simple_wrong_type_argument(sc, sym, val, T_INTEGER)); + if ((s7_integer_checked(sc, val) > 2) + || (s7_integer_checked(sc, val) < -1)) + return (simple_out_of_range + (sc, sym, val, + wrap_string(sc, + "should be between -1 (no safety) and 2 (max safety)", + 51))); + sc->safety = s7_integer_checked(sc, val); + return (val); + + case SL_STACKTRACE_DEFAULTS: + if (!is_pair(val)) + return (simple_wrong_type_argument(sc, sym, val, T_PAIR)); + if (s7_list_length(sc, val) != 5) + return (simple_wrong_type_argument_with_type + (sc, sym, val, + wrap_string(sc, "a list with 5 entries", 21))); + if (!is_t_integer(car(val))) + return (wrong_type_argument_with_type + (sc, sym, 1, car(val), + wrap_string(sc, "an integer (stack frames)", 25))); + if (!is_t_integer(cadr(val))) + return (wrong_type_argument_with_type + (sc, sym, 2, cadr(val), + wrap_string(sc, "an integer (cols-for-data)", 26))); + if (!is_t_integer(caddr(val))) + return (wrong_type_argument_with_type + (sc, sym, 3, caddr(val), + wrap_string(sc, "an integer (line length)", 24))); + if (!is_t_integer(cadddr(val))) + return (wrong_type_argument_with_type + (sc, sym, 4, cadddr(val), + wrap_string(sc, "an integer (comment position)", + 29))); + if (!s7_is_boolean(s7_list_ref(sc, val, 4))) + return (wrong_type_argument_with_type + (sc, sym, 5, s7_list_ref(sc, val, 4), + wrap_string(sc, "a boolean (treat-data-as-comment)", + 33))); + sc->stacktrace_defaults = copy_proper_list(sc, val); + return (val); + + case SL_STACK: + case SL_STACK_SIZE: + case SL_STACK_TOP: + return (sl_unsettable_error(sc, sym)); + + case SL_UNDEFINED_CONSTANT_WARNINGS: + if (s7_is_boolean(val)) { + sc->undefined_constant_warnings = s7_boolean(sc, val); + return (val); + } + return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN)); + + case SL_UNDEFINED_IDENTIFIER_WARNINGS: + if (s7_is_boolean(val)) { + sc->undefined_identifier_warnings = s7_boolean(sc, val); + return (val); + } + return (simple_wrong_type_argument(sc, sym, val, T_BOOLEAN)); + + case SL_VERSION: + return (sl_unsettable_error(sc, sym)); + + default: + return (s7_error + (sc, sc->out_of_range_symbol, + set_elist_2(sc, + wrap_string(sc, + "can't set (*s7* '~S); no such field in *s7*", + 43), sym))); + } + return (sc->undefined); +} + +s7_pointer s7_let_field_set(s7_scheme * sc, s7_pointer sym, + s7_pointer new_value) +{ + if (is_symbol(sym)) { + if (is_keyword(sym)) + sym = keyword_symbol(sym); + if (symbol_s7_let(sym) != SL_NO_FIELD) + return (g_s7_let_set_fallback + (sc, + set_plist_3(sc, sc->s7_let_symbol, sym, new_value))); + } + return (sc->undefined); +} + + +/* ---------------- gdbinit annotated stacktrace ---------------- */ +#if (!MS_WINDOWS) +/* s7bt, s7btfull: gdb stacktrace decoding */ + +static const char *decoded_name(s7_scheme * sc, s7_pointer p) +{ + if (p == sc->value) + return ("value"); + if (p == sc->args) + return ("args"); + if (p == sc->code) + return ("code"); + if (p == sc->cur_code) + return ("cur_code"); + if (p == sc->curlet) + return ("curlet"); + if (p == sc->nil) + return ("()"); + if (p == sc->T) + return ("#t"); + if (p == sc->F) + return ("#f"); + if (p == eof_object) + return ("eof_object"); + if (p == sc->undefined) + return ("undefined"); + if (p == sc->unspecified) + return ("unspecified"); + if (p == sc->no_value) + return ("no_value"); + if (p == sc->unused) + return ("#"); + if (p == sc->symbol_table) + return ("symbol_table"); + if (p == sc->rootlet) + return ("rootlet"); + if (p == sc->s7_let) + return ("*s7*"); + if (p == sc->unlet) + return ("unlet"); + if (p == current_input_port(sc)) + return ("current-input-port"); + if (p == current_output_port(sc)) + return ("current-output-port"); + if (p == sc->error_port) + return ("error_port"); + if (p == sc->owlet) + return ("owlet"); + if (p == sc->standard_input) + return ("*stdin*"); + if (p == sc->standard_output) + return ("*stdout*"); + if (p == sc->standard_error) + return ("*stderr*"); + if (p == sc->else_symbol) + return ("else_symbol"); + return ((p == sc->stack) ? "stack" : NULL); +} + +static bool is_decodable(s7_scheme * sc, s7_pointer p) +{ + int32_t i; + s7_pointer x; + s7_pointer *tp, *heap_top; + + /* check symbol-table */ + for (i = 0; i < SYMBOL_TABLE_SIZE; i++) + for (x = vector_element(sc->symbol_table, i); is_not_null(x); + x = cdr(x)) { + s7_pointer sym = car(x); + if ((sym == p) || + ((is_global(sym)) && (is_slot(global_slot(sym))) + && (p == global_value(sym)))) + return (true); + } + + for (i = 0; i < NUM_CHARS; i++) + if (p == chars[i]) + return (true); + for (i = 0; i < NUM_SMALL_INTS; i++) + if (p == small_ints[i]) + return (true); + + /* check the heap */ + tp = sc->heap; + heap_top = (s7_pointer *) (sc->heap + sc->heap_size); + while (tp < heap_top) + if (p == (*tp++)) + return (true); + return (false); +} + +char *s7_decode_bt(s7_scheme * sc) +{ + FILE *fp; + fp = fopen("gdb.txt", "r"); + if (fp) { + int64_t i, size; + size_t bytes; + bool in_quotes = false, old_stop = sc->stop_at_error; + uint8_t *bt; + block_t *bt_block; + + sc->stop_at_error = false; + fseek(fp, 0, SEEK_END); + size = ftell(fp); + rewind(fp); + + bt_block = mallocate(sc, (size + 1) * sizeof(uint8_t)); + bt = (uint8_t *) block_data(bt_block); + bytes = fread(bt, sizeof(uint8_t), size, fp); + if (bytes != (size_t) size) { + fclose(fp); + liberate(sc, bt_block); + return ((char *) " oops "); + } + bt[size] = '\0'; + fclose(fp); + + for (i = 0; i < size; i++) { + fputc(bt[i], stdout); + if ((bt[i] == '"') && ((i == 0) || (bt[i - 1] != '\\'))) + in_quotes = (!in_quotes); + else if ((!in_quotes) && (i < size - 8) && + ((bt[i] == '=') && + (((bt[i + 1] == '0') && (bt[i + 2] == 'x')) || + ((bt[i + 1] == ' ') && (bt[i + 2] == '0') + && (bt[i + 3] == 'x'))))) { + void *vp; + int32_t vals; + vals = sscanf((const char *) (bt + i + 1), "%p", &vp); + if ((vp) && (vals == 1)) { + int32_t k; + for (k = i + ((bt[i + 2] == 'x') ? 3 : 4); + (k < size) && (IS_DIGIT(bt[k], 16)); k++); + if ((bt[k] != ' ') || (bt[k + 1] != '"')) { + if (vp == (void *) sc) { + if (bt[i + 1] == ' ') + fputc(' ', stdout); + fprintf(stdout, "%s[s7]%s", BOLD_TEXT, + UNBOLD_TEXT); + i = k - 1; + } else { + s7_pointer p = (s7_pointer) vp; + const char *dname; + dname = decoded_name(sc, p); + if (dname) { + if (bt[i + 1] == ' ') + fputc(' ', stdout); + fprintf(stdout, "%s[sc->%s]%s", BOLD_TEXT, + dname, UNBOLD_TEXT); + } + if ((dname) || (is_decodable(sc, p))) { + if (bt[i + 1] == ' ') + fputc(' ', stdout); + i = k - 1; + if (s7_is_valid(sc, p)) { + s7_pointer strp; + if (dname) + fprintf(stdout, " "); + strp = + object_to_truncated_string(sc, p, + 80); + fprintf(stdout, "%s%s%s", BOLD_TEXT, + string_value(strp), + UNBOLD_TEXT); + if ((is_pair(p)) && (has_location(p))) { + uint32_t line = + pair_line_number(p), file = + pair_file_number(p); + if (line > 0) + fprintf(stdout, + " %s(%s[%u])%s", + BOLD_TEXT, + string_value + (sc->file_names[file]), + line, UNBOLD_TEXT); + } + } + } + } + } + } + } + } + liberate(sc, bt_block); + sc->stop_at_error = old_stop; + } + return ((char *) ""); +} +#endif + + +/* -------------------------------- initialization -------------------------------- */ + +static void init_fx_function(void) +{ + fx_function = (s7_function *) calloc(NUM_OPS, sizeof(s7_function)); + + fx_function[HOP_SAFE_C_NC] = fx_c_nc; + fx_function[HOP_SAFE_C_S] = fx_c_s; + fx_function[HOP_SAFE_C_SC] = fx_c_sc; + fx_function[HOP_SAFE_C_CS] = fx_c_cs; + fx_function[HOP_SAFE_C_CQ] = fx_c_cq; + fx_function[HOP_SAFE_C_FF] = fx_c_ff; + fx_function[HOP_SAFE_C_SS] = fx_c_ss; + fx_function[HOP_SAFE_C_opNCq] = fx_c_opncq; + fx_function[HOP_SAFE_C_opSq] = fx_c_opsq; + fx_function[HOP_SAFE_C_opSSq] = fx_c_opssq; + fx_function[HOP_SAFE_C_opSCq] = fx_c_opscq; + fx_function[HOP_SAFE_C_opCSq] = fx_c_opcsq; + fx_function[HOP_SAFE_C_opSq_S] = fx_c_opsq_s; + fx_function[HOP_SAFE_C_opSq_C] = fx_c_opsq_c; + fx_function[HOP_SAFE_C_opSq_CS] = fx_c_opsq_cs; + fx_function[HOP_SAFE_C_S_opSq] = fx_c_s_opsq; + fx_function[HOP_SAFE_C_C_opSq] = fx_c_c_opsq; + fx_function[HOP_SAFE_C_opCSq_C] = fx_c_opcsq_c; + fx_function[HOP_SAFE_C_opCSq_S] = fx_c_opcsq_s; + fx_function[HOP_SAFE_C_S_opCSq] = fx_c_s_opcsq; + fx_function[HOP_SAFE_C_opSSq_C] = fx_c_opssq_c; + fx_function[HOP_SAFE_C_opSCq_C] = fx_c_opscq_c; + fx_function[HOP_SAFE_C_opSSq_S] = fx_c_opssq_s; + fx_function[HOP_SAFE_C_S_opSSq] = fx_c_s_opssq; + fx_function[HOP_SAFE_C_C_opSSq] = fx_c_c_opssq; + fx_function[HOP_SAFE_C_S_opSCq] = fx_c_s_opscq; + fx_function[HOP_SAFE_C_C_opSCq] = fx_c_c_opscq; + fx_function[HOP_SAFE_C_opSq_opSq] = fx_c_opsq_opsq; + fx_function[HOP_SAFE_C_opSq_opSSq] = fx_c_opsq_opssq; + fx_function[HOP_SAFE_C_opSSq_opSq] = fx_c_opssq_opsq; + fx_function[HOP_SAFE_C_opSSq_opSSq] = fx_c_opssq_opssq; + fx_function[HOP_SAFE_C_op_opSqq] = fx_c_op_opsqq; + fx_function[HOP_SAFE_C_op_S_opSqq] = fx_c_op_s_opsqq; + fx_function[HOP_SAFE_C_op_opSq_Sq] = fx_c_op_opsq_sq; + fx_function[HOP_SAFE_C_op_opSSqq_S] = fx_c_op_opssqq_s; + + fx_function[HOP_SAFE_C_SSC] = fx_c_ssc; + fx_function[HOP_SAFE_C_SSS] = fx_c_sss; + fx_function[HOP_SAFE_C_SCS] = fx_c_scs; + fx_function[HOP_SAFE_C_SCC] = fx_c_scc; + fx_function[HOP_SAFE_C_CSS] = fx_c_css; + fx_function[HOP_SAFE_C_CSC] = fx_c_csc; + fx_function[HOP_SAFE_C_CCS] = fx_c_ccs; + fx_function[HOP_SAFE_C_NS] = fx_c_ns; + + fx_function[HOP_SAFE_C_A] = fx_c_a; + fx_function[HOP_SAFE_C_AA] = fx_c_aa; + fx_function[HOP_SAFE_C_SA] = fx_c_sa; + fx_function[HOP_SAFE_C_AS] = fx_c_as; + fx_function[HOP_SAFE_C_CA] = fx_c_ca; + fx_function[HOP_SAFE_C_AC] = fx_c_ac; + fx_function[HOP_SAFE_C_AAA] = fx_c_aaa; + fx_function[HOP_SAFE_C_CAC] = fx_c_cac; + fx_function[HOP_SAFE_C_CSA] = fx_c_csa; + fx_function[HOP_SAFE_C_SCA] = fx_c_sca; + fx_function[HOP_SAFE_C_SAS] = fx_c_sas; + fx_function[HOP_SAFE_C_SAA] = fx_c_saa; + fx_function[HOP_SAFE_C_SSA] = fx_c_ssa; + fx_function[HOP_SAFE_C_ASS] = fx_c_ass; + fx_function[HOP_SAFE_C_AGG] = fx_c_agg; + fx_function[HOP_SAFE_C_ALL_CA] = fx_c_all_ca; + fx_function[HOP_SAFE_C_NA] = fx_c_na; + fx_function[HOP_SAFE_C_4A] = fx_c_4a; + fx_function[HOP_SAFE_C_opAq] = fx_c_opaq; + fx_function[HOP_SAFE_C_opAAq] = fx_c_opaaq; + fx_function[HOP_SAFE_C_opAAAq] = fx_c_opaaaq; + fx_function[HOP_SAFE_C_opAq_S] = fx_c_opaq_s; + fx_function[HOP_SAFE_C_S_opAq] = fx_c_s_opaq; + fx_function[HOP_SAFE_C_S_opAAq] = fx_c_s_opaaq; + fx_function[HOP_SAFE_C_S_opAAAq] = fx_c_s_opaaaq; + + fx_function[HOP_SSA_DIRECT] = fx_c_ssa_direct; + fx_function[HOP_HASH_TABLE_INCREMENT] = fx_hash_table_increment; + + fx_function[HOP_SAFE_THUNK_A] = fx_safe_thunk_a; + fx_function[HOP_SAFE_CLOSURE_S_A] = fx_safe_closure_s_a; + fx_function[HOP_SAFE_CLOSURE_A_A] = fx_safe_closure_a_a; + fx_function[HOP_SAFE_CLOSURE_SS_A] = fx_safe_closure_ss_a; + fx_function[HOP_SAFE_CLOSURE_AA_A] = fx_safe_closure_aa_a; + fx_function[HOP_SAFE_CLOSURE_3S_A] = fx_safe_closure_3s_a; + fx_function[HOP_SAFE_CLOSURE_S_TO_S] = fx_safe_closure_s_to_s; + fx_function[HOP_SAFE_CLOSURE_S_TO_SC] = fx_safe_closure_s_to_sc; + fx_function[HOP_SAFE_CLOSURE_A_TO_SC] = fx_safe_closure_a_to_sc; + + fx_function[OP_COND_FX_FX] = fx_cond_fx_fx; + fx_function[OP_IF_A_C_C] = fx_if_a_c_c; + fx_function[OP_IF_A_A] = fx_if_a_a; + fx_function[OP_IF_S_A_A] = fx_if_s_a_a; + fx_function[OP_IF_A_A_A] = fx_if_a_a_a; + fx_function[OP_IF_AND2_S_A] = fx_if_and2_s_a; + fx_function[OP_IF_NOT_A_A] = fx_if_not_a_a; + fx_function[OP_IF_NOT_A_A_A] = fx_if_not_a_a_a; + fx_function[OP_IF_IS_TYPE_S_A_A] = fx_if_is_type_s_a_a; + fx_function[OP_OR_2A] = fx_or_2a; + fx_function[OP_OR_S_2] = fx_or_s_2; + fx_function[OP_OR_S_TYPE_2] = fx_or_s_type_2; + fx_function[OP_OR_3A] = fx_or_3a; + fx_function[OP_OR_N] = fx_or_n; + fx_function[OP_AND_2A] = fx_and_2a; + fx_function[OP_AND_S_2] = fx_and_s_2; + fx_function[OP_AND_3A] = fx_and_3a; + fx_function[OP_AND_N] = fx_and_n; + fx_function[OP_BEGIN_NA] = fx_begin_na; + fx_function[OP_BEGIN_AA] = fx_begin_aa; + fx_function[OP_LET_TEMP_A_A] = fx_let_temp_a_a; + fx_function[OP_IMPLICIT_S7_LET_REF_S] = fx_implicit_s7_let_ref_s; + fx_function[OP_IMPLICIT_S7_LET_SET_SA] = fx_implicit_s7_let_set_sa; + + /* these are ok even if a "z" branch is taken -- in that case the body does not have the is_optimized bit, so is_fxable returns false */ + fx_function[OP_TC_AND_A_OR_A_LA] = fx_tc_and_a_or_a_la; + fx_function[OP_TC_OR_A_AND_A_LA] = fx_tc_or_a_and_a_la; + fx_function[OP_TC_OR_A_A_AND_A_A_LA] = fx_tc_or_a_a_and_a_a_la; + fx_function[OP_TC_AND_A_OR_A_LAA] = fx_tc_and_a_or_a_laa; + fx_function[OP_TC_OR_A_AND_A_LAA] = fx_tc_or_a_and_a_laa; + fx_function[OP_TC_AND_A_OR_A_A_LA] = fx_tc_and_a_or_a_a_la; + fx_function[OP_TC_OR_A_AND_A_A_LA] = fx_tc_or_a_and_a_a_la; + fx_function[OP_TC_IF_A_Z_LA] = fx_tc_if_a_z_la; + fx_function[OP_TC_IF_A_LA_Z] = fx_tc_if_a_la_z; + fx_function[OP_TC_COND_A_Z_LA] = fx_tc_cond_a_z_la; + fx_function[OP_TC_COND_A_LA_Z] = fx_tc_cond_a_la_z; + fx_function[OP_TC_IF_A_Z_LAA] = fx_tc_if_a_z_laa; + fx_function[OP_TC_IF_A_LAA_Z] = fx_tc_if_a_laa_z; + fx_function[OP_TC_COND_A_Z_LAA] = fx_tc_cond_a_z_laa; + fx_function[OP_TC_COND_A_LAA_Z] = fx_tc_cond_a_laa_z; + fx_function[OP_TC_IF_A_Z_L3A] = fx_tc_if_a_z_l3a; + fx_function[OP_TC_IF_A_L3A_Z] = fx_tc_if_a_l3a_z; + fx_function[OP_TC_IF_A_Z_IF_A_Z_LA] = fx_tc_if_a_z_if_a_z_la; + fx_function[OP_TC_IF_A_Z_IF_A_LA_Z] = fx_tc_if_a_z_if_a_la_z; + fx_function[OP_TC_COND_A_Z_A_Z_LA] = fx_tc_cond_a_z_a_z_la; + fx_function[OP_TC_COND_A_Z_A_LA_Z] = fx_tc_cond_a_z_a_la_z; + fx_function[OP_TC_AND_A_IF_A_Z_LA] = fx_tc_and_a_if_a_z_la; + fx_function[OP_TC_AND_A_IF_A_LA_Z] = fx_tc_and_a_if_a_la_z; + fx_function[OP_TC_IF_A_Z_IF_A_LAA_Z] = fx_tc_if_a_z_if_a_laa_z; + fx_function[OP_TC_IF_A_Z_IF_A_Z_LAA] = fx_tc_if_a_z_if_a_z_laa; + fx_function[OP_TC_COND_A_Z_A_Z_LAA] = fx_tc_cond_a_z_a_z_laa; + fx_function[OP_TC_COND_A_Z_A_LAA_Z] = fx_tc_cond_a_z_a_laa_z; + fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A] = fx_tc_if_a_z_if_a_l3a_l3a; + fx_function[OP_TC_CASE_LA] = fx_tc_case_la; + fx_function[OP_TC_OR_A_AND_A_A_L3A] = fx_tc_or_a_and_a_a_l3a; + fx_function[OP_TC_LET_IF_A_Z_LA] = fx_tc_let_if_a_z_la; + fx_function[OP_TC_LET_IF_A_Z_LAA] = fx_tc_let_if_a_z_laa; + fx_function[OP_TC_LET_WHEN_LAA] = fx_tc_let_when_laa; + fx_function[OP_TC_LET_UNLESS_LAA] = fx_tc_let_unless_laa; + fx_function[OP_TC_LET_COND] = fx_tc_let_cond; + fx_function[OP_TC_COND_A_Z_A_LAA_LAA] = fx_tc_cond_a_z_a_laa_laa; + + fx_function[OP_RECUR_IF_A_A_opA_LAq] = fx_recur_if_a_a_opa_laq; + fx_function[OP_RECUR_IF_A_opA_LAq_A] = fx_recur_if_a_opa_laq_a; + fx_function[OP_RECUR_IF_A_A_AND_A_LAA_LAA] = + fx_recur_if_a_a_and_a_laa_laa; + fx_function[OP_RECUR_COND_A_A_A_A_opLA_LAq] = + fx_recur_cond_a_a_a_a_opla_laq; + fx_function[OP_RECUR_AND_A_OR_A_LAA_LAA] = fx_recur_and_a_or_a_laa_laa; +} + +static void init_opt_functions(s7_scheme * sc) +{ +#if (!WITH_PURE_S7) + s7_set_b_7pp_function(sc, global_value(sc->char_ci_lt_symbol), + char_ci_lt_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->char_ci_leq_symbol), + char_ci_leq_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->char_ci_gt_symbol), + char_ci_gt_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->char_ci_geq_symbol), + char_ci_geq_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->char_ci_eq_symbol), + char_ci_eq_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->string_ci_lt_symbol), + string_ci_lt_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->string_ci_leq_symbol), + string_ci_leq_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->string_ci_gt_symbol), + string_ci_gt_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->string_ci_geq_symbol), + string_ci_geq_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->string_ci_eq_symbol), + string_ci_eq_b_7pp); + + s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_lt_symbol), + char_ci_lt_b_unchecked); + s7_set_b_pp_unchecked_function(sc, + global_value(sc->char_ci_leq_symbol), + char_ci_leq_b_unchecked); + s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_gt_symbol), + char_ci_gt_b_unchecked); + s7_set_b_pp_unchecked_function(sc, + global_value(sc->char_ci_geq_symbol), + char_ci_geq_b_unchecked); + s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_eq_symbol), + char_ci_eq_b_unchecked); + s7_set_b_pp_unchecked_function(sc, + global_value(sc->string_ci_lt_symbol), + string_ci_lt_b_unchecked); + s7_set_b_pp_unchecked_function(sc, + global_value(sc->string_ci_leq_symbol), + string_ci_leq_b_unchecked); + s7_set_b_pp_unchecked_function(sc, + global_value(sc->string_ci_gt_symbol), + string_ci_gt_b_unchecked); + s7_set_b_pp_unchecked_function(sc, + global_value(sc->string_ci_geq_symbol), + string_ci_geq_b_unchecked); + s7_set_b_pp_unchecked_function(sc, + global_value(sc->string_ci_eq_symbol), + string_ci_eq_b_unchecked); + + s7_set_p_pp_function(sc, global_value(sc->vector_append_symbol), + vector_append_p_pp); + s7_set_p_ppp_function(sc, global_value(sc->vector_append_symbol), + vector_append_p_ppp); + s7_set_i_i_function(sc, global_value(sc->integer_length_symbol), + integer_length_i_i); + s7_set_i_7p_function(sc, global_value(sc->string_length_symbol), + string_length_i_7p); + s7_set_i_7p_function(sc, global_value(sc->vector_length_symbol), + vector_length_i_7p); + s7_set_p_p_function(sc, global_value(sc->vector_to_list_symbol), + vector_to_list_p_p); + s7_set_p_p_function(sc, global_value(sc->string_to_list_symbol), + string_to_list_p_p); + s7_set_p_p_function(sc, global_value(sc->vector_length_symbol), + vector_length_p_p); + s7_set_b_7p_function(sc, global_value(sc->is_exact_symbol), + is_exact_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_inexact_symbol), + is_inexact_b_7p); +#endif + + s7_set_p_pp_function(sc, global_value(sc->float_vector_ref_symbol), + float_vector_ref_p_pp); + s7_set_d_7pi_function(sc, global_value(sc->float_vector_ref_symbol), + float_vector_ref_d_7pi); + s7_set_d_7pii_function(sc, global_value(sc->float_vector_ref_symbol), + float_vector_ref_d_7pii); + s7_set_d_7piii_function(sc, global_value(sc->float_vector_ref_symbol), + float_vector_ref_d_7piii); + s7_set_d_7pid_function(sc, global_value(sc->float_vector_set_symbol), + float_vector_set_d_7pid); + s7_set_d_7piid_function(sc, global_value(sc->float_vector_set_symbol), + float_vector_set_d_7piid); + s7_set_d_7piiid_function(sc, global_value(sc->float_vector_set_symbol), + float_vector_set_d_7piiid); + + s7_set_p_pp_function(sc, global_value(sc->int_vector_ref_symbol), + int_vector_ref_p_pp); + s7_set_i_7pi_function(sc, global_value(sc->int_vector_ref_symbol), + int_vector_ref_i_7pi); + s7_set_i_7pii_function(sc, global_value(sc->int_vector_ref_symbol), + int_vector_ref_i_7pii); + s7_set_i_7piii_function(sc, global_value(sc->int_vector_ref_symbol), + int_vector_ref_i_7piii); + s7_set_i_7pii_function(sc, global_value(sc->int_vector_set_symbol), + int_vector_set_i_7pii); + s7_set_i_7piii_function(sc, global_value(sc->int_vector_set_symbol), + int_vector_set_i_7piii); + + s7_set_i_7pi_function(sc, global_value(sc->byte_vector_ref_symbol), + byte_vector_ref_i_7pi); + s7_set_i_7pii_function(sc, global_value(sc->byte_vector_ref_symbol), + byte_vector_ref_i_7pii); + s7_set_i_7pii_function(sc, global_value(sc->byte_vector_set_symbol), + byte_vector_set_i_7pii); + s7_set_i_7piii_function(sc, global_value(sc->byte_vector_set_symbol), + byte_vector_set_i_7piii); + + s7_set_p_pp_function(sc, global_value(sc->vector_ref_symbol), + vector_ref_p_pp); + s7_set_p_pi_function(sc, global_value(sc->vector_ref_symbol), + vector_ref_p_pi); + s7_set_p_pii_function(sc, global_value(sc->vector_ref_symbol), + vector_ref_p_pii); + s7_set_p_pip_function(sc, global_value(sc->vector_set_symbol), + vector_set_p_pip); + s7_set_p_piip_function(sc, global_value(sc->vector_set_symbol), + vector_set_p_piip); + s7_set_p_pi_unchecked_function(sc, global_value(sc->vector_ref_symbol), + vector_ref_p_pi_unchecked); + s7_set_p_pip_unchecked_function(sc, + global_value(sc->vector_set_symbol), + vector_set_p_pip_unchecked); + s7_set_p_ppp_function(sc, global_value(sc->vector_set_symbol), + vector_set_p_ppp); + s7_set_p_ppp_function(sc, global_value(sc->int_vector_set_symbol), + int_vector_set_p_ppp); + + s7_set_p_pi_function(sc, global_value(sc->list_ref_symbol), + list_ref_p_pi); + s7_set_p_pip_function(sc, global_value(sc->list_set_symbol), + list_set_p_pip); + s7_set_p_pi_unchecked_function(sc, global_value(sc->list_ref_symbol), + list_ref_p_pi_unchecked); + s7_set_p_pip_unchecked_function(sc, global_value(sc->list_set_symbol), + list_set_p_pip_unchecked); + s7_set_p_p_function(sc, global_value(sc->cyclic_sequences_symbol), + cyclic_sequences_p_p); + s7_set_p_pp_function(sc, global_value(sc->let_ref_symbol), s7_let_ref); + s7_set_p_ppp_function(sc, global_value(sc->let_set_symbol), + s7_let_set); + s7_set_p_pi_function(sc, global_value(sc->string_ref_symbol), + string_ref_p_pi); + s7_set_p_pp_function(sc, global_value(sc->string_ref_symbol), + string_ref_p_pp); + s7_set_p_pip_function(sc, global_value(sc->string_set_symbol), + string_set_p_pip); + s7_set_p_pi_unchecked_function(sc, global_value(sc->string_ref_symbol), + string_ref_p_pi_unchecked); + s7_set_p_pip_unchecked_function(sc, + global_value(sc->string_set_symbol), + string_set_p_pip_unchecked); + s7_set_p_pp_function(sc, global_value(sc->hash_table_ref_symbol), + hash_table_ref_p_pp); + s7_set_p_ppp_function(sc, global_value(sc->hash_table_set_symbol), + hash_table_set_p_ppp); + + s7_set_p_ii_function(sc, global_value(sc->complex_symbol), + complex_p_ii); + s7_set_p_dd_function(sc, global_value(sc->complex_symbol), + complex_p_dd); + s7_set_p_i_function(sc, global_value(sc->number_to_string_symbol), + number_to_string_p_i); + s7_set_p_p_function(sc, global_value(sc->number_to_string_symbol), + number_to_string_p_p); + s7_set_p_pp_function(sc, global_value(sc->number_to_string_symbol), + number_to_string_p_pp); + s7_set_p_p_function(sc, global_value(sc->string_to_number_symbol), + string_to_number_p_p); + s7_set_p_pp_function(sc, global_value(sc->string_to_number_symbol), + string_to_number_p_pp); + + s7_set_p_p_function(sc, global_value(sc->car_symbol), car_p_p); + s7_set_p_pp_function(sc, global_value(sc->set_car_symbol), + set_car_p_pp); + s7_set_p_p_function(sc, global_value(sc->cdr_symbol), cdr_p_p); + s7_set_p_pp_function(sc, global_value(sc->set_cdr_symbol), + set_cdr_p_pp); + s7_set_p_p_function(sc, global_value(sc->caar_symbol), caar_p_p); + s7_set_p_p_function(sc, global_value(sc->cadr_symbol), cadr_p_p); + s7_set_p_p_function(sc, global_value(sc->cdar_symbol), cdar_p_p); + s7_set_p_p_function(sc, global_value(sc->cddr_symbol), cddr_p_p); + s7_set_p_p_function(sc, global_value(sc->caddr_symbol), caddr_p_p); + s7_set_p_p_function(sc, global_value(sc->caadr_symbol), caadr_p_p); + s7_set_p_p_function(sc, global_value(sc->cadar_symbol), cadar_p_p); + s7_set_p_p_function(sc, global_value(sc->cdddr_symbol), cdddr_p_p); + s7_set_p_p_function(sc, global_value(sc->cdadr_symbol), cdadr_p_p); + s7_set_p_p_function(sc, global_value(sc->cddar_symbol), cddar_p_p); + s7_set_p_p_function(sc, global_value(sc->cdaar_symbol), cdaar_p_p); + s7_set_p_p_function(sc, global_value(sc->caaar_symbol), caaar_p_p); + s7_set_p_p_function(sc, global_value(sc->caddar_symbol), caddar_p_p); + s7_set_p_p_function(sc, global_value(sc->caaddr_symbol), caaddr_p_p); + s7_set_p_p_function(sc, global_value(sc->cadddr_symbol), cadddr_p_p); + s7_set_p_p_function(sc, global_value(sc->cadadr_symbol), cadadr_p_p); + + s7_set_p_p_function(sc, global_value(sc->string_symbol), string_p_p); + s7_set_p_p_function(sc, global_value(sc->string_to_symbol_symbol), + string_to_symbol_p_p); + s7_set_p_p_function(sc, global_value(sc->symbol_to_string_symbol), + symbol_to_string_p_p); + s7_set_p_p_function(sc, global_value(sc->symbol_symbol), + string_to_symbol_p_p); + s7_set_p_pp_function(sc, global_value(sc->symbol_symbol), symbol_p_pp); + s7_set_p_function(sc, global_value(sc->newline_symbol), newline_p); + s7_set_p_p_function(sc, global_value(sc->newline_symbol), newline_p_p); + s7_set_p_p_function(sc, global_value(sc->display_symbol), display_p_p); + s7_set_p_pp_function(sc, global_value(sc->display_symbol), + display_p_pp); + s7_set_p_p_function(sc, global_value(sc->write_symbol), write_p_p); + s7_set_p_pp_function(sc, global_value(sc->write_symbol), write_p_pp); + s7_set_p_p_function(sc, global_value(sc->write_char_symbol), + write_char_p_p); + s7_set_p_pp_function(sc, global_value(sc->write_char_symbol), + write_char_p_pp); + s7_set_p_pp_function(sc, global_value(sc->write_string_symbol), + write_string_p_pp); + s7_set_p_pp_function(sc, global_value(sc->read_line_symbol), + read_line_p_pp); + s7_set_p_p_function(sc, global_value(sc->read_line_symbol), + read_line_p_p); + s7_set_p_pp_function(sc, global_value(sc->inlet_symbol), inlet_p_pp); + s7_set_i_7p_function(sc, global_value(sc->port_line_number_symbol), + s7_port_line_number); + s7_set_p_pp_function(sc, global_value(sc->cons_symbol), cons_p_pp); + s7_set_p_function(sc, global_value(sc->open_output_string_symbol), + s7_open_output_string); + s7_set_p_ppi_function(sc, global_value(sc->char_position_symbol), + char_position_p_ppi); + s7_set_p_pp_function(sc, global_value(sc->append_symbol), s7_append); + s7_set_p_pp_function(sc, global_value(sc->string_append_symbol), + string_append_p_pp); + s7_set_p_ppp_function(sc, global_value(sc->append_symbol), + append_p_ppp); + s7_set_p_function(sc, global_value(sc->values_symbol), values_p); + s7_set_p_p_function(sc, global_value(sc->values_symbol), values_p_p); + s7_set_p_pp_function(sc, global_value(sc->member_symbol), member_p_pp); + s7_set_p_pp_function(sc, global_value(sc->assoc_symbol), assoc_p_pp); + + s7_set_i_i_function(sc, global_value(sc->abs_symbol), abs_i_i); + s7_set_d_d_function(sc, global_value(sc->abs_symbol), abs_d_d); + s7_set_p_p_function(sc, global_value(sc->abs_symbol), abs_p_p); + s7_set_p_p_function(sc, global_value(sc->magnitude_symbol), + magnitude_p_p); + + s7_set_p_d_function(sc, global_value(sc->sin_symbol), sin_p_d); + s7_set_p_p_function(sc, global_value(sc->sin_symbol), sin_p_p); + s7_set_p_d_function(sc, global_value(sc->cos_symbol), cos_p_d); + s7_set_p_p_function(sc, global_value(sc->cos_symbol), cos_p_p); + s7_set_p_p_function(sc, global_value(sc->tan_symbol), tan_p_p); + s7_set_p_p_function(sc, global_value(sc->asin_symbol), asin_p_p); + s7_set_p_p_function(sc, global_value(sc->acos_symbol), acos_p_p); + + s7_set_p_d_function(sc, global_value(sc->rationalize_symbol), + rationalize_p_d); + s7_set_p_i_function(sc, global_value(sc->rationalize_symbol), + rationalize_p_i); + s7_set_i_i_function(sc, global_value(sc->rationalize_symbol), + rationalize_i_i); + s7_set_p_p_function(sc, global_value(sc->truncate_symbol), + truncate_p_p); + s7_set_p_p_function(sc, global_value(sc->round_symbol), round_p_p); + s7_set_p_p_function(sc, global_value(sc->ceiling_symbol), ceiling_p_p); + s7_set_p_p_function(sc, global_value(sc->floor_symbol), floor_p_p); + s7_set_p_pp_function(sc, global_value(sc->max_symbol), max_p_pp); + s7_set_p_pp_function(sc, global_value(sc->min_symbol), min_p_pp); + s7_set_p_p_function(sc, global_value(sc->sqrt_symbol), sqrt_p_p); + + s7_set_d_7dd_function(sc, global_value(sc->remainder_symbol), + remainder_d_7dd); + s7_set_i_7ii_function(sc, global_value(sc->remainder_symbol), + remainder_i_7ii); + s7_set_i_7ii_function(sc, global_value(sc->quotient_symbol), + quotient_i_7ii); + s7_set_d_7dd_function(sc, global_value(sc->modulo_symbol), + modulo_d_7dd); + s7_set_i_ii_function(sc, global_value(sc->modulo_symbol), modulo_i_ii); + s7_set_p_dd_function(sc, global_value(sc->multiply_symbol), mul_p_dd); + s7_set_p_dd_function(sc, global_value(sc->add_symbol), add_p_dd); + s7_set_p_dd_function(sc, global_value(sc->subtract_symbol), + subtract_p_dd); + s7_set_p_ii_function(sc, global_value(sc->subtract_symbol), + subtract_p_ii); + + s7_set_p_pp_function(sc, global_value(sc->modulo_symbol), modulo_p_pp); + s7_set_p_pp_function(sc, global_value(sc->remainder_symbol), + remainder_p_pp); + s7_set_p_pp_function(sc, global_value(sc->quotient_symbol), + quotient_p_pp); + s7_set_p_pp_function(sc, global_value(sc->subtract_symbol), + subtract_p_pp); + s7_set_p_pp_function(sc, global_value(sc->add_symbol), add_p_pp); + s7_set_p_ppp_function(sc, global_value(sc->add_symbol), add_p_ppp); + s7_set_p_pp_function(sc, global_value(sc->multiply_symbol), + multiply_p_pp); + s7_set_p_ppp_function(sc, global_value(sc->multiply_symbol), + multiply_p_ppp); + s7_set_p_pp_function(sc, global_value(sc->divide_symbol), divide_p_pp); + s7_set_p_p_function(sc, global_value(sc->divide_symbol), invert_p_p); + s7_set_p_p_function(sc, global_value(sc->subtract_symbol), negate_p_p); + + s7_set_p_p_function(sc, global_value(sc->random_symbol), random_p_p); + s7_set_d_7d_function(sc, global_value(sc->random_symbol), random_d_7d); + s7_set_i_7i_function(sc, global_value(sc->random_symbol), random_i_7i); + + s7_set_p_d_function(sc, global_value(sc->float_vector_symbol), + float_vector_p_d); + s7_set_p_i_function(sc, global_value(sc->int_vector_symbol), + int_vector_p_i); + s7_set_i_i_function(sc, global_value(sc->round_symbol), round_i_i); + s7_set_i_i_function(sc, global_value(sc->floor_symbol), floor_i_i); + s7_set_i_i_function(sc, global_value(sc->ceiling_symbol), ceiling_i_i); + s7_set_i_i_function(sc, global_value(sc->truncate_symbol), + truncate_i_i); + + s7_set_d_d_function(sc, global_value(sc->tan_symbol), tan_d_d); + s7_set_d_dd_function(sc, global_value(sc->atan_symbol), atan_d_dd); + s7_set_d_d_function(sc, global_value(sc->tanh_symbol), tanh_d_d); + s7_set_p_p_function(sc, global_value(sc->exp_symbol), exp_p_p); +#if (!WITH_GMP) + s7_set_i_7ii_function(sc, global_value(sc->ash_symbol), ash_i_7ii); + s7_set_d_d_function(sc, global_value(sc->sin_symbol), sin_d_d); + s7_set_d_d_function(sc, global_value(sc->cos_symbol), cos_d_d); + s7_set_d_d_function(sc, global_value(sc->sinh_symbol), sinh_d_d); + s7_set_d_d_function(sc, global_value(sc->cosh_symbol), cosh_d_d); + s7_set_d_d_function(sc, global_value(sc->exp_symbol), exp_d_d); + s7_set_i_7d_function(sc, global_value(sc->round_symbol), round_i_7d); + s7_set_i_7d_function(sc, global_value(sc->floor_symbol), floor_i_7d); + s7_set_i_7d_function(sc, global_value(sc->ceiling_symbol), + ceiling_i_7d); + s7_set_i_7p_function(sc, global_value(sc->floor_symbol), floor_i_7p); + s7_set_i_7p_function(sc, global_value(sc->ceiling_symbol), + ceiling_i_7p); + s7_set_i_7d_function(sc, global_value(sc->truncate_symbol), + truncate_i_7d); +#endif + + s7_set_d_d_function(sc, global_value(sc->add_symbol), add_d_d); + s7_set_d_d_function(sc, global_value(sc->subtract_symbol), + subtract_d_d); + s7_set_d_d_function(sc, global_value(sc->multiply_symbol), + multiply_d_d); + s7_set_d_7d_function(sc, global_value(sc->divide_symbol), divide_d_7d); + s7_set_d_dd_function(sc, global_value(sc->add_symbol), add_d_dd); + s7_set_d_dd_function(sc, global_value(sc->subtract_symbol), + subtract_d_dd); + s7_set_d_dd_function(sc, global_value(sc->multiply_symbol), + multiply_d_dd); + s7_set_d_7dd_function(sc, global_value(sc->divide_symbol), + divide_d_7dd); + s7_set_d_ddd_function(sc, global_value(sc->add_symbol), add_d_ddd); + s7_set_d_ddd_function(sc, global_value(sc->subtract_symbol), + subtract_d_ddd); + s7_set_d_ddd_function(sc, global_value(sc->multiply_symbol), + multiply_d_ddd); + s7_set_d_dddd_function(sc, global_value(sc->add_symbol), add_d_dddd); + s7_set_d_dddd_function(sc, global_value(sc->subtract_symbol), + subtract_d_dddd); + s7_set_d_dddd_function(sc, global_value(sc->multiply_symbol), + multiply_d_dddd); + s7_set_p_i_function(sc, global_value(sc->divide_symbol), divide_p_i); + s7_set_p_ii_function(sc, global_value(sc->divide_symbol), divide_p_ii); + s7_set_d_dd_function(sc, global_value(sc->max_symbol), max_d_dd); + s7_set_d_dd_function(sc, global_value(sc->min_symbol), min_d_dd); + s7_set_d_ddd_function(sc, global_value(sc->max_symbol), max_d_ddd); + s7_set_d_ddd_function(sc, global_value(sc->min_symbol), min_d_ddd); + s7_set_d_dddd_function(sc, global_value(sc->max_symbol), max_d_dddd); + s7_set_d_dddd_function(sc, global_value(sc->min_symbol), min_d_dddd); + s7_set_i_ii_function(sc, global_value(sc->max_symbol), max_i_ii); + s7_set_i_ii_function(sc, global_value(sc->min_symbol), min_i_ii); + s7_set_i_iii_function(sc, global_value(sc->max_symbol), max_i_iii); + s7_set_i_iii_function(sc, global_value(sc->min_symbol), min_i_iii); + s7_set_i_i_function(sc, global_value(sc->subtract_symbol), + subtract_i_i); + s7_set_i_ii_function(sc, global_value(sc->add_symbol), add_i_ii); + s7_set_i_iii_function(sc, global_value(sc->add_symbol), add_i_iii); + s7_set_i_ii_function(sc, global_value(sc->subtract_symbol), + subtract_i_ii); + s7_set_i_iii_function(sc, global_value(sc->subtract_symbol), + subtract_i_iii); + s7_set_i_ii_function(sc, global_value(sc->multiply_symbol), + multiply_i_ii); + s7_set_i_iii_function(sc, global_value(sc->multiply_symbol), + multiply_i_iii); + + s7_set_i_i_function(sc, global_value(sc->lognot_symbol), lognot_i_i); + s7_set_i_ii_function(sc, global_value(sc->logior_symbol), logior_i_ii); + s7_set_i_ii_function(sc, global_value(sc->logxor_symbol), logxor_i_ii); + s7_set_i_ii_function(sc, global_value(sc->logand_symbol), logand_i_ii); + s7_set_i_iii_function(sc, global_value(sc->logior_symbol), + logior_i_iii); + s7_set_i_iii_function(sc, global_value(sc->logxor_symbol), + logxor_i_iii); + s7_set_i_iii_function(sc, global_value(sc->logand_symbol), + logand_i_iii); + s7_set_b_7ii_function(sc, global_value(sc->logbit_symbol), + logbit_b_7ii); + s7_set_b_7pp_function(sc, global_value(sc->logbit_symbol), + logbit_b_7pp); + + s7_set_i_7p_function(sc, global_value(sc->numerator_symbol), + numerator_i_7p); + s7_set_i_7p_function(sc, global_value(sc->denominator_symbol), + denominator_i_7p); + s7_set_i_7p_function(sc, global_value(sc->char_to_integer_symbol), + char_to_integer_i_7p); + s7_set_i_7p_function(sc, global_value(sc->hash_table_entries_symbol), + hash_table_entries_i_7p); + s7_set_i_7p_function(sc, global_value(sc->tree_leaves_symbol), + tree_leaves_i_7p); + s7_set_p_p_function(sc, global_value(sc->char_to_integer_symbol), + char_to_integer_p_p); + + s7_set_b_p_function(sc, global_value(sc->is_boolean_symbol), + s7_is_boolean); + s7_set_b_p_function(sc, global_value(sc->is_byte_vector_symbol), + is_byte_vector_b_p); + s7_set_b_p_function(sc, global_value(sc->is_c_object_symbol), + s7_is_c_object); + s7_set_b_p_function(sc, global_value(sc->is_char_symbol), + s7_is_character); + s7_set_b_p_function(sc, global_value(sc->is_complex_symbol), + s7_is_complex); + s7_set_b_p_function(sc, global_value(sc->is_continuation_symbol), + is_continuation_b_p); + s7_set_b_p_function(sc, global_value(sc->is_c_pointer_symbol), + s7_is_c_pointer); + s7_set_b_p_function(sc, global_value(sc->is_dilambda_symbol), + s7_is_dilambda); + s7_set_b_p_function(sc, global_value(sc->is_eof_object_symbol), + is_eof_object_b_p); + s7_set_b_7p_function(sc, global_value(sc->is_even_symbol), + is_even_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_odd_symbol), is_odd_b_7p); + s7_set_b_p_function(sc, global_value(sc->is_float_symbol), is_float_b); + s7_set_b_p_function(sc, global_value(sc->is_float_vector_symbol), + s7_is_float_vector); + s7_set_b_p_function(sc, global_value(sc->is_gensym_symbol), + is_gensym_b_p); + s7_set_b_p_function(sc, global_value(sc->is_hash_table_symbol), + s7_is_hash_table); + s7_set_b_7p_function(sc, global_value(sc->is_infinite_symbol), + is_infinite_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_nan_symbol), is_nan_b_7p); + s7_set_b_p_function(sc, global_value(sc->is_input_port_symbol), + is_input_port_b); + s7_set_b_p_function(sc, global_value(sc->is_integer_symbol), + s7_is_integer); + s7_set_b_p_function(sc, global_value(sc->is_int_vector_symbol), + s7_is_int_vector); + s7_set_b_p_function(sc, global_value(sc->is_keyword_symbol), + s7_is_keyword); + s7_set_b_p_function(sc, global_value(sc->is_let_symbol), s7_is_let); + s7_set_b_p_function(sc, global_value(sc->is_list_symbol), is_list_b); + s7_set_b_p_function(sc, global_value(sc->is_macro_symbol), is_macro_b); + s7_set_b_p_function(sc, global_value(sc->is_number_symbol), + s7_is_number); + s7_set_b_p_function(sc, global_value(sc->is_output_port_symbol), + is_output_port_b); + s7_set_b_p_function(sc, global_value(sc->is_pair_symbol), s7_is_pair); + s7_set_b_p_function(sc, global_value(sc->is_null_symbol), is_null_b_p); + s7_set_b_7p_function(sc, global_value(sc->is_port_closed_symbol), + is_port_closed_b_7p); + s7_set_b_p_function(sc, global_value(sc->is_procedure_symbol), + s7_is_procedure); + s7_set_b_7p_function(sc, global_value(sc->is_proper_list_symbol), + s7_is_proper_list); + s7_set_b_p_function(sc, global_value(sc->is_random_state_symbol), + s7_is_random_state); + s7_set_b_p_function(sc, global_value(sc->is_rational_symbol), + s7_is_rational); + s7_set_b_p_function(sc, global_value(sc->is_real_symbol), s7_is_real); + s7_set_b_p_function(sc, global_value(sc->is_sequence_symbol), + is_sequence_b); + s7_set_b_p_function(sc, global_value(sc->is_string_symbol), + s7_is_string); + s7_set_b_p_function(sc, global_value(sc->is_symbol_symbol), + s7_is_symbol); + s7_set_b_p_function(sc, global_value(sc->is_syntax_symbol), + s7_is_syntax); + s7_set_b_p_function(sc, global_value(sc->is_vector_symbol), + s7_is_vector); + s7_set_b_7p_function(sc, global_value(sc->is_iterator_symbol), + is_iterator_b_7p); + + s7_set_b_7p_function(sc, global_value(sc->is_char_alphabetic_symbol), + is_char_alphabetic_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_char_lower_case_symbol), + is_char_lower_case_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_char_numeric_symbol), + is_char_numeric_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_char_upper_case_symbol), + is_char_upper_case_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_char_whitespace_symbol), + is_char_whitespace_b_7p); + + s7_set_b_p_function(sc, global_value(sc->is_openlet_symbol), + s7_is_openlet); + s7_set_b_7p_function(sc, global_value(sc->iterator_is_at_end_symbol), + iterator_is_at_end_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_zero_symbol), + is_zero_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_negative_symbol), + is_negative_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_positive_symbol), + is_positive_b_7p); + s7_set_b_7p_function(sc, global_value(sc->not_symbol), not_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_provided_symbol), + is_provided_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_defined_symbol), + is_defined_b_7p); + s7_set_b_7pp_function(sc, global_value(sc->is_defined_symbol), + is_defined_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->tree_memq_symbol), + s7_tree_memq); + s7_set_b_7p_function(sc, global_value(sc->tree_is_cyclic_symbol), + tree_is_cyclic); + s7_set_b_7pp_function(sc, global_value(sc->tree_set_memq_symbol), + tree_set_memq_b_7pp); + s7_set_p_pp_function(sc, global_value(sc->tree_set_memq_symbol), + tree_set_memq_p_pp); + s7_set_b_p_function(sc, global_value(sc->is_immutable_symbol), + s7_is_immutable); + + s7_set_p_p_function(sc, global_value(sc->is_proper_list_symbol), + is_proper_list_p_p); + s7_set_p_p_function(sc, global_value(sc->is_pair_symbol), is_pair_p_p); + s7_set_p_p_function(sc, global_value(sc->is_char_symbol), is_char_p_p); + s7_set_p_p_function(sc, global_value(sc->is_constant_symbol), + is_constant_p_p); + s7_set_b_7p_function(sc, global_value(sc->is_constant_symbol), + is_constant_b_7p); + s7_set_p_p_function(sc, global_value(sc->type_of_symbol), s7_type_of); + s7_set_p_i_function(sc, global_value(sc->integer_to_char_symbol), + integer_to_char_p_i); + s7_set_p_p_function(sc, global_value(sc->integer_to_char_symbol), + integer_to_char_p_p); + s7_set_p_p_function(sc, global_value(sc->iterate_symbol), iterate_p_p); + s7_set_p_p_function(sc, global_value(sc->list_symbol), list_p_p); + s7_set_p_pp_function(sc, global_value(sc->list_symbol), list_p_pp); + s7_set_p_ppp_function(sc, global_value(sc->list_symbol), list_p_ppp); + s7_set_p_pp_function(sc, global_value(sc->list_tail_symbol), + list_tail_p_pp); + s7_set_p_pp_function(sc, global_value(sc->make_list_symbol), + make_list_p_pp); + s7_set_p_pp_function(sc, global_value(sc->assq_symbol), assq_p_pp); + s7_set_p_pp_function(sc, global_value(sc->assv_symbol), assv_p_pp); + s7_set_p_pp_function(sc, global_value(sc->memq_symbol), memq_p_pp); + s7_set_p_pp_function(sc, global_value(sc->memv_symbol), memv_p_pp); + s7_set_p_p_function(sc, global_value(sc->tree_leaves_symbol), + tree_leaves_p_p); + s7_set_p_p_function(sc, global_value(sc->length_symbol), s7_length); + s7_set_p_p_function(sc, global_value(sc->pair_line_number_symbol), + pair_line_number_p_p); + s7_set_p_p_function(sc, global_value(sc->port_line_number_symbol), + port_line_number_p_p); + s7_set_p_p_function(sc, global_value(sc->port_filename_symbol), + port_filename_p_p); + s7_set_p_p_function(sc, global_value(sc->c_pointer_info_symbol), + c_pointer_info_p_p); + s7_set_p_p_function(sc, global_value(sc->c_pointer_type_symbol), + c_pointer_type_p_p); + s7_set_p_p_function(sc, global_value(sc->c_pointer_weak1_symbol), + c_pointer_weak1_p_p); + s7_set_p_p_function(sc, global_value(sc->c_pointer_weak2_symbol), + c_pointer_weak2_p_p); + s7_set_p_p_function(sc, global_value(sc->is_char_alphabetic_symbol), + is_char_alphabetic_p_p); + s7_set_p_p_function(sc, global_value(sc->is_char_whitespace_symbol), + is_char_whitespace_p_p); + s7_set_p_p_function(sc, global_value(sc->is_char_numeric_symbol), + is_char_numeric_p_p); + s7_set_p_p_function(sc, global_value(sc->char_upcase_symbol), + char_upcase_p_p); + s7_set_p_p_function(sc, global_value(sc->read_char_symbol), + read_char_p_p); + s7_set_p_i_function(sc, global_value(sc->make_string_symbol), + make_string_p_i); + s7_set_p_ii_function(sc, global_value(sc->make_int_vector_symbol), + make_int_vector_p_ii); + s7_set_p_ii_function(sc, global_value(sc->make_byte_vector_symbol), + make_byte_vector_p_ii); + s7_set_p_pp_function(sc, global_value(sc->vector_symbol), vector_p_pp); + s7_set_p_p_function(sc, global_value(sc->signature_symbol), + s7_signature); + s7_set_p_p_function(sc, global_value(sc->copy_symbol), copy_p_p); + s7_set_p_p_function(sc, global_value(sc->object_to_let_symbol), + object_to_let_p_p); + s7_set_p_p_function(sc, global_value(sc->outlet_symbol), outlet_p_p); + +#if WITH_SYSTEM_EXTRAS + s7_set_b_7p_function(sc, global_value(sc->is_directory_symbol), + is_directory_b_7p); + s7_set_b_7p_function(sc, global_value(sc->file_exists_symbol), + file_exists_b_7p); +#endif + + s7_set_b_i_function(sc, global_value(sc->is_even_symbol), is_even_i); + s7_set_b_i_function(sc, global_value(sc->is_odd_symbol), is_odd_i); + s7_set_b_i_function(sc, global_value(sc->is_zero_symbol), is_zero_i); + s7_set_b_d_function(sc, global_value(sc->is_zero_symbol), is_zero_d); + s7_set_p_p_function(sc, global_value(sc->is_zero_symbol), is_zero_p_p); + s7_set_p_p_function(sc, global_value(sc->is_positive_symbol), + is_positive_p_p); + s7_set_p_p_function(sc, global_value(sc->is_negative_symbol), + is_negative_p_p); + s7_set_p_p_function(sc, global_value(sc->real_part_symbol), + real_part_p_p); + s7_set_p_p_function(sc, global_value(sc->imag_part_symbol), + imag_part_p_p); + s7_set_b_i_function(sc, global_value(sc->is_positive_symbol), + is_positive_i); + s7_set_b_d_function(sc, global_value(sc->is_positive_symbol), + is_positive_d); + s7_set_b_i_function(sc, global_value(sc->is_negative_symbol), + is_negative_i); + s7_set_b_d_function(sc, global_value(sc->is_negative_symbol), + is_negative_d); + + s7_set_p_pi_function(sc, global_value(sc->lt_symbol), lt_p_pi); + s7_set_b_pi_function(sc, global_value(sc->lt_symbol), lt_b_pi); + s7_set_p_pi_function(sc, global_value(sc->leq_symbol), leq_p_pi); + s7_set_b_pi_function(sc, global_value(sc->leq_symbol), leq_b_pi); + s7_set_p_pi_function(sc, global_value(sc->gt_symbol), gt_p_pi); + s7_set_b_pi_function(sc, global_value(sc->gt_symbol), gt_b_pi); + s7_set_p_pi_function(sc, global_value(sc->geq_symbol), geq_p_pi); + s7_set_b_pi_function(sc, global_value(sc->geq_symbol), geq_b_pi); + /* no ip pd dp! */ + s7_set_b_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_b_pi); + s7_set_p_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_p_pi); + s7_set_p_pi_function(sc, global_value(sc->add_symbol), g_add_xi); + s7_set_p_pi_function(sc, global_value(sc->subtract_symbol), g_sub_xi); + s7_set_p_pi_function(sc, global_value(sc->multiply_symbol), g_mul_xi); + + s7_set_p_ii_function(sc, global_value(sc->num_eq_symbol), num_eq_p_ii); + s7_set_p_dd_function(sc, global_value(sc->num_eq_symbol), num_eq_p_dd); + s7_set_p_pp_function(sc, global_value(sc->num_eq_symbol), num_eq_p_pp); + s7_set_b_7pp_function(sc, global_value(sc->num_eq_symbol), + num_eq_b_7pp); + s7_set_b_ii_function(sc, global_value(sc->num_eq_symbol), num_eq_b_ii); + s7_set_b_dd_function(sc, global_value(sc->num_eq_symbol), num_eq_b_dd); + + s7_set_p_ii_function(sc, global_value(sc->lt_symbol), lt_p_ii); + s7_set_p_dd_function(sc, global_value(sc->lt_symbol), lt_p_dd); + s7_set_p_pp_function(sc, global_value(sc->lt_symbol), lt_p_pp); + s7_set_b_7pp_function(sc, global_value(sc->lt_symbol), lt_b_7pp); + s7_set_b_ii_function(sc, global_value(sc->lt_symbol), lt_b_ii); + s7_set_b_dd_function(sc, global_value(sc->lt_symbol), lt_b_dd); + + s7_set_b_ii_function(sc, global_value(sc->leq_symbol), leq_b_ii); + s7_set_p_dd_function(sc, global_value(sc->leq_symbol), leq_p_dd); + s7_set_p_ii_function(sc, global_value(sc->leq_symbol), leq_p_ii); + s7_set_b_dd_function(sc, global_value(sc->leq_symbol), leq_b_dd); + s7_set_p_pp_function(sc, global_value(sc->leq_symbol), leq_p_pp); + s7_set_b_7pp_function(sc, global_value(sc->leq_symbol), leq_b_7pp); + + s7_set_b_ii_function(sc, global_value(sc->gt_symbol), gt_b_ii); + s7_set_b_dd_function(sc, global_value(sc->gt_symbol), gt_b_dd); + s7_set_p_dd_function(sc, global_value(sc->gt_symbol), gt_p_dd); + s7_set_p_ii_function(sc, global_value(sc->gt_symbol), gt_p_ii); + s7_set_p_pp_function(sc, global_value(sc->gt_symbol), gt_p_pp); + s7_set_b_7pp_function(sc, global_value(sc->gt_symbol), gt_b_7pp); + + s7_set_b_ii_function(sc, global_value(sc->geq_symbol), geq_b_ii); + s7_set_b_dd_function(sc, global_value(sc->geq_symbol), geq_b_dd); + s7_set_p_ii_function(sc, global_value(sc->geq_symbol), geq_p_ii); + s7_set_p_dd_function(sc, global_value(sc->geq_symbol), geq_p_dd); + s7_set_p_pp_function(sc, global_value(sc->geq_symbol), geq_p_pp); + s7_set_b_7pp_function(sc, global_value(sc->geq_symbol), geq_b_7pp); + + s7_set_b_pp_function(sc, global_value(sc->is_eq_symbol), s7_is_eq); + s7_set_p_pp_function(sc, global_value(sc->is_eq_symbol), is_eq_p_pp); + s7_set_b_7pp_function(sc, global_value(sc->is_eqv_symbol), s7_is_eqv); + s7_set_p_pp_function(sc, global_value(sc->is_eqv_symbol), is_eqv_p_pp); + s7_set_b_7pp_function(sc, global_value(sc->is_equal_symbol), + s7_is_equal); + s7_set_b_7pp_function(sc, global_value(sc->is_equivalent_symbol), + s7_is_equivalent); + s7_set_p_pp_function(sc, global_value(sc->is_equal_symbol), + is_equal_p_pp); + s7_set_p_pp_function(sc, global_value(sc->is_equivalent_symbol), + is_equivalent_p_pp); + s7_set_p_pp_function(sc, global_value(sc->char_eq_symbol), + char_eq_p_pp); + + s7_set_b_7pp_function(sc, global_value(sc->char_lt_symbol), + char_lt_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->char_leq_symbol), + char_leq_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->char_gt_symbol), + char_gt_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->char_geq_symbol), + char_geq_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->char_eq_symbol), + char_eq_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->string_lt_symbol), + string_lt_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->string_leq_symbol), + string_leq_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->string_gt_symbol), + string_gt_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->string_geq_symbol), + string_geq_b_7pp); + s7_set_b_7pp_function(sc, global_value(sc->string_eq_symbol), + string_eq_b_7pp); + + s7_set_b_pp_unchecked_function(sc, global_value(sc->char_lt_symbol), + char_lt_b_unchecked); + s7_set_b_pp_unchecked_function(sc, global_value(sc->char_leq_symbol), + char_leq_b_unchecked); + s7_set_b_pp_unchecked_function(sc, global_value(sc->char_gt_symbol), + char_gt_b_unchecked); + s7_set_b_pp_unchecked_function(sc, global_value(sc->char_geq_symbol), + char_geq_b_unchecked); + s7_set_b_pp_unchecked_function(sc, global_value(sc->char_eq_symbol), + char_eq_b_unchecked); + s7_set_b_pp_unchecked_function(sc, global_value(sc->string_lt_symbol), + string_lt_b_unchecked); + s7_set_b_pp_unchecked_function(sc, global_value(sc->string_leq_symbol), + string_leq_b_unchecked); + s7_set_b_pp_unchecked_function(sc, global_value(sc->string_gt_symbol), + string_gt_b_unchecked); + s7_set_b_pp_unchecked_function(sc, global_value(sc->string_geq_symbol), + string_geq_b_unchecked); + s7_set_b_pp_unchecked_function(sc, global_value(sc->string_eq_symbol), + string_eq_b_unchecked); + + s7_set_b_7pp_function(sc, global_value(sc->is_aritable_symbol), + is_aritable_b_7pp); +} + +static void init_features(s7_scheme * sc) +{ + s7_provide(sc, "s7"); + s7_provide(sc, "s7-" S7_VERSION); + s7_provide(sc, "ratio"); + +#if WITH_PURE_S7 + s7_provide(sc, "pure-s7"); +#endif +#if WITH_EXTRA_EXPONENT_MARKERS + s7_provide(sc, "dfls-exponents"); +#endif +#if HAVE_OVERFLOW_CHECKS + s7_provide(sc, "overflow-checks"); +#endif +#if WITH_SYSTEM_EXTRAS + s7_provide(sc, "system-extras"); +#endif +#if WITH_IMMUTABLE_UNQUOTE + s7_provide(sc, "immutable-unquote"); +#endif +#if S7_DEBUGGING + s7_provide(sc, "debugging"); +#endif +#if HAVE_COMPLEX_NUMBERS + s7_provide(sc, "complex-numbers"); +#endif +#if WITH_HISTORY + s7_provide(sc, "history"); +#endif +#if WITH_C_LOADER + s7_provide(sc, "dlopen"); +#endif +#if (!DISABLE_AUTOLOAD) + s7_provide(sc, "autoload"); +#endif +#if S7_ALIGNED + s7_provide(sc, "aligned"); +#endif + +#ifdef __APPLE__ + s7_provide(sc, "osx"); +#endif +#ifdef __linux__ + s7_provide(sc, "linux"); +#endif +#ifdef __OpenBSD__ + s7_provide(sc, "openbsd"); +#endif +#ifdef __NetBSD__ + s7_provide(sc, "netbsd"); +#endif +#ifdef __FreeBSD__ + s7_provide(sc, "freebsd"); +#endif +#if MS_WINDOWS + s7_provide(sc, "windows"); +#endif +#ifdef __bfin__ + s7_provide(sc, "blackfin"); +#endif +#ifdef __ANDROID__ + s7_provide(sc, "android"); +#endif +#ifdef __MSYS__ + s7_provide(sc, "msys2"); +#endif +#ifdef __MINGW32__ /* this is also defined in mingw64 */ + s7_provide(sc, "mingw"); +#endif +#ifdef __CYGWIN__ + s7_provide(sc, "cygwin"); /* this is also defined in msys2 */ +#endif +#ifdef __hpux + s7_provide(sc, "hpux"); +#endif +#if defined(__sun) && defined(__SVR4) + s7_provide(sc, "solaris"); +#endif + +#if POINTER_32 + s7_provide(sc, "32-bit"); +#endif +#ifdef __SUNPRO_C + s7_provide(sc, "sunpro_c"); +#endif +#if (defined(__clang__)) + s7_provide(sc, "clang"); +#endif +#if (defined(__GNUC__)) + s7_provide(sc, "gcc"); +#endif +#ifdef __EMSCRIPTEN__ + s7_provide(sc, "emscripten"); +#endif +} + +static s7_pointer make_real_wrapper(s7_scheme * sc) +{ + s7_pointer p; + p = (s7_pointer) calloc(1, sizeof(s7_cell)); + add_saved_pointer(sc, p); + full_type(p) = T_REAL | T_UNHEAP | T_MUTABLE | T_IMMUTABLE; + return (p); +} + +static s7_pointer make_integer_wrapper(s7_scheme * sc) +{ + s7_pointer p; + p = (s7_pointer) calloc(1, sizeof(s7_cell)); + add_saved_pointer(sc, p); + full_type(p) = T_INTEGER | T_UNHEAP | T_MUTABLE | T_IMMUTABLE; /* mutable to turn off set_has_number_name */ + return (p); +} + +static void init_wrappers(s7_scheme * sc) +{ + int32_t i; + sc->integer_wrapper1 = make_integer_wrapper(sc); + sc->integer_wrapper2 = make_integer_wrapper(sc); + sc->integer_wrapper3 = make_integer_wrapper(sc); + sc->real_wrapper1 = make_real_wrapper(sc); + sc->real_wrapper2 = make_real_wrapper(sc); + sc->real_wrapper3 = make_real_wrapper(sc); + sc->real_wrapper4 = make_real_wrapper(sc); + + sc->string_wrappers = + (s7_pointer *) malloc(NUM_STRING_WRAPPERS * sizeof(s7_pointer)); + add_saved_pointer(sc, sc->string_wrappers); + sc->string_wrapper_pos = 0; + for (i = 0; i < NUM_STRING_WRAPPERS; i++) { + s7_pointer p; + p = (s7_pointer) calloc(1, sizeof(s7_cell)); + add_saved_pointer(sc, p); + sc->string_wrappers[i] = p; + full_type(p) = + T_STRING | T_IMMUTABLE | T_SAFE_PROCEDURE | T_UNHEAP; + string_block(p) = NULL; + string_value(p) = NULL; + string_length(p) = 0; + string_hash(p) = 0; + } +} + +static s7_pointer syntax(s7_scheme * sc, const char *name, opcode_t op, + s7_pointer min_args, s7_pointer max_args, + const char *doc) +{ + s7_pointer x, syn; + uint64_t hash; + uint32_t loc; + + hash = raw_string_hash((const uint8_t *) name, safe_strlen(name)); + loc = hash % SYMBOL_TABLE_SIZE; + x = new_symbol(sc, name, safe_strlen(name), hash, loc); + + syn = alloc_pointer(sc); + set_full_type(syn, + T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS | T_GLOBAL | + T_UNHEAP); + syntax_opcode(syn) = op; + syntax_set_symbol(syn, x); + syntax_min_args(syn) = integer(min_args); + syntax_max_args(syn) = + ((max_args == max_arity) ? -1 : integer(max_args)); + syntax_documentation(syn) = doc; + set_global_slot(x, make_permanent_slot(sc, x, syn)); + set_initial_slot(x, make_permanent_slot(sc, x, syn)); /* set_local_slot(x, global_slot(x)); */ + set_type_bit(x, T_SYMBOL | T_SYNTACTIC | T_GLOBAL | T_UNHEAP); + symbol_set_local_slot_unchecked(x, 0LL, sc->nil); + symbol_clear_ctr(x); + return (x); +} + +static s7_pointer definer_syntax(s7_scheme * sc, const char *name, + opcode_t op, s7_pointer min_args, + s7_pointer max_args, const char *doc) +{ + s7_pointer x; + x = syntax(sc, name, op, min_args, max_args, doc); + set_syntax_is_definer(x); + return (x); +} + +static s7_pointer binder_syntax(s7_scheme * sc, const char *name, + opcode_t op, s7_pointer min_args, + s7_pointer max_args, const char *doc) +{ + s7_pointer x; + x = syntax(sc, name, op, min_args, max_args, doc); + set_syntax_is_binder(x); + return (x); +} + +static s7_pointer copy_args_syntax(s7_scheme * sc, const char *name, + opcode_t op, s7_pointer min_args, + s7_pointer max_args, const char *doc) +{ + s7_pointer x, p; + x = syntax(sc, name, op, min_args, max_args, doc); + p = global_value(x); + full_type(p) |= T_COPY_ARGS; /* (for-each and ''2) -- maybe this is a mistake? (currently segfault if not copied) */ + return (x); +} + +static s7_pointer make_unique(s7_scheme * sc, const char *name, + uint64_t typ) +{ + s7_pointer p; + p = alloc_pointer(sc); + set_full_type(p, typ | T_IMMUTABLE | T_UNHEAP); + set_optimize_op(p, OP_CON); + if (typ == T_UNDEFINED) { /* sc->undefined here to avoid the undefined_constant_warning */ + undefined_set_name_length(p, safe_strlen(name)); + undefined_name(p) = + copy_string_with_length(name, undefined_name_length(p)); + } else { + unique_name_length(p) = safe_strlen(name); + unique_name(p) = + copy_string_with_length(name, unique_name_length(p)); + add_saved_pointer(sc, (void *) unique_name(p)); + } + return (p); +} + +static void init_setters(s7_scheme * sc) +{ + sc->vector_set_function = global_value(sc->vector_set_symbol); + set_is_setter(sc->vector_set_symbol); + /* not float-vector-set! here */ + + sc->list_set_function = global_value(sc->list_set_symbol); + set_is_setter(sc->list_set_symbol); + + sc->hash_table_set_function = global_value(sc->hash_table_set_symbol); + set_is_setter(sc->hash_table_set_symbol); + + sc->let_set_function = global_value(sc->let_set_symbol); + set_is_setter(sc->let_set_symbol); + + sc->string_set_function = global_value(sc->string_set_symbol); + set_is_setter(sc->string_set_symbol); + + set_is_setter(sc->byte_vector_set_symbol); + set_is_setter(sc->set_car_symbol); + set_is_setter(sc->set_cdr_symbol); + set_is_safe_setter(sc->byte_vector_set_symbol); + set_is_safe_setter(sc->int_vector_set_symbol); + set_is_safe_setter(sc->float_vector_set_symbol); + set_is_safe_setter(sc->string_set_symbol); + +#if (WITH_PURE_S7) + /* we need to be able at least to set (current-output-port) to #f */ + c_function_set_setter(global_value(sc->current_input_port_symbol), + s7_make_function(sc, "#", + g_set_current_input_port, 1, 0, + false, "*stdin* setter")); + c_function_set_setter(global_value(sc->current_output_port_symbol), + s7_make_function(sc, "#", + g_set_current_output_port, 1, 0, + false, "*stdout* setter")); +#else + set_is_setter(sc->set_current_input_port_symbol); + set_is_setter(sc->set_current_output_port_symbol); + s7_function_set_setter(sc, "current-input-port", + "set-current-input-port"); + s7_function_set_setter(sc, "current-output-port", + "set-current-output-port"); +#endif + + set_is_setter(sc->set_current_error_port_symbol); + s7_function_set_setter(sc, "current-error-port", + "set-current-error-port"); + /* despite the similar names, current-error-port is different from the other two, and a setter is needed + * in scheme because error and warn send output to it by default. It is not a "dynamic variable". + */ + + s7_function_set_setter(sc, "car", "set-car!"); + s7_function_set_setter(sc, "cdr", "set-cdr!"); + s7_function_set_setter(sc, "hash-table-ref", "hash-table-set!"); + s7_function_set_setter(sc, "vector-ref", "vector-set!"); + s7_function_set_setter(sc, "float-vector-ref", "float-vector-set!"); + s7_function_set_setter(sc, "int-vector-ref", "int-vector-set!"); + s7_function_set_setter(sc, "byte-vector-ref", "byte-vector-set!"); + s7_function_set_setter(sc, "list-ref", "list-set!"); + s7_function_set_setter(sc, "let-ref", "let-set!"); + s7_function_set_setter(sc, "string-ref", "string-set!"); + c_function_set_setter(global_value(sc->outlet_symbol), + s7_make_function(sc, "#", + g_set_outlet, 2, 0, false, + "outlet setter")); + c_function_set_setter(global_value(sc->port_line_number_symbol), + s7_make_function(sc, "#", + g_set_port_line_number, 1, 1, + false, "port line setter")); + c_function_set_setter(global_value(sc->port_position_symbol), + s7_make_function(sc, "#", + g_set_port_position, 2, 0, + false, "port position setter")); +} + +static void init_syntax(s7_scheme * sc) +{ +#define H_quote "(quote obj) returns obj unevaluated. 'obj is an abbreviation for (quote obj)." +#define H_if "(if expr true-stuff optional-false-stuff) evaluates expr, then if it is true, evaluates true-stuff; otherwise, \ + if optional-false-stuff exists, it is evaluated." +#define H_when "(when expr ...) evaluates expr, and if it is true, evaluates each form in its body, returning the value of the last" +#define H_unless "(unless expr ...) evaluates expr, and if it is false, evaluates each form in its body, returning the value of the last" +#define H_begin "(begin ...) evaluates each form in its body, returning the value of the last one" +#define H_set "(set! variable value) sets the value of variable to value." +#define H_let "(let ((var val)...) ...) binds each variable to its initial value, then evaluates its body,\ + returning the value of the last form. The let variables are local to it, and \ + are not available for use until all have been initialized." +#define H_let_star "(let* ((var val)...) ...) binds each variable to its initial value, then evaluates its body, \ + returning the value of the last form. The let* variables are local to it, and are available immediately." +#define H_letrec "(letrec ((var (lambda ...)))...) is like let, but var can refer to itself in its value \ + (i.e. you can define local recursive functions)" +#define H_letrec_star "(letrec* ((var val))...) is like letrec, but successive bindings are handled as in let*" +#define H_cond "(cond (expr clause...)...) is like if..then. Each expr is evaluated in order, and if one is not #f, \ + the associated clauses are evaluated, whereupon cond returns." +#define H_and "(and expr expr ...) evaluates each of its arguments in order, quitting (and returning #f) \ + as soon as one of them returns #f. If all are non-#f, it returns the last value." +#define H_or "(or expr expr ...) evaluates each of its arguments in order, quitting as soon as one of them is not #f. \ + If all are #f, or returns #f." +#define H_case "(case val ((key...) clause...)...) looks for val in the various lists of keys, and if a \ + match is found (via eqv?), the associated clauses are evaluated, and case returns." +#define H_do "(do (vars...) (loop control and return value) ...) is a do-loop." +#define H_lambda "(lambda args ...) returns a function." +#define H_lambda_star "(lambda* args ...) returns a function; the args list can have default values, \ + the parameters themselves can be accessed via keywords." +#define H_define "(define var val) assigns val to the variable (symbol) var. (define (func args) ...) is \ + shorthand for (define func (lambda args ...))" +#define H_define_star "(define* (func args) ...) defines a function with optional/keyword arguments." +#define H_define_constant "(define-constant var val) defines var to be a constant (it can't be set or bound), with the value val." +#define H_define_macro "(define-macro (mac args) ...) defines mac to be a macro." +#define H_define_macro_star "(define-macro* (mac args) ...) defines mac to be a macro with optional/keyword arguments." +#define H_macro "(macro args ...) defines an unnamed macro." +#define H_macro_star "(macro* args ...) defines an unnamed macro with optional/keyword arguments." +#define H_define_expansion "(define-expansion (mac args) ...) defines mac to be a read-time macro." +#define H_define_expansion_star "(define-expansion* (mac args) ...) defines mac to be a read-time macro*." +#define H_define_bacro "(define-bacro (mac args) ...) defines mac to be a bacro." +#define H_define_bacro_star "(define-bacro* (mac args) ...) defines mac to be a bacro with optional/keyword arguments." +#define H_bacro "(bacro args ...) defines an unnamed bacro." +#define H_bacro_star "(bacro* args ...) defines an unnamed bacro with optional/keyword arguments." +#define H_with_baffle "(with-baffle ...) evaluates its body in a context that blocks re-entry via call/cc." +#define H_macroexpand "(macroexpand macro-call) returns the result of the expansion phase of evaluating the macro call." +#define H_with_let "(with-let let ...) evaluates its body in the environment let." +#define H_let_temporarily "(let-temporarily ((var value)...) . body) sets each var to its new value, evals body, then returns each var to its original value." + + sc->quote_symbol = + syntax(sc, "quote", OP_QUOTE, int_one, int_one, H_quote); + sc->if_symbol = syntax(sc, "if", OP_IF, int_two, int_three, H_if); + sc->when_symbol = + syntax(sc, "when", OP_WHEN, int_two, max_arity, H_when); + sc->unless_symbol = + syntax(sc, "unless", OP_UNLESS, int_two, max_arity, H_unless); + sc->begin_symbol = syntax(sc, "begin", OP_BEGIN, int_zero, max_arity, H_begin); /* (begin) is () */ + sc->set_symbol = syntax(sc, "set!", OP_SET, int_two, int_two, H_set); + sc->cond_symbol = + copy_args_syntax(sc, "cond", OP_COND, int_one, max_arity, H_cond); + sc->and_symbol = + copy_args_syntax(sc, "and", OP_AND, int_zero, max_arity, H_and); + sc->or_symbol = + copy_args_syntax(sc, "or", OP_OR, int_zero, max_arity, H_or); + sc->case_symbol = + syntax(sc, "case", OP_CASE, int_two, max_arity, H_case); + sc->macroexpand_symbol = + syntax(sc, "macroexpand", OP_MACROEXPAND, int_one, int_one, + H_macroexpand); + sc->let_temporarily_symbol = + syntax(sc, "let-temporarily", OP_LET_TEMPORARILY, int_two, + max_arity, H_let_temporarily); + sc->define_symbol = + definer_syntax(sc, "define", OP_DEFINE, int_two, max_arity, + H_define); + sc->define_star_symbol = + definer_syntax(sc, "define*", OP_DEFINE_STAR, int_two, max_arity, + H_define_star); + sc->define_constant_symbol = + definer_syntax(sc, "define-constant", OP_DEFINE_CONSTANT, int_two, + max_arity, H_define_constant); + sc->define_macro_symbol = + definer_syntax(sc, "define-macro", OP_DEFINE_MACRO, int_two, + max_arity, H_define_macro); + sc->define_macro_star_symbol = + definer_syntax(sc, "define-macro*", OP_DEFINE_MACRO_STAR, int_two, + max_arity, H_define_macro_star); + sc->define_expansion_symbol = + definer_syntax(sc, "define-expansion", OP_DEFINE_EXPANSION, + int_two, max_arity, H_define_expansion); + sc->define_expansion_star_symbol = + definer_syntax(sc, "define-expansion*", OP_DEFINE_EXPANSION_STAR, + int_two, max_arity, H_define_expansion_star); + sc->define_bacro_symbol = + definer_syntax(sc, "define-bacro", OP_DEFINE_BACRO, int_two, + max_arity, H_define_bacro); + sc->define_bacro_star_symbol = + definer_syntax(sc, "define-bacro*", OP_DEFINE_BACRO_STAR, int_two, + max_arity, H_define_bacro_star); + sc->let_symbol = + binder_syntax(sc, "let", OP_LET, int_two, max_arity, H_let); + sc->let_star_symbol = + binder_syntax(sc, "let*", OP_LET_STAR, int_two, max_arity, + H_let_star); + sc->letrec_symbol = + binder_syntax(sc, "letrec", OP_LETREC, int_two, max_arity, + H_letrec); + sc->letrec_star_symbol = + binder_syntax(sc, "letrec*", OP_LETREC_STAR, int_two, max_arity, + H_letrec_star); + sc->do_symbol = binder_syntax(sc, "do", OP_DO, int_two, max_arity, H_do); /* 2 because body can be null */ + sc->lambda_symbol = + binder_syntax(sc, "lambda", OP_LAMBDA, int_two, max_arity, + H_lambda); + sc->lambda_star_symbol = + binder_syntax(sc, "lambda*", OP_LAMBDA_STAR, int_two, max_arity, + H_lambda_star); + sc->macro_symbol = + binder_syntax(sc, "macro", OP_MACRO, int_two, max_arity, H_macro); + sc->macro_star_symbol = + binder_syntax(sc, "macro*", OP_MACRO_STAR, int_two, max_arity, + H_macro_star); + sc->bacro_symbol = + binder_syntax(sc, "bacro", OP_BACRO, int_two, max_arity, H_bacro); + sc->bacro_star_symbol = + binder_syntax(sc, "bacro*", OP_BACRO_STAR, int_two, max_arity, + H_bacro_star); + sc->with_let_symbol = + binder_syntax(sc, "with-let", OP_WITH_LET, int_one, max_arity, + H_with_let); + sc->with_baffle_symbol = binder_syntax(sc, "with-baffle", OP_WITH_BAFFLE, int_zero, max_arity, H_with_baffle); /* (with-baffle) is () */ + set_local_slot(sc->with_let_symbol, global_slot(sc->with_let_symbol)); /* for set_locals */ + set_immutable(sc->with_let_symbol); + sc->setter_symbol = make_symbol(sc, "setter"); + +#if WITH_IMMUTABLE_UNQUOTE + /* this code solves the various unquote redefinition troubles + * if "," -> "(unquote...)" in the reader, (let (, (lambda (x) (+ x 1))) ,,,,'1) -> 5 + */ + sc->unquote_symbol = make_symbol(sc, ","); + set_immutable(sc->unquote_symbol); +#else + sc->unquote_symbol = make_symbol(sc, "unquote"); +#endif + + sc->feed_to_symbol = make_symbol(sc, "=>"); + sc->body_symbol = make_symbol(sc, "body"); + sc->read_error_symbol = make_symbol(sc, "read-error"); + sc->string_read_error_symbol = make_symbol(sc, "string-read-error"); + sc->syntax_error_symbol = make_symbol(sc, "syntax-error"); + sc->unbound_variable_symbol = make_symbol(sc, "unbound-variable"); + sc->wrong_type_arg_symbol = make_symbol(sc, "wrong-type-arg"); + sc->wrong_number_of_args_symbol = + make_symbol(sc, "wrong-number-of-args"); + sc->format_error_symbol = make_symbol(sc, "format-error"); + sc->autoload_error_symbol = make_symbol(sc, "autoload-error"); + sc->out_of_range_symbol = make_symbol(sc, "out-of-range"); + sc->out_of_memory_symbol = make_symbol(sc, "out-of-memory"); + sc->no_catch_symbol = make_symbol(sc, "no-catch"); + sc->io_error_symbol = make_symbol(sc, "io-error"); + sc->missing_method_symbol = make_symbol(sc, "missing-method"); + sc->invalid_escape_function_symbol = + make_symbol(sc, "invalid-escape-function"); + sc->immutable_error_symbol = make_symbol(sc, "immutable-error"); + sc->division_by_zero_symbol = make_symbol(sc, "division-by-zero"); + sc->bad_result_symbol = make_symbol(sc, "bad-result"); + + sc->baffled_symbol = make_symbol(sc, "baffled!"); + sc->value_symbol = make_symbol(sc, "value"); + sc->type_symbol = make_symbol(sc, "type"); + sc->position_symbol = make_symbol(sc, "position"); + sc->file_symbol = make_symbol(sc, "file"); + sc->line_symbol = make_symbol(sc, "line"); + sc->function_symbol = make_symbol(sc, "function"); + sc->else_symbol = make_symbol(sc, "else"); + s7_make_slot(sc, sc->nil, sc->else_symbol, sc->else_symbol); + slot_set_value(initial_slot(sc->else_symbol), sc->T); + /* if we set #_else to 'else, it can pick up a local else value: (let ((else #f)) (cond (#_else 2)...)) */ + sc->key_allow_other_keys_symbol = + s7_make_keyword(sc, "allow-other-keys"); + sc->key_rest_symbol = s7_make_keyword(sc, "rest"); + sc->key_if_symbol = s7_make_keyword(sc, "if"); /* internal optimizer local-let marker */ + sc->key_readable_symbol = s7_make_keyword(sc, "readable"); + sc->key_display_symbol = s7_make_keyword(sc, "display"); + sc->key_write_symbol = s7_make_keyword(sc, "write"); +} + +static void init_rootlet(s7_scheme * sc) +{ + s7_pointer sym; + init_syntax(sc); + + sc->owlet = init_owlet(sc); + + sc->wrong_type_arg_info = permanent_list(sc, 6); + set_car(sc->wrong_type_arg_info, + s7_make_permanent_string(sc, + "~A argument ~D, ~S, is ~A but should be ~A")); + + sc->simple_wrong_type_arg_info = permanent_list(sc, 5); + set_car(sc->simple_wrong_type_arg_info, + s7_make_permanent_string(sc, + "~A argument, ~S, is ~A but should be ~A")); + + sc->out_of_range_info = permanent_list(sc, 5); + set_car(sc->out_of_range_info, + s7_make_permanent_string(sc, + "~A argument ~D, ~S, is out of range (~A)")); + + sc->simple_out_of_range_info = permanent_list(sc, 4); + set_car(sc->simple_out_of_range_info, + s7_make_permanent_string(sc, + "~A argument, ~S, is out of range (~A)")); + + sc->gc_off = false; + +#define defun(Scheme_Name, C_Name, Req, Opt, Rst) \ + s7_define_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name) + +#define unsafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) \ + s7_define_unsafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name) + +#define semisafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) \ + s7_define_semisafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name) + +#define b_defun(Scheme_Name, C_Name, Opt, SymId, Marker, Simple) \ + define_bool_function(sc, Scheme_Name, g_ ## C_Name, Opt, H_ ## C_Name, Q_ ## C_Name, SymId, Marker, Simple, b_ ## C_Name ## _setter) + + /* we need the sc->is_* symbols first for the procedure signature lists */ + sc->is_boolean_symbol = make_symbol(sc, "boolean?"); + sc->pl_bt = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->T); + + sc->is_symbol_symbol = + b_defun("symbol?", is_symbol, 0, T_SYMBOL, mark_symbol_vector, + true); + sc->is_syntax_symbol = + b_defun("syntax?", is_syntax, 0, T_SYNTAX, just_mark_vector, true); + sc->is_gensym_symbol = + b_defun("gensym?", is_gensym, 0, T_FREE, mark_symbol_vector, true); + sc->is_keyword_symbol = + b_defun("keyword?", is_keyword, 0, T_FREE, just_mark_vector, true); + sc->is_let_symbol = + b_defun("let?", is_let, 0, T_LET, mark_vector_1, false); + sc->is_openlet_symbol = + b_defun("openlet?", is_openlet, 0, T_FREE, mark_vector_1, false); + sc->is_iterator_symbol = + b_defun("iterator?", is_iterator, 0, T_ITERATOR, mark_vector_1, + false); + sc->is_macro_symbol = + b_defun("macro?", is_macro, 0, T_FREE, mark_vector_1, false); + sc->is_c_pointer_symbol = + b_defun("c-pointer?", is_c_pointer, 1, T_C_POINTER, mark_vector_1, + false); + sc->is_input_port_symbol = + b_defun("input-port?", is_input_port, 0, T_INPUT_PORT, + mark_vector_1, true); + sc->is_output_port_symbol = + b_defun("output-port?", is_output_port, 0, T_OUTPUT_PORT, + mark_simple_vector, true); + sc->is_eof_object_symbol = + b_defun("eof-object?", is_eof_object, 0, T_EOF, just_mark_vector, + true); + sc->is_integer_symbol = + b_defun("integer?", is_integer, 0, (WITH_GMP) ? T_FREE : T_INTEGER, + mark_simple_vector, true); + sc->is_byte_symbol = + b_defun("byte?", is_byte, 0, T_FREE, mark_simple_vector, true); + sc->is_number_symbol = + b_defun("number?", is_number, 0, T_FREE, mark_simple_vector, true); + sc->is_real_symbol = + b_defun("real?", is_real, 0, T_FREE, mark_simple_vector, true); + sc->is_float_symbol = + b_defun("float?", is_float, 0, T_FREE, mark_simple_vector, true); + sc->is_complex_symbol = + b_defun("complex?", is_complex, 0, T_FREE, mark_simple_vector, + true); + sc->is_rational_symbol = + b_defun("rational?", is_rational, 0, T_FREE, mark_simple_vector, + true); + sc->is_random_state_symbol = + b_defun("random-state?", is_random_state, 0, T_RANDOM_STATE, + mark_simple_vector, true); + sc->is_char_symbol = + b_defun("char?", is_char, 0, T_CHARACTER, just_mark_vector, true); + sc->is_string_symbol = + b_defun("string?", is_string, 0, T_STRING, mark_simple_vector, + true); + sc->is_list_symbol = + b_defun("list?", is_list, 0, T_FREE, mark_vector_1, false); + sc->is_pair_symbol = + b_defun("pair?", is_pair, 0, T_PAIR, mark_vector_1, false); + sc->is_vector_symbol = + b_defun("vector?", is_vector, 0, T_FREE, mark_vector_1, false); + sc->is_float_vector_symbol = + b_defun("float-vector?", is_float_vector, 0, T_FLOAT_VECTOR, + mark_simple_vector, true); + sc->is_int_vector_symbol = + b_defun("int-vector?", is_int_vector, 0, T_INT_VECTOR, + mark_simple_vector, true); + sc->is_byte_vector_symbol = + b_defun("byte-vector?", is_byte_vector, 0, T_BYTE_VECTOR, + mark_simple_vector, true); + sc->is_hash_table_symbol = + b_defun("hash-table?", is_hash_table, 0, T_HASH_TABLE, + mark_vector_1, false); + sc->is_continuation_symbol = + b_defun("continuation?", is_continuation, 0, T_CONTINUATION, + mark_vector_1, false); + sc->is_procedure_symbol = + b_defun("procedure?", is_procedure, 0, T_FREE, mark_vector_1, + false); + sc->is_dilambda_symbol = + b_defun("dilambda?", is_dilambda, 0, T_FREE, mark_vector_1, false); + /* set above */ b_defun("boolean?", is_boolean, 0, T_BOOLEAN, + just_mark_vector, true); + sc->is_proper_list_symbol = + b_defun("proper-list?", is_proper_list, 0, T_FREE, mark_vector_1, + false); + sc->is_sequence_symbol = + b_defun("sequence?", is_sequence, 0, T_FREE, mark_vector_1, false); + sc->is_null_symbol = + b_defun("null?", is_null, 0, T_NIL, just_mark_vector, true); + sc->is_undefined_symbol = + b_defun("undefined?", is_undefined, 0, T_UNDEFINED, + just_mark_vector, true); + sc->is_unspecified_symbol = + b_defun("unspecified?", is_unspecified, 0, T_UNSPECIFIED, + just_mark_vector, true); + sc->is_c_object_symbol = + b_defun("c-object?", is_c_object, 0, T_C_OBJECT, mark_vector_1, + false); + sc->is_subvector_symbol = + b_defun("subvector?", is_subvector, 0, T_FREE, mark_vector_1, + false); + sc->is_weak_hash_table_symbol = + b_defun("weak-hash-table?", is_weak_hash_table, 0, T_FREE, + mark_vector_1, false); + sc->is_goto_symbol = + b_defun("goto?", is_goto, 0, T_GOTO, mark_vector_1, true); + + /* these are for signatures */ + sc->not_symbol = defun("not", not, 1, 0, false); + sc->is_integer_or_real_at_end_symbol = + make_symbol(sc, "integer:real?"); + sc->is_integer_or_any_at_end_symbol = make_symbol(sc, "integer:any?"); + + sc->pl_p = s7_make_signature(sc, 2, sc->T, sc->is_pair_symbol); + sc->pl_tl = s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol); /* memq and memv signature */ + sc->pl_bc = + s7_make_signature(sc, 2, sc->is_boolean_symbol, + sc->is_char_symbol); + sc->pl_bn = + s7_make_signature(sc, 2, sc->is_boolean_symbol, + sc->is_number_symbol); + sc->pl_nn = + s7_make_signature(sc, 2, sc->is_number_symbol, + sc->is_number_symbol); + sc->pl_sf = + s7_make_signature(sc, 3, sc->T, sc->is_string_symbol, + s7_make_signature(sc, 2, sc->is_procedure_symbol, + sc->is_macro_symbol)); + sc->pcl_bt = + s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->T); + sc->pcl_bc = + s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, + sc->is_char_symbol); + sc->pcl_bs = + s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, + sc->is_string_symbol); + sc->pcl_i = + s7_make_circular_signature(sc, 0, 1, sc->is_integer_symbol); + sc->pcl_r = s7_make_circular_signature(sc, 0, 1, sc->is_real_symbol); + sc->pcl_f = + s7_make_circular_signature(sc, 0, 1, sc->is_rational_symbol); + sc->pcl_n = s7_make_circular_signature(sc, 0, 1, sc->is_number_symbol); + sc->pcl_s = s7_make_circular_signature(sc, 0, 1, sc->is_string_symbol); + sc->pcl_v = s7_make_circular_signature(sc, 0, 1, sc->is_vector_symbol); + sc->pcl_c = s7_make_circular_signature(sc, 0, 1, sc->is_char_symbol); + sc->pcl_e = + s7_make_circular_signature(sc, 0, 1, + s7_make_signature(sc, 4, + sc->is_let_symbol, + sc->is_procedure_symbol, + sc->is_macro_symbol, + sc->is_c_object_symbol)); + + sc->values_symbol = make_symbol(sc, "values"); + + sc->is_bignum_symbol = defun("bignum?", is_bignum, 1, 0, false); + sc->bignum_symbol = defun("bignum", bignum, 1, 1, false); + + sc->gensym_symbol = defun("gensym", gensym, 0, 1, false); + sc->symbol_table_symbol = + defun("symbol-table", symbol_table, 0, 0, false); + sc->symbol_to_string_symbol = + defun("symbol->string", symbol_to_string, 1, 0, false); + sc->string_to_symbol_symbol = + defun("string->symbol", string_to_symbol, 1, 0, false); + sc->symbol_symbol = defun("symbol", symbol, 1, 0, true); + sc->symbol_to_value_symbol = + defun("symbol->value", symbol_to_value, 1, 1, false); + sc->symbol_to_dynamic_value_symbol = + defun("symbol->dynamic-value", symbol_to_dynamic_value, 1, 0, + false); + sc->immutable_symbol = defun("immutable!", immutable, 1, 0, false); + sc->is_immutable_symbol = + defun("immutable?", is_immutable, 1, 0, false); + sc->is_constant_symbol = defun("constant?", is_constant, 1, 0, false); + sc->string_to_keyword_symbol = + defun("string->keyword", string_to_keyword, 1, 0, false); + sc->symbol_to_keyword_symbol = + defun("symbol->keyword", symbol_to_keyword, 1, 0, false); + sc->keyword_to_symbol_symbol = + defun("keyword->symbol", keyword_to_symbol, 1, 0, false); + + sc->outlet_symbol = defun("outlet", outlet, 1, 0, false); + sc->rootlet_symbol = defun("rootlet", rootlet, 0, 0, false); + sc->curlet_symbol = defun("curlet", curlet, 0, 0, false); + set_func_is_definer(sc->curlet_symbol); + sc->unlet_symbol = defun("unlet", unlet, 0, 0, false); + set_local_slot(sc->unlet_symbol, global_slot(sc->unlet_symbol)); /* for set_locals */ + set_immutable(sc->unlet_symbol); + /* unlet (and with-let) don't actually need to be immutable, but s7.html says they are... */ + sc->is_funclet_symbol = defun("funclet?", is_funclet, 1, 0, false); + sc->sublet_symbol = defun("sublet", sublet, 1, 0, true); + sc->varlet_symbol = semisafe_defun("varlet", varlet, 1, 0, true); + set_func_is_definer(sc->varlet_symbol); + sc->cutlet_symbol = semisafe_defun("cutlet", cutlet, 1, 0, true); + set_func_is_definer(sc->cutlet_symbol); + sc->inlet_symbol = defun("inlet", inlet, 0, 0, true); + sc->owlet_symbol = defun("owlet", owlet, 0, 0, false); + sc->coverlet_symbol = defun("coverlet", coverlet, 1, 0, false); + sc->openlet_symbol = defun("openlet", openlet, 1, 0, false); + sc->let_ref_symbol = defun("let-ref", let_ref, 2, 0, false); + set_immutable(sc->let_ref_symbol); /* 16-Sep-19 */ + sc->let_set_symbol = defun("let-set!", let_set, 3, 0, false); + set_immutable(sc->let_set_symbol); + sc->let_ref_fallback_symbol = make_symbol(sc, "let-ref-fallback"); + sc->let_set_fallback_symbol = make_symbol(sc, "let-set-fallback"); /* was let-set!-fallback until 9-Oct-17 */ + + sc->make_iterator_symbol = + defun("make-iterator", make_iterator, 1, 1, false); + sc->iterate_symbol = defun("iterate", iterate, 1, 0, false); + sc->iterator_sequence_symbol = + defun("iterator-sequence", iterator_sequence, 1, 0, false); + sc->iterator_is_at_end_symbol = + defun("iterator-at-end?", iterator_is_at_end, 1, 0, false); + + sc->is_provided_symbol = defun("provided?", is_provided, 1, 0, false); + sc->provide_symbol = semisafe_defun("provide", provide, 1, 0, false); /* can add *features* to curlet */ + set_func_is_definer(sc->provide_symbol); + sc->is_defined_symbol = defun("defined?", is_defined, 1, 2, false); + + sc->c_object_type_symbol = + defun("c-object-type", c_object_type, 1, 0, false); + sc->c_pointer_symbol = defun("c-pointer", c_pointer, 1, 4, false); + sc->c_pointer_info_symbol = + defun("c-pointer-info", c_pointer_info, 1, 0, false); + sc->c_pointer_type_symbol = + defun("c-pointer-type", c_pointer_type, 1, 0, false); + sc->c_pointer_weak1_symbol = + defun("c-pointer-weak1", c_pointer_weak1, 1, 0, false); + sc->c_pointer_weak2_symbol = + defun("c-pointer-weak2", c_pointer_weak2, 1, 0, false); + sc->c_pointer_to_list_symbol = + defun("c-pointer->list", c_pointer_to_list, 1, 0, false); + + sc->port_file_symbol = defun("port-file", port_file, 1, 0, false); + sc->port_position_symbol = + defun("port-position", port_position, 1, 0, false); + sc->port_line_number_symbol = + defun("port-line-number", port_line_number, 0, 1, false); + sc->port_filename_symbol = + defun("port-filename", port_filename, 0, 1, false); + sc->pair_line_number_symbol = + defun("pair-line-number", pair_line_number, 1, 0, false); + sc->pair_filename_symbol = + defun("pair-filename", pair_filename, 1, 0, false); + sc->is_port_closed_symbol = + defun("port-closed?", is_port_closed, 1, 0, false); + + sc->current_input_port_symbol = + defun("current-input-port", current_input_port, 0, 0, false); + sc->current_output_port_symbol = + defun("current-output-port", current_output_port, 0, 0, false); + sc->current_error_port_symbol = + defun("current-error-port", current_error_port, 0, 0, false); + sc->set_current_error_port_symbol = + defun("set-current-error-port", set_current_error_port, 1, 0, + false); +#if (!WITH_PURE_S7) + sc->let_to_list_symbol = defun("let->list", let_to_list, 1, 0, false); + sc->set_current_input_port_symbol = + defun("set-current-input-port", set_current_input_port, 1, 0, + false); + sc->set_current_output_port_symbol = + defun("set-current-output-port", set_current_output_port, 1, 0, + false); + sc->is_char_ready_symbol = defun("char-ready?", is_char_ready, 0, 1, false); /* the least-used scheme function */ +#endif + + sc->close_input_port_symbol = + defun("close-input-port", close_input_port, 1, 0, false); + sc->close_output_port_symbol = + defun("close-output-port", close_output_port, 1, 0, false); + sc->flush_output_port_symbol = + defun("flush-output-port", flush_output_port, 0, 1, false); + sc->open_input_file_symbol = + defun("open-input-file", open_input_file, 1, 1, false); + sc->open_output_file_symbol = + defun("open-output-file", open_output_file, 1, 1, false); + sc->open_input_string_symbol = + defun("open-input-string", open_input_string, 1, 0, false); + sc->open_output_string_symbol = + defun("open-output-string", open_output_string, 0, 0, false); + sc->get_output_string_symbol = + defun("get-output-string", get_output_string, 1, 1, false); + sc->get_output_string_uncopied = + s7_make_function(sc, "get-output-string", + g_get_output_string_uncopied, 1, 1, false, NULL); + sc->open_input_function_symbol = + defun("open-input-function", open_input_function, 1, 0, false); + sc->open_output_function_symbol = + defun("open-output-function", open_output_function, 1, 0, false); + + sc->closed_input_function = + s7_make_function(sc, "closed-input-function", + g_closed_input_function_port, 2, 0, false, + "input-function error"), + sc->closed_output_function = + s7_make_function(sc, "closed-output-function", + g_closed_output_function_port, 1, 0, false, + "output-function error"), sc->newline_symbol = + defun("newline", newline, 0, 1, false); + sc->write_symbol = defun("write", write, 1, 1, false); + sc->display_symbol = defun("display", display, 1, 1, false); + sc->read_char_symbol = defun("read-char", read_char, 0, 1, false); + sc->peek_char_symbol = defun("peek-char", peek_char, 0, 1, false); + sc->write_char_symbol = defun("write-char", write_char, 1, 1, false); + sc->write_string_symbol = + defun("write-string", write_string, 1, 3, false); + sc->read_byte_symbol = defun("read-byte", read_byte, 0, 1, false); + sc->write_byte_symbol = defun("write-byte", write_byte, 1, 1, false); + sc->read_line_symbol = defun("read-line", read_line, 0, 2, false); + sc->read_string_symbol = + defun("read-string", read_string, 1, 1, false); + sc->read_symbol = semisafe_defun("read", read, 0, 1, false); + /* read can't be safe because it messes with the stack, expecting to be all by itself in the call sequence + * (not embedded in OP_SAFE_C_opSq for example) -- that is, it pushes OP_READ_INTERNAL, then returns + * expecting continue (goto top-of-eval-loop), which would be nonsense if arg=fn|x_proc(read) -> fn|x_proc(arg). + * a safe procedure leaves its argument list alone, does not push anything on the stack, + * and leaves sc->code|args unscathed (fx_call assumes that is the case). The stack part can + * be hidden: if a c_function calls s7_apply_function (lambda passed as arg as in some clm gens) + * then is called with args that use fx*, and the lambda func does the same, the two calls + * can step on each other. + */ + + sc->call_with_input_string_symbol = semisafe_defun("call-with-input-string", call_with_input_string, 2, 0, false); /* body unsafe if func=read */ + sc->call_with_input_file_symbol = + semisafe_defun("call-with-input-file", call_with_input_file, 2, 0, + false); + sc->with_input_from_string_symbol = + semisafe_defun("with-input-from-string", with_input_from_string, 2, + 0, false); + sc->with_input_from_file_symbol = + semisafe_defun("with-input-from-file", with_input_from_file, 2, 0, + false); + + sc->call_with_output_string_symbol = + semisafe_defun("call-with-output-string", call_with_output_string, + 1, 0, false); + sc->call_with_output_file_symbol = + semisafe_defun("call-with-output-file", call_with_output_file, 2, + 0, false); + sc->with_output_to_string_symbol = + semisafe_defun("with-output-to-string", with_output_to_string, 1, + 0, false); + sc->with_output_to_file_symbol = + semisafe_defun("with-output-to-file", with_output_to_file, 2, 0, + false); + +#if WITH_SYSTEM_EXTRAS + sc->is_directory_symbol = + defun("directory?", is_directory, 1, 0, false); + sc->file_exists_symbol = + defun("file-exists?", file_exists, 1, 0, false); + sc->delete_file_symbol = + defun("delete-file", delete_file, 1, 0, false); + sc->getenv_symbol = defun("getenv", getenv, 1, 0, false); + sc->system_symbol = defun("system", system, 1, 1, false); +#if (!MS_WINDOWS) + sc->directory_to_list_symbol = + defun("directory->list", directory_to_list, 1, 0, false); + sc->file_mtime_symbol = defun("file-mtime", file_mtime, 1, 0, false); +#endif +#endif + + sc->real_part_symbol = defun("real-part", real_part, 1, 0, false); + sc->imag_part_symbol = defun("imag-part", imag_part, 1, 0, false); + sc->numerator_symbol = defun("numerator", numerator, 1, 0, false); + sc->denominator_symbol = + defun("denominator", denominator, 1, 0, false); + sc->is_even_symbol = defun("even?", is_even, 1, 0, false); + sc->is_odd_symbol = defun("odd?", is_odd, 1, 0, false); + sc->is_zero_symbol = defun("zero?", is_zero, 1, 0, false); + sc->is_positive_symbol = defun("positive?", is_positive, 1, 0, false); + sc->is_negative_symbol = defun("negative?", is_negative, 1, 0, false); + sc->is_infinite_symbol = defun("infinite?", is_infinite, 1, 0, false); + sc->is_nan_symbol = defun("nan?", is_nan, 1, 0, false); + sc->complex_symbol = defun("complex", complex, 2, 0, false); + + sc->add_symbol = defun("+", add, 0, 0, true); + set_all_integer_and_float(sc->add_symbol); + sc->subtract_symbol = defun("-", subtract, 1, 0, true); + set_all_integer_and_float(sc->subtract_symbol); + sc->multiply_symbol = defun("*", multiply, 0, 0, true); + set_all_integer_and_float(sc->multiply_symbol); + sc->divide_symbol = defun("/", divide, 1, 0, true); + set_all_float(sc->divide_symbol); + sc->min_symbol = defun("min", min, 1, 0, true); + set_all_integer_and_float(sc->min_symbol); + sc->max_symbol = defun("max", max, 1, 0, true); + set_all_integer_and_float(sc->max_symbol); + + sc->quotient_symbol = defun("quotient", quotient, 2, 0, false); + set_all_integer(sc->quotient_symbol); + sc->remainder_symbol = defun("remainder", remainder, 2, 0, false); + set_all_integer(sc->remainder_symbol); + sc->modulo_symbol = defun("modulo", modulo, 2, 0, false); + set_all_integer(sc->modulo_symbol); + sc->num_eq_symbol = defun("=", num_eq, 2, 0, true); + sc->lt_symbol = defun("<", less, 2, 0, true); + sc->gt_symbol = defun(">", greater, 2, 0, true); + sc->leq_symbol = defun("<=", less_or_equal, 2, 0, true); + sc->geq_symbol = defun(">=", greater_or_equal, 2, 0, true); + sc->gcd_symbol = defun("gcd", gcd, 0, 0, true); + sc->lcm_symbol = defun("lcm", lcm, 0, 0, true); + sc->rationalize_symbol = + defun("rationalize", rationalize, 1, 1, false); + sc->random_symbol = defun("random", random, 1, 1, false); + set_all_integer_and_float(sc->random_symbol); + sc->random_state_symbol = + defun("random-state", random_state, 1, 1, false); + sc->expt_symbol = defun("expt", expt, 2, 0, false); + sc->log_symbol = defun("log", log, 1, 1, false); + sc->ash_symbol = defun("ash", ash, 2, 0, false); + sc->exp_symbol = defun("exp", exp, 1, 0, false); + set_all_float(sc->exp_symbol); + sc->abs_symbol = defun("abs", abs, 1, 0, false); + set_all_integer_and_float(sc->abs_symbol); + sc->magnitude_symbol = defun("magnitude", magnitude, 1, 0, false); + set_all_integer_and_float(sc->magnitude_symbol); + sc->angle_symbol = defun("angle", angle, 1, 0, false); + sc->sin_symbol = defun("sin", sin, 1, 0, false); + set_all_float(sc->sin_symbol); + sc->cos_symbol = defun("cos", cos, 1, 0, false); + set_all_float(sc->cos_symbol); + sc->tan_symbol = defun("tan", tan, 1, 0, false); + set_all_float(sc->tan_symbol); + sc->sinh_symbol = defun("sinh", sinh, 1, 0, false); + set_all_float(sc->sinh_symbol); + sc->cosh_symbol = defun("cosh", cosh, 1, 0, false); + set_all_float(sc->cosh_symbol); + sc->tanh_symbol = defun("tanh", tanh, 1, 0, false); + set_all_float(sc->tanh_symbol); + sc->asin_symbol = defun("asin", asin, 1, 0, false); + sc->acos_symbol = defun("acos", acos, 1, 0, false); + sc->atan_symbol = defun("atan", atan, 1, 1, false); + sc->asinh_symbol = defun("asinh", asinh, 1, 0, false); + sc->acosh_symbol = defun("acosh", acosh, 1, 0, false); + sc->atanh_symbol = defun("atanh", atanh, 1, 0, false); + sc->sqrt_symbol = defun("sqrt", sqrt, 1, 0, false); + sc->floor_symbol = defun("floor", floor, 1, 0, false); + sc->ceiling_symbol = defun("ceiling", ceiling, 1, 0, false); + sc->truncate_symbol = defun("truncate", truncate, 1, 0, false); + sc->round_symbol = defun("round", round, 1, 0, false); + sc->logand_symbol = defun("logand", logand, 0, 0, true); + sc->logior_symbol = defun("logior", logior, 0, 0, true); + sc->logxor_symbol = defun("logxor", logxor, 0, 0, true); + sc->lognot_symbol = defun("lognot", lognot, 1, 0, false); + sc->logbit_symbol = defun("logbit?", logbit, 2, 0, false); + sc->integer_decode_float_symbol = + defun("integer-decode-float", integer_decode_float, 1, 0, false); +#if (!WITH_PURE_S7) + sc->integer_length_symbol = + defun("integer-length", integer_length, 1, 0, false); + sc->inexact_to_exact_symbol = + defun("inexact->exact", inexact_to_exact, 1, 0, false); + sc->exact_to_inexact_symbol = + defun("exact->inexact", exact_to_inexact, 1, 0, false); + sc->is_exact_symbol = defun("exact?", is_exact, 1, 0, false); + sc->is_inexact_symbol = defun("inexact?", is_inexact, 1, 0, false); +#endif + sc->random_state_to_list_symbol = + defun("random-state->list", random_state_to_list, 0, 1, false); + sc->number_to_string_symbol = + defun("number->string", number_to_string, 1, 1, false); + sc->string_to_number_symbol = + defun("string->number", string_to_number, 1, 1, false); + + sc->char_upcase_symbol = + defun("char-upcase", char_upcase, 1, 0, false); + sc->char_downcase_symbol = + defun("char-downcase", char_downcase, 1, 0, false); + sc->char_to_integer_symbol = + defun("char->integer", char_to_integer, 1, 0, false); + sc->integer_to_char_symbol = + defun("integer->char", integer_to_char, 1, 0, false); + + sc->is_char_upper_case_symbol = + defun("char-upper-case?", is_char_upper_case, 1, 0, false); + sc->is_char_lower_case_symbol = + defun("char-lower-case?", is_char_lower_case, 1, 0, false); + sc->is_char_alphabetic_symbol = + defun("char-alphabetic?", is_char_alphabetic, 1, 0, false); + sc->is_char_numeric_symbol = + defun("char-numeric?", is_char_numeric, 1, 0, false); + sc->is_char_whitespace_symbol = + defun("char-whitespace?", is_char_whitespace, 1, 0, false); + + sc->char_eq_symbol = defun("char=?", chars_are_equal, 2, 0, true); + sc->char_lt_symbol = defun("charchar_gt_symbol = defun("char>?", chars_are_greater, 2, 0, true); + sc->char_leq_symbol = defun("char<=?", chars_are_leq, 2, 0, true); + sc->char_geq_symbol = defun("char>=?", chars_are_geq, 2, 0, true); + sc->char_position_symbol = + defun("char-position", char_position, 2, 1, false); + sc->string_position_symbol = + defun("string-position", string_position, 2, 1, false); + + sc->make_string_symbol = + defun("make-string", make_string, 1, 1, false); + sc->string_ref_symbol = defun("string-ref", string_ref, 2, 0, false); + sc->string_set_symbol = defun("string-set!", string_set, 3, 0, false); + + sc->string_eq_symbol = + defun("string=?", strings_are_equal, 2, 0, true); + sc->string_lt_symbol = defun("stringstring_gt_symbol = + defun("string>?", strings_are_greater, 2, 0, true); + sc->string_leq_symbol = + defun("string<=?", strings_are_leq, 2, 0, true); + sc->string_geq_symbol = + defun("string>=?", strings_are_geq, 2, 0, true); + +#if (!WITH_PURE_S7) + sc->char_ci_eq_symbol = + defun("char-ci=?", chars_are_ci_equal, 2, 0, true); + sc->char_ci_lt_symbol = + defun("char-cichar_ci_gt_symbol = + defun("char-ci>?", chars_are_ci_greater, 2, 0, true); + sc->char_ci_leq_symbol = + defun("char-ci<=?", chars_are_ci_leq, 2, 0, true); + sc->char_ci_geq_symbol = + defun("char-ci>=?", chars_are_ci_geq, 2, 0, true); + sc->string_ci_eq_symbol = + defun("string-ci=?", strings_are_ci_equal, 2, 0, true); + sc->string_ci_lt_symbol = + defun("string-cistring_ci_gt_symbol = + defun("string-ci>?", strings_are_ci_greater, 2, 0, true); + sc->string_ci_leq_symbol = + defun("string-ci<=?", strings_are_ci_leq, 2, 0, true); + sc->string_ci_geq_symbol = + defun("string-ci>=?", strings_are_ci_geq, 2, 0, true); + sc->string_fill_symbol = + defun("string-fill!", string_fill, 2, 2, false); + sc->list_to_string_symbol = + defun("list->string", list_to_string, 1, 0, false); + sc->string_length_symbol = + defun("string-length", string_length, 1, 0, false); + sc->string_to_list_symbol = + defun("string->list", string_to_list, 1, 2, false); +#endif + sc->string_copy_symbol = + defun("string-copy", string_copy, 1, 3, false); + + sc->string_downcase_symbol = + defun("string-downcase", string_downcase, 1, 0, false); + sc->string_upcase_symbol = + defun("string-upcase", string_upcase, 1, 0, false); + sc->string_append_symbol = + defun("string-append", string_append, 0, 0, true); + sc->substring_symbol = defun("substring", substring, 2, 1, false); + sc->string_symbol = defun("string", string, 0, 0, true); + sc->object_to_string_symbol = + defun("object->string", object_to_string, 1, 2, false); + sc->format_symbol = defun("format", format, 2, 0, true); + sc->object_to_let_symbol = + defun("object->let", object_to_let, 1, 0, false); + + sc->cons_symbol = defun("cons", cons, 2, 0, false); + sc->car_symbol = defun("car", car, 1, 0, false); + sc->cdr_symbol = defun("cdr", cdr, 1, 0, false); + sc->set_car_symbol = defun("set-car!", set_car, 2, 0, false); + sc->set_cdr_symbol = defun("set-cdr!", set_cdr, 2, 0, false); + sc->caar_symbol = defun("caar", caar, 1, 0, false); + sc->cadr_symbol = defun("cadr", cadr, 1, 0, false); + sc->cdar_symbol = defun("cdar", cdar, 1, 0, false); + sc->cddr_symbol = defun("cddr", cddr, 1, 0, false); + sc->caaar_symbol = defun("caaar", caaar, 1, 0, false); + sc->caadr_symbol = defun("caadr", caadr, 1, 0, false); + sc->cadar_symbol = defun("cadar", cadar, 1, 0, false); + sc->cdaar_symbol = defun("cdaar", cdaar, 1, 0, false); + sc->caddr_symbol = defun("caddr", caddr, 1, 0, false); + sc->cdddr_symbol = defun("cdddr", cdddr, 1, 0, false); + sc->cdadr_symbol = defun("cdadr", cdadr, 1, 0, false); + sc->cddar_symbol = defun("cddar", cddar, 1, 0, false); + sc->caaaar_symbol = defun("caaaar", caaaar, 1, 0, false); + sc->caaadr_symbol = defun("caaadr", caaadr, 1, 0, false); + sc->caadar_symbol = defun("caadar", caadar, 1, 0, false); + sc->cadaar_symbol = defun("cadaar", cadaar, 1, 0, false); + sc->caaddr_symbol = defun("caaddr", caaddr, 1, 0, false); + sc->cadddr_symbol = defun("cadddr", cadddr, 1, 0, false); + sc->cadadr_symbol = defun("cadadr", cadadr, 1, 0, false); + sc->caddar_symbol = defun("caddar", caddar, 1, 0, false); + sc->cdaaar_symbol = defun("cdaaar", cdaaar, 1, 0, false); + sc->cdaadr_symbol = defun("cdaadr", cdaadr, 1, 0, false); + sc->cdadar_symbol = defun("cdadar", cdadar, 1, 0, false); + sc->cddaar_symbol = defun("cddaar", cddaar, 1, 0, false); + sc->cdaddr_symbol = defun("cdaddr", cdaddr, 1, 0, false); + sc->cddddr_symbol = defun("cddddr", cddddr, 1, 0, false); + sc->cddadr_symbol = defun("cddadr", cddadr, 1, 0, false); + sc->cdddar_symbol = defun("cdddar", cdddar, 1, 0, false); + + sc->assq_symbol = defun("assq", assq, 2, 0, false); + sc->assv_symbol = defun("assv", assv, 2, 0, false); + sc->assoc_symbol = semisafe_defun("assoc", assoc, 2, 1, false); + sc->memq_symbol = defun("memq", memq, 2, 0, false); + sc->memv_symbol = defun("memv", memv, 2, 0, false); + sc->member_symbol = semisafe_defun("member", member, 2, 1, false); + + sc->list_symbol = defun("list", list, 0, 0, true); + sc->list_ref_symbol = defun("list-ref", list_ref, 2, 0, true); + sc->list_set_symbol = defun("list-set!", list_set, 3, 0, true); + sc->list_tail_symbol = defun("list-tail", list_tail, 2, 0, false); + sc->make_list_symbol = defun("make-list", make_list, 1, 1, false); + + sc->length_symbol = defun("length", length, 1, 0, false); + sc->copy_symbol = defun("copy", copy, 1, 3, false); + /* set_is_definer(sc->copy_symbol); *//* (copy (inlet 'a 1) (curlet)), but this check needs to be smarter */ + sc->fill_symbol = defun("fill!", fill, 2, 2, false); + sc->reverse_symbol = defun("reverse", reverse, 1, 0, false); + sc->reverseb_symbol = defun("reverse!", reverse_in_place, 1, 0, false); + sc->sort_symbol = unsafe_defun("sort!", sort, 2, 0, false); /* not semisafe! */ + sc->append_symbol = defun("append", append, 0, 0, true); + +#if (!WITH_PURE_S7) + sc->vector_append_symbol = + defun("vector-append", vector_append, 0, 0, true); + sc->list_to_vector_symbol = + defun("list->vector", list_to_vector, 1, 0, false); + sc->vector_fill_symbol = + defun("vector-fill!", vector_fill, 2, 2, false); + sc->vector_length_symbol = + defun("vector-length", vector_length, 1, 0, false); + sc->vector_to_list_symbol = + defun("vector->list", vector_to_list, 1, 2, false); +#else + sc->vector_append_symbol = sc->append_symbol; + sc->vector_fill_symbol = sc->fill_symbol; + sc->string_fill_symbol = sc->fill_symbol; +#endif + sc->vector_ref_symbol = defun("vector-ref", vector_ref, 2, 0, true); + sc->vector_set_symbol = defun("vector-set!", vector_set, 3, 0, true); + sc->vector_dimension_symbol = + defun("vector-dimension", vector_dimension, 2, 0, false); + sc->vector_dimensions_symbol = + defun("vector-dimensions", vector_dimensions, 1, 0, false); + sc->vector_rank_symbol = + defun("vector-rank", vector_rank, 1, 0, false); + sc->make_vector_symbol = + defun("make-vector", make_vector, 1, 2, false); + sc->vector_symbol = defun("vector", vector, 0, 0, true); + set_is_setter(sc->vector_symbol); /* like cons, I guess */ + + sc->subvector_symbol = defun("subvector", subvector, 1, 3, false); + sc->subvector_position_symbol = + defun("subvector-position", subvector_position, 1, 0, false); + sc->subvector_vector_symbol = + defun("subvector-vector", subvector_vector, 1, 0, false); + + sc->float_vector_symbol = + defun("float-vector", float_vector, 0, 0, true); + sc->make_float_vector_symbol = + defun("make-float-vector", make_float_vector, 1, 1, false); + sc->float_vector_set_symbol = + defun("float-vector-set!", float_vector_set, 3, 0, true); + sc->float_vector_ref_symbol = + defun("float-vector-ref", float_vector_ref, 2, 0, true); + + sc->int_vector_symbol = defun("int-vector", int_vector, 0, 0, true); + sc->make_int_vector_symbol = + defun("make-int-vector", make_int_vector, 1, 1, false); + sc->int_vector_set_symbol = + defun("int-vector-set!", int_vector_set, 3, 0, true); + sc->int_vector_ref_symbol = + defun("int-vector-ref", int_vector_ref, 2, 0, true); + + sc->byte_vector_symbol = defun("byte-vector", byte_vector, 0, 0, true); + sc->make_byte_vector_symbol = + defun("make-byte-vector", make_byte_vector, 1, 1, false); + sc->byte_vector_ref_symbol = + defun("byte-vector-ref", byte_vector_ref, 2, 0, true); + sc->byte_vector_set_symbol = + defun("byte-vector-set!", byte_vector_set, 3, 0, true); + sc->string_to_byte_vector_symbol = + defun("string->byte-vector", string_to_byte_vector, 1, 0, false); + sc->byte_vector_to_string_symbol = + defun("byte-vector->string", byte_vector_to_string, 1, 0, false); + + sc->hash_table_symbol = defun("hash-table", hash_table, 0, 0, true); + sc->make_hash_table_symbol = + defun("make-hash-table", make_hash_table, 0, 3, false); + sc->make_weak_hash_table_symbol = + defun("make-weak-hash-table", make_weak_hash_table, 0, 3, false); + sc->weak_hash_table_symbol = + defun("weak-hash-table", weak_hash_table, 0, 0, true); + sc->hash_table_ref_symbol = + defun("hash-table-ref", hash_table_ref, 2, 0, true); + sc->hash_table_set_symbol = + defun("hash-table-set!", hash_table_set, 3, 0, false); + sc->hash_table_entries_symbol = + defun("hash-table-entries", hash_table_entries, 1, 0, false); + sc->hash_code_symbol = defun("hash-code", hash_code, 1, 1, false); + sc->dummy_equal_hash_table = make_dummy_hash_table(sc); + + sc->cyclic_sequences_symbol = + defun("cyclic-sequences", cyclic_sequences, 1, 0, false); + sc->call_cc_symbol = semisafe_defun("call/cc", call_cc, 1, 0, false); /* was unsafe 8-Feb-21 */ + sc->call_with_current_continuation_symbol = + unsafe_defun("call-with-current-continuation", call_cc, 1, 0, + false); + sc->call_with_exit_symbol = semisafe_defun("call-with-exit", call_with_exit, 1, 0, false); /* was unsafe 8-Feb-21 */ + + sc->load_symbol = semisafe_defun("load", load, 1, 1, false); + sc->autoload_symbol = defun("autoload", autoload, 2, 0, false); + sc->eval_symbol = semisafe_defun("eval", eval, 1, 1, false); /* was unsafe 8-Feb-21, can affect stack */ + set_func_is_definer(sc->eval_symbol); + sc->eval_string_symbol = + semisafe_defun("eval-string", eval_string, 1, 1, false); + set_func_is_definer(sc->eval_string_symbol); + sc->apply_symbol = unsafe_defun("apply", apply, 1, 0, true); /* not semisafe (note that type is reset below) */ + set_func_is_definer(sc->apply_symbol); + /* yow... (apply (inlet) (f)) in do body where (f) returns '(define...) -- see s7test.scm under apply + * perhaps better: if closure returns a definer in some way set its name as a definer? even this is not fool-proof + */ + + sc->for_each_symbol = semisafe_defun("for-each", for_each, 2, 0, true); + sc->map_symbol = semisafe_defun("map", map, 2, 0, true); + sc->dynamic_wind_symbol = + semisafe_defun("dynamic-wind", dynamic_wind, 3, 0, false); + sc->dynamic_unwind_symbol = + semisafe_defun("dynamic-unwind", dynamic_unwind, 2, 0, false); + sc->catch_symbol = semisafe_defun("catch", catch, 3, 0, false); + sc->throw_symbol = unsafe_defun("throw", throw, 1, 0, true); + sc->error_symbol = unsafe_defun("error", error, 0, 0, true); + /* not safe in catch if macro as error handler, (define-macro (m . args) `(apply ,(car args) ',(cadr args))) (catch #t (lambda () (error abs -1)) m) */ + sc->stacktrace_symbol = defun("stacktrace", stacktrace, 0, 5, false); + + /* sc->values_symbol = */ unsafe_defun("values", values, 0, 0, true); + /* values_symbol set above for signatures, not semisafe! */ + sc->apply_values_symbol = + unsafe_defun("apply-values", apply_values, 0, 1, false); + set_immutable(sc->apply_values_symbol); + sc->list_values_symbol = defun("list-values", list_values, 0, 0, true); + set_immutable(sc->list_values_symbol); + + sc->documentation_symbol = + defun("documentation", documentation, 1, 0, false); + sc->signature_symbol = defun("signature", signature, 1, 0, false); + sc->help_symbol = defun("help", help, 1, 0, false); + sc->procedure_source_symbol = + defun("procedure-source", procedure_source, 1, 0, false); + sc->funclet_symbol = defun("funclet", funclet, 1, 0, false); + sc->_function__symbol = defun("*function*", function, 0, 2, false); + sc->dilambda_symbol = defun("dilambda", dilambda, 2, 0, false); + s7_typed_dilambda(sc, "setter", g_setter, 1, 1, g_set_setter, 2, 1, + H_setter, Q_setter, NULL); + sc->arity_symbol = defun("arity", arity, 1, 0, false); + sc->is_aritable_symbol = defun("aritable?", is_aritable, 2, 0, false); + + sc->is_eq_symbol = defun("eq?", is_eq, 2, 0, false); + sc->is_eqv_symbol = defun("eqv?", is_eqv, 2, 0, false); + sc->is_equal_symbol = defun("equal?", is_equal, 2, 0, false); + sc->is_equivalent_symbol = + defun("equivalent?", is_equivalent, 2, 0, false); + sc->type_of_symbol = defun("type-of", type_of, 1, 0, false); + + sc->gc_symbol = semisafe_defun("gc", gc, 0, 1, false); + defun("emergency-exit", emergency_exit, 0, 1, false); + sc->exit_symbol = defun("exit", exit, 0, 1, false); + +#if WITH_GCC + s7_define_function(sc, "abort", g_abort, 0, 0, true, + "drop into gdb I hope"); +#endif + s7_define_function(sc, "s7-optimize", g_optimize, 1, 0, false, + "short-term debugging aid"); + sc->c_object_set_function = + s7_make_function(sc, "#", g_c_object_set, 1, 0, + true, "c-object setter"); + /* c_function_signature(sc->c_object_set_function) = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_c_object_symbol, sc->T); */ + + set_scope_safe(global_value(sc->call_with_input_string_symbol)); + set_scope_safe(global_value(sc->call_with_input_file_symbol)); + set_scope_safe(global_value(sc->call_with_output_string_symbol)); + set_scope_safe(global_value(sc->call_with_output_file_symbol)); + set_scope_safe(global_value(sc->with_input_from_string_symbol)); + set_scope_safe(global_value(sc->with_input_from_file_symbol)); + set_scope_safe(global_value(sc->with_output_to_string_symbol)); + set_scope_safe(global_value(sc->with_output_to_file_symbol)); + set_maybe_safe(global_value(sc->assoc_symbol)); + set_scope_safe(global_value(sc->assoc_symbol)); + set_maybe_safe(global_value(sc->member_symbol)); + set_scope_safe(global_value(sc->member_symbol)); + set_scope_safe(global_value(sc->sort_symbol)); + set_scope_safe(global_value(sc->call_with_exit_symbol)); + set_scope_safe(global_value(sc->for_each_symbol)); + set_maybe_safe(global_value(sc->for_each_symbol)); + set_scope_safe(global_value(sc->map_symbol)); + set_maybe_safe(global_value(sc->map_symbol)); + set_scope_safe(global_value(sc->dynamic_wind_symbol)); + set_scope_safe(global_value(sc->catch_symbol)); + set_scope_safe(global_value(sc->throw_symbol)); + set_scope_safe(global_value(sc->error_symbol)); + set_scope_safe(global_value(sc->apply_values_symbol)); + + sc->tree_leaves_symbol = + defun("tree-leaves", tree_leaves, 1, 0, false); + sc->tree_memq_symbol = defun("tree-memq", tree_memq, 2, 0, false); + sc->tree_set_memq_symbol = + defun("tree-set-memq", tree_set_memq, 2, 0, false); + sc->tree_count_symbol = defun("tree-count", tree_count, 2, 1, false); + sc->tree_is_cyclic_symbol = + defun("tree-cyclic?", tree_is_cyclic, 1, 0, false); + + sc->quasiquote_symbol = + s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, + H_quasiquote); + + sc->profile_in_symbol = unsafe_defun("profile-in", profile_in, 1, 0, false); /* calls dynamic-unwind */ + sc->profile_out = NULL; + + /* -------- *features* -------- */ + sc->features_symbol = + s7_define_variable_with_documentation(sc, "*features*", sc->nil, + "list of currently available features ('complex-numbers, etc)"); + s7_set_setter(sc, sc->features_symbol, + s7_make_function(sc, "#", g_features_set, + 2, 0, false, "*features* setter")); + + /* -------- *load-path* -------- */ + sc->load_path_symbol = s7_define_variable_with_documentation(sc, "*load-path*", list_1(sc, s7_make_string(sc, ".")), /* not plist! */ + "*load-path* is a list of directories (strings) that the load function searches if it is passed an incomplete file name"); + s7_set_setter(sc, sc->load_path_symbol, + s7_make_function(sc, "#", + g_load_path_set, 2, 0, false, + "*load-path* setter")); + +#ifdef CLOAD_DIR + sc->cload_directory_symbol = + s7_define_variable(sc, "*cload-directory*", + s7_make_string(sc, (char *) CLOAD_DIR)); + s7_add_to_load_path(sc, (const char *) CLOAD_DIR); +#else + sc->cload_directory_symbol = + s7_define_variable(sc, "*cload-directory*", nil_string); +#endif + s7_set_setter(sc, sc->cload_directory_symbol, + s7_make_function(sc, "#", + g_cload_directory_set, 2, 0, false, + "*cload-directory* setter")); + + /* -------- *autoload* -------- this pretends to be a hash-table or environment, but it's actually a function */ + sc->autoloader_symbol = + s7_define_typed_function(sc, "*autoload*", g_autoloader, 1, 0, + false, H_autoloader, Q_autoloader); + c_function_set_setter(global_value(sc->autoloader_symbol), global_value(sc->autoload_symbol)); /* (set! (*autoload* x) y) */ + + sc->libraries_symbol = + s7_define_variable_with_documentation(sc, "*libraries*", sc->nil, + "list of currently loaded libraries (libc.scm, etc)"); + s7_set_setter(sc, sc->libraries_symbol, + s7_make_function(sc, "#", + g_libraries_set, 2, 0, false, + "*libraries* setter")); + + s7_autoload(sc, make_symbol(sc, "cload.scm"), + s7_make_permanent_string(sc, "cload.scm")); + s7_autoload(sc, make_symbol(sc, "lint.scm"), + s7_make_permanent_string(sc, "lint.scm")); + s7_autoload(sc, make_symbol(sc, "stuff.scm"), + s7_make_permanent_string(sc, "stuff.scm")); + s7_autoload(sc, make_symbol(sc, "mockery.scm"), + s7_make_permanent_string(sc, "mockery.scm")); + s7_autoload(sc, make_symbol(sc, "write.scm"), + s7_make_permanent_string(sc, "write.scm")); + s7_autoload(sc, make_symbol(sc, "reactive.scm"), + s7_make_permanent_string(sc, "reactive.scm")); + s7_autoload(sc, make_symbol(sc, "repl.scm"), + s7_make_permanent_string(sc, "repl.scm")); + s7_autoload(sc, make_symbol(sc, "r7rs.scm"), + s7_make_permanent_string(sc, "r7rs.scm")); + s7_autoload(sc, make_symbol(sc, "profile.scm"), + s7_make_permanent_string(sc, "profile.scm")); + s7_autoload(sc, make_symbol(sc, "debug.scm"), + s7_make_permanent_string(sc, "debug.scm")); + s7_autoload(sc, make_symbol(sc, "case.scm"), + s7_make_permanent_string(sc, "case.scm")); + + s7_autoload(sc, make_symbol(sc, "libc.scm"), + s7_make_permanent_string(sc, "libc.scm")); + s7_autoload(sc, make_symbol(sc, "libm.scm"), s7_make_permanent_string(sc, "libm.scm")); /* repl.scm adds *libm* */ + s7_autoload(sc, make_symbol(sc, "libdl.scm"), + s7_make_permanent_string(sc, "libdl.scm")); + s7_autoload(sc, make_symbol(sc, "libgsl.scm"), s7_make_permanent_string(sc, "libgsl.scm")); /* repl.scm adds *libgsl* */ + s7_autoload(sc, make_symbol(sc, "libgdbm.scm"), + s7_make_permanent_string(sc, "libgdbm.scm")); + s7_autoload(sc, make_symbol(sc, "libutf8proc.scm"), + s7_make_permanent_string(sc, "libutf8proc.scm")); + + sc->require_symbol = + s7_define_macro(sc, "require", g_require, 1, 0, true, H_require); + sc->stacktrace_defaults = s7_list(sc, 5, int_three, small_int(45), small_int(80), small_int(45), sc->T); /* assume NUM_SMALL_INTS >= NUM_CHARS == 256 */ + + /* -------- *#readers* -------- */ + sym = + s7_define_variable_with_documentation(sc, "*#readers*", sc->nil, + "list of current reader macros"); + sc->sharp_readers = global_slot(sym); + s7_set_setter(sc, sym, + s7_make_function(sc, "#", + g_sharp_readers_set, 2, 0, false, + "*#readers* setter")); + + sc->local_documentation_symbol = make_symbol(sc, "+documentation+"); + sc->local_signature_symbol = make_symbol(sc, "+signature+"); + sc->local_setter_symbol = make_symbol(sc, "+setter+"); + sc->local_iterator_symbol = make_symbol(sc, "+iterator+"); + + init_features(sc); + init_setters(sc); +} + +#if (!MS_WINDOWS) +static pthread_mutex_t init_lock = PTHREAD_MUTEX_INITIALIZER; +#endif + +s7_scheme *s7_init(void) +{ + int32_t i; + s7_scheme *sc; + static bool already_inited = false; + +#if (!MS_WINDOWS) + setlocale(LC_NUMERIC, "C"); /* use decimal point in floats */ + pthread_mutex_lock(&init_lock); +#endif + + if (!already_inited) { + init_types(); + init_ctables(); + init_mark_functions(); + init_display_functions(); + init_length_functions(); + init_equals(); + init_hash_maps(); + init_pows(); + init_int_limits(); + init_small_ints(); + init_uppers(); + init_chars(); + init_strings(); + init_fx_function(); + init_catchers(); + already_inited = true; + } + +#if (!MS_WINDOWS) + pthread_mutex_unlock(&init_lock); +#endif + sc = (s7_scheme *) calloc(1, sizeof(s7_scheme)); /* not malloc! */ + cur_sc = sc; /* for gdb/debugging */ + sc->gc_off = true; /* sc->args and so on are not set yet, so a gc during init -> segfault */ + sc->gc_stats = 0; + + sc->saved_pointers = + (void **) malloc(INITIAL_SAVED_POINTERS_SIZE * sizeof(void *)); + sc->saved_pointers_loc = 0; + sc->saved_pointers_size = INITIAL_SAVED_POINTERS_SIZE; + + init_gc_caches(sc); + sc->permanent_cells = 0; + sc->alloc_pointer_k = ALLOC_POINTER_SIZE; + sc->alloc_pointer_cells = NULL; + sc->alloc_big_pointer_k = ALLOC_BIG_POINTER_SIZE; + sc->alloc_big_pointer_cells = NULL; + sc->alloc_function_k = ALLOC_FUNCTION_SIZE; + sc->alloc_function_cells = NULL; + sc->alloc_symbol_k = ALLOC_SYMBOL_SIZE; + sc->alloc_symbol_cells = NULL; + sc->num_to_str_size = -1; + sc->num_to_str = NULL; + init_block_lists(sc); + sc->alloc_string_k = ALLOC_STRING_SIZE; + sc->alloc_string_cells = NULL; + sc->alloc_opt_func_cells = NULL; + sc->alloc_opt_func_k = ALLOC_FUNCTION_SIZE; + sc->longjmp_ok = false; + sc->setjmp_loc = NO_SET_JUMP; + sc->max_vector_length = (1LL << 32); + sc->max_string_length = 1073741824; /* 1 << 30 */ + sc->max_format_length = 10000; + sc->max_list_length = 1073741824; + sc->max_vector_dimensions = 512; + sc->strbuf_size = INITIAL_STRBUF_SIZE; + sc->strbuf = (char *) calloc(sc->strbuf_size, 1); + sc->print_width = sc->max_string_length; + sc->short_print = false; + sc->in_with_let = false; + sc->object_out_locked = false; + sc->has_openlets = true; + sc->is_expanding = true; + sc->accept_all_keyword_arguments = false; + sc->muffle_warnings = false; + sc->initial_string_port_length = 128; + sc->format_depth = -1; + sc->singletons = (s7_pointer *) calloc(256, sizeof(s7_pointer)); + add_saved_pointer(sc, sc->singletons); + sc->read_line_buf = NULL; + sc->read_line_buf_size = 0; + sc->last_error_line = -1; + sc->stop_at_error = true; + + sc->nil = make_unique(sc, "()", T_NIL); + sc->unused = make_unique(sc, "#", T_UNUSED); + sc->T = make_unique(sc, "#t", T_BOOLEAN); + sc->F = make_unique(sc, "#f", T_BOOLEAN); + sc->undefined = make_unique(sc, "#", T_UNDEFINED); + sc->unspecified = make_unique(sc, "#", T_UNSPECIFIED); + sc->no_value = make_unique(sc, "#", T_UNSPECIFIED); + + unique_car(sc->nil) = sc->unspecified; + unique_cdr(sc->nil) = sc->unspecified; + /* this is mixing two different s7_cell structs, cons and envr, but luckily envr has two initial s7_pointer fields, equivalent to car and cdr, so + * let_id which is the same as opt1 is unaffected. To get the names built-in, I'll append unique_name and unique_name_length fields to the envr struct. + */ + let_set_id(sc->nil, -1); + unique_cdr(sc->unspecified) = sc->unspecified; + + sc->temp_cell_2 = + permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE); + + sc->t1_1 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE); + sc->t2_2 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE); + sc->t2_1 = permanent_cons(sc, sc->nil, sc->t2_2, T_PAIR | T_IMMUTABLE); + sc->z2_2 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE); + sc->z2_1 = permanent_cons(sc, sc->nil, sc->z2_2, T_PAIR | T_IMMUTABLE); + sc->t3_3 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE); + sc->t3_2 = permanent_cons(sc, sc->nil, sc->t3_3, T_PAIR | T_IMMUTABLE); + sc->t3_1 = permanent_cons(sc, sc->nil, sc->t3_2, T_PAIR | T_IMMUTABLE); + sc->t4_1 = permanent_cons(sc, sc->nil, sc->t3_1, T_PAIR | T_IMMUTABLE); + sc->u1_1 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE); + sc->u2_2 = permanent_cons(sc, sc->nil, sc->nil, T_PAIR | T_IMMUTABLE); + sc->u2_1 = permanent_cons(sc, sc->nil, sc->u2_2, T_PAIR | T_IMMUTABLE); + + sc->safe_lists[0] = sc->nil; + for (i = 1; i < NUM_SAFE_PRELISTS; i++) + sc->safe_lists[i] = permanent_list(sc, i); + for (i = NUM_SAFE_PRELISTS; i < NUM_SAFE_LISTS; i++) + sc->safe_lists[i] = sc->nil; + sc->current_safe_list = 0; + + sc->input_port_stack_size = INPUT_PORT_STACK_INITIAL_SIZE; + sc->input_port_stack = + (s7_pointer *) malloc(sc->input_port_stack_size * + sizeof(s7_pointer)); + sc->input_port_stack_loc = 0; + + sc->code = sc->nil; +#if WITH_HISTORY + sc->eval_history1 = permanent_list(sc, DEFAULT_HISTORY_SIZE); + sc->eval_history2 = permanent_list(sc, DEFAULT_HISTORY_SIZE); + sc->history_pairs = permanent_list(sc, DEFAULT_HISTORY_SIZE); + sc->history_sink = permanent_list(sc, 1); + cdr(sc->history_sink) = sc->history_sink; + { + s7_pointer p1, p2, p3; + for (p3 = sc->history_pairs; is_pair(cdr(p3)); p3 = cdr(p3)) + set_car(p3, permanent_list(sc, 1)); + set_car(p3, permanent_list(sc, 1)); + set_cdr(p3, sc->history_pairs); + for (p1 = sc->eval_history1, p2 = sc->eval_history2; + is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2)); + set_cdr(p1, sc->eval_history1); + set_cdr(p2, sc->eval_history2); + sc->cur_code = sc->eval_history1; + sc->using_history1 = true; + sc->old_cur_code = sc->cur_code; + } +#else + sc->cur_code = sc->F; +#endif + sc->args = sc->nil; + sc->value = sc->nil; + sc->u = sc->nil; + sc->v = sc->nil; + sc->w = sc->nil; + sc->x = sc->nil; + sc->y = sc->nil; + sc->z = sc->nil; + sc->temp1 = sc->nil; + sc->temp2 = sc->nil; + sc->temp3 = sc->nil; + sc->temp4 = sc->nil; + sc->temp5 = sc->nil; + sc->temp6 = sc->nil; + sc->temp7 = sc->nil; + sc->temp8 = sc->nil; + sc->temp9 = sc->nil; + sc->rec_p1 = sc->F; + sc->rec_p2 = sc->F; + + sc->begin_hook = NULL; + sc->autoload_table = sc->nil; + sc->autoload_names = NULL; + sc->autoload_names_sizes = NULL; + sc->autoloaded_already = NULL; + sc->autoload_names_loc = 0; +#if DISABLE_AUTOLOAD + sc->is_autoloading = false; +#else + sc->is_autoloading = true; +#endif + sc->rec_stack = NULL; + + sc->heap_size = INITIAL_HEAP_SIZE; + if ((sc->heap_size % 32) != 0) + sc->heap_size = + 32 * (int64_t) ceil((double) (sc->heap_size) / 32.0); + sc->heap = (s7_pointer *) malloc(sc->heap_size * sizeof(s7_pointer)); + sc->free_heap = (s7_cell **) malloc(sc->heap_size * sizeof(s7_cell *)); + sc->free_heap_top = (s7_cell **) (sc->free_heap + INITIAL_HEAP_SIZE); + sc->free_heap_trigger = (s7_cell **) (sc->free_heap + GC_TRIGGER_SIZE); + sc->previous_free_heap_top = sc->free_heap_top; + { + s7_cell *cells; + cells = (s7_cell *) calloc(INITIAL_HEAP_SIZE, sizeof(s7_cell)); /* calloc to make sure type=0 at start? (for gc/valgrind) */ + add_saved_pointer(sc, (void *) cells); + for (i = 0; i < INITIAL_HEAP_SIZE; i++) { /* LOOP_4 here is slower! */ + sc->heap[i] = &cells[i]; + sc->free_heap[i] = sc->heap[i]; + i++; + sc->heap[i] = &cells[i]; + sc->free_heap[i] = sc->heap[i]; + } + sc->heap_blocks = (heap_block_t *) malloc(sizeof(heap_block_t)); + sc->heap_blocks->start = (intptr_t) cells; + sc->heap_blocks->end = + (intptr_t) cells + (sc->heap_size * sizeof(s7_cell)); + sc->heap_blocks->offset = 0; + sc->heap_blocks->next = NULL; + } + sc->gc_temps_size = GC_TEMPS_SIZE; + sc->gc_resize_heap_fraction = GC_RESIZE_HEAP_FRACTION; + sc->gc_resize_heap_by_4_fraction = GC_RESIZE_HEAP_BY_4_FRACTION; + sc->max_heap_size = (1LL << 62); + sc->gc_calls = 0; + sc->gc_total_time = 0; + + sc->max_port_data_size = (1LL << 62); +#ifndef OUTPUT_PORT_DATA_SIZE +#define OUTPUT_PORT_DATA_SIZE 2048 +#endif + sc->output_port_data_size = OUTPUT_PORT_DATA_SIZE; + + /* this has to precede s7_make_* allocations */ + sc->protected_setters_size = INITIAL_PROTECTED_OBJECTS_SIZE; + sc->protected_setters_loc = 0; + sc->protected_setters = + s7_make_vector(sc, INITIAL_PROTECTED_OBJECTS_SIZE); + sc->protected_setter_symbols = + s7_make_vector(sc, INITIAL_PROTECTED_OBJECTS_SIZE); + + sc->protected_objects_size = INITIAL_PROTECTED_OBJECTS_SIZE; + sc->gpofl = + (s7_int *) malloc(INITIAL_PROTECTED_OBJECTS_SIZE * sizeof(s7_int)); + sc->gpofl_loc = INITIAL_PROTECTED_OBJECTS_SIZE - 1; + sc->protected_objects = + s7_make_vector(sc, INITIAL_PROTECTED_OBJECTS_SIZE); + for (i = 0; i < INITIAL_PROTECTED_OBJECTS_SIZE; i++) { + vector_element(sc->protected_objects, i) = sc->unused; + vector_element(sc->protected_setters, i) = sc->unused; + vector_element(sc->protected_setter_symbols, i) = sc->unused; + sc->gpofl[i] = i; + } + + sc->stack = s7_make_vector(sc, INITIAL_STACK_SIZE); /* this fills it with sc->nil */ + sc->stack_start = vector_elements(sc->stack); /* stack type set below */ + sc->stack_end = sc->stack_start; + sc->stack_size = INITIAL_STACK_SIZE; + sc->stack_resize_trigger = + (s7_pointer *) (sc->stack_start + + (INITIAL_STACK_SIZE - STACK_RESIZE_TRIGGER)); + set_full_type(sc->stack, T_STACK); + sc->max_stack_size = (1 << 30); + stack_clear_flags(sc->stack); + initialize_op_stack(sc); + + /* keep the symbol table out of the heap */ + sc->symbol_table = (s7_pointer) calloc(1, sizeof(s7_cell)); + set_full_type(sc->symbol_table, T_VECTOR | T_UNHEAP); + vector_length(sc->symbol_table) = SYMBOL_TABLE_SIZE; + vector_elements(sc->symbol_table) = + (s7_pointer *) malloc(SYMBOL_TABLE_SIZE * sizeof(s7_pointer)); + vector_getter(sc->symbol_table) = default_vector_getter; + vector_setter(sc->symbol_table) = default_vector_setter; + s7_vector_fill(sc, sc->symbol_table, sc->nil); + + { /* sc->opts */ + opt_info *os; + os = (opt_info *) calloc(OPTS_SIZE, sizeof(opt_info)); + add_saved_pointer(sc, os); + for (i = 0; i < OPTS_SIZE; i++) { + opt_info *o = &os[i]; + sc->opts[i] = o; + opt_set_sc(o, sc); + } + } + + for (i = 0; i < NUM_TYPES; i++) + sc->prepackaged_type_names[i] = + s7_make_permanent_string(sc, + (const char *) type_name_from_type(i, + INDEFINITE_ARTICLE)); + +#if WITH_MULTITHREAD_CHECKS + sc->lock_count = 0; + { + pthread_mutexattr_t attr; + pthread_mutexattr_init(&attr); + pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE); + pthread_mutex_init(&sc->lock, &attr); + } +#endif + + sc->c_object_types = NULL; + sc->c_object_types_size = 0; + sc->num_c_object_types = 0; + sc->typnam = NULL; + sc->typnam_len = 0; + sc->default_rationalize_error = 1.0e-12; + sc->hash_table_float_epsilon = 1.0e-12; + sc->equivalent_float_epsilon = 1.0e-15; + sc->float_format_precision = WRITE_REAL_PRECISION; + sc->default_hash_table_length = 8; + sc->gensym_counter = 0; + sc->capture_let_counter = 0; + sc->continuation_counter = 0; + sc->f_class = 0; + sc->add_class = 0; + sc->num_eq_class = 0; + sc->let_number = 0; + sc->format_column = 0; + sc->format_ports = NULL; + sc->file_names = NULL; + sc->file_names_size = 0; + sc->file_names_top = -1; + sc->s7_call_line = 0; + sc->s7_call_file = NULL; + sc->s7_call_name = NULL; + sc->safety = NO_SAFETY; + sc->debug = 0; + sc->profile = 0; + sc->debug_or_profile = false; + sc->profiling_gensyms = false; + sc->profile_data = NULL; + sc->print_length = DEFAULT_PRINT_LENGTH; + sc->history_size = DEFAULT_HISTORY_SIZE; + sc->true_history_size = DEFAULT_HISTORY_SIZE; + sc->baffle_ctr = 0; + sc->syms_tag = 0; + sc->syms_tag2 = 0; + sc->class_name_symbol = make_symbol(sc, "class-name"); + sc->name_symbol = make_symbol(sc, "name"); + sc->trace_in_symbol = make_symbol(sc, "trace-in"); + sc->size_symbol = make_symbol(sc, "size"); + sc->mutable_symbol = make_symbol(sc, "mutable?"); + sc->file__symbol = make_symbol(sc, "FILE*"); + sc->circle_info = init_circle_info(sc); + sc->fdats = (format_data_t **) calloc(8, sizeof(format_data_t *)); + sc->num_fdats = 8; + sc->plist_1 = permanent_list(sc, 1); + sc->plist_2 = permanent_list(sc, 2); + sc->plist_2_2 = cdr(sc->plist_2); + sc->plist_3 = permanent_list(sc, 3); + sc->qlist_2 = permanent_list(sc, 2); + sc->qlist_3 = permanent_list(sc, 3); + sc->clist_1 = permanent_list(sc, 1); + sc->dlist_1 = permanent_list(sc, 1); + sc->elist_1 = permanent_list(sc, 1); + sc->elist_2 = permanent_list(sc, 2); + sc->elist_3 = permanent_list(sc, 3); + sc->elist_4 = permanent_list(sc, 4); + sc->elist_5 = permanent_list(sc, 5); + sc->undefined_identifier_warnings = false; + sc->undefined_constant_warnings = false; + sc->wrap_only = make_wrap_only(sc); + sc->unentry = (hash_entry_t *) malloc(sizeof(hash_entry_t)); + hash_entry_set_value(sc->unentry, sc->F); + sc->begin_op = OP_BEGIN_NO_HOOK; + /* we used to laboriously set various other fields to null, but the calloc takes care of that */ + sc->tree_pointers = NULL; + sc->tree_pointers_size = 0; + sc->tree_pointers_top = 0; + + sc->rootlet = s7_make_vector(sc, INITIAL_ROOTLET_SIZE); + set_full_type(sc->rootlet, T_LET | T_SAFE_PROCEDURE); + sc->rootlet_entries = 0; + for (i = 0; i < INITIAL_ROOTLET_SIZE; i++) + rootlet_element(sc->rootlet, i) = sc->nil; + sc->curlet = sc->nil; + sc->shadow_rootlet = sc->nil; + sc->objstr_max_len = S7_INT64_MAX; + + init_wrappers(sc); + init_standard_ports(sc); + init_rootlet(sc); + init_open_input_function_choices(sc); + + { + s7_pointer p; + new_cell(sc, p, T_RANDOM_STATE); /* s7_set_default_random_state might set sc->default_rng, so this shouldn't be permanent */ + sc->default_rng = p; + + sc->bignum_precision = DEFAULT_BIGNUM_PRECISION; +#if WITH_GMP + sc->bigints = NULL; + sc->bigrats = NULL; + sc->bigflts = NULL; + sc->bigcmps = NULL; + + mpfr_set_default_prec((mp_prec_t) DEFAULT_BIGNUM_PRECISION); + mpc_set_default_precision((mp_prec_t) DEFAULT_BIGNUM_PRECISION); + + mpz_inits(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL); + mpq_inits(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL); + mpfr_inits2(DEFAULT_BIGNUM_PRECISION, sc->mpfr_1, sc->mpfr_2, + sc->mpfr_3, NULL); + mpc_init(sc->mpc_1); + mpc_init(sc->mpc_2); + + mpz_set_ui(sc->mpz_1, (uint64_t) my_clock()); + gmp_randinit_default(random_gmp_state(p)); + gmp_randseed(random_gmp_state(p), sc->mpz_1); + + sc->pi_symbol = s7_define_constant(sc, "pi", big_pi(sc)); + set_initial_slot(sc->pi_symbol, make_permanent_slot(sc, sc->pi_symbol, big_pi(sc))); /* s7_make_slot does not handle this */ + s7_provide(sc, "gmp"); +#else + random_seed(p) = (uint64_t) my_clock(); /* used to be time(NULL), but that means separate threads can get the same random number sequence */ + random_carry(p) = 1675393560; + sc->pi_symbol = s7_define_constant(sc, "pi", real_pi); +#endif + } + for (i = 0; i < 10; i++) + sc->singletons[(uint8_t) '0' + i] = small_int(i); + sc->singletons[(uint8_t) '+'] = sc->add_symbol; + sc->singletons[(uint8_t) '-'] = sc->subtract_symbol; + sc->singletons[(uint8_t) '*'] = sc->multiply_symbol; + sc->singletons[(uint8_t) '/'] = sc->divide_symbol; + sc->singletons[(uint8_t) '<'] = sc->lt_symbol; + sc->singletons[(uint8_t) '>'] = sc->gt_symbol; + sc->singletons[(uint8_t) '='] = sc->num_eq_symbol; + + init_choosers(sc); + init_typers(sc); + init_opt_functions(sc); + s7_set_history_enabled(sc, false); + +#if S7_DEBUGGING + init_tc_rec(sc); +#endif + +#if (!WITH_PURE_S7) + s7_define_variable(sc, "make-rectangular", + global_value(sc->complex_symbol)); + s7_eval_c_string(sc, + "(define make-polar \n\ + (let ((+signature+ '(number? real? real?))) \n\ + (lambda (mag ang) \n\ + (if (and (real? mag) (real? ang)) \n\ + (complex (* mag (cos ang)) (* mag (sin ang))) \n\ + (error 'wrong-type-arg \"make-polar arguments should be real\")))))"); + + s7_eval_c_string(sc, + "(define (call-with-values producer consumer) (apply consumer (list (producer))))"); + /* (consumer (producer)) will work in any "normal" context. If consumer is syntax and then subsequently not syntax, there is confusion */ + + s7_eval_c_string(sc, + "(define-macro (multiple-value-bind vars expression . body) \n\ + (list (cons 'lambda (cons vars body)) expression))"); + + s7_eval_c_string(sc, + "(define-macro (cond-expand . clauses) \n\ + (letrec ((traverse (lambda (tree) \n\ + (if (pair? tree) \n\ + (cons (traverse (car tree)) \n\ + (case (cdr tree) ((())) (else => traverse))) \n\ + (if (memq tree '(and or not else)) tree \n\ + (and (symbol? tree) (provided? tree))))))) \n\ + (cons 'cond (map (lambda (clause) \n\ + (if (pair? clause) \n\ + (cons (traverse (car clause)) \n\ + (case (cdr clause) ((()) '(#f)) (else))) \n\ + (error 'read-error \"cond-expand: bad clause\"))) \n\ + clauses))))"); +#endif + + s7_eval_c_string(sc, "(define-expansion (reader-cond . clauses) \n\ + (call-with-exit \n\ + (lambda (return) \n\ + (for-each \n\ + (lambda (clause) \n\ + (let ((val (eval (car clause)))) \n\ + (when val \n\ + (return (cond ((null? (cdr clause)) val) \n\ + ((eq? (cadr clause) '=>) ((eval (caddr clause)) val)) \n\ + ((null? (cddr clause)) (cadr clause)) \n\ + (else (apply values (map quote (cdr clause))))))))) \n\ + clauses) \n\ + (values))))"); /* this is not redundant *//* map above ignores trailing cdr if improper */ + + s7_eval_c_string(sc, + "(define make-hook \n\ + (let ((+signature+ '(procedure?)) \n\ + (+documentation+ \"(make-hook . pars) returns a new hook (a function) that passes the parameters to its function list.\")) \n\ + (lambda hook-args \n\ + (let ((body ())) \n\ + (apply lambda* hook-args \n\ + (copy '(let ((result #)) \n\ + (let ((hook (curlet))) \n\ + (for-each (lambda (hook-function) (hook-function hook)) body)\n\ + result)) \n\ + :readable) \n\ + ())))))"); + + s7_eval_c_string(sc, + "(define hook-functions \n\ + (let ((+signature+ '(#t procedure?)) \n\ + (+documentation+ \"(hook-functions hook) gets or sets the list of functions associated with the hook\")) \n\ + (dilambda \n\ + (lambda (hook) \n\ + ((funclet hook) 'body)) \n\ + (lambda (hook lst) \n\ + (if (do ((p lst (cdr p))) \n\ + ((not (and (pair? p) \n\ + (procedure? (car p)) \n\ + (aritable? (car p) 1))) \n\ + (null? p))) \n\ + (set! ((funclet hook) 'body) lst) \n\ + (error 'wrong-type-arg \"hook-functions must be a list of functions, each accepting one argument: ~S\" lst))))))"); + + /* -------- *unbound-variable-hook* -------- */ + sc->unbound_variable_hook = + s7_eval_c_string(sc, "(make-hook 'variable)"); + s7_define_constant_with_documentation(sc, "*unbound-variable-hook*", + sc->unbound_variable_hook, + "*unbound-variable-hook* functions are called when an unbound variable is encountered, passed (hook 'variable)."); + + /* -------- *missing-close-paren-hook* -------- */ + sc->missing_close_paren_hook = s7_eval_c_string(sc, "(make-hook)"); + s7_define_constant_with_documentation(sc, "*missing-close-paren-hook*", + sc->missing_close_paren_hook, + "*missing-close-paren-hook* functions are called when the reader thinks a close paren is missing"); + + /* -------- *load-hook* -------- */ + sc->load_hook = s7_eval_c_string(sc, "(make-hook 'name)"); + s7_define_constant_with_documentation(sc, "*load-hook*", sc->load_hook, + "*load-hook* functions are invoked by load, passing the to-be-loaded filename as (hook 'name)"); + + /* -------- *autoload-hook* -------- */ + sc->autoload_hook = s7_eval_c_string(sc, "(make-hook 'name 'file)"); + s7_define_constant_with_documentation(sc, "*autoload-hook*", + sc->autoload_hook, + "*autoload-hook* functions are invoked by autoload, passing the to-be-autoloaded filename as (hook 'name) and (hook 'file))"); + + /* -------- *error-hook* -------- */ + sc->error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); + s7_define_constant_with_documentation(sc, "*error-hook*", + sc->error_hook, + "*error-hook* functions are called in the error handler, passed (hook 'type) and (hook 'data)."); + + /* -------- *read-error-hook* -------- */ + sc->read_error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); + s7_define_constant_with_documentation(sc, "*read-error-hook*", + sc->read_error_hook, + "*read-error-hook* functions are called by the reader if it is unhappy, passing the current program string as (hook 'data)."); + + /* -------- *rootlet-redefinition-hook* -------- */ + sc->rootlet_redefinition_hook = + s7_eval_c_string(sc, "(make-hook 'name 'value)"); + s7_define_constant_with_documentation(sc, + "*rootlet-redefinition-hook*", + sc->rootlet_redefinition_hook, + "*rootlet-redefinition-hook* functions are called when a top-level variable's value is changed, (hook 'name 'value)."); + + { /* *s7* is permanent -- 20-May-21 */ + s7_pointer x, slot1, slot2; + x = alloc_pointer(sc); + set_full_type(x, + T_LET | T_SAFE_PROCEDURE | T_UNHEAP | T_HAS_METHODS | + T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK); + let_set_id(x, ++sc->let_number); + let_set_outlet(x, sc->nil); + slot1 = + make_permanent_slot(sc, sc->let_set_fallback_symbol, + s7_make_function(sc, "s7-let-set", + g_s7_let_set_fallback, 3, + 0, false, "*s7* writer")); + symbol_set_local_slot(sc->let_set_fallback_symbol, sc->let_number, + slot1); + slot_set_next(slot1, slot_end(sc)); + slot2 = + make_permanent_slot(sc, sc->let_ref_fallback_symbol, + s7_make_function(sc, "s7-let-ref", + g_s7_let_ref_fallback, 2, + 0, false, "*s7* reader")); + symbol_set_local_slot(sc->let_ref_fallback_symbol, sc->let_number, + slot2); + slot_set_next(slot2, slot1); + let_set_slots(x, slot2); + sc->s7_let = x; + } + sc->s7_let_symbol = + s7_define_constant(sc, "*s7*", s7_openlet(sc, sc->s7_let)); + set_immutable(let_slots(sc->s7_let)); /* make the *s7* let-ref|set! fallbacks immutable */ + set_immutable(next_slot(let_slots(sc->s7_let))); + set_immutable(sc->s7_let); + s7_set_history_enabled(sc, true); + +#if S7_DEBUGGING + s7_define_function(sc, "report-missed-calls", g_report_missed_calls, 0, + 0, false, NULL); + if (!s7_type_names[0]) { + fprintf(stderr, "no type_names\n"); + gdb_break(); + } /* squelch very stupid warnings! */ + if (strcmp(op_names[HOP_SAFE_C_PP], "h_safe_c_pp") != 0) + fprintf(stderr, "c op_name: %s\n", op_names[HOP_SAFE_C_PP]); + if (strcmp(op_names[OP_SET_WITH_LET_2], "set_with_let_2") != 0) + fprintf(stderr, "set op_name: %s\n", op_names[OP_SET_WITH_LET_2]); + if (NUM_OPS != 940) + fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", + (int) sizeof(s7_cell), (int) sizeof(block_t), NUM_OPS, + (int) sizeof(opt_info)); + /* cell size: 48, 120 if debugging, block size: 40, opt: 128 or 280 */ +#endif + + init_unlet(sc); + init_s7_let(sc); /* set up *s7* */ + init_signatures(sc); /* depends on procedure symbols */ + return (sc); +} + + +/* -------------------------------- s7_free -------------------------------- */ + +void s7_free(s7_scheme * sc) +{ + /* free the memory associated with sc + * most pointers are in the saved_pointers table, but any that might be realloc'd need to be handled explicitly + * valgrind --leak-check=full --show-reachable=yes --suppressions=/home/bil/cl/free.supp repl s7test.scm + * valgrind --leak-check=full --show-reachable=yes --gen-suppressions=all --error-limit=no --log-file=raw.log repl s7test.scm + */ + s7_int i; + gc_list_t *gp; + + g_gc(sc, sc->nil); /* probably not needed (my simple tests work fine if the gc call is omitted) */ + + gp = sc->vectors; + for (i = 0; i < gp->loc; i++) + if (block_index(unchecked_vector_block(gp->list[i])) == + TOP_BLOCK_LIST) + free(block_data(unchecked_vector_block(gp->list[i]))); + free(gp->list); + free(gp); + free(sc->multivectors->list); /* I assume vector_dimension_info won't need 131072 bytes */ + free(sc->multivectors); + + gp = sc->strings; + for (i = 0; i < gp->loc; i++) + if (block_index(unchecked_string_block(gp->list[i])) == + TOP_BLOCK_LIST) + free(block_data(unchecked_string_block(gp->list[i]))); + free(gp->list); + free(gp); + + gp = sc->output_ports; + for (i = 0; i < gp->loc; i++) { + if ((unchecked_port_data_block(gp->list[i])) && + (block_index(unchecked_port_data_block(gp->list[i])) == + TOP_BLOCK_LIST)) + free(block_data(unchecked_port_data_block(gp->list[i]))); /* the file contents, port_block is other stuff */ + if ((is_file_port(gp->list[i])) && (!port_is_closed(gp->list[i]))) + fclose(port_file(gp->list[i])); + } + free(gp->list); + free(gp); + + gp = sc->input_ports; + for (i = 0; i < gp->loc; i++) + if ((unchecked_port_data_block(gp->list[i])) && + (block_index(unchecked_port_data_block(gp->list[i])) == + TOP_BLOCK_LIST)) + free(block_data(unchecked_port_data_block(gp->list[i]))); /* the file contents, port_block is other stuff */ + free(gp->list); + free(gp); + free(sc->input_string_ports->list); /* port_data_block is null, port_block is the const char* data, so I assume it is handled elsewhere */ + free(sc->input_string_ports); + + gp = sc->hash_tables; + for (i = 0; i < gp->loc; i++) + if (block_index(unchecked_hash_table_block(gp->list[i])) == + TOP_BLOCK_LIST) + free(block_data(unchecked_hash_table_block(gp->list[i]))); + free(gp->list); + free(gp); + + gp = sc->c_objects; + for (i = 0; i < gp->loc; i++) { + s7_pointer s1; + s1 = gp->list[i]; + if (c_object_gc_free(sc, s1)) + (*(c_object_gc_free(sc, s1))) (sc, s1); + else + (*(c_object_free(sc, s1))) (c_object_value(s1)); + } + free(gp->list); + free(gp); + +#if WITH_GMP + /* free lists */ + { + bigint *p, *np; + for (p = sc->bigints; p; p = np) { + mpz_clear(p->n); + np = p->nxt; + free(p); + } + } + { + bigrat *p, *np; + for (p = sc->bigrats; p; p = np) { + mpq_clear(p->q); + np = p->nxt; + free(p); + } + } + { + bigflt *p, *np; + for (p = sc->bigflts; p; p = np) { + mpfr_clear(p->x); + np = p->nxt; + free(p); + } + } + { + bigcmp *p, *np; + for (p = sc->bigcmps; p; p = np) { + mpc_clear(p->z); + np = p->nxt; + free(p); + } + } + + /* in-use lists */ + gp = sc->big_integers; + for (i = 0; i < gp->loc; i++) { + bigint *p; + p = big_integer_bgi(gp->list[i]); + mpz_clear(p->n); + free(p); + } + free(gp->list); + free(gp); + + gp = sc->big_ratios; + for (i = 0; i < gp->loc; i++) { + bigrat *p; + p = big_ratio_bgr(gp->list[i]); + mpq_clear(p->q); + free(p); + } + free(gp->list); + free(gp); + + gp = sc->big_reals; + for (i = 0; i < gp->loc; i++) { + bigflt *p; + p = big_real_bgf(gp->list[i]); + mpfr_clear(p->x); + free(p); + } + free(gp->list); + free(gp); + + gp = sc->big_complexes; + for (i = 0; i < gp->loc; i++) { + bigcmp *p; + p = big_complex_bgc(gp->list[i]); + mpc_clear(p->z); + free(p); + } + free(gp->list); + free(gp); + + gp = sc->big_random_states; + for (i = 0; i < gp->loc; i++) + gmp_randclear(random_gmp_state(gp->list[i])); + free(gp->list); + free(gp); + + gmp_randclear(random_gmp_state(sc->default_rng)); + + /* temps */ + if (sc->ratloc) + free_rat_locals(sc); + mpz_clears(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL); + mpq_clears(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL); + mpfr_clears(sc->mpfr_1, sc->mpfr_2, sc->mpfr_3, NULL); + mpc_clear(sc->mpc_1); + mpc_clear(sc->mpc_2); + /* I claim the leftovers (864 bytes, all from mpfr_cosh) are gmp's fault */ +#endif + + free(undefined_name(sc->undefined)); + gp = sc->undefineds; + for (i = 0; i < gp->loc; i++) + free(undefined_name(gp->list[i])); + free(gp->list); + free(gp); + + free(sc->gensyms->list); + free(sc->gensyms); + free(sc->continuations->list); + free(sc->continuations); /* stack is simple vector (handled above) */ + free(sc->lambdas->list); + free(sc->lambdas); + free(sc->weak_refs->list); + free(sc->weak_refs); + free(sc->weak_hash_iterators->list); + free(sc->weak_hash_iterators); + free(sc->opt1_funcs); + + free(port_port(sc->standard_output)); + free(port_port(sc->standard_error)); + free(port_port(sc->standard_input)); + + if (sc->autoload_names) + free(sc->autoload_names); + if (sc->autoload_names_sizes) + free(sc->autoload_names_sizes); + if (sc->autoloaded_already) + free(sc->autoloaded_already); + + { + block_t *top; + for (top = sc->block_lists[TOP_BLOCK_LIST]; top; + top = block_next(top)) + if (block_data(top)) + free(block_data(top)); + } + + for (i = 0; i < sc->saved_pointers_loc; i++) + free(sc->saved_pointers[i]); + free(sc->saved_pointers); + + { + gc_obj_t *g, *gnxt; + heap_block_t *hp, *hpnxt; + for (g = sc->permanent_lets; g; g = gnxt) { + gnxt = g->nxt; + free(g); + } + for (g = sc->permanent_objects; g; g = gnxt) { + gnxt = g->nxt; + free(g); + } + for (hp = sc->heap_blocks; hp; hp = hpnxt) { + hpnxt = hp->next; + free(hp); + } + } + + free(sc->heap); + free(sc->free_heap); + free(vector_elements(sc->symbol_table)); /* alloc'd directly, not via block */ + free(sc->symbol_table); + free(sc->unlet); + free(sc->setters); + free(sc->op_stack); + if (sc->tree_pointers) + free(sc->tree_pointers); + free(sc->num_to_str); + free(sc->gpofl); + if (sc->read_line_buf) + free(sc->read_line_buf); + free(sc->strbuf); + free(sc->circle_info->objs); + free(sc->circle_info->refs); + free(sc->circle_info->defined); + free(sc->circle_info); + if (sc->file_names) + free(sc->file_names); + free(sc->unentry); + free(sc->input_port_stack); + if (sc->typnam) + free(sc->typnam); + + for (i = 0; i < sc->num_fdats; i++) + if (sc->fdats[i]) { /* init val is NULL */ + if (sc->fdats[i]->curly_str) + free(sc->fdats[i]->curly_str); + free(sc->fdats[i]); + } + free(sc->fdats); + + if (sc->profile_data) { + free(sc->profile_data->funcs); + free(sc->profile_data->excl); + free(sc->profile_data->data); + free(sc->profile_data); + } + if (sc->c_object_types) { + for (i = 0; i < sc->num_c_object_types; i++) + free(sc->c_object_types[i]); + free(sc->c_object_types); + } + free(sc); +} + + +/* -------------------------------- repl -------------------------------- */ +#ifndef USE_SND +#define USE_SND 0 +#endif +#ifndef WITH_MAIN +#define WITH_MAIN 0 +#endif + +#if WITH_MAIN && WITH_NOTCURSES +#define S7_MAIN 1 +#include "nrepl.c" + /* gcc -o nrepl s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl -DWITH_MAIN -DWITH_NOTCURSES -lnotcurses-core */ +#else + +static void dumb_repl(s7_scheme * sc) +{ + while (true) { + char buffer[512]; + fprintf(stdout, "\n> "); + if (!fgets(buffer, 512, stdin)) + break; /* error or ctrl-D */ + if (((buffer[0] != '\n') || (strlen(buffer) > 1))) { + char response[1024]; + snprintf(response, 1024, "(write %s)", buffer); + s7_eval_c_string(sc, response); + } + } + fprintf(stdout, "\n"); + if (ferror(stdin)) + fprintf(stderr, "read error on stdin\n"); +} + +void s7_repl(s7_scheme * sc) +{ +#if (!WITH_C_LOADER) + dumb_repl(sc); +#else +#if WITH_NOTCURSES + s7_load(sc, "nrepl.scm"); +#else + s7_pointer old_e, e, val; + s7_int gc_loc; + bool repl_loaded = false; + /* try to get lib_s7.so from the repl's directory, and set *libc*. + * otherwise repl.scm will try to load libc.scm which will try to build libc_s7.so locally, but that requires s7.h + */ + e = s7_inlet(sc, + set_plist_2(sc, s7_make_symbol(sc, "init_func"), + s7_make_symbol(sc, "libc_s7_init"))); + gc_loc = s7_gc_protect(sc, e); + old_e = s7_set_curlet(sc, e); /* e is now (curlet) so loaded names from libc will be placed there, not in (rootlet) */ + + val = s7_load_with_environment(sc, "libc_s7.so", e); + if (val) { + s7_pointer libs; + uint64_t hash; + hash = raw_string_hash((const uint8_t *) "*libc*", 6); /* hack around an idiotic gcc 10.2.1 warning */ + s7_define(sc, sc->nil, + new_symbol(sc, "*libc*", 6, hash, + hash % SYMBOL_TABLE_SIZE), e); + libs = global_slot(sc->libraries_symbol); + slot_set_value(libs, + cons(sc, + cons(sc, make_permanent_string("libc.scm"), e), + slot_value(libs))); + } else { + val = s7_load(sc, "repl.scm"); + if (val) + repl_loaded = true; + } + s7_set_curlet(sc, old_e); /* restore incoming (curlet) */ + s7_gc_unprotect_at(sc, gc_loc); + + if (!val) /* s7_load was unable to find/load libc_s7.so or repl.scm */ + dumb_repl(sc); + else { +#if S7_DEBUGGING + s7_autoload(sc, s7_make_symbol(sc, "compare-calls"), + s7_make_string(sc, "compare-calls.scm")); + s7_autoload(sc, s7_make_symbol(sc, "get-overheads"), + s7_make_string(sc, "compare-calls.scm")); +#endif + s7_provide(sc, "libc.scm"); + if (!repl_loaded) + s7_load(sc, "repl.scm"); + s7_eval_c_string(sc, "((*repl* 'run))"); + } +#endif +#endif +} + +#if WITH_MAIN && (!USE_SND) + +#if (!MS_WINDOWS) && WITH_C_LOADER +static char *realdir(const char *filename) +{ /* this code courtesy Lassi Kortela 4-Nov-19 */ + char *path; + char *p; + /* s7_repl wants to load libc_s7.o (for tcsetattr et al), but if it is started in a directory other than the libc_s7.so + * directory, it fails (it tries to build the library but that requires s7.h and libc.scm). So here we are trying to + * guess the libc_s7 directory from the command line program name. This can't work in general, but it works often + * enough to be worth the effort. If S7_LOAD_PATH is set, it is used instead. + */ + if (!strchr(filename, '/')) + return (NULL); + + if (!(path = realpath(filename, NULL))) { /* in Windows maybe GetModuleFileName(NULL, buffer, buffer_size) */ + fprintf(stderr, "%s: %s\n", strerror(errno), filename); + exit(2); + } + if (!(p = strrchr(path, '/'))) { + free(path); + fprintf(stderr, "please provide the full pathname for %s\n", + filename); + exit(2); + } + if (p > path) + *p = '\0'; + else + p[1] = 0; + return (path); +} +#endif + +int main(int argc, char **argv) +{ + s7_scheme *sc; + sc = s7_init(); + fprintf(stderr, "s7: %s\n", S7_DATE); + + if (argc == 2) { + fprintf(stderr, "load %s\n", argv[1]); + if (!s7_load(sc, argv[1])) { + fprintf(stderr, "can't load %s\n", argv[1]); + return (2); + } + } else { +#if (MS_WINDOWS) || (!WITH_C_LOADER) || ((defined(__linux__)) && (!defined(__GLIBC__))) /* musl? */ + dumb_repl(sc); +#else +#ifdef S7_LOAD_PATH + s7_add_to_load_path(sc, S7_LOAD_PATH); +#else + char *dir; + dir = realdir(argv[0]); + if (dir) { + s7_add_to_load_path(sc, dir); + free(dir); + } +#endif + s7_repl(sc); +#endif + } + return (0); +} + +/* in Linux: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-dynamic + * in *BSD: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm -Wl,-export-dynamic + * in OSX: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm + * (clang also needs LDFLAGS="-Wl,-export-dynamic" in Linux and "-fPIC") + * in msys2: gcc s7.c -o s7 -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-all-symbols,--out-implib,s7.lib + * + * for nrepl: gcc s7.c -o repl -DWITH_MAIN -DWITH_NOTCURSES -I. -O2 -g -lnotcurses-core -ldl -lm -Wl,-export-dynamic + * + * (s7.c compile time 2-Jul-21 52 secs) + * musl works, but there is some problem in libgsl.scm with gsl/gsl_blas.h I think + */ +#endif +#endif + +/* -------------------------------------------------------- + * gmp (8-23) 20.9 21.0 21.7 21.8 + * -------------------------------------------------------- + * tpeak 123 115 114 110 110 + * tref 552 691 687 476 476 + * tauto 785 648 642 496 496 + * tshoot 1471 883 872 808 808 + * index 1031 1026 1016 981 981 + * tmock 7756 1177 1165 1090 1090 + * tvect 1915 2456 2413 1735 1724 + * s7test 4514 1873 1831 1792 1794 + * texit ---- ---- 1886 + * lt 2129 2123 2110 2120 2120 + * tform 3245 2281 2273 2255 2258 + * tmac 2429 3317 3277 2409 2409 + * tread 2591 2440 2421 2415 2414 + * trclo 4093 2715 2561 2458 2458 + * fbench 2852 2688 2583 2475 2475 + * tmat 2648 3065 3042 2530 2519 + * tcopy 2745 8035 5546 2550 2550 + * dup 2760 3805 3788 2565 2577 + * tb 3375 2735 2681 2627 2627 + * titer 2678 2865 2842 2679 2679 + * tsort 3590 3105 3104 2860 2856 + * tset 3100 3253 3104 3089 3089 + * tload 3849 ---- ---- 3142 3142 + * teq 3542 4068 4045 3570 3570 + * tio 3684 3816 3752 3693 3694 + * tclo 4636 4787 4735 4402 4402 + * tlet 5283 7775 5640 4431 4431 + * tcase 4550 4960 4793 4444 4444 + * tmap 5984 8869 8774 4493 4493 + * tfft 115.1 7820 7729 4787 4787 + * tnum 56.7 6348 6013 5443 5441 + * tstr 8059 6880 6342 5776 5776 + * tgsl 25.2 8485 7802 6397 6397 + * trec 8338 6936 6922 6553 6553 + * tmisc 7217 8960 7699 6597 6594 + * tari ---- 12.8 12.5 6973 6931 + * tlist 6834 7896 7546 6865 6865 + * tgc 10.1 11.9 11.1 8668 8667 + * thash 35.4 11.8 11.7 9775 9775 + * cb 18.8 12.2 12.2 11.1 11.1 + * tgen 12.1 11.2 11.4 11.5 11.6 + * tall 24.4 15.6 15.6 15.6 15.6 + * calls 58.0 36.7 37.5 37.1 37.1 + * sg 80.0 ---- ---- 56.1 56.1 + * lg 104.5 106.6 105.0 104.4 104.4 + * tbig 635.1 177.4 175.8 166.4 166.3 + * -------------------------------------------------------- + * + * (n)repl.scm should have some autoload function for libm and libgsl (libc also for nrepl): cload.scm has checks at end + * nrepl bug(?) in row 0 (2.3.13 is ok, 2.3.17 is broken) + * fb_annotate: bool_opt cases? and/or with bool ops (lt gt etc), cond/do tests if result + * in the vs case, can we see the bfunc and update it? In fx_tree OP_IF_B* call fx_tree directly and catch fixup + * for and/or: all branches fx->fb -> new op?? + * fx_tree fb cases? trec: half fx_num_eq_t0 -> fb_num_eq_s0 + * op_local_lambda _fx? [and unwrap the pointless case ((lambda () (f a b)))] + * need fx_annotate (but not tree) for lambda body, OP_F|F_A|F_AA? + * v*ref_un* from check_unchecked: -> make_integer|real? + * d_7pi??, d_dp|[pd]|pp and i_ip|[pi=i_7pi]|pp to reduce intermediate number creation, also d_pid=d_7pid and i_7pii for nr cases + * tari case for these + * b_pi_ff and check_b_types -> b_pi etc + * some opt cases check methods/errors, but others don't -- these should have the methods + * asin at top -- return ignored, so asin is pointless -- at call point we have args, so p_p_nr, p_pp_nr etc? + * then idp_nr_fixup could see if func has no_side_effects set and set call to p_p_nr etc -- will break all timing tests... + * maybe an S7_TIMING flag or *s7* field (*s7* 'timing-test?) lint has no-side-effect-functions list + * at least a bit for opt functions that have an _nr replacement + */ diff --git a/source/engine/thirdparty/s7/s7.h b/source/engine/thirdparty/s7/s7.h new file mode 100644 index 0000000..4dc596e --- /dev/null +++ b/source/engine/thirdparty/s7/s7.h @@ -0,0 +1,1452 @@ +#ifndef S7_H +#define S7_H + +#define S7_VERSION "9.17" +#define S7_DATE "9-Sep-2021" +#define S7_MAJOR_VERSION 9 +#define S7_MINOR_VERSION 17 + +#include /* for int64_t */ + +typedef int64_t s7_int; +typedef double s7_double; + +#ifndef __cplusplus +#ifndef _MSC_VER +#include +#else +#ifndef true +#define bool unsigned char +#define true 1 +#define false 0 +#endif +#endif +#endif + +#if WITH_GMP + /* in g++ these includes need to be outside the extern "C" business */ +#include +#include +#include +#endif + +#ifdef __cplusplus +extern "C" { +#endif + + typedef struct s7_scheme s7_scheme; + typedef struct s7_cell *s7_pointer; + + s7_scheme *s7_init(void); + + /* s7_scheme is our interpreter + * s7_pointer is a Scheme object of any (Scheme) type + * s7_init creates the interpreter. + */ + void s7_free(s7_scheme * sc); + + typedef s7_pointer(*s7_function) (s7_scheme * sc, s7_pointer args); /* that is, obj = func(s7, args) -- args is a list of arguments */ + typedef s7_pointer(*s7_pfunc) (s7_scheme * sc); + + s7_pointer s7_f(s7_scheme * sc); /* #f */ + s7_pointer s7_t(s7_scheme * sc); /* #t */ + s7_pointer s7_nil(s7_scheme * sc); /* () */ + s7_pointer s7_undefined(s7_scheme * sc); /* # */ + s7_pointer s7_unspecified(s7_scheme * sc); /* # */ + bool s7_is_unspecified(s7_scheme * sc, s7_pointer val); /* returns true if val is # */ + s7_pointer s7_eof_object(s7_scheme * sc); /* # */ + bool s7_is_null(s7_scheme * sc, s7_pointer p); /* null? */ + + /* these are the Scheme constants; they do not change in value during a run, + * so they can be safely assigned to C global variables if desired. + */ + + bool s7_is_valid(s7_scheme * sc, s7_pointer arg); /* does 'arg' look like an s7 object? */ + bool s7_is_c_pointer(s7_pointer arg); /* (c-pointer? arg) */ + bool s7_is_c_pointer_of_type(s7_pointer arg, s7_pointer type); + void *s7_c_pointer(s7_pointer p); + void *s7_c_pointer_with_type(s7_scheme * sc, s7_pointer p, + s7_pointer expected_type, + const char *caller, s7_int argnum); + s7_pointer s7_c_pointer_type(s7_pointer p); + s7_pointer s7_make_c_pointer(s7_scheme * sc, void *ptr); /* these are for passing uninterpreted C pointers through Scheme */ + s7_pointer s7_make_c_pointer_with_type(s7_scheme * sc, void *ptr, + s7_pointer type, + s7_pointer info); + + s7_pointer s7_eval_c_string(s7_scheme * sc, const char *str); /* (eval-string str) */ + s7_pointer s7_eval_c_string_with_environment(s7_scheme * sc, + const char *str, + s7_pointer e); + s7_pointer s7_object_to_string(s7_scheme * sc, s7_pointer arg, + bool use_write); + /* (object->string obj) */ + char *s7_object_to_c_string(s7_scheme * sc, s7_pointer obj); /* same as object->string but returns a C char* directly */ + /* the returned value should be freed by the caller */ + + s7_pointer s7_load(s7_scheme * sc, const char *file); /* (load file) */ + s7_pointer s7_load_with_environment(s7_scheme * sc, + const char *filename, + s7_pointer e); + s7_pointer s7_load_c_string(s7_scheme * sc, const char *content, + s7_int bytes); + s7_pointer s7_load_c_string_with_environment(s7_scheme * sc, + const char *content, + s7_int bytes, + s7_pointer e); + s7_pointer s7_load_path(s7_scheme * sc); /* *load-path* */ + s7_pointer s7_add_to_load_path(s7_scheme * sc, const char *dir); /* (set! *load-path* (cons dir *load-path*)) */ + s7_pointer s7_autoload(s7_scheme * sc, s7_pointer symbol, s7_pointer file_or_function); /* (autoload symbol file-or-function) */ + void s7_autoload_set_names(s7_scheme * sc, const char **names, + s7_int size); + + /* the load path is a list of directories to search if load can't find the file passed as its argument. + * + * s7_load and s7_load_with_environment can load shared object files as well as scheme code. + * The scheme (load "somelib.so" (inlet 'init_func 'somelib_init)) is equivalent to + * s7_load_with_environment(s7, "somelib.so", s7_inlet(s7, s7_list(s7, 2, s7_make_symbol(s7, "init_func"), s7_make_symbol(s7, "somelib_init")))) + * s7_load_with_environment returns NULL if it can't load the file. + */ + void s7_quit(s7_scheme * sc); + /* this tries to break out of the current evaluation, leaving everything else intact */ + + void (*s7_begin_hook(s7_scheme * sc))(s7_scheme * sc, bool *val); + void s7_set_begin_hook(s7_scheme * sc, + void (*hook)(s7_scheme * sc, bool *val)); + /* call "hook" at the start of any block; use NULL to cancel. + * s7_begin_hook returns the current begin_hook function or NULL. + */ + + s7_pointer s7_eval(s7_scheme * sc, s7_pointer code, s7_pointer e); /* (eval code e) -- e is the optional environment */ + void s7_provide(s7_scheme * sc, const char *feature); /* add feature (as a symbol) to the *features* list */ + bool s7_is_provided(s7_scheme * sc, const char *feature); /* (provided? feature) */ + void s7_repl(s7_scheme * sc); + + s7_pointer s7_error(s7_scheme * sc, s7_pointer type, s7_pointer info); + s7_pointer s7_wrong_type_arg_error(s7_scheme * sc, const char *caller, + s7_int arg_n, s7_pointer arg, + const char *descr); + /* set arg_n to 0 to indicate that caller takes only one argument (so the argument number need not be reported */ + s7_pointer s7_out_of_range_error(s7_scheme * sc, const char *caller, + s7_int arg_n, s7_pointer arg, + const char *descr); + s7_pointer s7_wrong_number_of_args_error(s7_scheme * sc, + const char *caller, + s7_pointer args); + + /* these are equivalent to (error ...) in Scheme + * the first argument to s7_error is a symbol that can be caught (via (catch tag ...)) + * the rest of the arguments are passed to the error handler (if in catch) + * or printed out (in the default case). If the first element of the list + * of args ("info") is a string, the default error handler treats it as + * a format control string, and passes it to format with the rest of the + * info list as the format function arguments. + * + * s7_wrong_type_arg_error is equivalent to s7_error with a type of 'wrong-type-arg + * and similarly s7_out_of_range_error with type 'out-of-range. + * + * catch in Scheme is taken from Guile: + * + * (catch tag thunk handler) + * + * evaluates 'thunk'. If an error occurs, and the type matches 'tag' (or if 'tag' is #t), + * the handler is called, passing it the arguments (including the type) passed to the + * error function. If no handler is found, the default error handler is called, + * normally printing the error arguments to current-error-port. + */ + + s7_pointer s7_stacktrace(s7_scheme * sc); + s7_pointer s7_history(s7_scheme * sc); /* the current (circular backwards) history buffer */ + s7_pointer s7_add_to_history(s7_scheme * sc, s7_pointer entry); /* add entry to the history buffer */ + bool s7_history_enabled(s7_scheme * sc); + bool s7_set_history_enabled(s7_scheme * sc, bool enabled); + + s7_pointer s7_gc_on(s7_scheme * sc, bool on); /* (gc on) */ + + s7_int s7_gc_protect(s7_scheme * sc, s7_pointer x); + void s7_gc_unprotect_at(s7_scheme * sc, s7_int loc); + s7_pointer s7_gc_protected_at(s7_scheme * sc, s7_int loc); + s7_pointer s7_gc_protect_via_stack(s7_scheme * sc, s7_pointer x); + s7_pointer s7_gc_unprotect_via_stack(s7_scheme * sc, s7_pointer x); + s7_pointer s7_gc_protect_via_location(s7_scheme * sc, s7_pointer x, + s7_int loc); + s7_pointer s7_gc_unprotect_via_location(s7_scheme * sc, s7_int loc); + + /* any s7_pointer object held in C (as a local variable for example) needs to be + * protected from garbage collection if there is any chance the GC may run without + * an existing Scheme-level reference to that object. s7_gc_protect places the + * object in a vector that the GC always checks, returning the object's location + * in that table. s7_gc_unprotect_at unprotects the object (removes it from the + * vector) using the location passed to it. s7_gc_protected_at returns the object + * at the given location. + * + * You can turn the GC on and off via s7_gc_on. + * + * There is a built-in lag between the creation of a new object and its first possible GC + * (the lag time is set indirectly by GC_TEMPS_SIZE in s7.c), so you don't need to worry about + * very short term temps such as the arguments to s7_cons in: + * + * s7_cons(s7, s7_make_real(s7, 3.14), + * s7_cons(s7, s7_make_integer(s7, 123), s7_nil(s7))); + */ + + bool s7_is_eq(s7_pointer a, s7_pointer b); /* (eq? a b) */ + bool s7_is_eqv(s7_scheme * sc, s7_pointer a, s7_pointer b); /* (eqv? a b) */ + bool s7_is_equal(s7_scheme * sc, s7_pointer a, s7_pointer b); /* (equal? a b) */ + bool s7_is_equivalent(s7_scheme * sc, s7_pointer x, s7_pointer y); /* (equivalent? x y) */ + + bool s7_is_boolean(s7_pointer x); /* (boolean? x) */ + bool s7_boolean(s7_scheme * sc, s7_pointer x); /* Scheme boolean -> C bool */ + s7_pointer s7_make_boolean(s7_scheme * sc, bool x); /* C bool -> Scheme boolean */ + + /* for each Scheme type (boolean, integer, string, etc), there are three + * functions: s7_(...), s7_make_(...), and s7_is_(...): + * + * s7_boolean(s7, obj) returns the C bool corresponding to the value of 'obj' (#f -> false) + * s7_make_boolean(s7, false|true) returns the s7 boolean corresponding to the C bool argument (false -> #f) + * s7_is_boolean(s7, obj) returns true if 'obj' has a boolean value (#f or #t). + */ + + + bool s7_is_pair(s7_pointer p); /* (pair? p) */ + s7_pointer s7_cons(s7_scheme * sc, s7_pointer a, s7_pointer b); /* (cons a b) */ + + s7_pointer s7_car(s7_pointer p); /* (car p) */ + s7_pointer s7_cdr(s7_pointer p); /* (cdr p) */ + + s7_pointer s7_set_car(s7_pointer p, s7_pointer q); /* (set-car! p q) */ + s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q); /* (set-cdr! p q) */ + + s7_pointer s7_cadr(s7_pointer p); /* (cadr p) */ + s7_pointer s7_cddr(s7_pointer p); /* (cddr p) */ + s7_pointer s7_cdar(s7_pointer p); /* (cdar p) */ + s7_pointer s7_caar(s7_pointer p); /* (caar p) */ + + s7_pointer s7_caadr(s7_pointer p); /* etc */ + s7_pointer s7_caddr(s7_pointer p); + s7_pointer s7_cadar(s7_pointer p); + s7_pointer s7_caaar(s7_pointer p); + s7_pointer s7_cdadr(s7_pointer p); + s7_pointer s7_cdddr(s7_pointer p); + s7_pointer s7_cddar(s7_pointer p); + s7_pointer s7_cdaar(s7_pointer p); + + s7_pointer s7_caaadr(s7_pointer p); + s7_pointer s7_caaddr(s7_pointer p); + s7_pointer s7_caadar(s7_pointer p); + s7_pointer s7_caaaar(s7_pointer p); + s7_pointer s7_cadadr(s7_pointer p); + s7_pointer s7_cadddr(s7_pointer p); + s7_pointer s7_caddar(s7_pointer p); + s7_pointer s7_cadaar(s7_pointer p); + s7_pointer s7_cdaadr(s7_pointer p); + s7_pointer s7_cdaddr(s7_pointer p); + s7_pointer s7_cdadar(s7_pointer p); + s7_pointer s7_cdaaar(s7_pointer p); + s7_pointer s7_cddadr(s7_pointer p); + s7_pointer s7_cddddr(s7_pointer p); + s7_pointer s7_cdddar(s7_pointer p); + s7_pointer s7_cddaar(s7_pointer p); + + bool s7_is_list(s7_scheme * sc, s7_pointer p); /* (list? p) -> (or (pair? p) (null? p)) */ + bool s7_is_proper_list(s7_scheme * sc, s7_pointer p); /* (proper-list? p) */ + s7_int s7_list_length(s7_scheme * sc, s7_pointer a); /* (length a) */ + s7_pointer s7_make_list(s7_scheme * sc, s7_int len, s7_pointer init); /* (make-list len init) */ + s7_pointer s7_list(s7_scheme * sc, s7_int num_values, ...); /* (list ...) */ + s7_pointer s7_list_nl(s7_scheme * sc, s7_int num_values, ...); /* (list ...) arglist should be NULL terminated (more error checks than s7_list) */ + s7_pointer s7_array_to_list(s7_scheme * sc, s7_int num_values, s7_pointer * array); /* array contents -> list */ + s7_pointer s7_reverse(s7_scheme * sc, s7_pointer a); /* (reverse a) */ + s7_pointer s7_append(s7_scheme * sc, s7_pointer a, s7_pointer b); /* (append a b) */ + s7_pointer s7_list_ref(s7_scheme * sc, s7_pointer lst, s7_int num); /* (list-ref lst num) */ + s7_pointer s7_list_set(s7_scheme * sc, s7_pointer lst, s7_int num, s7_pointer val); /* (list-set! lst num val) */ + s7_pointer s7_assoc(s7_scheme * sc, s7_pointer obj, s7_pointer lst); /* (assoc obj lst) */ + s7_pointer s7_assq(s7_scheme * sc, s7_pointer obj, s7_pointer x); /* (assq obj lst) */ + s7_pointer s7_member(s7_scheme * sc, s7_pointer obj, s7_pointer lst); /* (member obj lst) */ + s7_pointer s7_memq(s7_scheme * sc, s7_pointer obj, s7_pointer x); /* (memq obj lst) */ + bool s7_tree_memq(s7_scheme * sc, s7_pointer sym, s7_pointer tree); /* (tree-memq sym tree) */ + + + bool s7_is_string(s7_pointer p); /* (string? p) */ + const char *s7_string(s7_pointer p); /* Scheme string -> C string (do not free the string) */ + s7_pointer s7_make_string(s7_scheme * sc, const char *str); /* C string -> Scheme string (str is copied) */ + s7_pointer s7_make_string_with_length(s7_scheme * sc, const char *str, s7_int len); /* same as s7_make_string, but provides strlen */ + s7_pointer s7_make_string_wrapper(s7_scheme * sc, const char *str); + s7_pointer s7_make_permanent_string(s7_scheme * sc, const char *str); /* make a string that will never be GC'd */ + s7_int s7_string_length(s7_pointer str); /* (string-length str) */ + + + bool s7_is_character(s7_pointer p); /* (character? p) */ + uint8_t s7_character(s7_pointer p); /* Scheme character -> unsigned C char */ + s7_pointer s7_make_character(s7_scheme * sc, uint8_t c); /* unsigned C char -> Scheme character */ + + + bool s7_is_number(s7_pointer p); /* (number? p) */ + bool s7_is_integer(s7_pointer p); /* (integer? p) */ + s7_int s7_integer(s7_pointer p); /* Scheme integer -> C integer (s7_int) */ + s7_pointer s7_make_integer(s7_scheme * sc, s7_int num); /* C s7_int -> Scheme integer */ + + bool s7_is_real(s7_pointer p); /* (real? p) */ + s7_double s7_real(s7_pointer p); /* Scheme real -> C double */ + s7_pointer s7_make_real(s7_scheme * sc, s7_double num); /* C double -> Scheme real */ + s7_pointer s7_make_mutable_real(s7_scheme * sc, s7_double n); + s7_double s7_number_to_real(s7_scheme * sc, s7_pointer x); /* x can be any kind of number */ + s7_double s7_number_to_real_with_caller(s7_scheme * sc, s7_pointer x, + const char *caller); + s7_int s7_number_to_integer(s7_scheme * sc, s7_pointer x); + s7_int s7_number_to_integer_with_caller(s7_scheme * sc, s7_pointer x, + const char *caller); + + bool s7_is_rational(s7_pointer arg); /* (rational? arg) -- integer or ratio */ + bool s7_is_ratio(s7_pointer arg); /* true if arg is a ratio, not an integer */ + s7_pointer s7_make_ratio(s7_scheme * sc, s7_int a, s7_int b); /* returns the Scheme object a/b */ + s7_pointer s7_rationalize(s7_scheme * sc, s7_double x, s7_double error); /* (rationalize x error) */ + s7_int s7_numerator(s7_pointer x); /* (numerator x) */ + s7_int s7_denominator(s7_pointer x); /* (denominator x) */ + s7_double s7_random(s7_scheme * sc, s7_pointer state); /* (random x) */ + s7_pointer s7_random_state(s7_scheme * sc, s7_pointer seed); /* (random-state seed) */ + s7_pointer s7_random_state_to_list(s7_scheme * sc, s7_pointer args); /* (random-state->list r) */ + void s7_set_default_random_state(s7_scheme * sc, s7_int seed, + s7_int carry); + bool s7_is_random_state(s7_pointer p); /* (random-state? p) */ + + bool s7_is_complex(s7_pointer arg); /* (complex? arg) */ + s7_pointer s7_make_complex(s7_scheme * sc, s7_double a, s7_double b); /* returns the Scheme object a+bi */ + s7_double s7_real_part(s7_pointer z); /* (real-part z) */ + s7_double s7_imag_part(s7_pointer z); /* (imag-part z) */ + char *s7_number_to_string(s7_scheme * sc, s7_pointer obj, s7_int radix); /* (number->string obj radix) */ + + bool s7_is_vector(s7_pointer p); /* (vector? p) */ + s7_int s7_vector_length(s7_pointer vec); /* (vector-length vec) */ + s7_int s7_vector_rank(s7_pointer vect); /* number of dimensions in vect */ + s7_int s7_vector_dimension(s7_pointer vec, s7_int dim); + s7_pointer *s7_vector_elements(s7_pointer vec); /* a pointer to the array of s7_pointers */ + s7_int *s7_int_vector_elements(s7_pointer vec); + s7_double *s7_float_vector_elements(s7_pointer vec); + bool s7_is_float_vector(s7_pointer p); /* (float-vector? p) */ + bool s7_is_int_vector(s7_pointer p); /* (int-vector? p) */ + + s7_pointer s7_vector_ref(s7_scheme * sc, s7_pointer vec, s7_int index); /* (vector-ref vec index) */ + s7_pointer s7_vector_set(s7_scheme * sc, s7_pointer vec, s7_int index, s7_pointer a); /* (vector-set! vec index a) */ + s7_pointer s7_vector_ref_n(s7_scheme * sc, s7_pointer vector, s7_int indices, ...); /* multidimensional vector-ref */ + s7_pointer s7_vector_set_n(s7_scheme * sc, s7_pointer vector, s7_pointer value, s7_int indices, ...); /* multidimensional vector-set! */ + s7_int s7_vector_dimensions(s7_pointer vec, s7_int * dims, s7_int dims_size); /* vector dimensions */ + s7_int s7_vector_offsets(s7_pointer vec, s7_int * offs, + s7_int offs_size); + + s7_int s7_int_vector_ref(s7_pointer vec, s7_int index); + s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value); + s7_double s7_float_vector_ref(s7_pointer vec, s7_int index); + s7_double s7_float_vector_set(s7_pointer vec, s7_int index, + s7_double value); + + s7_pointer s7_make_vector(s7_scheme * sc, s7_int len); /* (make-vector len) */ + s7_pointer s7_make_int_vector(s7_scheme * sc, s7_int len, s7_int dims, + s7_int * dim_info); + s7_pointer s7_make_float_vector(s7_scheme * sc, s7_int len, + s7_int dims, s7_int * dim_info); + s7_pointer s7_make_normal_vector(s7_scheme * sc, s7_int len, s7_int dims, s7_int * dim_info); /* make-vector but possibly multidimensional */ + s7_pointer s7_make_float_vector_wrapper(s7_scheme * sc, s7_int len, + s7_double * data, s7_int dims, + s7_int * dim_info, + bool free_data); + s7_pointer s7_make_and_fill_vector(s7_scheme * sc, s7_int len, s7_pointer fill); /* (make-vector len fill) */ + + void s7_vector_fill(s7_scheme * sc, s7_pointer vec, s7_pointer obj); /* (vector-fill! vec obj) */ + s7_pointer s7_vector_copy(s7_scheme * sc, s7_pointer old_vect); + s7_pointer s7_vector_to_list(s7_scheme * sc, s7_pointer vect); /* (vector->list vec) */ + /* + * (vect i) is the same as (vector-ref vect i) + * (set! (vect i) x) is the same as (vector-set! vect i x) + * (vect i j k) accesses the 3-dimensional vect + * (set! (vect i j k) x) sets that element (vector-ref and vector-set! can also be used) + * (make-vector (list 2 3 4)) returns a 3-dimensional vector with the given dimension sizes + * (make-vector '(2 3) 1.0) returns a 2-dim vector with all elements set to 1.0 + */ + + bool s7_is_hash_table(s7_pointer p); /* (hash-table? p) */ + s7_pointer s7_make_hash_table(s7_scheme * sc, s7_int size); /* (make-hash-table size) */ + s7_pointer s7_hash_table_ref(s7_scheme * sc, s7_pointer table, + s7_pointer key); + /* (hash-table-ref table key) */ + s7_pointer s7_hash_table_set(s7_scheme * sc, s7_pointer table, + s7_pointer key, s7_pointer value); + /* (hash-table-set! table key value) */ + s7_int s7_hash_code(s7_scheme * sc, s7_pointer obj, s7_pointer eqfunc); /* (hash-code obj [eqfunc]) */ + + s7_pointer s7_hook_functions(s7_scheme * sc, s7_pointer hook); /* (hook-functions hook) */ + s7_pointer s7_hook_set_functions(s7_scheme * sc, s7_pointer hook, s7_pointer functions); /* (set! (hook-functions hook) ...) */ + + + bool s7_is_input_port(s7_scheme * sc, s7_pointer p); /* (input-port? p) */ + bool s7_is_output_port(s7_scheme * sc, s7_pointer p); /* (output-port? p) */ + const char *s7_port_filename(s7_scheme * sc, s7_pointer x); /* (port-filename p) */ + s7_int s7_port_line_number(s7_scheme * sc, s7_pointer p); /* (port-line-number p) */ + + s7_pointer s7_current_input_port(s7_scheme * sc); /* (current-input-port) */ + s7_pointer s7_set_current_input_port(s7_scheme * sc, s7_pointer p); /* (set-current-input-port) */ + s7_pointer s7_current_output_port(s7_scheme * sc); /* (current-output-port) */ + s7_pointer s7_set_current_output_port(s7_scheme * sc, s7_pointer p); /* (set-current-output-port) */ + s7_pointer s7_current_error_port(s7_scheme * sc); /* (current-error-port) */ + s7_pointer s7_set_current_error_port(s7_scheme * sc, s7_pointer port); /* (set-current-error-port port) */ + void s7_close_input_port(s7_scheme * sc, s7_pointer p); /* (close-input-port p) */ + void s7_close_output_port(s7_scheme * sc, s7_pointer p); /* (close-output-port p) */ + s7_pointer s7_open_input_file(s7_scheme * sc, const char *name, + const char *mode); + /* (open-input-file name mode) */ + s7_pointer s7_open_output_file(s7_scheme * sc, const char *name, + const char *mode); + /* (open-output-file name mode) */ + /* mode here is an optional C style flag, "a" for "alter", etc ("r" is the input default, "w" is the output default) */ + s7_pointer s7_open_input_string(s7_scheme * sc, + const char *input_string); + /* (open-input-string str) */ + s7_pointer s7_open_output_string(s7_scheme * sc); /* (open-output-string) */ + const char *s7_get_output_string(s7_scheme * sc, s7_pointer out_port); /* (get-output-string port) -- current contents of output string */ + /* don't free the string */ + s7_pointer s7_output_string(s7_scheme * sc, s7_pointer p); /* same but returns an s7 string */ + bool s7_flush_output_port(s7_scheme * sc, s7_pointer p); /* (flush-output-port port) */ + + typedef enum { S7_READ, S7_READ_CHAR, S7_READ_LINE, S7_PEEK_CHAR, + S7_IS_CHAR_READY, S7_NUM_READ_CHOICES + } s7_read_t; + s7_pointer s7_open_output_function(s7_scheme * sc, + void (*function)(s7_scheme * sc, + uint8_t c, + s7_pointer port)); + s7_pointer s7_open_input_function(s7_scheme * sc, + s7_pointer(*function) (s7_scheme * + sc, + s7_read_t + read_choice, + s7_pointer + port)); + + s7_pointer s7_read_char(s7_scheme * sc, s7_pointer port); /* (read-char port) */ + s7_pointer s7_peek_char(s7_scheme * sc, s7_pointer port); /* (peek-char port) */ + s7_pointer s7_read(s7_scheme * sc, s7_pointer port); /* (read port) */ + void s7_newline(s7_scheme * sc, s7_pointer port); /* (newline port) */ + s7_pointer s7_write_char(s7_scheme * sc, s7_pointer c, s7_pointer port); /* (write-char c port) */ + s7_pointer s7_write(s7_scheme * sc, s7_pointer obj, s7_pointer port); /* (write obj port) */ + s7_pointer s7_display(s7_scheme * sc, s7_pointer obj, s7_pointer port); /* (display obj port) */ + const char *s7_format(s7_scheme * sc, s7_pointer args); /* (format ... */ + + + bool s7_is_syntax(s7_pointer p); /* (syntax? p) */ + bool s7_is_symbol(s7_pointer p); /* (symbol? p) */ + const char *s7_symbol_name(s7_pointer p); /* (symbol->string p) -- don't free the string */ + s7_pointer s7_make_symbol(s7_scheme * sc, const char *name); /* (string->symbol name) */ + s7_pointer s7_gensym(s7_scheme * sc, const char *prefix); /* (gensym prefix) */ + + bool s7_is_keyword(s7_pointer obj); /* (keyword? obj) */ + s7_pointer s7_make_keyword(s7_scheme * sc, const char *key); /* (string->keyword key) */ + s7_pointer s7_keyword_to_symbol(s7_scheme * sc, s7_pointer key); /* (keyword->symbol key) */ + + s7_pointer s7_rootlet(s7_scheme * sc); /* (rootlet) */ + s7_pointer s7_shadow_rootlet(s7_scheme * sc); + s7_pointer s7_set_shadow_rootlet(s7_scheme * sc, s7_pointer let); + s7_pointer s7_curlet(s7_scheme * sc); /* (curlet) */ + s7_pointer s7_set_curlet(s7_scheme * sc, s7_pointer e); /* returns previous curlet */ + s7_pointer s7_outlet(s7_scheme * sc, s7_pointer e); /* (outlet e) */ + s7_pointer s7_sublet(s7_scheme * sc, s7_pointer env, s7_pointer bindings); /* (sublet e ...) */ + s7_pointer s7_inlet(s7_scheme * sc, s7_pointer bindings); /* (inlet ...) */ + s7_pointer s7_varlet(s7_scheme * sc, s7_pointer env, s7_pointer symbol, s7_pointer value); /* (varlet env symbol value) */ + s7_pointer s7_let_to_list(s7_scheme * sc, s7_pointer env); /* (let->list env) */ + bool s7_is_let(s7_pointer e); /* )let? e) */ + s7_pointer s7_let_ref(s7_scheme * sc, s7_pointer env, s7_pointer sym); /* (let-ref e sym) */ + s7_pointer s7_let_set(s7_scheme * sc, s7_pointer env, s7_pointer sym, s7_pointer val); /* (let-set! e sym val) */ + s7_pointer s7_openlet(s7_scheme * sc, s7_pointer e); /* (openlet e) */ + bool s7_is_openlet(s7_pointer e); /* (openlet? e) */ + s7_pointer s7_method(s7_scheme * sc, s7_pointer obj, + s7_pointer method); + +/* *s7* */ + s7_pointer s7_let_field_ref(s7_scheme * sc, s7_pointer sym); /* (*s7* sym) */ + s7_pointer s7_let_field_set(s7_scheme * sc, s7_pointer sym, s7_pointer new_value); /* (set! (*s7* sym) new_value) */ + + + s7_pointer s7_name_to_value(s7_scheme * sc, const char *name); /* name's value in the current environment (after turning name into a symbol) */ + s7_pointer s7_symbol_table_find_name(s7_scheme * sc, const char *name); + s7_pointer s7_symbol_value(s7_scheme * sc, s7_pointer sym); + s7_pointer s7_symbol_set_value(s7_scheme * sc, s7_pointer sym, + s7_pointer val); + s7_pointer s7_symbol_local_value(s7_scheme * sc, s7_pointer sym, + s7_pointer local_env); + bool s7_for_each_symbol_name(s7_scheme * sc, + bool (*symbol_func)(const char + *symbol_name, + void *data), + void *data); + bool s7_for_each_symbol(s7_scheme * sc, + bool (*symbol_func)(const char *symbol_name, + void *data), void *data); + + /* these access the current environment and symbol table, providing + * a symbol's current binding (s7_name_to_value takes the symbol name as a char*, + * s7_symbol_value takes the symbol itself, s7_symbol_set_value changes the + * current binding, and s7_symbol_local_value uses the environment passed + * as its third argument). + * + * To iterate over the complete symbol table, use s7_for_each_symbol_name, + * and s7_for_each_symbol. Both call 'symbol_func' on each symbol, passing it + * the symbol or symbol name, and the uninterpreted 'data' pointer. + * the current binding. The for-each loop stops if the symbol_func returns true, + * or at the end of the table. + */ + + s7_pointer s7_dynamic_wind(s7_scheme * sc, s7_pointer init, + s7_pointer body, s7_pointer finish); + + bool s7_is_immutable(s7_pointer p); + s7_pointer s7_immutable(s7_pointer p); + + void s7_define(s7_scheme * sc, s7_pointer env, s7_pointer symbol, + s7_pointer value); + bool s7_is_defined(s7_scheme * sc, const char *name); + s7_pointer s7_define_variable(s7_scheme * sc, const char *name, + s7_pointer value); + s7_pointer s7_define_variable_with_documentation(s7_scheme * sc, + const char *name, + s7_pointer value, + const char *help); + s7_pointer s7_define_constant(s7_scheme * sc, const char *name, + s7_pointer value); + s7_pointer s7_define_constant_with_documentation(s7_scheme * sc, + const char *name, + s7_pointer value, + const char *help); + s7_pointer s7_define_constant_with_environment(s7_scheme * sc, + s7_pointer envir, + const char *name, + s7_pointer value); + /* These functions add a symbol and its binding to either the top-level environment + * or the 'env' passed as the second argument to s7_define. + * + * s7_define_variable(sc, "*features*", s7_nil(sc)); + * + * in s7.c is equivalent to the top level form + * + * (define *features* ()) + * + * s7_define_variable is simply s7_define with string->symbol and the global environment. + * s7_define_constant is s7_define but makes its "definee" immutable. + * s7_define is equivalent to define in Scheme. + */ + + bool s7_is_function(s7_pointer p); + bool s7_is_procedure(s7_pointer x); /* (procedure? x) */ + bool s7_is_macro(s7_scheme * sc, s7_pointer x); /* (macro? x) */ + s7_pointer s7_closure_body(s7_scheme * sc, s7_pointer p); + s7_pointer s7_closure_let(s7_scheme * sc, s7_pointer p); + s7_pointer s7_closure_args(s7_scheme * sc, s7_pointer p); + s7_pointer s7_funclet(s7_scheme * sc, s7_pointer p); /* (funclet x) */ + bool s7_is_aritable(s7_scheme * sc, s7_pointer x, s7_int args); /* (aritable? x args) */ + s7_pointer s7_arity(s7_scheme * sc, s7_pointer x); /* (arity x) */ + const char *s7_help(s7_scheme * sc, s7_pointer obj); /* (help obj) */ + s7_pointer s7_make_continuation(s7_scheme * sc); /* call/cc... (see example below) */ + + const char *s7_documentation(s7_scheme * sc, s7_pointer p); /* (documentation x) if any (don't free the string) */ + const char *s7_set_documentation(s7_scheme * sc, s7_pointer p, + const char *new_doc); + s7_pointer s7_setter(s7_scheme * sc, s7_pointer obj); /* (setter obj) */ + s7_pointer s7_set_setter(s7_scheme * sc, s7_pointer p, s7_pointer setter); /* (set! (setter p) setter) */ + s7_pointer s7_signature(s7_scheme * sc, s7_pointer func); /* (signature obj) */ + s7_pointer s7_make_signature(s7_scheme * sc, s7_int len, ...); /* procedure-signature data */ + s7_pointer s7_make_circular_signature(s7_scheme * sc, + s7_int cycle_point, s7_int len, + ...); + +/* possibly unsafe functions: */ + s7_pointer s7_make_function(s7_scheme * sc, const char *name, + s7_function fnc, s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc); + +/* safe functions: */ + s7_pointer s7_make_safe_function(s7_scheme * sc, const char *name, + s7_function fnc, s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc); + s7_pointer s7_make_typed_function(s7_scheme * sc, const char *name, + s7_function f, s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc, + s7_pointer signature); + +/* arglist or body possibly unsafe: */ + s7_pointer s7_define_function(s7_scheme * sc, const char *name, + s7_function fnc, s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc); + +/* arglist and body safe: */ + s7_pointer s7_define_safe_function(s7_scheme * sc, const char *name, + s7_function fnc, + s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc); + s7_pointer s7_define_typed_function(s7_scheme * sc, const char *name, + s7_function fnc, + s7_int required_args, + s7_int optional_args, + bool rest_arg, const char *doc, + s7_pointer signature); + +/* arglist unsafe or body unsafe: */ + s7_pointer s7_define_unsafe_typed_function(s7_scheme * sc, + const char *name, + s7_function fnc, + s7_int required_args, + s7_int optional_args, + bool rest_arg, + const char *doc, + s7_pointer signature); + +/* arglist safe, body possibly unsafe: */ + s7_pointer s7_define_semisafe_typed_function(s7_scheme * sc, + const char *name, + s7_function fnc, + s7_int required_args, + s7_int optional_args, + bool rest_arg, + const char *doc, + s7_pointer signature); + + s7_pointer s7_make_function_star(s7_scheme * sc, const char *name, + s7_function fnc, const char *arglist, + const char *doc); + s7_pointer s7_make_safe_function_star(s7_scheme * sc, const char *name, + s7_function fnc, + const char *arglist, + const char *doc); + void s7_define_function_star(s7_scheme * sc, const char *name, + s7_function fnc, const char *arglist, + const char *doc); + void s7_define_safe_function_star(s7_scheme * sc, const char *name, + s7_function fnc, const char *arglist, + const char *doc); + void s7_define_typed_function_star(s7_scheme * sc, const char *name, + s7_function fnc, + const char *arglist, + const char *doc, + s7_pointer signature); + s7_pointer s7_define_macro(s7_scheme * sc, const char *name, + s7_function fnc, s7_int required_args, + s7_int optional_args, bool rest_arg, + const char *doc); + + /* s7_make_function creates a Scheme function object from the s7_function 'fnc'. + * Its name (for s7_describe_object) is 'name', it requires 'required_args' arguments, + * can accept 'optional_args' other arguments, and if 'rest_arg' is true, it accepts + * a "rest" argument (a list of all the trailing arguments). The function's documentation + * is 'doc'. + * + * s7_define_function is the same as s7_make_function, but it also adds 'name' (as a symbol) to the + * global (top-level) environment, with the function as its value. For example, the Scheme + * function 'car' is essentially: + * + * s7_pointer g_car(s7_scheme *sc, s7_pointer args) {return(s7_car(s7_car(args)));} + * + * then bound to the name "car": + * + * s7_define_function(sc, "car", g_car, 1, 0, false, "(car obj)"); + * one required arg, no optional arg, no "rest" arg + * + * s7_is_function returns true if its argument is a function defined in this manner. + * s7_apply_function applies the function (the result of s7_make_function) to the arguments. + * + * s7_define_macro defines a Scheme macro; its arguments are not evaluated (unlike a function), + * but its returned value (assumed to be some sort of Scheme expression) is evaluated. + * + * Use the "unsafe" definer if the function might call the evaluator itself in some way (s7_apply_function for example), + * or messes with s7's stack. + */ + + /* In s7, (define* (name . args) body) or (define name (lambda* args body)) + * define a function that takes optional (keyword) named arguments. + * The "args" is a list that can contain either names (normal arguments), + * or lists of the form (name default-value), in any order. When called, + * the names are bound to their default values (or #f), then the function's + * current arglist is scanned. Any name that occurs as a keyword (":name") + * precedes that argument's new value. Otherwise, as values occur, they + * are plugged into the environment based on their position in the arglist + * (as normal for a function). So, + * + * (define* (hi a (b 32) (c "hi")) (list a b c)) + * (hi 1) -> '(1 32 "hi") + * (hi :b 2 :a 3) -> '(3 2 "hi") + * (hi 3 2 1) -> '(3 2 1) + * + * :rest causes its argument to be bound to the rest of the arguments at that point. + * + * The C connection to this takes the function name, the C function to call, the argument + * list as written in Scheme, and the documentation string. s7 makes sure the arguments + * are ordered correctly and have the specified defaults before calling the C function. + * s7_define_function_star(sc, "a-func", a_func, "arg1 (arg2 32)", "an example of C define*"); + * Now (a-func :arg1 2) calls the C function a_func(2, 32). See the example program in s7.html. + * + * In s7 Scheme, define* can be used just for its optional arguments feature, but that is + * included in s7_define_function. s7_define_function_star implements keyword arguments + * for C-level functions (as well as optional/rest arguments). + */ + + s7_pointer s7_apply_function(s7_scheme * sc, s7_pointer fnc, + s7_pointer args); + s7_pointer s7_apply_function_star(s7_scheme * sc, s7_pointer fnc, + s7_pointer args); + + s7_pointer s7_call(s7_scheme * sc, s7_pointer func, s7_pointer args); + s7_pointer s7_call_with_location(s7_scheme * sc, s7_pointer func, + s7_pointer args, const char *caller, + const char *file, s7_int line); + s7_pointer s7_call_with_catch(s7_scheme * sc, s7_pointer tag, + s7_pointer body, + s7_pointer error_handler); + + /* s7_call takes a Scheme function (e.g. g_car above), and applies it to 'args' (a list of arguments) returning the result. + * s7_integer(s7_call(s7, g_car, s7_cons(s7, s7_make_integer(s7, 123), s7_nil(s7)))); + * returns 123. + * + * s7_call_with_location passes some information to the error handler. + * s7_call makes sure some sort of catch exists if an error occurs during the call, but + * s7_apply_function does not -- it assumes the catch has been set up already. + * s7_call_with_catch wraps an explicit catch around a function call ("body" above); + * s7_call_with_catch(sc, tag, body, err) is equivalent to (catch tag body err). + */ + + bool s7_is_dilambda(s7_pointer obj); + s7_pointer s7_dilambda(s7_scheme * sc, + const char *name, + s7_pointer(*getter) (s7_scheme * sc, + s7_pointer args), + s7_int get_req_args, s7_int get_opt_args, + s7_pointer(*setter) (s7_scheme * sc, + s7_pointer args), + s7_int set_req_args, s7_int set_opt_args, + const char *documentation); + s7_pointer s7_typed_dilambda(s7_scheme * sc, const char *name, + s7_pointer(*getter) (s7_scheme * sc, + s7_pointer args), + s7_int get_req_args, s7_int get_opt_args, + s7_pointer(*setter) (s7_scheme * sc, + s7_pointer args), + s7_int set_req_args, s7_int set_opt_args, + const char *documentation, + s7_pointer get_sig, s7_pointer set_sig); + s7_pointer s7_dilambda_with_environment(s7_scheme * sc, + s7_pointer envir, + const char *name, + s7_pointer(*getter) (s7_scheme + * sc, + s7_pointer + args), + s7_int get_req_args, + s7_int get_opt_args, + s7_pointer(*setter) (s7_scheme + * sc, + s7_pointer + args), + s7_int set_req_args, + s7_int set_opt_args, + const char *documentation); + + s7_pointer s7_values(s7_scheme * sc, s7_pointer args); /* (values ...) */ + + + s7_pointer s7_make_iterator(s7_scheme * sc, s7_pointer e); /* (make-iterator e) */ + bool s7_is_iterator(s7_pointer obj); /* (iterator? obj) */ + bool s7_iterator_is_at_end(s7_scheme * sc, s7_pointer obj); /* (iterator-at-end? obj) */ + s7_pointer s7_iterate(s7_scheme * sc, s7_pointer iter); /* (iterate iter) */ + + s7_pointer s7_copy(s7_scheme * sc, s7_pointer args); /* (copy ...) */ + s7_pointer s7_fill(s7_scheme * sc, s7_pointer args); /* (fill! ...) */ + s7_pointer s7_type_of(s7_scheme * sc, s7_pointer arg); /* (type-of arg) */ + + + +/* -------------------------------------------------------------------------------- */ +/* c types/objects */ + + void s7_mark(s7_pointer p); + + bool s7_is_c_object(s7_pointer p); + s7_int s7_c_object_type(s7_pointer obj); + void *s7_c_object_value(s7_pointer obj); + void *s7_c_object_value_checked(s7_pointer obj, s7_int type); + s7_pointer s7_make_c_object(s7_scheme * sc, s7_int type, void *value); + s7_pointer s7_make_c_object_with_let(s7_scheme * sc, s7_int type, + void *value, s7_pointer let); + s7_pointer s7_make_c_object_without_gc(s7_scheme * sc, s7_int type, + void *value); + s7_pointer s7_c_object_let(s7_pointer obj); + s7_pointer s7_c_object_set_let(s7_scheme * sc, s7_pointer obj, + s7_pointer e); +/* the "let" in s7_make_c_object_with_let and s7_c_object_set_let needs to be GC protected by marking it in the c_object's mark function */ + + s7_int s7_make_c_type(s7_scheme * sc, const char *name); /* create a new c_object type */ + +/* old style free/mark/equal */ + void s7_c_type_set_free(s7_scheme * sc, s7_int tag, + void (*gc_free)(void *value)); + void s7_c_type_set_mark(s7_scheme * sc, s7_int tag, + void (*mark)(void *value)); + void s7_c_type_set_equal(s7_scheme * sc, s7_int tag, + bool (*equal)(void *value1, void *value2)); + +/* new style free/mark/equal and equivalent */ + void s7_c_type_set_gc_free(s7_scheme * sc, s7_int tag, s7_pointer(*gc_free) (s7_scheme * sc, s7_pointer obj)); /* free c_object function, new style */ + void s7_c_type_set_gc_mark(s7_scheme * sc, s7_int tag, s7_pointer(*mark) (s7_scheme * sc, s7_pointer obj)); /* mark function, new style */ + void s7_c_type_set_is_equal(s7_scheme * sc, s7_int tag, + s7_pointer(*is_equal) (s7_scheme * sc, + s7_pointer args)); + void s7_c_type_set_is_equivalent(s7_scheme * sc, s7_int tag, + s7_pointer(*is_equivalent) (s7_scheme + * sc, + s7_pointer + args)); + + void s7_c_type_set_ref(s7_scheme * sc, s7_int tag, + s7_pointer(*ref) (s7_scheme * sc, + s7_pointer args)); + void s7_c_type_set_set(s7_scheme * sc, s7_int tag, + s7_pointer(*set) (s7_scheme * sc, + s7_pointer args)); + void s7_c_type_set_length(s7_scheme * sc, s7_int tag, + s7_pointer(*length) (s7_scheme * sc, + s7_pointer args)); + void s7_c_type_set_copy(s7_scheme * sc, s7_int tag, + s7_pointer(*copy) (s7_scheme * sc, + s7_pointer args)); + void s7_c_type_set_fill(s7_scheme * sc, s7_int tag, + s7_pointer(*fill) (s7_scheme * sc, + s7_pointer args)); + void s7_c_type_set_reverse(s7_scheme * sc, s7_int tag, + s7_pointer(*reverse) (s7_scheme * sc, + s7_pointer args)); + void s7_c_type_set_to_list(s7_scheme * sc, s7_int tag, + s7_pointer(*to_list) (s7_scheme * sc, + s7_pointer args)); + void s7_c_type_set_to_string(s7_scheme * sc, s7_int tag, + s7_pointer(*to_string) (s7_scheme * sc, + s7_pointer args)); + void s7_c_type_set_getter(s7_scheme * sc, s7_int tag, + s7_pointer getter); + void s7_c_type_set_setter(s7_scheme * sc, s7_int tag, + s7_pointer setter); +/* For the copy function, either the first or second argument can be a c-object of the given type. */ + + /* These functions create a new Scheme object type. There is a simple example in s7.html. + * + * s7_make_c_type creates a new C-based type for Scheme. It returns an s7_int "tag" used to indentify this type elsewhere. + * The functions associated with this type are set via s7_c_type_set*: + * + * free: the function called when an object of this type is about to be garbage collected + * mark: called during the GC mark pass -- you should call s7_mark + * on any embedded s7_pointer associated with the object (including its "let") to protect if from the GC. + * gc_mark and gc_free are new forms of mark and free, taking the c_object s7_pointer rather than its void* value + * equal: compare two objects of this type; (equal? obj1 obj2) -- this is the old form + * is_equal: compare objects as in equal? -- this is the new form of equal? + * is_equivalent: compare objects as in equivalent? + * ref: a function that is called whenever an object of this type + * occurs in the function position (at the car of a list; the rest of the list + * is passed to the ref function as the arguments: (obj ...)) + * set: a function that is called whenever an object of this type occurs as + * the target of a generalized set! (set! (obj ...) val) + * length: the function called when the object is asked what its length is. + * copy: the function called when a copy of the object is needed. + * fill: the function called to fill the object with some value. + * reverse: similarly... + * to_string: object->string for an object of this type + * getter/setter: these help the optimizer handle applicable c-objects (see s7test.scm for an example) + * + * s7_is_c_object returns true if 'p' is a c_object + * s7_c_object_type returns the c_object's type (the s7_int passed to s7_make_c_object) + * s7_c_object_value returns the value bound to that c_object (the void *value of s7_make_c_object) + * s7_make_c_object creates a new Scheme entity of the given type with the given (uninterpreted) value + * s7_mark marks any Scheme c_object as in-use (use this in the mark function to mark + * any embedded s7_pointer variables). + */ + +/* -------------------------------------------------------------------------------- */ +/* the new clm optimizer! this time for sure! + * d=double, i=integer, v=c_object, p=s7_pointer + * first return type, then arg types, d_vd -> returns double takes c_object and double (i.e. a standard clm generator) + * + * It is possible to tell s7 to call a foreign function directly, without any scheme-related + * overhead. The call needs to take the form of one of the s7_*_t functions in s7.h. For example, + * one way to call + is to pass it two s7_double arguments and get an s7_double back. This is the + * s7_d_dd_t function (the first letter gives the return type, the rest give successive argument types). + * We tell s7 about it via s7_set_d_dd_function. Whenever s7's optimizer encounters + with two arguments + * that it (the optimizer) knows are s7_doubles, in a context where an s7_double result is expected, + * s7 calls the s7_d_dd_t function directly without consing a list of arguments, and without + * wrapping up the result as a scheme cell. + */ + + s7_pfunc s7_optimize(s7_scheme * sc, s7_pointer expr); + + typedef s7_double(*s7_float_function) (s7_scheme * sc); + s7_float_function s7_float_optimize(s7_scheme * sc, s7_pointer expr); + + typedef s7_double(*s7_d_t) (void); + void s7_set_d_function(s7_scheme * sc, s7_pointer f, s7_d_t df); + s7_d_t s7_d_function(s7_pointer f); + + typedef s7_double(*s7_d_d_t) (s7_double x); + void s7_set_d_d_function(s7_scheme * sc, s7_pointer f, s7_d_d_t df); + s7_d_d_t s7_d_d_function(s7_pointer f); + + typedef s7_double(*s7_d_dd_t) (s7_double x1, s7_double x2); + void s7_set_d_dd_function(s7_scheme * sc, s7_pointer f, s7_d_dd_t df); + s7_d_dd_t s7_d_dd_function(s7_pointer f); + + typedef s7_double(*s7_d_ddd_t) (s7_double x1, s7_double x2, + s7_double x3); + void s7_set_d_ddd_function(s7_scheme * sc, s7_pointer f, + s7_d_ddd_t df); + s7_d_ddd_t s7_d_ddd_function(s7_pointer f); + + typedef s7_double(*s7_d_dddd_t) (s7_double x1, s7_double x2, + s7_double x3, s7_double x4); + void s7_set_d_dddd_function(s7_scheme * sc, s7_pointer f, + s7_d_dddd_t df); + s7_d_dddd_t s7_d_dddd_function(s7_pointer f); + + typedef s7_double(*s7_d_v_t) (void *v); + void s7_set_d_v_function(s7_scheme * sc, s7_pointer f, s7_d_v_t df); + s7_d_v_t s7_d_v_function(s7_pointer f); + + typedef s7_double(*s7_d_vd_t) (void *v, s7_double d); + void s7_set_d_vd_function(s7_scheme * sc, s7_pointer f, s7_d_vd_t df); + s7_d_vd_t s7_d_vd_function(s7_pointer f); + + typedef s7_double(*s7_d_vdd_t) (void *v, s7_double x1, s7_double x2); + void s7_set_d_vdd_function(s7_scheme * sc, s7_pointer f, + s7_d_vdd_t df); + s7_d_vdd_t s7_d_vdd_function(s7_pointer f); + + typedef s7_double(*s7_d_vid_t) (void *v, s7_int i, s7_double d); + void s7_set_d_vid_function(s7_scheme * sc, s7_pointer f, + s7_d_vid_t df); + s7_d_vid_t s7_d_vid_function(s7_pointer f); + + typedef s7_double(*s7_d_p_t) (s7_pointer p); + void s7_set_d_p_function(s7_scheme * sc, s7_pointer f, s7_d_p_t df); + s7_d_p_t s7_d_p_function(s7_pointer f); + + typedef s7_double(*s7_d_pd_t) (s7_pointer v, s7_double x); + void s7_set_d_pd_function(s7_scheme * sc, s7_pointer f, s7_d_pd_t df); + s7_d_pd_t s7_d_pd_function(s7_pointer f); + + typedef s7_double(*s7_d_7pi_t) (s7_scheme * sc, s7_pointer v, + s7_int i); + void s7_set_d_7pi_function(s7_scheme * sc, s7_pointer f, + s7_d_7pi_t df); + s7_d_7pi_t s7_d_7pi_function(s7_pointer f); + + typedef s7_double(*s7_d_7pid_t) (s7_scheme * sc, s7_pointer v, + s7_int i, s7_double d); + void s7_set_d_7pid_function(s7_scheme * sc, s7_pointer f, + s7_d_7pid_t df); + s7_d_7pid_t s7_d_7pid_function(s7_pointer f); + + typedef s7_double(*s7_d_id_t) (s7_int i, s7_double d); + void s7_set_d_id_function(s7_scheme * sc, s7_pointer f, s7_d_id_t df); + s7_d_id_t s7_d_id_function(s7_pointer f); + + typedef s7_double(*s7_d_ip_t) (s7_int i, s7_pointer p); + void s7_set_d_ip_function(s7_scheme * sc, s7_pointer f, s7_d_ip_t df); + s7_d_ip_t s7_d_ip_function(s7_pointer f); + + typedef s7_int(*s7_i_i_t) (s7_int x); + void s7_set_i_i_function(s7_scheme * sc, s7_pointer f, s7_i_i_t df); + s7_i_i_t s7_i_i_function(s7_pointer f); + + typedef s7_int(*s7_i_7d_t) (s7_scheme * sc, s7_double x); + void s7_set_i_7d_function(s7_scheme * sc, s7_pointer f, s7_i_7d_t df); + s7_i_7d_t s7_i_7d_function(s7_pointer f); + + typedef s7_int(*s7_i_ii_t) (s7_int i1, s7_int i2); + void s7_set_i_ii_function(s7_scheme * sc, s7_pointer f, s7_i_ii_t df); + s7_i_ii_t s7_i_ii_function(s7_pointer f); + + typedef s7_int(*s7_i_7p_t) (s7_scheme * sc, s7_pointer p); + void s7_set_i_7p_function(s7_scheme * sc, s7_pointer f, s7_i_7p_t df); + s7_i_7p_t s7_i_7p_function(s7_pointer f); + + typedef bool (*s7_b_p_t)(s7_pointer p); + void s7_set_b_p_function(s7_scheme * sc, s7_pointer f, s7_b_p_t df); + s7_b_p_t s7_b_p_function(s7_pointer f); + + typedef s7_pointer(*s7_p_d_t) (s7_scheme * sc, s7_double x); + void s7_set_p_d_function(s7_scheme * sc, s7_pointer f, s7_p_d_t df); + s7_p_d_t s7_p_d_function(s7_pointer f); + +/* Here is an example of using these functions; more extensive examples are in clm2xen.c in sndlib, and in s7.c. + * (This example comes from a HackerNews discussion): + * plus.c: + * -------- + * #include "s7.h" + * + * s7_pointer g_plusone(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, s7_integer(s7_car(args)) + 1));} + * s7_int plusone(s7_int x) {return(x + 1);} + * + * void plusone_init(s7_scheme *sc) + * { + * s7_define_safe_function(sc, "plusone", g_plusone, 1, 0, false, ""); + * s7_set_i_i_function(sc, s7_name_to_value(sc, "plusone"), plusone); + * } + * -------- + * gcc -c plus.c -fPIC -O2 -lm + * gcc plus.o -shared -o plus.so -ldl -lm -Wl,-export-dynamic + * repl + * <1> (load "plus.so" (inlet 'init_func 'plusone_init)) + * -------- + */ + +/* -------------------------------------------------------------------------------- */ + +/* maybe remove these? */ + s7_pointer s7_slot(s7_scheme * sc, s7_pointer symbol); + s7_pointer s7_slot_value(s7_pointer slot); + s7_pointer s7_slot_set_value(s7_scheme * sc, s7_pointer slot, + s7_pointer value); + s7_pointer s7_make_slot(s7_scheme * sc, s7_pointer env, + s7_pointer symbol, s7_pointer value); + void s7_slot_set_real_value(s7_scheme * sc, s7_pointer slot, + s7_double value); + +/* -------------------------------------------------------------------------------- */ + + /* these will be deprecated and removed eventually */ + s7_pointer s7_apply_1(s7_scheme * sc, s7_pointer args, + s7_pointer(*f1) (s7_pointer a1)); + s7_pointer s7_apply_2(s7_scheme * sc, s7_pointer args, + s7_pointer(*f2) (s7_pointer a1, s7_pointer a2)); + s7_pointer s7_apply_3(s7_scheme * sc, s7_pointer args, + s7_pointer(*f3) (s7_pointer a1, s7_pointer a2, + s7_pointer a3)); + s7_pointer s7_apply_4(s7_scheme * sc, s7_pointer args, + s7_pointer(*f4) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4)); + s7_pointer s7_apply_5(s7_scheme * sc, s7_pointer args, + s7_pointer(*f5) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5)); + s7_pointer s7_apply_6(s7_scheme * sc, s7_pointer args, + s7_pointer(*f6) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6)); + s7_pointer s7_apply_7(s7_scheme * sc, s7_pointer args, + s7_pointer(*f7) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6, + s7_pointer a7)); + s7_pointer s7_apply_8(s7_scheme * sc, s7_pointer args, + s7_pointer(*f8) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6, + s7_pointer a7, s7_pointer a8)); + s7_pointer s7_apply_9(s7_scheme * sc, s7_pointer args, + s7_pointer(*f9) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6, + s7_pointer a7, s7_pointer a8, + s7_pointer a9)); + + s7_pointer s7_apply_n_1(s7_scheme * sc, s7_pointer args, + s7_pointer(*f1) (s7_pointer a1)); + s7_pointer s7_apply_n_2(s7_scheme * sc, s7_pointer args, + s7_pointer(*f2) (s7_pointer a1, + s7_pointer a2)); + s7_pointer s7_apply_n_3(s7_scheme * sc, s7_pointer args, + s7_pointer(*f3) (s7_pointer a1, s7_pointer a2, + s7_pointer a3)); + s7_pointer s7_apply_n_4(s7_scheme * sc, s7_pointer args, + s7_pointer(*f4) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, + s7_pointer a4)); + s7_pointer s7_apply_n_5(s7_scheme * sc, s7_pointer args, + s7_pointer(*f5) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5)); + s7_pointer s7_apply_n_6(s7_scheme * sc, s7_pointer args, + s7_pointer(*f6) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, + s7_pointer a6)); + s7_pointer s7_apply_n_7(s7_scheme * sc, s7_pointer args, + s7_pointer(*f7) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6, + s7_pointer a7)); + s7_pointer s7_apply_n_8(s7_scheme * sc, s7_pointer args, + s7_pointer(*f8) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6, + s7_pointer a7, + s7_pointer a8)); + s7_pointer s7_apply_n_9(s7_scheme * sc, s7_pointer args, + s7_pointer(*f9) (s7_pointer a1, s7_pointer a2, + s7_pointer a3, s7_pointer a4, + s7_pointer a5, s7_pointer a6, + s7_pointer a7, s7_pointer a8, + s7_pointer a9)); + +#if WITH_GMP + mpfr_t *s7_big_real(s7_pointer x); + mpz_t *s7_big_integer(s7_pointer x); + mpq_t *s7_big_ratio(s7_pointer x); + mpc_t *s7_big_complex(s7_pointer x); + + bool s7_is_bignum(s7_pointer obj); + bool s7_is_big_real(s7_pointer x); + bool s7_is_big_integer(s7_pointer x); + bool s7_is_big_ratio(s7_pointer x); + bool s7_is_big_complex(s7_pointer x); + + s7_pointer s7_make_big_real(s7_scheme * sc, mpfr_t * val); + s7_pointer s7_make_big_integer(s7_scheme * sc, mpz_t * val); + s7_pointer s7_make_big_ratio(s7_scheme * sc, mpq_t * val); + s7_pointer s7_make_big_complex(s7_scheme * sc, mpc_t * val); +#endif + + +/* -------------------------------------------------------------------------------- */ + +#if (!DISABLE_DEPRECATED) + typedef s7_int s7_Int; + typedef s7_double s7_Double; + +#define s7_is_object s7_is_c_object +#define s7_object_type s7_c_object_type +#define s7_object_value s7_c_object_value +#define s7_make_object s7_make_c_object +#define s7_mark_object s7_mark +#define s7_UNSPECIFIED(Sc) s7_unspecified(Sc) +#endif + + +/* -------------------------------------------------------------------------------- + * + * s7 changes + * + * 25-Aug: s7_output_string (like s7_get_output_string, but returns an s7 string). + * 19-Jul: s7_is_random_state, s7_make_normal_vector. s7_array_to_list. + * 12-Apr: s7_optimize now returns an s7_pfunc, not an s7_function. + * 7-Apr: removed the "args" parameter from s7_float_function. added s7_make_c_object_without_gc. + * 31-Mar: vector-rank, vector-dimension. + * 17-Mar: removed deprecated nan.0 and inf.0 due to compiler stupidity. + * 25-Jan: s7_define_semisafe_typed_function. + * 6-Jan-21: s7_hash_code. + * -------- + * 14-Oct: s7_load_c_string and s7_load_c_string_with_environment. + * 10-Sep: s7_free. + * 5-Aug: s7_make_list. + * 31-July: s7_define_constant_with_environment and s7_dilambda_with_environment. + * 29-July: open-input|output-function. add S7_NUM_READ_CHOICES to s7_read_t enum and remove (unused) S7_READ_BYTE. + * 20-July: s7_c_pointer_with_type. notcurses_s7.c and nrepl.scm. *autoload-hook*. + * 8-July: s7_int|float_vector_ref|set. subvector parameter order changed. + * 17-June: removed deprecated *s7* accessors. + * 20-May: libarb_s7.c. + * 12-May: s7_is_big*. + * 6-May: added s7_scheme* initial arguments to s7_set_* opt_func calls (s7_set_d_d_function for example). + * 23-Apr: added s7_scheme* initial argument to s7_is_eqv. + * 9-Mar: move openlets to (*s7* 'openlets), s7-version to (*s7* 'version), deprecate nan.0 and inf.0. + * 17-Feb: s7_let_field_ref|set for *s7* access. *function* to replace __func__. + * deprecate __func__, s7_print_length, s7_float_format_precision, s7_set_gc_stats. + * 31-Jan: macro(*) and bacro(*) -- unnamed macros analogous to lambda(*). + * 20-Jan: debug.scm and (*s7* 'debug), trace-in, dynamic-unwind. + * remove coverlets (openlets is now a dilambda). + * 10-Jan: s7_c_type_set_gc_free and s7_c_type_set_gc_mark. + * 2-Jan-20: s7_c_type_set_is_equal and s7_c_type_set_is_equivalent. + * -------- + * 2-Nov: s7_repl. + * 30-Oct: change S7_DATE format, and start updating it to reflect s7.c. + * 30-Jul: define-expansion*. + * 12-Jul: s7_call_with_catch, s7_load now returns NULL if file not found (rather than raise an error). + * 8-July: most-positive-fixnum and most-negative-fixnum moved to *s7*. + * 23-May: added s7_scheme argument to s7_c_object_set_let. + * 19-May: s7_gc_stats renamed s7_set_gc_stats. + * 7-May: s7_gc_unprotect_via_stack and s7_gc_(un)protect_via_location. + * 22-Mar: s7_float_format_precision. port-position. port-file. + * 4-Jan-19: morally-equal? -> equivalent? + * -------- + * 29-Dec: s7_c_type_set_getter|setter (implicit c-object access). + * 23-Dec: remove hash-table, rename hash-table* to hash-table. add weak-hash-table. + * 3-Dec: deprecate s7_gc_unprotect (use s7_gc_unprotect_at). + * 21-Nov: added s7_history_enabled and s7_set_history_enabled. + * 3-Nov: removed the "value" argument from s7_for_each_symbol. + * 22-Sep: s7_list_nl. + * 12-Sep: byte-vectors can be multidimensional; homogenous vectors of any built-in type. typed hash-tables. + * 29-Jul: symbol-setter deprecated (use setter). s7_symbol_documentation (and setter) folded into s7_documentation. + * 12-Jul: changed s7_vector_dimensions|offsets. + * Added s7_scheme* arg to make_permanent_string and several of the optimizer functions. + * 3-Jul: changed make-shared-vector to subvector. + * 20-May: s7_keyword_to_symbol. + * 6-May: s7_mark_c_object -> s7_mark. + * 26-Apr: s7_c_type_set_to_list|string, s7_c_type_set_apply -> s7_c_type_set_ref, removed s7_c_type_set_set|apply_direct + * c_type length|set|ref are now s7_functions (args, not obj, etc). + * 23-Mar: s7_peek_char and s7_read_char now return s7_pointer, s7_write_char takes s7_pointer, not int32_t c + * s7_gc_protect and friends now return/take s7_int location, not uint32_t. + * removed s7_new_type_x. + * 19-Mar: int32_t -> s7_int in various functions. + * 17-Mar: deprecate s7_ulong and s7_ulong_long functions. + * 26-Jan-18: s7_set_setter. + * -------- + * 11-Dec: s7_gc_protect_via_stack + * 3-Oct: renamed procedure-signature -> signature, procedure-documentation -> documentation, and procedure-setter -> setter. + * 18-Sep: s7_immutable, s7_is_immutable. define-constant follows lexical scope now. + * s7_symbol_access -> s7_symbol_setter, symbol-access -> symbol-setter. + * 3-Aug: object->c_object name changes. + * 28-Jul: s7_make_c_pointer_with_type and s7_c_pointer_type. + * 24-Jul: int64_t rather than long long int, and various related changes. + * 18-Jul: s7_make_object_with_let. + * 8-July: s7_define_typed_function_star, s7_make_function_star. s7_apply_function_star. + * 27-June: s7_make_string_wrapper. + * 22-May: lambda* keyword arg handling changed slightly. + * 9-May: s7_history, s7_add_to_history. + * 20-Apr: s7_tree_memq (for Snd), s7_type_of, many changes for new clm optimizer. + * 10-Apr: added s7_scheme first argument to s7_iterator_is_at_end. + * 28-Mar: removed the "rf", "pf" and "if" clm optimization functions. + * s7_optimize, s7_float_optimize, s7_procedure_signature. + * 22-Feb: removed the "gf" clm optimization functions. + * 11-Feb: #e, #i, #d removed. #i(...) is an int-vector constant, #r(...) a float-vector. + * 2-Jan-17: {apply_values} -> apply-values, {list} -> list-values, and {append} -> append. + * -------- + * 23-Sep: make-keyword -> string->keyword. + * 9-Aug: s7_varlet. + * 29-Jul: s7_define_unsafe_typed_function. + * 30-May: symbol takes any number of args. make-vector no longer takes an optional fourth argument. + * 24-May: let-ref/set! check rootlet now if let is not an open let; setter for with-let. + * 20-Feb: removed last vestiges of quasiquoted vector support. + * 3-Feb: *cload-directory*. + * 14-Jan: profile.scm. Moved multiple-value-set! to stuff.scm. Setter for port-line-number. + * 7-Jan: s7_load_with_environment. + * s7_eval_c_string takes only one statement now (use begin to handle multiple statements) + * 4-Jan-16: remove s7_eval_form, change s7_eval to take its place. + * -------- + * 11-Dec: owlet error-history field if WITH_HISTORY=1 + * 6-Nov: removed :key and :optional. + * 16-Oct: s7_make_random_state -> s7_random_state. + * 16-Aug: remove s7_define_integer_function, s7_function_set_removes_temp, + * add s7_define_typed_function, s7_make_signature. + * 5-Aug: added s7_scheme* arg to s7_openlet and s7_outlet. + * 3-Jul: s7_Double -> s7_double, s7_Int -> s7_int. Removed function_chooser_data. + * 27-Jun: s7_rf_t, s7_rp_t etc. + * 19-Jun: removed the ex_parser stuff, set_step_safe, s7_ex_fallback. + * 5-May: s7_make_iterator and friends. + * 16-Apr: added s7_fill, changed arg interpretation of s7_copy, s7_dynamic_wind. + * 30-Mar: s7_eval_c_string_with_environment (repl experiment). + * 19-Mar: repl.scm. + * 28-Feb: s7_vector_print_length -> s7_print_length, set case also. + * 25-Feb: s7_closure_* funcs to replace clumsy (deprecated) s7_procedure_source. + * 29-Jan: changed args to s7_new_type_x (added s7_scheme arg, fill! takes s7_function). + * 14-Jan-15: make-iterator, iterator? + * -------- + * 26-Dec: s7_arity replaces s7_procedure_arity. s7_define_integer_function. deprecate s7_procedure_name. + * 5-Nov: s7_shadow_rootlet and s7_set_shadow_rootlet. + * 30-Aug: s7_make_safe_function (for cload.scm). + * 25-July: define and friends now return the value, not the symbol. + * procedure_with_setter -> dilambda. + * environment -> let. All the replaced names are deprecated. + * 30-June: s7_method. + * 16-June: remove unoptimize and s7_unoptimize. + * 14-May: s7_define_safe_function_star. Removed s7_catch_all. + * 22-Apr: remove s7_apply_n_10, s7_is_valid_pointer, s7_keyword_eq_p. + * 5-Mar-14: s7_heap_size, s7_gc_freed (subsequently removed). + * -------- + * 8-Nov: s7_symbol_documentation, s7_define_constant_with_documentation. + * 17-Oct: bignum-precision (procedure-with-setter) is now an integer variable named *bignum-precision*. + * 28-Aug: s7_int|float_vector_elements (homogeneous vectors), libc.scm. + * 16-Aug: ~W directive in format, make-shared-vector. + * 23-Jul: s7_autoload_set_names, libm.scm, libdl.scm, libgdbm.scm, r7rs.scm, s7libtest.scm. + * 21-Jul: s7_is_valid (replaces deprecated s7_is_valid_pointer). + * 24-Jun: some bool-related changes for Windows Visual C++, including change to s7_begin_hook. + * 3-June: s7_autoload. + * 28-May: export s7_is_provided. Added s7_scheme* arg to s7_procedure_environment. + * 21-May: equality predicate optional arg in make-hash-table. + * 14-May: glistener.c, glistener.h, s7_symbol_table_find_name (for glistener). + * 2-May: r7rs changes: flush-output-port, vector-append, read|write-string, boolean=?, symbol=?. + * start/end args for string-fill!, vector-fill!, string->list, vector->list, and copy. + * exit, emergency-exit. + * 7-Apr: removed s7_scheme* arg from s7_slot_value, added s7_is_local_variable. + * 25-Mar: char-position, string-position, environment-ref, environment-set! added to the scheme side. + * 9-Jan-13: s7_cos, s7_sin, other optimization changes. + * -------- + * 24-Dec: s7_set_object_array_info and other such changes. + * 20-Nov: removed s7_set_error_exiter and s7_error_and_exit which I think have never been used. + * 22-Oct: changed args to s7_function_class and s7_function_set_class. + * 22-Aug: symbol->dynamic-value. + * 10-Aug: exported s7_outer_environment. + * 6-Aug: removed WITH_OPTIMIZATION. + * 25-July: environment (in scheme). s7_vector_ref_n and s7_vector_set_n. s7_copy. + * added s7_scheme arg to s7_number_to_real|integer. + * 16-July: s7_function_returns_temp (an experiment). + * 2-July: s7_object_set_* functions. + * 11-June: throw. + * 4-June. s7_object_environment. + * 31-May: added s7_scheme argument to all the optimizer chooser functions. + * 24-May: open-environment? + * 17-May: arity, aritable? + * removed trace and untrace. + * 14-May: s7_list. s7_procedure_set_setter. Removed s7_procedure_getter. + * procedure-setter is settable: removed most of procedure-with-setter. + * make-type replaced by open-environment. + * 11-May: s7 2.0: hook implementation changed completely. + * s7_environment_ref|set. + * 4-May: *error-info* replaced by error-environment, and stacktrace has changed. + * 22-Apr: #_ = startup (built-in) value of name + * 17-Apr: with-baffle. + * 14-Apr: WITH_SYSTEM_EXTRAS (default 0) has additional OS and IO functions: + * directory? file-exists? delete-file getenv directory->list system + * 26-Mar: "@" as exponent, WITH_AT_SIGN_AS_EXPONENT switch (default is 1). + * 18-Mar: removed *trace-hook*. + * 6-Feb: random-state?, hash-table-iterator?, and morally-equal? + * 18-Jan: s7_environment_to_list and environment->list return just the local environment's bindings. + * outer-environment returns the environment enclosing its argument (an environment). + * environments are now applicable objects. + * added the object system example to s7.html. + * 12-Jan: added reverse argument to s7_new_type_x. This is needed because an object might implement + * the apply and set methods, but they might refer to different things. + * 6-Jan-12: added (scheme side) logbit?. + * -------- + * 21-Dec: s7_eval, s7_make_slot, s7_slot_set_value. + * changed s7_symbol_slot to s7_slot, and s7_symbol_slot_value to s7_slot_value. + * 26-Oct: s7_procedure_name. + * 6-Oct: changed s7_make_closure args: split the code argument in two (args and body). + * s7_make_closure(... code ...) is now s7_make_closure(... car(code), cdr(code) ...) + * s7_is_environment. + * 19-Aug: s7_function_chooser_data. + * 11-Aug: s7_symbol_accessor functions. s7_cxxxxr. + * 9-Aug: s7_function_chooser, s7_function_choice, s7_function_choice_set_direct. + * 20-Jul: s7_function_class, s7_function_set_class, and s7_function_set_chooser. + * 14-Jul: removed thread and profiling support. + * 5-June: s7_define_safe_function and s7_unoptimize exported; added unoptimize function in scheme. + * 30-May: environment->list and s7_environment_to_list since environments are no longer alists internally. + * 26-May: added s7_scheme argument to s7_procedure_setter and getter (old names had "with_setter_"). + * 28-Apr: s7_help. + * 5-Apr: pair-line-number. + * 14-Mar: s7_make_random_state, optional state argument to s7_random, random-state->list, s7_random_state_to_list. + * 10-Feb: s7_vector_print_length, s7_set_vector_print_length. + * 7-Feb: s7_begin_hook, s7_set_begin_hook. + * 25-Jan: s7_is_thread, s7_thread, s7_make_thread, s7_thread_s7, s7_thread_data. + * s7_is_lock, s7_make_lock, s7_lock. + * changed s7_thread_variable_value to s7_thread_variable. + * 23-Jan: removed (scheme-level) quit. + * 17-Jan-11: make-hash-table-iterator. + * map and for-each accept any applicable object as the first argument. + * format's ~{...~} directive can handle any applicable object. + * -------- + * 17-Dec: removed unquote-splicing; replaced by (unquote (apply values ...)). + * 12-Dec: environment? + * 7-Dec: member and assoc have an optional third arg, the comparison function. + * 1-Dec: *gc-stats* in Scheme, s7_gc_stats in C. + * gmp and gtk-repl examples in s7.html. + * 21-Nov: Load C module example in s7.html. + * 12-Nov: *trace-hook*, *load-hook*, *error-hook*, and *unbound-variable-hook* are now s7 hooks. + * 9-Nov: hooks: C side: s7_is_hook, s7_make_hook, s7_hook_apply, s7_hook_functions, s7_hook_arity, s7_hook_documentation. + * s7 side: hook?, make-hook, hook, hook-apply, hook-functions, hook-arity, hook-documentation. + * 8-Nov: Closure defined in C example in s7.html. + * 23-Oct: s7_call_with_location for better error reporting. + * 19-Oct: *stdin*, *stdout*, *stderr* for default IO ports (rather than nil which is ambiguous). + * 14-Oct: removed special variable support. + * 30-Sep: setters for current-input-port, current-output-port, and current-error-port. + * 30-Aug: :allow-other-keys in define*. + * 10-Aug: added boolean argument use_write to s7_object_to_string (true=write, false=display). + * 30-July: special macro for access to dynamic binding. + * s7_symbol_special_value for C-side access to dynamic bindings. + * s7_is_macro. + * port-closed? returns #t if its argument (a port) is closed. + * 22-July: s7_make_character takes uint32_t, rather than int. + * added symbol function for funny symbol names. + * 12-July: initial-environment. + * 7-July: removed force and delay: use slib. + * 3-July: new backquote implementation. + * 28-June: syntactic keywords (e.g. lambda) are applicable. + * 7-June: changed key arg in s7_hash_table_ref|set to be s7_pointer, not const char*. + * hash-tables can now handle any s7 object as the key. + * map and for-each now pass a hash-table entry to the function, rather than an internal alist. + * reverse of a hash-table reverses the keys and values (i.e. old value becomes new key, etc). + * 2-June: removed procedure-with-setter-setter-arity and folded that info into procedure-arity (use cdddr). + * 22-May: multidimensional vectors are no longer optional. + * 9-May: s7_read_char and s7_peek_char have to return an int, not a char (=-1, but 255 is a legit char). + * s7_write_char and s7_open_output_function have similar changes. + * 3-May: *#readers* to customize #... reading. Also nan? and infinite?. + * multidimensional vector constants using #nD(...): (#2D((1 2 3) (4 5 6)) 0 0) -> 1. + * 13-Apr: removed hash-table|vector|string-for-each -- these are handled by for-each. + * also removed vector-map -- map is generic, but always returns a list. + * 12-Apr: removed immutable constant checks -- see s7.html. + * 7-Apr: *unbound-variable-hook*. + * augment-environment and s7_augment_environment. + * 29-Mar: symbol-access, s7_symbol_access, s7_symbol_set_access. + * C example of notification in s7.html. + * 25-Mar: make-type. s7_is_equal now includes an s7_scheme pointer as its first argument. + * 24-Mar: s7_is_defined. + * 19-Mar: removed encapsulation mechanism and s7_define_set_function. + * 18-Mar: added macro?. + * 27-Feb: removed r4rs-style macro syntax. + * 17-Feb: s7_number_to_integer. + * 20-Jan-10: removed the stack function. + * -------- + * 16-Dec: hash-table-for-each. + * 1-Dec: mpc versions before 0.8.0 are no longer supported. + * 24-Nov: define-macro* and defmacro*. + * force and delay included only if WITH_FORCE set, promise? removed. + * 17-Nov: s7_is_boolean no longer takes the s7_scheme argument. + * 7-Nov: s7_vector_dimensions, s7_vector_offsets, example of use. + * 3-Nov: s7_vector_rank. + * 30-Oct: *trace-hook*. + * 12-Oct: s7_port_filename. + * 5-Oct: s7_c_pointer and friends. + * 14-Sep: s7_values, s7_make_continuation, and a better interrupt example. + * vector-for-each, vector-map, string-for-each. + * 7-Sep: s7_open_input_function. with-environment. receive. + * 3-Sep: s7.html, s7-slib-init.scm. + * s7_stacktrace in s7.h. + * 27-Aug: vector and hash-table sizes are now s7_ints, rather than ints. + * 20-Aug: s7_remove_from_heap. + * 17-Aug: *error-info*. + * 7-Aug: s7_define_function_with_setter. + * s7_quit and example of signal handling. + * 6-Aug: encapsulation. s7_define_set_function. s7_new_type_x. + * generic function: copy, and length is generic. + * 1-Aug: lower-case versions of s7_T and friends. + * s7_define_macro. macroexpand. + * strings are set-applicable (like vectors). + * 31-Jul: *error-hook*. + * 30-Jul: changed backtrace handling: removed backtrace stuff, added stacktrace. + * removed gc-verbose and load-verbose replaced by *load-hook*. + * 23-Jul: __func__. + * 20-Jul: trace and untrace. + * 14-Jul: replaced s7_make_closure_star with s7_define_function_star. + * 29-Jun: s7_format declaration. + * 12-May: s7_is_constant. + * 20-Apr: changed rationalize to be both r5rs-acceptable and fast. + * 6-Apr: added s7_make_permanent_string. + * 14-Mar: removed s7_local_gc_protect and s7_local_gc_unprotect. + * 4-Mar: multidimensional and applicable vectors. + * 1-Mar: s7_random added to s7.h. + * 29-Jan: s7_is_bignum and friends. + * 26-Jan: added s7_scheme arg to s7_vector_fill. + * 16-Jan: s7_is_ulong_long and friends for C pointers in 64-bit situations. + * 9-Jan-09 multiprecision arithmetic (gmp, mpfr, mpc) on the WITH_GMP switch + * -------- + * 29-Dec: "+" specialization example, s7_apply_function. + * 3-Dec: s7_open_output_function. + * 30-Nov: s7_wrong_number_of_args_error. + * 24-Nov: changed s7_make_counted_string to s7_make_string_with_length. + * also added built-in format and define* + * 10-Nov: s7_define_constant, + * built-in (scheme-side) pi, most-positive-fixnum, most-negative-fixnum + * 7-Nov: removed s7_is_immutable and friends, s7_reverse_in_place. + * removed the s7_pointer arg to s7_gc_on. + * added s7_UNSPECIFIED + * 25-Oct: added name arg to s7_make_procedure_with_setter, + * and s7_scheme arg to new_type print func. + * 1-Oct-08 version 1.0 + */ + + +#ifdef __cplusplus +} +#endif +#endif diff --git a/source/engine/thirdparty/s7/s7.html b/source/engine/thirdparty/s7/s7.html new file mode 100644 index 0000000..e990d34 --- /dev/null +++ b/source/engine/thirdparty/s7/s7.html @@ -0,0 +1,10552 @@ + + + + +s7 + + + + + + + + +

+ + +

s7 is a Scheme implementation intended as an extension language +for other applications, primarily Snd, Radium, Common Music, and Max/MSP through the Scheme For Max external. +It exists as just two files, s7.c and +s7.h, that want only to disappear into someone else's source tree. There are no libraries, +no run-time init files, and no configuration scripts. +It can be built as a stand-alone +interpreter (see below). s7test.scm is a regression test for s7. +A tarball is available: s7 tarball. +There is an svn repository at sourceforge (the Snd project): Snd, +and a git repository (just s7): git@cm-gitlab.stanford.edu:bil/s7.git s7.git. +Please ignore all other "s7" github sites. Christos Vagias created a web-assembly site with +a repl: https://github.com/actonDev/s7-playground/. +

+ +

+s7 is the default extension language of Snd and sndlib (snd), +Rick Taube's Common Music (commonmusic at sourceforge), and Kjetil Matheussen's Radium music editor. +There are X, Motif, and openGL bindings +in libxm in the Snd tarball, or at ftp://ccrma-ftp.stanford.edu/pub/Lisp/libxm.tar.gz. +If you're running s7 in a context +that has getenv, file-exists?, and system, you can use s7-slib-init.scm +to gain easy access to slib. This init file is named "s7.init" in the slib distribution. +

+ +

Although it is a descendant of tinyScheme, s7 is closest as a Scheme dialect to Guile 1.8. +I believe it is compatible with r5rs and r7rs: you can just ignore all the additions discussed in this file. +It has continuations, +ratios, complex numbers, +macros, keywords, hash-tables, +multiprecision arithmetic, +generalized set!, unicode, and so on. +It does not have syntax-rules or any of +its friends, and it does not think there is any such thing +as an inexact integer. +

+ +

This file assumes you know about Scheme and all its problems, +and want a quick tour of where s7 is different. (Well, it was quick once upon a time). +The main difference: if it's in s7, it's a first-class citizen of s7, and that includes +macros, environments, and syntactic values. +

+ +
+
+
+

I originally used a small font for scholia, but now I have to squint +to read that tiny text, so less-than-vital commentaries are shown in the normal font, but +indented and on a sort of brownish background. +

+
+
+
+ + + + +

multiprecision arithmetic

+ +

All numeric types, integers, ratios, reals, and complex numbers are supported. +The basic integer and real +types are defined in s7.h, defaulting to int64_t and double. +A ratio consists of two integers, a complex number two reals. +pi is predefined. +s7 can be built with multiprecision support +for all types, using the gmp, mpfr, and mpc libraries (set WITH_GMP to 1 in s7.c). +If multiprecision arithmetic is +enabled, the following functions are included: bignum, and bignum?, and the variable (*s7* 'bignum-precision). +(*s7* 'bignum-precision) defaults to 128; it sets the number of bits each float takes. +pi automatically reflects the current (*s7* 'bignum-precision): +

+ +
> pi
+3.141592653589793238462643383279502884195E0
+> (*s7* 'bignum-precision)
+128
+> (set! (*s7* 'bignum-precision) 256)
+256
+> pi
+3.141592653589793238462643383279502884197169399375105820974944592307816406286198E0
+
+ +

+bignum? returns #t if its argument is a big number of some type; I use "bignum" +for any big number, not just integers. To create a big number, +either include enough digits to overflow the default types, or use the bignum function. +Its argument is either a number which it casts to a bignum, or a string representing the desired number: +

+ +
> (bignum "123456789123456789")
+123456789123456789
+> (bignum "1.123123123123123123123123123")
+1.12312312312312312312312312300000000009E0
+
+ +

For read-time bignums: +

+
(set! *#readers* 
+  (cons (cons #\B (lambda (str)
+	            (bignum (string->number (substring str 1)))))
+        *#readers*))
+
+ +

and now #B123 is the reader equivalent of (bignum 123). +

+ +
+
+ +

In the non-gmp case, if s7 is built using doubles (s7_double in s7.h), the float "epsilon" is +around (expt 2 -53), or about 1e-16. In the gmp case, it is around (expt 2 (- (*s7* 'bignum-precision))). +So in the default case (precision = 128), using gmp: +

+ +
> (= 1.0 (+ 1.0 (expt 2.0 -128)))
+#t
+> (= 1.0 (+ 1.0 (expt 2.0 -127)))
+#f
+
+ +

and in the non-gmp case: +

+ +
> (= 1.0 (+ 1.0 (expt 2 -53)))
+#t
+> (= 1.0 (+ 1.0 (expt 2 -52)))
+#f
+
+ +

In the gmp case, integers and ratios are limited only by the size of memory, +but reals are limited by (*s7* 'bignum-precision). This means, for example, that +

+ +
> (floor 1e56) ; (*s7* 'bignum-precision) is 128
+99999999999999999999999999999999999999927942405962072064
+> (set! (*s7* 'bignum-precision) 256)
+256
+> (floor 1e56)
+100000000000000000000000000000000000000000000000000000000
+
+ +

The non-gmp case is similar, but it's easy to find the edge cases: +

+ +
> (floor (+ 0.9999999995 (expt 2.0 23)))
+8388609
+
+
+
+ + + + + +

math functions

+ + +

+s7 includes: +

+ +
    +
  • sinh, cosh, tanh, asinh, acosh, atanh +
  • logior, logxor, logand, lognot, logbit?, ash, integer-decode-float +
  • random +
  • nan?, infinite? +
+ +

+The random function can take any numeric argument, including 0. +Other math-related differences between s7 and r5rs: +

+ +
    +
  • rational? and exact mean integer or ratio (i.e. not floating point), inexact means not exact. +
  • floor, ceiling, truncate, and round return (exact) integer results. +
  • "#" does not stand for an unknown digit. +
  • the "@" complex number notation is not supported ("@" is an exponent marker in s7). +
  • "+i" is not considered a number; include the real part. +
  • modulo, remainder, and quotient take integer, ratio, or real arguments. +
  • lcm and gcd can take integer or ratio arguments. +
  • log takes an optional second argument, the base. +
  • '.' and an exponent can occur in a number in any base. +
  • rationalize returns a ratio! +
  • case is significant in numbers, as elsewhere: #b0 is 0, but #B0 is an error. +
+ +
> (exact? 1.0)
+#f
+> (rational? 1.5)
+#f
+> (floor 1.4)
+1
+> (remainder 2.4 1)
+0.4
+> (modulo 1.4 1.0)
+0.4
+> (lcm 3/4 1/6)
+3/2
+> (log 8 2)
+3
+> (number->string 0.5 2)
+"0.1"
+> (string->number "0.1" 2)
+0.5
+> (rationalize 1.5)
+3/2
+> (complex 1/2 0)
+1/2
+> (logbit? 6 1) ; argument order, (logbit? int index), follows gmp, not CL
+#t
+
+ +

See cload and libgsl.scm for easy access to GSL, +and similarly libm.scm for the C math library. +

+ +
+
+ +

The exponent itself is always in base 10; this follows gmp usage. +Scheme normally uses "@" for its useless polar notation, but that +means (string->number "1e1" 16) is ambiguous — is the "e" a digit or an exponent marker? +In s7, "@" is an exponent marker. +

+ +
> (string->number "1e9" 2)  ; (expt 2 9)
+512.0
+> (string->number "1e1" 12) ; "e" is not a digit in base 12
+#f
+> (string->number "1e1" 16) ; (+ (* 1 16 16) (* 14 16) 1)
+481
+> (string->number "1.2e1" 3); (* 3 (+ 1 2/3))
+5.0
+
+
+ + +
+ +

+What is (/ 1.0 0.0)? s7 gives a "division by zero" error here, and also in (/ 1 0). +Guile returns +inf.0 in the first case, which seems reasonable, but a "numerical overflow" error in the second. +Slightly weirder is (expt 0.0 0+i). Currently s7 returns 0.0, Guile returns +nan.0+nan.0i, +Clisp and sbcl throw an error. Everybody agrees that (expt 0 0) is 1, and Guile thinks +that (expt 0.0 0.0) is 1.0. But (expt 0 0.0) and (expt 0.0 0) return different +results in Guile (1 and 1.0), both are 0.0 in s7, the first is an error in Clisp, but the second returns 1, +and so on — what a mess! This mess was made a lot worse than it needs to be when the IEEE decreed that +0.0 equals -0.0, so we can't tell them apart, but that they produce different results in nearly every use! +

+ +
scheme@(guile-user)> (= -0.0 0.0)
+#t
+scheme@(guile-user)> (negative? -0.0)
+#f
+scheme@(guile-user)> (= (/ 1.0 0.0) (/ 1.0 -0.0))
+#f
+scheme@(guile-user)>  (< (/ 1.0 -0.0) -1e100 1e100 (/ 1.0 0.0))
+#t
+
+ +

+How can they be equal? In s7, the sign +of -0.0 is ignored, and they really are equal. +One other oddity: two floats can satisfy eq? and yet not be eqv?: +(eq? +nan.0 +nan.0) might be #t (it is unspecified), but (eqv? +nan.0 +nan.0) is #f. +The same problem afflicts memq and assq. +

+
+ + +
+ +

The random function takes a range and an optional state, and returns a number +between zero and the range, of the same type as the range. It is perfectly reasonable +to use a range of 0, in which case random returns 0. +random-state creates a new random state from a seed. If no state is passed, +random uses some default state initialized from the current time. random-state? returns #t if passed a random state object. +

+ +
> (random 0)
+0
+> (random 1.0)
+0.86331198514245
+> (random 3/4)
+654/1129
+> (random 1+i)
+0.86300308872748+0.83601002730848i
+> (random -1.0)
+-0.037691127513267
+> (define r0 (random-state 1234))
+r0
+> (random 100 r0)
+94
+> (random 100 r0)
+19
+> (define r1 (random-state 1234))
+r1
+> (random 100 r1)
+94
+> (random 100 r1)
+19
+
+ +

copy the random-state to save a spot in a random number sequence, or save the random-state as a list via +random-state->list, then to restart from that point, apply random-state to that list. +

+
+ + +
+ +

I can't find the right tone for this section; this is the 400-th revision; I wish I were a better writer! +

+ +

In some Schemes, +"rational" means "could possibly be +expressed equally well as a ratio: floats are approximations". In s7 +it's: "is actually expressed (at the scheme level) as a ratio (or an +integer of course)"; +otherwise "rational?" is the same as "real?": +

+ +
(not-s7)> (rational? (sqrt 2))
+#t
+
+ +

That 1.0 is represented at the IEEE-float level as a sort of +ratio does not mean it has to be a scheme ratio; the two notions are independent. +

+ +

But that confusion is trivial compared to the completely nutty "inexact integer". +As I understand it, "inexact" originally meant "floating point", and "exact" meant integer or ratio of integers. +But words have a life of their own. +0.0 somehow became an "inexact" integer (although it can be represented exactly in floating +point). ++inf.0 must be an integer — +its fractional part is explicitly zero! But +nan.0... +And then there's: +

+ +
(not-s7)> (integer? 9007199254740993.1)
+#t
+
+ +

+When does this matter? I often need to index into a vector, but the index is a float (a "real" in Scheme-speak: its +fractional part can be non-zero). +In one Scheme: +

+ +
(not-s7)> (vector-ref #(0) (floor 0.1))
+ERROR: Wrong type (expecting exact integer): 0.0   ; [why?  "it's probably a programmer mistake"!]
+
+ +

Not to worry, I'll use inexact->exact: +

+ +
(not-s7)> (inexact->exact 0.1)
+3602879701896397/36028797018963968                  ; [why? "floats are ratios"!]
+
+ +

So I end up using the verbose (floor (inexact->exact ...)) everywhere, and even +then I have no guarantee that I'll get a legal vector index. +I have never seen any use made of the exact/inexact distinction — just +wild flailing to try get around it. +I think the whole idea is confused and useless, and leads +to verbose and buggy code. +If we discard it, +we can maintain backwards compatibility via: +

+ +
(define exact? rational?)
+(define (inexact? x) (not (rational? x)))
+(define inexact->exact rationalize) ; or floor
+(define (exact->inexact x) (* x 1.0))
+
+ +

Standard Scheme's #i and #e are also useless because you can +have any number after, for example, #b: +

+ +
> #b1.1
+1.5
+> #b1e2
+4.0
+> #o17.5+i
+15.625+1i
+
+ +

(But s7 uses #i for int-vector and does not implement #e). +Speaking of #b and friends, what should (string->number "#xffff" 2) return? +

+
+ +
+ + + + +

define*, lambda*

+ + +

define* and + lambda* +are extensions of define and lambda that make it easier +to deal with optional, keyword, and rest arguments. +The syntax is very simple: every argument to define* has a default value +and is automatically available as a keyword argument. The default value +is either #f if unspecified, or given in a list whose first member is +the argument name. +The last argument +can be preceded by :rest or a dot to indicate that all other trailing arguments +should be packaged as a list under that argument's name. A trailing or rest +argument's default value is () and can't be specified in the declaration. +The rest argument is not available as a keyword argument. +

+ +
(define* (hi a (b 32) (c "hi")) (list a b c))
+
+ +

Here the argument "a" defaults to #f, "b" to 32, etc. +When the function is called, +the argument names are set from the values passed the function, +then any unset arguments are bound to their default values, evaluated in left-to-right order. +As the current argument list is scanned, any name that occurs as a keyword, :arg for example where the parameter name is arg, +sets that argument's new value. Otherwise, as values occur, they +are plugged into the actual argument list based on their position, counting a keyword/value pair as one argument. +This is called an optional-key list in CLM. So, taking the function +above as an example: +

+ +
> (hi 1) 
+(1 32 "hi")
+> (hi :b 2 :a 3) 
+(3 2 "hi")
+> (hi 3 2 1) 
+(3 2 1)
+
+ +

See s7test.scm for many examples. (s7's define* is very close to srfi-89's define*). +To mark an argument as required, set its default value to a call on the error function: +

+
> (define* (f a (b (error 'unset-arg "f's b parameter not set"))) (list a b))
+f
+> (f 1 2)
+(1 2)
+> (f 1)
+error: f's b parameter not set
+
+ +
+ +
+

The combination of optional and keyword arguments is viewed with +disfavor in the Lisp +community, but the problem is in CL's implementation of the idea, not +the idea itself. +I've used the s7 style since around 1976, and have never found it +confusing. The mistake +in CL is to require the optional arguments if a keyword argument occurs, + and to consider them as distinct from the +keyword arguments. So everyone forgets and puts a keyword where CL +expects a required-optional +argument. CL then does something ridiculous, and the programmer stomps +around shouting about keywords, but the fault lies with CL. +If s7's way is considered too loose, one way to tighten it might be to +insist that once a keyword +is used, only keyword argument pairs can follow. +

+
+ + +
+

A natural companion of lambda* is named let*. In named let, the implicit function's +arguments have initial values, but thereafter, each call requires the full set of arguments. +Why not treat the initial values as default values? +

+ +
> (let* func ((i 1) (j 2)) 
+    (+ i j (if (> i 0) (func (- i 1)) 0)))
+5
+> (letrec ((func (lambda* ((i 1) (j 2)) 
+                   (+ i j (if (> i 0) (func (- i 1)) 0)))))
+    (func))
+5
+
+ +

This is consistent with the lambda* arguments because their defaults are +already set in left-to-right order, and as each parameter is set to its default value, +the binding is added to the default value expression environment (just as if it were a let*). +The let* name itself (the implicit function) is not defined until after the bindings +have been evaluated (as in named let). +

+ +

In CL, keyword default values are handled in the same way: +

+ +
> (defun foo (&key (a 0) (b (+ a 4)) (c (+ a 7))) (list a b c)) 
+FOO 
+> (foo :b 2 :a 60) 
+(60 2 67) 
+
+ +

In s7, we'd use: +

+ +
(define* (foo (a 0) (b (+ a 4)) (c (+ a 7))) (list a b c))
+
+

Also CL and s7 handle keywords as values in the same way: +

+
> (defun foo (&key a) a)
+FOO
+> (defvar x :a)
+X
+> (foo x 1)
+1
+
+ +
> (define* (foo a) a)
+foo
+> (define x :a)
+:a
+> (foo x 1)
+1
+
+
+ + +
+ +

To try to catch what I believe are usually mistakes, I added two +error checks. One is triggered if you set the same parameter twice +in the same call, and the other if an unknown keyword is encountered +in the key position. To turn off these errors, add :allow-other-keys +at the end of the parameter list. +These problems arise in a case such as +

+ +
(define* (f (a 1) (b 2)) (list a b))
+
+ +

You could do any of the following by accident: +

+ +
(f 1 :a 2)  ; what is a?
+(f :b 1 2)  ; what is b?
+(f :c 3)    ; did you really want a to be :c and b to be 3?
+
+ +

In the last case, to pass a keyword deliberately, either include the +argument keyword: (f :a :c), or make the default value a keyword: +(define* (f (a :c) ...)), or set (*s7* 'accept-all-keyword-arguments) +to some true value. +See s7test.scm for many examples. +

+ +

What if two functions share a keyword argument, +and one wants to call the other, passing both arguments to the wrapper? +

+ +
(define* (f1 a) a)                         ; the wrappee
+(define* (f2 a :rest b :allow-other-keys)  ; the wrapper
+  (+ a (apply f1 b)))
+(f2 :a 3 :a 4)                             ; 7, b='(:a 4)
+(let ((c :a)) 
+  (f2 c 3 c 4))                            ; also 7
+
+ +

Since named let* is a form of lambda*, the prohibition of repeated variable names makes it different +from let*: (let* ((a 1) (a 2)) a) is 2, but (let* loop ((a 1) (a 2)) a) is an error. +If let* and named let* agreed in this, we'd have an inconsistency with lambda*. If all three allowed repeated +variables, the decision as to which parameter is intended becomes messy: ((lambda* (a a) a) 2 :a 3), +or (let* loop ((a 1) (a 2)) (loop 2 :a 3)). +CL and standard scheme accept repeated variables in let*, so I think the current +choice is the least surprising. +

+ +
+ + +
+ +

s7's lambda* arglist handling is not the same as CL's lambda-list. First, +you can have more than one :rest parameter: +

+ +
> ((lambda* (:rest a :rest b) (map + a b)) 1 2 3 4 5) 
+'(3 5 7 9)
+
+ +

and second, the rest parameter, if any, takes up an argument slot just like any other +argument: +

+ +
> ((lambda* ((b 3) :rest x (c 1)) (list b c x)) 32)
+(32 1 ())
+> ((lambda* ((b 3) :rest x (c 1)) (list b c x)) 1 2 3 4 5)
+(1 3 (2 3 4 5))
+
+ +

CL would agree with the first case if we used &key for 'c', but would give an error in the second. +Of course, the major difference is that s7 keyword arguments don't insist that the key be present. +The :rest argument is needed in cases like these because we can't use an expression +such as: +

+ +
> ((lambda* ((a 3) . b c) (list a b c)) 1 2 3 4 5)
+error: stray dot?
+> ((lambda* (a . (b 1)) b) 1 2) ; the reader turns the arglist into (a b 1)
+error: lambda* parameter '1 is a constant
+
+ +

Yet another nit: the :rest argument is not considered a keyword argument, so +

+ +
> (define* (f :rest a) a)
+f
+> (f :a 1)
+(:a 1)
+
+
+ + + + +
+ + + +

macros

+ + +

+define-macro, +define-macro*, +define-bacro, +define-nacro*, +macroexpand, +gensym, +gensym?, and +macro? +implement the standard old-time macros. +The anonymous versions (analogous to lambda and lambda*) are +macro, macro*, bacro, and bacro*. +See s7test.scm for many examples of macros including such perennial favorites as +loop, dotimes, do*, enum, pushnew, and defstruct. +

+ +
> (define-macro (and-let* vars . body)
+    `(let () 
+       (and ,@(map (lambda (v) 
+                     `(define ,@v))
+                   vars)
+            (begin ,@body))))
+
+ +

macroexpand can help debug a macro. I always forget that it +wants an expression: +

+ +
> (define-macro (add-1 arg) `(+ 1 ,arg))
+add-1
+> (macroexpand (add-1 32))
+(+ 1 32)
+
+ +

gensym returns a symbol that is guaranteed to be unused. It takes an optional string argument +giving the new symbol name's prefix. gensym? returns #t if its argument is a symbol created by gensym. +

+ +
(define-macro (pop! sym)
+  (let ((v (gensym)))
+    `(let ((,v (car ,sym)))
+       (set! ,sym (cdr ,sym))
+       ,v)))
+
+ +

As in define*, the starred forms give optional and keyword arguments: +

+ +
> (define-macro* (add-2 a (b 2)) `(+ ,a ,b))
+add-2
+> (add-2 1 3)
+4
+> (add-2 1)
+3
+> (add-2 :b 3 :a 1)
+4
+
+ +
+
+ +

A macro is a first-class citizen of s7. You can +pass it as a function argument, apply it to a list, return it from a function, +call it recursively, +and assign it to a variable. You can even set its setter! +

+ +
> (define-macro (hi a) `(+ ,a 1))
+hi
+> (apply hi '(4))
+5
+> (define (fmac mac) (apply mac '(4)))
+fmac
+> (fmac hi)
+5
+> (define (fmac mac) (mac 4))
+fmac
+> (fmac hi)
+5
+> (define (make-mac)
+    (define-macro (hi a) `(+ ,a 1)))
+make-mac
+> (let ((x (make-mac)))
+    (x 2))
+3
+> (define-macro (ref v i) `(vector-ref ,v ,i))
+ref
+> (define-macro (set v i x) `(vector-set! ,v ,i ,x))
+set
+> (set! (setter ref) set)
+set
+> (let ((v (vector 1 2 3))) (set! (ref v 0) 32) v)
+#(32 2 3)
+
+ +

To expand all the macros in a piece of code: +

+
(define-macro (fully-macroexpand form)
+  (list 'quote
+    (let expand ((form form))
+      (cond ((not (pair? form)) form)
+            ((and (symbol? (car form))
+                  (macro? (symbol->value (car form))))
+             (expand (apply macroexpand (list form))))
+            ((and (eq? (car form) 'set!)  ; look for (set! (mac ...) ...) and use mac's setter
+                  (pair? (cdr form))
+                  (pair? (cadr form))
+                  (macro? (symbol->value (caadr form))))
+	     (expand (apply macroexpand (list (cons (setter (symbol->value (caadr form))) 
+							 (append (cdadr form) (copy (cddr form))))))))
+            (else (cons (expand (car form)) (expand (cdr form))))))))
+
+

This does not always handle bacros correctly because their expansion can depend on the run-time +state. +

+
+ + +
+ +

A bacro is a macro that expands its body and evaluates +the result in the calling environment. +

+ +
(define setf
+  (let ((args (gensym))
+        (name (gensym)))
+     (apply define-bacro `((,name . ,args)        
+			   (unless (null? ,args)
+			     (apply set! (car ,args) (cadr ,args) ())
+			     (apply setf (cddr ,args)))))))
+
+ + +

+The setf argument is a gensym (created when setf is defined) so that its name does not shadow any existing +variable. Bacros expand in the calling environment, and a normal argument name +might shadow something in that environment while the bacro is being expanded. +Similarly, if you introduce bindings in the bacro expansion code, you need to +keep track of which environment you want things to happen in. Use with-let +and gensym liberally. +stuff.scm has bacro-shaker which can find inadvertent name collisions, +but it is flighty and easily confused. +The calling environment itself is (outlet (curlet)) from within a bacro, so +

+ +
(define-bacro (holler)
+  `(format *stderr* "(~S~{ ~S ~S~^~})~%" 
+	   (let ((f (*function*)))
+	     (if (pair? f) (car f) f))
+	   (map (lambda (slot)
+		  (values (symbol->keyword (car slot)) (cdr slot)))		  
+		(reverse (map values ,(outlet (curlet)))))))
+
+(define (f1 a b)
+  (holler)
+  (+ a b))
+
+(f1 2 3) ; prints out "(f1 :a 2 :b 3)" and returns 5
+
+ +

+Since a bacro (normally) sheds its define-time environment: +

+ +
(define call-bac
+  (let ((x 2))
+    (define-bacro (m a) `(+ ,a ,x))))
+
+> (call-bac 1) 
+error: x: unbound variable
+
+

+A macro here returns 3. But don't be hasty! The bacro can get its define-time environment (its closure) +via funclet, so in fact, define-macro is a special case of define-bacro! We can define +macros that work in all four ways: the expansion can happen in either the definition or calling environment, +as can the evaluation of that expansion. In a bacro, both happen in the calling environment +if we take no other action, and in a normal macro (define-macro), the expansion happens in the definition +environment, and the evaluation in the calling environment. +Here's a brief example of all four: +

+ +
(let ((x 1) (y 2)) 
+  (define-bacro (bac1 a) 
+     `(+ ,x y ,a))        ; expand and eval in calling env
+  (let ((x 32) (y 64)) 
+    (bac1 3)))            ; (with-let (inlet 'x 32 'y 64) (+ 32 y 3))
+-> 99                     ;  with-let and inlet refer to environments
+
+(let ((x 1) (y 2))        ; this is like define-macro
+  (define-bacro (bac2 a) 
+    (with-let (sublet (funclet bac2) :a a)
+      `(+ ,x y ,a)))      ; expand in definition env, eval in calling env
+  (let ((x 32) (y 64)) 
+    (bac2 3)))            ; (with-let (inlet 'x 32 'y 64) (+ 1 y 3))
+-> 68
+
+(let ((x 1) (y 2))
+  (define-bacro (bac3 a) 
+    (let ((e (with-let (sublet (funclet bac3) :a a)
+	       `(+ ,x y ,a))))
+      `(with-let ,(sublet (funclet bac3) :a a)
+	 ,e)))           ; expand and eval in definition env 
+  (let ((x 32) (y 64)) 
+    (bac3 3)))           ; (with-let (inlet 'x 1 'y 2) (+ 1 y 3))
+-> 6
+
+(let ((x 1) (y 2))
+  (define-bacro (bac4 a) 
+    (let ((e `(+ ,x y ,a)))
+      `(with-let ,(sublet (funclet bac4) :a a)
+	 ,e)))           ; expand in calling env, eval in definition env
+  (let ((x 32) (y 64))     
+    (bac4 3)))           ; (with-let (inlet 'x 1 'y 2) (+ 32 y 3))
+-> 37
+
+
+ + +
+ +

Backquote (quasiquote) in s7 is almost trivial. Constants are unchanged, symbols are quoted, +",arg" becomes "arg", and ",@arg" becomes "(apply values arg)" — hooray for real multiple values! +It's almost as easy to write the actual macro body as the backquoted version of it. +

+ +
> (define-macro (hi a) `(+ 1 ,a))
+hi
+> (procedure-source hi)
+(lambda (a) (list-values '+ 1 a))
+
+> (define-macro (hi a) `(+ 1 ,@a))
+hi
+> (procedure-source hi)
+(lambda (a) (list-values '+ 1 (apply-values a)))
+
+ +

list-values and apply-values are quasiquote helper functions described below. +There is no unquote-splicing +macro in s7; ",@(...)" becomes "(unquote (apply-values ...))" at read-time. There shouldn't be any unquote +either. In Scheme the reader turns ,x into (unquote x), so: +

+ +
> (let (,'a) unquote)
+a
+> (let (, (lambda (x) (+ x 1))) ,,,,'3)
+7
+
+

comma becomes a sort of symbol macro! I think I'll remove unquote; ,x + and ,@x will still work +as expected, but there will not be any "unquote" or "unquote-splicing" +in the resultant source code. Just to make life difficult: +

+
> (let (' 1) quote)
+1
+
+

but that translation is so ingrained in lisp +that I'm reluctant to change it. The two unquote names, on the +other hand, seem unnecessary. +

+
+
+ +

s7 macros are not hygienic. For example, +

+ +
> (define-macro (mac b) 
+    `(let ((a 12)) 
+       (+ a ,b)))
+mac
+> (let ((a 1) (+ *)) (mac a))
+144
+
+ +

This returns 144 because '+' has turned into '*', and 'a' is the internal 'a', +not the argument 'a'. We get (* 12 12) where we might have expected +(+ 12 1). +Starting with the '+' problem, +as long as the redefinition of '+' is local (that is, it happens after the macro definition), we can unquote the +: +

+ +
> (define-macro (mac b) 
+    `(let ((a 12)) 
+       (,+ a ,b))) ; ,+ picks up the definition-time +
+mac
+> (let ((a 1) (+ *)) (mac a))
+24                 ; (+ a a) where a is 12
+
+ +

But the unquote trick won't work if we have previously loaded some file that redefined '+' +at the top-level (so at macro definition time, + is *, but we want the built-in +). +Although this example is silly, the problem is real in Scheme +because Scheme has no reserved words and only one name space. +

+ +
> (define + *)
++
+> (define (add a b) (+ a b))
+add
+> (add 2 3)
+6
+> (define (divide a b) (/ a b))
+divide
+> (divide 2 3)
+2/3
+> (set! / -) ; a bad idea — this turns off s7's optimizer
+-
+> (divide 2 3)
+-1
+
+ +

Obviously macros are not the problem here. Since +we might be loading +code written by others, it's sometimes hard to tell what names +that code depends on or redefines. +We need a way to get the pristine (start-up, built-in) value of '+'. +One long-winded way in s7 uses unlet: +

+ +
> (define + *)
++
+> (define (add a b) (with-let (unlet) (+ a b)))
+add
+> (add 2 3)
+5
+
+ +

But this is hard to read, and we might want all three +values of a symbol, the start-up value, the definition-time value, and the +current value. The latter can be accessed with the bare symbol, the definition-time +value with unquote (','), and the start-up value with either unlet +or #_<name>. That is, #_+ is a reader macro for (with-let (unlet) +). +

+ +
> (define-macro (mac b) 
+    `(#_let ((a 12)) 
+       (#_+ a ,b))) ; #_+ and #_let are start-up values
+mac
+> (let ((a 1) (+ *)) (mac a))
+24                 ; (+ a a) where a is 12 and + is the start-up +
+
+;;; make + generic (there's a similar C-based example below)
+> (define (+ . args) 
+    (if (null? args) 0 
+        (apply (if (number? (car args)) #_+ #_string-append) args)))
++
+> (+ 1 2)
+3
+> (+ "hi" "ho")
+"hiho"
+
+ +
+
+

Conceptually, #_<name> could be implemented via *#readers*: +

+
(set! *#readers*
+  (cons (cons #\_ (lambda (str)
+		    (with-let (unlet)
+                      (string->symbol (substring str 1)))))
+	*#readers*))
+
+

but s7 doesn't let you change the meaning of #\_; otherwise: +

+
(set! *#readers* (list (cons #\_ (lambda (str) (string->symbol (substring str 1))))))
+
+

and now #_ provides no protection: +

+
> (let ((+ -)) (#_+ 1 2))
+-1
+
+

#t and #f (along with their stupid r7rs cousins #true and #false) are also not settable. +

+
+
+ +

+So, now we have only the variable capture problem ('a' has been captured in the preceding examples). +This is the only thing that the gigantic "hygienic macro" systems actually deal with: +a microscopic problem that you'd think, from the hype, was up there with malaria and the +national debt. gensym is the standard approach: +

+ +
> (define-macro (mac b) 
+    (let ((var (gensym))) 
+      `(#_let ((,var 12))
+         (#_+ ,var ,b))))
+mac
+> (let ((a 1) (+ *)) (mac a))
+13
+
+;; or use lambda:
+> (define-macro (mac b) 
+  `((lambda (b) (let ((a 12)) (#_+ a b))) ,b))
+mac
+> (let ((a 1) (+ *)) (mac a))
+13
+
+ +

I think syntax-rules and its friends try to conjure up gensyms automatically, but +the real problem is not name collisions, but unspecified environments. +In s7 we have first-class environments, so you have complete +control over the environment at any point: +

+ +
(define-macro (mac b)
+  `(with-let (inlet 'b ,b)
+     (let ((a 12))
+       (+ a b))))
+
+> (let ((a 1) (+ *)) (mac a))
+13
+
+(define-macro (mac1 . b)         ; originally `(let ((a 12)) (+ a ,@b ,@b))
+  `(with-let (inlet 'e (curlet)) ; this 'e will not collide with the calling env
+     (let ((a 12))               ;   nor will 'a (so no gensyms are needed etc)
+       (+ a (with-let e ,@b) (with-let e ,@b)))))
+
+> (let ((a 1) (e 2)) (mac1 (display a) (+ a e)))
+18  ; (and it displays "11")
+
+(define-macro (mac2 x)           ; this will use mac2's definition environment for its body
+  `(with-let (sublet (funclet mac2) :x ,x)
+     (let ((a 12))
+       (+ a b x))))              ; a is always 12, b is whatever b happens to be in mac2's env
+
+> (define b 10)                  ; this is mac2's b
+10
+> (let ((+ *) (a 1) (b 15)) (mac2 (+ a b)))
+37                               ; mac2 uses its own a (12), b (10), and + (+)
+                                 ;   but (+ a b) is 15 because at that point + is *: (* 1 15)
+
+ +

Hygienic macros are trivial! Who needs syntax-rules? +To avoid the variable capture, avoid local variables in the generated code, or +protect them via with-let; to avoid shadowing of functions and syntax, make the +environment explicit (via #_ for example). +s7's lint.scm will warn you about a problematic macro expansion, so I'd +say just write macros as simply as possible, then let lint tell you +that it's time to do the with-let shuffle. When that happens, wrap the macro body in +a with-let that captures the current environment, and at each use of a macro argument +wrap it in a with-let that re-establishes that environment. +

+ +
+
+
(define-macro (swap a b) ; assume a and b are symbols
+  `(with-let (inlet 'e (curlet) 'tmp ,a)
+     (set! (e ',a) (e ',b))
+     (set! (e ',b) tmp)))
+
+> (let ((b 1) (tmp 2)) (swap b tmp) (list b tmp))
+(2 1)
+
+(define-macro (swap a b) ; here a and b can be any settable expressions
+  `(set! ,b (with-let (inlet 'e (curlet) 'tmp ,a) 
+	      (with-let e (set! ,a ,b))
+	      tmp)))
+
+> (let ((v (vector 1 2))) (swap (v 0) (v 1)) v)
+#(2 1)
+> (let ((tmp (cons 1 2))) (swap (car tmp) (cdr tmp)) tmp)
+(2 . 1)
+
+(set! (setter swap) (define-macro (set-swap a b c) `(set! ,b ,c)))
+
+> (let ((a 1) (b 2) (c 3) (d 4)) (swap a (swap b (swap c d))) (list a b c d))
+(2 3 4 1)
+
+;;; but this is simpler:
+(define-macro (rotate! . args)
+  `(set! ,(args (- (length args) 1))
+         (with-let (inlet 'e (curlet) 'tmp ,(car args))
+	   (with-let e 
+	     ,@(map (lambda (a b) `(set! ,a ,b)) args (cdr args)))
+	   tmp)))
+
+> (let ((a 1) (b 2) (c 3)) (rotate! a b c) (list a b c))
+(2 3 1)
+
+
+
+ +

+If you want the macro's expanded result +to be evaluated in its definition environment: +

+
(let ((a 3))
+  (define-macro (mac b)
+    `(with-let (inlet 'b ,b (funclet mac))
+       (+ a b)))       ; definition-time "a", call-time "b"
+  (define-macro (mac-1 b)
+    `(+ a ,b))         ; call-time "a" and "b"
+  (let ((a 32))
+    (list (mac 1) 
+	  (mac-1 1))))
+
+ +
+
+

Here are some variations on "unless", inspired by the wikipedia hygienic macro page: +

+
(define-macro (my-unless condition . body)
+ `(with-let (inlet (unlet) :condition ,condition) ; here unlet protects body (format below)
+    (if (not condition) (begin ,@body))))
+
+(let ((not (lambda (x) x))
+      (begin 32)
+      (if +)
+      (format abs))
+  (my-unless #t (format #t "This should not be printed!\n"))
+  (my-unless #f (format #t "This should be printed!\n")))
+
+(set! format abs)
+(let ((not (lambda (x) x)))
+  (my-unless #t (format #t "This should not be printed!\n"))
+  (my-unless #f (format #t "This should be printed!\n")))
+
+(define (user-defined-operator x) (not x))
+
+(define-macro (my-unless-1 condition . body)
+ `(with-let (inlet (unlet) :condition ,condition)
+    (if (user-defined-operator condition) (begin ,@body))))
+
+(let ((user-defined-operator (lambda (x) x)))
+  (my-unless-1 #t (format #t "This should not be printed!\n"))
+  (my-unless-1 #f (format #t "This should be printed!\n")))
+
+(define my-unless-2
+  (let ((op1 (lambda (x) (not x))))
+    (define-macro (_ condition . body)
+      `(with-let (inlet (unlet) (funclet my-unless-2) :condition ,condition) 
+         ;; funclet above to get my-unless-2's version of op1
+	 (if (op1 condition) (begin ,@body))))))
+
+(let ((op1 (lambda (x) x)))
+  (my-unless-2 #t (format #t "This should not be printed!\n"))
+  (my-unless-2 #f (format #t "This should be printed!\n")))
+      
+(define my-unless-3
+  (let ((op1 (lambda (x) x)))
+    (define-macro (_ condition . body)
+      `(with-let (inlet (unlet) :condition ,condition :local-env (curlet)) 
+         ;; curlet to get run-time local version of op1
+	 (if ((with-let local-env op1) condition) (begin ,@body))))))
+
+(let ((op1 (lambda (x) (not x))))
+  (my-unless-3 #t (format #t "This should not be printed!\n"))
+  (my-unless-3 #f (format #t "This should be printed!\n")))
+
+
+
+ + + +
+
+

On the subject of *#readers*, say we have: +

+
(set! *#readers* (list (cons #\o (lambda (str) 42))  ; #o... -> 42
+                       (cons #\x (lambda (str) 3)))) ; #x... -> 3
+
+

Now we load a file with: +

+
(define (oct) #o123)
+
+(let-temporarily ((*#readers* ()))
+  (eval (with-input-from-string "(define (hex) #x123)" read)))
+
+(define-constant old-readers *#readers*)
+(set! *#readers* ())
+
+(define (oct1) #o123)
+(define (hex1) #x123)
+
+(set! *#readers* old-readers)
+
+(define (oct2) #o123)
+(define (hex2) #x123)
+
+

Now we evaluate these functions, and get: +

+
(oct): 42   ; oct is not read-time hygienic so #o123 -> 42
+(oct1): 83  ; oct1 is protected by the top-level set, #o123 -> 83
+(oct2): 42  ; same as oct
+(hex): 291  ; hex is protected by let-temporarily + read
+(hex1): 291 ; hex1 is like oct1
+(hex2): 3   ; hex2 is like oct
+
+ +
+
+ + +
+
+ +

Here is Peter Seibel's wonderful once-only macro: +

+ +
(define-macro (once-only names . body)
+  (let ((gensyms (map (lambda (n) (gensym)) names)))
+    `(let (,@(map (lambda (g) (list g '(gensym))) gensyms))
+       `(let (,,@(map (lambda (g n) (list list g n)) gensyms names))
+          ,(let (,@(map list names gensyms))
+             ,@body)))))
+
+ + + +

From the land of sparkling bacros: +

+ +
(define once-only
+  (let ((names (gensym))
+	(body (gensym)))
+    (apply define-bacro `((,(gensym) ,names . ,body)
+      `(let (,@(map (lambda (name) `(,name ,(eval name))) ,names))
+	 ,@,body)))))
+
+

Sadly, with-let is simpler. +

+
+
+ + + + + +

setter

+ +
(setter proc)
+(dilambda proc setter)
+
+ +

There are several kinds of setters, reflecting the many ways that set! can be called. +First are the symbol setters: +

+ +
> (let ((x 1))
+    (set! (setter 'x) (lambda (name new-value) (* new-value 2)))
+    (set! x 2)
+    x)
+4
+
+ +

Here the setter is a function that is called before the variable is set. +It can take two or three arguments. In the two argument case shown above, +the first is the variable name (a symbol), and the second is the new-value. +The variable is set to the value returned by the setter function. +When s7 sees (set! x 2) above, it calls the setter which returns 4. +So x is set to 4. +

+

In some cases you need the environment that the variable lives in (to get its +current value for example), so you can include that in the setter function parameter list: +

+ +
> (let ((x 1))
+    (set! (setter 'x) (lambda (name new-value enviroment) (* new-value 2)))
+    (set! x 2)
+    x)
+4
+
+(define-macro (watch var) ; notification if 'var is set!
+  `(set! (setter ',var) 
+      (lambda (s v e)
+	(format *stderr* "~S set! to ~S~A~%" s v 
+                (let ((func (with-let e (*function*))))
+                  (if (eq? func #<undefined>) "" (format #f ", ~S" func))))
+	v)))
+
+ +

Since symbol setters are often implementing type restrictions, you can use +the built-in type checking functions such as integer? as a short-hand +for a setter that insists the new value be an integer: +

+ +
> (let ((x 1)) 
+    (set! (setter 'x) integer?)
+    (set! x 3.14))
+error: set! x: 3.14, is a real but should be an integer
+
+;;; use typed-let from stuff.scm to do the same thing:
+> (typed-let ((x 3 integer?))
+    (set! x 3.14))
+error: set! x: 3.14, is a real but should be an integer
+
+ +

C-side symbol setters go through s7_set_setter. There is an example below. +

+ + +

The second case is a function setter. Almost any function or macro can +have an associated setter that is invoked when the function is the target of set!. +In this case, the setter function does the set! itself (unlike a symbol setter): +

+ +
> (setter cadr)
+#f         ; by default cadr has no setter so (set! (cadr p) x) is an error
+> (set! (setter cadr)  ; add a setter to cadr
+        (lambda (lst val) 
+          (set! (car (cdr lst)) val)))
+#<lambda (lst val)>
+> (procedure-source (setter cadr))
+(lambda (lst val) (set! (car (cdr lst)) val))
+> (let ((lst (list 1 2 3))) 
+    (set! (cadr lst) 4)
+    lst)
+(1 4 3)
+
+ +

In some cases, the setter needs to be a macro: +

+ +
> (set! (setter logbit?)
+          (define-macro (m var index on) ; here we want to set "var", so we need a macro
+	    `(if ,on
+	         (set! ,var (logior ,var (ash 1 ,index)))
+	         (set! ,var (logand ,var (lognot (ash 1 ,index)))))))
+m
+> (define (mingle a b)
+    (let ((r 0))
+      (do ((i 0 (+ i 1)))
+          ((= i 31) r)
+        (set! (logbit? r (* 2 i)) (logbit? a i))
+        (set! (logbit? r (+ (* 2 i) 1)) (logbit? b i)))))
+mingle
+> (mingle 6 3) ; the INTERCAL mingle operator?
+30
+
+ +

dilambda defines a function (or macro) and its setter without having to set! the setter by hand: +

+ +
> (define f (let ((x 123))
+                 (dilambda (lambda () 
+                             x)
+		           (lambda (new-value) 
+                             (set! x new-value)))))
+f
+> (f)
+123 ; x = 123 
+> (set! (f) 32)
+32  ; now x = 32
+> (f)
+32
+
+ + +
+ +

Here is a pretty example of dilambda: +

+ +
(define-macro (c?r path)
+  ;; "path" is a list and "X" marks the spot in it that we are trying to access
+  ;; (a (b ((c X)))) — anything after the X is ignored, other symbols are just placeholders
+  ;; c?r returns a dilambda that gets/sets X
+
+  (define (X-marks-the-spot accessor tree)
+    (if (eq? tree 'X)
+        accessor
+        (and (pair? tree)
+	     (or (X-marks-the-spot (cons 'car accessor) (car tree))
+	         (X-marks-the-spot (cons 'cdr accessor) (cdr tree))))))
+
+  (let ((body 'lst))
+    (for-each
+     (lambda (f)
+       (set! body (list f body)))
+     (reverse (X-marks-the-spot () path)))
+
+    `(dilambda
+      (lambda (lst) 
+	,body)
+      (lambda (lst val)
+	(set! ,body val)))))
+
+> ((c?r (a b (X))) '(1 2 (3 4) 5))
+3
+> (let ((lst (list 1 2 (list 3 4) 5))) 
+   (set! ((c?r (a b (X))) lst) 32)
+   lst)
+(1 2 (32 4) 5)
+> (procedure-source (c?r (a b (X))))
+(lambda (lst) (car (car (cdr (cdr lst)))))
+> ((c?r (a b . X)) '(1 2 (3 4) 5))
+((3 4) 5)
+> (let ((lst (list 1 2 (list 3 4) 5))) 
+   (set! ((c?r (a b . X)) lst) '(32))
+   lst)
+(1 2 32)
+> (procedure-source (c?r (a b . X)))
+(lambda (lst) (cdr (cdr lst)))
+> ((c?r (((((a (b (c (d (e X)))))))))) '(((((1 (2 (3 (4 (5 6)))))))))) 
+6
+> (let ((lst '(((((1 (2 (3 (4 (5 6))))))))))) 
+    (set! ((c?r (((((a (b (c (d (e X)))))))))) lst) 32) 
+    lst)
+(((((1 (2 (3 (4 (5 32)))))))))
+> (procedure-source (c?r (((((a (b (c (d (e X)))))))))))
+(lambda (lst) (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (car (car (car lst)))))))))))))))
+
+
+ +

I may remove dilambda and dilambda? someday; they are trivial: +

+ +
(define (dilambda get set) (set! (setter get) set) get)
+(define dilambda? setter)
+
+ +

When a function setter is called, (set! (func ...) val) is +evaluated by s7 as ((setter func) ... val), so the setter function +needs to handle both the inner arguments to the function and the new value. +

+ +
(let ((x 123))
+  (define (f a b) (+ x a b))
+  (set! (setter f) (lambda (a b val) (set! x val)))
+  (display (f 1 2)) (newline) ; "126"
+  (set! (f 1 2) 32)
+  (display (f 1 2)) (newline)) ; "35"
+
+ +

A third type of setter handles vector element type and hash-table key and value types. +These are described under typed vectors and +typed hash-tables. +

+ + +
+
+
+

Speaking of INTERCAL, COME-FROM: +

+ +
(define-macro (define-with-goto-and-come-from name-and-args . body)
+  (let ((labels ())
+	(gotos ())
+	(come-froms ()))
+
+    (let collect-jumps ((tree body))
+      (when (pair? tree)
+	(when (pair? (car tree))
+	  (case (caar tree)
+	    ((label)     (set! labels (cons tree labels)))
+	    ((goto)      (set! gotos (cons tree gotos)))
+	    ((come-from) (set! come-froms (cons tree come-froms)))
+	    (else (collect-jumps (car tree)))))
+	(collect-jumps (cdr tree))))
+
+    (for-each
+     (lambda (goto)
+       (let* ((name (cadr (cadar goto)))
+	      (label (member name labels (lambda (a b) (eq? a (cadr (cadar b)))))))
+	 (if label
+	     (set-cdr! goto (car label))
+	     (error 'bad-goto "can't find label: ~S" name))))
+     gotos)
+    
+    (for-each
+     (lambda (from)
+       (let* ((name (cadr (cadar from)))
+	      (label (member name labels (lambda (a b) (eq? a (cadr (cadar b)))))))
+	 (if label
+	     (set-cdr! (car label) from)
+	     (error 'bad-come-from "can't find label: ~S" name))))
+     come-froms)
+
+    `(define ,name-and-args
+       (let ((label (lambda (name) #f))
+	     (goto (lambda (name) #f))
+	     (come-from (lambda (name) #f)))
+	 ,@body))))
+
+
+
+ + + + + + +

applicable objects, generalized set!, generic functions

+ + +

A procedure with a setter can be viewed as one generalization of set!. Another +treats objects as having predefined get and set functions. In s7 +lists, strings, vectors, hash-tables, environments, and any cooperating C or Scheme-defined objects +are both applicable and settable. newLisp calls this implicit indexing, Kawa has it, Gauche implements it +via object-apply, Guile via procedure-with-setter; CL's funcallable instance might be the same idea. +

+ +

+In (vector-ref #(1 2) 0), for example, vector-ref is just a type +declaration. But in Scheme, type declarations are unnecessary, so we get exactly +the same result from (#(1 2) 0). Similarly, (lst 1) is the +same as (list-ref lst 1), and (set! (lst 1) 2) is the same +as (list-set! lst 1 2). +I like this syntax: the less noise, the better! +

+ +
+ +
+ +

Well, maybe applicable strings look weird: ("hi" 1) is #\i, but worse, +so is (cond (1 => "hi"))! Even though a string, list, or vector is "applicable", it is +not currently considered to be a procedure, so (procedure? "hi") is #f. map and for-each, however, +accept anything that apply can handle, so +(map #(0 1) '(1 0)) is '(1 0). (On the first call to map in this case, you get the result of +(#(0 1) 1) and so on). +string->list, vector->list, and let->list are (map values object). +Their inverses are (and always have been) equally trivial. +

+ + +

The applicable object syntax makes it easy to write generic functions. +For example, s7test.scm has implementations of Common Lisp's sequence functions. +length, copy, reverse, fill!, iterate, map and for-each are generic in this sense (map always returns a list). +

+ +
> (map (lambda (a b) (- a b)) (list 1 2) (vector 3 4))
+(5 -3 9)
+> (length "hi")
+2
+
+ +

+Here's a generic FFT: +

+ +
(define* (cfft data n (dir 1)) ; complex data
+  (unless n (set! n (length data)))
+  (do ((i 0 (+ i 1))
+       (j 0))
+      ((= i n))
+    (if (> j i)
+	(let ((temp (data j)))
+	  (set! (data j) (data i))
+	  (set! (data i) temp)))
+    (do ((m (/ n 2) (/ m 2)))
+        ((not (<= 2 m j))
+         (set! j (+ j m)))
+     (set! j (- j m))))
+  (do ((ipow (floor (log n 2)))
+       (prev 1)
+       (lg 0 (+ lg 1))
+       (mmax 2 (* mmax 2))
+       (pow (/ n 2) (/ pow 2))
+       (theta (complex 0.0 (* pi dir)) (* theta 0.5)))
+      ((= lg ipow))
+    (do ((wpc (exp theta))
+         (wc 1.0)
+         (ii 0 (+ ii 1)))
+	((= ii prev)
+	 (set! prev mmax))
+      (do ((jj 0 (+ jj 1))
+           (i ii (+ i mmax))
+           (j (+ ii prev) (+ j mmax)))
+          ((>= jj pow)
+	   (set! wc (* wc wpc)))
+        (let ((tc (* wc (data j))))
+          (set! (data j) (- (data i) tc))
+          (set! (data i) (+ (data i) tc))))))
+  data)
+
+> (cfft (list 0.0 1+i 0.0 0.0))
+(1+1i -1+1i -1-1i 1-1i)
+> (cfft (vector 0.0 1+i 0.0 0.0))
+#(1+1i -1+1i -1-1i 1-1i)
+
+ +

And a generic function that copies one sequence's elements into another sequence: +

+
(define (copy-into source dest) ; this is equivalent to (copy source dest)
+  (do ((i 0 (+ i 1))) 
+      ((= i (min (length source) (length dest))) 
+       dest)
+    (set! (dest i) (source i))))
+
+ +

but that is already built-in as the two-argument version of the copy function. +

+
+ + +
+ +

There is one place where list-set! and friends are not the same as set!: the former +evaluate their first argument, but set! does not (with a quibble; see below): +

+ +
> (let ((str "hi")) (string-set! (let () str) 1 #\a) str)
+"ha"
+> (let ((str "hi")) (set! (let () str) 1 #\a) str)
+;((let () str) 1 #\a): too many arguments to set!
+> (let ((str "hi")) (set! ((let () str) 1) #\a) str)
+"ha"
+> (let ((str "hi")) (set! (str 1) #\a) str)
+"ha"
+
+ +

set! looks at its first argument to decide what to set. +If it's a symbol, no problem. If it's a pair, set! looks at its car to see if it is +some object that has a setter. If the car is itself a list, set! evaluates the internal +expression, and tries again. So the second case above is the only one that won't work. +And of course: +

+ +
> (let ((x (list 1 2))) 
+    (set! ((((lambda () (list x))) 0) 0) 3) 
+    x) 
+(3 2)
+
+
+ + +
+ +

By my count, around 20 of the Scheme built-in functions are already +generic in the sense +that they accept arguments of many types (leaving aside the numeric and +type checking functions, take for example equal?, display, +member, assoc, apply, eval, quasiquote, and values). s7 extends that +list with map, for-each, reverse, +and length, and adds a few others such as copy, fill!, sort!, +object->string, object->let, and append. +newLisp takes a more radical approach than s7: it extends operators such + as '>' +to compare strings and lists, as well as numbers. In map and for-each, +however, you can mix the argument +types, so I'm not as attracted to making '>' generic; you can't, for +example, (> "hi" 32.1), +or even (> 1 0+i). +

+
+
+ +
+ +

The somewhat non-standard generic sequence functions in s7 are: +

+ +
(sort! sequence less?)
+(reverse! sequence) and (reverse sequence)
+(fill! sequence value (start 0) end)
+(copy obj) and (copy source destination (start 0) end)
+(object->string obj)
+(object->let obj)
+(length obj)
+(append . sequences)
+(map func . sequences) and (for-each func . sequences)
+(equivalent? obj1 obj2)
+
+ +

copy returns a (shallow) copy of its argument. If a destination is provided, +it need not match the source in size or type. The start and end indices refer to the source. +

+
> (copy '(1 2 3 4) (make-list 2))
+(1 2)
+> (copy #(1 2 3 4) (make-list 5) 1) ; start at 1 in the source
+(2 3 4 #f #f)
+> (copy "1234" (make-vector 2))
+#(#\1 #\2)
+> (define lst (list 1 2 3 4 5))
+(1 2 3 4 5)
+> (copy #(8 9) (cddr lst))
+(8 9 5)
+> lst
+(1 2 8 9 5)
+
+ +

reverse! is an in-place version of reverse. That is, +it modifies the sequence passed to it in the process of reversing its contents. +If the sequence is a list, remember to use set!: +(set! p (reverse! p)). This is somewhat inconsistent with other cases, +but historically, lisp programmers have treated the in-place reverse as the fast +version, so s7 follows suit. +

+
> (define lst (list 1 2 3))
+(1 2 3)
+> (reverse! lst)
+(3 2 1)
+> lst
+(1)
+
+ +

Leaving aside the weird list case, +append returns a sequence of the same type as its first argument. +

+ +
> (append #(1 2) '(3 4))
+#(1 2 3 4)
+> (append (float-vector) '(1 2) (byte-vector 3 4))
+(float-vector 1.0 2.0 3.0 4.0)
+
+ +

+sort! sorts a sequence using the +function passed as its second argument: +

+ +
> (sort! (list 3 4 8 2 0 1 5 9 7 6) <)
+(0 1 2 3 4 5 6 7 8 9)
+
+ +

Underlying some of these functions are generic iterators, also built-into s7: +

+ +
(make-iterator sequence)
+(iterator? obj)
+(iterate iterator)
+(iterator-sequence iterator)
+(iterator-at-end? iterator)
+
+ +

make-iterator takes a sequence argument and returns an iterator object that traverses +that sequence as it is called. The iterator itself can be treated as a function of no arguments, +or (for code clarity) it can be the argument to iterate, which does the same thing. +That is (iter) is the same as (iterate iter). The sequence that an iterator is traversing +is iterator-sequence. +

+

+If the sequence is a hash-table or let, the iterator normally returns a cons of the key and value. +There are many cases where this overhead is objectionable, so make-iterator takes a third optional +argument, the cons to use (changing its car and cdr directly on each call). +

+ +

When an iterator reaches the end of its sequence, it returns #<eof>. It used to +return nil; I can't decide whether this change is an improvement. If an iterator over a +list notices that its list is circular, it returns #<eof>. map and for-each use +iterators, so if you pass a circular list to either, it will stop eventually. (An +arcane consequence for method writers: specialize make-iterator, not map or for-each). +

+ +
(define (find-if f sequence)
+  (let ((iter (make-iterator sequence)))
+    (do ((x (iter) (iter)))
+	((or (eof-object? x) (f x))
+	 (and (not (eof-object? x)) x)))))
+
+ +

But of course a sequence might contain #<eof>! So to be really safe, use iterator-at-end? +instead of eof-object?. +

+ +

The argument to make-iterator can also be a function or macro. +There should be a variable named '+iterator+ with a non-#f +value in the closure's environment: +

+
(define (make-circular-iterator obj)
+  (let ((iter (make-iterator obj)))
+    (make-iterator 
+     (let ((+iterator+ #t))
+       (lambda ()
+         (case (iter) 
+           ((#<eof>) ((set! iter (make-iterator obj))))
+           (else)))))))
+
+

The 'iterator? variable is similar to the '+documentation+ variable used by documentation. +It gives make-iterator some hope of catching inadvertent bogus function arguments that would +otherwise cause an infinite loop. +

+ + +

multidimensional vectors

+ + +

+s7 supports +vectors with any number of dimensions. It is here, in particular, that generalized +set! shines. make-vector's second argument can be a list of dimensions, rather than +an integer as in the one dimensional case: +

+ +
(make-vector (list 2 3 4))
+(make-vector '(2 3) 1.0)
+(vector-dimensions (make-vector '(2 3 4))) -> (2 3 4)
+
+ +

The second example includes the optional initial element. +(vect i ...) or (vector-ref vect i ...) return the given +element, and (set! (vect i ...) value) and (vector-set! vect i ... value) +set it. vector-length (or just length) returns the total number of elements. +vector-dimensions returns a list of the dimensions; vector-rank returns the length of this list, +and vector-dimension returns the nth member of the list (the size of the nth dimension). +

+ +
> (define v (make-vector '(2 3) 1.0))
+#2d((1.0 1.0 1.0) (1.0 1.0 1.0))
+> (set! (v 0 1) 2.0)
+#2d((1.0 2.0 1.0) (1.0 1.0 1.0))
+> (v 0 1)
+2.0
+> (vector-length v)
+6
+
+ +

This function initializes each element of a multidimensional vector: +

+ +
(define (make-array dims . inits)
+  (subvector (apply vector (flatten inits)) 0 (apply * dims) dims))
+
+> (make-array '(3 3) '(1 1 1) '(2 2 2) '(3 3 3))
+#2d((1 1 1) (2 2 2) (3 3 3))
+
+ +

make-int-vector, make-float-vector, and make-byte-vector produce homogeneous vectors holding +s7_ints, s7_doubles, or unsigned bytes. +

+ +
(make-vector length-or-list-of-dimensions initial-value element-type-function)
+(vector-dimensions vect)
+(vector-dimension vect n)
+(vector-rank obj)
+
+(float-vector? obj)
+(float-vector . args)
+(make-float-vector len (init 0.0))
+(float-vector-ref obj . indices)
+(float-vector-set! obj indices[...] value)
+
+(int-vector? obj)
+(int-vector . args)
+(make-int-vector len (init 0))
+(int-vector-ref obj . indices)
+(int-vector-set! obj indices[...] value)
+
+(byte-vector? obj)
+(byte-vector . args)
+(make-byte-vector len (init 0))
+(byte-vector-ref obj . indices)
+(byte-vector-set! obj indices[...] byte)
+(byte? obj)
+
+(string->byte-vector str)
+(byte-vector->string str)
+
+(subvector vector start end dimensions)
+(subvector? obj) 
+(subvector-vector obj) 
+(subvector-position obj)
+
+ +

In addition to the dimension list mentioned above, make-vector accepts +optional arguments giving the initial element and the element type. If the +type is given, every attempt to set an element of the vector first calls +the type function on the new value. +If the type function is omitted (or set to #t), +no type checking is performed. +If the type function is a closure (rather than a C-defined or built-in function), +its name must be accessible; it can't be an anonymous lambda (the signature and +error handlers need this name). +

+ +
> (define v (make-vector 3 'x symbol?)) ; initial element: 'x, elements must be symbols
+#(x x x)
+> (vector-set! v 0 123)
+error: vector-set! argument 3, 123, is an integer but should be a symbol?
+> (define (10|12? val) (memv val '(10 12)))
+10|12?
+> (define v1 (make-vector 3 10 10|12?)) ; only allow values 10 or 12 (initially 10)
+#(10 10 10)
+> (set! (v1 0) 12)
+12
+> v1
+#(12 10 10)
+> (set! (v1 1) 32)
+error: vector-set! argument 3, 32, is an integer but should be a 10|12?
+
+ +

To access a vector's elements with different dimensions than the original had, use +(subvector original-vector 0 (length original-vector) new-dimensions): +

+ +
> (let ((v1 #2d((1 2 3) (4 5 6)))) 
+    (let ((v2 (subvector v1))) ; flatten the original (1D is the default)
+      v2))
+#(1 2 3 4 5 6)
+> (let ((v1 #(1 2 3 4 5 6))) 
+    (let ((v2 (subvector v1 0 6 '(3 2)))) 
+      v2))
+#2d((1 2) (3 4) (5 6))
+
+

A subvector is a window onto some other vector's data. The data is not copied, just accessed differently. +The new-dimensions parameter is a list giving the lengths of the dimensions. The start and +end parameters refer to positions in the original vector. +subvector-vector returns +the underlying vector, and subvector-position returns the starting point of the subvector +in the underlying data. +

+ +
+

subvector's parameter list changed 8-Jul-2020. It was (subvector vect new-length-or-dimension-list start), +but that conflicts with substring, and is confusing (the start position follows the length). To translate from +the old subvector to the new: +

+
(define* (old-subvector vect len (offset 0))
+  (if (pair? len)
+      (subvector vect offset (+ offset (apply * len)) len)
+      (if (not len)
+          (subvector vect offset (length vect))
+          (subvector vect offset (+ offset len)))))
+
+
+
+ +
+ +

matrix multiplication: +

+ +
(define (matrix-multiply A B)
+  ;; assume square matrices and so on for simplicity
+  (let ((size (car (vector-dimensions A))))
+    (do ((C (make-vector (list size size) 0))
+         (i 0 (+ i 1)))
+	((= i size) C)
+      (do ((j 0 (+ j 1)))
+	  ((= j size))
+	(do ((sum 0)
+             (k 0 (+ k 1)))
+	    ((= k size)
+             (set! (C i j) sum))
+	  (set! sum (+ sum (* (A i k) (B k j)))))))))
+
+
+ + +
+ +

Conway's game of Life: +

+ +
(define* (life (width 40) (height 40))
+  (let ((state0 (make-vector (list width height) 0))
+	(state1 (make-vector (list width height) 0)))
+
+    ;; initialize with some random pattern
+    (do ((x 0 (+ x 1)))
+	((= x width))
+      (do ((y 0 (+ y 1)))
+	  ((= y height))
+	(set! (state0 x y) (if (< (random 100) 15) 1 0))))
+
+    (do () ()
+      ;; show current state (using terminal escape sequences, borrowed from the Rosetta C code)
+      (format *stderr* "~C[H" #\escape)           ; ESC H = tab set
+      (do ((y 0 (+ y 1)))
+	  ((= y height))
+	(do ((x 0 (+ x 1)))
+	    ((= x width))
+	  (format *stderr*
+                  (if (zero? (state0 x y))
+	              "  "                        ; ESC 07m below = inverse
+	              (values "~C[07m  ~C[m" #\escape #\escape))))
+	(format *stderr* "~C[E" #\escape))        ; ESC E = next line
+
+      ;; get the next state
+      (do ((x 1 (+ x 1)))
+	  ((= x (- width 1)))
+	(do ((y 1 (+ y 1)))
+	    ((= y (- height 1)))
+	  (let ((n (+ (state0 (- x 1) (- y 1))
+		      (state0    x    (- y 1))
+		      (state0 (+ x 1) (- y 1))
+		      (state0 (- x 1)    y)      
+		      (state0 (+ x 1)    y)      
+		      (state0 (- x 1) (+ y 1))
+		      (state0    x    (+ y 1))
+		      (state0 (+ x 1) (+ y 1)))))
+	    (set! (state1 x y) 
+		  (if (or (= n 3) 
+			  (and (= n 2)
+			       (not (zero? (state0 x y)))))
+		      1 0)))))
+      (copy state1 state0))))
+
+
+ + +
+ +

Multidimensional vector constant syntax is modelled after CL: #nd(...) +signals that the lists specify the elements of an 'n' dimensional vector: #2d((1 2 3) (4 5 6)) +int-vector constants use #i, float-vectors use #r. I wanted to use #f, but that is already taken. +Append the "nd" business after the type indication: #i2d((1 2) (3 4)). This syntax +collides with the r7rs byte-vector notation "#u8"; s7 uses "#u" for byte-vectors. "#u2d(...)" is a two-dimensional byte-vector. +For backwards compatibility, you can use "#u8" for one-dimensional byte-vectors. +

+ +
> (vector-ref #2d((1 2 3) (4 5 6)) 1 2)
+6
+> (matrix-multiply #2d((-1 0) (0 -1)) #2d((2 0) (-2 2)))
+#2d((-2 0) (2 -2))
+> (int-vector 1 2 3)
+#i(1 2 3)
+> (make-float-vector '(2 3) 1.0)
+#r2d((1.0 1.0 1.0) (1.0 1.0 1.0))
+> (vector (vector 1 2) (int-vector 1 2) (float-vector 1 2))
+#(#(1 2) #i(1 2) #r(1.0 2.0))
+
+ +

If any dimension has 0 length, you get an n-dimensional empty vector. It is not +equal to a 1-dimensional empty vector. +

+ +
> (make-vector '(10 0 3))
+#3d()
+> (equal? #() #3d())
+#f
+
+
+ + +
+ +

To save on costly parentheses, and make it easier to write generic multidimensional sequence functions, +you can use this same syntax with lists. +

+ +
> (let ((L '((1 2 3) (4 5 6))))
+    (L 1 0))              ; same as (list-ref (list-ref L 1) 0) or ((L 1) 0)
+4
+> (let ((L '(((1 2 3) (4 5 6)) ((7 8 9) (10 11 12))))) 
+    (set! (L 1 0 2) 32)   ; same as (list-set! (list-ref (list-ref L 1) 0) 2 32) which is unreadable!
+    L)
+(((1 2 3) (4 5 6)) ((7 8 32) (10 11 12)))
+
+ +

Or with vectors of vectors, of course: +

+ +
> (let ((V #(#(1 2 3) #(4 5 6)))) 
+    (V 1 2))              ; same as (vector-ref (vector-ref V 1) 2) or ((V 1) 2)
+6
+> (let ((V #2d((1 2 3) (4 5 6))))
+    (V 0))
+#(1 2 3)
+
+ +

There's one difference between a vector-of-vectors and a multidimensional vector: +in the latter case, you can't clobber one of the inner vectors. +

+ +
> (let ((V #(#(1 2 3) #(4 5 6)))) (set! (V 1) 32) V)
+#(#(1 2 3) 32)
+> (let ((V #2d((1 2 3) (4 5 6)))) (set! (V 1) 32) V)
+;not enough arguments for vector-set!: (#2d((1 2 3) (4 5 6)) 1 32)
+
+
+ + + +
+ +

Using lists to display the inner vectors may not be optimal, especially when the elements are also lists: +

+ +
#2d(((0) (0) ((0))) ((0) 0 ((0))))
+
+ +

The "#()" notation is no better (the elements can be vectors), and I'm not a fan of "[]" parentheses. +Perhaps we could use different colors? Or different size parentheses? +

+ +
#2D(((0) (0) ((0))) ((0) 0 ((0))))
+#2D(((0) (0) ((0))) ((0) 0 ((0))))
+
+ +
+ + + +
+ +

I'm not sure how to handle vector->list and list->vector in the multidimensional case. +Currently, vector->list flattens the vector, and list->vector always returns a +one dimensional vector, so the two are not inverses. +

+ +
> (vector->list #2d((1 2) (3 4)))
+(1 2 3 4)             ; should this be '((1 2) (3 4)) or '(#(1 2) #(3 4))?
+> (list->vector '(#(1 2) #(3 4))) ; what about '((1 2) (3 4))?
+#(#(1 2) #(3 4))      
+
+ +

+This also affects format and sort!: +

+ +
> (format #f "~{~A~^ ~}" #2d((1 2) (3 4)))
+"1 2 3 4"
+> (sort! #2d((1 4) (3 2)) >) 
+#2d((4 3) (2 1))
+
+ +

Perhaps subvector can help: +

+ +
>(subvector (list->vector '(1 2 3 4)) 0 4 '(2 2))
+#2d((1 2) (3 4))
+> (let ((a #2d((1 2) (3 4)))
+        (b #2d((5 6) (7 8))))
+  (list (subvector (append a b) 0 8 '(2 4))
+	(subvector (append a b) 0 8 '(4 2))
+	(subvector (append (a 0) (b 0) (a 1) (b 1)) 0 8 '(2 4))
+	(subvector (append (a 0) (b 0) (a 1) (b 1)) 0 8 '(4 2))))
+(#2d((1 2 3 4) (5 6 7 8)) 
+ #2d((1 2) (3 4) (5 6) (7 8)) 
+ #2d((1 2 5 6) (3 4 7 8)) 
+ #2d((1 2) (5 6) (3 4) (7 8)))
+
+ +
+ +
+ +

Another question: should we accept the multi-index syntax in a case such as +(#("abc" "def") 0 2)? +My first thought was that the indices should all refer to the same +type of object, so s7 would complain in a mixed case like that. +If we can nest any applicable objects and apply the whole thing to +an arbitrary list of indices, ambiguities arise: +

+ +
((lambda (x) x) "hi" 0) 
+((lambda (x) (lambda (y) (+ x y))) 1 2)
+
+ +

I think these should complain that the function got too many arguments, +but from the implicit indexing point of view, they could be interpreted +as: +

+ +
(string-ref ((lambda (x) x) "hi") 0) ; i.e. (((lambda (x) x) "hi") 0)
+(((lambda (x) (lambda (y) (+ x y))) 1) 2)
+
+ +

Add optional and rest arguments, and you can't tell who is supposed to +take which arguments. +Currently, you can mix types with implicit indices, +but a function grabs all remaining indices. +To insist that all objects are of the same type, use an explicit getter: +

+ +
> (list-ref (list 1 (list 2 3)) 1 0) ; same as ((list 1 (list 2 3)) 1 0)
+2
+> ((list 1 (vector 2 3)) 1 0)
+2
+> (list-ref (list 1 (vector 2 3)) 1 0)
+error: list-ref argument 1, #(2 3), is a vector but should be a proper list
+
+
+ +
+ + + +

hash-tables

+ + +
    +
  • (make-hash-table (size 8) eq-func typers) +
  • (make-weak-hash-table (size 8) eq-func typers) +
  • (hash-table ...) +
  • (weak-hash-table ...) +
  • (hash-table? obj) +
  • (weak-hash-table? obj) +
  • (hash-table-ref ht key) +
  • (hash-table-set! ht key value) +
  • (hash-table-entries ht) +
  • (hash-code obj eqfunc) +
+ +

+Each hash-table keeps track of the keys it contains, optimizing the search wherever possible. +Any s7 object can be the key or the key's value. +If you pass a table size that is not a power of 2, make-hash-table rounds it up to the next power of 2. +The table grows as needed. length returns the current size. +If a key is not in the table, hash-table-ref returns #f. To remove a key, +set its value to #f; to remove all keys, (fill! table #f). +

+ +
> (let ((ht (make-hash-table)))
+    (set! (ht "hi") 123)
+    (ht "hi"))
+123
+
+ +

hash-table (the function) parallels the functions vector, list, and string. +Its arguments are +the keys and values: (hash-table 'a 1 'b 2). +Implicit indexing gives multilevel hashes: +

+ +
> (let ((h (hash-table 'a (hash-table 'b 2 'c 3)))) (h 'a 'b))
+2
+> (let ((h (hash-table 'a (hash-table 'b 2 'c 3)))) (set! (h 'a 'b) 4) (h 'a 'b))
+4
+
+ +

hash-code is like Common Lisp's sxhash. It returns an integer that can be associated with +an s7 object when implementing your own hash-tables. s7test.scm has an example using vectors. +The eqfunc argument is currently ignored (hash-code assumes equal? is in use). +

+ + +
+ +
+ +

Since hash-tables accept the same applicable-object syntax that vectors use, we can +treat a hash-table as, for example, a sparse array: +

+ +
> (define make-sparse-array make-hash-table)
+make-sparse-array
+> (let ((arr (make-sparse-array)))
+   (set! (arr 1032) "1032")
+   (set! (arr -23) "-23")
+   (list (arr 1032) (arr -23)))
+("1032" "-23")
+
+
+ + +
+ +

map and for-each accept hash-table arguments. On each iteration, the map or for-each function is passed +an entry, '(key . value), in whatever order the entries are encountered in the table. +

+ +
(define (hash-table->alist table)
+  (map values table))
+
+ +

reverse of a hash-table returns a new table with the keys and values reversed. +fill! sets all the values. +Two hash-tables are equal if they have the same keys with the same values. This is independent +of the table sizes, or the order in which the key/value pairs were added. +

+
+ +
+

The second argument to make-hash-table (eq-func) is slightly complicated. If it is omitted, +s7 chooses the hashing equality and mapping functions based on the keys in the hash-table. +There are times when you know +in advance what equality function you want. If it's one of the built-in s7 equality +functions, eq?, eqv?, equal?, equivalent?, =, string=?, string-ci=?, char=?, or char-ci=?, +you can pass that function as the second argument. In any other case, you need to +give s7 both the equality function and the mapping function. The latter takes any object +and returns the hash-table location for it (an integer). The problem here is that +for the arbitrary equality function to work, objects that are equal according to that +function have to be mapped to the same hash-table location. There's no way for s7 to intuit +what this mapping should be except in the built-in cases. So to specify some arbitrary function, the second +argument is a cons: '(equality-checker mapper). +

+ +

Here's a brief example. In CLM, we have c-objects of type mus-generator (from s7's point of view), +and we want to hash them using equal? (which will call the generator-specific equality function). +But s7 doesn't realize that the mus-generator type covers 40 or 50 internal types, so as the mapper we pass mus-type: +(make-hash-table 64 (cons equal? mus-type)). +

+
+ +
+

If the hash key is a float (a non-rational number), hash-table-ref uses equivalent?. +Otherwise, for example, you could use NaN as a key, but then never be able to access it! +

+
+ +
+

To implement read-time hash-tables using #h(...): +

+
(set! *#readers* 
+      (cons (cons #\h (lambda (str)
+			(and (string=? str "h") ; #h(...)
+			     (apply hash-table (read)))))
+	    *#readers*))
+
+(display #h(:a 1)) (newline)
+(display #h(:a 1 :b "str")) (newline)
+
+

These can be made immutable by (immutable! (apply...)), or even better, +

+
(let ((h (apply hash-table (read)))) 
+  (if (> (*s7* 'safety) 1) (immutable! h) h))
+
+
+ + +
+
(define-macro (define-memoized name&arg . body)
+  (let ((arg (cadr name&arg))
+	(memo (gensym "memo")))
+    `(define ,(car name&arg)
+       (let ((,memo (make-hash-table)))
+	 (lambda (,arg)
+	   (or (,memo ,arg)                             ; check for saved value
+	       (set! (,memo ,arg) (begin ,@body)))))))) ; set! returns the new value
+
+> (define (fib n) 
+  (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+fib
+> (define-memoized 
+   (memo-fib n) 
+     (if (< n 2) n (+ (memo-fib (- n 1)) (memo-fib (- n 2)))))
+memo-fib
+> (time (fib 34))         ; un-memoized time
+1.168                        ;   0.70 on ccrma's i7-3930 machines
+> (time (memo-fib 34))    ; memoized time
+3.200e-05
+> (outlet (funclet memo-fib))
+(inlet '{memo}-18 (hash-table 
+    '(0 . 0) '(1 . 1) '(2 . 1) '(3 . 2) '(4 . 3) '(5 . 5) 
+    '(6 . 8) '(7 . 13) '(8 . 21) '(9 . 34) '(10 . 55) '(11 . 89) 
+    '(12 . 144) '(13 . 233) '(14 . 377) '(15 . 610) '(16 . 987) 
+    '(17 . 1597) '(18 . 2584) '(19 . 4181) '(20 . 6765) '(21 . 10946) 
+    '(22 . 17711) '(23 . 28657) '(24 . 46368) '(25 . 75025) '(26 . 121393) 
+    '(27 . 196418) '(28 . 317811) '(29 . 514229) '(30 . 832040) '(31 . 1346269) 
+    '(32 . 2178309) '(33 . 3524578) '(34 . 5702887)))
+
+

but the tail recursive version of fib is simpler and almost as fast as the memoized version, +and the iterative version beats both. +

+
+ +

The third argument, typers, sets type checkers for the keys and values in the table, +much like the third argument to make-vector. +It is a cons of the type functions, +(cons symbol? integer?) for example. This says that all the keys must +be symbols and all the values integers. +

+
> (define (10|12? val) (memv val '(10 12)))
+10|12?
+> (define hash (make-hash-table 8 #f (cons #t 10|12?))) ; any key is ok, but all values must be 10 or 12
+(hash-table)
+> (set! (hash 'a) 10)
+10
+> hash
+(hash-table 'a 10)
+> (set! (hash 'b) 32)
+error: hash-table-set! value argument 3, 32, is an integer but should be a 10|12?
+
+ +
+ + + + + +

environments

+ + +

An environment holds symbols and their values. The global environment, for example, +holds all the variables that are defined at the top level. +Environments are first class (and applicable) objects in s7. +

+ +
(rootlet)               the top-level (global) environment
+(curlet)                the current (innermost) environment
+(funclet proc)          the environment at the time when proc was defined
+(funclet? env)          #t if env is a funclet
+(owlet)                 the environment at the point of the last error
+(unlet)                 a let with any built-in functions that do not have their original value
+
+(let-ref env sym)       get value of sym in env, same as (env sym)
+(let-set! env sym val)  set value of sym in env to val, same as (set! (env sym) val)
+
+(inlet . bindings)       make a new environment with the given bindings
+(sublet env . bindings)  same as inlet, but the new environment is local to env
+(varlet env . bindings)  add new bindings directly to env
+(cutlet env . fields)    remove bindings from env
+
+(let? obj)               #t if obj is an environment
+(with-let env . body)    evaluate body in the environment env 
+(outlet env)             the environment that encloses the environment env (settable)
+(let->list env)          return the environment bindings as a list of (symbol . value) cons's
+
+(openlet env)            mark env as open (see below)
+(openlet? env)           #t is env is open
+(coverlet env)           mark env as closed (undo an earlier openlet)
+
+(object->let obj)        return an environment containing information about obj 
+(let-temporarily vars . body)
+
+ + +
+
> (inlet 'a 1 'b 2)
+(inlet 'a 1 'b 2)
+> (let ((a 1) (b 2)) (curlet))
+(inlet 'a 1 'b 2)
+> (let ((x (inlet :a 1 :b 2))) (x 'a))
+1
+> (with-let (inlet 'a 1 'b 2) (+ a b))
+3
+> (let ((x (inlet :a 1 :b 2))) (set! (x 'a) 4) x)
+(inlet 'a 4 'b 2)
+> (let ((x (inlet))) (varlet x 'a 1) x)
+(inlet 'a 1)
+> (let ((a 1)) (let ((b 2)) (outlet (curlet))))
+(inlet 'a 1)
+> (let ((e (inlet 'a (inlet 'b 1 'c 2)))) (e 'a 'b)) ; in C terms, e->a->b 
+1  
+> (let ((e (inlet 'a (inlet 'b 1 'c 2)))) (set! (e 'a 'b) 3) (e 'a 'b))
+3
+> (define* (make-let (a 1) (b 2)) (sublet (rootlet) (curlet)))
+make-let
+> (make-let :b 32)
+(inlet 'a 1 'b 32)
+
+
+ +

As the names suggest, in s7 an environment is viewed as a disembodied let. Environments are equal if they +contain the same symbols with the same values leaving aside shadowing, and taking into account the environment +chain up to the rootlet. That is, two environments are equal if any local variable of either has the same value in both. +

+ +

let-ref and let-set! return #<undefined> if the first argument is not +defined in the environment or its parents. To search just the given environment (ignoring its outlet chain), +use defined? with the third argument #t before calling let-ref or let-set!: +

+ +
> (defined? 'car (inlet 'a 1) #t)
+#f
+> (defined? 'car (inlet 'a 1))
+#t
+
+ +

This matters in let-set!: (let-set! (inlet 'a 1) 'car #f) +is the same as (set! car #f)! +

+ +

+with-let evaluates its body in the given environment, so +(with-let e . body) is equivalent to +(eval `(begin ,@body) e), but probably faster. +Similarly, (let bindings . body) is equivalent to +(eval `(begin ,@body) (apply inlet (flatten bindings))), +ignoring the outer (enclosing) environment (the default outer environment +of inlet is rootlet). +Or better, +

+
(define-macro (with-environs e . body) 
+  `(apply let (map (lambda (a) (list (car a) (cdr a))) ,e) '(,@body)))
+
+

Or turning it around,

+
(define-macro (Let vars . body)
+  `(with-let (sublet (curlet) 
+	       ,@(map (lambda (var)
+			(values (symbol->keyword (car var)) (cadr var)))
+		      vars))
+     ,@body))
+
+(Let ((c 4))
+  (Let ((a 2)
+        (b (+ c 2)))
+  (+ a b c)))
+
+

It is faster to use (biglet 'a-function) than (with-let biglet a-function). +

+ +

let-temporarily (now built-into s7) is somewhat similar to fluid-let in other Schemes. +Its syntax looks like +let, but it first saves the current value, then sets the +variable to the new value (via set!), calls the body, and finally restores the +original value. It can handle anything settable: +

+
(let-temporarily (((*s7* 'print-length) 8)) (display x))
+
+

This sets s7's print-length variable to 8 while displaying x, then +puts it back to its original value. +

+
> (define ourlet
+    (let ((x 1))
+      (define (a-func) x)
+      (define b-func (let ((y 1))
+		       (lambda ()
+		         (+ x y))))
+    (curlet)))
+(inlet 'x 1 'a-func a-func 'b-func b-func)
+> (ourlet 'x)
+1
+> (let-temporarily (((ourlet 'x) 2))
+    ((ourlet 'a-func)))
+2
+> ((funclet (ourlet 'b-func)) 'y)
+1
+> (let-temporarily ((((funclet (ourlet 'b-func)) 'y) 3))
+    ((ourlet 'b-func)))
+4
+
+

Despite the name, no new environment is created by let-temporarily: +(let () (let-temporarily () (define x 2)) (+ x 1)) is 3. +

+ +

+sublet adds bindings (symbols with associated values) to an environment. +It does not change the environment passed to it, but +just prepends the new bindings, shadowing any old ones, +as if you had called "let". +To add the bindings directly to the environment, +use varlet. Both of these functions accept nil as the +'env' argument as shorthand for (rootlet). +Both also accept other environments as well as individual bindings, +adding all the argument's bindings to the new environment. +inlet is very similar, but normally omits the environment argument. +The arguments to sublet and inlet can be passed as +symbol/value pairs, as a cons, or using keywords as if in define*. +inlet can also be used to copy an environment without accidentally invoking +that environment's copy method. +

+ +

Here's an example: we want to define two functions that share a +local variable: +

+ +
(varlet (curlet)            ; import f1 and f2 into the current environment
+  (let ((x 1))              ; x is our local variable
+    (define (f1 a) (+ a x)) 
+    (define (f2 b) (* b x)) 
+    (inlet 'f1 f1 'f2 f2))) ; export f1 and f2
+
+ +

One way to add reader and writer functions to an individual environment slot is: +

+ +
(define e (inlet 
+            'x (let ((local-x 3)) ; x's initial value
+		 (dilambda
+		   (lambda () local-x)
+		   (lambda (val) (set! local-x (max 0 (min val 100))))))))
+> ((e 'x))
+3
+> (set! ((e 'x)) 123)
+100
+
+ +

funclet returns a function's local environment. Here's an example that +keeps a circular buffer of the calls to that function: +

+ +
(define func (let ((history (let ((lst (make-list 8 #f)))
+			      (set-cdr! (list-tail lst 7) lst))))
+	       (lambda (x y)
+		 (let ((result (+ x y)))
+		   (set-car! history (list result x y))
+		   (set! history (cdr history))
+		   result))))
+
+> (func 1 2)
+3
+> (func 3 4)
+7
+> ((funclet func) 'history)
+#1=(#f #f #f #f #f #f (3 1 2) (7 3 4) . #1#)
+
+ + +

It is possible in Scheme to redefine built-in functions such as car. +To ensure that some code sees the original built-in function definitions, +wrap it in (with-let (unlet) ...): +

+
> (let ((caar 123)) 
+    (+ caar (with-let (unlet) 
+              (caar '((2) 3)))))
+125
+
+

Or perhaps better, to keep the current environment intact except for the +changed built-ins: +

+
> (let ((x 1) 
+        (display 3))
+    (with-let (sublet (curlet) (unlet)) ; (curlet) picks up 'x, (unlet) the original 'display
+      (display x)))
+1
+
+ +
+

+with-let and unlet are constants, so you can +use them in any context without worrying about whether they've been redefined. +As mentioned in the macro section, #_<name> is a built-in reader macro +for (with-let (unlet) <name>), +so for example, #_+ is the built-in + function, no matter what. +(The environment of built-in functions +that unlet accesses is not accessible from scheme code, so there's no way +that those values can be clobbered). +

+ + +
+ +

+I think these functions can implement the notions of libraries, +separate namespaces, or modules. +Here's one way: first the library writer just writes his library. +The normal user simply loads it. The abnormal user worries about everything, +so first he loads the library in a local let to make sure no bindings escape +to pollute his code, and then he +uses unlet to +make sure that none of his bindings pollute the library code: +

+ +
(let ()
+  (with-let (unlet)
+    (load "any-library.scm" (curlet)) 
+    ;; by default load puts stuff in the global environment
+    ...))
+
+ +

Now Abnormal User can do what he wants with the library entities. +Say he wants to use "lognor" under the name "bitwise-not-or", and +all the other functions are of no interest: +

+ +
(varlet (curlet)
+  'bitwise-not-or (with-let (unlet)
+                    (load "any-library.scm" (curlet))
+                    lognor)) ; lognor is presumably defined in "any-library.scm"
+
+ +

Say he wants to make sure the library is cleanly loaded, but all +its top-level bindings are imported into the current environment: +

+ +
(varlet (curlet)
+  (with-let (unlet)
+    (let ()
+      (load "any-library.scm" (curlet))
+      (curlet)))) ; these are the bindings introduced by loading the library
+
+ +

To do the same thing, but prepend "library:" to each name: +

+ +
(apply varlet (curlet)
+  (with-let (unlet)
+    (let ()
+      (load "any-library.scm" (curlet))
+      (map (lambda (binding)
+	     (cons (symbol "library:" (symbol->string (car binding)))
+		   (cdr binding)))
+	    (curlet)))))
+
+ +

That's all there is to it! Here is the same idea as a macro: +

+ +
(define-macro (let! init end . body)
+  ;; syntax mimics 'do: (let! (vars&values) ((exported-names) result) body)
+  ;;   (let! ((a 1)) ((hiho)) (define (hiho x) (+ a x)))
+  `(let ,init
+     ,@body
+     (varlet (outlet (curlet))
+       ,@(map (lambda (export)
+		`(cons ',export ,export))
+	      (car end)))
+     ,@(cdr end)))
+
+ + + +
+ +
+

Well, almost, darn it. If the loaded library file sets (via set!) a global value +such as abs, we need to put it back to its original form: +

+ +
(define (safe-load file)
+  (let ((e (with-let (unlet)         ; save the environment before loading
+	     (let->list (curlet)))))
+    (load file (curlet))
+    (let ((new-e (with-let (unlet)   ; get the environment after loading
+		   (let->list (curlet)))))
+      (for-each                       ; see if any built-in functions were stepped on
+       (lambda (sym)
+	 (unless (assoc (car sym) e)
+	   (format () "~S clobbered ~A~%" file (car sym))
+	   (apply set! (car sym) (list (cdr sym)))))
+       new-e))))
+
+;; say libtest.scm has the line (set! abs odd?)
+
+> (safe-load "libtest.scm")
+"libtest.scm" clobbered abs
+> (abs -2)
+2
+
+ +
+
+ + +

openlet marks its argument, either an environment, a closure, a c-object, or a c-pointer +as open; coverlet as closed. I need better terminology here! An open object is one that the +built-in s7 functions handle specially. If they encounter one in their +argument list, they look in the object for their own name, and call that +function if it exists. A bare-bones example: +

+ +
> (abs (openlet (inlet 'abs (lambda (x) 47))))
+47
+> (define* (f1 (a 1)) (if (real? a) (abs a) ((a 'f1) a)))
+f1
+> (f1 :a (openlet (inlet 'f1 (lambda (e) 47))))
+47
+
+ +

In CLOS, we'd declare a class and a method, and call make-instance, +and then discover that it wouldn't work anyway. +Here we have, in effect, an anonymous instance of an anonymous class. +I think this is called a "prototype system"; javascript is apparently similar. +A slightly more complex example: +

+ +
(let* ((e1 (openlet 
+	   (inlet 
+	    'x 3
+	    '* (lambda args
+		 (apply * (if (number? (car args))
+		     	      (values (car args) ((cadr args) 'x) (cddr args))
+		              (values ((car args) 'x) (cdr args))))))))
+       (e2 (copy e1)))
+  (set! (e2 'x) 4)
+  (* 2 e1 e2)) ; (* 2 3 4) => 24
+
+ +

Perhaps these names would be better: openlet -> with-methods, coverlet -> without-methods, +and openlet? -> methods?. +

+ +
+ +
+

let-ref and let-set! are problematic as methods. It is very easy to get into an infinite +loop, especially with let-ref since any reference to the let within the method body probably +calls let-ref, which calls the let-ref method. We used to recommend coverlet here, but +even that is not enough, so not let-ref and let-set! are immutable; they can't be used +as methods. +Use let-ref-fallback and let-set-fallback instead, if possible. +

+ +
+
+ + +

object->let returns an environment (more of a dictionary really) that +contains details about its argument. It +is intended as a debugging aid, underlying a debugger's "inspect" for example. +

+ +
> (let ((iter (make-iterator "1234")))
+    (iter)
+    (iter)
+    (object->let iter))
+(inlet 'value #<iterator: string> 'type iterator? 'at-end #f 'sequence "1234" 'length 4 'position 2)
+
+ +

A c-object (in the sense of s7_make_c_type), can add its own info to this namespace via an object->let +method in its local environment. snd-marks.c has a simple example using a class-wide environment (g_mark_methods), +holding as the value of its 'object->let field the function s7_mark_to_let. The latter uses s7_varlet to +add information to the namespace created by (object->let mark). +

+ + +
+
(define-macro (value->symbol expr)
+  `(let ((val ,expr)
+	 (e1 (curlet)))
+     (call-with-exit
+      (lambda (return)
+	(do ((e e1 (outlet e))) ()
+	  (for-each 
+	   (lambda (slot)
+	     (if (equal? val (cdr slot))
+		 (return (car slot))))
+	   e)
+	  (if (eq? e (rootlet))
+	      (return #f)))))))
+
+> (let ((a 1) (b "hi")) 
+    (value->symbol "hi"))
+b
+
+
+ + +
+

openlet alerts the rest of s7 that the environment has methods. +

+ +
(begin
+  (define fvector? #f)
+  (define make-fvector #f)
+  (let ((type (gensym))
+	(->float (lambda (x)
+		   (if (real? x)
+		       (* x 1.0)
+		       (error 'wrong-type-arg "fvector new value is not a real: ~A" x)))))
+    (set! make-fvector
+	  (lambda* (len (init 0.0)) 
+	    (openlet
+	     (inlet :v (make-vector len (->float init))
+	            :type type
+	   	    :length (lambda (f) len)
+		    :object->string (lambda (f . args) "#<fvector>")
+		    :let-set! (lambda (fv i val) (#_vector-set! (fv 'v) i (->float val)))
+		    :let-ref-fallback (lambda (fv i) (#_vector-ref (fv 'v) i))))))
+    (set! fvector? (lambda (p)
+		     (and (let? p)
+			  (eq? (p 'type) type))))))
+  
+> (define fv (make-fvector 32))
+fv
+> fv
+#<fvector>
+> (length fv)
+32
+> (set! (fv 0) 123)
+123.0
+> (fv 0)
+123.0
+
+ +
+ + + +
+

If an s7 function ignores the type of an argument, as in cons or vector for example, +then that argument won't be treated as having any methods. +

+ +

+Since outlet is settable, there are two ways an environment can +become circular. One is to include the current environment as the value of one of its variables. +The other is: (let () (set! (outlet (curlet)) (curlet))). +

+ +

If you want to hide an environment's fields from any part of s7 that does not +know the field names in advance, +

+
(openlet  ; make it appear to be empty to the rest of s7
+  (inlet 'object->string  (lambda args "#<let>")
+         'map             (lambda args ())
+         'for-each        (lambda args #<unspecified>)
+  	 'let->list       (lambda args ())
+         'length          (lambda args 0)
+	 'copy            (lambda args (inlet))
+ 	 'open #t
+	 'coverlet        (lambda (e) (set! (e 'open) #f) e)
+	 'openlet         (lambda (e) (set! (e 'open) #t) e)
+	 'openlet?        (lambda (e) (e 'open))
+         ;; your secret data here
+         ))
+
+

(There are still at least two ways to tell that something is fishy). +

+ +
+ + +
+

Here's one way to add a method to a closure: +

+
(define sf (let ((object->string (lambda (obj . arg) 
+				   "#<secret function!>")))
+	     (openlet (lambda (x) 
+			(+ x 1)))))
+> sf
+#<secret function!>
+
+
+ + + +

multiple-values

+ +

+In s7, multiple values are spliced directly into the caller's argument list. +

+ +
> (+ (values 1 2 3) 4)
+10
+> (string-ref ((lambda () (values "abcd" 2))))
+#\c
+> ((lambda (a b) (+ a b)) ((lambda () (values 1 2))))
+3
+> (+ (call/cc (lambda (ret) (ret 1 2 3))) 4) ; call/cc has an implicit "values"
+10
+> ((lambda* ((a 1) (b 2)) (list a b)) (values :a 3))
+(3 2)
+
+(define-macro (call-with-values producer consumer) 
+  `(,consumer (,producer)))
+
+(define-macro (multiple-value-bind vars expr . body)
+  `((lambda ,vars ,@body) ,expr))
+
+(define-macro (define-values vars expression)
+  `(if (not (null? ',vars))
+       (varlet (curlet) ((lambda ,vars (curlet)) ,expression))))
+
+(define (curry function . args)
+  (if (null? args)
+      function
+      (lambda more-args
+        (if (null? more-args)
+            (apply function args)
+            (function (apply values args) (apply values more-args))))))
+
+ + + +
+ +
+ +

multiple-values are useful in a several situations. For example, +(if test (+ a b c) (+ a b d e)) can be written +(+ a b (if test c (values d e))). +There are a few special uses of multiple-values. +First, you can use the values function to return any number of values, including 0, +from map's function application: +

+ +
> (map (lambda (x) (if (odd? x) (values x (* x 20)) (values))) (list 1 2 3))
+(1 20 3 60)
+> (map values (list 1 2 3) (list 4 5 6))
+(1 4 2 5 3 6)
+
+(define (remove-if func lst) 
+  (map (lambda (x) (if (func x) (values) x)) lst))
+
+(define (pick-mappings func lst)          
+  (map (lambda (x) (or (func x) (values))) lst))
+
+(define (shuffle . args) 
+  (apply map values args))
+
+> (shuffle '(1 2 3) #(4 5 6) '(7 8 9))
+(1 4 7 2 5 8 3 6 9)
+
+(define (concatenate . args)
+  (apply append (map (lambda (arg) (map values arg)) args)))
+
+ +

Second, a macro can return multiple values; these are evaluated and spliced, +exactly like a normal macro, +so you can use (values '(define a 1) '(define b 2)) to +splice multiple definitions at the macro invocation point. +If an expansion returns (values), nothing is spliced in. This is +mostly useful in reader-cond and the #; reader. +

+ +
> (define-expansion (comment str) (values))
+comment
+> (+ 1 (comment "one") 2 (comment "two"))
+3
+
+ +

At the top-level (in the REPL), since there's nothing to splice into, you simply get your values back: +

+ +
> (values 1 (list 1 2) (+ 3 4 5))
+(values 1 (1 2) 12)
+
+ +

But this printout is just trying to be informative. There is no multiple-values object +in s7. You can't (set! x (values 1 2)), for example. The values function +tells s7 that its arguments should be handled in a special way, and the multiple-value indication goes away +as soon as the arguments are spliced into some caller's arguments. +

+ +

There are two helper functions for multiple values, apply-values and list-values, +both intended primarily for quasiquote where (apply-values ...) implements what other schemes call unquote-splicing (",@..."). +(apply-values lst) is like (apply values lst), +and (list-values ...) is like (list ...) except in one special case. It is common in writing macros +to create some piece of code to be spliced into the output, but if that code is nil, the resulting +macro code should contain nothing (not nil). apply-values and list-values cooperate with quasiquote to implement +this. As an example: +

+
> (list-values 1 2 (apply-values) 3)
+(1 2 3)
+> (define (supply . args) (apply-values args))
+supply
+> (define (consume f . args) (apply f (apply list-values args)))
+consume
+> (consume + (supply 1 2) (supply 3 4 5) (supply))
+15
+> (consume + (supply))
+0
+
+ +

It might seem simpler to return "nothing" from (values), rather than #<unspecified>, +but that has drawbacks. First, (abs -1 (values)), or worse (abs (f x) (f y)) +is no longer an error at the level of the program text; you lose the ability to see at a glance that +a normal function has the right number of arguments. Second, a lot of code currently assumes that +(values) returns #<unspecified>, and that implies that (apply values ()) does as well. +But it would be nice if ((lambda* ((x 1)) x) (values)) returned 1! + +

+
+ + +
+ +

Since set! does not evaluate its first argument, and +there is no setter for "values", (set! (values x) ...) is not +the same as (set! x ...). (string-set! (values string) ...) +works because string-set! does evaluate its first argument. ((values + 1 2) (values 3 4) 5) +is 15, as anyone would expect. +

+
+ +

One problem with this way of handling multiple values involves cases where you can't +tell whether an expression will return multiple values. Then you have, for example, (let ((val (expr)))...) +and need to accept either a normal single value from expr, or one member of the +possible set of multiple values. In lint.scm, I'm currently handling this with lambda: +(let ((val ((lambda args (car args)) (expr))))...), but this feels kludgey. +CL has nth-value which appears to do "the right thing" in this context; perhaps s7 needs +it too. +

+

A similar difficulty arises in (if (expr) ...) where (expr) might +return multiple values. CL (or sbcl anyway) treats this as if it were wrapped in (nth-value 0 (expr)). +Splicing the values in, on the other hand, could lead to disaster: there would be no way to tell from the code +that the if statement +was valid, or which branch would be taken! So, in those cases where a syntactic form evaluates +an argument, s7 follows CL, and uses only the first of the values (this affects if, when, unless, cond, and case). +

+ +
+ + + + +

call-with-exit, with-baffle and continuation?

+ + +

call-with-exit is call/cc without the ability to jump back into the original context, +similar to "return" in C. This +is cleaner than call/cc, and much faster. +

+ +
(define-macro (block . body) 
+  ;; borrowed loosely from CL — predefine "return" as an escape
+  `(call-with-exit (lambda (return) ,@body)))
+
+(define-macro (while test . body)      ; while loop with predefined break and continue
+  `(call-with-exit
+    (lambda (break) 
+      (let continue ()
+	(if (let () ,test)
+	    (begin 
+	      (let () ,@body)
+	      (continue))
+	    (break))))))
+
+(define-macro (switch selector . clauses) ; C-style case (branches fall through unless break called)
+  `(call-with-exit
+    (lambda (break)
+      (case ,selector
+	,@(do ((clause clauses (cdr clause))
+	       (new-clauses ()))
+	      ((null? clause) (reverse new-clauses))
+	    (set! new-clauses (cons `(,(caar clause) 
+				      ,@(cdar clause)
+				      ,@(map (lambda (nc)
+					       (apply values (cdr nc))) ; doubly spliced!
+					     (if (pair? clause) (cdr clause) ())))
+				    new-clauses)))))))
+
+(define (and-for-each func . args)
+  ;; apply func to the first member of each arg, stopping if it returns #f
+  (call-with-exit
+   (lambda (quit)
+     (apply for-each (lambda arglist
+		       (if (not (apply func arglist))
+			   (quit #<unspecified>))) 
+	    args))))
+
+(define (find-if f . args)  ; generic position-if is very similar
+  (call-with-exit
+   (lambda (return) 
+     (apply for-each (lambda main-args 
+		       (if (apply f main-args) 
+			   (apply return main-args)))
+	    args))))
+
+> (find-if even? #(1 3 5 2))
+2
+> (* (find-if > #(1 3 5 2) '(2 2 2 3)))
+6
+
+ +

+The call-with-exit function's argument (the "continuation") is only valid +within the call-with-exit function. In call/cc, you can save it, then call it later +to jump back, but if you try that with call-with-exit (from outside the call-with-exit function's body), you'll get an error. +This is similar to trying to read from a closed input port. +

+ + +

The other side, so to speak, of call-with-exit, is with-baffle. +Sometimes we need a normal call/cc, but want to make sure it is active +only within a given block of code. +Normally, if a continuation gets away, there's no telling when it might wreak havoc on us. +with-baffle blocks that — no continuation can jump into its body: +

+ +
(let ((what's-for-breakfast ())
+      (bad-dog 'fido))        ; bad-dog wonders what's for breakfast?
+  (with-baffle                ; the syntax is (with-baffle . body)         
+   (set! what's-for-breakfast
+	 (call/cc
+	  (lambda (biscuit?)
+	    (set! bad-dog biscuit?) ; bad-dog smells a biscuit!
+	    'biscuit!))))
+  (if (eq? what's-for-breakfast 'biscuit!) 
+      (bad-dog 'biscuit!))     ; now, outside the baffled block, bad-dog wants that biscuit!
+  what's-for-breakfast)        ;   but s7 says "No!": baffled! ("continuation can't jump into with-baffle")
+
+ +
+

continuation? returns #t if its argument is a continuation, +as opposed to a normal procedure. I don't know why Scheme hasn't had this function from +the very beginning, but it's needed if you want to write a continuable error +handler. Here is a sketch of the situation: +

+ +
(catch #t
+       (lambda ()
+         (let ((res (call/cc 
+                      (lambda (ok) 
+                        (error 'cerror "an error" ok)))))
+           (display res) (newline)))
+       (lambda args
+         (when (and (eq? (car args) 'cerror)
+                    (continuation? (cadadr args)))
+           (display "continuing...")
+           ((cadadr args) 2))
+         (display "oops")))
+
+ +

In a more general case, the error handler is separate from the +catch body, and needs a way to distinguish a real continuation +from a simple procedure. +

+ +
(define (continuable-error . args)
+  (call/cc 
+   (lambda (continue)
+     (apply error args))))
+
+(define (continue-from-error)
+  (if (continuation? ((owlet) 'continue)) ; might be #<undefined> or a function as in the while macro
+      (((owlet) 'continue))
+      'bummer))
+
+ + + + + + +

format, object->string

+ +

object->string returns the string representation of its argument. Its optional second argument +can be #f or :display (use display), #t or :write (the default, use write), or :readable. In the latter case, object->string +tries to produce a string that can be evaluated via eval-string to return an object equal to the +original. The optional third argument sets the maximum desired string length; if object->string +notices it has exceeded this limit, it returns the partial string. +

+ +
> (object->string "hiho")
+"\"hiho\""
+> (format #f "~S" "hiho")
+"\"hiho\""
+
+ +
+

s7's format function is very close to that in srfi-48. +

+ +
> (format #f "~A ~D ~F" 'hi 123 3.14)
+"hi 123 3.140000"
+
+ + +

The format directives (tilde chars) are:

+
~%        insert newline
+~&        insert newline if preceding char was not newline
+~~        insert tilde
+~\n       (tilde followed by newline): trim white space
+~{        begin iteration (take arguments from a list, string, vector, or any other applicable object)
+~}        end iteration
+~^ ~|     jump out of iteration
+~*        ignore the current argument
+~C        print character (numeric argument = how many times to print it)
+~P        insert 's' if current argument is not 1 or 1.0 (use ~@P for "ies" or "y")
+~A        object->string as in display
+~S        object->string as in write
+~B        number->string in base 2
+~O        number->string in base 8
+~D        number->string in base 10 (~:D for ordinal)
+~X        number->string in base 16
+~E        float to string, (format #f "~E" 100.1) -> "1.001000e+02", (%e in C)
+~F        float to string, (format #f "~F" 100.1) -> "100.100000",   (%f in C)
+~G        float to string, (format #f "~G" 100.1) -> "100.1",        (%g in C)
+~T        insert spaces (padding)
+~N        get numeric argument from argument list (similar to ~V in CL)
+~W        object->string with :readable (write readably: "serialization"; s7 is the intended reader)
+
+ +

The eight directives before ~W take the usual numeric arguments to specify field width and precision. +These can also be ~N or ~n in which case the numeric argument is read from the list of arguments: +

+
(format #f "~ND" 20 1234) ; => (format "~20D" 1234)
+"                1234"
+
+ +

+(format #f ...) simply returns the formatted string; (format #t ...) +also sends the string to the current-output-port. (format () ...) sends the output to +the current-output-port without returning the string (this mimics the other IO routines +such as display and newline). Other built-in port choices are *stdout* and *stderr*. +

+ +
+ +
+ +

Floats can occur in any base, so: +

+ +
> #xf.c
+15.75
+
+ +

This also affects format. In most Schemes, (format #f "~X" 1.25) is +an error. In CL, it is equivalent to using ~A which is perverse. But +

+ +
> (number->string 1.25 16)
+"1.4"
+
+ +

and there's no obvious way to get the same effect from format unless we accept +floats in the "~X" case. So in s7, +

+ +
> (format #f "~X" 21)
+"15"
+> (format #f "~X" 1.25)
+"1.4"
+> (format #f "~X" 1.25+i)
+"1.4+1.0i"
+> (format #f "~X" 21/4)
+"15/4"
+
+ +

That is, the output choice matches the argument. A case that came up in the Guile mailing lists is: +(format #f "~F" 1/3). s7 currently returns "1/3", but Clisp returns "0.33333334". +

+
+

The curly bracket directive applies to anything you can map over, not just lists: +

+ +
> (format #f "~{~C~^ ~}" "hiho")
+"h i h o"
+> (format #f "~{~{~C~^ ~}~^...~}" (list "hiho" "test"))
+"h i h o...t e s t"
+> (with-input-from-string (format #f "(~{~C~^ ~})" (format #f "~B" 1367)) read) ; integer->list
+(1 0 1 0 1 0 1 0 1 1 1)
+
+
+ +

Since any sequence can be passed to ~{~}, we need a way to truncate output and represent +the rest of the sequence with "...", but ~^ only stops at the end of the sequence. ~| +is like ~^ but it also stops after it handles (*s7* 'print-length) elements and prints +"...". So, (format #f "~{~A~| ~}" #(0 1 2 3 4)) returns "0 1 2 ..." +if (*s7* 'print-length) is 3. +

+ +
+
+ + +
+ +
+ +

I added object->string to s7 before deciding to include format. format excites a +vague disquiet — why do we need this ancient unlispy thing? +We can almost replace it with: +

+ +
(define (objects->string . objects)
+  (apply string-append (map (lambda (obj) (object->string obj #f)) objects)))
+
+ +

But how to handle lists (~{...~} in format), or columnized output (~T)? +I wonder whether formatted string output still matters outside a REPL. Even in that context, +a modern GUI leaves formatting decisions to a text or table widget. +

+ +
(define-macro (string->objects str . objs)
+  `(with-input-from-string ,str
+     (lambda ()
+       ,@(map (lambda (obj)
+		`(set! ,obj (eval (read))))
+	      objs))))
+
+
+ +
+

format is a mess. It is trying to cram two different choices into its first ("port") argument. +Perhaps it should be split into format->string and format->port. format->string has no +port argument and returns a string. format->port writes to its port argument (which must be an output +port, not a boolean), and returns #f or maybe <unspecified>. Then: +

+
(format #f ...) -> (format->string ...)
+(format () ...) -> (format->port (current-output-port) ...)
+(format #t ...) -> (display (format->string ...))
+(format port ...) -> (display (format->string ...) port)
+
+

and the currently unavailable choice, format to port without creating a string: +(format->port port ...). +

+
+ + +
+ + + +

hooks

+ +
(make-hook . fields)           ; make a new hook
+(hook-functions hook)          ; the hook's list of 'body' functions
+
+ +

A hook is a function created by make-hook, and called (normally from C) when something interesting happens. +In GUI toolkits hooks are called callback-lists, in CL conditions, +in other contexts watchpoints or signals. s7 itself has several +hooks: *error-hook*, *read-error-hook*, +*unbound-variable-hook*, *missing-close-paren-hook*, *rootlet-redefinition-hook*, +*load-hook*, and *autoload-hook*. +make-hook is: +

+ +
(define (make-hook . args)
+  (let ((body ()))
+    (apply lambda* args
+      '(let ((result #<unspecified>))
+         (let ((e (curlet)))
+	   (for-each (lambda (f) (f e)) body) 
+           result))
+       ())))
+
+ +

So the result of calling make-hook is a function (the lambda* that is applied to args above) that +contains a list of functions, 'body. +Each function in that list takes one argument, the hook. +Each time the hook itself is called, each of the body functions is called, and the value of 'result is returned. +That variable, and each of the hook's arguments are accessible to the hook's internal +functions by going through the environment passed to the internal functions. This is a bit circuitous; +here's a sketch: +

+ +
> (define h (make-hook '(a 32) 'b))     ; h is a function: (lambda* ((a 32) b) ...)
+h
+> (set! (hook-functions h)              ; this sets ((funclet h) 'body)
+           (list (lambda (hook) 	; each hook internal function takes one argument, the environment
+                   (set! (hook 'result) ; this is the "result" variable above 
+                         (format #f "a: ~S, b: ~S" (hook 'a) (hook 'b))))))
+(#<lambda (hook)>)
+> (h 1 2)                               ; this calls the hook's internal functions (just one in this case)
+"a: 1, b: 2"                            ; we set "result" to this string, so it is returned as the hook application result
+> (h)
+"a: 32, b: #f"
+
+ +

In C, to make a hook: +

+ +
hook = s7_eval_c_string("(make-hook '(a 32) 'b)");
+s7_gc_protect(s7, hook);
+
+ +

And call it: +

+ +
result = s7_call(s7, hook, s7_list(s7, 2, s7_make_integer(s7, 1), s7_make_integer(s7, 2)));
+
+ +
+
(define-macro (hook . body)  ; return a new hook with "body" as its body, setting "result"
+  `(let ((h (make-hook)))
+     (set! (hook-functions h) (list (lambda (h) (set! (h 'result) (begin ,@body)))))
+     h))
+
+
+ + + + + +

variable info

+ + +
(documentation obj)          ; old name: (procedure-documentation obj)
+(signature obj)              ; old:      (procedure-signature obj)
+(setter obj)                 ; old:      (procedure-setter obj)
+(arity obj)                  ; very old: (procedure-arity obj)
+(aritable? obj num-args)
+(funclet proc)
+(procedure-source proc)
+
+ +

+funclet returns +a procedure's environment. +

+
> (funclet (let ((b 32)) (lambda (a) (+ a b))))
+(inlet 'b 32)
+> (funclet abs)
+(rootlet)
+
+ +

+setter returns or sets the set function associated with a procedure (set-car! with car, for example). +

+ +

+procedure-source returns the procedure source (a list): +

+
(define (procedure-arglist f) (cadr (procedure-source f)))
+
+ +

+documentation returns the documentation string associated with a procedure. This used to be +the initial string in the function's body (as in CL), but now it is the value of the '+documentation+ variable, if any, +in the procedure's local environment: +

+
(define func 
+  (let ((+documentation+ "helpful info"))
+     (lambda (a) a)))
+
+> (documentation func)
+"helpful info"
+
+

Since documentation is a method, a function's documentation can be computed at run-time: +

+
(define func
+  (let ((documentation (lambda (f) (format #f "this is func's funclet: ~S" (funclet f)))))
+    (lambda (x)
+      (+ x 1))))
+
+> (documentation func)
+"this is func's funclet: (inlet 'x ())"
+
+ +

+arity takes any object and returns either #f if it is not applicable, +or a cons containing the minimum and maximum number of arguments acceptable. If the maximum reported +is a really big number, that means any number of arguments is ok. +aritable? takes two arguments, an object and an integer, and returns #t if the object can be +applied to that many arguments. +

+ +
> (define* (add-2 a (b 32)) (+ a b))
+add-2
+> (procedure-source add-2)
+(lambda* (a (b 32)) (+ a b))
+> (arity add-2)
+(0 . 2)
+> (aritable? add-2 1)
+#t
+
+ +

+signature is a list describing the argument types and returned value type +of the function. The first entry in the list is the return type, and the rest are +argument types. #t means any type is possible, and 'values means the function returns multiple values. +

+ +
> (signature round)
+(integer? real?)                   ; round takes a real argument, returns an integer
+> (signature vector-ref)
+(#t vector? . #1=(integer? . #1#)) ; trailing args are all integers (indices)
+
+ +

If an entry is a list, any of the listed types can occur: +

+ +
> (signature char-position)
+((boolean? integer?) (char? string?) string? integer?)
+
+ +

which says that the first argument to char-position can be a string or a character, +and the return type can be either boolean or an integer. If we know a function returns +multiple values, the return type (first element of the signature) can contain a list +describing each such value: (define (f x) (values (floor x) (ceiling x))) +could be (((integer?) (integer?)) real?). +

+

+If the function is defined in scheme, its signature is the value of the '+signature+ variable +in its closure: +

+ +
> (define f1 (let ((+documentation+ "helpful info") 
+                   (+signature+ '(boolean? real?)))
+                (lambda (x) 
+                  (positive? x))))
+f1
+> (documentation f1)
+"helpful info"
+> (signature f1)
+(boolean? real?)
+
+ +

We could do the same thing using methods: +

+ +
> (define f1 (let ((documentation (lambda (f) "helpful info"))
+                   (signature (lambda (f) '(boolean? real?))))
+                (openlet  ; openlet alerts s7 that f1 has methods
+                  (lambda (x) 
+                    (positive? x)))))
+> (documentation f1)
+"helpful info"
+> (signature f1)
+(boolean? real?)
+
+ +

signature could also be used to implement CL's 'the: +

+
(define-macro (the value-type form)
+  `((let ((+signature+ (list ,value-type)))
+      (lambda ()
+	,form))))
+
+(display (+ 1 (the integer? (+ 2 3))))
+
+ +

but the optimizer currently doesn't know how to take advantage of this pattern. +

+ +

You can obviously add your own methods: +

+ +
(define my-add
+  (let ((tester (lambda ()
+		  (if (not (= (my-add 2 3) 5))
+		      (format #t "oops: (myadd 2 3) -> ~A~%" 
+			      (my-add 2 3))))))
+    (lambda (x y)
+      (- x y))))
+
+(define (auto-test) ; scan the symbol table for procedures with testers
+  (let ((st (symbol-table)))
+    (for-each (lambda (f)
+		(let* ((fv (and (defined? f)
+			       (symbol->value f)))
+		       (testf (and (procedure? fv)
+				   ((funclet fv) 'tester))))
+		  (when (procedure? testf)  ; found one!
+		    (testf)))) 
+	      st)))
+
+> (auto-test)
+oops: (myadd 2 3) -> -1
+
+ +

Even the setter can be set this way: +

+
(define flocals
+  (let ((x 1))
+    (let ((+setter+ (lambda (val) (set! x val))))
+      (lambda ()
+	x))))
+
+> (flocals)
+1
+> (setter flocals)
+#<lambda (val)>
+> (set! (flocals) 32)
+32
+> (flocals)
+32
+
+ +
+
+ +
+ +
(define (for-each-subset func args)
+  ;; form each subset of args, apply func to the subsets that fit its arity
+  (let subset ((source args)
+               (dest ())
+               (len 0))
+    (if (null? source)
+        (if (aritable? func len)   ; does this subset fit?
+            (apply func dest))
+        (begin
+          (subset (cdr source) (cons (car source) dest) (+ len 1))
+          (subset (cdr source) dest len)))))
+
+
+
+ + +

eval

+ +

+eval evaluates its argument, a list representing a piece of code. It takes an optional +second argument, the environment in which the evaluation should take place. eval-string +is similar, but its argument is a string. +

+ +
> (eval '(+ 1 2))
+3
+> (eval-string "(+ 1 2)")
+3
+
+ +

Leaving aside a few special cases, eval-string could be defined: +

+
(define-macro* (eval-string x e)
+  `(eval (with-input-from-string ,x read) (or ,e (curlet))))
+
+ + + +

IO and other OS functions

+ +

Besides files, ports can also represent strings and functions. The string port functions +are: +

+ +
(with-output-to-string thunk)         ; open a string port as current-output-port, call thunk, return string
+(with-input-from-string string thunk) ; open string as current-input-port, call thunk
+(call-with-output-string proc)        ; open a string port, apply proc to it, return string
+(call-with-input-string string proc)  ; open string as current-input-port, apply proc to it
+(open-output-string)                  ; open a string output port
+(get-output-string port clear)        ; return output accumulated in the string output port
+(open-input-string string)            ; open a string input port reading string
+(open-input-function function)        ; open a function input port
+(open-output-function function)       ; open a function output port
+
+ +
> (let ((result #f) 
+        (p (open-output-string)))
+    (format p "this ~A ~C test ~D" "is" #\a 3)
+    (set! result (get-output-string p))
+    (close-output-port p)
+    result)
+"this is a test 3"
+
+ +

In get-output-string, if the optional 'clear' argument is #t, the port is cleared (the default in r7rs I think). +Other functions: +

+ +
    +
  • read-byte and write-byte: binary IO +
  • read-line: line-at-a-time reads, optional second argument #t to include the newline +
  • read-string (r7rs) +
  • current-error-port, set-current-error-port +
  • port-filename and + port-line-number (input ports) +
  • port-position (input port, settable) +
  • port-file +
+ +

Use length to get the length in bytes of an input port's file or string. +port-line-number is settable (for fancy *#readers*). +port-position is the position in bytes of the reader in the port. It is settable. +port-file is intended for use with the *libc* library. It returns a c-pointer +containing the FILE* pointer associated with the file port (except in Windows): +

+
(call-with-input-file "s7test.scm"
+  (lambda (p)
+    (with-let (sublet *libc* :file (port-file p))
+      (fseek file 1000 SEEK_SET))))
+
+ +

The variable (*s7* 'print-length) sets +the upper limit on how many elements of a sequence are printed by object->string and format. +When running s7 behind a GUI, you often want input to come from and output to go to +arbitrary widgets. The function ports provide a way to redirect IO in C. See below +for an example. +

+ +

The function ports call a function rather than reading or writing the data to a string or file. +See nrepl.scm and s7test.scm for examples. The function-port function is accessible as +((object->let function-port) 'function). These ports are even more esoteric than +their C-side cousins. An example that traps current-ouput-port output: +

+
(let* ((str ())
+       (stdout-wrapper (open-output-function
+			 (lambda (c)
+			   (set! str (cons c str))))))
+  (let-temporarily (((current-output-port) stdout-wrapper))
+    (write-char #\a)
+    ...))
+
+
+ +
+

+The end-of-file object is #<eof>. +When the read function encounters the constant #<eof> it returns #<eof>. +This is neither inconsistent nor unusual: read returns either a form or +#<eof>. If read encounters a form that contains #<eof>, it returns a +form containing #<eof>, just as with any other constant. +

+ +
> (with-input-from-string "(or x #<eof>)" read)
+(or x #<eof>)
+> (eof-object? (with-input-from-string "'#<eof>" read))
+#f
+
+ +

If read hits the end of +the input while reading a form, it raises an error (e.g. "missing close paren"). +If it encounters +#<eof> all by itself at the top level (this never happens), +it returns that #<eof>. But this is specific to read, not (for example) load: +

+
;; say we have "t234.scm" with:
+(display "line 1") (newline)
+#<eof>
+(display "line 2") (newline)
+;; end of t234.scm
+
+> (load "t234.scm")
+line 1
+line 2
+
+(with-input-from-file "t234.scm" 
+  (lambda () 
+    (do ((c (read) (read))) 
+	((eof-object? c)) 
+      (eval c))))
+line 1
+
+ +

+Built-in #<eof> has lots of +uses, and as far as I can see, no drawbacks. For example, +it is common to call +read (or one of its friends) in a loop which first checks for #<eof>, then falls into +a case statement. In s7, we can dispense with the extra if (and let), and include +the #<eof> in the case statement: (case (read-char) ((#<eof>) (quit-reading)) ((#\a)...)). +Another example: (or (eof-object? x) (eqv x 24)...) can be instead: (memv x '(#<eof> 24 ...). +

+
+ + +
+ +

+The default IO ports are *stdin*, *stdout*, and *stderr*. +*stderr* is useful if you want to make sure output is flushed out immediately. +The default output port is *stdout* which buffers output until a newline is seen. +

+ +
+ + +
+

An environment can be treated as an IO port, providing what Guile calls a "soft port": +

+ +
(define (call-with-input-vector v proc)
+  (let ((i -1))
+    (proc (openlet (inlet 'read (lambda (p) (v (set! i (+ i 1)))))))))
+
+ +

Here the IO port is an open environment that redefines the "read" function so that it +returns the next element of a vector. See stuff.scm for call-with-output-vector. +The "proc" argument above can also be a macro, giving you a kludgey way to get around +the dumb "lambda". Here are more useful examples: +

+
(openlet          ; a soft port for format that sends its output to *stderr* and returns the string
+  (inlet 'format (lambda (port str . args)
+ 	           (apply format *stderr* str args))))
+
+(define (open-output-log name)
+  ;; return a soft output port that does not hold its output file open
+  (define (logit name str)
+    (let ((p (open-output-file name "a")))
+      (display str p)
+      (close-output-port p)))
+  (openlet 
+   (inlet :name name
+	  :format (lambda (p str . args) (logit (p 'name) (apply format #f str args)))))))
+	  :write (lambda (obj p)         (logit (p 'name) (object->string obj #t)))
+	  :display (lambda (obj p)       (logit (p 'name) (object->string obj #f)))
+	  :write-string (lambda (str p)  (logit (p 'name) str))
+	  :write-char (lambda (ch p)     (logit (p 'name) (string ch)))
+	  :newline (lambda (p)           (logit (p 'name) (string #\newline)))
+	  :output-port? (lambda (p) #t)
+	  :close-output-port (lambda (p) #f)
+	  :flush-output-port (lambda (p) #f)
+
+(let ((p (open-output-log "logit.data")))
+  (format p "this is a test~%")
+  (format p "line: ~A~%" 2))
+
+
+ + +
+ +

binary-io.scm in the Snd package has functions that read and write integers and floats in +both endian choices in a variety of sizes. +

+ +
+
+ +

If the compile time switch WITH_SYSTEM_EXTRAS is 1, several additional OS-related and +file-related functions are built-in. This is work in progress; currently this switch +adds: +

+ +
(directory? str)         ; return #t if str is the name of a directory
+(file-exists? str)       ; return #t if str names an existing file
+(delete-file str)        ; try to delete the file, return 0 is successful, else -1
+(getenv var)             ; return the value of an environment variable: (getenv "HOME")
+(directory->list dir)    ; return contents of directory as a list of strings (if HAVE_DIRENT_H)
+(system command)         ; execute command
+
+ +

But maybe this is not needed; see cload.scm below for +a more direct approach. +

+ + + + + +

error handling

+ +
(error tag . info)           ; signal an error of type tag with addition information
+(catch tag body err)         ; if error of type tag signalled in body (a thunk), call err with tag and info
+(throw tag . info)           ; jump to corresponding catch
+
+ +

s7's error handling mimics that of Guile. An error is signalled +via the error function, and can be trapped and dealt with via catch. +

+ +
> (catch 'wrong-number-of-args
+    (lambda ()     ; code protected by the catch
+      (abs 1 2))
+    (lambda args   ; the error handler
+      (apply format #t (cadr args))))
+"abs: too many arguments: (1 2)"
+> (catch 'division-by-zero
+    (lambda () (/ 1.0 0.0))
+    (lambda args (string->number "+inf.0")))
++inf.0
+
+(define-macro (catch-all . body)
+  `(catch #t (lambda () ,@body) (lambda args args)))
+
+ +

+catch has 3 arguments: a tag indicating what error to catch (#t = anything), +the code, a thunk, that the catch is protecting, and the function to call +if a matching error occurs during the evaluation of the thunk. The error handler +takes a rest argument which will hold whatever the error function chooses to pass it. +The error function itself takes at least 2 arguments, the error type, a symbol, +and the error message. There may also be other arguments describing the error. +The default action, in the absence of any catch, is to treat the message as +a format control string, apply format to it and the other arguments, and +send that info to the current-error-port: +

+ +
(catch #t
+  (lambda ()
+    (error 'oops))
+  (lambda args
+    (format (current-error-port) "~A: ~A~%~A[~A]:~%~A~%" 
+      (car args)                        ; the error type
+      (apply format #f (cadr args))     ; the error info
+      (port-filename) (port-line-number); error file location
+      (stacktrace))))                   ; and a stacktrace
+
+ +
+
+

Normally when reading a file, we have to check for #<eof>, but we can let s7 +do that: +

+ +
(define (copy-file infile outfile)
+  (call-with-input-file infile
+    (lambda (in)
+      (call-with-output-file outfile
+	(lambda (out)
+	  (catch 'wrong-type-arg   ; s7 raises this error if write-char gets #<eof>
+	    (lambda () 
+	      (do () ()            ; read/write until #<eof>
+		(write-char (read-char in) out)))
+	    (lambda err 
+	      outfile)))))))
+
+ +

catch is not limited to error handling: +

+ +
(define (map-with-exit func . args)
+  ;; map, but if early exit taken, return the accumulated partial result
+  ;;   func takes escape thunk, then args
+  (let* ((result ())
+	 (escape-tag (gensym))
+	 (escape (lambda () (throw escape-tag))))
+    (catch escape-tag
+      (lambda ()
+	(let ((len (apply max (map length args))))
+	  (do ((ctr 0 (+ ctr 1)))
+	      ((= ctr len) (reverse result))      ; return the full result if no throw
+	    (let ((val (apply func escape (map (lambda (x) (x ctr)) args))))
+	      (set! result (cons val result))))))
+      (lambda args
+	(reverse result))))) ; if we catch escape-tag, return the partial result
+
+(define (truncate-if func lst)
+  (map-with-exit (lambda (escape x) (if (func x) (escape) x)) lst))
+
+> (truncate-if even? #(1 3 5 -1 4 6 7 8))
+(1 3 5 -1)
+
+ +

But this is less useful than map (it can't map over a hash-table for example), +and is mostly reimplementing built-in code. Perhaps s7 should have an extension +of map (and more usefully, for-each) that is patterned after dynamic-wind: +(dynamic-for-each init-func main-func end-func . args) where init-func +is called with one argument, the length of the shortest sequence argument (for-each +and map know this in advance); main-func takes n arguments where n matches +the number of sequences passed; and end-func is called even if a jump out of main-func +occurs (like dynamic-wind in this regard). In the dynamic-map case, the end-func +takes one argument, the current, possibly partial, result list. dynamic-for-each +then could easily (but maybe not efficiently) implement generic functions such as ->list, ->vector, and +->string (converting any sequence into a sequence of some other type). +map-with-exit would be +

+
(define (map-with-exit func . args) 
+  (let ((result ()))
+    (call-with-exit
+      (lambda (quit)
+        (apply dynamic-map #f ; no init-func in this case
+               (lambda main-args 
+                 (apply func quit main-args)) 
+               (lambda (res) 
+                 (set! result res))
+               args)))
+    result))
+
+
+ +
+

With all the lambda boilerplate, nested catches are hard to read: +

+
(catch #t
+  (lambda ()
+    (catch 'division-by-zero
+      (lambda ()
+	(catch 'wrong-type-arg
+	  (lambda () 
+	    (abs -1))
+	  (lambda args (format () "got a bad arg~%") -1)))
+      (lambda args 0)))
+  (lambda args 123))
+
+ +

Perhaps we need a macro: +

+ +
(define-macro (catch-case clauses . body)
+  (let ((base (cons 'lambda (cons () body))))
+    (for-each (lambda (clause)
+	        (let ((tag (car clause)))
+	          (set! base `(lambda () 
+			        (catch ',(or (eq? tag 'else) tag)
+			          ,base 
+			          ,@(cdr clause))))))
+	      clauses)
+    (caddr base)))
+
+;;; the code above becomes:
+(catch-case ((wrong-type-arg   (lambda args (format () "got a bad arg~%") -1))
+	     (division-by-zero (lambda args 0))
+	     (else             (lambda args 123)))
+  (abs -1))
+
+ +

This is similar to r7rs scheme's "guard", but I don't want a pointless thunk for the body of the catch. +Along the same lines: +

+
(define (catch-if test func err)
+  (catch #t
+    func
+    (lambda args
+      (apply (if (test (car args)) err throw) args)))) ; if not caught, re-raise the error via throw
+
+(define (catch-member lst func err)
+  (catch-if (lambda (tag) (member tag lst)) func err))
+
+(define-macro (catch* clauses . error) 
+  ;; try each clause until one evaluates without error, else error:
+  ;;    (macroexpand (catch* ((+ 1 2) (- 3 4)) 'error))
+  ;;    (catch #t (lambda () (+ 1 2)) (lambda args (catch #t (lambda () (- 3 4)) (lambda args 'error))))
+  (define (builder lst)
+    (if (null? lst)
+	(apply values error)
+	`(catch #t (lambda () ,(car lst)) (lambda args ,(builder (cdr lst))))))
+  (builder clauses))
+
+
+ + + +
+ +

When an error is encountered, and when s7 is interrupted via begin_hook, +(owlet) returns an environment that contains +additional info about that error: +

+ +
    +
  • error-type: the error type or tag, e.g. 'division-by-zero +
  • error-data: the message or information passed by the error function +
  • error-code: the code that s7 thinks triggered the error +
  • error-line: the line number of that code +
  • error-file: the file name of that code +
  • error-history: previous evaluations leading to the error (a circular list) +
+ +

The error-history field depends on the compiler flag WITH_HISTORY. See ow! in +stuff.scm for one way to display this data. The *s7* field 'history-size sets the size of the buffer. +

+ +
+ + +
+ +

To find a variable's value at the point of the error: ((owlet) var). +To list all the local bindings from the error outward: +

+ +
(do ((e (outlet (owlet)) (outlet e))) 
+    ((eq? e (rootlet))) 
+  (format () "~{~A ~}~%" e))
+
+ +

To see the current s7 stack, (stacktrace). You'll probably +want to use this in conjunction with *error-hook*. +To evaluate the error handler in the environment of the error: +

+ +
(let ((x 1))
+  (catch #t
+    (lambda ()
+      (let ((y 2))
+        (error 'oops)))
+    (lambda args
+      (with-let (sublet (owlet) :args args)    ; add the error handler args
+        (list args x y)))))    ; we have access to 'y'
+
+ +

To limit the maximum size of the stack, set (*s7* 'max-stack-size). +

+
+ + +
+ + +

The hook *error-hook* provides a way to specialize error reporting. +Its arguments are named 'type and 'data. +

+ +
(set! (hook-functions *error-hook*) 
+      (list (lambda (hook) 
+              (apply format *stderr* (hook 'data)) 
+              (newline *stderr*))))
+
+ +

*read-error-hook* provides two hooks into the reader. +A major problem when reading code written for other Schemes is that each Scheme provides +a plethora of idiosyncratic #-names (even special character names), and \ escapes in string +constants. *read-error-hook* provides a way to handle these weird cases. If a #-name +is encountered that s7 can't deal with, *read-error-hook* is called with two arguments, + #t and the string representing the constant. If you set (hook 'result), that result is +returned to the reader. Otherwise a 'read-error is raised and you drop into the error handler. +Similarly, if some bizaare \ use occurs, *read-error-hook* is called with two arguments, +#f and the offending character. If you return a character, it is passed to the reader; +otherwise you get an error. lint.scm has an example. +

+ +

*rootlet-redefinition-hook* is called when +a top-level variable is redefined (via define and friends, not set!). +

+
(set! (hook-functions *rootlet-redefinition-hook*) 
+      (list (lambda (hook) 
+              (format *stderr* "~A ~A~%" (hook 'name) (hook 'value)))))
+
+

will print out the variable's name and the new value. +

+ + +
+

The s7-built-in catch tags are 'wrong-type-arg, 'syntax-error, 'read-error, 'unbound-variable, +'out-of-memory, 'wrong-number-of-args, 'format-error, 'out-of-range, 'division-by-zero, 'io-error, and 'bignum-error. +

+
+ + + +

autoload

+ + +

+If s7 encounters an unbound variable, it first looks to see if it has any autoload information about it. +This info can be declared via autoload, a function of two arguments, the +symbol that triggers the autoload, and either a filename or a function. If a filename, s7 +loads that file; if a function, it is called with one argument, the current (calling) environment. +

+ +
(autoload 'channel-distance "dsp.scm") 
+;; now if we subsequently call channel-distance but forget to load "dsp.scm" first,
+;;   s7 loads "dsp.scm" itself, and uses its definition of channel-distance.
+;;   The C-side equivalent is s7_autoload.
+
+;; here is the cload.scm case, loading j0 from the math library if it is called:
+(autoload 'j0
+	  (lambda (e)
+	    (unless (provided? 'cload.scm)
+	      (load "cload.scm"))
+	    (c-define '(double j0 (double)) "" "math.h")
+	    (varlet e 'j0 j0)))
+
+ +

The entity (hash-table or environment probably) that holds the autoload info is named *autoload*. +If after checking autoload, the symbol is still unbound, s7 calls +*unbound-variable-hook*. +The offending symbol is named 'variable in the hook environment. +If after running *unbound-variable-hook*, the symbol is still unbound, +s7 calls the error handler. +

+ +

The autoloader knows about s7 environments used as libraries, so, for example, +you can (autoload 'j0 "libm.scm"), then use j0 in scheme code. The first +time s7 encounters j0, j0 is undefined, so +s7 loads libm.scm. That load returns the C math library as the environment *libm*. +s7 then automatically looks for j0 in *libm*, and defines it for you. +So the result is the same as if you had defined j0 yourself in C code. +You can use the r7rs library mechanism here, or with-let, or +whatever you want! (In Snd, libc, libm, libdl, and libgdbm are automatically +tied into s7 via autoload, so if you call, for example, frexp, libm.scm +is loaded, and frexp is exported from the *libm* environment, then the +evaluator soldiers on, as if frexp had always been defined in s7). +You can also import all of (say) gsl into the current environment +via (varlet (curlet) *libgsl*). +

+ + +

define-constant

+ +

+define-constant defines a symbol whose value is always the same (within the current lexical scope), +constant? returns #t if its argument is a constant, +immutable! declares a sequence to be immutable (its elements can't be changed), and +immutable? returns #t if its argument is immutable. +

+ +
> (define v (immutable! (vector 1 2 3)))
+#(1 2 3)
+> (vector-set! v 0 23)
+error: can't vector-set! #(1 2 3) (it is immutable)
+> (immutable? v)
+#t
+
+> (define-constant var 32)
+var
+> (set! var 1)
+;set!: can't alter immutable object: var
+> (let ((var 1)) var)
+;can't bind or set an immutable object: var, line 1
+
+ +

There is one complication here. (immutable! let) closes the let in the sense +that you can't add locals to or delete locals from the let. You can still set! the locals. To make +the locals themselves immutable: +

+
(define (vars-immutable! L)
+  (with-let L 
+    (for-each (lambda (f)
+                (immutable! (car f)))
+              (curlet)))
+  L)
+
+

Now (vars-immutable! let) makes it an error to set! any of the locals, but you +can add locals to the let. +You can speed up evaluation by doing this because it tells the optimizer that the current entries in the let will not change. +To completely petrify the let, (immutable! (vars-immutable! let)). +To make a function's documentation immutable: (with-let (funclet 'f2) (immutable! '+documentation+)), +and similarly for other function closure entries. +

+ + +

define-constant blocks any attempt to set! or shadow the constant (lexically speaking of course), +so local constants behave as you'd expect: +

+ +
> (let () (define-constant x 3) (let ((x 32)) x))
+error: can't bind an immutable object: ((x 32))
+> (let ((x 3)) (set! x (let () (define-constant x 32) x))) ; outer x is not a constant
+32
+
+

But watch out for deferred bindings: +

+ +
> (define (func a) (let ((cvar (+ a 1))) cvar))
+func
+> (define-constant cvar 23) ; cvar is now globally constant so it can't be shadowed
+23
+> (func 1)                  ; here we're trying to shadow cvar
+error: can't bind an immutable object: ((cvar (+ a 1)))
+> (let ((x 1)) 
+     (define z (let ()
+                 (define-constant x 3) 
+                 (lambda (y) 
+                   (let ((x y))  ; this x is the inner constant x
+                     x)))) 
+     (z 1))  ; so this is an error even though the outer x is not a constant
+error: can't bind an immutable object: ((x y))
+
+ +

+A function can also be a constant. In some cases, the optimizer can take advantage +of this information to speed up function calls. +

+ +

Constants are very similar to things such as keywords (no set, always return itself as its value), +variable trace (informative function upon set or keeping a history of past values), typed variables (restricting a +variable's values or doing automatic conversions upon set), and notification upon set (either in Scheme +or in C; I wanted this many years ago in Snd). The notification function is especially useful if +you have a Scheme variable and want to reflect any change in its value immediately in C (see below). +In s7, setter sets this function. +

+ +

Each environment is a set of symbols and their associated values. +setter places a function (or macro) between a symbol +and its value in a given environment. The setter function takes two +arguments, the symbol and the new value, and +returns the value that is actually set. If the setter function accepts a + third argument, the current (symbol-relative) environment +is also passed (the weird argument order is an historical artifact). +

+ +
(define e      ; save environment for use below
+  (let ((x 3)  ; will always be an integer
+	(y 3)  ; will always keep its initial value
+	(z 3)) ; will report set!
+
+    (set! (setter 'x) (lambda (s v) (if (integer? v) v x)))
+    (set! (setter 'y) (lambda (s v) y))
+    (set! (setter 'z) (lambda (s v) (format *stderr* "z ~A -> ~A~%" z v) v))
+  
+    (set! x 3.3) ; x does not change because 3.3 is not an integer
+    (set! y 3.3) ; y does not change
+    (set! z 3.3) ; prints "z 3 -> 3.3" 
+    (curlet)))
+
+> e
+(inlet 'x 3 'y 3 'z 3.3)
+>(begin (set! (e 'x) 123) (set! (e 'y) #()) (set! (e 'z) #f))
+;; prints "z 3.3 -> #f"
+> e
+(inlet 'x 123 'y 3 'z #f)
+> (define-macro (reflective-let vars . body)
+    `(let ,vars
+       ,@(map (lambda (vr)
+	        `(set! (setter ',(car vr))
+		       (lambda (s v)
+		         (format *stderr* "~S -> ~S~%" s v)
+		         v)))
+	      vars)
+       ,@body))
+reflective-let
+> (reflective-let ((a 1)) (set! a 2))
+2     ; prints "a -> 2"
+>(let ((a 0))
+     (set! (setter 'a)
+      (let ((history (make-vector 3 0))
+	    (position 0))
+	(lambda (s v)
+	  (set! (history position) v)
+	  (set! position (+ position 1))
+	  (if (= position 3) (set! position 0))
+	  v)))
+     (set! a 1)
+     (set! a 2)
+     ((funclet (setter 'a)) 'history))
+#(1 2 0)
+
+ +

See also typed-let in stuff.scm. +define-constant is more restrictive than a setter that raises an error: the latter +does not block nested (possibly non-constant) bindings of the symbol. The setters +are kind of ugly. Here's a macro that lets you put the let variable's setter after +the initial value: +

+ +
(define-macro (let/setter vars . body)
+  ;; (let/setter ((name value [setter])...) ...)
+  (let ((setters (map (lambda (binding)
+			 (and (pair? (cddr binding))
+			      (caddr binding)))
+		       vars))
+	(gsetters (gensym)))
+    `(let ((,gsetters (list ,@setters))
+	   ,@(map (lambda (binding)
+		    (list (car binding) (cadr binding)))
+		  vars))
+       ,@(do ((s setters (cdr s))
+	      (var vars (cdr var))
+	      (i 0 (+ i 1))
+	      (result ()))
+	     ((null? s)
+	      (reverse result))
+	   (if (car s)
+	       (set! result (cons `(set! (setter (quote ,(caar var))) (list-ref ,gsetters ,i)) result))))
+       ,@body)))
+
+(let ((a 3))
+  (let/setter ((a 1)
+	       (b 2 (lambda (s v)
+		      (+ v a)))) ; this is the outer "a"
+   (set! a (+ a 1))
+   (set! b (+ a b))
+   (display (list a b)) (newline)))
+
+ + + +

marvels and curiousities

+ +

+*load-path* is a list of directories to search when loading a file. +*load-hook* is a hook whose functions are called just before a file is loaded. +The hook function argument, named 'name, is the filename. +While loading, port-filename and +port-line-number of the current-input-port can tell you +where you are in the file. This data is also available after loading via pair-line-number +and pair-filename. +

+ +
(set! (hook-functions *load-hook*)
+       (list (lambda (hook) 
+               (format () "loading ~S...~%" (hook 'name)))))
+
+(set! (hook-functions *load-hook*) 
+      (cons (lambda (hook) 
+              (format *stderr* "~A~%" 
+                (system (string-append "./snd lint.scm -e '(begin (lint \"" (hook 'name) "\") (exit))'") #t)))
+            (hook-functions *load-hook*)))
+
+ +

Here's a *load-hook* function that adds the loaded file's directory +to the *load-path* variable so that subsequent loads don't need to specify +the directory: +

+ +
(set! (hook-functions *load-hook*)
+  (list (lambda (hook)
+          (let ((pos -1)
+                (filename (hook 'name)))
+            (do ((len (length filename))
+                 (i 0 (+ i 1)))
+	        ((= i len))
+	      (if (char=? (filename i) #\/)
+	          (set! pos i)))
+            (if (positive? pos)
+	        (let ((directory-name (substring filename 0 pos)))
+	          (if (not (member directory-name *load-path*))
+		      (set! *load-path* (cons directory-name *load-path*)))))))))
+
+ + +
+ +

As in Common Lisp, *features* is a list describing what is currently loaded into s7. You can +check it with the provided? function, or add something to it with provide. In my version of Snd, +at startup *features* is: +

+ +
> *features*
+(snd-20.0 snd20 snd audio snd-s7 snd-motif gsl alsa xm clm6 clm sndlib linux 
+autoload dlopen history complex-numbers system-extras overflow-checks ratio s7-8.11 s7)
+> (provided? 'gsl)
+#t
+
+ +

The other side of provide is require. +(require . things) finds each thing +(via autoload), and if that thing has not already been loaded, +loads the associated file. (require integrate-envelope) +loads "env.scm", for example; in this case it is equivalent to +simply using integrate-envelope, but if placed at the start of +a file, it documents that you're using that function. +In the more normal use, (require snd-ws.scm) +looks for the file that has (provide 'snd-ws.scm) +and if it hasn't already been loaded, loads it ("ws.scm" in this case). +To add your own files to this mechanism, add the provided symbol via autoload. +Since load can take an environment argument, *features* and its friends follow block structure. +So, for example, (let () (require stuff.scm) ...) loads "stuff.scm" into the local environment, +not globally. +

+ +
+

*features* is an odd variable: it is spread out across the chain of environments, and +can hold features in an intermediate environment that aren't in subsequent (nested) values. +One simple way this can happen is to load a file in a let, but cause the load to happen +at the top level. The provided entities get added to the top-level *features* value, +not the current let's value, but they are actually accessible locally. So *features* +is a merge of all its currently accessible values, vaguely like call-next-method in +CLOS. We can mimic this behavior: +

+
(let ((x '(a)))
+  (let ((x '(b)))
+    (define (transparent-memq sym var e)
+      (let ((val (symbol->value var e)))
+	(or (and (pair? val)
+		 (memq sym val))
+	    (and (not (eq? e (rootlet)))
+		 (transparent-memq sym var (outlet e))))))
+    (let ((ce (curlet)))
+      (list (transparent-memq 'a 'x ce)
+	    (transparent-memq 'b 'x ce)
+	    (transparent-memq 'c 'x ce)))))
+
+'((a) (b) #f)
+
+
+ + + + +
+ +

Multi-line and in-line comments can be enclosed in #| and |#. +(+ #| add |# 1 2). +

+ +
+

Leaving aside this case and the booleans, #f and #t, you can specify your own handlers for +tokens that start with "#". *#readers* is a list of pairs: (char . func). +"char" refers to the first character after the sharp sign (#). "func" is a function of +one argument, the string that follows the #-sign up to the next delimiter. "func" is called +when #<char> is encountered. If it returns something other than #f, the #-expression +is replaced with that value. Scheme has several predefined #-readers for cases such +as #b1, #\a, and so on, but you can override these if you like. If the string +passed in is not the complete #-expression, the function can use read-char or read to get the +rest. Say we'd like #t<number> to interpret the number in base 12: +

+ +
(set! *#readers* (cons (cons #\t (lambda (str) (string->number (substring str 1) 12))) *#readers*))
+
+> #tb
+11
+> #t11.3
+13.25
+
+ +

Or have #c(real imag) be read as a complex number: +

+ +
(set! *#readers* (cons (cons #\c (lambda (str) (apply complex (read)))) *#readers*))
+
+> #c(1 2)
+1+2i
+
+ +

Here's a reader macro for read-time evaluation: +

+ +
(set! *#readers*
+  (cons (cons #\. (lambda (str)
+		    (and (string=? str ".") (eval (read)))))
+	*#readers*))
+
+> '(1 2 #.(* 3 4) 5)
+(1 2 12 5)
+
+ + +

And a reader that implements #[...]# for literal hash-tables: +

+ +
> (set! *#readers* 
+    (list (cons #\[ (lambda (str)
+		      (let ((h (make-hash-table)))
+		        (do ((c (read) (read)))
+		            ((eq? c ']#) h) ; ]# is a symbol from the reader's point of view
+		          (set! (h (car c)) (cdr c))))))))
+((#\[ . #<lambda (str)>))
+> #[(a . 1) (b . #[(c . 3)]#)]#
+(hash-table '(b . (hash-table '(c . 3))) '(a . 1))
+
+ + +

To return no value from a reader, use (values). +

+
> (set! *#readers* (cons (cons #\; (lambda (str) (if (string=? str ";") (read)) (values))) *#readers*))
+((#\; . #<lambda (str)>))
+> (+ 1 #;(* 2 3) 4)
+5
+
+

Here is CL's #+ reader: +

+
(define (sharp-plus str)
+  ;; str here is "+", we assume either a symbol or an expression involving symbols follows
+  (let ((e (if (string=? str "+")
+		(read)                                ; must be #+(...)
+		(string->symbol (substring str 1))))  ; #+feature
+	(expr (read)))  ; this is the expression following #+
+    (if (symbol? e)
+        (if (provided? e)
+	    expr
+	    (values))
+	(if (not (pair? e))
+	    (error 'wrong-type-arg "strange #+ chooser: ~S~%" e)
+	    (begin      ; evaluate the #+(...) expression as in cond-expand
+	      (define (traverse tree)
+		(if (pair? tree)                                             
+		    (cons (traverse (car tree))                             
+			  (case (cdr tree) ((())) (else => traverse)))
+		    (if (memq tree '(and or not)) tree                 
+			(and (symbol? tree) (provided? tree)))))
+	      (if (eval (traverse e))
+		  expr
+		  (values)))))))
+
+

See also the #n= reader below.

+
+ +
+ +

(make-list length (initial-element #f)) returns a list of 'length' elements defaulting to 'initial-element'. +

+ +
+ +
(char-position char-or-string searched-string (start 0))
+(string-position substring searched-string (start 0))
+
+ +

+char-position and string-position search a string for the occurrence of a character, +any of a set of characters, or a string. They return either #f if none is found, or the position +within the searched string of the first occurrence. The optional third argument sets where the +search starts in the second argument. +

+ +

If char-position's first argument is a string, it is treated as a set of characters, and +char-position looks for the first occurrence of any member of that set. +Currently, the strings involved are assumed to be C strings (don't expect embedded nulls +to work right in this context). +

+ +
(call-with-input-file "s7.c" ; report any lines with "static " but no following open paren
+  (lambda (file)
+    (let loop ((line (read-line file #t)))
+      (or (eof-object? line)
+	  (let ((pos (string-position "static " line)))
+	    (if (and pos
+		     (not (char-position #\( (substring line pos))))
+ 	        (if (> (length line) 80)
+		    (begin (display (substring line 0 80)) (newline))
+		    (display line))))
+	    (loop (read-line file #t)))))))
+
+ + +
+ +

+Keywords exist mainly for define*'s benefit. The keyword functions are: +keyword?, string->keyword, symbol->keyword, and keyword->symbol. +A keyword is a symbol that starts or ends with a colon. The colon +is considered to be a part of the symbol name. A keyword is a constant that evaluates to itself. +

+ + + +
+ +
(symbol-table)
+(symbol->value sym (env (curlet)))
+(symbol->dynamic-value sym)
+(defined? sym (env (curlet)) ignore-rootlet)
+
+ +

+defined? returns #t if the symbol is defined in the environment: +

+ +
(define-macro (defvar name value) 
+  `(unless (defined? ',name)
+     (define ,name ,value)))
+
+ +

If ignore-rootlet is #t, the search is confined to the given environment. +

+

+symbol->value returns the value (lexically) bound to the symbol, whereas symbol->dynamic-value +returns the value dynamically bound to it. +

+

+symbol-table returns a vector containing the symbols currently in the symbol-table. +Here we scan the symbol table looking for any function that doesn't have documentation: +

+ +
(for-each 
+   (lambda (sym)
+     (if (defined? sym)
+         (let ((val (symbol->value sym)))
+           (if (and (procedure? val)
+                    (string=? "" (documentation val)))
+               (format *stderr* "~S " sym)))))
+  (symbol-table))
+
+ +

Or get a list of gensyms:

+
(map (lambda (sym) (if (gensym? sym) sym (values))) (symbol-table))
+
+ +
+ +

An automatic software tester (see also tauto.scm and auto-tester.scm in the tools directory): +

+ +
(for-each 
+  (lambda (sym)
+    (if (defined? sym)
+	(let ((val (symbol->value sym)))
+          (if (procedure? val)
+	      (let ((max-args (cdr (arity val))))
+	        (if (or (> max-args 4)
+	   	        (memq sym '(exit abort)))
+		    (format () ";skip ~S for now~%" sym)
+		    (begin
+		      (format () ";whack on ~S...~%" sym)
+                      (let ((constants (list #f #t pi () 1 1.5 3/2 1.5+i)))
+                        (let autotest ((args ()) (args-left max-args))
+                          (catch #t (lambda () (apply func args)) (lambda any #f))
+                          (if (> args-left 0)
+ 	                      (for-each
+	                        (lambda (c)
+	                          (autotest (cons c args) (- args-left 1)))
+	                        constants)))))))))))
+  (symbol-table))
+
+
+ + +
+ +

help tries to find information about its argument. +

+ +
> (help 'caadar)
+"(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2"
+
+ + + +
+ +

gc calls the garbage collector. (gc #f) turns off the GC, and (gc #t) turns it on. +

+ +

If you get an error complaining about a "free cell", this is usually a sign that the GC freed some object +that it should have left alone. In straight scheme code, it's an s7 bug; please send me mail about it! +In foreign code, it probably indicates that you need to protect some s7_pointer with s7_gc_protect. +

+ + +
+ +
(equivalent? x y)
+
+ +

+Say we want to check that two different computations came to the same result, and that result might +involve circular structures. Will equal? be our friend? +

+ +
> (equal? 2 2.0)
+#f
+> (let ((x +nan.0)) (equal? x x))
+#f
+> (equal? .1 1/10)
+#f    
+> (= .1 1/10)
+#f
+> (= 0.0 0+1e-300i)
+#f
+
+ +

No! We need an equality check that ignores epsilonic differences in real and +complex numbers, and knows that NaNs are equal for all practical purposes. +Leaving aside numbers, +closed ports are not equal, yet nothing can be done with them. +#() is not equal to #2d(). And two closures are never equal, even if their +arguments, environments, and bodies are equal. +Since there might be circles, it is not easy to write +a replacement for equal? in Scheme. +So, in s7, if one thing is basically the same as +some other thing, they satisfy the function equivalent?. +

+ +
> (equivalent? 2 2.0)
+#t
+> (equivalent? 1/0 1/0)         ; NaN
+#t
+> (equivalent? .1 1/10)
+#t                              ; floating-point epsilon here is 1.0e-15 or thereabouts
+> (equivalent? 0.0 1e-300)
+#t
+> (equivalent? 0.0 1e-14)
+#f                              ; its not always #t!
+> (equivalent? (lambda () #f) (lambda () #f))
+#t
+
+ +

The *s7* field equivalent-float-epsilon sets the floating-point fudge factor. +I can't decide how bignums should interact with equivalent?. Currently, +if a bignum is involved, either here or in a hash-table, s7 uses equal?. +Finally, if either argument is an environment with an 'equivalent? method, +that method is invoked. +

+ + +
+ +

+define-expansion defines a macro that expands at read-time. +It has the same syntax as +define-macro, and (in normal use) the same result, but it is much faster because it expands only once. +Similarly, define-expansion* defines a read-time macro*. +(See also define-with-macros in s7test.scm for a way to expand macros in a function body at definition time). +Since the reader knows almost nothing +about the code it is reading, +you need to make sure the expansion is defined at the top level and that its name is unique. +The reader does know about global variables, so: +

+ +
(define *debugging* #t)
+
+(define-expansion (assert assertion)
+  (if *debugging*          ; or maybe better, (eq? (symbol->value '*debugging*) #t)
+      `(unless ,assertion
+	 (format *stderr* "~A: ~A failed~%" (*function*) ',assertion))
+      (values)))
+
+ +

Now the assertion code is only present in the function body (or wherever) +if *debugging* is #t; otherwise assert expands into nothing. Another very handy +use is to embed a source file line number into a message; see for example lint-format +in lint.scm. +Leaving aside +read-time expansion and splicing, the real difference between define-macro and define-expansion +is that the expansion's result is not evaluated. +I'm no historian, but I believe that means that define-expansion creates +a (gasp!) f*xpr. In fact: +

+ +
(define-macro (define-f*xpr name-and-args . body)
+  `(define ,(car name-and-args)
+     (apply define-expansion 
+       (append (list (append (list (gensym)) ',(cdr name-and-args))) ',body))))
+
+> (define-f*xpr (mac a) `(+ ,a 1))
+mac
+> (mac (* 2 3))
+(+ (* 2 3) 1)
+
+ +

+You can do something similar with a normal macro, or make the indirection explicit: +

+ +
> (define-macro (fx x) `'(+ 1 ,x)) ; quote result to avoid evaluation
+fx
+> (let ((a 3)) (fx a))
+(+ 1 a)
+> (define-expansion (ex x) `(+ 1 ,x))
+ex
+> (let ((x ex) (a 3)) (x a))       ; avoid read-time splicing
+(+ 1 a)
+> (let ((a 3)) (ex a))             ; spliced in at read-time
+4
+
+ +

As this example shows, the reader knows nothing about the program context, +so if it does not see a list whose first element is a expansion name, it does +not do anything special. In the (x a) case above, the +expansion happens when the code is evaluated, and the expansion result +is simply returned, unevaluated. +

+ +

You can also use macroexpand to cancel the evaluation of a macro's expansion: +

+
(define-macro (rmac . args)
+  (if (null? args)
+      ()
+      (if (null? (cdr args))
+	  `(display ',(car args))
+	  (list 'begin
+                `(display ',(car args))
+		(apply macroexpand (list (cons 'rmac (cdr args))))))))
+
+> (macroexpand (rmac a b c))
+(begin (display 'a) (begin (display 'b) (display 'c)))
+> (begin (rmac a b c d) (newline))
+abcd
+
+ +

The main built-in expansion is reader-cond. The syntax is based on cond: +the car of each clause is evaluated (in the read-time context), and if it is not false, +the remainder of that clause is spliced into the code as if you had typed it from the start. +

+ +
> '(1 2 (reader-cond ((> 1 0) 3) (else 4)) 5 6)
+(1 2 3 5 6)
+> ((reader-cond ((> 1 0) list 1 2) (else cons)) 5 6)
+(1 2 5 6)
+
+ + + + + +
+

+Whenever (*s7* 'profile) is positive, profiling is turned on. +As the program runs, the profiler collects data about each function it can identify. +At any time, you can call show-profile to see that data. The first timing is inclusive +(it includes the time spent in any nested calls), the second is exclusive (it is the time +spent just in the current function). In Linux and *BSD, we use clock_gettime() which is reasonably +fast, but there is some profiler overhead. In other systems, we use clock() which is +amazingly slow. The optimizer sometimes recasts tail recursion and similar cases as while loops, +so the number of calls listed may be less than you'd expect, but the overall time should be +correct. To clear out the current data, call clear-profile. +

+ + +
+

*s7* is a let that gives access to some of s7's internal +state: +

+
print-length                  number of elements to print of a non-string sequence
+max-string-length             maximum size arg to make-string and read-string
+max-format-length             maximum size arg to ~N or the width and precision fields for floats in format
+max-list-length               maximum size arg to make-list
+max-port-data-size            maximum size of a port data buffer
+max-vector-length             maximum size arg to make-vector and make-hash-table
+max-vector-dimensions         make-vector dimensions limit
+default-hash-table-length     default size for make-hash-table (8, tables resize as needed)
+initial-string-port-length    128, initial size of a input string port's buffer
+output-port-data-size         2048, size of an output port's buffer
+
+history			      a circular buffer of recent eval entries stored backwards (use set! to add an entry)
+history-size                  eval history buffer size if s7 built WITH_HISTORY=1
+history-enabled               is history buffer receiving additions (if WITH_HISTORY=1 as above)
+debug                         determines debugging level (see debug.scm), default=0
+profile                       profile switch (0=default, 1=gather profiling info)
+profile-info                  the current profiling data; see profile.scm
+profile-prefix                name (a symbol) used to identify the current environment in profile data
+
+default-rationalize-error     1e-12
+equivalent-float-epsilon      1e-15
+hash-table-float-epsilon      1e-12 (currently limited to less than 1e-3).
+bignum-precision              bits for bignum floats (128)
+float-format-precision        digits to print for floats (16)
+default-random-state          the default arg for random
+most-positive-fixnum          if not using gmp, the most positive integer ("fixnum" comes from CL)
+most-negative-fixnum          as above, but negative
+
+safety                        0 (see below)
+undefined-identifier-warnings #f 
+undefined-constant-warnings   #f 
+accept-all-keyword-arguments  #f 
+autoloading?                  #t
+openlets                      #t, whether any let can be open globally (this overrides all openlets)
+expansions?                   #t, whether expansions are handled at read-time
+muffle-warnings?              #f, if #t s7_warn does not output anything
+
+cpu-time                      run time so far
+file-names                    currently loaded files (a list)
+catches                       a list of the currently active catch tags
+c-types                       a list of c-object type names (from s7_make_c_type, etc)
+
+stack			      the current stack entries
+stack-top                     current stack location
+stack-size                    current stack size
+max-stack-size                maximum stack size
+stacktrace-defaults           stacktrace formatting info for error handler
+
+rootlet-size                  the number of globals
+heap-size                     total cells currently available
+max-heap-size                 maximum heap size
+free-heap-size                the number of currently unused cells
+gc-stats                      0 (or #f), 1: show GC activity, 2: heap, 4: stack, 8: protected_objects, #t = 1
+gc-freed                      number of cells freed by the last GC pass
+gc-total-freed                number of cells freed so far by the GC; the total allocated is probably close to
+                                (with-let *s7* (+ (- heap-size free-heap-size) gc-total-freed))
+gc-info                       a list: calls total-time ticks-per-second (see profile.scm)
+gc-temps-size                 number of cells just allocated that are protected from the GC (256)
+gc-resize-heap-fraction       when to resize the heap (0.8); these two are aimed at GC experiments
+gc-resize-heap-by-4-fraction  when to get panicky about resizing the heap
+gc-protected-objects          vector of the objects permanently protected from the GC
+memory-usage                  a description of current memory allocations (sent to current-output-port)
+
+ +

+Use the standard environment syntax to access these fields: +(*s7* 'stack-top). stuff.scm has the function +*s7*->list that returns most of these fields in a list. +

+

The compile-time defaults for some of these fields can be set: +

+
heap-size:               INITIAL_HEAP_SIZE        (64000)
+stack-size:              INITIAL_STACK_SIZE       (4096)
+gc-temps-size:           GC_TEMPS_SIZE            (256)
+bignum-precision:        DEFAULT_BIGNUM_PRECISION (128)
+history-size:            DEFAULT_HISTORY_SIZE     (8)
+print-length:            DEFAULT_PRINT_LENGTH     (12)
+gc-resize-heap-fraction: GC_RESIZE_HEAP_FRACTION  (0.8)
+output-port-data-size:   OUTPUT_PORT_DATA_SIZE    (2048)
+
+See also WITH_WARNINGS, S7_ALIGNED, and GC_TRIGGER_SIZE.
+
+ +

(set! (*s7* 'autoloading) #f) turns off the autoloader. +

+ +

The 'safety variable is an integer. Currently: +

+
0: default.
+1: no remove_from_heap (a GC optimization)
+   infinite loop check in eval, sort! and some iterators
+   immutable object check in reverse!, sort!, and fill!
+   more info in (*s7* 'history) for s7_apply_function, s7_call and s7_eval
+   less aggressive optimization in with-let and lambda
+   warnings about syntax redefinition
+   incoming s7_pointer checks in some FFI functions
+   bignum int to s7_int conversion checks
+2: vector, string, and pair constants are immutable (but checks for this are currently sparse)
+
+ +

The debug variable controls where debug.scm is active. If it is (if debug > 0), it inserts +trace calls in functions and so on. It uses dynamic-unwind +to establish a catcher for the return value. (dynamic-unwind function arg) causes +function to be called after the traced function has returned, passing it arg +and the returned value. +

+ + +

(*s7* 'stacktrace-defaults) is a list of four integers and a boolean that tell the error +handler how to format stacktrace information. The four integers are: +how many frames to display, +how many columns are devoted to code display, +how many columns are available for a line of data, +and where to place comments. +The boolean sets whether the entire output should be displayed as a comment. +The defaults are '(3 45 80 45 #t). +

+ +

This will display s7 memory usage sort of like the top program: +

+
(format *stderr* "~C[~D;~DH" #\escape 0 0)
+(format *stderr* "~C[J" #\escape)
+(display (with-output-to-string (lambda() (*s7* 'memory-usage))))
+
+

(Ideally we'd only redisplay the changed fields). +

+ +

The standard time macro:

+ +
(define-macro (time expr) 
+  `(let ((start (*s7* 'cpu-time)))
+     (let ((res (list ,expr))) ; expr might return multiple values
+       (list (car res)
+	     (- (*s7* 'cpu-time) start)))))
+
+ +

Add automatic log10 recalculation to (*s7* 'bignum-precision):

+ +
(define log10 (log (bignum 10)))
+(define bignum-precision (dilambda (lambda () 
+				     (*s7* 'bignum-precision)) 
+				   (lambda (val)
+				     (set! (*s7* 'bignum-precision) val)
+				     (set! log10 (log (bignum 10)))
+				     val)))
+
+ +

The stack, history and gc-protected-objects fields are intended for debugging. Don't keep +these hanging around and expect good things to happen! +

+ + +
+
(c-object? obj)
+(c-object-type obj)
+
+(c-pointer? obj)
+(c-pointer int type info weak1 weak2)
+(c-pointer-type obj)
+(c-pointer-info obj)
+(c-pointer-weak1 obj) ; also weak2
+(c-pointer->list obj)
+
+ +

+c-object? returns #t is its argument is a c-object. +c-object-type returns the object's type tag (otherwise #f of course). This tag is also the position +of the object's type in the (*s7* 'c-types) list. +(*s7* 'c-types) returns a list of the types created by s7_make_c_type. +

+

+You can wrap up raw C pointers and +pass them around in s7 code. The function c-pointer returns a wrapped pointer, +and c-pointer? returns #t if passed one. (define NULL (c-pointer 0)). +If the type field is a symbol, it is used to check types in s7_c_pointer with_type. +If the 'info field of a c-pointer is a let, that pointer can participate in +the generic functions mechanism, much like a c-object: +

+
> (let ((ptr (c-pointer 1 'abc 
+                (inlet 'object->string 
+		  (lambda (obj . args)
+		    (let ((lt (object->let obj)))
+		      (format #f "I am pointer ~A of type '~A!" 
+			      (lt 'c-pointer)        ; we need c-pointer-type etc
+			      (lt 'c-type))))))))
+    (openlet ptr)
+    (object->string ptr))
+"I am pointer 1 of type 'abc!"
+
+

c-pointer->list returns (list pointer-as-int type info). +The "weak1" and "weak2" fields are intended for custom "weak" references. The weak +fields values are not marked during the GC sweep, much like a key in a weak-hash-table. +If either value is GC'd, that field is set to #f by the GC. The weak fields are +ignored by equal? and equivalent? when comparing c-pointers, and by object->string +of a c-pointer even if :readable is specified. +

+ + +
+ +

There are several tree-oriented functions currently built into s7: +

+
(tree-cyclic? tree) returns #t if tree contains a cycle.
+(tree-leaves tree) returns the number of leaves in tree.
+(tree-memq obj tree) returns #t if obj is in tree (using eq?).
+(tree-set-memq set tree) returns #t if any member of the set (a list of symbols) is in tree.
+(tree-count obj tree) returns how many times obj is in tree.
+
+ + +
+ +

s7 originally had Scheme-level multithreading support, but I removed it in August, 2011. +It turned out to be less useful than I hoped, +mainly because s7 threads shared the heap and therefore had to coordinate +all cell allocations. It was faster and simpler to use multiple +processes each running a separate s7 interpreter, rather than one s7 +running multiple s7 threads. In CLM, there was also contention for access +to the output stream. In GUI-related situations, +threads were not useful mainly because the GUI toolkits are not thread safe. +Last but not least, the effort to make the non-threaded +s7 faster messed up parts of the threaded version. Rather than +waste a lot of time fixing this, I chose to flush multithreading. +s7 is thread-safe: +

+ +
+
+
#include <stdio.h>
+#include <stdlib.h>
+#include <pthread.h>
+#include "s7.h"
+
+#define NUM_THREADS 16
+static pthread_t threads[NUM_THREADS];
+static pthread_mutex_t lock = PTHREAD_MUTEX_INITIALIZER;
+
+static void *run_thread(void *obj)
+{
+  s7_scheme *sc = (s7_scheme *)obj;
+  const char *str;
+  str = s7_object_to_c_string(sc, s7_make_integer(sc, 123));
+  s7_eval_c_string(sc, "(let () \
+                          (define (f) \
+                            (do ((i 0 (+ i 1))) ((= i 10)) \
+                              (do ((k 0 (+ k 1))) ((= k 1000000))) \
+                              (format *stderr* \"~D \" i))) \
+                          (f))");
+  pthread_mutex_lock(&lock);
+  fprintf(stderr, "%s\n", str);
+  pthread_mutex_unlock(&lock);
+}
+
+int main(int argc, char **argv)
+{
+  int32_t i;
+  for (i = 0; i < NUM_THREADS; i++)
+    pthread_create(&threads[i], NULL, run_thread, (void *)s7_init());
+  for (i = 0; i < NUM_THREADS; i++)
+    pthread_join(threads[i], NULL);
+  exit(0);
+}
+
+/* linux: gcc -o threads threads.c s7.o -Wl,-export-dynamic -pthread -lm -I. -ldl
+ * mac: clang -o threads threads.c s7.o -pthread -lm -I. -ldl
+ */
+
+
+
+ + + +
+ +
+ +
+

Some other differences from r5rs: +

+ +
    +
  • no force or delay (see below). +
  • no syntax-rules or any of its friends. +
  • no scheme-report-environment, null-environment, or interaction-environment (use curlet). +
  • no transcript-on or transcript-off. +
  • begin returns the value of the last form; it can contain both definitions and other statements. +
  • #<unspecified>, #<eof>, and #<undefined> are first-class objects. +
  • for-each and map accept different length arguments; the operation stops when any argument reaches its end. +
  • for-each and map accept any applicable object as the first argument, and any sequence or iterator as a trailing argument. +
  • letrec*, but without conviction. +
  • set! and *-set! return the new value (modulo setter), not #<unspecified>. +
  • define and its friends return the new value. +
  • port-closed? +
  • list? means "pair or null", proper-list? is r5rs list?, float? = + real and not rational, sequence? = length, byte? = unsigned byte. + +
  • the default IO ports are named *stdin*, *stdout*, and *stderr*. +
  • #f as an output port means nothing is output (#f is /dev/null, I guess). +
  • member and assoc accept an optional third argument, the comparison function (equal? is the default). +
  • case accepts => much like cond (the function argument is the selector). +
  • if WITH_SYSTEM_EXTRAS is 1, the following are built-in: +directory?, file-exists?, delete-file, system, directory->list, +getenv. +
  • s7 is case sensitive. +
  • when and unless (for r7rs), returning the value of the last form. +
  • the "d", "f", "s", and "l" exponent markers are not supported by default (use "e", "E", or "@"). +
  • quasiquoted vector constants are not supported (use the normal list expansions wrapped in list->vector). +
  • type-of returns a type indicator for its argument. +
+ +

In s7 if a built-in function like gcd is referred to in a function +body, the optimizer is free to replace it with #_function. That is, (gcd ...) can be changed +to (#_gcd ...) at s7's whim, if gcd has its original value at the time the optimizer +sees the expression using it. A subsequent (set! gcd +) does not affect this optimized call. +I think I could wave my hands and mumble about "aggressive lexical scope" or something, but actually the +choice here is that speed trumps that ol' hobgoblin consistency. If you want to change gcd to +, do it before +loading code that calls gcd. +I think most Schemes handle macros this way: the macro call is replaced by its expansion using its current +definition, and a later redefinition does not affect earlier uses. +Guile behaves like s7: +

+
(define (add1 x) (+ x 1))
+(set! + -)
+(display (add1 3))) ; 4 in both s7 and Guile 3.0.4
+
+

But if a Scheme function is involved, things get messy: +

+
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+(define oldfib fib)
+(set! fib 32)
+(display (oldfib 10))) ; s7 says 55, Guile says "wrong type to apply: 32"
+
+

I can't decide which way is correct: s7 looks more consistent, +but: +

+
(define (fib n) 32)
+(set! fib (lambda (n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))
+(define oldfib fib)
+(set! fib 32)
+(display (oldfib 10)) ; "attempt to apply an integer 32 to..."
+
+

So s7 is inconsistent too! (Actually this was consistent until Jan 2021 when I suddenly thought it was +a mistake and "fixed" it; now I'm having second thoughts. +

+ + + + + +
+ + +
+ +

Here are some changes I'd make to s7 if I didn't care about compatibility with other Schemes: +

+ +
    +
  • remove the exact/inexact distinction including #i and #e (done! #i means int-vector constant). +
  • remove call-with-values and its friends +
  • remove char-ready? +
  • change eof-object? to eof? or just omit it (you can use eq? #<eof>) +
  • change make-rectangular to complex (done!), and remove make-polar. +
  • remove unquote (the name, not the functionality). +
  • remove cond-expand. +
  • remove *-ci functions +
  • remove #d (done!) +
+ +

(most of these are removed if you set the compiler flag WITH_PURE_S7), and perhaps: +

+ +
    +
  • remove even? and odd?, gcd and lcm. +
  • remove string-length and vector-length. +
  • remove list-ref|set!, string-ref|set!, vector-ref|set!, +hash-table-ref|set!, set-car!|cdr!, and +set-current-output|input|error-port. +
  • change file-exists? to file? (or omit it and assume the use of libc.scm — why reinvent the wheel?). +
  • remove all the conversion and copy functions like vector->list and vector-copy (use copy or map). +
  • change string->symbol to symbol (what to do with symbol->string in that case?) +
  • change with-output-to-* and with-input-from-* to omit the pointless lambda. +
  • remove the with-* IO functions (e.g. with-input-from-string), keeping the call-with-* versions (call-with-input-string). +
  • remove assq, assv, memq, and memv (these are pointless now that assoc and member can be passed eq? and eqv?). +
  • move all the "*var*" names to *s7*: *load-hook* becomes (*s7* 'load-hook) for example. +
+ +

With the move to s7_setter and s7_set_setter (setter in Scheme), +dilambda and dilambda? have been reduced to trivial conveniences, so perhaps they can also be +removed. +

+ +

string-copy has 3 extra arguments to allow strings to be copied directly into other strings. +In vectors, we can use subvector, but substring returns a new string (copying its argument) unless +the optimizer notices that the copy is not needed. Copy almost works, but its start and end arguments +refer to the source, not the destination. substring should be like subvector, but that is not backwards compatible. +

+ +

There are several less-than-ideal names. +get-output-string should be current-output-string. write-char behaves +like display, not write. +provided? should be feature? or *features* should be *provisions*. +list-ref, list-set!, and list-tail actually only apply to pairs. +let-temporarily should be templet, or maybe set-temporarily. +There should not be two names for the same thing: call/cc and +call-with-current-continuation: flush the latter! +The CL-inspired "log*" names such as logand look very old-fashioned. +Standard scheme opts +for the name "bitwise*"; why not "integerwise" or "bytevectorwise"? The + "wise" business is just noise; are they thinking of The Hobbit? +(define & logand) (define | logior) (define ~ lognot), but ^ for logxor +(as in C) is not ideal; ^ should be expt. Finally, I think the notion of a current input or output port is +a mistake: the IO functions should always get an explicit port. +

+ +

+cond-expand is dumb and its name is dumber. +Take libgsl.scm; different versions of the GSL library have different functions. We need to know +when we're building the FFI what GSL version we're dealing with. It would be nuts to start pushing and checking dozens +of library version symbols when all we actually want is (> version 23.19). +In place of cond-expand, s7 uses reader-cond, +so the read-time decision involves normal Scheme evaluation. +

+ +

Then there's the case case: a case clause without a result appears to be an error in r7rs. +But the notation used to indicate that is the same as that used for begin, +so if we allow (begin), we should allow case clauses to have no explicit result. +In cond, +the "implicit progn" (in CL terminology) includes the test expression, so a clause without a result returns +the test result (if true of course). In the case case, s7 returns the selector. +(case x ((0 1))) is equivalent to (case x ((0 1) => values)), +just as (cond (A)) is equivalent to (cond (A => values)). +One application is method lookup: ((case (obj 'abs) ((#<undefined>) abs) (else)) ...); +we would otherwise have to save the lookup result or do it twice. +This choice has a ripple +effect on do: if no result is specified for do, s7 returns the test result. +It also affects +hash-tables. Currently hash-table-ref returns #f if the key is not in the table, +mimicking assoc and aimed at cond with =>, but if we also use case and #<undefined>, +it seems more useful and maybe intuitive to mimic let-ref instead. But if hash-table-ref returns +#<undefined>, it's harder to use hash-tables as sets. Hmm. +In any case, +the fall-through value of case should be (and is in s7) +#<unspecified>: case is a form of if, so +(if #f #f), (cond (#f #f)), and (case #t ((#f) #f)) should be equal. +

+ + +

+Better ideas are always welcome! +

+ +

Here are the built-in s7 variables: +

+
    +
  • *features* ; a list of symbols +
  • *libraries* ; a list of (filename . let) pairs +
  • *load-path* ; a list of directories +
  • *cload-directory* ; directory for cload output +
  • *autoload* ; autoload info +
  • *#readers* ; a list of (char . handler) pairs +
+ +

And the built-in constants: +

+
    +
  • pi +
  • *stdin* *stdout* *stderr* +
  • *s7* +
  • +nan.0 -nan.0 +inf.0 -inf.0 (what crappy names! +nan.0 is a positive inexact integer that is not a number?) +
  • *unbound-variable-hook* *missing-close-paren-hook* *load-hook* *autoload-hook* +
  • *error-hook* *read-error-hook* *rootlet-redefinition-hook* +
+ +

Is it odd that the "+" in +nan.0 can't be omitted, but as used in a complex number, someone drops a "+": 1+nan.0i? +

+ +

(*function*) returns the name (or name and location) of the function currently being called. +(define (example) (*function*)) returns 'example. +Here is an example using a bacro (to access the call-time environment) and an openlet to implement a probe; +it reports any operation that the probe participates in, using *function* to get the calling function name: +

+
(define (probe-eval val)
+  (let ((all-let (inlet)))
+    (for-each
+     (lambda (sym)
+       (unless (immutable? sym) ; apply-values etc
+	 (let ((func (symbol->value sym (rootlet))))
+	   (when (procedure? func)
+	     (varlet all-let sym
+		     (apply bacro 'args
+		       `((let-temporarily (((*s7* 'openlets) #f))
+			   (let ((clean-args (map (lambda (arg)
+						    (if (eq? arg probe-eval)
+							(probe-eval 'value)
+							arg))
+						  args)))
+			   (format *stderr* "(~S ~{~S~^ ~}) ; ~S~%" 
+                                   ,sym clean-args 
+                                   (*function* (outlet (outlet (curlet)))))
+			   (apply ,func clean-args))))))))))
+     (symbol-table))
+    (varlet all-let 'value val)
+    (openlet all-let)))
+
+(define (call-any x)
+  (+ x 21))
+
+(call-any (probe-eval 42)) ; prints "(+ 42 21) ; call-any", returns 63
+
+

+The second argument to *function* is the let from which to start searching for a function. +In the example above, we start the search from the let outside the bacro, since we hope to find the bacro's caller. +As a convenience, *function* takes an optional third argument specifying what information you want +about the current function. An example: (*function* (curlet) 'name). +name returns the name (a symbol) of the current function. +line returns the function's definition line number. +file returns the function's definition file. +Other possibilities are signature, documentation, +arity, arglist, value, and source. +funclet returns the current function's funclet. +

+ +

Currently WITH_PURE_S7: +

+
    +
  • places 'pure-s7 in *features* +
  • omits char-ready, char-ci*, string-ci* +
  • omits string-fill!, vector-fill!, vector-append +
  • omits list->string, list->vector, string->list, vector->list, let->list +
  • omits string-length and vector-length +
  • omits cond-expand, multiple-values-bind|set!, call-with-values +
  • omits unquote (the name) +
  • omits d/f/s/l exponents +
  • omits make-polar and make-rectangular (use complex) +
  • omits exact?, inexact?, exact->inexact, inexact->exact +
  • omits set-current-output-port and set-current-input-port +
+ +
+ + + +
+ +

Schemes vary in their treatment of (). s7 considers it a constant that evaluates to itself, +so you don't need to quote it. (eq? () '()) is #t. +This is consistent with, for example, +(eq? #f '#f) which is also #t. +The standard says "the empty list is a special object of its own type", so surely either choice is +acceptable in that regard (but, sigh, the standard stupidly goes on to deny that () can evaluate to itself). +(I'm told that "is an error" means "is not portable" in the standard's weasely abuse of English; if +they mean "is not portable" why not say so?). +Some of the confusion appears to be caused by the word "list". I would describe the evaluator: "if it gets a +constant (and () is a constant) it returns that constant; if a symbol, it returns the value +associated with that symbol; if a pair, it looks at the pair's +car to decide what to do". It's kinda looney to insist on looking at the car of a list when you know () has no car! +

+ + + +

Similarly, in s7, vector constants do not have to be quoted. A list constant is quoted +to keep it from being evaluated, but +#(1 2 3) is as unproblematic as "123" or 123. +

+ + + +

These examples bring up another odd corner of scheme: else. In (cond (else 1)) +the 'else is evaluated (like any cond test), so its value might be #f; in (case 0 (else 1)) +it is not evaluated (like any case key), so it's just a symbol. +Since setters are local in s7, +someone can (let ((else #f)) (cond (else 1))) even if we protect the rootlet 'else. +Of course, in scheme this kind of trouble is pervasive, so rather than make 'else a constant +I think the best path is to use unlet: +(let ((else #f)) (cond (#_else 1))). This is 1 (not ()) because the initial value of 'else +can't be changed. +

+
+ + +
+ +

s7 handles circular lists and vectors and dotted lists with its customary aplomb. +You can pass them to memq, or print them, for example; you can even evaluate them. +The print syntax is borrowed from CL: +

+ +
> (let ((lst (list 1 2 3))) 
+    (set! (cdr (cdr (cdr lst))) lst) 
+    lst)
+#1=(1 2 3 . #1#)
+> (let* ((x (cons 1 2)) 
+         (y (cons 3 x))) 
+    (list x y))
+(#1=(1 . 2) (3 . #1#))
+
+ +

+But should this syntax be readable as well? I'm inclined to say no because +then it is part of the language, and it doesn't look like the rest of the language. +(I think it's kind of ugly). Perhaps we could implement it via *#readers*: +

+ +
(define circular-list-reader
+  (let ((known-vals #f)
+	(top-n -1))
+    (lambda (str)
+
+      (define (replace-syms lst)
+	;; walk through the new list, replacing our special keywords 
+        ;;   with the associated locations
+
+	(define (replace-sym tree getter)
+	  (if (keyword? (getter tree))
+	      (let ((n (string->number (symbol->string (keyword->symbol (getter tree))))))
+		(if (integer? n)
+		    (let ((lst (assoc n known-vals)))
+		      (if lst
+			  (set! (getter tree) (cdr lst))
+			  (format *stderr* "#~D# is not defined~%" n)))))))
+
+	(let walk-tree ((tree (cdr lst)))
+	  (if (pair? tree)
+	      (begin
+		(if (pair? (car tree)) (walk-tree (car tree)) (replace-sym tree car))
+		(if (pair? (cdr tree)) (walk-tree (cdr tree)) (replace-sym tree cdr))))
+	  tree))
+
+      ;; str is whatever followed the #, first char is a digit
+      (let* ((len (length str))
+	     (last-char (str (- len 1))))
+	(and (memv last-char '(#\= #\#))             ; is it #n= or #n#?
+	    (let ((n (string->number (substring str 0 (- len 1)))))
+	      (and (integer? n)
+		  (begin
+		    (if (not known-vals)            ; save n so we know when we're done
+			(begin
+			  (set! known-vals ())
+			  (set! top-n n))) 
+
+		    (if (char=? last-char #\=)      ; #n=
+			(and (eqv? (peek-char) #\() ; eqv? since peek-char can return #<eof>
+			    (let ((cur-val (assoc n known-vals)))
+			      ;; associate the number and the list it points to
+			      ;;    if cur-val, perhaps complain? (#n# redefined)
+			      (let ((lst (catch #t 
+					   read
+					   (lambda args             ; a read error
+					     (set! known-vals #f)   ;   so clear our state
+					     (apply throw args))))) ;   and pass the error on up
+				(if cur-val
+                                    (set! (cdr cur-val) lst)
+				    (set! known-vals 
+					  (cons (set! cur-val (cons n lst)) known-vals))))
+
+			      (if (= n top-n)            ; replace our special keywords
+				  (let ((result (replace-syms cur-val)))
+				    (set! known-vals #f) ; '#1=(#+gsl #1#) -> '(:1)!
+				    result)
+				  (cdr cur-val))))
+			                         ; #n=<not a list>?
+			;; else it's #n# — set a marker for now since we may not 
+			;;   have its associated value yet.  We use a symbol name that 
+                        ;;   string->number accepts.
+			(symbol->keyword 
+                          (symbol (number->string n) (string #\null) " "))))))
+		                                 ; #n<not an integer>?
+	    )))))                                ; #n<something else>?
+
+(do ((i 0 (+ i 1)))
+    ((= i 10))
+  ;; load up all the #n cases
+  (set! *#readers* 
+    (cons (cons (integer->char (+ i (char->integer #\0))) circular-list-reader)
+          *#readers*)))
+
+> '#1=(1 2 . #1#)
+#1=(1 2 . #1#)
+> '#1=(1 #2=(2 . #2#) . #1#)
+#2=(1 #1=(2 . #1#) . #2#)
+
+ +

And of course, we can treat these as labels: +

+ +
(let ((ctr 0)) #1=(begin (format () "~D " ctr) (set! ctr (+ ctr 1)) (if (< ctr 4) #1# (newline))))
+
+ +

which prints "0 1 2 3" and a newline. +

+ +
+ + +

Length returns +inf.0 if passed a circular list, and returns a negative +number if passed a dotted list. In the dotted case, the absolute value of the length is the list length not counting +the final cdr. (define (circular? lst) (infinite? (length lst))). +

+ +

+cyclic-sequences returns a list of the cyclic +sequences in its argument, or nil. +(define (cyclic? obj) (pair? (cyclic-sequences obj))). +

+ +

Here's an amusing use of circular lists: +

+ +
(define (for-each-permutation func vals)
+  ;; apply func to every permutation of vals: 
+  ;;   (for-each-permutation (lambda args (format () "~{~A~^ ~}~%" args)) '(1 2 3))
+  (define (pinner cur nvals len)
+    (if (= len 1)
+        (apply func (car nvals) cur)
+        (do ((i 0 (+ i 1)))                       ; I suppose a named let would be more Schemish
+            ((= i len))
+          (let ((start nvals))
+            (set! nvals (cdr nvals))
+            (let ((cur1 (cons (car nvals) cur)))  ; add (car nvals) to our arg list
+              (set! (cdr start) (cdr nvals))      ; splice out that element and 
+              (pinner cur1 (cdr start) (- len 1)) ;   pass a smaller circle on down, "wheels within wheels"
+              (set! (cdr start) nvals))))))       ; restore original circle
+  (let ((len (length vals)))
+    (set-cdr! (list-tail vals (- len 1)) vals)    ; make vals into a circle
+    (pinner () vals len)
+    (set-cdr! (list-tail vals (- len 1)) ())))    ; restore its original shape
+
+
+ + +
+ +

s7 and Snd use "*" in a variable name, *features* for example, to indicate +that the variable is predefined. It may occur unprotected in a macro, for +example. The "*" doesn't mean that the variable is special in the CL sense of dynamic scope, +but some clear marker is needed for a global variable so that the programmer +doesn't accidentally step on it. +

+ +

Although a variable name's first character is more restricted, currently +only #\null, #\newline, #\tab, #\space, #\), #\(, #\", and #\; can't +occur within the name. I did not originally include double-quote in this set, so wild stuff like +(let ((nam""e 1)) nam""e) +would work, but that means that '(1 ."hi") is parsed as a 1 and the +symbol ."hi", and (string-set! x"hi") is an error. +The first character should not be #\#, #\', #\`, #\,, #\:, or any of those mentioned above, +and some characters can't occur by themselves. For example, "." is not a legal variable +name, but ".." is. +These weird symbols have to be printed sometimes: +

+ +
> (list 1 (string->symbol (string #\; #\" #\\)) 2)
+(1 ;"\ 2)            
+> (list 1 (string->symbol (string #\.)) 2)
+(1 . 2)
+
+ +

which is a mess. Guile prints the first as (1 #{\;\"\\}# 2). +In CL and some Schemes: +

+ +
[1]> (list 1 (intern (coerce (list #\; #\" #\\) 'string)) 2) ; thanks to Rob Warnock
+(1 |;"\\| 2)        
+[2]> (equalp 'A '|A|) ; in CL case matters here
+T
+
+ +

This is clean, and has the weight of tradition behind it, but +I think I'll use "symbol" instead: +

+ +
> (list 1 (string->symbol (string #\; #\" #\\)) 2)
+(1 (symbol ";\"\\") 2)       
+
+ +

+This output is readable, and does not eat up perfectly good +characters like vertical bar, but it means we can't easily use +variable names like "| e t c |". We could allow a name to +contain any characters if it starts and ends with "|", +but then one vertical bar is trouble. (The symbol function +actually accepts any number of string arguments which it concatenates +to form the new symbol name). +

+ +

+These symbols are not just an optimization of string comparison: +

+ +
> (define-macro (hi a) 
+  (let ((funny-name (string->symbol ";")))
+    `(let ((,funny-name ,a)) (+ 1 ,funny-name))))
+hi
+> (hi 2)
+3
+> (macroexpand (hi 2))
+(let ((; 2)) (+ 1 ;))    ; for a good time, try (string #\")
+
+> (define-macro (hi a) 
+  (let ((funny-name (string->symbol "| e t c |")))
+    `(let ((,funny-name ,a)) (+ 1 ,funny-name))))
+hi
+> (hi 2)
+3
+> (macroexpand (hi 2))
+(let ((| e t c | 2)) (+ 1 | e t c |))
+> (let ((funny-name (string->symbol "| e t c |"))) ; now use it as a keyword arg to a function
+    (apply define* `((func (,funny-name 32)) (+ ,funny-name 1)))
+    ;; (procedure-source func) is (lambda* ((| e t c | 32)) (+ | e t c | 1))
+    (apply func (list (symbol->keyword funny-name) 2)))
+3
+
+ +

I hope that makes you as happy as it makes me! +

+
+ + +
+ +

The built-in syntactic forms, such as "begin", are almost first-class citizens. +

+ +
> (let ((progn begin)) 
+    (progn 
+      (define x 1) 
+      (set! x 3) 
+      (+ x 4)))
+7
+> (let ((function lambda)) 
+    ((function (a b) (list a b)) 3 4))
+(3 4)
+> (apply begin '((define x 3) (+ x 2)))
+5
+> ((lambda (n) (apply n '(((x 1)) (+ x 2)))) let)
+3
+
+(define-macro (symbol-set! var val) ; like CL's set
+  `(apply set! ,var ',val ()))      ; trailing nil is just to make apply happy — apply*?
+
+(define-macro (progv vars vals . body)
+ `(apply (apply lambda ,vars ',body) ,vals))
+
+> (let ((s '(one two)) (v '(1 2))) (progv s v (+ one two)))
+3
+
+ +

We can snap together program fragments ("look Ma, no macros!"): +

+ +
(let* ((x 3) 
+       (arg '(x)) 
+       (body `((+ ,x x 1)))) 
+  ((apply lambda arg body) 12)) ; "legolambda"?
+
+(define (engulph form)
+  (let ((body `(let ((L ()))
+		 (do ((i 0 (+ i 1)))
+		     ((= i 10) (reverse L))
+		   (set! L (cons ,form L))))))
+    (define function (apply lambda () (list (copy body))))
+    (function)))
+
+(let ()
+  (define (hi a) (+ a x))
+  ((apply let '((x 32)) (list (procedure-source hi))) 12)) ; one function, many closures?
+
+(let ((ctr -1))  ; (enum zero one two) but without using a macro
+  (apply begin 
+    (map (lambda (symbol) 
+           (set! ctr (+ ctr 1)) 
+           (list 'define symbol ctr)) ; e.g. '(define zero 0) 
+         '(zero one two)))
+  (+ zero one two))
+
+ +

But there's a prettier way to implement enum ("transparent-for-each"): +

+ +
> (define-macro (enum . args)
+    `(for-each define ',args (iota (length ',args))))
+enum
+> (enum a b c) 
+#<unspecified>
+> b
+1
+
+ +

Now we notice that (case 0.0 ((0.0) 1) (else 0)) is 1, but +how to get pi into a key list? +

+
> (apply case 'pi `(((,pi) 1) (else 0)))
+1
+> (let ((lst '(1 2))) (apply case 'lst `(((,lst) 1) (else 0))))
+1         ; same trick puts a list in the keys
+> (apply case '+nan.0 `(((,+nan.0) 1) (else 0)))
+0         ; (eqv? +nan.0 +nan.0) is #f
+
+ +

(apply define ...) is similar to CL's set. +

+ +
> ((apply define-macro '((m a) `(+ 1 ,a))) 3)
+4
+> ((apply define '((hi a) (+ a 1))) 3)
+4
+
+ +

Apply let is very similar to eval: +

+
> (apply let '((a 2) (b 3)) '((+ a b)))
+5
+> (eval '(+ a b) (inlet 'a 2 'b 3))
+5
+> ((apply lambda '(a b) '((+ a b))) 2 3)
+5
+> (apply let '((a 2) (b 3)) '((list + a b))) ; a -> 2, b -> 3
+(+ 2 3)
+
+

The redundant-looking double lists are for apply's benefit. We could +use a trailing null instead (mimicking apply* in some ancient lisps): +

+
> (apply let '((a 2) (b 3)) '(list + a b) ())
+(+ 2 3)
+
+ +

Scheme claims that it evaluates the car of an expression, then calls the +result with the rest of the expression. So ((if x + -) y z) calls either +(+ y z) or (- y z) depending on x. +But only s7, as far as I know, handles ((if x or and) y z). +

+ +

catch, dynamic-wind, and many of the other functions that take function +arguments in standard Scheme, accept macros in s7, and dynamic-wind accepts +#f as the initial and final entries. +

+ +

+Currently, you can't set! a built-in syntactic keyword to some new value: +(set! if 3). +let-temporarily uses set!, so (let-temporarily ((if 3))...) +is also unlikely to work. +

+
+ + +

Speaking of speed... It is widely believed +that a Scheme with first class everything can't hope to compete with any +"real" Scheme. Humph I say. Take this little example (which is not +so misleading that I feel guilty about it): +

+
(define (do-loop n)
+  (do ((i 0 (+ i 1)))
+      ((= i n))
+    (if (zero? (modulo i 1000))
+	(display ".")))
+  (newline))
+
+(for-each do-loop (list 1000 1000000 10000000))
+
+ +

In s7, that takes 0.09 seconds on my home machine. In tinyScheme, from +whence we sprang, it takes 85 seconds. In the chicken interpreter, 5.3 +seconds, and after compilation (using -O2) of the chicken compiler output, +0.75 seconds. So, s7 is comparable to chicken in speed, even though chicken +is compiling to C. I think Guile 2.0.9 takes about 1 second. +The equivalent in CL: +clisp interpreted 9.3 seconds, compiled 0.85 seconds; sbcl 0.21 seconds. +Similarly, s7 computes (fib 40) in 0.8 seconds, approximately the same as sbcl. +Guile 2.2.3 takes 7 seconds. +

+ +
+

+s7's timing tests are in its tools directory. The script +valcall.scm runs them through callgrind. The results +can be found at the end of s7.c. +If you're interested in the standard Scheme benchmarks, it +is possible to add s7 to that package. First, s7-prelude.scm +and s7-postlude.scm need to be added to the benchmarks src directory. +s7-postlude.scm can be empty. My version of s7-prelude.scm is: +

+
(define (this-scheme-implementation-name) "s7")
+(define exact-integer? integer?)	
+(define (exact-integer-sqrt i) (let ((sq (floor (sqrt i)))) (values sq (- i (* sq sq)))))
+(define inexact exact->inexact)
+(define exact inexact->exact)
+(define (square x) (* x x))
+(define (vector-map f v) (copy v)) ; for quicksort.scm
+(define-macro (import . args) #f)
+(define (jiffies-per-second) 1000)
+(define (current-jiffy) (round (* (jiffies-per-second) (*s7* 'cpu-time))))
+(define (current-second) (floor (*s7* 'cpu-time)))
+
+

+If you want to run gcbench, add the define-record-type macro from r7rs.scm. +Here are the diffs for the bench script: +

+
141a142
+>     S7=${S7:-"/home/bil/motif-snd/repl"}
+187a189
+>   s7               for s7
+406a409,421
+> # Definitions specific to s7
+> 
+> s7_comp ()
+> {
+>     :
+> }
+> 
+> s7_exec ()
+> {
+>     time ${S7} "$1" < "$2"
+> }
+> 
+> # -----------------------------------------------------------------------------
+940a957,966
+> 
+>         s7)    NAME='s7'
+>                COMP=s7_comp
+>                EXEC=s7_exec
+>                COMPOPTS=""
+>                EXTENSION="scm"
+>                EXTENSIONCOMP="scm"
+>                COMPCOMMANDS=""
+>                EXECCOMMANDS=""
+>                ;;
+
+

+I call the standalone version of s7 "repl", so its path +is /home/bil/motif-snd/repl. To build repl, get s7.tar.gz +from https://ccrma.stanford.edu/software/s7/s7.tar.gz; +if not using gcc or clang, add the empty file mus-config.h to the tarball's contents, +then (in Linux): +

+
gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-dynamic -Wno-stringop-overflow
+
+

For timing tests, I add "-fomit-frame-pointer -funroll-loops -march=native". +mus-config.h normally has +

+
#define HAVE_COMPLEX_NUMBERS 1
+#define HAVE_COMPLEX_TRIG 1
+
+

+but s7.c has defaults, so mus-config.h can be empty, or absent. +Finally, go back to the benchmarks directory and +

+
bench s7 all
+
+ +

+The benchmark compiler.scm assumes that small +integers can be compared with eq? (via assq), which is incorrect. +pi.scm and chudnovsky.scm need the gmp version of s7. +I ran the bench script on an AMD 3950X machine, and got these results (in seconds): +ack: 6.6, array1: 6.4, browse: 11.2, bv2string: 4.1, cat: 0.4, +compiler: 16.9, conform: 30.0, cpstak: 42.8, ctak: 16.6, deriv: 9.7, +destruc: 8.6, diviter: 3.7, divrec: 4.6, dynamic: 12.6, earley: 25.5, +equal: 0.3, fft: 12.5, fib: 6.1, fibc: 8.6, fibfp: 1.1, gcbench: 12.9, +grahps: 72.5, lattice: 63.4, matrix: 21.0, maze: 11.4, mazefun: 9.8, +mbrot: 12.6, mbrotZ: 8.0, mperm: 18.9, nboyer: 20.1, nqueens: 27.0, +ntakl: 8.0, nucleic: 8.3, paraffins: 4.4, parsing: 20.7, peval: 15.2, +pnpoly: 9.8, primes: 10.2, puzzle: 10.2, quicksort: 40.0, ray: 8.3, +read1: 0.2, sboyer: 19.1, scheme: 29.5, simplex: 26.9, slatex: 4.2, +string: 0.8, sum1: 0.2, sum: 4.1, sumfp: 2.2, tail: 0.1, tak: 7.1, +takl: 8.1, triangl: 16.4, wc: 4.9. In the gmp case, chudnovsky: 0.017, pi: .01. +

+
+ + + +
+ +

In s7, there is only one kind of begin statement, +and it can contain both definitions and expressions. These are evaluated in the order +in which they occur, and in the environment at the point of the evaluation. I think +of it as being a little REPL. begin does not introduce a new frame in +the current environment, so defines happen in the enclosing environment. +Finally, begin, explicit or otherwise, does not pretend to emulate letrec*. +

+ +

If we allow defines anywhere, the notion of "lexical scope" becomes problematic. +Scheme is already a mess in that regard: take +

+ +
(let ((x 1))
+  (do ((y x x)
+       (x 3))
+      ((> y 1) y)))
+
+ +

In (y x x) the first x is the outer one, and the second is the +following do variable, so this returns 3! But sticking to define, in +

+ +
(let ((x 1))
+  (define y x)
+  (define x 2)
+  y)
+
+ +

s7 returns 1 even though technically the second x is in y's environment. +Since we treat this as a REPL, y gets its value from the only x defined at +the point it is defined. However, +

+ +
(let ((x 1))
+  (define y (lambda () x))
+  (define x 2)
+  (y))
+
+ +

returns 2 in s7 because the x in y's function body is not evaluated +until after the second x is defined. +The define propagates backwards, but: +(list x (define x 0)), or (list x (begin (define x 0) x)). +

+
+ + +
+ +

The r7rs compatibility code is in r7rs.scm. I used to include it here, but +as r7rs grew, this section got too large. In general, all the conversion routines in +r7rs are handled in s7 via generic functions, records are classes, and so on. +

+
+ + +
+ +

"Life", a poem. +

+ +
(+(*(+))(*)(+(+)(+)(*)))
+(((((lambda () (lambda () (lambda () (lambda () 1))))))))
+(+ (((lambda () values)) 1 2 3))
+(map apply (list map) (list map) (list (list *)) '((((1 2)) ((3 4 5)))))
+(do ((do do do)) (do do do))
+(*(*)(*) (+)(+) 1)
+
+ +
+ +
+

+ + + +
FFI examples
+ +

s7 exists only to serve as an extension of some other application, so +it is primarily a foreign function interface. s7.h has lots of comments about the individual +functions. Here I'll collect some complete examples. s7.c depends on the following +compile-time flags: +

+ +
SIZEOF_VOID_P                  8 (default) or 4.
+WITH_GMP                       1 if you want multiprecision arithmetic (requires gmp, mpfr, and mpc, default is 0)
+HAVE_COMPLEX_NUMBERS           1 if your compiler supports complex numbers
+HAVE_COMPLEX_TRIG              1 if your math library has complex versions of the trig functions
+DISABLE_DEPRECATED             1 if you want to make sure you're not using any deprecated s7 stuff (default is 0)
+
+WITH_IMMUTATBLE_UNQUOTE        1 if you want "unquote" omitted (default is 0)
+WITH_EXTRA_EXPONENT_MARKERS    1 if you want "d", "f", "l", and "s" in addition to "e" as exponent markers (default is 0)
+                                   if someone defends these exponent markers, ask him to read 1l11+11l1i
+                                   (in 2 million lines of open-source Scheme, there is not one use of these silly things)
+WITH_SYSTEM_EXTRAS             1 if you want some additional OS-related functions built-in (default is 0)
+WITH_MAIN                      1 if you want s7.c to include a main program section that runs a REPL.
+WITH_C_LOADER		       1 if you want to be able to load shared object files with load.
+
+ +

See the comment at the start of s7.c for more information about these switches. +s7.h defines the two main number types: s7_int and s7_double. +The examples that follow show: +

+ + + + + + + +

A simple listener

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include "s7.h"
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  char buffer[512];
+  char response[1024];
+
+  s7 = s7_init();                 /* initialize the interpreter */
+  while (1)                       /* fire up a read-eval-print loop */
+    {
+      fprintf(stdout, "\n> ");    /* prompt for input */
+      fgets(buffer, 512, stdin);
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                         /* evaluate the input and print the result */
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response); 
+	}
+    }
+}
+
+/* if not using gcc or clang, make mus-config.h (it can be empty), then
+ *
+ *   gcc -c s7.c -I.
+ *   gcc -o repl repl.c s7.o -lm -I. -ldl
+ *
+ * run it:
+ *
+ *    repl
+ *    > (+ 1 2)
+ *    3
+ *    > (define (add1 x) (+ 1 x))
+ *    add1
+ *    > (add1 2)
+ *    3
+ *    > (exit)
+ *
+ * for long-term happiness in linux use:
+ *   gcc -o repl repl.c s7.o -Wl,-export-dynamic -lm -I. -ldl
+ *   clang also needs -fPIC I think
+ * freebsd:
+ *   gcc -o repl repl.c s7.o -Wl,-export-dynamic -lm -I.
+ * osx:
+ *   gcc -o repl repl.c s7.o -lm -I.
+ * openbsd:
+ *   gcc -o repl repl.c s7.o -I. -ftrampolines -Wl,-export-dynamic -lm
+ */
+
+
+ + +

Since this reads stdin and writes stdout, it can be run as a Scheme subjob of emacs. +One (inconvenient) way to do this is to set the emacs variable scheme-program-name to +the name of the exectuable created above ("repl"), then call the emacs function run-scheme: +M-x eval-expression in emacs, followed by (setq scheme-program-name "repl"), then +M-x run-scheme, and you're talking to s7 in emacs. Of course, this connection can be +customized indefinitely. See, for example, inf-snd.el in the Snd package. +

+ +

Here are the not-always-built-in indentations I use in emacs: +

+
(put 'with-let 'scheme-indent-function 1)
+(put 'with-baffle 'scheme-indent-function 0)
+(put 'with-sound 'scheme-indent-function 1)
+(put 'catch 'scheme-indent-function 1)
+(put 'lambda* 'scheme-indent-function 1)
+(put 'when 'scheme-indent-function 1)
+(put 'let-temporarily 'scheme-indent-function 1)
+(put 'let*-temporarily 'scheme-indent-function 1)
+(put 'call-with-input-string 'scheme-indent-function 1)
+(put 'unless 'scheme-indent-function 1)
+(put 'letrec* 'scheme-indent-function 1)
+(put 'sublet 'scheme-indent-function 1)
+(put 'varlet 'scheme-indent-function 1)
+(put 'case* 'scheme-indent-function 1)
+
+ +

To read stdin while working in a GUI-based program is trickier. In glib, you can use +something like this: +

+ +
+
+
static gboolean read_stdin(GIOChannel *source, GIOCondition condition, gpointer data)
+{
+  /* here read from g_io_channel_unix_get_fd(source) and call s7_eval_string */
+  return(true);
+}
+
+/* ... during initialization ... */
+
+GIOChannel *channel;
+channel = g_io_channel_unix_new(STDIN_FILENO);  /* watch stdin */
+stdin_id = g_io_add_watch_full(channel,         /* and call read_stdin above if input is noticed */
+			       G_PRIORITY_DEFAULT, 
+			       (GIOCondition)(G_IO_IN | G_IO_HUP | G_IO_ERR), 
+			       read_stdin, NULL, NULL);
+g_io_channel_unref(channel);
+
+
+ + +

Here's a version that uses libtecla for the line editor: +

+ +
+
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <libtecla.h>
+#include "s7.h"
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  char *buffer;
+  char response[1024];
+  GetLine *gl;            /* The tecla line editor */
+
+  gl = new_GetLine(500, 5000);
+  s7 = s7_init();  
+
+  while (1) 
+    {
+      buffer = gl_get_line(gl, "> ", NULL, 0);
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response);
+	  fprintf(stdout, "\n");
+	}
+    }
+  gl = del_GetLine(gl);
+}
+
+/* 
+ *   gcc -c s7.c -I. -O2 -g3
+ *   gcc -o ex1 ex1.c s7.o -lm -I. -ltecla -ldl
+ */
+
+
+ + +

A repl (based on repl.scm or nrepl.scm) is built into s7. Include the compiler flag -DWITH_MAIN: +

+ +
gcc -o nrepl s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl -DWITH_MAIN -DWITH_NOTCURSES -lnotcurses-core
+
+ + +

+Common Lisp has something called "evalhook" that makes it possible +to insert your own function into the eval loop. In s7, we have a "begin_hook" which sits at the opening of many begin blocks +(implicit or explicit). begin_hook is a (C) function; +if it sets its bool argument to true, +s7 interrupts the current evaluation. +Here is a version of the REPL in which begin_hook watches for C-g to interrupt +some long computation: +

+ +
+
+
/* terminal-based REPL, 
+ *    an expansion of the read-eval-print loop program above.
+ * type C-g to interrupt an evaluation.
+ */
+#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <termios.h>
+#include <signal.h>
+
+#include "s7.h"
+
+static struct termios save_buf, buf;
+
+static void sigcatch(int n)
+{
+  /* put things back the way they were */
+  tcsetattr(fileno(stdin), TCSAFLUSH, &save_buf);
+  exit(0);
+}
+
+static char buffer[512];
+static int type_ahead_point = 0;
+
+static void watch_for_c_g(s7_scheme *sc, bool *all_done)
+{
+  char c;
+  /* watch for C-g without blocking, save other chars as type-ahead */
+  tcsetattr(fileno(stdin), TCSAFLUSH, &buf);
+  if (read(fileno(stdin), &c, 1) == 1)
+    {
+      if (c == 7) /* C-g */
+	{
+	  *all_done = true;
+	  type_ahead_point = 0;
+	}
+      else buffer[type_ahead_point++] = c;
+    }
+  tcsetattr(fileno(stdin), TCSAFLUSH, &save_buf);
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  bool use_begin_hook;
+
+  use_begin_hook = (tcgetattr(fileno(stdin), &save_buf) >= 0);
+  if (use_begin_hook)
+    {
+      buf = save_buf;
+      buf.c_lflag &= ~ICANON;
+      buf.c_cc[VMIN] = 0;
+      buf.c_cc[VTIME] = 0;
+
+      signal(SIGINT, sigcatch);
+      signal(SIGQUIT, sigcatch);
+      signal(SIGTERM, sigcatch);
+    }
+  s7 = s7_init();  
+
+  if (argc == 2)
+    {
+      fprintf(stderr, "load %s\n", argv[1]);
+      if (!s7_load(s7, argv[1]))
+        fprintf(stderr, "can't find %s\n", argv[1]);
+    }
+  else
+    {
+      char response[1024];
+      while (1) 
+	{
+	  fprintf(stdout, "\n> ");
+	  fgets((char *)(buffer + type_ahead_point), 512 - type_ahead_point, stdin);
+	  type_ahead_point = 0;
+
+	  if ((buffer[0] != '\n') || 
+	      (strlen(buffer) > 1))
+	    {                            
+	      snprintf(response, 1024, "(write %s)", buffer);
+
+	      if (use_begin_hook)
+		s7_set_begin_hook(s7, watch_for_c_g);
+	      s7_eval_c_string(s7, response);
+	      if (use_begin_hook)
+		s7_set_begin_hook(s7, NULL);
+	    }
+	}
+    }
+  if (use_begin_hook)
+    tcsetattr(fileno(stdin), TCSAFLUSH, &save_buf);
+}
+
+
+ + + + +

Define a function with arguments and a returned value, and a variable

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+static s7_pointer add1(s7_scheme *sc, s7_pointer args)
+{
+  /* all added functions have this form, args is a list, 
+   *    s7_car(args) is the first arg, etc 
+   */
+  if (s7_is_integer(s7_car(args)))
+    return(s7_make_integer(sc, 1 + s7_integer(s7_car(args))));
+  return(s7_wrong_type_arg_error(sc, "add1", 1, s7_car(args), "an integer"));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  char buffer[512];
+  char response[1024];
+
+  s7 = s7_init();
+  
+  s7_define_function(s7, "add1", add1, 1, 0, false, "(add1 int) adds 1 to int");
+                                      /* add the function "add1" to the interpreter.
+                                       *   1, 0, false -> one required arg,
+				       *                  no optional args,
+				       *                  no "rest" arg
+				       */
+ s7_define_variable(s7, "my-pi", s7_make_real(s7, 3.14159265));
+
+  while (1)                           /* fire up a "repl" */
+    {
+      fprintf(stdout, "\n> ");        /* prompt for input */
+      fgets(buffer, 512, stdin);
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response); /* evaluate input and write the result */
+	}
+    }
+}
+
+/*    doc7
+ *    > my-pi
+ *    3.14159265
+ *    > (+ 1 (add1 1))
+ *    3
+ *    > (exit)
+ */
+
+ + + + +

Call a Scheme-defined function from C, and get/set Scheme variable values in C

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  s7 = s7_init();
+
+  s7_define_variable(s7, "an-integer", s7_make_integer(s7, 1));
+  s7_eval_c_string(s7, "(define (add1 a) (+ a 1))");
+  
+  fprintf(stderr, "an-integer: %lld\n", 
+	  s7_integer(s7_name_to_value(s7, "an-integer")));
+
+  s7_symbol_set_value(s7, s7_make_symbol(s7, "an-integer"), s7_make_integer(s7, 32));
+
+  fprintf(stderr, "now an-integer: %lld\n", 
+	  s7_integer(s7_name_to_value(s7, "an-integer")));
+
+  fprintf(stderr, "(add1 2): %lld\n", 
+	  s7_integer(s7_call(s7, 
+			     s7_name_to_value(s7, "add1"), 
+			     s7_cons(s7, s7_make_integer(s7, 2), s7_nil(s7)))));
+}
+
+/*
+ *    doc7
+ *    an-integer: 1
+ *    now an-integer: 32
+ *    (add1 2): 3
+ */
+
+ +

In more complicated cases, it is probably easier use s7_eval_c_string_with_environment. +As an example, say we want to have a C procedure that calls the pretty printer function pp +in write.scm, returning a string to C. We need to make sure pp is loaded, and catch +any errors that come up. And we need to pass the C-level s7 object to pp. So... +

+
static const char *pp(s7_scheme *sc, s7_pointer obj) /* (pp obj) */
+{
+  return(s7_string(
+          s7_eval_c_string_with_environment(sc,
+            "(catch #t                         \
+               (lambda ()                      \
+                 (unless (defined? 'pp)        \
+                   (load \"write.scm\"))       \
+                 (pp obj))                     \
+               (lambda (type info)             \
+                 (apply format #f info)))",
+	   s7_inlet(sc, s7_list(sc, 1, s7_cons(sc, s7_make_symbol(sc, "obj"), obj))))));
+}
+
+

and now when we want a pretty-printed representation of something: pp(sc, obj); +The s7_inlet call is creating a local environment with the object "obj" bound +in scheme to the name "obj" so that (pp obj) will find the "obj" that actually +lives in C. You may need to give the full filename for write.scm, or add its path +to the load-path list. In the latter case, (require write.scm) could +replace (unless (defined?...)). +

+
+ + + +

C++ and Juce, from Rick Taube

+ + +
+
int main(int argc, const char* argv[]) 
+{ 
+  initialiseJuce_NonGUI(); 
+
+  s7_scheme *s7 = s7_init(); 
+  if (!s7) 
+    { 
+      std::cout <<  "Can't start S7!\n"; 
+      return -1; 
+    } 
+
+  s7_pointer val; 
+  std::string str; 
+  while (true) 
+    { 
+      std::cout << "\ns7> "; 
+      std::getline(std::cin, str); 
+      val = s7_eval_c_string(s7, str.c_str()); 
+      std::cout << s7_object_to_c_string(s7, val); 
+    } 
+
+  free(s7); 
+  std::cout << "Bye!\n"; 
+  return 0; 
+} 
+
+ + + + + +

Load sndlib into an s7 repl

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <unistd.h>
+
+/* assume we've configured and built sndlib, so it has created a mus-config.h file.
+ * also assume we've built s7 with WITH_SYSTEM_EXTRAS set, so we have file-exists? and delete-file
+ */
+
+#include "mus-config.h"
+#include "s7.h"
+#include "xen.h"
+#include "clm.h"
+#include "clm2xen.h"
+
+/* we need to redirect clm's mus_error calls to s7_error */
+
+static void mus_error_to_s7(int type, char *msg)
+{
+  s7_error(s7,                               /* s7 is declared in xen.h, defined in xen.c */
+	   s7_make_symbol(s7, "mus-error"),
+	   s7_cons(s7, s7_make_string(s7, msg), s7_nil(s7)));
+}
+
+int main(int argc, char **argv)
+{
+  char buffer[512];
+  char response[1024];
+
+  s7 = s7_init();                     /* initialize the interpreter */
+  s7_xen_initialize(s7);              /* initialize the xen stuff (hooks and the xen s7 FFI used by sndlib) */
+  Init_sndlib();                      /* initialize sndlib with all the functions linked into s7 */  
+
+  mus_error_set_handler(mus_error_to_s7); /* catch low-level errors and pass them to s7-error */
+
+  while (1)                           /* fire up a "repl" */
+    {
+      fprintf(stdout, "\n> ");        /* prompt for input */
+      fgets(buffer, 512, stdin);
+
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response); /* evaluate input and write the result */
+	}
+    }
+}
+
+/* gcc -o doc7 doc7.c -lm -I. /usr/local/lib/libsndlib.a -lasound -ldl
+ *
+ *   (load "sndlib-ws.scm")
+ *   (with-sound () (outa 10 .1))
+ *   (load "v.scm")
+ *   (with-sound () (fm-violin 0 .1 440 .1))
+ *
+ * you might also need -lgsl -lgslcblas -lfftw3
+ */
+
+
+ +

If you built libsndlib.so, it is possible to use it directly in the s7 repl: +

+
repl          ; this is a bare s7 running repl.scm via -DWITH_MAIN=1
+loading libc_s7.so
+> (load "/home/bil/test/sndlib/libsndlib.so" (inlet 'init_func 's7_init_sndlib))
+#t            ; s7_init_sndlib ties all the sndlib functions and variables into s7
+> (load "sndlib-ws.scm")
+tmpnam
+> (set! *clm-player* (lambda (file) (system (format #f "sndplay ~A" file))))
+> (load "v.scm")
+fm-violin
+> (with-sound (:play #t) (fm-violin 0 1 440 .1))
+"test.snd"
+
+ +

You can use autoload to load libsndlib when needed: +

+ +
(define (find-library name)
+  (if (or (file-exists? name)
+	  (char=? (name 0) #\/))
+      name
+      (call-with-exit
+       (lambda (return)
+	 (for-each
+	  (lambda (path)
+	    (let ((new-name (string-append path "/" name)))
+	      (if (file-exists? new-name)
+		  (return new-name))))
+	  *load-path*)
+	 (let ((libs (getenv "LD_LIBRARY_PATH")) ; colon separated directory names
+	       (start 0))
+	   (do ((colon (char-position #\: libs) (char-position #\: libs start)))
+	       ((or (not colon)
+		    (let ((new-name (string-append (substring libs start colon) "/" name)))
+		      (and (file-exists? new-name)
+			   (return new-name)))))
+	     (set! start (+ colon 1))))
+	 name))))
+
+(autoload 'clm 
+  (lambda (e)
+    (load (find-library "libsndlib.so") (inlet '(init_func . s7_init_sndlib)))
+    (set! *features* (cons 'clm *features*))
+    (with-let (rootlet) (define clm #t))
+    (load "sndlib-ws.scm")
+    (set! *clm-player* (lambda (file) (system (format #f "sndplay ~A" file))))))
+
+ +

and use the repl's vt100 stuff to (for example) post the current begin time +as a note list computes: +

+ +
(define (clm-notehook . args)
+  ;; assume second arg is begin time (first is instrument name)
+  (when (and (pair? args) 
+	     (pair? (cdr args)) 
+	     (number? (cadr args)))
+    (with-let (sublet (*repl* 'repl-let) :begin-time (cadr args))
+      (let ((coords (cursor-coords))
+	    (col (floor (/ last-col 2))))
+	(let ((str (number->string begin-time)))
+	  (format *stderr* "~C[~D;~DH" #\escape prompt-row col)
+	  (format *stderr* "~C[K~A"  #\escape (if (> (length str) col) (substring str 0 (- col 1)) str)))
+	(format *stderr* "~C[~D;~DH"   #\escape (cdr coords) (car coords))))))
+
+(set! *clm-notehook* clm-notehook)
+
+ + + + + +

Add a new Scheme type and a procedure with a setter

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+/* define *listener-prompt* in scheme, add two accessors for C get/set */
+
+static const char *listener_prompt(s7_scheme *sc)
+{
+  return(s7_string(s7_name_to_value(sc, "*listener-prompt*")));
+}
+
+static void set_listener_prompt(s7_scheme *sc, const char *new_prompt)
+{
+  s7_symbol_set_value(sc, s7_make_symbol(sc, "*listener-prompt*"), s7_make_string(sc, new_prompt));
+}
+
+/* now add a new type, a struct named "dax" with two fields, a real "x" and a list "data" */
+/*   since the data field is an s7 object, we'll need to mark it to protect it from the GC */
+
+typedef struct {
+  s7_double x;
+  s7_pointer data;
+} dax;
+
+static int dax_type_tag = 0;
+
+static s7_pointer dax_to_string(s7_scheme *sc, s7_pointer args)
+{
+  char *data_str, *str;
+  s7_pointer result;
+  int data_str_len;
+  dax *o = (dax *)s7_c_object_value(s7_car(args));
+  data_str = s7_object_to_c_string(sc, o->data);
+  data_str_len = strlen(data_str);
+  str = (char *)calloc(data_str_len + 32, sizeof(char));
+  snprintf(str, data_str_len + 32, "<dax %.3f %s>", o->x, data_str);
+  free(data_str);
+  result = s7_make_string(sc, str);
+  free(str);
+  return(result);
+}
+
+static s7_pointer free_dax(s7_scheme *sc, s7_pointer obj)
+{
+  free(s7_c_object_value(obj));
+  return(NULL);
+}
+
+static s7_pointer mark_dax(s7_scheme *sc, s7_pointer obj)
+{
+  dax *o;
+  o = (dax *)s7_c_object_value(obj);
+  s7_mark(o->data);
+  return(NULL);
+}
+
+static s7_pointer make_dax(s7_scheme *sc, s7_pointer args)
+{
+  dax *o;
+  o = (dax *)malloc(sizeof(dax));
+  o->x = s7_real(s7_car(args));
+  if (s7_cdr(args) != s7_nil(sc))
+    o->data = s7_cadr(args);
+  else o->data = s7_nil(sc);
+  return(s7_make_c_object(sc, dax_type_tag, (void *)o));
+}
+
+static s7_pointer is_dax(s7_scheme *sc, s7_pointer args)
+{
+  return(s7_make_boolean(sc, 
+			 s7_is_c_object(s7_car(args)) &&
+			 s7_c_object_type(s7_car(args)) == dax_type_tag));
+}
+
+static s7_pointer dax_x(s7_scheme *sc, s7_pointer args)
+{
+  dax *o;
+  o = (dax *)s7_c_object_value(s7_car(args));
+  return(s7_make_real(sc, o->x));
+}
+
+static s7_pointer set_dax_x(s7_scheme *sc, s7_pointer args)
+{
+  dax *o;
+  o = (dax *)s7_c_object_value(s7_car(args));
+  o->x = s7_real(s7_cadr(args));
+  return(s7_cadr(args));
+}
+
+static s7_pointer dax_data(s7_scheme *sc, s7_pointer args)
+{
+  dax *o;
+  o = (dax *)s7_c_object_value(s7_car(args));
+  return(o->data);
+}
+
+static s7_pointer set_dax_data(s7_scheme *sc, s7_pointer args)
+{
+  dax *o;
+  o = (dax *)s7_c_object_value(s7_car(args));
+  o->data = s7_cadr(args);
+  return(o->data);
+}
+
+static s7_pointer dax_is_equal(s7_scheme *sc, s7_pointer args) 
+{
+  s7_pointer p1, p2;
+  dax *d1, *d2;
+  p1 = s7_car(args);
+  p2 = s7_cadr(args);
+  if (p1 == p2) 
+    return(s7_t(sc));
+  if ((!s7_is_c_object(p2)) ||
+      (s7_c_object_type(p2) != dax_type_tag))
+    return(s7_f(sc));
+  d1 = (dax *)s7_c_object_value(p1);
+  d2 = (dax *)s7_c_object_value(p2);
+  return(s7_make_boolean(sc,
+			 (d1->x == d2->x) &&
+			 (s7_is_equal(sc, d1->data, d2->data))));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  char buffer[512];
+  char response[1024];
+
+  s7 = s7_init();
+  
+  s7_define_variable(s7, "*listener-prompt*", s7_make_string(s7, ">"));
+
+  dax_type_tag = s7_make_c_type(s7, "dax");
+  s7_c_type_set_gc_free(s7, dax_type_tag, free_dax);
+  s7_c_type_set_gc_mark(s7, dax_type_tag, mark_dax);
+  s7_c_type_set_is_equal(s7, dax_type_tag, dax_is_equal);
+  s7_c_type_set_to_string(s7, dax_type_tag, dax_to_string);
+  
+  s7_define_function(s7, "make-dax", make_dax, 2, 0, false, "(make-dax x data) makes a new dax");
+  s7_define_function(s7, "dax?", is_dax, 1, 0, false, "(dax? anything) returns #t if its argument is a dax object");
+
+  s7_define_variable(s7, "dax-x", 
+                     s7_dilambda(s7, "dax-x", dax_x, 1, 0, set_dax_x, 2, 0, "dax x field"));
+
+  s7_define_variable(s7, "dax-data", 
+                     s7_dilambda(s7, "dax-data", dax_data, 1, 0, set_dax_data, 2, 0, "dax data field"));
+
+  while (1)
+    {
+      fprintf(stdout, "\n%s ", listener_prompt(s7));
+      fgets(buffer, 512, stdin);
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response); /* evaluate input and write the result */
+	}
+    }
+}
+
+/* (in Linux);
+ *    gcc dax.c -o dax -I. -O2 -g s7.o -ldl -lm -Wl,-export-dynamic -Wno-stringop-overflow
+ *    dax
+ *    > *listener-prompt*
+ *    ">"
+ *    > (set! *listener-prompt* ":")
+ *    ":"
+ *    : (define obj (make-dax 1.0 (list 1 2 3)))
+ *    obj
+ *    : obj
+ *    #<dax 1.000 (1 2 3)>
+ *    : (dax-x obj)
+ *    1.0
+ *    : (dax-data obj)
+ *    (1 2 3)
+ *    : (set! (dax-x obj) 123.0)
+ *    123.0
+ *    : obj
+ *    #<dax 123.000 (1 2 3)>
+ *    : (dax? obj)
+ *    #t
+ *    : (exit)
+ */
+
+ + + + + +

Redirect output (and input) to a C procedure

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+static void my_print(s7_scheme *sc, uint8_t c, s7_pointer port)
+{
+  fprintf(stderr, "[%c] ", c);
+}
+
+static s7_pointer my_read(s7_scheme *sc, s7_read_t peek, s7_pointer port)
+{
+  return(s7_make_character(sc, fgetc(stdin)));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  char buffer[512];
+  char response[1024];
+
+  s7 = s7_init();  
+
+  s7_set_current_output_port(s7, s7_open_output_function(s7, my_print));
+  s7_define_variable(s7, "io-port", s7_open_input_function(s7, my_read));
+
+  while (1) 
+    {
+      fprintf(stdout, "\n> ");
+      fgets(buffer, 512, stdin);
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response);
+	}
+    }
+}
+
+/* 
+ *    > (+ 1 2)
+ *    [3]
+ *    > (display "hiho")
+ *    [h] [i] [h] [o] [#] [<] [u] [n] [s] [p] [e] [c] [i] [f] [i] [e] [d] [>] 
+ *    > (define (add1 x) (+ 1 x))
+ *    [a] [d] [d] [1] 
+ *    > (add1 123)
+ *    [1] [2] [4] 
+ *    > (read-char io-port)
+ *    a                             ; here I typed "a" in the shell
+ *    [#] [\] [a] 
+ */
+
+
+ +

In Snd, we want debug.scm (*debug-port*) output to go to the Snd listener text widget. The Snd function listener_append +adds a string to that widget's text, so we define: +

+
static void (listener_write)(s7_scheme *sc, uint8_t c, s7_pointer port)
+{
+  char buf[2];
+  buf[0] = c;
+  buf[1] = '\0';
+  listener_append(buf);
+}
+
+

+Then we define a Scheme-side variable, *listener-port*, to be a function port: +

+
s7_define_variable_with_documentation(s7, "*listener-port*", 
+  s7_open_output_function(s7, listener_write), "port to write to Snd's listener");
+
+

+And tie it into *debug-port* via +(set! ((funclet trace-in) '*debug-port*) *listener-port*). +

+ + + + +

Extend a built-in operator ("+" in this case)

+ +

There are several ways to do this. In the first example, we save the original function, +and replace it with ours, calling the original whenever possible: +

+ +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+static s7_pointer old_add;           /* the original "+" function for non-string cases */
+static s7_pointer old_string_append; /* same, for "string-append" */
+
+static s7_pointer our_add(s7_scheme *sc, s7_pointer args)
+{
+  /* this will replace the built-in "+" operator, extending it to include strings:
+   *   (+ "hi" "ho") -> "hiho" and  (+ 3 4) -> 7
+   */
+  if ((s7_is_pair(args)) &&
+      (s7_is_string(s7_car(args))))
+    return(s7_apply_function(sc, old_string_append, args));
+  return(s7_apply_function(sc, old_add, args));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  char buffer[512];
+  char response[1024];
+  s7 = s7_init();
+
+  /* get built-in + and string-append */
+  old_add = s7_name_to_value(s7, "+");      
+  old_string_append = s7_name_to_value(s7, "string-append");
+
+  /* redefine "+" */
+  s7_define_function(s7, "+", our_add, 0, 0, true, "(+ ...) adds or appends its arguments");
+
+  while (1)
+    {
+      fprintf(stdout, "\n> ");
+      fgets(buffer, 512, stdin);
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response);
+	}
+    }
+}
+
+/*    > (+ 1 2)
+ *    3
+ *    > (+ "hi" "ho")
+ *    "hiho"
+ */
+
+ +

In the next example, we use the method (inlet) machinery: +

+ +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <math.h>
+
+#include "s7.h"
+
+static s7_pointer our_abs(s7_scheme *sc, s7_pointer args)
+{
+  s7_pointer x;
+  x = s7_car(args);
+  if (!s7_is_number(x))
+    {
+      s7_pointer method;
+      method = s7_method(sc, x, s7_make_symbol(sc, "abs"));
+      if (method == s7_undefined(sc))                       /* no method found, so raise an error */
+	s7_wrong_type_arg_error(sc, "abs", 1, x, "a real"); 
+      return(s7_apply_function(sc, method, args));          /*   else apply the method to the args */
+    }
+  return(s7_make_real(sc, (s7_double)fabs(s7_number_to_real(sc, x))));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  char buffer[512];
+  char response[1024];
+
+  s7 = s7_init();
+  s7_define_function(s7, "our-abs", our_abs, 1, 0, false, "abs replacement");
+
+  while (1)
+    {
+      fprintf(stdout, "\n> ");
+      fgets(buffer, 512, stdin);
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response);
+	}
+    }
+}
+
+/*    > (our-abs -1)
+ *    1.0
+ *    > (our-abs (openlet (inlet 'value -3.0 'abs (lambda (x) (abs (x 'value))))))
+ *    3.0
+ */
+
+
+
+ + + +

C-side define* (s7_define_function_star)

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+static s7_pointer plus(s7_scheme *sc, s7_pointer args)
+{
+  /* (define* (plus (red 32) blue) (+ (* 2 red) blue)) */
+  return(s7_make_integer(sc, 2 * s7_integer(s7_car(args)) + s7_integer(s7_cadr(args))));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  char buffer[512];
+  char response[1024];
+
+  s7 = s7_init();
+  s7_define_function_star(s7, "plus", plus, "(red 32) blue", "an example of define* from C");
+
+  while (1)
+    {
+      fprintf(stdout, "\n> ");
+      fgets(buffer, 512, stdin);
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response);
+	}
+    }
+}
+
+/* 
+ *    > (plus 2 3)
+ *    7
+ *    > (plus :blue 3)
+ *    67
+ *    > (plus :blue 1 :red 4)
+ *    9
+ *    > (plus 2 :blue 3)
+ *    7
+ *    > (plus :blue 3 :red 1)
+ *    5
+ */
+
+ + + + + +

C-side define-macro (s7_define_macro)

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+static s7_pointer plus(s7_scheme *sc, s7_pointer args)
+{
+  /* (define-macro (plus a b) `(+ ,a ,b)) */
+  s7_pointer a, b;
+  a = s7_car(args);
+  b = s7_cadr(args);
+  return(s7_list(sc, 3, s7_make_symbol(sc, "+"),  a, b));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  char buffer[512];
+  char response[1024];
+
+  s7 = s7_init();
+  s7_define_macro(s7, "plus", plus, 2, 0, false, "plus adds its two arguments");
+
+  while (1)
+    {
+      fprintf(stdout, "\n> ");
+      fgets(buffer, 512, stdin);
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response);
+	}
+    }
+}
+
+/* 
+ *    > (plus 2 3)
+ *    5
+ */
+
+ + + +

define a generic function in C

+ +

In scheme, a function becomes generic simply by (apply ((car args) 'func) args). +To accomplish the same thing in C, we use s7_method and s7_apply_function: +

+ +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+static s7_pointer plus(s7_scheme *sc, s7_pointer args)
+{
+  #define plus_help "(plus obj ...) applies obj's plus method to obj and any trailing arguments."
+  s7_pointer obj, method;
+  obj = s7_car(args);
+  method = s7_method(sc, obj, s7_make_symbol(sc, "plus"));
+  if (s7_is_procedure(method))
+    return(s7_apply_function(sc, method, args));
+  return(s7_f(sc));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  s7 = s7_init();
+  s7_define_function(s7, "plus", plus, 1, 0, true, plus_help);
+  while (1)
+    {
+      char buffer[512];
+      char response[1024];
+      fprintf(stdout, "\n> ");
+      fgets(buffer, 512, stdin);
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response);
+	}
+    }
+}
+
+/* gcc -c s7.c -I.
+ * gcc -o ex15 ex15.c s7.o -I. -lm -ldl
+ *
+ *     > (plus 1 2)
+ *     #f
+ *     > (define obj (openlet (inlet 'plus (lambda args (apply + 1 (cdr args))))))
+ *     obj
+ *     > (plus obj 2 3)
+ *     6
+ */
+
+
+ + + +

Signal handling and continuations

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+#include <signal.h>
+
+#include "s7.h"
+
+static s7_scheme *s7;
+struct sigaction new_act, old_act;  
+  
+static void handle_sigint(int ignored)  
+{  
+  fprintf(stderr, "interrupted!\n");
+  s7_symbol_set_value(s7, s7_make_symbol(s7, "*interrupt*"), s7_make_continuation(s7)); /* save where we were interrupted */
+  sigaction(SIGINT, &new_act, NULL);  
+  s7_quit(s7);                             /* get out of the eval loop if possible */
+}  
+
+static s7_pointer our_sleep(s7_scheme *sc, s7_pointer args)
+{
+  /* slow down our infinite loop for demo purposes */
+  sleep(1);
+  return(s7_f(sc));
+}
+
+int main(int argc, char **argv)
+{
+  char buffer[512];
+  char response[1024];
+
+  s7 = s7_init();
+  s7_define_function(s7, "sleep", our_sleep, 0, 0, false, "(sleep) sleeps");
+  s7_define_variable(s7, "*interrupt*", s7_f(s7)); 
+  /* Scheme variable *interrupt* holds the continuation at the point of the interrupt */
+
+  sigaction(SIGINT, NULL, &old_act);
+  if (old_act.sa_handler != SIG_IGN)
+    {
+      memset(&new_act, 0, sizeof(new_act));  
+      new_act.sa_handler = &handle_sigint;  
+      sigaction(SIGINT, &new_act, NULL);  
+    }
+
+  while (1)
+    {
+      fprintf(stderr, "\n> ");
+      fgets(buffer, 512, stdin);
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response);
+	}
+    }
+}
+
+/*
+ *    > (do ((i 0 (+ i 1))) ((= i -1)) (format () "~D " i) (sleep))
+ *      ;;; now type C-C to break out of this loop
+ *    0 1 2 ^Cinterrupted!
+ *      ;;; call the continuation to continue from where we were interrupted
+ *    > (*interrupt*)
+ *    3 4 5 ^Cinterrupted!
+ *    > *interrupt*
+ *    #<continuation>
+ *    > (+ 1 2)
+ *    3
+ */
+
+ + + +

Notification from Scheme that a given Scheme variable has been set

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+static s7_pointer scheme_set_notification(s7_scheme *sc, s7_pointer args)
+{
+  /* this function is called when the Scheme variable is set! */
+  fprintf(stderr, "%s set to %s\n",
+	  s7_object_to_c_string(sc, s7_car(args)),
+	  s7_object_to_c_string(sc, s7_cadr(args)));
+  return(s7_cadr(args));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  s7 = s7_init();  
+
+  s7_define_function(s7, "notify-C", scheme_set_notification, 2, 0, false, "called if notified-var is set!");
+  s7_define_variable(s7, "notified-var", s7_make_integer(s7, 0));
+  s7_set_setter(s7, s7_make_symbol(s7, "notified-var"), s7_name_to_value(s7, "notify-C"));
+
+  if (argc == 2)
+    {
+      fprintf(stderr, "load %s\n", argv[1]);
+      if (!s7_load(s7, argv[1]))
+        fprintf(stderr, "can't find %s\n", argv[1]);
+    }
+  else
+    {
+      char buffer[512];
+      char response[1024];
+      while (1) 
+	{
+	  fprintf(stdout, "\n> ");
+	  fgets(buffer, 512, stdin);
+	  
+	  if ((buffer[0] != '\n') || 
+	      (strlen(buffer) > 1))
+	    {                            
+	      snprintf(response, 1024, "(write %s)", buffer);
+	      s7_eval_c_string(s7, response);
+	    }
+	}
+    }
+}
+
+/*    > notified-var
+ *    0
+ *    > (set! notified-var 32)
+ *    notified-var set to 32
+ *    32
+ */
+
+ + + + + +

Load C defined stuff into a separate namespace

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+static s7_pointer func1(s7_scheme *sc, s7_pointer args)
+{
+  return(s7_make_integer(sc, s7_integer(s7_car(args)) + 1));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  s7_pointer new_env;
+
+  s7 = s7_init();  
+
+  /* "func1" and "var1" will be placed in an anonymous environment,
+   *   accessible from Scheme via the global variable "lib-exports"
+   */
+  
+  new_env = s7_inlet(s7, s7_curlet(s7), s7_nil(s7));
+  /* make a private environment for func1 and var1 below (this is our "namespace") */
+  s7_gc_protect(s7, new_env);
+
+  s7_define(s7, new_env, 
+	    s7_make_symbol(s7, "func1"),
+	    s7_make_function(s7, "func1", func1, 1, 0, false, "func1 adds 1 to its argument"));
+  
+  s7_define(s7, new_env, s7_make_symbol(s7, "var1"), s7_make_integer(s7, 32));
+  /* those two symbols are now defined in the new environment */
+
+  /* add "lib-exports" to the global environment */
+  s7_define_variable(s7, "lib-exports", s7_let_to_list(s7, new_env));
+
+  if (argc == 2)
+    {
+      fprintf(stderr, "load %s\n", argv[1]);
+      if (!s7_load(s7, argv[1]))
+        fprintf(stderr, "can't find %s\n", argv[1]);
+    }
+  else
+    {
+      char buffer[512];
+      char response[1024];
+      while (1) 
+	{
+	  fprintf(stdout, "\n> ");
+	  fgets(buffer, 512, stdin);
+	  
+	  if ((buffer[0] != '\n') || 
+	      (strlen(buffer) > 1))
+	    {                            
+	      snprintf(response, 1024, "(write %s)", buffer);
+	      s7_eval_c_string(s7, response);
+	    }
+	}
+    }
+}
+
+/*     > func1
+ *     ;func1: unbound variable, line 1
+ *     > lib-exports
+ *     ((var1 . 32) (func1 . func1))
+ *     ;; so lib-exports has the C-defined names and values
+ *     ;; we can use these directly:
+ *
+ *     > (define lib-env (apply sublet (curlet) lib-exports))
+ *     lib-env
+ *     > (with-let lib-env (func1 var1))
+ *     33
+ *
+ *     ;; or rename them to prepend "lib:"
+ *     > (define lib-env (apply sublet 
+                                (curlet) 
+                                (map (lambda (binding) 
+                                       (cons (string->symbol 
+                                               (string-append "lib:" (symbol->string (car binding)))) 
+                                             (cdr binding))) 
+                                     lib-exports)))
+ *     lib-env
+ *     > (with-let lib-env (lib:func1 lib:var1))
+ *     33
+ *
+ *     ;;; now for convenience, place "func1" in the global environment under the name "func2"
+ *     > (define func2 (cdadr lib-exports)) 
+ *     func2
+ *     > (func2 1)  
+ *     2
+ */
+
+ + + + + +

Handle scheme errors in C

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+static s7_pointer error_handler(s7_scheme *sc, s7_pointer args)
+{
+  fprintf(stdout, "error: %s\n", s7_string(s7_car(args)));
+  return(s7_f(sc));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  char buffer[512];
+  char response[1024];
+  bool with_error_hook = false;
+
+  s7 = s7_init();  
+  s7_define_function(s7, "error-handler", error_handler, 1, 0, false, "our error handler");
+
+  if (with_error_hook)
+    s7_eval_c_string(s7, "(set! (hook-functions *error-hook*)                    \n\
+                            (list (lambda (hook)                                 \n\
+                                    (error-handler                               \n\
+                                      (apply format #f (hook 'data)))            \n\
+                                    (set! (hook 'result) 'our-error))))");
+  while (1) 
+    {
+      fprintf(stdout, "\n> ");
+      fgets(buffer, 512, stdin);
+	  
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  s7_pointer old_port, result;
+	  int gc_loc = -1;
+	  const char *errmsg = NULL;
+
+	  /* trap error messages */
+	  old_port = s7_set_current_error_port(s7, s7_open_output_string(s7));
+	  if (old_port != s7_nil(s7))
+	    gc_loc = s7_gc_protect(s7, old_port);
+
+	  /* evaluate the input string */
+	  result = s7_eval_c_string(s7, buffer);
+
+	  /* print out the value wrapped in "{}" so we can tell it from other IO paths */
+	  fprintf(stdout, "{%s}", s7_object_to_c_string(s7, result));
+
+	  /* look for error messages */
+	  errmsg = s7_get_output_string(s7, s7_current_error_port(s7));
+
+	  /* if we got something, wrap it in "[]" */
+	  if ((errmsg) && (*errmsg))
+	    fprintf(stdout, "[%s]", errmsg); 
+
+	  s7_close_output_port(s7, s7_current_error_port(s7));
+	  s7_set_current_error_port(s7, old_port);
+	  if (gc_loc != -1)
+	    s7_gc_unprotect_at(s7, gc_loc);
+	}
+    }
+}
+
+/* 
+ *   gcc -c s7.c -I. -g3
+ *   gcc -o ex3 ex3.c s7.o -lm -I. -ldl
+ *
+ * if with_error_hook is false,
+ *
+ *   > (+ 1 2)
+ *   {3}
+ *   > (+ 1 #\c)
+ *   {wrong-type-arg}[
+ *   ;+ argument 2, #\c, is character but should be a number, line 1
+ *   ]
+ *
+ * so s7 by default prepends ";" to the error message, and appends "\n",
+ *   sending that to current-error-port, and the error type ('wrong-type-arg here)
+ *   is returned.
+ *
+ * if with_error_hook is true,
+ *
+ *   > (+ 1 2)
+ *   {3}
+ *   > (+ 1 #\c)
+ *   error: + argument 2, #\c, is character but should be a number
+ *   {our-error}
+ *
+ * so now the *error-hook* code handles both the error reporting and
+ *   the value returned ('our-error in this case).
+ */
+
+ + + +

C and Scheme hooks

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+static s7_pointer my_hook_function(s7_scheme *sc, s7_pointer args)
+{
+  fprintf(stderr, "a is %s\n", s7_object_to_c_string(sc, s7_symbol_local_value(sc, s7_make_symbol(sc, "a"), s7_car(args))));
+  return(s7_car(args));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  char buffer[512];
+  char response[1024];
+  s7_pointer test_hook;
+
+  s7 = s7_init();  
+
+  /* define test_hook in C, test-hook in Scheme, arguments are named a and b */
+  test_hook = s7_eval_c_string(s7, "(make-hook 'a 'b)");
+  s7_define_constant(s7, "test-hook", test_hook); 
+
+  /* add my_hook_function to the test_hook function list */
+  s7_hook_set_functions(s7, test_hook, 
+			s7_cons(s7, 
+				s7_make_function(s7, "my-hook-function", my_hook_function, 1, 0, false, "my hook-function"), 
+				s7_hook_functions(s7, test_hook)));
+  while (1) 
+    {
+      fprintf(stdout, "\n> ");
+      fgets(buffer, 512, stdin);
+	  
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response);
+	}
+    }
+}
+
+/* 
+ *    > test-hook
+ *    #<lambda (hook)>
+ *    > (hook-functions test-hook)
+ *    (my-hook-function)
+ *    > (test-hook 1 2)
+ *    a is 1
+ *    #<unspecified>
+ */
+
+ + + + + +

Load a shared library

+ +

We can use dlopen to load a shared library, and dlsym to initialize +that library in our main program. The tricky part is to conjure up the right +compiler and loader flags. +First we define a module that defines a new s7 function, add-1 that we'll tie +into s7 explicitly, and another +function that we'll try to call by waving a wand. +

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+
+double a_function(double an_arg);
+double a_function(double an_arg)
+{
+  return(an_arg + 1.0);
+}
+
+static s7_pointer add_1(s7_scheme *sc, s7_pointer args) 
+{
+  return(s7_make_integer(sc, s7_integer(s7_car(args)) + 1)); 
+}
+
+void init_ex(s7_scheme *sc);
+void init_ex(s7_scheme *sc)  /* this needs to be globally accessible (not "static") */
+{
+  /* tell s7 about add-1, but leave a_function hidden */
+  s7_define_function(sc, "add-1", add_1, 1, 0, false, "(add-1 x) adds 1 to x");
+}
+
+
+ + +

And here is our main program: +

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include "s7.h"
+#include <dlfcn.h>
+
+static void *library = NULL;
+
+static s7_pointer try(s7_scheme *sc, s7_pointer args)
+{
+  /* try tries to call an arbitrary function in the shared library */
+  void *func;
+  func = dlsym(library, s7_string(s7_car(args)));
+  if (func)
+    {
+      /* we'll assume double f(double) */
+      typedef double (*dl_func)(double arg);
+      return(s7_make_real(sc, ((dl_func)func)(s7_real(s7_cadr(args)))));
+    }
+  return(s7_error(sc, s7_make_symbol(sc, "can't find function"), 
+		  s7_list(sc, 2, s7_make_string(sc, "loader error: ~S"), 
+			         s7_make_string(sc, dlerror()))));
+}
+
+static s7_pointer cload(s7_scheme *sc, s7_pointer args)
+{
+  /* cload loads a shared library */
+  #define CLOAD_HELP "(cload so-file-name) loads the module"
+  library = dlopen(s7_string(s7_car(args)), RTLD_LAZY);
+  if (library)
+    {
+      /* call our init func to define add-1 in s7 */
+      void *init_func;
+      init_func = dlsym(library, s7_string(s7_cadr(args)));
+      if (init_func)
+	{
+	  typedef void *(*dl_func)(s7_scheme *sc);
+	  ((dl_func)init_func)(sc);  /* call the initialization function (init_ex above) */
+	  return(s7_t(sc));
+	}
+    }
+  return(s7_error(sc, s7_make_symbol(sc, "load-error"), 
+		      s7_list(sc, 2, s7_make_string(sc, "loader error: ~S"), 
+			             s7_make_string(sc, dlerror()))));
+}
+
+int main(int argc, char **argv)
+{
+  char buffer[512];
+  char response[1024];
+  s7_scheme *s7;
+
+  s7 = s7_init();  
+
+  s7_define_function(s7, "cload", cload, 2, 0, false, CLOAD_HELP);
+  s7_define_function(s7, "try", try, 2, 0, false, 
+                         "(try name num) tries to call name in the shared library with the argument num.");
+
+  while (1) 
+    {
+      fprintf(stdout, "\n> ");
+      fgets(buffer, 512, stdin);
+	  
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response);
+	}
+    }
+}
+
+/* Put the module in the file ex3a.c and the main program in ex3.c, then
+ *
+ * in Linux:
+ *   gcc -c -fPIC ex3a.c
+ *   gcc ex3a.o -shared -o ex3a.so
+ *   gcc -c s7.c -I. -fPIC -shared
+ *   gcc -o ex3 ex3.c s7.o -lm -ldl -I. -Wl,-export-dynamic
+ *   # omit -ldl in freeBSD, openBSD might want -ftrampolines
+ *
+ * in Mac OSX:
+ *   gcc -c ex3a.c
+ *   gcc ex3a.o -o ex3a.so -dynamic -bundle -undefined suppress -flat_namespace
+ *   gcc -c s7.c -I. -dynamic -bundle -undefined suppress -flat_namespace
+ *   gcc -o ex3 ex3.c s7.o -lm -ldl -I.
+ *
+ * and run it:
+ *   ex3
+ *   > (cload "/home/bil/snd-18/ex3a.so" "init_ex")
+ *   #t
+ *   > (add-1 2)
+ *   3
+ *   > (try "a_function" 2.5)
+ *   3.5
+ */
+
+ +

All of this is just boring boilerplate, so with a little support from s7, +we can write a script to do the entire linkage. The s7 side is an extension +to "load" that loads a shared object file if its extension is "so", and +runs an initialization function whose name is defined in the load +environment (the optional second argument to load). An example of the scheme side is cload.scm, +included in the s7 tarball. It defines a function that can be +called: +

+ +
(c-define '(double j0 (double)) "m" "math.h")
+
+ +

This links the s7 function m:j0 to the math library +function j0. See cload.scm for more details. +

+ + +

Here's a shorter example: +

+
+
add1.c:
+
+#include <stdlib.h>
+#include "s7.h"
+
+static s7_pointer add1(s7_scheme *sc, s7_pointer args)
+{
+  if (s7_is_integer(s7_car(args)))
+    return(s7_make_integer(sc, 1 + s7_integer(s7_car(args))));
+  return(s7_wrong_type_arg_error(sc, "add1", 1, s7_car(args), "an integer"));
+}
+
+void add1_init(s7_scheme *sc);
+void add1_init(s7_scheme *sc)
+{
+  s7_define_function(sc, "add1", add1, 1, 0, false, "(add1 int) adds 1 to int");
+}
+
+/* gcc -fpic -c add1.c
+ * gcc -shared -Wl,-soname,libadd1.so -o libadd1.so add1.o -lm -lc
+ * gcc s7.c -o repl -fpic -DWITH_MAIN -I. -ldl -lm -Wl,-export-dynamic -DUSE_SND=0
+ * repl
+ *   (load "libadd1.so" (inlet 'init_func 'add1_init))
+ *   (add1 2)
+ */
+
+
+ + + +

Bignums in C

+ +

Bignum support depends on gmp, mpfr, and mpc. In this example, we define "add-1" which adds +1 to any kind of number. The s7_big_* functions return the underlying gmp/mpfr/mpc pointer. +

+ + +
+
#include <stdlib.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <gmp.h>
+#include <mpfr.h>
+#include <mpc.h>
+
+#include "s7.h"
+
+static s7_pointer big_add_1(s7_scheme *sc, s7_pointer args)
+{
+  /* add 1 to either a normal number or a bignum */
+  s7_pointer x, n;
+  x = s7_car(args);
+  if (s7_is_big_integer(x))
+    {
+      mpz_t big_n;
+      mpz_init_set(big_n, *s7_big_integer(x));
+      mpz_add_ui(big_n, big_n, 1);
+      n = s7_make_big_integer(sc, &big_n);
+      mpz_clear(big_n);
+      return(n);
+    }
+  if (s7_is_big_ratio(x))
+    {
+      mpq_t big_q;
+      mpq_init(big_q);
+      mpq_set_si(big_q, 1, 1);
+      mpq_add(big_q, *s7_big_ratio(x), big_q);
+      mpq_canonicalize(big_q);
+      n = s7_make_big_ratio(sc, &big_q);
+      mpq_clear(big_q);
+      return(n);
+    }
+  if (s7_is_big_real(x))
+    {
+      mpfr_t big_x;
+      mpfr_init_set(big_x, *s7_big_real(x), MPFR_RNDN);
+      mpfr_add_ui(big_x, big_x, 1, MPFR_RNDN);
+      n = s7_make_big_real(sc, &big_x);
+      mpfr_clear(big_x);
+      return(n);
+    }
+  if (s7_is_big_complex(x))
+    {
+      mpc_t big_z;
+      mpc_init2(big_z, mpc_get_prec(*s7_big_complex(x)));
+      mpc_add_ui(big_z, *s7_big_complex(x), 1, MPC_RNDNN);
+      n = s7_make_big_complex(sc, &big_z);
+      mpc_clear(big_z);
+      return(n);
+    }
+  if (s7_is_integer(x))
+    return(s7_make_integer(sc, 1 + s7_integer(x)));
+  if (s7_is_rational(x))
+    return(s7_make_ratio(sc, s7_numerator(x) + s7_denominator(x), s7_denominator(x)));
+  if (s7_is_real(x))
+    return(s7_make_real(sc, 1.0 + s7_real(x)));
+  if (s7_is_complex(x))
+    return(s7_make_complex(sc, 1.0 + s7_real_part(x), s7_imag_part(x)));
+  return(s7_wrong_type_arg_error(sc, "add-1", 0, x, "a number"));
+}
+
+int main(int argc, char **argv)
+{
+  s7_scheme *s7;
+  char buffer[512];
+  char response[1024];
+
+  s7 = s7_init();  
+  s7_define_function(s7, "add-1", big_add_1, 1, 0, false, "(add-1 num) adds 1 to num");
+
+  while (1) 
+    {
+      fprintf(stdout, "\n> ");
+      fgets(buffer, 512, stdin);
+      if ((buffer[0] != '\n') || 
+	  (strlen(buffer) > 1))
+	{                            
+	  snprintf(response, 1024, "(write %s)", buffer);
+	  s7_eval_c_string(s7, response);
+	}
+    }
+}
+
+/* 
+ *   gcc -DWITH_GMP=1 -c s7.c -I. -O2 -g3
+ *   gcc -DWITH_GMP=1 -o gmpex gmpex.c s7.o -I. -O2 -lm -ldl -lgmp -lmpfr -lmpc
+ *
+ *   gmpex
+ *   > (add-1 1)   
+ *   2
+ *   > (add-1 2/3)
+ *   5/3
+ *   > (add-1 1.4) 
+ *   2.4
+ *   > (add-1 1.5+i)
+ *   2.5+1i
+ *   > (add-1 (bignum 3))
+ *   4
+ *   > (add-1 (bignum 3/4))
+ *   7/4
+ *   > (add-1 (bignum 2.5))
+ *   3.500E0
+ *   > (add-1 (bignum 1.5+i))
+ *   2.500E0+1.000E0i
+ */
+
+
+ + +

To tie mpfr's bessel-j0 into s7 at run-time: +

+ +
+
/* libgmp_s7.c */
+
+#include <gmp.h>
+#include <mpfr.h>
+#include <mpc.h>
+
+#define WITH_GMP 1
+#include "s7.h"
+
+static s7_pointer gmp_bessel_j0(s7_scheme *sc, s7_pointer args)
+{
+  s7_pointer x, result;
+  mpfr_t mp;
+
+  mpfr_init2(mp, s7_integer(s7_let_field_ref(sc, s7_make_symbol(sc, "bignum-precision"))));
+  /* initialize the mpfr variable mp to the current s7 bignum-precision */
+
+  x = s7_car(args);
+  if (s7_is_big_real(x))
+    mpfr_j0(mp, *s7_big_real(x), MPFR_RNDN);
+  else
+    {
+      if (s7_is_real(x))
+	{
+	  mpfr_set_d(mp, s7_real(x), MPFR_RNDN);
+	  mpfr_j0(mp, mp, MPFR_RNDN);
+	}
+      else return(s7_wrong_type_arg_error(sc, "gmp_bessel_j0", 1, x, "real"));
+    }
+
+  result = s7_make_big_real(sc, &mp);
+  mpfr_clear(mp);
+  return(result);
+}
+
+void libgmp_s7_init(s7_scheme *sc);
+void libgmp_s7_init(s7_scheme *sc)
+{
+  s7_define_function(sc, "bessel-j0", gmp_bessel_j0, 1, 0, false, "(bessel-j0 x) returns j0(x)");
+}
+
+
+ +

libarb_s7.c provides some extensions of the multiprecision math: Bessel functions and the like. It is based on +the Flint and Arb libraries, flintlib.org and arblib.org. In Linux: +

+ +
gcc -fPIC -c libarb_s7.c
+gcc libarb_s7.o -shared -o libarb_s7.so -lflint -larb
+repl
+  > (load "libarb_s7.so" (inlet 'init_func 'libarb_s7_init))
+  #f
+  > (acb_bessel_j 0 1.0)
+  7.651976865579665514497175261026632209096E-1
+
+ + + +

gdb

+ +

+gdbinit has some debugging commands, intended for your ~/.gdbinit file. +

+ +
s7print interprets its argument as an s7 value and displays it
+s7eval evals its argument (a string)
+s7stack displays the current s7 stack (nested lets)
+s7value prints the value of the variable passed by its print name: s7v "*features*"
+s7let shows all non-global variables that are currently accessible
+s7history shows the history entries (if enabled)
+
+ +

gdbinit also has two backtrace +decoders: s7bt and s7btfull. The bt replacements print the gdb backtrace info, +replacing bare pointer numbers with their s7 value, wherever possible: +

+ +
(gdb) s7bt
+#0  0x000055555567f7ca in check_cell (p=#<lambda (lst ind)>, 
+    func=0x5555559106e0 <__FUNCTION__.10273> "mark_slot", line=3976) at s7.c:28494
+#1  0x000055555567f84d in check_nref (p=#<lambda (lst ind)>, 
+    func=0x5555559106e0 <__FUNCTION__.10273> "mark_slot", line=3976) at s7.c:28507
+#2  0x0000555555563201 in mark_slot (p='list-ref #<lambda (lst ind)>) at s7.c:3976
+#3  0x0000555555564ce0 in mark_let (env=#<mock-number-class>) at s7.c:4506
+#4  0x0000555555563239 in mark_slot (p='mock-number-class #<mock-number-class>) at s7.c:3976
+#5  0x0000555555564ce0 in mark_let (env=(inlet 'mock-number-class #<mock-number-class> 'mock-number mock-number)) at s7.c:4506
+#6  0x0000555555563239 in mark_slot (p='*mock-number* (inlet 'mock-number-class #<mock-number-class> 'mock-number...)) at s7.c:3976
+#7  0x0000555555564ce0 in mark_let (env=(inlet '*features* (mockery.scm stuff.scm linux autoload dlopen...))) at s7.c:4506
+#8  0x0000555555565697 in mark_closure (p=reactive-vector) at s7.c:4590
+#9  0x0000555555566872 in mark_rootlet (sc=0x555555b41eb0) at s7.c:4813
+#10 0x0000555555566a2f in gc (sc=0x555555b41eb0) at s7.c:4897
+#11 0x000055555558e903 in copy_stack (sc=0x555555b41eb0, old_v=[sc->stack] #<stack>) at s7.c:9024
+
+ + + + +

FFI notes

+ + + +
Errors
+ +

Most of the s7.h functions do little, if any, error checking. s7_car, for example, +does not check that its argument is a pair. Partly this is a matter of speed; partly +of simplicity. If we had elaborate error checks, we'd need some convention +for passing error information back to the caller, and of course separate versions +of each function for cases where all those checks are redundant. You can easily +make your own C version of s7_car that includes error checks: +

+
static s7_pointer my_car(s7_scheme *sc, s7_pointer lst)
+{
+  if (s7_is_pair(lst))
+    return(s7_car(lst));
+  return(s7_wrong_type_arg_error(sc, "my_car", 0, "a pair"));
+}
+
+ +

The s7.h error functions are: +

+ +
s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info);
+
+s7_pointer s7_wrong_type_arg_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr);
+s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr);
+s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args);
+
+s7_pointer s7_current_error_port(s7_scheme *sc);
+s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port);
+
+ +

s7_error is equivalent to the scheme error function, and like the latter, it takes two arguments: +a symbol giving the error type, and a list giving the error data. In s7, all of the data lists +are organized so that you can (apply format #f data) to get an error string. +If you're using catch to handle errors, the error type is what catch looks for. So, the +s7_wrong_type_arg call above could be: +

+
s7_error(sc, s7_make_symbol(sc, "wrong-type-arg"), 
+             s7_list(sc, 3, s7_make_string(sc, "~S is a ~S, but should be a pair"), 
+                            s7_car(lst), 
+                            s7_type_of(sc, s7_car(lst))));
+
+

s7_wrong_type_arg_error takes the name of the caller, the argument number, the argument itself, +and a description of the type expected. If the argument number is 0, that info is left out of the +error message (that is, the caller takes only one argument). s7_out_of_range_error is similar. +s7_wrong_number_of_args_error takes the caller's name and the offending arg list. The corresponding +error types are 'wrong-type-arg, 'wrong-number-of-args, and 'out-of-range. +

+ +

Normally, s7_error sends its error message +to the current error-port which defaults to stderr. In GUI-based apps, +you may need to redirect the output to your interface. One method, +used in Snd's snd-motif.c, captures the error output in an output string: +

+
old_port = s7_set_current_error_port(s7, s7_open_output_string(s7));
+...
+result = s7_eval_c_string(s7, text);
+errmsg = s7_get_output_string(s7, s7_current_error_port(s7));
+s7_close_output_port(s7, s7_current_error_port(s7));
+s7_set_current_error_port(s7, old_port);
+...
+
+

and if errmsg is not NULL, it posts it somewhere. +(You'll also want to GC-protect the old port while it is idle). +If you don't want catch or s7's error messages, you can go down +a level via *error-hook*. +

+

s7_error does not return; its s7_pointer return type is just a convenience. It unwinds the +scheme stack, closing files, handling dynamic-winds, looking for a catch that matches its type argument +and so on, then longjmps to unwind the C stack. If a catch is found, its error handler becomes the new point +of execution. +

+ + +
GC protection
+ +

If you save an s7_pointer value in C, you may need to protect it from the garbage collector. In the example above, +the first "..." is: +

+
gc_loc = s7_gc_protect(s7, old_port);
+
+

where gc_loc is (or should be) an s7_int. Since we're subsequently +calling s7_eval_c_string, we need to GC protect old_port beforehand. After the evaluation, +

+
s7_close_output_port(s7, s7_current_error_port(s7));
+s7_set_current_error_port(s7, old_port);
+s7_gc_unprotect_at(s7, gc_loc);
+
+

The full set of GC protection functions is: +

+
s7_int s7_gc_protect(s7_scheme *sc, s7_pointer x);
+void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc);
+s7_pointer s7_gc_protected_at(s7_scheme *sc, s7_int loc);
+
+s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x);
+s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x);
+
+s7_pointer s7_gc_protect_via_location(s7_scheme *sc, s7_pointer x, s7_int loc);
+s7_pointer s7_gc_unprotect_via_location(s7_scheme *sc, s7_int loc);
+
+s7_pointer s7_gc_on(s7_scheme *sc, bool on);
+
+ +

If you create an s7 object in C, that object +needs to be +GC protected if there is any chance the GC might run without +an existing Scheme-level reference to it. s7_gc_protect places the +object in a vector that the GC always checks, returning the object's location +in that table. s7_gc_unprotect_at unprotects the object (removes it from the +vector) using the location passed to it. s7_gc_protected_at returns the object +at the given location. +There is a built-in lag between the creation of a new object and its first possible GC +(the lag time is set indirectly by GC_TEMPS_SIZE in s7.c), so you don't need to worry about +very short term temps such as the arguments to s7_cons in: +

+
s7_cons(s7, s7_make_real(s7, 3.14), 
+            s7_cons(s7, s7_make_integer(s7, 123), s7_nil(s7)));
+
+

The protect_via_stack functions place the object on the s7 stack where it is +protected until the stack unwinds past that point. Besides speed, this provides +a way to be sure an object is unprotected even in some complicated situation where +error handling may bypass an explicit s7_gc_unprotect_at call. +The protect_via_location are intended for cases where you have a location already +(from s7_gc_protect), and want to reuse it for a different object. +s7_gc_on turns the GC on or off. Objects can be created at a blistering pace, +so don't leave the GC off for a long time! +

+ +
Load
+ +
s7_pointer s7_load(s7_scheme *sc, const char *file);
+s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e);
+s7_pointer s7_load_c_string(s7_scheme *sc, const char *content, s7_int bytes);
+s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer e);
+s7_pointer s7_load_path(s7_scheme *sc);
+s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir);
+s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_function);
+void s7_autoload_set_names(s7_scheme *sc, const char **names, s7_int size); snd-xref.c
+
+

s7_load is similar to the scheme-side load function. Its argument is + a file name, and optionally (via s7_load_with_environment) an +environment +in which to place top-level objects. Normally the file contains scheme +code, but if WITH_C_LOADER is set when s7 is built, you can +also load shared-object files. If you load a shared-object file (a +dynamically loadable library), the environment argument +provides a way to pass in the initialization function (named +'init_func). For example, the repl in s7.c needs access to +libc's tcsetattr, so it looks for libc_s7.so (created by libc.scm). If +found, +

+
  s7_load_with_environment(sc, "libc_s7.so", 
+    s7_inlet(sc, s7_list(sc, 2, s7_make_symbol(sc, "init_func"), 
+                                s7_make_symbol(sc, "libc_s7_init")));
+
+

You can also include an 'init_args field to pass arguments to init_func. Here's an example that +includes init_args: +

+
/* tlib.c */
+#include <stdio.h>
+#include <stdlib.h>
+#include "s7.h"
+
+static s7_pointer a_function(s7_scheme *sc, s7_pointer args)
+{
+  return(s7_car(args));
+}
+
+s7_pointer tlib_init(s7_scheme *sc, s7_pointer args); /* void tlib_init(s7_scheme *sc) if no init_args */
+s7_pointer tlib_init(s7_scheme *sc, s7_pointer args)
+{
+  fprintf(stderr, "tlib_init: %s\n", s7_object_to_c_string(sc, args));
+  s7_define_function(sc, "a-function", a_function, 1, 0, true, "");
+  return(s7_car(args));
+}
+
+/* in Linux:
+   gcc -fPIC -c tlib.c
+   gcc tlib.o -shared -o tlib.so -ldl -lm -Wl,-export-dynamic
+
+   /home/bil/cl/ repl
+   <1> (load "tlib.so" (inlet 'init_func 'tlib_init 'init_args (list 1 2 3)))
+   tlib_init: (1 2 3)
+   1
+   <2> (a-function 1 2 3)
+   1
+*/
+
+

+s7_load returns the last value produced during the load; so given "test.scm" with the contents: +

+
define (f x) (+ x 1)) 
+32
+
+

when we call s7_load:

+
s7_pointer val;
+val = s7_load_with_environment(sc, "test.scm", s7_curlet(sc));
+
+

val is set to 32 (as a scheme object), and f is placed in the current environment. +If "test.scm" is not in the current directory, s7 looks at the entries in its *load-path* variable, +trying each in turn until it finds the file. If it fails, it returns NULL. +s7_load_path returns this list, and s7_add_to_load_path adds a directory name to the list. +

+

+s7_load_c_string takes an array of bytes representing some scheme code (xxd -i file.scm can generate these arrays), +and treats it as if it were the contents of a file of scheme code. So, unlike s7_eval_c_string, it can handle +multiple statements, and things like double-quote don't need to be quoted. nrepl.c for example +embeds the contents of nrepl.scm at compile time, then calls s7_load_c_string at program startup. It also +includes notcurses_s7.c. The end result is a stand-alone program that doesn't need to load either nrepl.scm +or notcurses_s7.so. The "content" argument should be a null-terminated C string. The "bytes" argument +is the contents length, not including the trailing null, as in strlen. There are simple examples in ffitest.c. +

+ +
+
+

xxd is not ideal in this context because diffs become enormous. I use this code to turn nrepl.scm +into nrepl-bits.h, following the original code's layout to minimize diffs: +

+
(call-with-output-file "nrepl-bits.h"
+  (lambda (op)
+    (call-with-input-file "nrepl.scm"
+      (lambda (ip)
+	(format op "unsigned char nrepl_scm[] = {~%  ")
+	(do ((c (read-char ip) (read-char ip))
+	     (i 0 (+ i 1)))
+	    ((eof-object? c)
+	     (format op "0};~%unsigned int nrepl_scm_len = ~D;~%" (+ i 1)))
+	  (format op "0x~X, " (char->integer c))
+	  (if (char=? c #\newline)
+	      (format op "~%  ")))))))
+
+

Then in nrepl.c: +

+
      #include "nrepl-bits.h"
+      s7_load_c_string(sc, (const char *)nrepl_scm, nrepl_scm_len);
+
+

which replaces s7_load(sc, "nrepl.scm"). +

+
+
+ + +

+s7_autoload adds a symbol to the autoload table. As a convenience, +s7_autoload_set_names adds an array of names+files. The array should be sorted alphabetically +by string<? acting on the symbol names (not the file names), and the size argument is the number +of symbol names (half the actual array size). +snd-xref.c in Snd has more than 5000 such +names: +

+
static const char *snd_names[11848] = {
+    "*clm-array-print-length*", "ws.scm", /* each pair of entries is entity name + file name */
+    "*clm-channels*", "ws.scm",           /*   so clm-channels is defined in ws.scm */
+    ...
+    "zone-tailed-hawk", "animals.scm",
+    "zoom-spectrum", "examp.scm",
+};
+
+s7_autoload_set_names(sc, snd_names, 5924);
+
+ +
Eval and Apply
+ +
s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e);
+s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str);
+s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer e);
+
+s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args);
+s7_pointer s7_apply_function_star(s7_scheme *sc, s7_pointer fnc, s7_pointer args);
+
+s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args);
+s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args, const char *caller, const char *file, s7_int line);
+s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7_pointer error_handler);
+
+s7_pointer s7_apply_1(s7_scheme *sc, s7_pointer args, s7_pointer (*f1)(s7_pointer a1)); 
+s7_pointer s7_apply_n_1(s7_scheme *sc, s7_pointer args, s7_pointer (*f1)(s7_pointer a1));
+/* and many more passing 2 to 9 arguments */
+
+

These functions evaluate Scheme expressions, and call Scheme functions (which might be defined in C originally). +s7_eval evaluates a list that represents Scheme code. That is, +

+
s7_eval(sc, s7_cons(sc, s7_make_symbol(sc, "+"),
+               s7_cons(sc, s7_make_integer(sc, 1),
+                  s7_cons(sc, s7_make_integer(sc, 2), s7_nil(sc)))),
+            s7_rootlet(sc));   /* s7_nil here is the same as s7_rootlet */
+
+

returns 3 (as a Scheme integer). This may look ridiculous, but see snd-sig.c for an actual use. +s7_eval_c_string evaluates a Scheme expression presented to it as a C string; it combines read and +eval, whereas s7_eval is just the eval portion. +

+
s7_eval_c_string(sc, "(+ 1 2)");
+
+

also returns 3. The expression is evaluated in rootlet (the global environment). To specify the +environment, use s7_eval_c_string_with_environment. +

+

s7_apply_function and s7_apply_function_star take an s7_function and apply it to a list of arguments. +These two functions are the low-level versions of the s7_call functions. The latter set up various +catches so that error handling is safe, whereas s7_apply_function assumes you have a catch already somewhere. +

+

+s7_call_with_location passes some information to the error handler, and +s7_call_with_catch wraps an explicit catch around a function call: +s7_call_with_catch(sc, tag, body, err) is equivalent to (catch tag body err). +There are many examples of these functions in clm2xen.c, ffitest.c, etc. +

+

The s7_apply_1 functions and its many friends are left over from long ago. I hope to +deprecate them someday, but currently Snd uses them to excess. Each applies its function +to the arguments. +

+ +
Define
+ +
void s7_define(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value);
+bool s7_is_defined(s7_scheme *sc, const char *name);
+
+s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value);
+s7_pointer s7_define_variable_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help);
+
+s7_pointer s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value);
+s7_pointer s7_define_constant_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help);
+s7_pointer s7_define_constant_with_environment(s7_scheme *sc, s7_pointer envir, const char *name, s7_pointer value);
+
+s7_pointer s7_define_function(s7_scheme *sc, const char *name, s7_function fnc, 
+                              s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc);
+s7_pointer s7_define_safe_function(s7_scheme *sc, const char *name, s7_function fnc, 
+                                   s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc);
+s7_pointer s7_define_typed_function(s7_scheme *sc, const char *name, s7_function fnc,
+				    s7_int required_args, s7_int optional_args, bool rest_arg, 
+				    const char *doc, s7_pointer signature);
+s7_pointer s7_define_unsafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc,
+					   s7_int required_args, s7_int optional_args, bool rest_arg, 
+					   const char *doc, s7_pointer signature);
+s7_pointer s7_define_semisafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc,
+					     s7_int required_args, s7_int optional_args, bool rest_arg,
+					     const char *doc, s7_pointer signature);
+
+void s7_define_function_star(s7_scheme *sc, const char *name, s7_function fnc, 
+                             const char *arglist, const char *doc);
+void s7_define_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, 
+                                  const char *arglist, const char *doc);
+void s7_define_typed_function_star(s7_scheme *sc, const char *name, s7_function fnc, 
+                                   const char *arglist, const char *doc, s7_pointer signature);
+
+s7_pointer s7_define_macro(s7_scheme *sc, const char *name, s7_function fnc, 
+                           s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc);
+
+s7_pointer s7_make_function(s7_scheme *sc, const char *name, s7_function fnc, 
+                            s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc);
+s7_pointer s7_make_safe_function(s7_scheme *sc, const char *name, s7_function fnc, 
+                                 s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc);
+s7_pointer s7_make_typed_function(s7_scheme *sc, const char *name, s7_function f, 
+				  s7_int required_args, s7_int optional_args, bool rest_arg, 
+                                  const char *doc, s7_pointer signature);
+
+s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fnc, 
+                                 const char *arglist, const char *doc);
+s7_pointer s7_make_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, 
+                                 const char *arglist, const char *doc);
+
+bool s7_is_dilambda(s7_pointer obj);
+s7_pointer s7_dilambda(s7_scheme *sc, 
+		       const char *name,
+		       s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), 
+		       s7_int get_req_args, s7_int get_opt_args,
+		       s7_pointer (*setter)(s7_scheme *sc, s7_pointer args),
+		       s7_int set_req_args, s7_int set_opt_args,
+		       const char *documentation);
+s7_pointer s7_typed_dilambda(s7_scheme *sc, 
+		       const char *name,
+		       s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), 
+		       s7_int get_req_args, s7_int get_opt_args,
+		       s7_pointer (*setter)(s7_scheme *sc, s7_pointer args),
+		       s7_int set_req_args, s7_int set_opt_args,
+		       const char *documentation,
+ 		       s7_pointer get_sig, s7_pointer set_sig);
+s7_pointer s7_dilambda_with_environment(s7_scheme *sc, s7_pointer envir,
+		       const char *name,
+		       s7_pointer (*getter)(s7_scheme *sc, s7_pointer args),
+		       s7_int get_req_args, s7_int get_opt_args,
+		       s7_pointer (*setter)(s7_scheme *sc, s7_pointer args),
+	               s7_int set_req_args, s7_int set_opt_args,
+		       const char *documentation);
+
+

The s7_define* functions add a symbol and its binding to either the top-level (global) environment +or, in s7_define, the 'env' passed as the second argument. Use s7_set_shadow_rootlet to +import the current let into rootlet. +

+
s7_define(s7, s7_curlet(s7), s7_make_symbol(s7, "var"), s7_make_integer(s7, 123));
+
+

adds the variable named var to the current environment with the value 123. +Scheme code can then refer to var just as if we had said (define var 123) +in Scheme. +

+

s7_define_variable is a wrapper for s7_define; the code above could be: +

+
s7_define_variable(s7, "var", s7_make_integer(s7, 123)); /* (define var 123) */
+
+

except that s7_define_variable assumes you want var in rootlet. +

+

s7_define_constant is another wrapper for s7_define; it makes the variable immutable: +

+
s7_define_constant(sc, "var", s7_f(sc));  /* (define-constant var 123) */
+
+ +

The rest of the functions in this section deal with tieing C functions into Scheme. +s7_make_function creates a Scheme function object from the s7_function 'fnc'. +An s7_function is a C function of the form s7_pointer func(s7_scheme *sc, s7_pointer args). +The new function's name is 'name', it requires 'required_args' arguments, +it can accept 'optional_args' other arguments, and if 'rest_arg' is true, it accepts +a "rest" argument (a list of all the trailing arguments). +The function's documentation is 'doc'. +

+

s7_define_function is the same as s7_make_function, but it also adds 'name' (as a symbol) to the +global environment, with the function as its value. For example, the Scheme +function 'car' is essentially: +

+
s7_pointer g_car(s7_scheme *sc, s7_pointer args) {return(s7_car(s7_car(args)));} /* args is a list of args */
+
+

It is bound to the name "car": +

+
s7_define_function(sc, "car", g_car, 1, 0, false, "(car obj)");
+
+

which says that car has one required argument, no optional arguments, and no "rest" argument. +

+

s7_define_macro defines a Scheme macro; its arguments are not evaluated (unlike a function), +but its returned value (assumed to be some sort of Scheme expression) is evaluated. +

+

The "safe" and "unsafe" versions of these functions refer to the s7 optimizer. +If it knows a function is safe, it can more thoroughly optimize the expression it is in. +"Safe" here means the function does not call the evaluator itself (via s7_apply_function for example) +and does not mess with s7's stack. +

+

The "typed" versions refer to the function's signature. Since "car" is safe, and has a signature, +it is defined in s7.c: +

+
s7_define_typed_function(sc, "car", g_car, 1, 0, false, H_car, Q_car);
+
+

Here unless you use s7_define_unsafe_typed_function, the function is assumed to be safe. +We've given it the Scheme name "car", which invokes the C function g_car. It takes one +required argument, and no optional or rest arguments. Its documentation is H_car, and +its signature is Q_car. The latter is s7_make_signature(sc, 2, sc->T, sc->is_pair_symbol) +which says that car takes a pair argument, and returns any type object. +

+

The function_star functions are similar, but in this case we pass the argument list +as a string, as it would appear in Scheme. +s7 makes sure the arguments are ordered correctly and have the specified defaults before calling the C function. +

+
s7_define_function_star(sc, "a-func", a_func, "arg1 (arg2 32)", "an example of C define*");
+
+

Now in Scheme, (a-func :arg1 2) calls the C function a_func with the arguments 2 and 32. +

+

Finally, the dilambda function define Scheme dilambda, just as the Scheme dilambda function does. +The dax example above gives read/write access to its x field via: +

+
s7_define_variable(s7, "dax-x", s7_dilambda(s7, "dax-x", dax_x, 1, 0, set_dax_x, 2, 0, "dax x field"));
+
+ + + +
Function info
+ +
const char *s7_documentation(s7_scheme *sc, s7_pointer p);
+const char *s7_set_documentation(s7_scheme *sc, s7_pointer symbol, const char *new_doc);
+const char *s7_help(s7_scheme *sc, s7_pointer obj);
+
+s7_pointer s7_arity(s7_scheme *sc, s7_pointer obj);
+bool s7_is_aritable(s7_scheme *sc, s7_pointer obj, s7_int args);
+
+s7_pointer s7_setter(s7_scheme *sc, s7_pointer obj);
+s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer obj, s7_pointer setter);
+
+s7_pointer s7_signature(s7_scheme *sc, s7_pointer func);
+s7_pointer s7_make_signature(s7_scheme *sc, s7_int len, ...);
+s7_pointer s7_make_circular_signature(s7_scheme *sc, s7_int cycle_point, s7_int len, ...);
+
+s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p);
+s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p);
+s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer p);
+s7_pointer s7_funclet(s7_scheme *sc, s7_pointer p);
+
+

These functions pertain mostly to functions, both those defined in Scheme and those in C. +s7_help and s7_documentation return the documentation string associated with their argument. +I find "documentation" tedious to type, and Snd uses "help", but other than the name, +there isn't much difference between them. s7_set_documentation sets the documentation string, if it can. +

+ +

s7_arity returns an object's arity, a cons of the number of required arguments, and the total acceptable arguments. +s7_is_aritable returns true if the object can accept that number of args. +

+ +

s7_setter is the object's setter, and s7_set_setter sets it, if possible. +

+ +

s7_signature is the object's signature, a list of types (symbols like 'integer?) giving return and argument types. +For a function defined in C, s7_make_signature and s7_make_circular_signature create the signature that is then +associated with the function via s7_define_typed_function and its friends. +In s7.c g_is_zero (the function that implements zero?) uses: +

+
s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_number_symbol); /* return a boolean, argument is a number */
+
+

Similarly, g_add is: +

+
s7_make_circular_signature(sc, 0, 1, sc->is_number_symbol); /* returns a number, takes any number of numbers */
+
+

The two numeric arguments set the cycle start point (0-based) and the number of type symbols passed as arguments to it. +So, char=? is: +

+
s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_char_symbol);
+
+

which says there are two type entries (the "2"), and the cycle starts at the second (the "1" -- it's 0-based). +

+ +

The s7_closure functions only apply to functions defined in Scheme. They return the closure body (s7_closure_body, a list), +its definition environment (s7_closure_let), and its argument list (s7_closure_args). If the function is of the form +(define (f . args) ...), s7_closure_args returns the symbol ('args in this case). +s7_funclet returns the top let within the function (the let containing the argument names). +

+ + +
C-objects
+ +
bool s7_is_c_object(s7_pointer p);
+s7_pointer s7_make_c_object(s7_scheme *sc, s7_int type, void *value);
+s7_pointer s7_make_c_object_without_gc(s7_scheme *sc, s7_int type, void *value);
+s7_pointer s7_make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let);
+
+s7_int s7_c_object_type(s7_pointer obj);
+void *s7_c_object_value(s7_pointer obj);
+void *s7_c_object_value_checked(s7_pointer obj, s7_int type);
+s7_pointer s7_c_object_let(s7_pointer obj);
+s7_pointer s7_c_object_set_let(s7_scheme *sc, s7_pointer obj, s7_pointer e);
+
+s7_int s7_make_c_type(s7_scheme *sc, const char *name);
+void s7_c_type_set_gc_free      (s7_scheme *sc, s7_int type, s7_pointer (*gc_free)   (s7_scheme *sc, s7_pointer obj));
+void s7_c_type_set_gc_mark      (s7_scheme *sc, s7_int type, s7_pointer (*mark)      (s7_scheme *sc, s7_pointer obj));
+void s7_c_type_set_is_equal     (s7_scheme *sc, s7_int type, s7_pointer (*is_equal)  (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_is_equivalent(s7_scheme *sc, s7_int type, s7_pointer (*is_equivalent)(s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_ref          (s7_scheme *sc, s7_int type, s7_pointer (*ref)       (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_set          (s7_scheme *sc, s7_int type, s7_pointer (*set)       (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_length       (s7_scheme *sc, s7_int type, s7_pointer (*length)    (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_copy         (s7_scheme *sc, s7_int type, s7_pointer (*copy)      (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_fill         (s7_scheme *sc, s7_int type, s7_pointer (*fill)      (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_reverse      (s7_scheme *sc, s7_int type, s7_pointer (*reverse)   (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_to_list      (s7_scheme *sc, s7_int type, s7_pointer (*to_list)   (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_to_string    (s7_scheme *sc, s7_int type, s7_pointer (*to_string) (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_getter       (s7_scheme *sc, s7_int type, s7_pointer getter);
+void s7_c_type_set_setter       (s7_scheme *sc, s7_int type, s7_pointer setter);
+
+void s7_mark(s7_pointer p);
+
+ +

These functions create a new Scheme object type. See dax above for a simple example, +and s7test.scm for several progressively more complicated examples. +C-objects in Scheme usually correspond to an instance of a struct in C which you want to access from Scheme. +The normal sequence is: define a new c-type via s7_make_c_type, call s7_c_type_set* to specialize its behavior, +then to wrap a C object, call s7_make_c_object. +s7_make_c_type takes an arbitrary name, used in object->string to identify the object, and returns an s7_int, the "type" +mentioned in many of the other functions. +

+

s7_c_type_set_free sets the function that is called by the GC when a Scheme c-object is garbage-collected. +You normally use this to free the associated C value (the instance of the struct). To get that value, +call s7_c_object_value. It returns the void* pointer that you originally passed to s7_make_c_object. +See free_dax in the dax example. +

+

s7_c_type_set_mark sets the function that is called by the GC during its marking phase. Any s7_pointer +value local to your C struct should be marked explicitly at this time, or the GC will free it. Use s7_mark +for this (see mark_dax). +

+

s7_c_type_set_equal and s7_c_type_set_equivalent set the function called when s7 sees a c-object of the +current type as an argument to equal? or equivalent?. When called, these functions can assume that the +first argument is a c-object of the current type, but the second argument can be anything (see dax_is_equal). +

+

s7_c_type_set_ref and s7_c_type_set_set are called when the c-object is treated as an applicable object +in Scheme. That is, (object ...) in Scheme calls the function set as the "ref" function, and +(set! (object ...) new-value) calls the "set" function. The arguments in the set! form are +passed as a flattened list. +

+

The rest of the s7_c_type_set* functions set the functions called when the c-object is an argument to +length (s7_c_type_set_length), copy (s7_c_type_set_copy), fill! (s7_c_type_set_fill), reverse (s7_c_type_set_reverse), +object->string (s7_c_type_set_to_string), and internally by map and a few other cases, s7_c_type_set_to_list. +For the copy function, either the first or second argument can be a c-object of the given type. +The getter and setter functions are optimizer helpers. +

+

s7_c_object_value_checked is like s7_c_object, but it first checks that the object type matches the given type. +

+

s7_c_object_let and s7_c_object_set_let manage the c-object's local environment. +These two functions need to check that they are passed the correct number of arguments. +See the block object in s7test.scm. The c_object_let provides methods normally. +In Snd, marks can be passed into Scheme; the setup code is: +

+
  static s7_pointer g_mark_methods;
+  ...
+  g_mark_methods = s7_openlet(s7, 
+                     s7_inlet(s7, s7_list(s7, 2, s7_make_symbol(s7, "object->let"), 
+                                                 mark_to_let_func)));
+  s7_gc_protect(s7, g_mark_methods);
+  xen_mark_tag = s7_make_c_type(s7, "<mark>");
+  s7_c_type_set_gc_free(s7, xen_mark_tag, s7_xen_mark_free);
+  s7_c_type_set_is_equal(s7, xen_mark_tag, s7_xen_mark_is_equal);
+  s7_c_type_set_copy(s7, xen_mark_tag, s7_xen_mark_copy);
+  s7_c_type_set_to_string(s7, xen_mark_tag, g_xen_mark_to_string);
+
+

The mark object's let (g_mark_methods) has a method for object->let. +It is tied into each mark object: +

+
s7_pointer m;
+m = s7_make_c_object(s7, xen_mark_tag, mx);  /* mx is the C-side value */
+s7_c_object_set_let(s7, m, g_mark_methods);
+
+

and now if you type (object->let mark) in Snd's listener (where "mark" is +an appropriate mark of course), object->let calls the object's object->let method. +Don't forget to GC-protect the let! +

+

s7_make_c_object_without_gc makes a c-object of the given type, but the gc_free function +won't be called when the s7_cell that holds the C data is freed for reuse. +

+ +
IO
+
bool s7_is_input_port(s7_scheme *sc, s7_pointer p);
+bool s7_is_output_port(s7_scheme *sc, s7_pointer p);
+void s7_close_input_port(s7_scheme *sc, s7_pointer p);
+void s7_close_output_port(s7_scheme *sc, s7_pointer p);
+bool s7_flush_output_port(s7_scheme *sc, s7_pointer p); /* false=flush lost data */
+const char *s7_port_filename(s7_scheme *sc, s7_pointer x);
+s7_int s7_port_line_number(s7_scheme *sc, s7_pointer p);
+
+s7_pointer s7_open_input_file(s7_scheme *sc, const char *name, const char *mode);  
+s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode); 
+
+s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string);  
+s7_pointer s7_open_output_string(s7_scheme *sc);
+const char *s7_get_output_string(s7_scheme *sc, s7_pointer out_port);
+s7_pointer s7_output_string(s7_scheme *sc, s7_pointer out_port);
+
+typedef enum {S7_READ, S7_READ_CHAR, S7_READ_LINE, S7_PEEK_CHAR, S7_IS_CHAR_READY, S7_NUM_READ_CHOICES} s7_read_t;
+s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port));  
+s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port));
+
+s7_pointer s7_read_char(s7_scheme *sc, s7_pointer port);
+s7_pointer s7_peek_char(s7_scheme *sc, s7_pointer port);
+s7_pointer s7_write_char(s7_scheme *sc, s7_pointer c, s7_pointer port);
+s7_pointer s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port);
+s7_pointer s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port);
+void s7_newline(s7_scheme *sc, s7_pointer port);
+const char *s7_format(s7_scheme *sc, s7_pointer args);
+s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer arg, bool use_write);       
+char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj);
+
+s7_pointer s7_current_input_port(s7_scheme *sc);
+s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer p);
+s7_pointer s7_current_output_port(s7_scheme *sc);
+s7_pointer s7_set_current_output_port(s7_scheme *sc, s7_pointer p);
+s7_pointer s7_current_error_port(s7_scheme *sc);
+s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port);
+
+s7_pointer s7_read(s7_scheme *sc, s7_pointer port);
+
+

Most of these correspond closely to the similarly named scheme function. s7_port_filename +returns the file associated with a file port. s7_port_line_number returns position of the +reader in an input file port. The "use_write" parameter to s7_object_to_string refers +to the write/display choice in scheme. The string returned by s7_object_to_c_string +should be freed by the caller. +s7_output_string is the same as s7_get_output_string except that it returns an s7 string, +not a C string. +

+

s7_open_input_function and s7_open_output_function +call their "function" argument when input or output is requested. The "read_choice" +argument specifies to that function which of the input scheme functions called it. +The intent of these two input functions is to give you complete control over IO. +In the case of an input_function: +

+
static s7_pointer my_read(s7_scheme *sc, s7_read_t peek, s7_pointer port)
+{
+  /* this function should handle input according to the peek choice */
+  return(s7_make_character(sc, '0'));
+}
+
+s7_pointer port;
+s7_int gc_loc;
+uint8_t c;
+port = s7_open_input_function(sc, my_read);
+gc_loc = s7_gc_protect(sc, port);
+c = s7_character(s7_read_char(sc, p1)); /* my_read "peek" == S7_READ_CHAR */
+if (last_c != '0') 
+   fprintf(stderr, "c: %c\n", c);
+s7_gc_unprotect_at(sc, gc_loc);
+
+ + +
Lets
+
s7_pointer s7_rootlet(s7_scheme *sc);
+s7_pointer s7_shadow_rootlet(s7_scheme *sc);
+s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let);
+
+s7_pointer s7_curlet(s7_scheme *sc);
+s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e);
+
+s7_pointer s7_outlet(s7_scheme *sc, s7_pointer e);
+s7_pointer s7_sublet(s7_scheme *sc, s7_pointer let, s7_pointer bindings);
+s7_pointer s7_inlet(s7_scheme *sc, s7_pointer bindings);
+s7_pointer s7_varlet(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value);
+
+s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let);
+bool s7_is_let(s7_pointer e);
+s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol);
+s7_pointer s7_let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer val);
+s7_pointer s7_let_field_ref(s7_scheme *sc, s7_pointer symbol);
+s7_pointer s7_let_field_set(s7_scheme *sc, s7_pointer symbol, s7_pointer new_value);
+
+s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e);
+bool s7_is_openlet(s7_pointer e);
+s7_pointer s7_method(s7_scheme *sc, s7_pointer object, s7_pointer method);
+
+/* these might go away someday */
+s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol);
+s7_pointer s7_slot_value(s7_pointer slot);
+s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value);
+s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value);
+void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value);
+
+

Many of these are the same as the corresponding scheme function: s7_rootlet, s7_curlet, s7_outlet, +s7_sublet, s7_inlet, s7_varlet, s7_let_to_list, s7_is_let, s7_let_ref, s7_let_set, s7_openlet, +and s7_is_openlet. +

+

s7_let_field_ref and s7_let_field_set refer to *s7*, the let that holds various s7 settings. +To get the current default print-length, +

+
s7_integer(s7_let_field_ref(s7, s7_make_symbol(s7, "print-length")))
+
+

s7_method looks for a field in "object" with the name "method", a symbol. +For example, in clm2xen.c, if mus-copy is called on an object that Snd does not +immediately recognize (i.e. a generator), it looks for a mus-copy method, and +if found, Snd calls it: +

+
s7_pointer func; 
+func = s7_method(s7, gen, s7_make_symbol(s7, "mus-copy"));
+if (func != s7_undefined(s7))
+  return(s7_apply_function(s7, func, s7_list(s7, 1, gen))); 
+
+

The object searched can be anything that has an associated let: a c-object, +a function or macro, a c-pointer, or of course a let. +

+

s7_set_curlet and the slot functions might go away someday. They are currently used +in Snd. For the adventurous however, here's a sketchy description. +A slot in s7 is a location in a let (a variable binding in an environment to use more standard terminology). +s7_make_slot creates a slot in "env" with the given symbol and value. s7_slot_value returns the value; +s7_slot_set_value sets the value; s7_slot_set_real_value sets the mutable real value's numerical value. +s7_slot takes a symbol and tries to find its currently active slot. s7_set_curlet sets curlet, returning +the previous curlet. +

+

s7_shadow_rootlet and s7_set_shadow_rootlet make it easier to import a let into rootlet. This is also aimed +at code that is defining lots of functions and variables, using the default functions like s7_define_variable +that place things in the rootlet, but the code actually wants all those objects stored +in a let other than rootlet. +

+
s7_pointer cur_env, old_shadow;
+cur_env = s7_curlet(sc);
+old_shadow = s7_set_shadow_rootlet(sc, cur_env);
+/* define everything here */
+s7_set_shadow_rootlet(sc, old_shadow);
+
+

s7_set_shadow_rootlet returns the previous shadow rootlet, +so this turns the current environment into a shadow rootlet while defining functions, then restores +the old rootlet. +Similarly notcurses_s7.c places everything in the *notcurses* let, +but uses s7_set_shadow_rootlet to make these available in scheme as if they were in the rootlet: +

+
  s7_pointer notcurses_let, old_shadow;
+  s7_define_constant(sc, "*notcurses*", notcurses_let = s7_inlet(sc, s7_nil(sc)));
+  old_shadow = s7_set_shadow_rootlet(sc, notcurses_let);
+  /* ... here we have all the s7_defines ... */
+  s7_set_shadow_rootlet(sc, old_shadow);
+
+ +
Symbols
+
bool s7_is_symbol(s7_pointer p);
+const char *s7_symbol_name(s7_pointer p);
+s7_pointer s7_make_symbol(s7_scheme *sc, const char *name);
+s7_pointer s7_gensym(s7_scheme *sc, const char *prefix);
+
+bool s7_is_keyword(s7_pointer obj);
+s7_pointer s7_make_keyword(s7_scheme *sc, const char *key);
+s7_pointer s7_keyword_to_symbol(s7_scheme *sc, s7_pointer key);
+
+s7_pointer s7_name_to_value(s7_scheme *sc, const char *name);
+s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym);
+s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val);
+s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer local_env);
+
+s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name);
+bool s7_for_each_symbol_name(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data);
+bool s7_for_each_symbol(s7_scheme *sc,      bool (*symbol_func)(const char *symbol_name, void *data), void *data);
+
+

s7_is_symbol corresponds to scheme's symbol?, s7_symbol_name to symbol->string, +s7_make_symbol is string->symbol, +s7_gensym to gensym. The gensym prefix is the optional argument to gensym in scheme. +By default the prefix is "gensym", so the gensym-created symbols are of the form {gensym}-nnn +where nnn is some number. s7_is_keyword is keyword?, s7_make_keyword is string->keyword, +and s7_keyword_to_symbol is keyword->symbol. +

+

Normal symbols, and keywords do not need to be garbage-protected, but gensyms do. +

+

s7_symbol_to_value finds the current binding of the symbol (using its string name), +and returns its value, similar to symbol->value. To specify the environment in which to +lookup the symbol, use s7_symbol_local_value. s7_symbol_set_value sets the value of the +symbol in its current binding. +

+

s7_symbol_table_find_name finds the symbol given its name. s7_make_symbol is the same +if the symbol already exists, but s7_symbol_find_by_name returns NULL if there isn't any +symbol by that name. +s7_for_each_symbol_name and s7_for_each_symbol traverse the symbol +table, calling "symbol_func" on each symbol. symbol_func is a boolean function that +takes as arguments the symbol name and the void* data pointer. The latter can carry +along whatever state your function needs. s7_for_each_symbol_name also includes some +s7 constants like #f. +

+

The C declaration above says s7_for_each_symbol is a C function that returns a boolean, +and takes three arguments, an s7_scheme* pointer, a function (symbol_func), and a void* pointer +(data). The function passed (symbol_func) also returns a boolean, and takes two arguments, a char* (name), +and the same void* pointer that was passed to s7_symbol_for_each. If symbol_func returns true, +the outer function immediately returns true, ending the symbol table traversal. +Sketched in scheme, it might be: +

+
(define (s7_for_each_symbol s7 symbol_func data)
+  (call-with-exit 
+    (lambda (return)
+      (for-each 
+        (lambda (symbol-name)
+          (if (symbol_func symbol-name data)
+              (return #t)))
+        (symbol-table))
+      #f)))
+
+

An example is snd-completion.c. +

+ + +
Numbers
+
bool s7_is_number(s7_pointer p);
+char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, s7_int radix);
+
+bool s7_is_integer(s7_pointer p);
+s7_int s7_integer(s7_pointer p);
+s7_pointer s7_make_integer(s7_scheme *sc, s7_int num);
+s7_int s7_number_to_integer(s7_scheme *sc, s7_pointer x);
+s7_int s7_number_to_integer_with_caller(s7_scheme *sc, s7_pointer x, const char *caller);
+
+bool s7_is_real(s7_pointer p);
+s7_double s7_real(s7_pointer p);
+s7_pointer s7_make_real(s7_scheme *sc, s7_double num);
+s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n);
+s7_double s7_number_to_real(s7_scheme *sc, s7_pointer x);
+s7_double s7_number_to_real_with_caller(s7_scheme *sc, s7_pointer x, const char *caller);
+
+bool s7_is_rational(s7_pointer arg);
+bool s7_is_ratio(s7_pointer arg);
+s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b);
+s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error);
+s7_int s7_numerator(s7_pointer x);
+s7_int s7_denominator(s7_pointer x);
+
+bool s7_is_complex(s7_pointer arg);
+s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b);
+s7_double s7_real_part(s7_pointer z);
+s7_double s7_imag_part(s7_pointer z);
+
+s7_double s7_random(s7_scheme *sc, s7_pointer state);
+s7_pointer s7_random_state(s7_scheme *sc, s7_pointer seed);
+bool s7_is_random_state(s7_pointer p);
+s7_pointer s7_random_state_to_list(s7_scheme *sc, s7_pointer args);
+void s7_set_default_random_state(s7_scheme *sc, s7_int seed, s7_int carry);
+
+bool s7_is_bignum(s7_pointer obj);
+mpfr_t *s7_big_real(s7_pointer x);
+mpz_t *s7_big_integer(s7_pointer x);
+mpq_t *s7_big_ratio(s7_pointer x);
+mpc_t *s7_big_complex(s7_pointer x);
+s7_pointer s7_make_big_integer(s7_scheme *sc, mpz_t *val);
+s7_pointer s7_make_big_ratio(s7_scheme *sc, mpq_t *val);
+s7_pointer s7_make_big_real(s7_scheme *sc, mpfr_t *val);
+s7_pointer s7_make_big_complex(s7_scheme *sc, mpc_t *val);
+
+

Most of these correspond to the obvious scheme functions, so I'll +only touch on the less-obvious cases. +s7_make_mutable_real returns a real number object whose value can be changed directly. +In snd-sig.c, for example, we have a C procedure that applies a scheme function to +every sound sample in an audio file. We do not want to create a new object for the +scheme function's argument list on every call! So, we start by creating the mutable real: +

+
yp = s7_make_slot(s7, e, arg, s7_make_mutable_real(s7, 1.5));
+
+

"e" is the let for the evaluation, "arg" is the real's name as a symbol in that let, +and we make its initial value 1.5 (for no particular reason). Then on every sample, we +call the function: +

+
s7_slot_set_real_value(s7, yp, data[kp]); /* set yp's value to data[kp] */
+data[kp] = opt_func(s7, res);             /* call opt_func */
+
+

s7_number_to_real returns any real number as an s7_double. If it can't +convert its argument, it signals an error, which is annoying because it doesn't +know where that error occured in scheme. So s7_number_to_real_with_caller gives +you a way to tell it at lease the caller's name. +

+

For the bignum functions, see Bignums in C. +

+ + +
Lists
+
bool s7_is_pair(s7_pointer p);
+s7_pointer s7_cons(s7_scheme *sc, s7_pointer a, s7_pointer b);
+
+s7_pointer s7_car(s7_pointer p);
+s7_pointer s7_cdr(s7_pointer p);
+s7_pointer s7_set_car(s7_pointer p, s7_pointer q);
+s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q);
+s7_pointer s7_cadr(s7_pointer p);
+etc...
+
+bool s7_is_list(s7_scheme *sc, s7_pointer p);
+bool s7_is_proper_list(s7_scheme *sc, s7_pointer p);
+s7_pointer s7_make_list(s7_scheme *sc, s7_int length, s7_pointer initial_value);
+s7_int s7_list_length(s7_scheme *sc, s7_pointer a);
+s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...);
+s7_pointer s7_list_nl(s7_scheme *sc, s7_int num_values, ...);
+s7_pointer s7_array_to_list(s7_scheme *sc, s7_int num_values, s7_pointer *array);
+s7_pointer s7_list_ref(s7_scheme *sc, s7_pointer lst, s7_int num);
+s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, s7_int num, s7_pointer val);
+
+s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a);
+s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b);
+s7_pointer s7_assoc(s7_scheme *sc, s7_pointer obj, s7_pointer lst);
+s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer x);
+s7_pointer s7_member(s7_scheme *sc, s7_pointer obj, s7_pointer lst);
+s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x);
+bool s7_tree_memq(s7_scheme *sc, s7_pointer sym, s7_pointer tree);
+
+

These functions are mostly obvious: s7_car corresponds to scheme car, etc. +s7_list_nl was added to catch a typo that affected s7_list: the latter would accept +trailing, but ignored list values. s7_tree_memq is like s7_memq, but searches +an entire tree structure. not just the top-level list. s7_array_to_list takes +an array of s7_pointers and returns a list of them (similar to s7_vector_to_list). +

+ + +
Vectors
+
s7_pointer s7_make_vector(s7_scheme *sc, s7_int len);
+s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill);
+s7_pointer s7_make_normal_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info);
+bool s7_is_vector(s7_pointer p);
+
+s7_int s7_vector_length(s7_pointer vec);
+s7_int s7_vector_rank(s7_pointer vect);
+s7_int s7_vector_dimension(s7_pointer vec, s7_int dim);
+s7_pointer *s7_vector_elements(s7_pointer vec);
+s7_int s7_vector_dimensions(s7_pointer vec, s7_int *dims, s7_int dims_size);
+s7_int s7_vector_offsets(s7_pointer vec, s7_int *offs, s7_int offs_size);   
+ 
+void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj);
+s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vect);
+s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect);
+
+s7_pointer s7_make_int_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info);
+s7_int *s7_int_vector_elements(s7_pointer vec);
+bool s7_is_int_vector(s7_pointer p);
+s7_int s7_int_vector_ref(s7_pointer vec, s7_int index);
+s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value);
+
+s7_pointer s7_make_float_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info);
+s7_pointer s7_make_float_vector_wrapper(s7_scheme *sc, s7_int len, s7_double *data, s7_int dims, s7_int *dim_info, bool free_data);
+s7_double *s7_float_vector_elements(s7_pointer vec);
+bool s7_is_float_vector(s7_pointer p);
+s7_double s7_float_vector_ref(s7_pointer vec, s7_int index);
+s7_double s7_float_vector_set(s7_pointer vec, s7_int index, s7_double value);
+
+s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_int index);
+s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer a);
+s7_pointer s7_vector_ref_n(s7_scheme *sc, s7_pointer vector, s7_int indices, ...);
+s7_pointer s7_vector_set_n(s7_scheme *sc, s7_pointer vector, s7_pointer value, s7_int indices, ...);
+
+

s7_make_vector returns a one-dimensional vector of the given length; +its elements are initialized to the empty list, (). +s7_make_and_fill_vector is similar, but the initial element is set by +the "fill" parameter. This value +is simply placed in every vector location, not copied, so if you pass a +cons, then change its car, +that change is reflected in every element of the vector. +s7_make_normal_vector returns a possibly multidimensional inhomogenous +vector (a "normal" vector, as opposed to an int-vector or a +float-vector). +

+

s7_is_vector is the same as vector?, s7_vector_length is length. +s7_vector_rank returns the number of dimensions in a vector, and s7_vector_dimension returns +the size of the given dimension. s7_vector_elements returns the s7_pointer array that holds +that vector's elements. +s7_vector_dimensions fills "dims" with the lengths of the corresponding dimensions. +s7_vector_offsets does the same for the successive dimensional offsets. +In a multidimensional vector, you can get the s7_vector_elements index by summing each index * offset[dimension]. +s7_vector_to_list is vector->list. s7_vector_fill is fill! (as applied to a vector of course), and s7_vector_copy is copy. +

+

s7_make_int_vector returns an int-vector. Its elements are s7_ints (int64_t), and the array of s7_ints can be accessed +via s7_int_vector_elements. Similarly for float-vectors (the elements are s7_doubles which +are C doubles). s7_make_float_vector_wrapper provides a way to pass a C array of doubles +through scheme; it wraps up the array as a scheme float-vector. Both s7_make_int_vector +and s7_make_float_vector can return multidimensional vectors. The "dims" parameter specifies +the number of dimensions, and the "dim_info" parameter the individual dimensions. If dims +is 1, dim_info can be NULL. If the s7_make_float_vector_wrapper "free_data" parameter is true, s7 will free the "data" +array when the float-vector is garbage-collected. In ffitest.c, the g_block example calls: +

+
v1 = s7_make_float_vector_wrapper(sc, len, g1->data, 1, NULL, false);
+
+

when checking if two blocks are equivalent. Since this data is actually being shared +with a block object, we don't want s7 to free it when the g_blocks_are_equivalent function +is done. g1->data is freed by g_block_free when the c-object is garbage collected. +

+

s7_vector_ref and s7_vector_set apply to one-dimensional vectors; the "_n" cases +apply to multidimensional cases. All four functions can be used on any type of vector. +

+ + +
C-pointers
+
bool s7_is_c_pointer(s7_pointer arg);
+bool s7_is_c_pointer_of_type(s7_pointer arg, s7_pointer type);
+void *s7_c_pointer(s7_pointer p);
+void *s7_c_pointer_with_type(s7_scheme *sc, s7_pointer p, s7_pointer expected_type, const char *caller, s7_int argnum);
+s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr);
+s7_pointer s7_make_c_pointer_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info);
+s7_pointer s7_c_pointer_type(s7_pointer p);
+
+

These functions are equivalent to s7's c-pointer?, c-pointer, and c-pointer-type. +C-pointers in s7 are aimed primarily at passing uninterpreted C pointers through +s7 from one C function to another. +The "type" field can hold a type +indication, useful in debugging. s7_c_pointer_of_type checks that the c-pointer's +type field matches the type passed as the second argument. As a convenience, +s7_c_pointer_with_type combines s7_c_pointer with s7_is_c_pointer_of_type, +calling s7_error if the types don't match. +Nothing else in s7 assumes the type field is actually a type symbol, so you +can use the type and info fields for any purpose. +

+ + +
Strings
+ +
bool s7_is_string(s7_pointer p);
+const char *s7_string(s7_pointer p);
+s7_pointer s7_make_string(s7_scheme *sc, const char *str);
+s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, s7_int len);
+s7_pointer s7_make_string_wrapper(s7_scheme *sc, const char *str);
+s7_pointer s7_make_permanent_string(s7_scheme *sc, const char *str);
+s7_int s7_string_length(s7_pointer str);
+
+

These handle s7 strings. s7_is_string corresponds to scheme's string?, +and s7_string_length to scheme's string-length. s7_string returns the scheme string's value as a C string. +Don't free the returned string! s7_make_string takes a C string, and returns its scheme +equivalent. s7_make_string_with_length is the same, but it is faster because you pass the +new string's length (s7_make_string has to use strlen). +s7_make_permanent_string returns a scheme string that is not in the heap; it will never be GC'd. +s7_make_string_wrapper creates a temporary string. This saves the overhead of getting a free cell +from the heap and later GC-ing it, but the string may be reused at any time. It is useful as +an argument to s7_call and similar functions where you know no other strings will be needed +during that call. +

+ + +
Characters
+ +
bool s7_is_character(s7_pointer p);
+uint8_t s7_character(s7_pointer p);
+s7_pointer s7_make_character(s7_scheme *sc, uint8_t c);
+
+ +

s7_is_character is equivalent to character?. s7_character returns the unsigned char held by the s7 object p, +and s7_make_character returns an s7 object holding the unsigned char c. +

+ + +
Hash-tables
+ +
bool s7_is_hash_table(s7_pointer p);
+s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size);
+s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key);   
+s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value);  
+
+

These functions are the C-side equivalent of hash-table?, make-hash-table, hash-table-ref, +and hash-table-set!. +

+ + +
Iterators
+ +
s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e);
+bool s7_is_iterator(s7_pointer obj);
+bool s7_iterator_is_at_end(s7_scheme *sc, s7_pointer iter);
+s7_pointer s7_iterate(s7_scheme *sc, s7_pointer iter);
+
+

These are the C equivalents of make-iterator, iterator?, iterator-at-end?, and iterate. +

+ + +
Hooks
+
s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook);
+s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions);
+
+

These access the list of functions associated with a hook. See hooks +for a discussion of hooks, and C and Scheme Hooks for a short example. +The scheme equivalent is hook-functions (a dilambda). +

+ + +
Constants
+
s7_pointer s7_f(s7_scheme *sc);
+s7_pointer s7_t(s7_scheme *sc);
+s7_pointer s7_nil(s7_scheme *sc);
+s7_pointer s7_undefined(s7_scheme *sc);
+s7_pointer s7_unspecified(s7_scheme *sc);
+s7_pointer s7_eof_object(s7_scheme *sc);
+
+bool s7_is_unspecified(s7_scheme *sc, s7_pointer val);
+bool s7_is_null(s7_scheme *sc, s7_pointer p);
+bool s7_is_boolean(s7_pointer x);
+
+bool s7_boolean(s7_scheme *sc, s7_pointer x);
+s7_pointer s7_make_boolean(s7_scheme *sc, bool x);
+
+bool s7_is_immutable(s7_pointer p);
+s7_pointer s7_immutable(s7_pointer p);
+
+

These return the standard scheme or s7 constants: #f, #t, (), #<undefined>, #<unspecified>, and #<eof>. +Also the s7 function unspecified?, and the scheme functions null?, and boolean?. s7_make_boolean +returns #t or #f depending on its argument. +

+

s7_immutable makes its argument immutable, and s7_is_immutable returns true if its argument is immutable. +They parallel s7's immutable! and immutable?. +

+ + +
Optimization
+ +
typedef s7_double (*s7_d_t)(void);
+void s7_set_d_function(s7_scheme *sc, s7_pointer f, s7_d_t df);
+s7_d_t s7_d_function(s7_pointer f);
+etc...
+
+ +

+These functions tell s7 to call a foreign function directly, without any scheme-related +overhead. The function to be called in this manner needs to take the form of one of the s7_*_t functions in s7.h. +For example, +one way to call + is to pass it two s7_double arguments and get an s7_double back. This is the +s7_d_dd_t function (the first letter gives the return type, the rest give successive argument types, +d=double, i=integer, v=c_object, p=s7_pointer). +We tell s7 about it via s7_set_d_dd_function. Whenever s7's optimizer encounters + with two arguments +that it (the optimizer) knows are s7_doubles, in a context where an s7_double result is expected, +s7 calls the associated s7_d_dd_t function directly without preparing a list of arguments, and without +wrapping up the result as an s7 object. +

+ +

Here is an example of using these functions; more extensive examples are in clm2xen.c in sndlib, and in s7.c. +

+
static s7_pointer g_plus_one(s7_scheme *sc, s7_pointer args) 
+{
+  return(s7_make_integer(sc, s7_integer(s7_car(args)) + 1));
+}
+
+static s7_int plus_one(s7_int x) {return(x + 1);}
+
+s7_define_safe_function(sc, "plus1", g_plus_one, 1, 0, false, "");
+s7_set_i_i_function(sc, s7_name_to_value(sc, "plus1"), plus_one);
+
+

s7_define_safe_function defines a Scheme function "plus1", +telling the optimizer that this function is safe. +A safe function does not push anything on the s7 stack, and treats the arglist +passed to it as immutable and temporary (that is, it just grabs the arguments from +the list). A few s7_* functions are unsafe, and that makes anything that calls +them also unsafe. If the optimizer knows a function is safe, it can use prebuilt +lists to pass the arguments (saving in the GC), and can combine it in various +ways with other stuff. If an unsafe function handles its argument list safely, +declare it with s7_define_semisafe_typed_function. +If the safe function knows its return and argument +types, there is another level of optimization that can call it without +setting up an arglist or "unboxing" values, basically a direct call in C. +In this example, the s7_set_i_i_function call +tells the optimizer that if plus1 is seen in a context where the optimizer +knows it is receiving an s7_int argument, and is expected to return +an s7_int result, it can call plus_one directly, rather than g_plus_one. +

+ +

There are more of these functions in s7.c that could be exported via s7.h +if you need them. +

+

By the way, to optimize scheme code (for speed), first use functions: the optimizer +ignores anything else at the top level. Then perhaps check lint.scm and the profiler. +Don't use something dumb like call/cc. Avoid append. Use iteration, not recursion. +Perhaps take the hot spot and do it in C. callgrind might also be helpful, but it +can be hard to map from callgrind output to the original scheme code. +

+ + +
And so on...
+ +
s7_scheme *s7_init(void);
+void s7_quit(s7_scheme *sc);
+void s7_free(s7_scheme *sc);
+void s7_repl(s7_scheme *sc);
+
+bool s7_is_eq(s7_pointer a, s7_pointer b);
+bool s7_is_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b);
+bool s7_is_equal(s7_scheme *sc, s7_pointer a, s7_pointer b);
+bool s7_is_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y);
+
+void s7_provide(s7_scheme *sc, const char *feature);
+bool s7_is_provided(s7_scheme *sc, const char *feature);
+
+s7_pointer s7_stacktrace(s7_scheme *sc);
+
+s7_pointer s7_history(s7_scheme *sc);
+s7_pointer s7_add_to_history(s7_scheme *sc, s7_pointer entry);
+bool s7_history_enabled(s7_scheme *sc);
+bool s7_set_history_enabled(s7_scheme *sc, bool enabled);
+
+s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_pointer finish);
+s7_pointer s7_make_continuation(s7_scheme *sc);
+s7_pointer s7_values(s7_scheme *sc, s7_pointer args);
+s7_pointer s7_copy(s7_scheme *sc, s7_pointer args);
+s7_pointer s7_fill(s7_scheme *sc, s7_pointer args);
+s7_pointer s7_type_of(s7_scheme *sc, s7_pointer arg);
+s7_pfunc s7_optimize(s7_scheme *sc, s7_pointer expr);
+bool s7_is_syntax(s7_pointer p);
+bool s7_is_valid(s7_scheme *sc, s7_pointer arg);
+
+void (*s7_begin_hook(s7_scheme *sc))(s7_scheme *sc, bool *val);
+void s7_set_begin_hook(s7_scheme *sc, void (*hook)(s7_scheme *sc, bool *val));
+
+ +

s7_init creates a scheme interpreter. The returned value is the s7_scheme* used by many of the FFI functions. +s7_quit exits the interpreter. The memory allocated for it by s7_init is not freed unless you call s7_free. +(s7_free also frees its s7_scheme* argument). +s7_repl fires up a REPL. +s7_is_eq and friends correspond to scheme's eq?, eqv?, equal?, and equivalent?. s7_provide and s7_is_provided +add a symbol to the *features* list, or check for its presence there. +

+

s7_stacktrace is like stacktrace; it currently ignores (*s7* 'stacktrace). +The s7_history functions deal with the (*s7* 'history) buffer. +s7_dynamic_wind is dynamic-wind in C. The parameters "init", "body", and "finish" are +the same as in scheme (i.e. #f or a thunk). s7_make_continuation is call/cc; there +is an example above. +s7_values is values, s7_copy is copy, s7_fill is fill!, s7_type_of is type-of, s7_is_syntax +is syntax?. +

+

s7_is_valid is a debugging aid; it tries to tell if an arbitrary value is pointing to +an s7 object. Set the compile-time switch TRAP_SEGFAULT to 1 before using this function! +

+

s7_optimize is the third-level optimizer. It is a bit hard to explain, +but basically you pass it some scheme code, and it returns either NULL or a function that can be called +to evaluate that code. There are several examples in snd-sig.c. +

+
static s7_pointer g_d_func(s7_scheme *sc, s7_pointer args) 
+{
+  /* a normal C-defined s7 function that simply returns (scheme) 1.0 */
+  return(s7_make_real(sc, 1.0));
+}
+static s7_double opt_d_func(void) 
+{
+  /* a version of g_d_func that returns (C) 1.0 */
+  return(1.0);
+}
+
+/* now make it possible to call opt_d_func in place of g_d_func */
+s7_float_function func;
+s7_pointer symbol;
+
+symbol = s7_define_safe_function(sc, "d-func", g_d_func, 0, 0, false, "opt func");
+s7_set_d_function(sc, s7_name_to_value(sc, "d-func"), opt_d_func);
+
+/* and try it (this saves creating an s7 real, accessing its value, and GC-ing it eventually) */
+func = s7_float_optimize(sc, s7_list(sc, 1, s7_list(sc, 1, symbol)));
+fprintf(stderr, "%f\n", func(sc));
+
+

+Finally, the begin_hook +functions are explained above. +

+ + +

+ + + +
s7 examples
+ +

The s7 tarball includes several scheme files: +

+
    +
  • case.scm provides case*, an extension of case for pattern matching +
  • cload.scm is a wrapper for the FFI stuff described above +
  • debug.scm provides various debugging aids such as trace, break, and watch +
  • json.scm is a JSON reader/writer, but I got side-tracked +
  • lint.scm is the s7 equivalent of the ancient C program named lint (modern equivalent: cppcheck) +
  • loop.scm is Rick Taube's CL loop macro +
  • mockery.scm has mock data libraries (openlets masquerading as various data types) +
  • profile.scm is a profiler +
  • r7rs.scm implements some of r7rs-small +
  • reactive.scm implements some reactive programming macros (set!, let) +
  • repl.scm is a vt-100 based repl +
  • nrepl.scm is a notcurses based repl +
  • s7test.scm is a regression test for s7 +
  • stuff.scm is just some arbitrary stuff +
  • write.scm has a pretty printer +
+

+libc.scm, libgsl.scm, libm.scm, libdl.scm, notcurses_s7.c, libutf8proc.scm, and libgdbm.scm tie the associated +libraries into s7. +gdbinit has some gdb commands for s7. +

+ + +

cload.scm

+ +

cload.scm defines the macro c-define that reduces the overhead +involved in (dynamically) linking C entities into s7. +

+ +
(c-define c-info (prefix "") (headers ()) (cflags "") (ldflags "") output-name)
+
+ +

For example, (c-define '(double j0 (double)) "m" "math.h") +links the C math library function j0 into s7 under the name m:j0, +passing it a double argument and getting a double result (a real in s7). +

+ +

prefix is some arbitrary prefix that you want prepended to various names. +

+ +

headers is a list of headers (as strings) that the c-info relies on, (("math.h") for example). +

+ +

cflags are any special C compiler flags that are needed ("-I." in particular), and +ldflags is the similar case for the loader. output-name is the name of the +output C file and associated library. It defaults to "temp-s7-output" followed by a number. +In libm.scm, it is set to "libm_s7" to protect it across cload calls. If cload finds an +up-to-date output C file and shared library, it simply loads the library, rather than +going through all the trouble of writing and compling it. +

+ +

c-info is a list that describes the C entities that you want to load into s7. +It can be either one list describing one entity, or a list of such lists. +Each description has the form: +

+ +
(return-type entity-name-in-C (argument-type...))
+
+ +

where each entry is a symbol, and C names are used throughout. So, in the j0 +example above, (double j0 (double)) says we want access to j0, it returns +a C double, and it takes one argument, also a C double. s7 tries to figure out +what the corresponding s7 type is, but in tricky cases, you should tell it +by replacing the bare type name with a list: (C-type underlying-C-type). For example, +the Snd function set_graph_style takes an (enum) argument of type graph_style_t. +This is actually an int, so we use (graph_style_t int) as the type: +

+ +
(void set_graph_style ((graph_style_t int)))
+
+ +

If the C entity is a constant, then the descriptor list has just two entries, +the C-type and the entity name: (int F_OK) for example. The entity name can also be a list: +

+ +
((graph_style_t int) (GRAPH_LINES GRAPH_DOTS GRAPH_FILLED GRAPH_DOTS_AND_LINES GRAPH_LOLLIPOPS))
+
+ +

This defines all the names in the list as integers. +If the C type has a space ("struct tm*"), use (symbol "struct tm*") +to construct the corresponding symbol. +

+ +

The entity is placed in the current s7 environment under the name (string-append prefix ":" name) +where the ":" is omitted if the prefix is null. So in the j0 example, we get in s7 the function m:j0. +c-define returns #t if it thinks the load worked, and #f otherwise. +

+ +

There are times when the only straightforward approach is to write the desired +C code directly. To insert C code on the fly, use (in-C "code..."). Two more such +cases that come up all the time: C-function for linkage to functions written +directly in s7 style using in-C, and C-macro for macros in the C header file that +need to be wrapped in #ifdefs. +Here are some examples: +

+ +
;;; various math library functions
+(c-define '((double j0 (double)) 
+            (double j1 (double)) 
+            (double erf (double)) 
+            (double erfc (double))
+            (double lgamma (double)))
+          "m" "math.h")
+
+
+;;; getenv and setenv
+(c-define '(char* getenv (char*)))
+(c-define '(int setenv (char* char* int)))
+
+
+;;; file-exists? and delete-file
+(define file-exists? (let () ; define F_OK and access only within this let
+                       (c-define '((int F_OK) (int access (char* int))) "" "unistd.h") 
+                       (lambda (arg) (= (access arg F_OK) 0))))
+
+(define delete-file (let () 
+                      (c-define '(int unlink (char*)) "" "unistd.h") 
+                      (lambda (file) (= (unlink file) 0)))) ; 0=success
+
+
+;;; examples from Snd:
+(c-define '(char* version_info ()) "" "snd.h" "-I.")
+
+(c-define '(mus_float_t mus_degrees_to_radians (mus_float_t)) "" "snd.h" "-I.")
+
+(c-define '(snd_info* any_selected_sound ()) "" "snd.h" "-I.")
+(c-define '(void select_channel (snd_info* int)) "" "snd.h" "-I.")
+
+(c-define '(((graph_style_t int) (GRAPH_LINES GRAPH_DOTS GRAPH_FILLED GRAPH_DOTS_AND_LINES GRAPH_LOLLIPOPS)) 
+            (void set_graph_style ((graph_style_t int)))) 
+          "" "snd.h" "-I.")
+   
+
+;;; getcwd, strftime
+(c-define '(char* getcwd (char* size_t)) "" "unistd.h")
+
+(c-define (list '(void* calloc (size_t size_t))
+	        '(void free (void*))
+	        '(void time (time_t*)) ; ignore returned value
+	        (list (symbol "struct tm*") 'localtime '(time_t*))
+                (list 'size_t 'strftime (list 'char* 'size_t 'char* (symbol "struct tm*"))))
+          "" "time.h")
+
+> (let ((p (calloc 1 8)) 
+        (str (make-string 32)))
+    (time p) 
+    (strftime str 32 "%a %d-%b-%Y %H:%M %Z" (localtime p))
+    (free p) 
+    str)
+"Sat 11-Aug-2012 08:55 PDT\x00      "
+
+
+;;; opendir, read_dir, closedir
+(c-define '((int closedir (DIR*))
+	    (DIR* opendir (char*))
+	    (in-C "static char *read_dir(DIR *p)  \
+                   {                              \
+                     struct dirent *dirp;          \
+                     dirp = readdir(p);            \
+                     if (!dirp) return(NULL);      \
+                     return(dirp->d_name);         \
+                   }")
+	    (char* read_dir (DIR*)))
+  "" '("sys/types.h" "dirent.h"))
+
+ +

C-init inserts its string argument into the initialization section of +the module. In libgsl.scm, for example, +

+
(C-init "gsl_set_error_handler(g_gsl_error);")
+
+

inserts that string (as C code) into libgsl_s7.c toward the beginning of the +libgsl_s7_init function (line 42346 or so). +

+ +

When compiling, for the simple cases above, include "-ldl -Wl,-export-dynamic" in the gcc command. So the first +FFI example is built (this is in Linux): +

+ +
gcc -c s7.c -I.
+gcc -o ex1 ex1.c s7.o -lm -I. -ldl -Wl,-export-dynamic
+ex1
+> (load "cload.scm")
+c-define-1
+> (c-define '(double j0 (double)) "m" "math.h")
+#t
+> (m:j0 0.5)
+0.93846980724081
+
+ +

See also r7rs.scm, libc.scm, libgsl.scm, libm.scm, libdl.scm, and libgdbm.scm. +libutf8proc.scm exists, but I have not tested it at all. +

+ +

The default in the lib*.scm files is to use the C name as the Scheme name. +This collides with (for example) the widespread use of "-", rather than "_" in Scheme, but +I have found it much more straightforward to stick with one name. In cases like +libgsl there are thousands of names, all documented at great length +by the C name. Anyone who wants to use these functions has to start with the C name. +If they are forced to fuss with some annoying Schemely translation of it, +the only sane response is: "forget it! I'll do it in C". +

+ +
+
(require libc.scm)
+
+(define (copy-file in-file out-file)
+  (with-let (sublet *libc* :in-file in-file :out-file out-file)
+
+    ;; the rest of the function body exists in the *libc* environment, with the
+    ;;   function parameters in-file and out-file imported, so, for example,
+    ;;   (open ...) below calls the libc function open.  
+
+    (let ((infd (open in-file O_RDONLY 0)))
+      (if (= infd -1)
+	  (error 'io-error "can't find ~S~%" in-file)
+	  (let ((outfd (creat out-file #o666)))
+	    (if (= outfd -1)
+		(begin
+		  (close infd)
+		  (error 'io-error "can't open ~S~%" out-file))
+		(let* ((BUF_SIZE 1024)
+                       (buf (malloc BUF_SIZE)))
+		  (do ((num (read infd buf BUF_SIZE) (read infd buf BUF_SIZE)))
+		      ((or (<= num 0)
+			   (not (= (write outfd buf num) num)))))
+		  (close outfd)
+		  (close infd)
+		  (free buf)
+		  out-file)))))))
+
+(define (glob->list pattern)
+  (with-let (sublet *libc* :pattern pattern)
+    (let ((g (glob.make))) 
+      (glob pattern 0 g) 
+      (let ((res (glob.gl_pathv g))) 
+	(globfree g) 
+	res))))
+
+;; now (load "*.scm") is (for-each load (glob->list "*.scm")) 
+
+;; a couple regular expression examples
+(with-let (sublet *libc*)
+  (define rg (regex.make))
+  (regcomp rg "a.b" 0)
+  (display (regexec rg "acb" 0 0)) (newline) ; 0 = match
+  (regfree rg))
+
+(with-let (sublet *libc*)
+  (define rg (regex.make))
+  (let ((res (regcomp rg "colou\\?r" 0)))
+    (if (not (zero? res))
+	(error 'regex-error "~S: ~S~%" "colou\\?r" (regerror res rg)))
+    (set! res (regexec rg "The color green" 1 0))
+    (display res) (newline)                ; #i(4 9) = match start/end
+    (regfree rg)))
+
+
+ + +
+
(require libgsl.scm)
+
+(define (eigenvalues M)
+  (with-let (sublet *libgsl* :M M)
+    (let* ((len (sqrt (length M)))
+	   (gm (gsl_matrix_alloc len len))
+	   (m (float-vector->gsl_matrix M gm))
+	   (evl (gsl_vector_complex_alloc len))
+	   (evc (gsl_matrix_complex_alloc len len))
+	   (w (gsl_eigen_nonsymmv_alloc len)))
+      
+      (gsl_eigen_nonsymmv m evl evc w)
+      (gsl_eigen_nonsymmv_free w)
+      (gsl_eigen_nonsymmv_sort evl evc GSL_EIGEN_SORT_ABS_DESC)
+      
+      (let ((vals (make-vector len)))
+	(do ((i 0 (+ i 1)))
+	    ((= i len))
+	  (set! (vals i) (gsl_vector_complex_get evl i)))
+	(gsl_matrix_free gm)
+	(gsl_vector_complex_free evl)
+	(gsl_matrix_complex_free evc)
+	vals))))
+
+
+ +

We can use gdbm (or better yet, mdb), the :readable argument to object->string, and +the fallback methods in the environments to create name-spaces (lets) with billions of +thread-safe local variables, which can be saved and communicated between s7 runs: +

+
+
(require libgdbm.scm)
+
+(with-let *libgdbm*
+
+  (define *db* 
+    (openlet 
+     (inlet :file (gdbm_open "test.gdbm" 1024 GDBM_NEWDB #o664 
+		    (lambda (str) (format *stderr* "gdbm error: ~S~%" str)))
+
+	    :let-ref-fallback (lambda (obj sym)
+				(eval-string (gdbm_fetch (obj 'file) (symbol->string sym))))
+	    
+	    :let-set-fallback (lambda (obj sym val)
+				 (gdbm_store (obj 'file)
+					     (symbol->string sym)
+					     (object->string val :readable)
+					     GDBM_REPLACE)
+				 val)
+	    
+	    :make-iterator (lambda (obj)
+			     (let ((key #f)
+				   (length (lambda (obj) (expt 2 20))))
+			       (#_make-iterator
+                                (let ((+iterator+ #t))
+				  (openlet 
+				   (lambda ()
+				     (if key
+				         (set! key (gdbm_nextkey (obj 'file) (cdr key)))
+				         (set! key (gdbm_firstkey (obj 'file))))
+				     (if (pair? key)
+				         (cons (string->symbol (car key))
+					       (eval-string (gdbm_fetch (obj 'file) (car key))))
+				         key))))))))))
+
+  (set! (*db* 'str) "123") ; add a variable named 'str with the value "123"
+  (set! (*db* 'int) 432)
+
+  (with-let *db* 
+    (+ int (length str)))    ; -> 435
+  (map values *db*)          ; -> '((str . "123") (int . 432))
+
+  (gdbm_close (*db* 'file)))
+
+ + +
+ + + +

case.scm

+ +

case.scm has case*, a compatible extension of case that includes pattern matching. +(case* selector ((target...) body) ...) uses equivalent? to match the +selector to the targets, evaluating the body associated with the first matching target. +If a target is a list or vector, the elements are checked item by item. +Each target, or element of a list or vector can be a pattern. Patterns +are of the form #<whatever> (undefined constants from s7's pointer of view). +A pattern can be: +

+
    
+
  • #<>               any expr matches
+
  • #<func>           expr matches if (func expr)
+
  • #<label:func>     expr matches as above, expr is saved under "label"
+
  • #<label:>         any expr matches, and is saved under "label"
+
  • #<label>          expr must match the value saved under "label"
+
  • #<...>            skip exprs covered by the ellipsis
+
  • #<label:...>      skip as above, saved skipped exprs under "label" as a quoted list.
+
  •                   a pattern can have any number of labelled ellipses overall, 
+
  •                   but just one unnamed ellipsis, and only one ellipsis per pair or vector
+
  • #<label,func:...> a labelled ellipsis which matches if (func expr); expr is the ellipsis list,
+
  •                   label is not optional in this case
+
  • #<"regexp">       pattern is a regular expression to be matched against a string
+
  • #<label:"regexp"> a labelled regular expression
+

+
+ +

If a label occurs in the result body, the expression it labelled is substituted for it. +

+ +
(case* x ((3.14) 'pi))                ; returns 'pi if x is 3.14
+
+(case* x ((#<symbol?>)))              ; returns #t if x is a symbol
+
+(case* x (((+ 1 #<symbol?>))))        ; matches any list of the form '(+ 1 x) or any symbol in place of "x"
+
+(case* x (((#<symbol?> #<e1:...> (+ #<e2:...>)))
+          (append #<e1> #<e2>)))      ;  passed '(a b c d (+ 1 2)), returns '(b c d 1 2)
+
+(case* x ((#<"a.b">)))                ; matches if x is a string "a.b" where "." matches anything
+
+(define (palindrome? x)
+  (case* x
+    ((() (#<>)) 
+     #t)
+    (((#<start:> #<middle:...> #<start>)) 
+     (palindrome? #<middle>))
+    (else #f)))
+
+ +

case*'s matching function can be used anywhere. +

+ +
(let ((match? ((funclet 'case*) 'case*-match?))) ; this is case*'s matcher
+  (match? x '(+ #<symbol?> 1)))                  ; returns #t if x is of the form '(+ x 1), x any symbol
+
+(define match+
+  (let ((match? ((funclet 'case*) 'case*-match?))
+	(labels ((funclet 'case*) 'case*-labels))) ; these are the labels and their values
+    (macro (arg)
+      (cond ((null? arg) ())
+	    ((match? arg '(+ #<a:> (+ #<b:...>))) `(+ ,(labels 'a) ,@(cadr (labels 'b))))
+	    ((match? arg '(+ #<> #<>)) `(+ ,@(cdr arg)))
+	    (else #f)))))
+
+  ;; (match+ (+ 1 (+ 2 3))) -> 6
+
+ +

See case.scm and s7test.scm for many more examples, including let and hash-table matching. +

+ + +

debug.scm

+ +

debug.scm has various debugging aids, including trace, break, watch, and a C-style stacktrace. +The *s7* field 'debug controls when these are active, and to what extent. +

+ +

(trace func) adds a tracepoint to the start of the function or macro func. +(trace) adds such tracing to every subsequently defined function or macro. +(untrace) turns off tracing; (untrace func) turns off tracing in func. +Similarly (break func) places a breakpoint at the start of func, +(unbreak func) removes it. (unbreak) removes all breakpoints. +When a breakpoint is encountered, you are placed in a repl at +that point; type C-q to continue. To trace a variable, use +(watch var). watch reports whenever var is set! and +(unwatch var) removes the watchpoint. +

+ +

+These trace, break and watchpoints are active +only if (*s7* 'debug) is positive. If 'debug is 1, existing traces +and breaks are active, but no new ones are added by s7. If 'debug +is 2, s7 adds tracepoints to any subsequently defined (i.e. named) functions and macros. +If (*s7* 'debug) is 3, unnamed functions are also traced. +If any tracing is enabled, you can get a C-style stacktrace by +setting (debug-stack) to a vector, then +call (show-debug-stack) to see the calls. +

+ +

+Besides debug-stack, debug.scm also defines the convenience functions +debug-function, debug-port, and +debug-repl. debug-port is the debugger's +output port, debug-repl drops into a repl at a breakpoint, and debug-function +provides a way to customize the debugger's behavior. +The function debug-frame provides a way to examine local variables. +

+ +
> (define (g1 x) (+ x 1))
+g1
+> (trace g1)   ; this loads debug.scm unless it's already loaded, and sets (*s7* 'debug) to 1
+g1
+> (procedure-source g1) ; you can add trace-in explicitly (rather than call trace)
+(lambda (x) (trace-in (curlet)) (+ x 1))
+> (g1 2)
+(g1 2)         ; file/line info is included if relevant
+  -> 3
+3
+> (break g1)
+g1
+> (g1 3)
+break: (g1 3), C-q to exit break
+break> x       ; this is a repl started at the breakpoint
+3
+break>  -> 4   ; C-q typed to exit the break
+4
+> (define var 1)
+1
+> (watch var)
+#<lambda (s v ...)>  ; this is the new setter for 'var
+> (set! var 3)
+var set! to 3
+3
+> (define lt (inlet 'a 3))
+(inlet 'a 3)
+> (watch (lt 'a))
+#<lambda (s v ...)>
+> (set! (lt 'a) 12)
+let-set! a to 12
+12
+
+ +

s7test.scm has more examples

+ + + +

lint.scm

+ +

lint tries to find errors or infelicities in your scheme code. +To try it: +

+ +
(load "lint.scm")
+(lint "some-code.scm")
+
+ + +

+There are several +variables at the start of lint.scm to control additional output: +

+ + +
*report-unused-parameters*
+*report-unused-top-level-functions*
+*report-shadowed-variables*
+*report-undefined-identifiers*
+*report-multiply-defined-top-level-functions*
+*report-nested-if*
+*report-short-branch*
+*report-one-armed-if*
+*report-loaded-files*
+*report-any-!-as-setter*
+*report-doc-strings*
+*report-func-as-arg-arity-mismatch*
+*report-bad-variable-names*
+*report-built-in-functions-used-as-variables*
+*report-forward-functions*
+*report-sloppy-assoc*
+*report-bloated-arg*
+*report-clobbered-function-return-value*
+*report-boolean-functions-misbehaving*
+*report-repeated-code-fragments*
+*report-quasiquote-rewrites*
+*report-combinable-lets*
+
+ +

See lint.scm for more about these switches. You can also extend lint by adding your own code, +or adding your functions to lint's tables, or most simply by defining signatures for your functions. +snd-lint.scm performs these tasks for Snd. (lint exports its innards via *lint*). +lint is not smart about functions defined outside the current file, so *report-undefined-variables* +sometimes gets confused. You'll sometimes get a recommendation from lint that is less than helpful; nobody's perfect. +If it's actually wrong, and not just wrong-headed, please let me know. +Also in lint.scm are html-lint and C-lint. html-lint reads an HTML file looking for +Scheme code. If any is found, it runs s7 and then lint over it, reporting troubles. +Similarly C-lint reads a C file looking for s7_eval_c_string and running lint over its string. +

+ +

repl.scm and nrepl.scm

+ +

There are three or four repls included with s7. +repl.scm is a textual interface based on vt-100 codes, and nrepl.scm is an +improvement of repl.scm based on the notcurses-core library. +I'll treat repl.scm first, then discuss how nrepl differs from it. +

+ +
+ +

repl.scm implements a repl using vt100 codes and libc.scm. It includes +symbol and filename completion, a history buffer, paren matching, +indentation, multi-line edits, and a debugger window. +To move around in the history buffer, use M-p, M-n or M-. (C-p and C-n are used to move the cursor in the current expression). +You can change the keymap or the prompt; all the repl functions are +accessible through the *repl* environment. One field is 'repl-let which +gives you access to all the repl's internal variables and functions. +Another is 'top-level-let, normally (sublet (rootlet)), which is the environment in +which the repl's evaluation takes place. You can reset the repl back to its +starting point with: (set! (*repl* 'top-level-let) (sublet (rootlet))). +You can save the current repl state via ((*repl* 'save-repl)), and +restore it later via ((*repl* 'restore-repl)). The repl's saved state +is in the file save.repl, or the filename can be passed as an argument to save-repl and restore-repl. +

+ +

There is one annoying consequence of using (sublet (rootlet)) for the top-level let: +if you define something in the repl, then load a file that expects to find that thing +in rootlet, it won't: +

+
<1> (define (func x) (+ x 1)) ; func is in (sublet (rootlet))
+func
+<2> (load "use-func.scm") ; file contents: (display (func 3))
+error: unbound variable func
+
+

To get around this, either load the file into curlet: (load "use-func.scm" (curlet)), +or use with-let to place the definition in rootlet: (with-let (curlet) (define (func x) (+ x 1))). +

+ +

Meta keys are a problem on the Mac. You can use ESC instead, but that requires +super-human capacities. I stared at replacement control keys, and nothing seemed +right. If you can think of something, it's easy to define replacements: see repl.scm +which has a small table of mappings. +

+ +

To run the repl, either build s7 with the compiler flag -DWITH_MAIN, +or conjure up a wrapper: +

+ +
#include "s7.h"
+
+int main(int argc, char **argv)
+{
+  s7_scheme *sc;
+  sc = s7_init();
+  s7_load(sc, "repl.scm");
+  s7_eval_c_string(sc, "((*repl* 'run))");
+  return(0);
+}
+
+/* gcc -o r r.c s7.o -Wl,-export-dynamic -lm -I. -ldl
+ */
+
+ +

Besides evaluating s7 expressions, like any repl, +you can also type shell commands just as in a shell: +

+ +
<1> pwd
+/home/bil/cl
+<2> cd ..
+/home/bil
+<3> date
+Wed 15-Apr-2015 17:32:24 PDT
+
+ +

In most cases, these are handled through *unbound-variable-hook*, checked using "command -v", then passed +to the underlying shell via the system function. +

+ +

The prompt is set by the function (*repl* 'prompt). It gets one argument, +the current line number, and should set the prompt string and its length. +

+
(set! (*repl* 'prompt) (lambda (num) 
+			 (with-let (*repl* 'repl-let)
+			   (set! prompt-string "scheme> ") 
+			   (set! prompt-length (length prompt-string)))))
+
+

or, to use the red lambda example mentioned earlier: +

+
(set! (*repl* 'prompt)
+      (lambda (num)
+	(with-let (*repl* 'repl-let)
+	  (set! prompt-string (bold (red (string #\xce #\xbb #\> #\space))))
+	  (set! prompt-length 3)))) ; until we get unicode length calc
+
+ +

The line number provides a quick way to move around in the history buffer. +To get a previous line without laboriously typing M-p over and over, +simply type the line number (without control or meta bits), then M-. +In some CL repls, the special variable '* holds the last value computed. +In repl.scm, each value is retained in variables of the form '<n> where n +is the number shown in the prompt. +

+ +
<1> (+ 1 2)
+3
+<2> (* <1> 2)
+6
+
+ +

Here is an example of adding to the keymap: +

+
(set! ((*repl* 'keymap) (integer->char 17)) ; C-q to quit and return to caller
+      (lambda (c)
+	(set! ((*repl* 'repl-let) 'all-done) #t)))
+
+ +

To access the meta keys (in the keymap), use a string: +((*repl* 'keymap) (string #\escape #\p)); this is Meta-p which normally accesses +the history buffer. +

+ +

You can call the repl from other code, poke around in the current environment (or whatever), +then return to the caller: +

+ +
(load "repl.scm")
+
+(define (drop-into-repl e)
+  (let ((C-q (integer->char 17)))              ; we'll use the C-q example above to get out
+    (let ((old-C-q ((*repl* 'keymap) C-q))
+	  (old-top-level (*repl* 'top-level-let)))
+      (dynamic-wind
+	  (lambda ()
+	    (set! (*repl* 'top-level-let) e)
+	    (set! ((*repl* 'keymap) C-q)       
+		  (lambda (c)
+		    (set! ((*repl* 'repl-let) 'all-done) #t))))
+	  (lambda ()
+	    ((*repl* 'run)))                   ; run the repl
+	  (lambda ()
+	    (set! (*repl* 'top-level-let) old-top-level)
+	    (set! ((*repl* 'keymap) C-q) old-C-q))))))
+
+(let ((x 32))
+  (format *stderr* "x: ~A~%" x)
+  (drop-into-repl (curlet))
+  (format *stderr* "now x: ~A~%" x))
+
+ +

Now load that code and: +

+ +
x: 32
+<1> x
+32
+<2> (set! x 91)
+91
+<3> x
+91
+<4> now x: 91  ; here I typed C-q at the prompt
+
+ +

Another possibility: +

+
(set! (hook-functions *error-hook*) 
+      (list (lambda (hook) 
+              (apply format *stderr* (hook 'data)) 
+              (newline *stderr*)
+	      (drop-into-repl (owlet)))))
+
+ +

See the end of repl.scm for more examples. See nrepl.scm for a better version of repl.scm. +Eventually I'll probably retire repl.scm. +

+ + + + +
+ +

Unlike repl, nrepl has support for the mouse, traversable, scrollable, and resizable panes, built-in ties to +lint.scm, debug.scm, and profile.scm, and various other enhancements. +Since it includes all the libc, notcurses FFI code, and nrepl.scm at compile-time, there +are no problems running it anywhere. To build nrepl: +

+
gcc -o nrepl s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl -DWITH_MAIN -DWITH_NOTCURSES -lnotcurses-core
+
+

If that is too easy, try: +

+
gcc -c s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl
+gcc -o nrepl nrepl.c s7.o -lnotcurses-core -lm -I. -ldl
+
+

notcurses_s7.c needs version 2.1.6 or later of the notcurses-core library. +

+ +

When nrepl starts up, you have a prompt at the top of the terminal, and a status box +at the bottom. You can move around the pane via C-p and C-n (no need for repl.scm's M-p and M-n), +or use the mouse, or the arrow keys. If you set and hit a break point, a new pane is +opened in the context of the break. C-q exits the break. At the top pane, C-q exits +nrepl. C-g gives you another prompt (handy if you're caught in a messed up expression). +If you're in an infinite loop, C-c interrupts it. Otherwise C-c exits nrepl. +

+ +

If you set up a watcher (via watch from debug.scm), the action is displayed in +a separate box in the upper right corner. The status box displays all sorts of +informative and helpful messages, or at least that is the intent. lint.scm +checks each expression you type, and various hooks let you know when things +are happening in the background. Function signatures are posted there as well. +

+ +

You can customize nrepl in basically the same ways as described above for repl.scm. +You can also place these in a file named ".nrepl"; if nrepl finds such a file, it +loads it automatically at startup. +

+ +
+
+
+

After months of intense typing, +Insanely declares his labors complete. "Ship it!" says Mr Big, and hands +him a million stock options. Meanwhile, in the basement behind an old door +with the eldritch sign "eep Ou", in a labyrinth of pounding pipes and fluorescent lights, +a forgotten shadow types (lint "insanely-great.scm")... +

+
+
+ + + + + \ No newline at end of file diff --git a/source/engine/thirdparty/sqlite3/README.txt b/source/engine/thirdparty/sqlite3/README.txt new file mode 100644 index 0000000..6e62a4e --- /dev/null +++ b/source/engine/thirdparty/sqlite3/README.txt @@ -0,0 +1,113 @@ +This package contains: + + * the SQLite library amalgamation source code file: sqlite3.c + * the sqlite3.h and sqlite3ext.h header files that define the C-language + interface to the sqlite3.c library file + * the shell.c file used to build the sqlite3 command-line shell program + * autoconf/automake installation infrastucture for building on POSIX + compliant systems + * a Makefile.msc, sqlite3.rc, and Replace.cs for building with Microsoft + Visual C++ on Windows + +SUMMARY OF HOW TO BUILD +======================= + + Unix: ./configure; make + Windows: nmake /f Makefile.msc + +BUILDING ON POSIX +================= + +The generic installation instructions for autoconf/automake are found +in the INSTALL file. + +The following SQLite specific boolean options are supported: + + --enable-readline use readline in shell tool [default=yes] + --enable-threadsafe build a thread-safe library [default=yes] + --enable-dynamic-extensions support loadable extensions [default=yes] + +The default value for the CFLAGS variable (options passed to the C +compiler) includes debugging symbols in the build, resulting in larger +binaries than are necessary. Override it on the configure command +line like this: + + $ CFLAGS="-Os" ./configure + +to produce a smaller installation footprint. + +Other SQLite compilation parameters can also be set using CFLAGS. For +example: + + $ CFLAGS="-Os -DSQLITE_THREADSAFE=0" ./configure + + +BUILDING WITH MICROSOFT VISUAL C++ +================================== + +To compile for Windows using Microsoft Visual C++: + + $ nmake /f Makefile.msc + +Using Microsoft Visual C++ 2005 (or later) is recommended. Several Windows +platform variants may be built by adding additional macros to the NMAKE +command line. + +Building for WinRT 8.0 +---------------------- + + FOR_WINRT=1 + +Using Microsoft Visual C++ 2012 (or later) is required. When using the +above, something like the following macro will need to be added to the +NMAKE command line as well: + + "NSDKLIBPATH=%WindowsSdkDir%\..\8.0\lib\win8\um\x86" + +Building for WinRT 8.1 +---------------------- + + FOR_WINRT=1 + +Using Microsoft Visual C++ 2013 (or later) is required. When using the +above, something like the following macro will need to be added to the +NMAKE command line as well: + + "NSDKLIBPATH=%WindowsSdkDir%\..\8.1\lib\winv6.3\um\x86" + +Building for UWP 10.0 +--------------------- + + FOR_WINRT=1 FOR_UWP=1 + +Using Microsoft Visual C++ 2015 (or later) is required. When using the +above, something like the following macros will need to be added to the +NMAKE command line as well: + + "NSDKLIBPATH=%WindowsSdkDir%\..\10\lib\10.0.10586.0\um\x86" + "PSDKLIBPATH=%WindowsSdkDir%\..\10\lib\10.0.10586.0\um\x86" + "NUCRTLIBPATH=%UniversalCRTSdkDir%\..\10\lib\10.0.10586.0\ucrt\x86" + +Building for the Windows 10 SDK +------------------------------- + + FOR_WIN10=1 + +Using Microsoft Visual C++ 2015 (or later) is required. When using the +above, no other macros should be needed on the NMAKE command line. + +Other preprocessor defines +-------------------------- + +Additionally, preprocessor defines may be specified by using the OPTS macro +on the NMAKE command line. However, not all possible preprocessor defines +may be specified in this manner as some require the amalgamation to be built +with them enabled (see http://www.sqlite.org/compile.html). For example, the +following will work: + + "OPTS=-DSQLITE_ENABLE_STAT4=1 -DSQLITE_ENABLE_JSON1=1" + +However, the following will not compile unless the amalgamation was built +with it enabled: + + "OPTS=-DSQLITE_ENABLE_UPDATE_DELETE_LIMIT=1" diff --git a/source/engine/thirdparty/sqlite3/shell.c b/source/engine/thirdparty/sqlite3/shell.c new file mode 100644 index 0000000..1d0c139 --- /dev/null +++ b/source/engine/thirdparty/sqlite3/shell.c @@ -0,0 +1,22857 @@ +/* DO NOT EDIT! +** This file is automatically generated by the script in the canonical +** SQLite source tree at tool/mkshellc.tcl. That script combines source +** code from various constituent source files of SQLite into this single +** "shell.c" file used to implement the SQLite command-line shell. +** +** Most of the code found below comes from the "src/shell.c.in" file in +** the canonical SQLite source tree. That main file contains "INCLUDE" +** lines that specify other files in the canonical source tree that are +** inserted to getnerate this complete program source file. +** +** The code from multiple files is combined into this single "shell.c" +** source file to help make the command-line program easier to compile. +** +** To modify this program, get a copy of the canonical SQLite source tree, +** edit the src/shell.c.in" and/or some of the other files that are included +** by "src/shell.c.in", then rerun the tool/mkshellc.tcl script. +*/ +/* +** 2001 September 15 +** +** The author disclaims copyright to this source code. In place of +** a legal notice, here is a blessing: +** +** May you do good and not evil. +** May you find forgiveness for yourself and forgive others. +** May you share freely, never taking more than you give. +** +************************************************************************* +** This file contains code to implement the "sqlite" command line +** utility for accessing SQLite databases. +*/ +#if (defined(_WIN32) || defined(WIN32)) && !defined(_CRT_SECURE_NO_WARNINGS) +/* This needs to come before any includes for MSVC compiler */ +#define _CRT_SECURE_NO_WARNINGS +#endif + +/* +** Optionally #include a user-defined header, whereby compilation options +** may be set prior to where they take effect, but after platform setup. +** If SQLITE_CUSTOM_INCLUDE=? is defined, its value names the #include +** file. Note that this macro has a like effect on sqlite3.c compilation. +*/ +#ifdef SQLITE_CUSTOM_INCLUDE +# define INC_STRINGIFY_(f) #f +# define INC_STRINGIFY(f) INC_STRINGIFY_(f) +# include INC_STRINGIFY(SQLITE_CUSTOM_INCLUDE) +#endif + +/* +** Determine if we are dealing with WinRT, which provides only a subset of +** the full Win32 API. +*/ +#if !defined(SQLITE_OS_WINRT) +# define SQLITE_OS_WINRT 0 +#endif + +/* +** Warning pragmas copied from msvc.h in the core. +*/ +#if defined(_MSC_VER) +#pragma warning(disable : 4054) +#pragma warning(disable : 4055) +#pragma warning(disable : 4100) +#pragma warning(disable : 4127) +#pragma warning(disable : 4130) +#pragma warning(disable : 4152) +#pragma warning(disable : 4189) +#pragma warning(disable : 4206) +#pragma warning(disable : 4210) +#pragma warning(disable : 4232) +#pragma warning(disable : 4244) +#pragma warning(disable : 4305) +#pragma warning(disable : 4306) +#pragma warning(disable : 4702) +#pragma warning(disable : 4706) +#endif /* defined(_MSC_VER) */ + +/* +** No support for loadable extensions in VxWorks. +*/ +#if (defined(__RTP__) || defined(_WRS_KERNEL)) && !SQLITE_OMIT_LOAD_EXTENSION +# define SQLITE_OMIT_LOAD_EXTENSION 1 +#endif + +/* +** Enable large-file support for fopen() and friends on unix. +*/ +#ifndef SQLITE_DISABLE_LFS +# define _LARGE_FILE 1 +# ifndef _FILE_OFFSET_BITS +# define _FILE_OFFSET_BITS 64 +# endif +# define _LARGEFILE_SOURCE 1 +#endif + +#include +#include +#include +#include +#include "sqlite3.h" +typedef sqlite3_int64 i64; +typedef sqlite3_uint64 u64; +typedef unsigned char u8; +#if SQLITE_USER_AUTHENTICATION +# include "sqlite3userauth.h" +#endif +#include +#include + +#if !defined(_WIN32) && !defined(WIN32) +# include +# if !defined(__RTP__) && !defined(_WRS_KERNEL) +# include +# endif +#endif +#if (!defined(_WIN32) && !defined(WIN32)) || defined(__MINGW32__) +# include +# include +# define GETPID getpid +# if defined(__MINGW32__) +# define DIRENT dirent +# ifndef S_ISLNK +# define S_ISLNK(mode) (0) +# endif +# endif +#else +# define GETPID (int)GetCurrentProcessId +#endif +#include +#include + +#if HAVE_READLINE +# include +# include +#endif + +#if HAVE_EDITLINE +# include +#endif + +#if HAVE_EDITLINE || HAVE_READLINE + +# define shell_add_history(X) add_history(X) +# define shell_read_history(X) read_history(X) +# define shell_write_history(X) write_history(X) +# define shell_stifle_history(X) stifle_history(X) +# define shell_readline(X) readline(X) + +#elif HAVE_LINENOISE + +# include "linenoise.h" +# define shell_add_history(X) linenoiseHistoryAdd(X) +# define shell_read_history(X) linenoiseHistoryLoad(X) +# define shell_write_history(X) linenoiseHistorySave(X) +# define shell_stifle_history(X) linenoiseHistorySetMaxLen(X) +# define shell_readline(X) linenoise(X) + +#else + +# define shell_read_history(X) +# define shell_write_history(X) +# define shell_stifle_history(X) + +# define SHELL_USE_LOCAL_GETLINE 1 +#endif + + +#if defined(_WIN32) || defined(WIN32) +# if SQLITE_OS_WINRT +# define SQLITE_OMIT_POPEN 1 +# else +# include +# include +# define isatty(h) _isatty(h) +# ifndef access +# define access(f,m) _access((f),(m)) +# endif +# ifndef unlink +# define unlink _unlink +# endif +# ifndef strdup +# define strdup _strdup +# endif +# undef popen +# define popen _popen +# undef pclose +# define pclose _pclose +# endif +#else + /* Make sure isatty() has a prototype. */ + extern int isatty(int); + +# if !defined(__RTP__) && !defined(_WRS_KERNEL) + /* popen and pclose are not C89 functions and so are + ** sometimes omitted from the header */ + extern FILE *popen(const char*,const char*); + extern int pclose(FILE*); +# else +# define SQLITE_OMIT_POPEN 1 +# endif +#endif + +#if defined(_WIN32_WCE) +/* Windows CE (arm-wince-mingw32ce-gcc) does not provide isatty() + * thus we always assume that we have a console. That can be + * overridden with the -batch command line option. + */ +#define isatty(x) 1 +#endif + +/* ctype macros that work with signed characters */ +#define IsSpace(X) isspace((unsigned char)X) +#define IsDigit(X) isdigit((unsigned char)X) +#define ToLower(X) (char)tolower((unsigned char)X) + +#if defined(_WIN32) || defined(WIN32) +#if SQLITE_OS_WINRT +#include +#endif +#include + +/* string conversion routines only needed on Win32 */ +extern char *sqlite3_win32_unicode_to_utf8(LPCWSTR); +extern char *sqlite3_win32_mbcs_to_utf8_v2(const char *, int); +extern char *sqlite3_win32_utf8_to_mbcs_v2(const char *, int); +extern LPWSTR sqlite3_win32_utf8_to_unicode(const char *zText); +#endif + +/* On Windows, we normally run with output mode of TEXT so that \n characters +** are automatically translated into \r\n. However, this behavior needs +** to be disabled in some cases (ex: when generating CSV output and when +** rendering quoted strings that contain \n characters). The following +** routines take care of that. +*/ +#if (defined(_WIN32) || defined(WIN32)) && !SQLITE_OS_WINRT +static void setBinaryMode(FILE *file, int isOutput){ + if( isOutput ) fflush(file); + _setmode(_fileno(file), _O_BINARY); +} +static void setTextMode(FILE *file, int isOutput){ + if( isOutput ) fflush(file); + _setmode(_fileno(file), _O_TEXT); +} +#else +# define setBinaryMode(X,Y) +# define setTextMode(X,Y) +#endif + + +/* True if the timer is enabled */ +static int enableTimer = 0; + +/* Return the current wall-clock time */ +static sqlite3_int64 timeOfDay(void){ + static sqlite3_vfs *clockVfs = 0; + sqlite3_int64 t; + if( clockVfs==0 ) clockVfs = sqlite3_vfs_find(0); + if( clockVfs==0 ) return 0; /* Never actually happens */ + if( clockVfs->iVersion>=2 && clockVfs->xCurrentTimeInt64!=0 ){ + clockVfs->xCurrentTimeInt64(clockVfs, &t); + }else{ + double r; + clockVfs->xCurrentTime(clockVfs, &r); + t = (sqlite3_int64)(r*86400000.0); + } + return t; +} + +#if !defined(_WIN32) && !defined(WIN32) && !defined(__minux) +#include +#include + +/* VxWorks does not support getrusage() as far as we can determine */ +#if defined(_WRS_KERNEL) || defined(__RTP__) +struct rusage { + struct timeval ru_utime; /* user CPU time used */ + struct timeval ru_stime; /* system CPU time used */ +}; +#define getrusage(A,B) memset(B,0,sizeof(*B)) +#endif + +/* Saved resource information for the beginning of an operation */ +static struct rusage sBegin; /* CPU time at start */ +static sqlite3_int64 iBegin; /* Wall-clock time at start */ + +/* +** Begin timing an operation +*/ +static void beginTimer(void){ + if( enableTimer ){ + getrusage(RUSAGE_SELF, &sBegin); + iBegin = timeOfDay(); + } +} + +/* Return the difference of two time_structs in seconds */ +static double timeDiff(struct timeval *pStart, struct timeval *pEnd){ + return (pEnd->tv_usec - pStart->tv_usec)*0.000001 + + (double)(pEnd->tv_sec - pStart->tv_sec); +} + +/* +** Print the timing results. +*/ +static void endTimer(void){ + if( enableTimer ){ + sqlite3_int64 iEnd = timeOfDay(); + struct rusage sEnd; + getrusage(RUSAGE_SELF, &sEnd); + printf("Run Time: real %.3f user %f sys %f\n", + (iEnd - iBegin)*0.001, + timeDiff(&sBegin.ru_utime, &sEnd.ru_utime), + timeDiff(&sBegin.ru_stime, &sEnd.ru_stime)); + } +} + +#define BEGIN_TIMER beginTimer() +#define END_TIMER endTimer() +#define HAS_TIMER 1 + +#elif (defined(_WIN32) || defined(WIN32)) + +/* Saved resource information for the beginning of an operation */ +static HANDLE hProcess; +static FILETIME ftKernelBegin; +static FILETIME ftUserBegin; +static sqlite3_int64 ftWallBegin; +typedef BOOL (WINAPI *GETPROCTIMES)(HANDLE, LPFILETIME, LPFILETIME, + LPFILETIME, LPFILETIME); +static GETPROCTIMES getProcessTimesAddr = NULL; + +/* +** Check to see if we have timer support. Return 1 if necessary +** support found (or found previously). +*/ +static int hasTimer(void){ + if( getProcessTimesAddr ){ + return 1; + } else { +#if !SQLITE_OS_WINRT + /* GetProcessTimes() isn't supported in WIN95 and some other Windows + ** versions. See if the version we are running on has it, and if it + ** does, save off a pointer to it and the current process handle. + */ + hProcess = GetCurrentProcess(); + if( hProcess ){ + HINSTANCE hinstLib = LoadLibrary(TEXT("Kernel32.dll")); + if( NULL != hinstLib ){ + getProcessTimesAddr = + (GETPROCTIMES) GetProcAddress(hinstLib, "GetProcessTimes"); + if( NULL != getProcessTimesAddr ){ + return 1; + } + FreeLibrary(hinstLib); + } + } +#endif + } + return 0; +} + +/* +** Begin timing an operation +*/ +static void beginTimer(void){ + if( enableTimer && getProcessTimesAddr ){ + FILETIME ftCreation, ftExit; + getProcessTimesAddr(hProcess,&ftCreation,&ftExit, + &ftKernelBegin,&ftUserBegin); + ftWallBegin = timeOfDay(); + } +} + +/* Return the difference of two FILETIME structs in seconds */ +static double timeDiff(FILETIME *pStart, FILETIME *pEnd){ + sqlite_int64 i64Start = *((sqlite_int64 *) pStart); + sqlite_int64 i64End = *((sqlite_int64 *) pEnd); + return (double) ((i64End - i64Start) / 10000000.0); +} + +/* +** Print the timing results. +*/ +static void endTimer(void){ + if( enableTimer && getProcessTimesAddr){ + FILETIME ftCreation, ftExit, ftKernelEnd, ftUserEnd; + sqlite3_int64 ftWallEnd = timeOfDay(); + getProcessTimesAddr(hProcess,&ftCreation,&ftExit,&ftKernelEnd,&ftUserEnd); + printf("Run Time: real %.3f user %f sys %f\n", + (ftWallEnd - ftWallBegin)*0.001, + timeDiff(&ftUserBegin, &ftUserEnd), + timeDiff(&ftKernelBegin, &ftKernelEnd)); + } +} + +#define BEGIN_TIMER beginTimer() +#define END_TIMER endTimer() +#define HAS_TIMER hasTimer() + +#else +#define BEGIN_TIMER +#define END_TIMER +#define HAS_TIMER 0 +#endif + +/* +** Used to prevent warnings about unused parameters +*/ +#define UNUSED_PARAMETER(x) (void)(x) + +/* +** Number of elements in an array +*/ +#define ArraySize(X) (int)(sizeof(X)/sizeof(X[0])) + +/* +** If the following flag is set, then command execution stops +** at an error if we are not interactive. +*/ +static int bail_on_error = 0; + +/* +** Threat stdin as an interactive input if the following variable +** is true. Otherwise, assume stdin is connected to a file or pipe. +*/ +static int stdin_is_interactive = 1; + +/* +** On Windows systems we have to know if standard output is a console +** in order to translate UTF-8 into MBCS. The following variable is +** true if translation is required. +*/ +static int stdout_is_console = 1; + +/* +** The following is the open SQLite database. We make a pointer +** to this database a static variable so that it can be accessed +** by the SIGINT handler to interrupt database processing. +*/ +static sqlite3 *globalDb = 0; + +/* +** True if an interrupt (Control-C) has been received. +*/ +static volatile int seenInterrupt = 0; + +#ifdef SQLITE_DEBUG +/* +** Out-of-memory simulator variables +*/ +static unsigned int oomCounter = 0; /* Simulate OOM when equals 1 */ +static unsigned int oomRepeat = 0; /* Number of OOMs in a row */ +static void*(*defaultMalloc)(int) = 0; /* The low-level malloc routine */ +#endif /* SQLITE_DEBUG */ + +/* +** This is the name of our program. It is set in main(), used +** in a number of other places, mostly for error messages. +*/ +static char *Argv0; + +/* +** Prompt strings. Initialized in main. Settable with +** .prompt main continue +*/ +static char mainPrompt[20]; /* First line prompt. default: "sqlite> "*/ +static char continuePrompt[20]; /* Continuation prompt. default: " ...> " */ + +/* +** Render output like fprintf(). Except, if the output is going to the +** console and if this is running on a Windows machine, translate the +** output from UTF-8 into MBCS. +*/ +#if defined(_WIN32) || defined(WIN32) +void utf8_printf(FILE *out, const char *zFormat, ...){ + va_list ap; + va_start(ap, zFormat); + if( stdout_is_console && (out==stdout || out==stderr) ){ + char *z1 = sqlite3_vmprintf(zFormat, ap); + char *z2 = sqlite3_win32_utf8_to_mbcs_v2(z1, 0); + sqlite3_free(z1); + fputs(z2, out); + sqlite3_free(z2); + }else{ + vfprintf(out, zFormat, ap); + } + va_end(ap); +} +#elif !defined(utf8_printf) +# define utf8_printf fprintf +#endif + +/* +** Render output like fprintf(). This should not be used on anything that +** includes string formatting (e.g. "%s"). +*/ +#if !defined(raw_printf) +# define raw_printf fprintf +#endif + +/* Indicate out-of-memory and exit. */ +static void shell_out_of_memory(void){ + raw_printf(stderr,"Error: out of memory\n"); + exit(1); +} + +#ifdef SQLITE_DEBUG +/* This routine is called when a simulated OOM occurs. It is broken +** out as a separate routine to make it easy to set a breakpoint on +** the OOM +*/ +void shellOomFault(void){ + if( oomRepeat>0 ){ + oomRepeat--; + }else{ + oomCounter--; + } +} +#endif /* SQLITE_DEBUG */ + +#ifdef SQLITE_DEBUG +/* This routine is a replacement malloc() that is used to simulate +** Out-Of-Memory (OOM) errors for testing purposes. +*/ +static void *oomMalloc(int nByte){ + if( oomCounter ){ + if( oomCounter==1 ){ + shellOomFault(); + return 0; + }else{ + oomCounter--; + } + } + return defaultMalloc(nByte); +} +#endif /* SQLITE_DEBUG */ + +#ifdef SQLITE_DEBUG +/* Register the OOM simulator. This must occur before any memory +** allocations */ +static void registerOomSimulator(void){ + sqlite3_mem_methods mem; + sqlite3_config(SQLITE_CONFIG_GETMALLOC, &mem); + defaultMalloc = mem.xMalloc; + mem.xMalloc = oomMalloc; + sqlite3_config(SQLITE_CONFIG_MALLOC, &mem); +} +#endif + +/* +** Write I/O traces to the following stream. +*/ +#ifdef SQLITE_ENABLE_IOTRACE +static FILE *iotrace = 0; +#endif + +/* +** This routine works like printf in that its first argument is a +** format string and subsequent arguments are values to be substituted +** in place of % fields. The result of formatting this string +** is written to iotrace. +*/ +#ifdef SQLITE_ENABLE_IOTRACE +static void SQLITE_CDECL iotracePrintf(const char *zFormat, ...){ + va_list ap; + char *z; + if( iotrace==0 ) return; + va_start(ap, zFormat); + z = sqlite3_vmprintf(zFormat, ap); + va_end(ap); + utf8_printf(iotrace, "%s", z); + sqlite3_free(z); +} +#endif + +/* +** Output string zUtf to stream pOut as w characters. If w is negative, +** then right-justify the text. W is the width in UTF-8 characters, not +** in bytes. This is different from the %*.*s specification in printf +** since with %*.*s the width is measured in bytes, not characters. +*/ +static void utf8_width_print(FILE *pOut, int w, const char *zUtf){ + int i; + int n; + int aw = w<0 ? -w : w; + for(i=n=0; zUtf[i]; i++){ + if( (zUtf[i]&0xc0)!=0x80 ){ + n++; + if( n==aw ){ + do{ i++; }while( (zUtf[i]&0xc0)==0x80 ); + break; + } + } + } + if( n>=aw ){ + utf8_printf(pOut, "%.*s", i, zUtf); + }else if( w<0 ){ + utf8_printf(pOut, "%*s%s", aw-n, "", zUtf); + }else{ + utf8_printf(pOut, "%s%*s", zUtf, aw-n, ""); + } +} + + +/* +** Determines if a string is a number of not. +*/ +static int isNumber(const char *z, int *realnum){ + if( *z=='-' || *z=='+' ) z++; + if( !IsDigit(*z) ){ + return 0; + } + z++; + if( realnum ) *realnum = 0; + while( IsDigit(*z) ){ z++; } + if( *z=='.' ){ + z++; + if( !IsDigit(*z) ) return 0; + while( IsDigit(*z) ){ z++; } + if( realnum ) *realnum = 1; + } + if( *z=='e' || *z=='E' ){ + z++; + if( *z=='+' || *z=='-' ) z++; + if( !IsDigit(*z) ) return 0; + while( IsDigit(*z) ){ z++; } + if( realnum ) *realnum = 1; + } + return *z==0; +} + +/* +** Compute a string length that is limited to what can be stored in +** lower 30 bits of a 32-bit signed integer. +*/ +static int strlen30(const char *z){ + const char *z2 = z; + while( *z2 ){ z2++; } + return 0x3fffffff & (int)(z2 - z); +} + +/* +** Return the length of a string in characters. Multibyte UTF8 characters +** count as a single character. +*/ +static int strlenChar(const char *z){ + int n = 0; + while( *z ){ + if( (0xc0&*(z++))!=0x80 ) n++; + } + return n; +} + +/* +** Return open FILE * if zFile exists, can be opened for read +** and is an ordinary file or a character stream source. +** Otherwise return 0. +*/ +static FILE * openChrSource(const char *zFile){ +#ifdef _WIN32 + struct _stat x = {0}; +# define STAT_CHR_SRC(mode) ((mode & (_S_IFCHR|_S_IFIFO|_S_IFREG))!=0) + /* On Windows, open first, then check the stream nature. This order + ** is necessary because _stat() and sibs, when checking a named pipe, + ** effectively break the pipe as its supplier sees it. */ + FILE *rv = fopen(zFile, "rb"); + if( rv==0 ) return 0; + if( _fstat(_fileno(rv), &x) != 0 + || !STAT_CHR_SRC(x.st_mode)){ + fclose(rv); + rv = 0; + } + return rv; +#else + struct stat x = {0}; + int rc = stat(zFile, &x); +# define STAT_CHR_SRC(mode) (S_ISREG(mode)||S_ISFIFO(mode)||S_ISCHR(mode)) + if( rc!=0 ) return 0; + if( STAT_CHR_SRC(x.st_mode) ){ + return fopen(zFile, "rb"); + }else{ + return 0; + } +#endif +#undef STAT_CHR_SRC +} + +/* +** This routine reads a line of text from FILE in, stores +** the text in memory obtained from malloc() and returns a pointer +** to the text. NULL is returned at end of file, or if malloc() +** fails. +** +** If zLine is not NULL then it is a malloced buffer returned from +** a previous call to this routine that may be reused. +*/ +static char *local_getline(char *zLine, FILE *in){ + int nLine = zLine==0 ? 0 : 100; + int n = 0; + + while( 1 ){ + if( n+100>nLine ){ + nLine = nLine*2 + 100; + zLine = realloc(zLine, nLine); + if( zLine==0 ) shell_out_of_memory(); + } + if( fgets(&zLine[n], nLine - n, in)==0 ){ + if( n==0 ){ + free(zLine); + return 0; + } + zLine[n] = 0; + break; + } + while( zLine[n] ) n++; + if( n>0 && zLine[n-1]=='\n' ){ + n--; + if( n>0 && zLine[n-1]=='\r' ) n--; + zLine[n] = 0; + break; + } + } +#if defined(_WIN32) || defined(WIN32) + /* For interactive input on Windows systems, translate the + ** multi-byte characterset characters into UTF-8. */ + if( stdin_is_interactive && in==stdin ){ + char *zTrans = sqlite3_win32_mbcs_to_utf8_v2(zLine, 0); + if( zTrans ){ + int nTrans = strlen30(zTrans)+1; + if( nTrans>nLine ){ + zLine = realloc(zLine, nTrans); + if( zLine==0 ) shell_out_of_memory(); + } + memcpy(zLine, zTrans, nTrans); + sqlite3_free(zTrans); + } + } +#endif /* defined(_WIN32) || defined(WIN32) */ + return zLine; +} + +/* +** Retrieve a single line of input text. +** +** If in==0 then read from standard input and prompt before each line. +** If isContinuation is true, then a continuation prompt is appropriate. +** If isContinuation is zero, then the main prompt should be used. +** +** If zPrior is not NULL then it is a buffer from a prior call to this +** routine that can be reused. +** +** The result is stored in space obtained from malloc() and must either +** be freed by the caller or else passed back into this routine via the +** zPrior argument for reuse. +*/ +static char *one_input_line(FILE *in, char *zPrior, int isContinuation){ + char *zPrompt; + char *zResult; + if( in!=0 ){ + zResult = local_getline(zPrior, in); + }else{ + zPrompt = isContinuation ? continuePrompt : mainPrompt; +#if SHELL_USE_LOCAL_GETLINE + printf("%s", zPrompt); + fflush(stdout); + zResult = local_getline(zPrior, stdin); +#else + free(zPrior); + zResult = shell_readline(zPrompt); + if( zResult && *zResult ) shell_add_history(zResult); +#endif + } + return zResult; +} + + +/* +** Return the value of a hexadecimal digit. Return -1 if the input +** is not a hex digit. +*/ +static int hexDigitValue(char c){ + if( c>='0' && c<='9' ) return c - '0'; + if( c>='a' && c<='f' ) return c - 'a' + 10; + if( c>='A' && c<='F' ) return c - 'A' + 10; + return -1; +} + +/* +** Interpret zArg as an integer value, possibly with suffixes. +*/ +static sqlite3_int64 integerValue(const char *zArg){ + sqlite3_int64 v = 0; + static const struct { char *zSuffix; int iMult; } aMult[] = { + { "KiB", 1024 }, + { "MiB", 1024*1024 }, + { "GiB", 1024*1024*1024 }, + { "KB", 1000 }, + { "MB", 1000000 }, + { "GB", 1000000000 }, + { "K", 1000 }, + { "M", 1000000 }, + { "G", 1000000000 }, + }; + int i; + int isNeg = 0; + if( zArg[0]=='-' ){ + isNeg = 1; + zArg++; + }else if( zArg[0]=='+' ){ + zArg++; + } + if( zArg[0]=='0' && zArg[1]=='x' ){ + int x; + zArg += 2; + while( (x = hexDigitValue(zArg[0]))>=0 ){ + v = (v<<4) + x; + zArg++; + } + }else{ + while( IsDigit(zArg[0]) ){ + v = v*10 + zArg[0] - '0'; + zArg++; + } + } + for(i=0; iz); + initText(p); +} + +/* zIn is either a pointer to a NULL-terminated string in memory obtained +** from malloc(), or a NULL pointer. The string pointed to by zAppend is +** added to zIn, and the result returned in memory obtained from malloc(). +** zIn, if it was not NULL, is freed. +** +** If the third argument, quote, is not '\0', then it is used as a +** quote character for zAppend. +*/ +static void appendText(ShellText *p, char const *zAppend, char quote){ + int len; + int i; + int nAppend = strlen30(zAppend); + + len = nAppend+p->n+1; + if( quote ){ + len += 2; + for(i=0; iz==0 || p->n+len>=p->nAlloc ){ + p->nAlloc = p->nAlloc*2 + len + 20; + p->z = realloc(p->z, p->nAlloc); + if( p->z==0 ) shell_out_of_memory(); + } + + if( quote ){ + char *zCsr = p->z+p->n; + *zCsr++ = quote; + for(i=0; in = (int)(zCsr - p->z); + *zCsr = '\0'; + }else{ + memcpy(p->z+p->n, zAppend, nAppend); + p->n += nAppend; + p->z[p->n] = '\0'; + } +} + +/* +** Attempt to determine if identifier zName needs to be quoted, either +** because it contains non-alphanumeric characters, or because it is an +** SQLite keyword. Be conservative in this estimate: When in doubt assume +** that quoting is required. +** +** Return '"' if quoting is required. Return 0 if no quoting is required. +*/ +static char quoteChar(const char *zName){ + int i; + if( !isalpha((unsigned char)zName[0]) && zName[0]!='_' ) return '"'; + for(i=0; zName[i]; i++){ + if( !isalnum((unsigned char)zName[i]) && zName[i]!='_' ) return '"'; + } + return sqlite3_keyword_check(zName, i) ? '"' : 0; +} + +/* +** Construct a fake object name and column list to describe the structure +** of the view, virtual table, or table valued function zSchema.zName. +*/ +static char *shellFakeSchema( + sqlite3 *db, /* The database connection containing the vtab */ + const char *zSchema, /* Schema of the database holding the vtab */ + const char *zName /* The name of the virtual table */ +){ + sqlite3_stmt *pStmt = 0; + char *zSql; + ShellText s; + char cQuote; + char *zDiv = "("; + int nRow = 0; + + zSql = sqlite3_mprintf("PRAGMA \"%w\".table_info=%Q;", + zSchema ? zSchema : "main", zName); + sqlite3_prepare_v2(db, zSql, -1, &pStmt, 0); + sqlite3_free(zSql); + initText(&s); + if( zSchema ){ + cQuote = quoteChar(zSchema); + if( cQuote && sqlite3_stricmp(zSchema,"temp")==0 ) cQuote = 0; + appendText(&s, zSchema, cQuote); + appendText(&s, ".", 0); + } + cQuote = quoteChar(zName); + appendText(&s, zName, cQuote); + while( sqlite3_step(pStmt)==SQLITE_ROW ){ + const char *zCol = (const char*)sqlite3_column_text(pStmt, 1); + nRow++; + appendText(&s, zDiv, 0); + zDiv = ","; + cQuote = quoteChar(zCol); + appendText(&s, zCol, cQuote); + } + appendText(&s, ")", 0); + sqlite3_finalize(pStmt); + if( nRow==0 ){ + freeText(&s); + s.z = 0; + } + return s.z; +} + +/* +** SQL function: shell_module_schema(X) +** +** Return a fake schema for the table-valued function or eponymous virtual +** table X. +*/ +static void shellModuleSchema( + sqlite3_context *pCtx, + int nVal, + sqlite3_value **apVal +){ + const char *zName = (const char*)sqlite3_value_text(apVal[0]); + char *zFake = shellFakeSchema(sqlite3_context_db_handle(pCtx), 0, zName); + UNUSED_PARAMETER(nVal); + if( zFake ){ + sqlite3_result_text(pCtx, sqlite3_mprintf("/* %s */", zFake), + -1, sqlite3_free); + free(zFake); + } +} + +/* +** SQL function: shell_add_schema(S,X) +** +** Add the schema name X to the CREATE statement in S and return the result. +** Examples: +** +** CREATE TABLE t1(x) -> CREATE TABLE xyz.t1(x); +** +** Also works on +** +** CREATE INDEX +** CREATE UNIQUE INDEX +** CREATE VIEW +** CREATE TRIGGER +** CREATE VIRTUAL TABLE +** +** This UDF is used by the .schema command to insert the schema name of +** attached databases into the middle of the sqlite_schema.sql field. +*/ +static void shellAddSchemaName( + sqlite3_context *pCtx, + int nVal, + sqlite3_value **apVal +){ + static const char *aPrefix[] = { + "TABLE", + "INDEX", + "UNIQUE INDEX", + "VIEW", + "TRIGGER", + "VIRTUAL TABLE" + }; + int i = 0; + const char *zIn = (const char*)sqlite3_value_text(apVal[0]); + const char *zSchema = (const char*)sqlite3_value_text(apVal[1]); + const char *zName = (const char*)sqlite3_value_text(apVal[2]); + sqlite3 *db = sqlite3_context_db_handle(pCtx); + UNUSED_PARAMETER(nVal); + if( zIn!=0 && strncmp(zIn, "CREATE ", 7)==0 ){ + for(i=0; i +#include +#include +#include +#include +#include +#include + +/* +** We may need several defines that should have been in "sys/stat.h". +*/ + +#ifndef S_ISREG +#define S_ISREG(mode) (((mode) & S_IFMT) == S_IFREG) +#endif + +#ifndef S_ISDIR +#define S_ISDIR(mode) (((mode) & S_IFMT) == S_IFDIR) +#endif + +#ifndef S_ISLNK +#define S_ISLNK(mode) (0) +#endif + +/* +** We may need to provide the "mode_t" type. +*/ + +#ifndef MODE_T_DEFINED + #define MODE_T_DEFINED + typedef unsigned short mode_t; +#endif + +/* +** We may need to provide the "ino_t" type. +*/ + +#ifndef INO_T_DEFINED + #define INO_T_DEFINED + typedef unsigned short ino_t; +#endif + +/* +** We need to define "NAME_MAX" if it was not present in "limits.h". +*/ + +#ifndef NAME_MAX +# ifdef FILENAME_MAX +# define NAME_MAX (FILENAME_MAX) +# else +# define NAME_MAX (260) +# endif +#endif + +/* +** We need to define "NULL_INTPTR_T" and "BAD_INTPTR_T". +*/ + +#ifndef NULL_INTPTR_T +# define NULL_INTPTR_T ((intptr_t)(0)) +#endif + +#ifndef BAD_INTPTR_T +# define BAD_INTPTR_T ((intptr_t)(-1)) +#endif + +/* +** We need to provide the necessary structures and related types. +*/ + +#ifndef DIRENT_DEFINED +#define DIRENT_DEFINED +typedef struct DIRENT DIRENT; +typedef DIRENT *LPDIRENT; +struct DIRENT { + ino_t d_ino; /* Sequence number, do not use. */ + unsigned d_attributes; /* Win32 file attributes. */ + char d_name[NAME_MAX + 1]; /* Name within the directory. */ +}; +#endif + +#ifndef DIR_DEFINED +#define DIR_DEFINED +typedef struct DIR DIR; +typedef DIR *LPDIR; +struct DIR { + intptr_t d_handle; /* Value returned by "_findfirst". */ + DIRENT d_first; /* DIRENT constructed based on "_findfirst". */ + DIRENT d_next; /* DIRENT constructed based on "_findnext". */ +}; +#endif + +/* +** Provide a macro, for use by the implementation, to determine if a +** particular directory entry should be skipped over when searching for +** the next directory entry that should be returned by the readdir() or +** readdir_r() functions. +*/ + +#ifndef is_filtered +# define is_filtered(a) ((((a).attrib)&_A_HIDDEN) || (((a).attrib)&_A_SYSTEM)) +#endif + +/* +** Provide the function prototype for the POSIX compatiable getenv() +** function. This function is not thread-safe. +*/ + +extern const char *windirent_getenv(const char *name); + +/* +** Finally, we can provide the function prototypes for the opendir(), +** readdir(), readdir_r(), and closedir() POSIX functions. +*/ + +extern LPDIR opendir(const char *dirname); +extern LPDIRENT readdir(LPDIR dirp); +extern INT readdir_r(LPDIR dirp, LPDIRENT entry, LPDIRENT *result); +extern INT closedir(LPDIR dirp); + +#endif /* defined(WIN32) && defined(_MSC_VER) */ + +/************************* End test_windirent.h ********************/ +/************************* Begin test_windirent.c ******************/ +/* +** 2015 November 30 +** +** The author disclaims copyright to this source code. In place of +** a legal notice, here is a blessing: +** +** May you do good and not evil. +** May you find forgiveness for yourself and forgive others. +** May you share freely, never taking more than you give. +** +************************************************************************* +** This file contains code to implement most of the opendir() family of +** POSIX functions on Win32 using the MSVCRT. +*/ + +#if defined(_WIN32) && defined(_MSC_VER) +/* #include "test_windirent.h" */ + +/* +** Implementation of the POSIX getenv() function using the Win32 API. +** This function is not thread-safe. +*/ +const char *windirent_getenv( + const char *name +){ + static char value[32768]; /* Maximum length, per MSDN */ + DWORD dwSize = sizeof(value) / sizeof(char); /* Size in chars */ + DWORD dwRet; /* Value returned by GetEnvironmentVariableA() */ + + memset(value, 0, sizeof(value)); + dwRet = GetEnvironmentVariableA(name, value, dwSize); + if( dwRet==0 || dwRet>dwSize ){ + /* + ** The function call to GetEnvironmentVariableA() failed -OR- + ** the buffer is not large enough. Either way, return NULL. + */ + return 0; + }else{ + /* + ** The function call to GetEnvironmentVariableA() succeeded + ** -AND- the buffer contains the entire value. + */ + return value; + } +} + +/* +** Implementation of the POSIX opendir() function using the MSVCRT. +*/ +LPDIR opendir( + const char *dirname +){ + struct _finddata_t data; + LPDIR dirp = (LPDIR)sqlite3_malloc(sizeof(DIR)); + SIZE_T namesize = sizeof(data.name) / sizeof(data.name[0]); + + if( dirp==NULL ) return NULL; + memset(dirp, 0, sizeof(DIR)); + + /* TODO: Remove this if Unix-style root paths are not used. */ + if( sqlite3_stricmp(dirname, "/")==0 ){ + dirname = windirent_getenv("SystemDrive"); + } + + memset(&data, 0, sizeof(struct _finddata_t)); + _snprintf(data.name, namesize, "%s\\*", dirname); + dirp->d_handle = _findfirst(data.name, &data); + + if( dirp->d_handle==BAD_INTPTR_T ){ + closedir(dirp); + return NULL; + } + + /* TODO: Remove this block to allow hidden and/or system files. */ + if( is_filtered(data) ){ +next: + + memset(&data, 0, sizeof(struct _finddata_t)); + if( _findnext(dirp->d_handle, &data)==-1 ){ + closedir(dirp); + return NULL; + } + + /* TODO: Remove this block to allow hidden and/or system files. */ + if( is_filtered(data) ) goto next; + } + + dirp->d_first.d_attributes = data.attrib; + strncpy(dirp->d_first.d_name, data.name, NAME_MAX); + dirp->d_first.d_name[NAME_MAX] = '\0'; + + return dirp; +} + +/* +** Implementation of the POSIX readdir() function using the MSVCRT. +*/ +LPDIRENT readdir( + LPDIR dirp +){ + struct _finddata_t data; + + if( dirp==NULL ) return NULL; + + if( dirp->d_first.d_ino==0 ){ + dirp->d_first.d_ino++; + dirp->d_next.d_ino++; + + return &dirp->d_first; + } + +next: + + memset(&data, 0, sizeof(struct _finddata_t)); + if( _findnext(dirp->d_handle, &data)==-1 ) return NULL; + + /* TODO: Remove this block to allow hidden and/or system files. */ + if( is_filtered(data) ) goto next; + + dirp->d_next.d_ino++; + dirp->d_next.d_attributes = data.attrib; + strncpy(dirp->d_next.d_name, data.name, NAME_MAX); + dirp->d_next.d_name[NAME_MAX] = '\0'; + + return &dirp->d_next; +} + +/* +** Implementation of the POSIX readdir_r() function using the MSVCRT. +*/ +INT readdir_r( + LPDIR dirp, + LPDIRENT entry, + LPDIRENT *result +){ + struct _finddata_t data; + + if( dirp==NULL ) return EBADF; + + if( dirp->d_first.d_ino==0 ){ + dirp->d_first.d_ino++; + dirp->d_next.d_ino++; + + entry->d_ino = dirp->d_first.d_ino; + entry->d_attributes = dirp->d_first.d_attributes; + strncpy(entry->d_name, dirp->d_first.d_name, NAME_MAX); + entry->d_name[NAME_MAX] = '\0'; + + *result = entry; + return 0; + } + +next: + + memset(&data, 0, sizeof(struct _finddata_t)); + if( _findnext(dirp->d_handle, &data)==-1 ){ + *result = NULL; + return ENOENT; + } + + /* TODO: Remove this block to allow hidden and/or system files. */ + if( is_filtered(data) ) goto next; + + entry->d_ino = (ino_t)-1; /* not available */ + entry->d_attributes = data.attrib; + strncpy(entry->d_name, data.name, NAME_MAX); + entry->d_name[NAME_MAX] = '\0'; + + *result = entry; + return 0; +} + +/* +** Implementation of the POSIX closedir() function using the MSVCRT. +*/ +INT closedir( + LPDIR dirp +){ + INT result = 0; + + if( dirp==NULL ) return EINVAL; + + if( dirp->d_handle!=NULL_INTPTR_T && dirp->d_handle!=BAD_INTPTR_T ){ + result = _findclose(dirp->d_handle); + } + + sqlite3_free(dirp); + return result; +} + +#endif /* defined(WIN32) && defined(_MSC_VER) */ + +/************************* End test_windirent.c ********************/ +#define dirent DIRENT +#endif +/************************* Begin ../ext/misc/shathree.c ******************/ +/* +** 2017-03-08 +** +** The author disclaims copyright to this source code. In place of +** a legal notice, here is a blessing: +** +** May you do good and not evil. +** May you find forgiveness for yourself and forgive others. +** May you share freely, never taking more than you give. +** +****************************************************************************** +** +** This SQLite extension implements functions that compute SHA3 hashes. +** Two SQL functions are implemented: +** +** sha3(X,SIZE) +** sha3_query(Y,SIZE) +** +** The sha3(X) function computes the SHA3 hash of the input X, or NULL if +** X is NULL. +** +** The sha3_query(Y) function evalutes all queries in the SQL statements of Y +** and returns a hash of their results. +** +** The SIZE argument is optional. If omitted, the SHA3-256 hash algorithm +** is used. If SIZE is included it must be one of the integers 224, 256, +** 384, or 512, to determine SHA3 hash variant that is computed. +*/ +/* #include "sqlite3ext.h" */ +SQLITE_EXTENSION_INIT1 +#include +#include +#include + +#ifndef SQLITE_AMALGAMATION +/* typedef sqlite3_uint64 u64; */ +#endif /* SQLITE_AMALGAMATION */ + +/****************************************************************************** +** The Hash Engine +*/ +/* +** Macros to determine whether the machine is big or little endian, +** and whether or not that determination is run-time or compile-time. +** +** For best performance, an attempt is made to guess at the byte-order +** using C-preprocessor macros. If that is unsuccessful, or if +** -DSHA3_BYTEORDER=0 is set, then byte-order is determined +** at run-time. +*/ +#ifndef SHA3_BYTEORDER +# if defined(i386) || defined(__i386__) || defined(_M_IX86) || \ + defined(__x86_64) || defined(__x86_64__) || defined(_M_X64) || \ + defined(_M_AMD64) || defined(_M_ARM) || defined(__x86) || \ + defined(__arm__) +# define SHA3_BYTEORDER 1234 +# elif defined(sparc) || defined(__ppc__) +# define SHA3_BYTEORDER 4321 +# else +# define SHA3_BYTEORDER 0 +# endif +#endif + + +/* +** State structure for a SHA3 hash in progress +*/ +typedef struct SHA3Context SHA3Context; +struct SHA3Context { + union { + u64 s[25]; /* Keccak state. 5x5 lines of 64 bits each */ + unsigned char x[1600]; /* ... or 1600 bytes */ + } u; + unsigned nRate; /* Bytes of input accepted per Keccak iteration */ + unsigned nLoaded; /* Input bytes loaded into u.x[] so far this cycle */ + unsigned ixMask; /* Insert next input into u.x[nLoaded^ixMask]. */ +}; + +/* +** A single step of the Keccak mixing function for a 1600-bit state +*/ +static void KeccakF1600Step(SHA3Context *p){ + int i; + u64 b0, b1, b2, b3, b4; + u64 c0, c1, c2, c3, c4; + u64 d0, d1, d2, d3, d4; + static const u64 RC[] = { + 0x0000000000000001ULL, 0x0000000000008082ULL, + 0x800000000000808aULL, 0x8000000080008000ULL, + 0x000000000000808bULL, 0x0000000080000001ULL, + 0x8000000080008081ULL, 0x8000000000008009ULL, + 0x000000000000008aULL, 0x0000000000000088ULL, + 0x0000000080008009ULL, 0x000000008000000aULL, + 0x000000008000808bULL, 0x800000000000008bULL, + 0x8000000000008089ULL, 0x8000000000008003ULL, + 0x8000000000008002ULL, 0x8000000000000080ULL, + 0x000000000000800aULL, 0x800000008000000aULL, + 0x8000000080008081ULL, 0x8000000000008080ULL, + 0x0000000080000001ULL, 0x8000000080008008ULL + }; +# define a00 (p->u.s[0]) +# define a01 (p->u.s[1]) +# define a02 (p->u.s[2]) +# define a03 (p->u.s[3]) +# define a04 (p->u.s[4]) +# define a10 (p->u.s[5]) +# define a11 (p->u.s[6]) +# define a12 (p->u.s[7]) +# define a13 (p->u.s[8]) +# define a14 (p->u.s[9]) +# define a20 (p->u.s[10]) +# define a21 (p->u.s[11]) +# define a22 (p->u.s[12]) +# define a23 (p->u.s[13]) +# define a24 (p->u.s[14]) +# define a30 (p->u.s[15]) +# define a31 (p->u.s[16]) +# define a32 (p->u.s[17]) +# define a33 (p->u.s[18]) +# define a34 (p->u.s[19]) +# define a40 (p->u.s[20]) +# define a41 (p->u.s[21]) +# define a42 (p->u.s[22]) +# define a43 (p->u.s[23]) +# define a44 (p->u.s[24]) +# define ROL64(a,x) ((a<>(64-x))) + + for(i=0; i<24; i+=4){ + c0 = a00^a10^a20^a30^a40; + c1 = a01^a11^a21^a31^a41; + c2 = a02^a12^a22^a32^a42; + c3 = a03^a13^a23^a33^a43; + c4 = a04^a14^a24^a34^a44; + d0 = c4^ROL64(c1, 1); + d1 = c0^ROL64(c2, 1); + d2 = c1^ROL64(c3, 1); + d3 = c2^ROL64(c4, 1); + d4 = c3^ROL64(c0, 1); + + b0 = (a00^d0); + b1 = ROL64((a11^d1), 44); + b2 = ROL64((a22^d2), 43); + b3 = ROL64((a33^d3), 21); + b4 = ROL64((a44^d4), 14); + a00 = b0 ^((~b1)& b2 ); + a00 ^= RC[i]; + a11 = b1 ^((~b2)& b3 ); + a22 = b2 ^((~b3)& b4 ); + a33 = b3 ^((~b4)& b0 ); + a44 = b4 ^((~b0)& b1 ); + + b2 = ROL64((a20^d0), 3); + b3 = ROL64((a31^d1), 45); + b4 = ROL64((a42^d2), 61); + b0 = ROL64((a03^d3), 28); + b1 = ROL64((a14^d4), 20); + a20 = b0 ^((~b1)& b2 ); + a31 = b1 ^((~b2)& b3 ); + a42 = b2 ^((~b3)& b4 ); + a03 = b3 ^((~b4)& b0 ); + a14 = b4 ^((~b0)& b1 ); + + b4 = ROL64((a40^d0), 18); + b0 = ROL64((a01^d1), 1); + b1 = ROL64((a12^d2), 6); + b2 = ROL64((a23^d3), 25); + b3 = ROL64((a34^d4), 8); + a40 = b0 ^((~b1)& b2 ); + a01 = b1 ^((~b2)& b3 ); + a12 = b2 ^((~b3)& b4 ); + a23 = b3 ^((~b4)& b0 ); + a34 = b4 ^((~b0)& b1 ); + + b1 = ROL64((a10^d0), 36); + b2 = ROL64((a21^d1), 10); + b3 = ROL64((a32^d2), 15); + b4 = ROL64((a43^d3), 56); + b0 = ROL64((a04^d4), 27); + a10 = b0 ^((~b1)& b2 ); + a21 = b1 ^((~b2)& b3 ); + a32 = b2 ^((~b3)& b4 ); + a43 = b3 ^((~b4)& b0 ); + a04 = b4 ^((~b0)& b1 ); + + b3 = ROL64((a30^d0), 41); + b4 = ROL64((a41^d1), 2); + b0 = ROL64((a02^d2), 62); + b1 = ROL64((a13^d3), 55); + b2 = ROL64((a24^d4), 39); + a30 = b0 ^((~b1)& b2 ); + a41 = b1 ^((~b2)& b3 ); + a02 = b2 ^((~b3)& b4 ); + a13 = b3 ^((~b4)& b0 ); + a24 = b4 ^((~b0)& b1 ); + + c0 = a00^a20^a40^a10^a30; + c1 = a11^a31^a01^a21^a41; + c2 = a22^a42^a12^a32^a02; + c3 = a33^a03^a23^a43^a13; + c4 = a44^a14^a34^a04^a24; + d0 = c4^ROL64(c1, 1); + d1 = c0^ROL64(c2, 1); + d2 = c1^ROL64(c3, 1); + d3 = c2^ROL64(c4, 1); + d4 = c3^ROL64(c0, 1); + + b0 = (a00^d0); + b1 = ROL64((a31^d1), 44); + b2 = ROL64((a12^d2), 43); + b3 = ROL64((a43^d3), 21); + b4 = ROL64((a24^d4), 14); + a00 = b0 ^((~b1)& b2 ); + a00 ^= RC[i+1]; + a31 = b1 ^((~b2)& b3 ); + a12 = b2 ^((~b3)& b4 ); + a43 = b3 ^((~b4)& b0 ); + a24 = b4 ^((~b0)& b1 ); + + b2 = ROL64((a40^d0), 3); + b3 = ROL64((a21^d1), 45); + b4 = ROL64((a02^d2), 61); + b0 = ROL64((a33^d3), 28); + b1 = ROL64((a14^d4), 20); + a40 = b0 ^((~b1)& b2 ); + a21 = b1 ^((~b2)& b3 ); + a02 = b2 ^((~b3)& b4 ); + a33 = b3 ^((~b4)& b0 ); + a14 = b4 ^((~b0)& b1 ); + + b4 = ROL64((a30^d0), 18); + b0 = ROL64((a11^d1), 1); + b1 = ROL64((a42^d2), 6); + b2 = ROL64((a23^d3), 25); + b3 = ROL64((a04^d4), 8); + a30 = b0 ^((~b1)& b2 ); + a11 = b1 ^((~b2)& b3 ); + a42 = b2 ^((~b3)& b4 ); + a23 = b3 ^((~b4)& b0 ); + a04 = b4 ^((~b0)& b1 ); + + b1 = ROL64((a20^d0), 36); + b2 = ROL64((a01^d1), 10); + b3 = ROL64((a32^d2), 15); + b4 = ROL64((a13^d3), 56); + b0 = ROL64((a44^d4), 27); + a20 = b0 ^((~b1)& b2 ); + a01 = b1 ^((~b2)& b3 ); + a32 = b2 ^((~b3)& b4 ); + a13 = b3 ^((~b4)& b0 ); + a44 = b4 ^((~b0)& b1 ); + + b3 = ROL64((a10^d0), 41); + b4 = ROL64((a41^d1), 2); + b0 = ROL64((a22^d2), 62); + b1 = ROL64((a03^d3), 55); + b2 = ROL64((a34^d4), 39); + a10 = b0 ^((~b1)& b2 ); + a41 = b1 ^((~b2)& b3 ); + a22 = b2 ^((~b3)& b4 ); + a03 = b3 ^((~b4)& b0 ); + a34 = b4 ^((~b0)& b1 ); + + c0 = a00^a40^a30^a20^a10; + c1 = a31^a21^a11^a01^a41; + c2 = a12^a02^a42^a32^a22; + c3 = a43^a33^a23^a13^a03; + c4 = a24^a14^a04^a44^a34; + d0 = c4^ROL64(c1, 1); + d1 = c0^ROL64(c2, 1); + d2 = c1^ROL64(c3, 1); + d3 = c2^ROL64(c4, 1); + d4 = c3^ROL64(c0, 1); + + b0 = (a00^d0); + b1 = ROL64((a21^d1), 44); + b2 = ROL64((a42^d2), 43); + b3 = ROL64((a13^d3), 21); + b4 = ROL64((a34^d4), 14); + a00 = b0 ^((~b1)& b2 ); + a00 ^= RC[i+2]; + a21 = b1 ^((~b2)& b3 ); + a42 = b2 ^((~b3)& b4 ); + a13 = b3 ^((~b4)& b0 ); + a34 = b4 ^((~b0)& b1 ); + + b2 = ROL64((a30^d0), 3); + b3 = ROL64((a01^d1), 45); + b4 = ROL64((a22^d2), 61); + b0 = ROL64((a43^d3), 28); + b1 = ROL64((a14^d4), 20); + a30 = b0 ^((~b1)& b2 ); + a01 = b1 ^((~b2)& b3 ); + a22 = b2 ^((~b3)& b4 ); + a43 = b3 ^((~b4)& b0 ); + a14 = b4 ^((~b0)& b1 ); + + b4 = ROL64((a10^d0), 18); + b0 = ROL64((a31^d1), 1); + b1 = ROL64((a02^d2), 6); + b2 = ROL64((a23^d3), 25); + b3 = ROL64((a44^d4), 8); + a10 = b0 ^((~b1)& b2 ); + a31 = b1 ^((~b2)& b3 ); + a02 = b2 ^((~b3)& b4 ); + a23 = b3 ^((~b4)& b0 ); + a44 = b4 ^((~b0)& b1 ); + + b1 = ROL64((a40^d0), 36); + b2 = ROL64((a11^d1), 10); + b3 = ROL64((a32^d2), 15); + b4 = ROL64((a03^d3), 56); + b0 = ROL64((a24^d4), 27); + a40 = b0 ^((~b1)& b2 ); + a11 = b1 ^((~b2)& b3 ); + a32 = b2 ^((~b3)& b4 ); + a03 = b3 ^((~b4)& b0 ); + a24 = b4 ^((~b0)& b1 ); + + b3 = ROL64((a20^d0), 41); + b4 = ROL64((a41^d1), 2); + b0 = ROL64((a12^d2), 62); + b1 = ROL64((a33^d3), 55); + b2 = ROL64((a04^d4), 39); + a20 = b0 ^((~b1)& b2 ); + a41 = b1 ^((~b2)& b3 ); + a12 = b2 ^((~b3)& b4 ); + a33 = b3 ^((~b4)& b0 ); + a04 = b4 ^((~b0)& b1 ); + + c0 = a00^a30^a10^a40^a20; + c1 = a21^a01^a31^a11^a41; + c2 = a42^a22^a02^a32^a12; + c3 = a13^a43^a23^a03^a33; + c4 = a34^a14^a44^a24^a04; + d0 = c4^ROL64(c1, 1); + d1 = c0^ROL64(c2, 1); + d2 = c1^ROL64(c3, 1); + d3 = c2^ROL64(c4, 1); + d4 = c3^ROL64(c0, 1); + + b0 = (a00^d0); + b1 = ROL64((a01^d1), 44); + b2 = ROL64((a02^d2), 43); + b3 = ROL64((a03^d3), 21); + b4 = ROL64((a04^d4), 14); + a00 = b0 ^((~b1)& b2 ); + a00 ^= RC[i+3]; + a01 = b1 ^((~b2)& b3 ); + a02 = b2 ^((~b3)& b4 ); + a03 = b3 ^((~b4)& b0 ); + a04 = b4 ^((~b0)& b1 ); + + b2 = ROL64((a10^d0), 3); + b3 = ROL64((a11^d1), 45); + b4 = ROL64((a12^d2), 61); + b0 = ROL64((a13^d3), 28); + b1 = ROL64((a14^d4), 20); + a10 = b0 ^((~b1)& b2 ); + a11 = b1 ^((~b2)& b3 ); + a12 = b2 ^((~b3)& b4 ); + a13 = b3 ^((~b4)& b0 ); + a14 = b4 ^((~b0)& b1 ); + + b4 = ROL64((a20^d0), 18); + b0 = ROL64((a21^d1), 1); + b1 = ROL64((a22^d2), 6); + b2 = ROL64((a23^d3), 25); + b3 = ROL64((a24^d4), 8); + a20 = b0 ^((~b1)& b2 ); + a21 = b1 ^((~b2)& b3 ); + a22 = b2 ^((~b3)& b4 ); + a23 = b3 ^((~b4)& b0 ); + a24 = b4 ^((~b0)& b1 ); + + b1 = ROL64((a30^d0), 36); + b2 = ROL64((a31^d1), 10); + b3 = ROL64((a32^d2), 15); + b4 = ROL64((a33^d3), 56); + b0 = ROL64((a34^d4), 27); + a30 = b0 ^((~b1)& b2 ); + a31 = b1 ^((~b2)& b3 ); + a32 = b2 ^((~b3)& b4 ); + a33 = b3 ^((~b4)& b0 ); + a34 = b4 ^((~b0)& b1 ); + + b3 = ROL64((a40^d0), 41); + b4 = ROL64((a41^d1), 2); + b0 = ROL64((a42^d2), 62); + b1 = ROL64((a43^d3), 55); + b2 = ROL64((a44^d4), 39); + a40 = b0 ^((~b1)& b2 ); + a41 = b1 ^((~b2)& b3 ); + a42 = b2 ^((~b3)& b4 ); + a43 = b3 ^((~b4)& b0 ); + a44 = b4 ^((~b0)& b1 ); + } +} + +/* +** Initialize a new hash. iSize determines the size of the hash +** in bits and should be one of 224, 256, 384, or 512. Or iSize +** can be zero to use the default hash size of 256 bits. +*/ +static void SHA3Init(SHA3Context *p, int iSize){ + memset(p, 0, sizeof(*p)); + if( iSize>=128 && iSize<=512 ){ + p->nRate = (1600 - ((iSize + 31)&~31)*2)/8; + }else{ + p->nRate = (1600 - 2*256)/8; + } +#if SHA3_BYTEORDER==1234 + /* Known to be little-endian at compile-time. No-op */ +#elif SHA3_BYTEORDER==4321 + p->ixMask = 7; /* Big-endian */ +#else + { + static unsigned int one = 1; + if( 1==*(unsigned char*)&one ){ + /* Little endian. No byte swapping. */ + p->ixMask = 0; + }else{ + /* Big endian. Byte swap. */ + p->ixMask = 7; + } + } +#endif +} + +/* +** Make consecutive calls to the SHA3Update function to add new content +** to the hash +*/ +static void SHA3Update( + SHA3Context *p, + const unsigned char *aData, + unsigned int nData +){ + unsigned int i = 0; +#if SHA3_BYTEORDER==1234 + if( (p->nLoaded % 8)==0 && ((aData - (const unsigned char*)0)&7)==0 ){ + for(; i+7u.s[p->nLoaded/8] ^= *(u64*)&aData[i]; + p->nLoaded += 8; + if( p->nLoaded>=p->nRate ){ + KeccakF1600Step(p); + p->nLoaded = 0; + } + } + } +#endif + for(; iu.x[p->nLoaded] ^= aData[i]; +#elif SHA3_BYTEORDER==4321 + p->u.x[p->nLoaded^0x07] ^= aData[i]; +#else + p->u.x[p->nLoaded^p->ixMask] ^= aData[i]; +#endif + p->nLoaded++; + if( p->nLoaded==p->nRate ){ + KeccakF1600Step(p); + p->nLoaded = 0; + } + } +} + +/* +** After all content has been added, invoke SHA3Final() to compute +** the final hash. The function returns a pointer to the binary +** hash value. +*/ +static unsigned char *SHA3Final(SHA3Context *p){ + unsigned int i; + if( p->nLoaded==p->nRate-1 ){ + const unsigned char c1 = 0x86; + SHA3Update(p, &c1, 1); + }else{ + const unsigned char c2 = 0x06; + const unsigned char c3 = 0x80; + SHA3Update(p, &c2, 1); + p->nLoaded = p->nRate - 1; + SHA3Update(p, &c3, 1); + } + for(i=0; inRate; i++){ + p->u.x[i+p->nRate] = p->u.x[i^p->ixMask]; + } + return &p->u.x[p->nRate]; +} +/* End of the hashing logic +*****************************************************************************/ + +/* +** Implementation of the sha3(X,SIZE) function. +** +** Return a BLOB which is the SIZE-bit SHA3 hash of X. The default +** size is 256. If X is a BLOB, it is hashed as is. +** For all other non-NULL types of input, X is converted into a UTF-8 string +** and the string is hashed without the trailing 0x00 terminator. The hash +** of a NULL value is NULL. +*/ +static void sha3Func( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + SHA3Context cx; + int eType = sqlite3_value_type(argv[0]); + int nByte = sqlite3_value_bytes(argv[0]); + int iSize; + if( argc==1 ){ + iSize = 256; + }else{ + iSize = sqlite3_value_int(argv[1]); + if( iSize!=224 && iSize!=256 && iSize!=384 && iSize!=512 ){ + sqlite3_result_error(context, "SHA3 size should be one of: 224 256 " + "384 512", -1); + return; + } + } + if( eType==SQLITE_NULL ) return; + SHA3Init(&cx, iSize); + if( eType==SQLITE_BLOB ){ + SHA3Update(&cx, sqlite3_value_blob(argv[0]), nByte); + }else{ + SHA3Update(&cx, sqlite3_value_text(argv[0]), nByte); + } + sqlite3_result_blob(context, SHA3Final(&cx), iSize/8, SQLITE_TRANSIENT); +} + +/* Compute a string using sqlite3_vsnprintf() with a maximum length +** of 50 bytes and add it to the hash. +*/ +static void hash_step_vformat( + SHA3Context *p, /* Add content to this context */ + const char *zFormat, + ... +){ + va_list ap; + int n; + char zBuf[50]; + va_start(ap, zFormat); + sqlite3_vsnprintf(sizeof(zBuf),zBuf,zFormat,ap); + va_end(ap); + n = (int)strlen(zBuf); + SHA3Update(p, (unsigned char*)zBuf, n); +} + +/* +** Implementation of the sha3_query(SQL,SIZE) function. +** +** This function compiles and runs the SQL statement(s) given in the +** argument. The results are hashed using a SIZE-bit SHA3. The default +** size is 256. +** +** The format of the byte stream that is hashed is summarized as follows: +** +** S: +** R +** N +** I +** F +** B: +** T: +** +** is the original SQL text for each statement run and is +** the size of that text. The SQL text is UTF-8. A single R character +** occurs before the start of each row. N means a NULL value. +** I mean an 8-byte little-endian integer . F is a floating point +** number with an 8-byte little-endian IEEE floating point value . +** B means blobs of bytes. T means text rendered as +** bytes of UTF-8. The and values are expressed as an ASCII +** text integers. +** +** For each SQL statement in the X input, there is one S segment. Each +** S segment is followed by zero or more R segments, one for each row in the +** result set. After each R, there are one or more N, I, F, B, or T segments, +** one for each column in the result set. Segments are concatentated directly +** with no delimiters of any kind. +*/ +static void sha3QueryFunc( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + sqlite3 *db = sqlite3_context_db_handle(context); + const char *zSql = (const char*)sqlite3_value_text(argv[0]); + sqlite3_stmt *pStmt = 0; + int nCol; /* Number of columns in the result set */ + int i; /* Loop counter */ + int rc; + int n; + const char *z; + SHA3Context cx; + int iSize; + + if( argc==1 ){ + iSize = 256; + }else{ + iSize = sqlite3_value_int(argv[1]); + if( iSize!=224 && iSize!=256 && iSize!=384 && iSize!=512 ){ + sqlite3_result_error(context, "SHA3 size should be one of: 224 256 " + "384 512", -1); + return; + } + } + if( zSql==0 ) return; + SHA3Init(&cx, iSize); + while( zSql[0] ){ + rc = sqlite3_prepare_v2(db, zSql, -1, &pStmt, &zSql); + if( rc ){ + char *zMsg = sqlite3_mprintf("error SQL statement [%s]: %s", + zSql, sqlite3_errmsg(db)); + sqlite3_finalize(pStmt); + sqlite3_result_error(context, zMsg, -1); + sqlite3_free(zMsg); + return; + } + if( !sqlite3_stmt_readonly(pStmt) ){ + char *zMsg = sqlite3_mprintf("non-query: [%s]", sqlite3_sql(pStmt)); + sqlite3_finalize(pStmt); + sqlite3_result_error(context, zMsg, -1); + sqlite3_free(zMsg); + return; + } + nCol = sqlite3_column_count(pStmt); + z = sqlite3_sql(pStmt); + if( z ){ + n = (int)strlen(z); + hash_step_vformat(&cx,"S%d:",n); + SHA3Update(&cx,(unsigned char*)z,n); + } + + /* Compute a hash over the result of the query */ + while( SQLITE_ROW==sqlite3_step(pStmt) ){ + SHA3Update(&cx,(const unsigned char*)"R",1); + for(i=0; i=1; j--){ + x[j] = u & 0xff; + u >>= 8; + } + x[0] = 'I'; + SHA3Update(&cx, x, 9); + break; + } + case SQLITE_FLOAT: { + sqlite3_uint64 u; + int j; + unsigned char x[9]; + double r = sqlite3_column_double(pStmt,i); + memcpy(&u, &r, 8); + for(j=8; j>=1; j--){ + x[j] = u & 0xff; + u >>= 8; + } + x[0] = 'F'; + SHA3Update(&cx,x,9); + break; + } + case SQLITE_TEXT: { + int n2 = sqlite3_column_bytes(pStmt, i); + const unsigned char *z2 = sqlite3_column_text(pStmt, i); + hash_step_vformat(&cx,"T%d:",n2); + SHA3Update(&cx, z2, n2); + break; + } + case SQLITE_BLOB: { + int n2 = sqlite3_column_bytes(pStmt, i); + const unsigned char *z2 = sqlite3_column_blob(pStmt, i); + hash_step_vformat(&cx,"B%d:",n2); + SHA3Update(&cx, z2, n2); + break; + } + } + } + } + sqlite3_finalize(pStmt); + } + sqlite3_result_blob(context, SHA3Final(&cx), iSize/8, SQLITE_TRANSIENT); +} + + +#ifdef _WIN32 + +#endif +int sqlite3_shathree_init( + sqlite3 *db, + char **pzErrMsg, + const sqlite3_api_routines *pApi +){ + int rc = SQLITE_OK; + SQLITE_EXTENSION_INIT2(pApi); + (void)pzErrMsg; /* Unused parameter */ + rc = sqlite3_create_function(db, "sha3", 1, + SQLITE_UTF8 | SQLITE_INNOCUOUS | SQLITE_DETERMINISTIC, + 0, sha3Func, 0, 0); + if( rc==SQLITE_OK ){ + rc = sqlite3_create_function(db, "sha3", 2, + SQLITE_UTF8 | SQLITE_INNOCUOUS | SQLITE_DETERMINISTIC, + 0, sha3Func, 0, 0); + } + if( rc==SQLITE_OK ){ + rc = sqlite3_create_function(db, "sha3_query", 1, + SQLITE_UTF8 | SQLITE_DIRECTONLY, + 0, sha3QueryFunc, 0, 0); + } + if( rc==SQLITE_OK ){ + rc = sqlite3_create_function(db, "sha3_query", 2, + SQLITE_UTF8 | SQLITE_DIRECTONLY, + 0, sha3QueryFunc, 0, 0); + } + return rc; +} + +/************************* End ../ext/misc/shathree.c ********************/ +/************************* Begin ../ext/misc/fileio.c ******************/ +/* +** 2014-06-13 +** +** The author disclaims copyright to this source code. In place of +** a legal notice, here is a blessing: +** +** May you do good and not evil. +** May you find forgiveness for yourself and forgive others. +** May you share freely, never taking more than you give. +** +****************************************************************************** +** +** This SQLite extension implements SQL functions readfile() and +** writefile(), and eponymous virtual type "fsdir". +** +** WRITEFILE(FILE, DATA [, MODE [, MTIME]]): +** +** If neither of the optional arguments is present, then this UDF +** function writes blob DATA to file FILE. If successful, the number +** of bytes written is returned. If an error occurs, NULL is returned. +** +** If the first option argument - MODE - is present, then it must +** be passed an integer value that corresponds to a POSIX mode +** value (file type + permissions, as returned in the stat.st_mode +** field by the stat() system call). Three types of files may +** be written/created: +** +** regular files: (mode & 0170000)==0100000 +** symbolic links: (mode & 0170000)==0120000 +** directories: (mode & 0170000)==0040000 +** +** For a directory, the DATA is ignored. For a symbolic link, it is +** interpreted as text and used as the target of the link. For a +** regular file, it is interpreted as a blob and written into the +** named file. Regardless of the type of file, its permissions are +** set to (mode & 0777) before returning. +** +** If the optional MTIME argument is present, then it is interpreted +** as an integer - the number of seconds since the unix epoch. The +** modification-time of the target file is set to this value before +** returning. +** +** If three or more arguments are passed to this function and an +** error is encountered, an exception is raised. +** +** READFILE(FILE): +** +** Read and return the contents of file FILE (type blob) from disk. +** +** FSDIR: +** +** Used as follows: +** +** SELECT * FROM fsdir($path [, $dir]); +** +** Parameter $path is an absolute or relative pathname. If the file that it +** refers to does not exist, it is an error. If the path refers to a regular +** file or symbolic link, it returns a single row. Or, if the path refers +** to a directory, it returns one row for the directory, and one row for each +** file within the hierarchy rooted at $path. +** +** Each row has the following columns: +** +** name: Path to file or directory (text value). +** mode: Value of stat.st_mode for directory entry (an integer). +** mtime: Value of stat.st_mtime for directory entry (an integer). +** data: For a regular file, a blob containing the file data. For a +** symlink, a text value containing the text of the link. For a +** directory, NULL. +** +** If a non-NULL value is specified for the optional $dir parameter and +** $path is a relative path, then $path is interpreted relative to $dir. +** And the paths returned in the "name" column of the table are also +** relative to directory $dir. +** +** Notes on building this extension for Windows: +** Unless linked statically with the SQLite library, a preprocessor +** symbol, FILEIO_WIN32_DLL, must be #define'd to create a stand-alone +** DLL form of this extension for WIN32. See its use below for details. +*/ +/* #include "sqlite3ext.h" */ +SQLITE_EXTENSION_INIT1 +#include +#include +#include + +#include +#include +#include +#if !defined(_WIN32) && !defined(WIN32) +# include +# include +# include +# include +#else +# include "windows.h" +# include +# include +/* # include "test_windirent.h" */ +# define dirent DIRENT +# ifndef chmod +# define chmod _chmod +# endif +# ifndef stat +# define stat _stat +# endif +# define mkdir(path,mode) _mkdir(path) +# define lstat(path,buf) stat(path,buf) +#endif +#include +#include + + +/* +** Structure of the fsdir() table-valued function +*/ + /* 0 1 2 3 4 5 */ +#define FSDIR_SCHEMA "(name,mode,mtime,data,path HIDDEN,dir HIDDEN)" +#define FSDIR_COLUMN_NAME 0 /* Name of the file */ +#define FSDIR_COLUMN_MODE 1 /* Access mode */ +#define FSDIR_COLUMN_MTIME 2 /* Last modification time */ +#define FSDIR_COLUMN_DATA 3 /* File content */ +#define FSDIR_COLUMN_PATH 4 /* Path to top of search */ +#define FSDIR_COLUMN_DIR 5 /* Path is relative to this directory */ + + +/* +** Set the result stored by context ctx to a blob containing the +** contents of file zName. Or, leave the result unchanged (NULL) +** if the file does not exist or is unreadable. +** +** If the file exceeds the SQLite blob size limit, through an +** SQLITE_TOOBIG error. +** +** Throw an SQLITE_IOERR if there are difficulties pulling the file +** off of disk. +*/ +static void readFileContents(sqlite3_context *ctx, const char *zName){ + FILE *in; + sqlite3_int64 nIn; + void *pBuf; + sqlite3 *db; + int mxBlob; + + in = fopen(zName, "rb"); + if( in==0 ){ + /* File does not exist or is unreadable. Leave the result set to NULL. */ + return; + } + fseek(in, 0, SEEK_END); + nIn = ftell(in); + rewind(in); + db = sqlite3_context_db_handle(ctx); + mxBlob = sqlite3_limit(db, SQLITE_LIMIT_LENGTH, -1); + if( nIn>mxBlob ){ + sqlite3_result_error_code(ctx, SQLITE_TOOBIG); + fclose(in); + return; + } + pBuf = sqlite3_malloc64( nIn ? nIn : 1 ); + if( pBuf==0 ){ + sqlite3_result_error_nomem(ctx); + fclose(in); + return; + } + if( nIn==(sqlite3_int64)fread(pBuf, 1, (size_t)nIn, in) ){ + sqlite3_result_blob64(ctx, pBuf, nIn, sqlite3_free); + }else{ + sqlite3_result_error_code(ctx, SQLITE_IOERR); + sqlite3_free(pBuf); + } + fclose(in); +} + +/* +** Implementation of the "readfile(X)" SQL function. The entire content +** of the file named X is read and returned as a BLOB. NULL is returned +** if the file does not exist or is unreadable. +*/ +static void readfileFunc( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + const char *zName; + (void)(argc); /* Unused parameter */ + zName = (const char*)sqlite3_value_text(argv[0]); + if( zName==0 ) return; + readFileContents(context, zName); +} + +/* +** Set the error message contained in context ctx to the results of +** vprintf(zFmt, ...). +*/ +static void ctxErrorMsg(sqlite3_context *ctx, const char *zFmt, ...){ + char *zMsg = 0; + va_list ap; + va_start(ap, zFmt); + zMsg = sqlite3_vmprintf(zFmt, ap); + sqlite3_result_error(ctx, zMsg, -1); + sqlite3_free(zMsg); + va_end(ap); +} + +#if defined(_WIN32) +/* +** This function is designed to convert a Win32 FILETIME structure into the +** number of seconds since the Unix Epoch (1970-01-01 00:00:00 UTC). +*/ +static sqlite3_uint64 fileTimeToUnixTime( + LPFILETIME pFileTime +){ + SYSTEMTIME epochSystemTime; + ULARGE_INTEGER epochIntervals; + FILETIME epochFileTime; + ULARGE_INTEGER fileIntervals; + + memset(&epochSystemTime, 0, sizeof(SYSTEMTIME)); + epochSystemTime.wYear = 1970; + epochSystemTime.wMonth = 1; + epochSystemTime.wDay = 1; + SystemTimeToFileTime(&epochSystemTime, &epochFileTime); + epochIntervals.LowPart = epochFileTime.dwLowDateTime; + epochIntervals.HighPart = epochFileTime.dwHighDateTime; + + fileIntervals.LowPart = pFileTime->dwLowDateTime; + fileIntervals.HighPart = pFileTime->dwHighDateTime; + + return (fileIntervals.QuadPart - epochIntervals.QuadPart) / 10000000; +} + + +#if defined(FILEIO_WIN32_DLL) && (defined(_WIN32) || defined(WIN32)) +# /* To allow a standalone DLL, use this next replacement function: */ +# undef sqlite3_win32_utf8_to_unicode +# define sqlite3_win32_utf8_to_unicode utf8_to_utf16 +# +LPWSTR utf8_to_utf16(const char *z){ + int nAllot = MultiByteToWideChar(CP_UTF8, 0, z, -1, NULL, 0); + LPWSTR rv = sqlite3_malloc(nAllot * sizeof(WCHAR)); + if( rv!=0 && 0 < MultiByteToWideChar(CP_UTF8, 0, z, -1, rv, nAllot) ) + return rv; + sqlite3_free(rv); + return 0; +} +#endif + +/* +** This function attempts to normalize the time values found in the stat() +** buffer to UTC. This is necessary on Win32, where the runtime library +** appears to return these values as local times. +*/ +static void statTimesToUtc( + const char *zPath, + struct stat *pStatBuf +){ + HANDLE hFindFile; + WIN32_FIND_DATAW fd; + LPWSTR zUnicodeName; + extern LPWSTR sqlite3_win32_utf8_to_unicode(const char*); + zUnicodeName = sqlite3_win32_utf8_to_unicode(zPath); + if( zUnicodeName ){ + memset(&fd, 0, sizeof(WIN32_FIND_DATAW)); + hFindFile = FindFirstFileW(zUnicodeName, &fd); + if( hFindFile!=NULL ){ + pStatBuf->st_ctime = (time_t)fileTimeToUnixTime(&fd.ftCreationTime); + pStatBuf->st_atime = (time_t)fileTimeToUnixTime(&fd.ftLastAccessTime); + pStatBuf->st_mtime = (time_t)fileTimeToUnixTime(&fd.ftLastWriteTime); + FindClose(hFindFile); + } + sqlite3_free(zUnicodeName); + } +} +#endif + +/* +** This function is used in place of stat(). On Windows, special handling +** is required in order for the included time to be returned as UTC. On all +** other systems, this function simply calls stat(). +*/ +static int fileStat( + const char *zPath, + struct stat *pStatBuf +){ +#if defined(_WIN32) + int rc = stat(zPath, pStatBuf); + if( rc==0 ) statTimesToUtc(zPath, pStatBuf); + return rc; +#else + return stat(zPath, pStatBuf); +#endif +} + +/* +** This function is used in place of lstat(). On Windows, special handling +** is required in order for the included time to be returned as UTC. On all +** other systems, this function simply calls lstat(). +*/ +static int fileLinkStat( + const char *zPath, + struct stat *pStatBuf +){ +#if defined(_WIN32) + int rc = lstat(zPath, pStatBuf); + if( rc==0 ) statTimesToUtc(zPath, pStatBuf); + return rc; +#else + return lstat(zPath, pStatBuf); +#endif +} + +/* +** Argument zFile is the name of a file that will be created and/or written +** by SQL function writefile(). This function ensures that the directory +** zFile will be written to exists, creating it if required. The permissions +** for any path components created by this function are set in accordance +** with the current umask. +** +** If an OOM condition is encountered, SQLITE_NOMEM is returned. Otherwise, +** SQLITE_OK is returned if the directory is successfully created, or +** SQLITE_ERROR otherwise. +*/ +static int makeDirectory( + const char *zFile +){ + char *zCopy = sqlite3_mprintf("%s", zFile); + int rc = SQLITE_OK; + + if( zCopy==0 ){ + rc = SQLITE_NOMEM; + }else{ + int nCopy = (int)strlen(zCopy); + int i = 1; + + while( rc==SQLITE_OK ){ + struct stat sStat; + int rc2; + + for(; zCopy[i]!='/' && i=0 ){ +#if defined(_WIN32) +#if !SQLITE_OS_WINRT + /* Windows */ + FILETIME lastAccess; + FILETIME lastWrite; + SYSTEMTIME currentTime; + LONGLONG intervals; + HANDLE hFile; + LPWSTR zUnicodeName; + extern LPWSTR sqlite3_win32_utf8_to_unicode(const char*); + + GetSystemTime(¤tTime); + SystemTimeToFileTime(¤tTime, &lastAccess); + intervals = Int32x32To64(mtime, 10000000) + 116444736000000000; + lastWrite.dwLowDateTime = (DWORD)intervals; + lastWrite.dwHighDateTime = intervals >> 32; + zUnicodeName = sqlite3_win32_utf8_to_unicode(zFile); + if( zUnicodeName==0 ){ + return 1; + } + hFile = CreateFileW( + zUnicodeName, FILE_WRITE_ATTRIBUTES, 0, NULL, OPEN_EXISTING, + FILE_FLAG_BACKUP_SEMANTICS, NULL + ); + sqlite3_free(zUnicodeName); + if( hFile!=INVALID_HANDLE_VALUE ){ + BOOL bResult = SetFileTime(hFile, NULL, &lastAccess, &lastWrite); + CloseHandle(hFile); + return !bResult; + }else{ + return 1; + } +#endif +#elif defined(AT_FDCWD) && 0 /* utimensat() is not universally available */ + /* Recent unix */ + struct timespec times[2]; + times[0].tv_nsec = times[1].tv_nsec = 0; + times[0].tv_sec = time(0); + times[1].tv_sec = mtime; + if( utimensat(AT_FDCWD, zFile, times, AT_SYMLINK_NOFOLLOW) ){ + return 1; + } +#else + /* Legacy unix */ + struct timeval times[2]; + times[0].tv_usec = times[1].tv_usec = 0; + times[0].tv_sec = time(0); + times[1].tv_sec = mtime; + if( utimes(zFile, times) ){ + return 1; + } +#endif + } + + return 0; +} + +/* +** Implementation of the "writefile(W,X[,Y[,Z]]])" SQL function. +** Refer to header comments at the top of this file for details. +*/ +static void writefileFunc( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + const char *zFile; + mode_t mode = 0; + int res; + sqlite3_int64 mtime = -1; + + if( argc<2 || argc>4 ){ + sqlite3_result_error(context, + "wrong number of arguments to function writefile()", -1 + ); + return; + } + + zFile = (const char*)sqlite3_value_text(argv[0]); + if( zFile==0 ) return; + if( argc>=3 ){ + mode = (mode_t)sqlite3_value_int(argv[2]); + } + if( argc==4 ){ + mtime = sqlite3_value_int64(argv[3]); + } + + res = writeFile(context, zFile, argv[1], mode, mtime); + if( res==1 && errno==ENOENT ){ + if( makeDirectory(zFile)==SQLITE_OK ){ + res = writeFile(context, zFile, argv[1], mode, mtime); + } + } + + if( argc>2 && res!=0 ){ + if( S_ISLNK(mode) ){ + ctxErrorMsg(context, "failed to create symlink: %s", zFile); + }else if( S_ISDIR(mode) ){ + ctxErrorMsg(context, "failed to create directory: %s", zFile); + }else{ + ctxErrorMsg(context, "failed to write file: %s", zFile); + } + } +} + +/* +** SQL function: lsmode(MODE) +** +** Given a numberic st_mode from stat(), convert it into a human-readable +** text string in the style of "ls -l". +*/ +static void lsModeFunc( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + int i; + int iMode = sqlite3_value_int(argv[0]); + char z[16]; + (void)argc; + if( S_ISLNK(iMode) ){ + z[0] = 'l'; + }else if( S_ISREG(iMode) ){ + z[0] = '-'; + }else if( S_ISDIR(iMode) ){ + z[0] = 'd'; + }else{ + z[0] = '?'; + } + for(i=0; i<3; i++){ + int m = (iMode >> ((2-i)*3)); + char *a = &z[1 + i*3]; + a[0] = (m & 0x4) ? 'r' : '-'; + a[1] = (m & 0x2) ? 'w' : '-'; + a[2] = (m & 0x1) ? 'x' : '-'; + } + z[10] = '\0'; + sqlite3_result_text(context, z, -1, SQLITE_TRANSIENT); +} + +#ifndef SQLITE_OMIT_VIRTUALTABLE + +/* +** Cursor type for recursively iterating through a directory structure. +*/ +typedef struct fsdir_cursor fsdir_cursor; +typedef struct FsdirLevel FsdirLevel; + +struct FsdirLevel { + DIR *pDir; /* From opendir() */ + char *zDir; /* Name of directory (nul-terminated) */ +}; + +struct fsdir_cursor { + sqlite3_vtab_cursor base; /* Base class - must be first */ + + int nLvl; /* Number of entries in aLvl[] array */ + int iLvl; /* Index of current entry */ + FsdirLevel *aLvl; /* Hierarchy of directories being traversed */ + + const char *zBase; + int nBase; + + struct stat sStat; /* Current lstat() results */ + char *zPath; /* Path to current entry */ + sqlite3_int64 iRowid; /* Current rowid */ +}; + +typedef struct fsdir_tab fsdir_tab; +struct fsdir_tab { + sqlite3_vtab base; /* Base class - must be first */ +}; + +/* +** Construct a new fsdir virtual table object. +*/ +static int fsdirConnect( + sqlite3 *db, + void *pAux, + int argc, const char *const*argv, + sqlite3_vtab **ppVtab, + char **pzErr +){ + fsdir_tab *pNew = 0; + int rc; + (void)pAux; + (void)argc; + (void)argv; + (void)pzErr; + rc = sqlite3_declare_vtab(db, "CREATE TABLE x" FSDIR_SCHEMA); + if( rc==SQLITE_OK ){ + pNew = (fsdir_tab*)sqlite3_malloc( sizeof(*pNew) ); + if( pNew==0 ) return SQLITE_NOMEM; + memset(pNew, 0, sizeof(*pNew)); + sqlite3_vtab_config(db, SQLITE_VTAB_DIRECTONLY); + } + *ppVtab = (sqlite3_vtab*)pNew; + return rc; +} + +/* +** This method is the destructor for fsdir vtab objects. +*/ +static int fsdirDisconnect(sqlite3_vtab *pVtab){ + sqlite3_free(pVtab); + return SQLITE_OK; +} + +/* +** Constructor for a new fsdir_cursor object. +*/ +static int fsdirOpen(sqlite3_vtab *p, sqlite3_vtab_cursor **ppCursor){ + fsdir_cursor *pCur; + (void)p; + pCur = sqlite3_malloc( sizeof(*pCur) ); + if( pCur==0 ) return SQLITE_NOMEM; + memset(pCur, 0, sizeof(*pCur)); + pCur->iLvl = -1; + *ppCursor = &pCur->base; + return SQLITE_OK; +} + +/* +** Reset a cursor back to the state it was in when first returned +** by fsdirOpen(). +*/ +static void fsdirResetCursor(fsdir_cursor *pCur){ + int i; + for(i=0; i<=pCur->iLvl; i++){ + FsdirLevel *pLvl = &pCur->aLvl[i]; + if( pLvl->pDir ) closedir(pLvl->pDir); + sqlite3_free(pLvl->zDir); + } + sqlite3_free(pCur->zPath); + sqlite3_free(pCur->aLvl); + pCur->aLvl = 0; + pCur->zPath = 0; + pCur->zBase = 0; + pCur->nBase = 0; + pCur->nLvl = 0; + pCur->iLvl = -1; + pCur->iRowid = 1; +} + +/* +** Destructor for an fsdir_cursor. +*/ +static int fsdirClose(sqlite3_vtab_cursor *cur){ + fsdir_cursor *pCur = (fsdir_cursor*)cur; + + fsdirResetCursor(pCur); + sqlite3_free(pCur); + return SQLITE_OK; +} + +/* +** Set the error message for the virtual table associated with cursor +** pCur to the results of vprintf(zFmt, ...). +*/ +static void fsdirSetErrmsg(fsdir_cursor *pCur, const char *zFmt, ...){ + va_list ap; + va_start(ap, zFmt); + pCur->base.pVtab->zErrMsg = sqlite3_vmprintf(zFmt, ap); + va_end(ap); +} + + +/* +** Advance an fsdir_cursor to its next row of output. +*/ +static int fsdirNext(sqlite3_vtab_cursor *cur){ + fsdir_cursor *pCur = (fsdir_cursor*)cur; + mode_t m = pCur->sStat.st_mode; + + pCur->iRowid++; + if( S_ISDIR(m) ){ + /* Descend into this directory */ + int iNew = pCur->iLvl + 1; + FsdirLevel *pLvl; + if( iNew>=pCur->nLvl ){ + int nNew = iNew+1; + sqlite3_int64 nByte = nNew*sizeof(FsdirLevel); + FsdirLevel *aNew = (FsdirLevel*)sqlite3_realloc64(pCur->aLvl, nByte); + if( aNew==0 ) return SQLITE_NOMEM; + memset(&aNew[pCur->nLvl], 0, sizeof(FsdirLevel)*(nNew-pCur->nLvl)); + pCur->aLvl = aNew; + pCur->nLvl = nNew; + } + pCur->iLvl = iNew; + pLvl = &pCur->aLvl[iNew]; + + pLvl->zDir = pCur->zPath; + pCur->zPath = 0; + pLvl->pDir = opendir(pLvl->zDir); + if( pLvl->pDir==0 ){ + fsdirSetErrmsg(pCur, "cannot read directory: %s", pCur->zPath); + return SQLITE_ERROR; + } + } + + while( pCur->iLvl>=0 ){ + FsdirLevel *pLvl = &pCur->aLvl[pCur->iLvl]; + struct dirent *pEntry = readdir(pLvl->pDir); + if( pEntry ){ + if( pEntry->d_name[0]=='.' ){ + if( pEntry->d_name[1]=='.' && pEntry->d_name[2]=='\0' ) continue; + if( pEntry->d_name[1]=='\0' ) continue; + } + sqlite3_free(pCur->zPath); + pCur->zPath = sqlite3_mprintf("%s/%s", pLvl->zDir, pEntry->d_name); + if( pCur->zPath==0 ) return SQLITE_NOMEM; + if( fileLinkStat(pCur->zPath, &pCur->sStat) ){ + fsdirSetErrmsg(pCur, "cannot stat file: %s", pCur->zPath); + return SQLITE_ERROR; + } + return SQLITE_OK; + } + closedir(pLvl->pDir); + sqlite3_free(pLvl->zDir); + pLvl->pDir = 0; + pLvl->zDir = 0; + pCur->iLvl--; + } + + /* EOF */ + sqlite3_free(pCur->zPath); + pCur->zPath = 0; + return SQLITE_OK; +} + +/* +** Return values of columns for the row at which the series_cursor +** is currently pointing. +*/ +static int fsdirColumn( + sqlite3_vtab_cursor *cur, /* The cursor */ + sqlite3_context *ctx, /* First argument to sqlite3_result_...() */ + int i /* Which column to return */ +){ + fsdir_cursor *pCur = (fsdir_cursor*)cur; + switch( i ){ + case FSDIR_COLUMN_NAME: { + sqlite3_result_text(ctx, &pCur->zPath[pCur->nBase], -1, SQLITE_TRANSIENT); + break; + } + + case FSDIR_COLUMN_MODE: + sqlite3_result_int64(ctx, pCur->sStat.st_mode); + break; + + case FSDIR_COLUMN_MTIME: + sqlite3_result_int64(ctx, pCur->sStat.st_mtime); + break; + + case FSDIR_COLUMN_DATA: { + mode_t m = pCur->sStat.st_mode; + if( S_ISDIR(m) ){ + sqlite3_result_null(ctx); +#if !defined(_WIN32) && !defined(WIN32) + }else if( S_ISLNK(m) ){ + char aStatic[64]; + char *aBuf = aStatic; + sqlite3_int64 nBuf = 64; + int n; + + while( 1 ){ + n = readlink(pCur->zPath, aBuf, nBuf); + if( nzPath); + } + } + case FSDIR_COLUMN_PATH: + default: { + /* The FSDIR_COLUMN_PATH and FSDIR_COLUMN_DIR are input parameters. + ** always return their values as NULL */ + break; + } + } + return SQLITE_OK; +} + +/* +** Return the rowid for the current row. In this implementation, the +** first row returned is assigned rowid value 1, and each subsequent +** row a value 1 more than that of the previous. +*/ +static int fsdirRowid(sqlite3_vtab_cursor *cur, sqlite_int64 *pRowid){ + fsdir_cursor *pCur = (fsdir_cursor*)cur; + *pRowid = pCur->iRowid; + return SQLITE_OK; +} + +/* +** Return TRUE if the cursor has been moved off of the last +** row of output. +*/ +static int fsdirEof(sqlite3_vtab_cursor *cur){ + fsdir_cursor *pCur = (fsdir_cursor*)cur; + return (pCur->zPath==0); +} + +/* +** xFilter callback. +** +** idxNum==1 PATH parameter only +** idxNum==2 Both PATH and DIR supplied +*/ +static int fsdirFilter( + sqlite3_vtab_cursor *cur, + int idxNum, const char *idxStr, + int argc, sqlite3_value **argv +){ + const char *zDir = 0; + fsdir_cursor *pCur = (fsdir_cursor*)cur; + (void)idxStr; + fsdirResetCursor(pCur); + + if( idxNum==0 ){ + fsdirSetErrmsg(pCur, "table function fsdir requires an argument"); + return SQLITE_ERROR; + } + + assert( argc==idxNum && (argc==1 || argc==2) ); + zDir = (const char*)sqlite3_value_text(argv[0]); + if( zDir==0 ){ + fsdirSetErrmsg(pCur, "table function fsdir requires a non-NULL argument"); + return SQLITE_ERROR; + } + if( argc==2 ){ + pCur->zBase = (const char*)sqlite3_value_text(argv[1]); + } + if( pCur->zBase ){ + pCur->nBase = (int)strlen(pCur->zBase)+1; + pCur->zPath = sqlite3_mprintf("%s/%s", pCur->zBase, zDir); + }else{ + pCur->zPath = sqlite3_mprintf("%s", zDir); + } + + if( pCur->zPath==0 ){ + return SQLITE_NOMEM; + } + if( fileLinkStat(pCur->zPath, &pCur->sStat) ){ + fsdirSetErrmsg(pCur, "cannot stat file: %s", pCur->zPath); + return SQLITE_ERROR; + } + + return SQLITE_OK; +} + +/* +** SQLite will invoke this method one or more times while planning a query +** that uses the generate_series virtual table. This routine needs to create +** a query plan for each invocation and compute an estimated cost for that +** plan. +** +** In this implementation idxNum is used to represent the +** query plan. idxStr is unused. +** +** The query plan is represented by values of idxNum: +** +** (1) The path value is supplied by argv[0] +** (2) Path is in argv[0] and dir is in argv[1] +*/ +static int fsdirBestIndex( + sqlite3_vtab *tab, + sqlite3_index_info *pIdxInfo +){ + int i; /* Loop over constraints */ + int idxPath = -1; /* Index in pIdxInfo->aConstraint of PATH= */ + int idxDir = -1; /* Index in pIdxInfo->aConstraint of DIR= */ + int seenPath = 0; /* True if an unusable PATH= constraint is seen */ + int seenDir = 0; /* True if an unusable DIR= constraint is seen */ + const struct sqlite3_index_constraint *pConstraint; + + (void)tab; + pConstraint = pIdxInfo->aConstraint; + for(i=0; inConstraint; i++, pConstraint++){ + if( pConstraint->op!=SQLITE_INDEX_CONSTRAINT_EQ ) continue; + switch( pConstraint->iColumn ){ + case FSDIR_COLUMN_PATH: { + if( pConstraint->usable ){ + idxPath = i; + seenPath = 0; + }else if( idxPath<0 ){ + seenPath = 1; + } + break; + } + case FSDIR_COLUMN_DIR: { + if( pConstraint->usable ){ + idxDir = i; + seenDir = 0; + }else if( idxDir<0 ){ + seenDir = 1; + } + break; + } + } + } + if( seenPath || seenDir ){ + /* If input parameters are unusable, disallow this plan */ + return SQLITE_CONSTRAINT; + } + + if( idxPath<0 ){ + pIdxInfo->idxNum = 0; + /* The pIdxInfo->estimatedCost should have been initialized to a huge + ** number. Leave it unchanged. */ + pIdxInfo->estimatedRows = 0x7fffffff; + }else{ + pIdxInfo->aConstraintUsage[idxPath].omit = 1; + pIdxInfo->aConstraintUsage[idxPath].argvIndex = 1; + if( idxDir>=0 ){ + pIdxInfo->aConstraintUsage[idxDir].omit = 1; + pIdxInfo->aConstraintUsage[idxDir].argvIndex = 2; + pIdxInfo->idxNum = 2; + pIdxInfo->estimatedCost = 10.0; + }else{ + pIdxInfo->idxNum = 1; + pIdxInfo->estimatedCost = 100.0; + } + } + + return SQLITE_OK; +} + +/* +** Register the "fsdir" virtual table. +*/ +static int fsdirRegister(sqlite3 *db){ + static sqlite3_module fsdirModule = { + 0, /* iVersion */ + 0, /* xCreate */ + fsdirConnect, /* xConnect */ + fsdirBestIndex, /* xBestIndex */ + fsdirDisconnect, /* xDisconnect */ + 0, /* xDestroy */ + fsdirOpen, /* xOpen - open a cursor */ + fsdirClose, /* xClose - close a cursor */ + fsdirFilter, /* xFilter - configure scan constraints */ + fsdirNext, /* xNext - advance a cursor */ + fsdirEof, /* xEof - check for end of scan */ + fsdirColumn, /* xColumn - read data */ + fsdirRowid, /* xRowid - read data */ + 0, /* xUpdate */ + 0, /* xBegin */ + 0, /* xSync */ + 0, /* xCommit */ + 0, /* xRollback */ + 0, /* xFindMethod */ + 0, /* xRename */ + 0, /* xSavepoint */ + 0, /* xRelease */ + 0, /* xRollbackTo */ + 0, /* xShadowName */ + }; + + int rc = sqlite3_create_module(db, "fsdir", &fsdirModule, 0); + return rc; +} +#else /* SQLITE_OMIT_VIRTUALTABLE */ +# define fsdirRegister(x) SQLITE_OK +#endif + +#ifdef _WIN32 + +#endif +int sqlite3_fileio_init( + sqlite3 *db, + char **pzErrMsg, + const sqlite3_api_routines *pApi +){ + int rc = SQLITE_OK; + SQLITE_EXTENSION_INIT2(pApi); + (void)pzErrMsg; /* Unused parameter */ + rc = sqlite3_create_function(db, "readfile", 1, + SQLITE_UTF8|SQLITE_DIRECTONLY, 0, + readfileFunc, 0, 0); + if( rc==SQLITE_OK ){ + rc = sqlite3_create_function(db, "writefile", -1, + SQLITE_UTF8|SQLITE_DIRECTONLY, 0, + writefileFunc, 0, 0); + } + if( rc==SQLITE_OK ){ + rc = sqlite3_create_function(db, "lsmode", 1, SQLITE_UTF8, 0, + lsModeFunc, 0, 0); + } + if( rc==SQLITE_OK ){ + rc = fsdirRegister(db); + } + return rc; +} + +#if defined(FILEIO_WIN32_DLL) && (defined(_WIN32) || defined(WIN32)) +/* To allow a standalone DLL, make test_windirent.c use the same + * redefined SQLite API calls as the above extension code does. + * Just pull in this .c to accomplish this. As a beneficial side + * effect, this extension becomes a single translation unit. */ +# include "test_windirent.c" +#endif + +/************************* End ../ext/misc/fileio.c ********************/ +/************************* Begin ../ext/misc/completion.c ******************/ +/* +** 2017-07-10 +** +** The author disclaims copyright to this source code. In place of +** a legal notice, here is a blessing: +** +** May you do good and not evil. +** May you find forgiveness for yourself and forgive others. +** May you share freely, never taking more than you give. +** +************************************************************************* +** +** This file implements an eponymous virtual table that returns suggested +** completions for a partial SQL input. +** +** Suggested usage: +** +** SELECT DISTINCT candidate COLLATE nocase +** FROM completion($prefix,$wholeline) +** ORDER BY 1; +** +** The two query parameters are optional. $prefix is the text of the +** current word being typed and that is to be completed. $wholeline is +** the complete input line, used for context. +** +** The raw completion() table might return the same candidate multiple +** times, for example if the same column name is used to two or more +** tables. And the candidates are returned in an arbitrary order. Hence, +** the DISTINCT and ORDER BY are recommended. +** +** This virtual table operates at the speed of human typing, and so there +** is no attempt to make it fast. Even a slow implementation will be much +** faster than any human can type. +** +*/ +/* #include "sqlite3ext.h" */ +SQLITE_EXTENSION_INIT1 +#include +#include +#include + +#ifndef SQLITE_OMIT_VIRTUALTABLE + +/* completion_vtab is a subclass of sqlite3_vtab which will +** serve as the underlying representation of a completion virtual table +*/ +typedef struct completion_vtab completion_vtab; +struct completion_vtab { + sqlite3_vtab base; /* Base class - must be first */ + sqlite3 *db; /* Database connection for this completion vtab */ +}; + +/* completion_cursor is a subclass of sqlite3_vtab_cursor which will +** serve as the underlying representation of a cursor that scans +** over rows of the result +*/ +typedef struct completion_cursor completion_cursor; +struct completion_cursor { + sqlite3_vtab_cursor base; /* Base class - must be first */ + sqlite3 *db; /* Database connection for this cursor */ + int nPrefix, nLine; /* Number of bytes in zPrefix and zLine */ + char *zPrefix; /* The prefix for the word we want to complete */ + char *zLine; /* The whole that we want to complete */ + const char *zCurrentRow; /* Current output row */ + int szRow; /* Length of the zCurrentRow string */ + sqlite3_stmt *pStmt; /* Current statement */ + sqlite3_int64 iRowid; /* The rowid */ + int ePhase; /* Current phase */ + int j; /* inter-phase counter */ +}; + +/* Values for ePhase: +*/ +#define COMPLETION_FIRST_PHASE 1 +#define COMPLETION_KEYWORDS 1 +#define COMPLETION_PRAGMAS 2 +#define COMPLETION_FUNCTIONS 3 +#define COMPLETION_COLLATIONS 4 +#define COMPLETION_INDEXES 5 +#define COMPLETION_TRIGGERS 6 +#define COMPLETION_DATABASES 7 +#define COMPLETION_TABLES 8 /* Also VIEWs and TRIGGERs */ +#define COMPLETION_COLUMNS 9 +#define COMPLETION_MODULES 10 +#define COMPLETION_EOF 11 + +/* +** The completionConnect() method is invoked to create a new +** completion_vtab that describes the completion virtual table. +** +** Think of this routine as the constructor for completion_vtab objects. +** +** All this routine needs to do is: +** +** (1) Allocate the completion_vtab object and initialize all fields. +** +** (2) Tell SQLite (via the sqlite3_declare_vtab() interface) what the +** result set of queries against completion will look like. +*/ +static int completionConnect( + sqlite3 *db, + void *pAux, + int argc, const char *const*argv, + sqlite3_vtab **ppVtab, + char **pzErr +){ + completion_vtab *pNew; + int rc; + + (void)(pAux); /* Unused parameter */ + (void)(argc); /* Unused parameter */ + (void)(argv); /* Unused parameter */ + (void)(pzErr); /* Unused parameter */ + +/* Column numbers */ +#define COMPLETION_COLUMN_CANDIDATE 0 /* Suggested completion of the input */ +#define COMPLETION_COLUMN_PREFIX 1 /* Prefix of the word to be completed */ +#define COMPLETION_COLUMN_WHOLELINE 2 /* Entire line seen so far */ +#define COMPLETION_COLUMN_PHASE 3 /* ePhase - used for debugging only */ + + sqlite3_vtab_config(db, SQLITE_VTAB_INNOCUOUS); + rc = sqlite3_declare_vtab(db, + "CREATE TABLE x(" + " candidate TEXT," + " prefix TEXT HIDDEN," + " wholeline TEXT HIDDEN," + " phase INT HIDDEN" /* Used for debugging only */ + ")"); + if( rc==SQLITE_OK ){ + pNew = sqlite3_malloc( sizeof(*pNew) ); + *ppVtab = (sqlite3_vtab*)pNew; + if( pNew==0 ) return SQLITE_NOMEM; + memset(pNew, 0, sizeof(*pNew)); + pNew->db = db; + } + return rc; +} + +/* +** This method is the destructor for completion_cursor objects. +*/ +static int completionDisconnect(sqlite3_vtab *pVtab){ + sqlite3_free(pVtab); + return SQLITE_OK; +} + +/* +** Constructor for a new completion_cursor object. +*/ +static int completionOpen(sqlite3_vtab *p, sqlite3_vtab_cursor **ppCursor){ + completion_cursor *pCur; + pCur = sqlite3_malloc( sizeof(*pCur) ); + if( pCur==0 ) return SQLITE_NOMEM; + memset(pCur, 0, sizeof(*pCur)); + pCur->db = ((completion_vtab*)p)->db; + *ppCursor = &pCur->base; + return SQLITE_OK; +} + +/* +** Reset the completion_cursor. +*/ +static void completionCursorReset(completion_cursor *pCur){ + sqlite3_free(pCur->zPrefix); pCur->zPrefix = 0; pCur->nPrefix = 0; + sqlite3_free(pCur->zLine); pCur->zLine = 0; pCur->nLine = 0; + sqlite3_finalize(pCur->pStmt); pCur->pStmt = 0; + pCur->j = 0; +} + +/* +** Destructor for a completion_cursor. +*/ +static int completionClose(sqlite3_vtab_cursor *cur){ + completionCursorReset((completion_cursor*)cur); + sqlite3_free(cur); + return SQLITE_OK; +} + +/* +** Advance a completion_cursor to its next row of output. +** +** The ->ePhase, ->j, and ->pStmt fields of the completion_cursor object +** record the current state of the scan. This routine sets ->zCurrentRow +** to the current row of output and then returns. If no more rows remain, +** then ->ePhase is set to COMPLETION_EOF which will signal the virtual +** table that has reached the end of its scan. +** +** The current implementation just lists potential identifiers and +** keywords and filters them by zPrefix. Future enhancements should +** take zLine into account to try to restrict the set of identifiers and +** keywords based on what would be legal at the current point of input. +*/ +static int completionNext(sqlite3_vtab_cursor *cur){ + completion_cursor *pCur = (completion_cursor*)cur; + int eNextPhase = 0; /* Next phase to try if current phase reaches end */ + int iCol = -1; /* If >=0, step pCur->pStmt and use the i-th column */ + pCur->iRowid++; + while( pCur->ePhase!=COMPLETION_EOF ){ + switch( pCur->ePhase ){ + case COMPLETION_KEYWORDS: { + if( pCur->j >= sqlite3_keyword_count() ){ + pCur->zCurrentRow = 0; + pCur->ePhase = COMPLETION_DATABASES; + }else{ + sqlite3_keyword_name(pCur->j++, &pCur->zCurrentRow, &pCur->szRow); + } + iCol = -1; + break; + } + case COMPLETION_DATABASES: { + if( pCur->pStmt==0 ){ + sqlite3_prepare_v2(pCur->db, "PRAGMA database_list", -1, + &pCur->pStmt, 0); + } + iCol = 1; + eNextPhase = COMPLETION_TABLES; + break; + } + case COMPLETION_TABLES: { + if( pCur->pStmt==0 ){ + sqlite3_stmt *pS2; + char *zSql = 0; + const char *zSep = ""; + sqlite3_prepare_v2(pCur->db, "PRAGMA database_list", -1, &pS2, 0); + while( sqlite3_step(pS2)==SQLITE_ROW ){ + const char *zDb = (const char*)sqlite3_column_text(pS2, 1); + zSql = sqlite3_mprintf( + "%z%s" + "SELECT name FROM \"%w\".sqlite_schema", + zSql, zSep, zDb + ); + if( zSql==0 ) return SQLITE_NOMEM; + zSep = " UNION "; + } + sqlite3_finalize(pS2); + sqlite3_prepare_v2(pCur->db, zSql, -1, &pCur->pStmt, 0); + sqlite3_free(zSql); + } + iCol = 0; + eNextPhase = COMPLETION_COLUMNS; + break; + } + case COMPLETION_COLUMNS: { + if( pCur->pStmt==0 ){ + sqlite3_stmt *pS2; + char *zSql = 0; + const char *zSep = ""; + sqlite3_prepare_v2(pCur->db, "PRAGMA database_list", -1, &pS2, 0); + while( sqlite3_step(pS2)==SQLITE_ROW ){ + const char *zDb = (const char*)sqlite3_column_text(pS2, 1); + zSql = sqlite3_mprintf( + "%z%s" + "SELECT pti.name FROM \"%w\".sqlite_schema AS sm" + " JOIN pragma_table_info(sm.name,%Q) AS pti" + " WHERE sm.type='table'", + zSql, zSep, zDb, zDb + ); + if( zSql==0 ) return SQLITE_NOMEM; + zSep = " UNION "; + } + sqlite3_finalize(pS2); + sqlite3_prepare_v2(pCur->db, zSql, -1, &pCur->pStmt, 0); + sqlite3_free(zSql); + } + iCol = 0; + eNextPhase = COMPLETION_EOF; + break; + } + } + if( iCol<0 ){ + /* This case is when the phase presets zCurrentRow */ + if( pCur->zCurrentRow==0 ) continue; + }else{ + if( sqlite3_step(pCur->pStmt)==SQLITE_ROW ){ + /* Extract the next row of content */ + pCur->zCurrentRow = (const char*)sqlite3_column_text(pCur->pStmt, iCol); + pCur->szRow = sqlite3_column_bytes(pCur->pStmt, iCol); + }else{ + /* When all rows are finished, advance to the next phase */ + sqlite3_finalize(pCur->pStmt); + pCur->pStmt = 0; + pCur->ePhase = eNextPhase; + continue; + } + } + if( pCur->nPrefix==0 ) break; + if( pCur->nPrefix<=pCur->szRow + && sqlite3_strnicmp(pCur->zPrefix, pCur->zCurrentRow, pCur->nPrefix)==0 + ){ + break; + } + } + + return SQLITE_OK; +} + +/* +** Return values of columns for the row at which the completion_cursor +** is currently pointing. +*/ +static int completionColumn( + sqlite3_vtab_cursor *cur, /* The cursor */ + sqlite3_context *ctx, /* First argument to sqlite3_result_...() */ + int i /* Which column to return */ +){ + completion_cursor *pCur = (completion_cursor*)cur; + switch( i ){ + case COMPLETION_COLUMN_CANDIDATE: { + sqlite3_result_text(ctx, pCur->zCurrentRow, pCur->szRow,SQLITE_TRANSIENT); + break; + } + case COMPLETION_COLUMN_PREFIX: { + sqlite3_result_text(ctx, pCur->zPrefix, -1, SQLITE_TRANSIENT); + break; + } + case COMPLETION_COLUMN_WHOLELINE: { + sqlite3_result_text(ctx, pCur->zLine, -1, SQLITE_TRANSIENT); + break; + } + case COMPLETION_COLUMN_PHASE: { + sqlite3_result_int(ctx, pCur->ePhase); + break; + } + } + return SQLITE_OK; +} + +/* +** Return the rowid for the current row. In this implementation, the +** rowid is the same as the output value. +*/ +static int completionRowid(sqlite3_vtab_cursor *cur, sqlite_int64 *pRowid){ + completion_cursor *pCur = (completion_cursor*)cur; + *pRowid = pCur->iRowid; + return SQLITE_OK; +} + +/* +** Return TRUE if the cursor has been moved off of the last +** row of output. +*/ +static int completionEof(sqlite3_vtab_cursor *cur){ + completion_cursor *pCur = (completion_cursor*)cur; + return pCur->ePhase >= COMPLETION_EOF; +} + +/* +** This method is called to "rewind" the completion_cursor object back +** to the first row of output. This method is always called at least +** once prior to any call to completionColumn() or completionRowid() or +** completionEof(). +*/ +static int completionFilter( + sqlite3_vtab_cursor *pVtabCursor, + int idxNum, const char *idxStr, + int argc, sqlite3_value **argv +){ + completion_cursor *pCur = (completion_cursor *)pVtabCursor; + int iArg = 0; + (void)(idxStr); /* Unused parameter */ + (void)(argc); /* Unused parameter */ + completionCursorReset(pCur); + if( idxNum & 1 ){ + pCur->nPrefix = sqlite3_value_bytes(argv[iArg]); + if( pCur->nPrefix>0 ){ + pCur->zPrefix = sqlite3_mprintf("%s", sqlite3_value_text(argv[iArg])); + if( pCur->zPrefix==0 ) return SQLITE_NOMEM; + } + iArg = 1; + } + if( idxNum & 2 ){ + pCur->nLine = sqlite3_value_bytes(argv[iArg]); + if( pCur->nLine>0 ){ + pCur->zLine = sqlite3_mprintf("%s", sqlite3_value_text(argv[iArg])); + if( pCur->zLine==0 ) return SQLITE_NOMEM; + } + } + if( pCur->zLine!=0 && pCur->zPrefix==0 ){ + int i = pCur->nLine; + while( i>0 && (isalnum(pCur->zLine[i-1]) || pCur->zLine[i-1]=='_') ){ + i--; + } + pCur->nPrefix = pCur->nLine - i; + if( pCur->nPrefix>0 ){ + pCur->zPrefix = sqlite3_mprintf("%.*s", pCur->nPrefix, pCur->zLine + i); + if( pCur->zPrefix==0 ) return SQLITE_NOMEM; + } + } + pCur->iRowid = 0; + pCur->ePhase = COMPLETION_FIRST_PHASE; + return completionNext(pVtabCursor); +} + +/* +** SQLite will invoke this method one or more times while planning a query +** that uses the completion virtual table. This routine needs to create +** a query plan for each invocation and compute an estimated cost for that +** plan. +** +** There are two hidden parameters that act as arguments to the table-valued +** function: "prefix" and "wholeline". Bit 0 of idxNum is set if "prefix" +** is available and bit 1 is set if "wholeline" is available. +*/ +static int completionBestIndex( + sqlite3_vtab *tab, + sqlite3_index_info *pIdxInfo +){ + int i; /* Loop over constraints */ + int idxNum = 0; /* The query plan bitmask */ + int prefixIdx = -1; /* Index of the start= constraint, or -1 if none */ + int wholelineIdx = -1; /* Index of the stop= constraint, or -1 if none */ + int nArg = 0; /* Number of arguments that completeFilter() expects */ + const struct sqlite3_index_constraint *pConstraint; + + (void)(tab); /* Unused parameter */ + pConstraint = pIdxInfo->aConstraint; + for(i=0; inConstraint; i++, pConstraint++){ + if( pConstraint->usable==0 ) continue; + if( pConstraint->op!=SQLITE_INDEX_CONSTRAINT_EQ ) continue; + switch( pConstraint->iColumn ){ + case COMPLETION_COLUMN_PREFIX: + prefixIdx = i; + idxNum |= 1; + break; + case COMPLETION_COLUMN_WHOLELINE: + wholelineIdx = i; + idxNum |= 2; + break; + } + } + if( prefixIdx>=0 ){ + pIdxInfo->aConstraintUsage[prefixIdx].argvIndex = ++nArg; + pIdxInfo->aConstraintUsage[prefixIdx].omit = 1; + } + if( wholelineIdx>=0 ){ + pIdxInfo->aConstraintUsage[wholelineIdx].argvIndex = ++nArg; + pIdxInfo->aConstraintUsage[wholelineIdx].omit = 1; + } + pIdxInfo->idxNum = idxNum; + pIdxInfo->estimatedCost = (double)5000 - 1000*nArg; + pIdxInfo->estimatedRows = 500 - 100*nArg; + return SQLITE_OK; +} + +/* +** This following structure defines all the methods for the +** completion virtual table. +*/ +static sqlite3_module completionModule = { + 0, /* iVersion */ + 0, /* xCreate */ + completionConnect, /* xConnect */ + completionBestIndex, /* xBestIndex */ + completionDisconnect, /* xDisconnect */ + 0, /* xDestroy */ + completionOpen, /* xOpen - open a cursor */ + completionClose, /* xClose - close a cursor */ + completionFilter, /* xFilter - configure scan constraints */ + completionNext, /* xNext - advance a cursor */ + completionEof, /* xEof - check for end of scan */ + completionColumn, /* xColumn - read data */ + completionRowid, /* xRowid - read data */ + 0, /* xUpdate */ + 0, /* xBegin */ + 0, /* xSync */ + 0, /* xCommit */ + 0, /* xRollback */ + 0, /* xFindMethod */ + 0, /* xRename */ + 0, /* xSavepoint */ + 0, /* xRelease */ + 0, /* xRollbackTo */ + 0 /* xShadowName */ +}; + +#endif /* SQLITE_OMIT_VIRTUALTABLE */ + +int sqlite3CompletionVtabInit(sqlite3 *db){ + int rc = SQLITE_OK; +#ifndef SQLITE_OMIT_VIRTUALTABLE + rc = sqlite3_create_module(db, "completion", &completionModule, 0); +#endif + return rc; +} + +#ifdef _WIN32 + +#endif +int sqlite3_completion_init( + sqlite3 *db, + char **pzErrMsg, + const sqlite3_api_routines *pApi +){ + int rc = SQLITE_OK; + SQLITE_EXTENSION_INIT2(pApi); + (void)(pzErrMsg); /* Unused parameter */ +#ifndef SQLITE_OMIT_VIRTUALTABLE + rc = sqlite3CompletionVtabInit(db); +#endif + return rc; +} + +/************************* End ../ext/misc/completion.c ********************/ +/************************* Begin ../ext/misc/appendvfs.c ******************/ +/* +** 2017-10-20 +** +** The author disclaims copyright to this source code. In place of +** a legal notice, here is a blessing: +** +** May you do good and not evil. +** May you find forgiveness for yourself and forgive others. +** May you share freely, never taking more than you give. +** +****************************************************************************** +** +** This file implements a VFS shim that allows an SQLite database to be +** appended onto the end of some other file, such as an executable. +** +** A special record must appear at the end of the file that identifies the +** file as an appended database and provides the offset to the first page +** of the exposed content. (Or, it is the length of the content prefix.) +** For best performance page 1 should be located at a disk page boundary, +** though that is not required. +** +** When opening a database using this VFS, the connection might treat +** the file as an ordinary SQLite database, or it might treat it as a +** database appended onto some other file. The decision is made by +** applying the following rules in order: +** +** (1) An empty file is an ordinary database. +** +** (2) If the file ends with the appendvfs trailer string +** "Start-Of-SQLite3-NNNNNNNN" that file is an appended database. +** +** (3) If the file begins with the standard SQLite prefix string +** "SQLite format 3", that file is an ordinary database. +** +** (4) If none of the above apply and the SQLITE_OPEN_CREATE flag is +** set, then a new database is appended to the already existing file. +** +** (5) Otherwise, SQLITE_CANTOPEN is returned. +** +** To avoid unnecessary complications with the PENDING_BYTE, the size of +** the file containing the database is limited to 1GiB. (1073741824 bytes) +** This VFS will not read or write past the 1GiB mark. This restriction +** might be lifted in future versions. For now, if you need a larger +** database, then keep it in a separate file. +** +** If the file being opened is a plain database (not an appended one), then +** this shim is a pass-through into the default underlying VFS. (rule 3) +**/ +/* #include "sqlite3ext.h" */ +SQLITE_EXTENSION_INIT1 +#include +#include + +/* The append mark at the end of the database is: +** +** Start-Of-SQLite3-NNNNNNNN +** 123456789 123456789 12345 +** +** The NNNNNNNN represents a 64-bit big-endian unsigned integer which is +** the offset to page 1, and also the length of the prefix content. +*/ +#define APND_MARK_PREFIX "Start-Of-SQLite3-" +#define APND_MARK_PREFIX_SZ 17 +#define APND_MARK_FOS_SZ 8 +#define APND_MARK_SIZE (APND_MARK_PREFIX_SZ+APND_MARK_FOS_SZ) + +/* +** Maximum size of the combined prefix + database + append-mark. This +** must be less than 0x40000000 to avoid locking issues on Windows. +*/ +#define APND_MAX_SIZE (0x40000000) + +/* +** Try to align the database to an even multiple of APND_ROUNDUP bytes. +*/ +#ifndef APND_ROUNDUP +#define APND_ROUNDUP 4096 +#endif +#define APND_ALIGN_MASK ((sqlite3_int64)(APND_ROUNDUP-1)) +#define APND_START_ROUNDUP(fsz) (((fsz)+APND_ALIGN_MASK) & ~APND_ALIGN_MASK) + +/* +** Forward declaration of objects used by this utility +*/ +typedef struct sqlite3_vfs ApndVfs; +typedef struct ApndFile ApndFile; + +/* Access to a lower-level VFS that (might) implement dynamic loading, +** access to randomness, etc. +*/ +#define ORIGVFS(p) ((sqlite3_vfs*)((p)->pAppData)) +#define ORIGFILE(p) ((sqlite3_file*)(((ApndFile*)(p))+1)) + +/* An open appendvfs file +** +** An instance of this structure describes the appended database file. +** A separate sqlite3_file object is always appended. The appended +** sqlite3_file object (which can be accessed using ORIGFILE()) describes +** the entire file, including the prefix, the database, and the +** append-mark. +** +** The structure of an AppendVFS database is like this: +** +** +-------------+---------+----------+-------------+ +** | prefix-file | padding | database | append-mark | +** +-------------+---------+----------+-------------+ +** ^ ^ +** | | +** iPgOne iMark +** +** +** "prefix file" - file onto which the database has been appended. +** "padding" - zero or more bytes inserted so that "database" +** starts on an APND_ROUNDUP boundary +** "database" - The SQLite database file +** "append-mark" - The 25-byte "Start-Of-SQLite3-NNNNNNNN" that indicates +** the offset from the start of prefix-file to the start +** of "database". +** +** The size of the database is iMark - iPgOne. +** +** The NNNNNNNN in the "Start-Of-SQLite3-NNNNNNNN" suffix is the value +** of iPgOne stored as a big-ending 64-bit integer. +** +** iMark will be the size of the underlying file minus 25 (APND_MARKSIZE). +** Or, iMark is -1 to indicate that it has not yet been written. +*/ +struct ApndFile { + sqlite3_file base; /* Subclass. MUST BE FIRST! */ + sqlite3_int64 iPgOne; /* Offset to the start of the database */ + sqlite3_int64 iMark; /* Offset of the append mark. -1 if unwritten */ + /* Always followed by another sqlite3_file that describes the whole file */ +}; + +/* +** Methods for ApndFile +*/ +static int apndClose(sqlite3_file*); +static int apndRead(sqlite3_file*, void*, int iAmt, sqlite3_int64 iOfst); +static int apndWrite(sqlite3_file*,const void*,int iAmt, sqlite3_int64 iOfst); +static int apndTruncate(sqlite3_file*, sqlite3_int64 size); +static int apndSync(sqlite3_file*, int flags); +static int apndFileSize(sqlite3_file*, sqlite3_int64 *pSize); +static int apndLock(sqlite3_file*, int); +static int apndUnlock(sqlite3_file*, int); +static int apndCheckReservedLock(sqlite3_file*, int *pResOut); +static int apndFileControl(sqlite3_file*, int op, void *pArg); +static int apndSectorSize(sqlite3_file*); +static int apndDeviceCharacteristics(sqlite3_file*); +static int apndShmMap(sqlite3_file*, int iPg, int pgsz, int, void volatile**); +static int apndShmLock(sqlite3_file*, int offset, int n, int flags); +static void apndShmBarrier(sqlite3_file*); +static int apndShmUnmap(sqlite3_file*, int deleteFlag); +static int apndFetch(sqlite3_file*, sqlite3_int64 iOfst, int iAmt, void **pp); +static int apndUnfetch(sqlite3_file*, sqlite3_int64 iOfst, void *p); + +/* +** Methods for ApndVfs +*/ +static int apndOpen(sqlite3_vfs*, const char *, sqlite3_file*, int , int *); +static int apndDelete(sqlite3_vfs*, const char *zName, int syncDir); +static int apndAccess(sqlite3_vfs*, const char *zName, int flags, int *); +static int apndFullPathname(sqlite3_vfs*, const char *zName, int, char *zOut); +static void *apndDlOpen(sqlite3_vfs*, const char *zFilename); +static void apndDlError(sqlite3_vfs*, int nByte, char *zErrMsg); +static void (*apndDlSym(sqlite3_vfs *pVfs, void *p, const char*zSym))(void); +static void apndDlClose(sqlite3_vfs*, void*); +static int apndRandomness(sqlite3_vfs*, int nByte, char *zOut); +static int apndSleep(sqlite3_vfs*, int microseconds); +static int apndCurrentTime(sqlite3_vfs*, double*); +static int apndGetLastError(sqlite3_vfs*, int, char *); +static int apndCurrentTimeInt64(sqlite3_vfs*, sqlite3_int64*); +static int apndSetSystemCall(sqlite3_vfs*, const char*,sqlite3_syscall_ptr); +static sqlite3_syscall_ptr apndGetSystemCall(sqlite3_vfs*, const char *z); +static const char *apndNextSystemCall(sqlite3_vfs*, const char *zName); + +static sqlite3_vfs apnd_vfs = { + 3, /* iVersion (set when registered) */ + 0, /* szOsFile (set when registered) */ + 1024, /* mxPathname */ + 0, /* pNext */ + "apndvfs", /* zName */ + 0, /* pAppData (set when registered) */ + apndOpen, /* xOpen */ + apndDelete, /* xDelete */ + apndAccess, /* xAccess */ + apndFullPathname, /* xFullPathname */ + apndDlOpen, /* xDlOpen */ + apndDlError, /* xDlError */ + apndDlSym, /* xDlSym */ + apndDlClose, /* xDlClose */ + apndRandomness, /* xRandomness */ + apndSleep, /* xSleep */ + apndCurrentTime, /* xCurrentTime */ + apndGetLastError, /* xGetLastError */ + apndCurrentTimeInt64, /* xCurrentTimeInt64 */ + apndSetSystemCall, /* xSetSystemCall */ + apndGetSystemCall, /* xGetSystemCall */ + apndNextSystemCall /* xNextSystemCall */ +}; + +static const sqlite3_io_methods apnd_io_methods = { + 3, /* iVersion */ + apndClose, /* xClose */ + apndRead, /* xRead */ + apndWrite, /* xWrite */ + apndTruncate, /* xTruncate */ + apndSync, /* xSync */ + apndFileSize, /* xFileSize */ + apndLock, /* xLock */ + apndUnlock, /* xUnlock */ + apndCheckReservedLock, /* xCheckReservedLock */ + apndFileControl, /* xFileControl */ + apndSectorSize, /* xSectorSize */ + apndDeviceCharacteristics, /* xDeviceCharacteristics */ + apndShmMap, /* xShmMap */ + apndShmLock, /* xShmLock */ + apndShmBarrier, /* xShmBarrier */ + apndShmUnmap, /* xShmUnmap */ + apndFetch, /* xFetch */ + apndUnfetch /* xUnfetch */ +}; + +/* +** Close an apnd-file. +*/ +static int apndClose(sqlite3_file *pFile){ + pFile = ORIGFILE(pFile); + return pFile->pMethods->xClose(pFile); +} + +/* +** Read data from an apnd-file. +*/ +static int apndRead( + sqlite3_file *pFile, + void *zBuf, + int iAmt, + sqlite_int64 iOfst +){ + ApndFile *paf = (ApndFile *)pFile; + pFile = ORIGFILE(pFile); + return pFile->pMethods->xRead(pFile, zBuf, iAmt, paf->iPgOne+iOfst); +} + +/* +** Add the append-mark onto what should become the end of the file. +* If and only if this succeeds, internal ApndFile.iMark is updated. +* Parameter iWriteEnd is the appendvfs-relative offset of the new mark. +*/ +static int apndWriteMark( + ApndFile *paf, + sqlite3_file *pFile, + sqlite_int64 iWriteEnd +){ + sqlite_int64 iPgOne = paf->iPgOne; + unsigned char a[APND_MARK_SIZE]; + int i = APND_MARK_FOS_SZ; + int rc; + assert(pFile == ORIGFILE(paf)); + memcpy(a, APND_MARK_PREFIX, APND_MARK_PREFIX_SZ); + while( --i >= 0 ){ + a[APND_MARK_PREFIX_SZ+i] = (unsigned char)(iPgOne & 0xff); + iPgOne >>= 8; + } + iWriteEnd += paf->iPgOne; + if( SQLITE_OK==(rc = pFile->pMethods->xWrite + (pFile, a, APND_MARK_SIZE, iWriteEnd)) ){ + paf->iMark = iWriteEnd; + } + return rc; +} + +/* +** Write data to an apnd-file. +*/ +static int apndWrite( + sqlite3_file *pFile, + const void *zBuf, + int iAmt, + sqlite_int64 iOfst +){ + ApndFile *paf = (ApndFile *)pFile; + sqlite_int64 iWriteEnd = iOfst + iAmt; + if( iWriteEnd>=APND_MAX_SIZE ) return SQLITE_FULL; + pFile = ORIGFILE(pFile); + /* If append-mark is absent or will be overwritten, write it. */ + if( paf->iMark < 0 || paf->iPgOne + iWriteEnd > paf->iMark ){ + int rc = apndWriteMark(paf, pFile, iWriteEnd); + if( SQLITE_OK!=rc ) return rc; + } + return pFile->pMethods->xWrite(pFile, zBuf, iAmt, paf->iPgOne+iOfst); +} + +/* +** Truncate an apnd-file. +*/ +static int apndTruncate(sqlite3_file *pFile, sqlite_int64 size){ + ApndFile *paf = (ApndFile *)pFile; + pFile = ORIGFILE(pFile); + /* The append mark goes out first so truncate failure does not lose it. */ + if( SQLITE_OK!=apndWriteMark(paf, pFile, size) ) return SQLITE_IOERR; + /* Truncate underlying file just past append mark */ + return pFile->pMethods->xTruncate(pFile, paf->iMark+APND_MARK_SIZE); +} + +/* +** Sync an apnd-file. +*/ +static int apndSync(sqlite3_file *pFile, int flags){ + pFile = ORIGFILE(pFile); + return pFile->pMethods->xSync(pFile, flags); +} + +/* +** Return the current file-size of an apnd-file. +** If the append mark is not yet there, the file-size is 0. +*/ +static int apndFileSize(sqlite3_file *pFile, sqlite_int64 *pSize){ + ApndFile *paf = (ApndFile *)pFile; + *pSize = ( paf->iMark >= 0 )? (paf->iMark - paf->iPgOne) : 0; + return SQLITE_OK; +} + +/* +** Lock an apnd-file. +*/ +static int apndLock(sqlite3_file *pFile, int eLock){ + pFile = ORIGFILE(pFile); + return pFile->pMethods->xLock(pFile, eLock); +} + +/* +** Unlock an apnd-file. +*/ +static int apndUnlock(sqlite3_file *pFile, int eLock){ + pFile = ORIGFILE(pFile); + return pFile->pMethods->xUnlock(pFile, eLock); +} + +/* +** Check if another file-handle holds a RESERVED lock on an apnd-file. +*/ +static int apndCheckReservedLock(sqlite3_file *pFile, int *pResOut){ + pFile = ORIGFILE(pFile); + return pFile->pMethods->xCheckReservedLock(pFile, pResOut); +} + +/* +** File control method. For custom operations on an apnd-file. +*/ +static int apndFileControl(sqlite3_file *pFile, int op, void *pArg){ + ApndFile *paf = (ApndFile *)pFile; + int rc; + pFile = ORIGFILE(pFile); + if( op==SQLITE_FCNTL_SIZE_HINT ) *(sqlite3_int64*)pArg += paf->iPgOne; + rc = pFile->pMethods->xFileControl(pFile, op, pArg); + if( rc==SQLITE_OK && op==SQLITE_FCNTL_VFSNAME ){ + *(char**)pArg = sqlite3_mprintf("apnd(%lld)/%z", paf->iPgOne,*(char**)pArg); + } + return rc; +} + +/* +** Return the sector-size in bytes for an apnd-file. +*/ +static int apndSectorSize(sqlite3_file *pFile){ + pFile = ORIGFILE(pFile); + return pFile->pMethods->xSectorSize(pFile); +} + +/* +** Return the device characteristic flags supported by an apnd-file. +*/ +static int apndDeviceCharacteristics(sqlite3_file *pFile){ + pFile = ORIGFILE(pFile); + return pFile->pMethods->xDeviceCharacteristics(pFile); +} + +/* Create a shared memory file mapping */ +static int apndShmMap( + sqlite3_file *pFile, + int iPg, + int pgsz, + int bExtend, + void volatile **pp +){ + pFile = ORIGFILE(pFile); + return pFile->pMethods->xShmMap(pFile,iPg,pgsz,bExtend,pp); +} + +/* Perform locking on a shared-memory segment */ +static int apndShmLock(sqlite3_file *pFile, int offset, int n, int flags){ + pFile = ORIGFILE(pFile); + return pFile->pMethods->xShmLock(pFile,offset,n,flags); +} + +/* Memory barrier operation on shared memory */ +static void apndShmBarrier(sqlite3_file *pFile){ + pFile = ORIGFILE(pFile); + pFile->pMethods->xShmBarrier(pFile); +} + +/* Unmap a shared memory segment */ +static int apndShmUnmap(sqlite3_file *pFile, int deleteFlag){ + pFile = ORIGFILE(pFile); + return pFile->pMethods->xShmUnmap(pFile,deleteFlag); +} + +/* Fetch a page of a memory-mapped file */ +static int apndFetch( + sqlite3_file *pFile, + sqlite3_int64 iOfst, + int iAmt, + void **pp +){ + ApndFile *p = (ApndFile *)pFile; + if( p->iMark < 0 || iOfst+iAmt > p->iMark ){ + return SQLITE_IOERR; /* Cannot read what is not yet there. */ + } + pFile = ORIGFILE(pFile); + return pFile->pMethods->xFetch(pFile, iOfst+p->iPgOne, iAmt, pp); +} + +/* Release a memory-mapped page */ +static int apndUnfetch(sqlite3_file *pFile, sqlite3_int64 iOfst, void *pPage){ + ApndFile *p = (ApndFile *)pFile; + pFile = ORIGFILE(pFile); + return pFile->pMethods->xUnfetch(pFile, iOfst+p->iPgOne, pPage); +} + +/* +** Try to read the append-mark off the end of a file. Return the +** start of the appended database if the append-mark is present. +** If there is no valid append-mark, return -1; +** +** An append-mark is only valid if the NNNNNNNN start-of-database offset +** indicates that the appended database contains at least one page. The +** start-of-database value must be a multiple of 512. +*/ +static sqlite3_int64 apndReadMark(sqlite3_int64 sz, sqlite3_file *pFile){ + int rc, i; + sqlite3_int64 iMark; + int msbs = 8 * (APND_MARK_FOS_SZ-1); + unsigned char a[APND_MARK_SIZE]; + + if( APND_MARK_SIZE!=(sz & 0x1ff) ) return -1; + rc = pFile->pMethods->xRead(pFile, a, APND_MARK_SIZE, sz-APND_MARK_SIZE); + if( rc ) return -1; + if( memcmp(a, APND_MARK_PREFIX, APND_MARK_PREFIX_SZ)!=0 ) return -1; + iMark = ((sqlite3_int64)(a[APND_MARK_PREFIX_SZ] & 0x7f)) << msbs; + for(i=1; i<8; i++){ + msbs -= 8; + iMark |= (sqlite3_int64)a[APND_MARK_PREFIX_SZ+i]< (sz - APND_MARK_SIZE - 512) ) return -1; + if( iMark & 0x1ff ) return -1; + return iMark; +} + +static const char apvfsSqliteHdr[] = "SQLite format 3"; +/* +** Check to see if the file is an appendvfs SQLite database file. +** Return true iff it is such. Parameter sz is the file's size. +*/ +static int apndIsAppendvfsDatabase(sqlite3_int64 sz, sqlite3_file *pFile){ + int rc; + char zHdr[16]; + sqlite3_int64 iMark = apndReadMark(sz, pFile); + if( iMark>=0 ){ + /* If file has the correct end-marker, the expected odd size, and the + ** SQLite DB type marker where the end-marker puts it, then it + ** is an appendvfs database. + */ + rc = pFile->pMethods->xRead(pFile, zHdr, sizeof(zHdr), iMark); + if( SQLITE_OK==rc + && memcmp(zHdr, apvfsSqliteHdr, sizeof(zHdr))==0 + && (sz & 0x1ff) == APND_MARK_SIZE + && sz>=512+APND_MARK_SIZE + ){ + return 1; /* It's an appendvfs database */ + } + } + return 0; +} + +/* +** Check to see if the file is an ordinary SQLite database file. +** Return true iff so. Parameter sz is the file's size. +*/ +static int apndIsOrdinaryDatabaseFile(sqlite3_int64 sz, sqlite3_file *pFile){ + char zHdr[16]; + if( apndIsAppendvfsDatabase(sz, pFile) /* rule 2 */ + || (sz & 0x1ff) != 0 + || SQLITE_OK!=pFile->pMethods->xRead(pFile, zHdr, sizeof(zHdr), 0) + || memcmp(zHdr, apvfsSqliteHdr, sizeof(zHdr))!=0 + ){ + return 0; + }else{ + return 1; + } +} + +/* +** Open an apnd file handle. +*/ +static int apndOpen( + sqlite3_vfs *pApndVfs, + const char *zName, + sqlite3_file *pFile, + int flags, + int *pOutFlags +){ + ApndFile *pApndFile = (ApndFile*)pFile; + sqlite3_file *pBaseFile = ORIGFILE(pFile); + sqlite3_vfs *pBaseVfs = ORIGVFS(pApndVfs); + int rc; + sqlite3_int64 sz = 0; + if( (flags & SQLITE_OPEN_MAIN_DB)==0 ){ + /* The appendvfs is not to be used for transient or temporary databases. + ** Just use the base VFS open to initialize the given file object and + ** open the underlying file. (Appendvfs is then unused for this file.) + */ + return pBaseVfs->xOpen(pBaseVfs, zName, pFile, flags, pOutFlags); + } + memset(pApndFile, 0, sizeof(ApndFile)); + pFile->pMethods = &apnd_io_methods; + pApndFile->iMark = -1; /* Append mark not yet written */ + + rc = pBaseVfs->xOpen(pBaseVfs, zName, pBaseFile, flags, pOutFlags); + if( rc==SQLITE_OK ){ + rc = pBaseFile->pMethods->xFileSize(pBaseFile, &sz); + if( rc ){ + pBaseFile->pMethods->xClose(pBaseFile); + } + } + if( rc ){ + pFile->pMethods = 0; + return rc; + } + if( apndIsOrdinaryDatabaseFile(sz, pBaseFile) ){ + /* The file being opened appears to be just an ordinary DB. Copy + ** the base dispatch-table so this instance mimics the base VFS. + */ + memmove(pApndFile, pBaseFile, pBaseVfs->szOsFile); + return SQLITE_OK; + } + pApndFile->iPgOne = apndReadMark(sz, pFile); + if( pApndFile->iPgOne>=0 ){ + pApndFile->iMark = sz - APND_MARK_SIZE; /* Append mark found */ + return SQLITE_OK; + } + if( (flags & SQLITE_OPEN_CREATE)==0 ){ + pBaseFile->pMethods->xClose(pBaseFile); + rc = SQLITE_CANTOPEN; + pFile->pMethods = 0; + }else{ + /* Round newly added appendvfs location to #define'd page boundary. + ** Note that nothing has yet been written to the underlying file. + ** The append mark will be written along with first content write. + ** Until then, paf->iMark value indicates it is not yet written. + */ + pApndFile->iPgOne = APND_START_ROUNDUP(sz); + } + return rc; +} + +/* +** Delete an apnd file. +** For an appendvfs, this could mean delete the appendvfs portion, +** leaving the appendee as it was before it gained an appendvfs. +** For now, this code deletes the underlying file too. +*/ +static int apndDelete(sqlite3_vfs *pVfs, const char *zPath, int dirSync){ + return ORIGVFS(pVfs)->xDelete(ORIGVFS(pVfs), zPath, dirSync); +} + +/* +** All other VFS methods are pass-thrus. +*/ +static int apndAccess( + sqlite3_vfs *pVfs, + const char *zPath, + int flags, + int *pResOut +){ + return ORIGVFS(pVfs)->xAccess(ORIGVFS(pVfs), zPath, flags, pResOut); +} +static int apndFullPathname( + sqlite3_vfs *pVfs, + const char *zPath, + int nOut, + char *zOut +){ + return ORIGVFS(pVfs)->xFullPathname(ORIGVFS(pVfs),zPath,nOut,zOut); +} +static void *apndDlOpen(sqlite3_vfs *pVfs, const char *zPath){ + return ORIGVFS(pVfs)->xDlOpen(ORIGVFS(pVfs), zPath); +} +static void apndDlError(sqlite3_vfs *pVfs, int nByte, char *zErrMsg){ + ORIGVFS(pVfs)->xDlError(ORIGVFS(pVfs), nByte, zErrMsg); +} +static void (*apndDlSym(sqlite3_vfs *pVfs, void *p, const char *zSym))(void){ + return ORIGVFS(pVfs)->xDlSym(ORIGVFS(pVfs), p, zSym); +} +static void apndDlClose(sqlite3_vfs *pVfs, void *pHandle){ + ORIGVFS(pVfs)->xDlClose(ORIGVFS(pVfs), pHandle); +} +static int apndRandomness(sqlite3_vfs *pVfs, int nByte, char *zBufOut){ + return ORIGVFS(pVfs)->xRandomness(ORIGVFS(pVfs), nByte, zBufOut); +} +static int apndSleep(sqlite3_vfs *pVfs, int nMicro){ + return ORIGVFS(pVfs)->xSleep(ORIGVFS(pVfs), nMicro); +} +static int apndCurrentTime(sqlite3_vfs *pVfs, double *pTimeOut){ + return ORIGVFS(pVfs)->xCurrentTime(ORIGVFS(pVfs), pTimeOut); +} +static int apndGetLastError(sqlite3_vfs *pVfs, int a, char *b){ + return ORIGVFS(pVfs)->xGetLastError(ORIGVFS(pVfs), a, b); +} +static int apndCurrentTimeInt64(sqlite3_vfs *pVfs, sqlite3_int64 *p){ + return ORIGVFS(pVfs)->xCurrentTimeInt64(ORIGVFS(pVfs), p); +} +static int apndSetSystemCall( + sqlite3_vfs *pVfs, + const char *zName, + sqlite3_syscall_ptr pCall +){ + return ORIGVFS(pVfs)->xSetSystemCall(ORIGVFS(pVfs),zName,pCall); +} +static sqlite3_syscall_ptr apndGetSystemCall( + sqlite3_vfs *pVfs, + const char *zName +){ + return ORIGVFS(pVfs)->xGetSystemCall(ORIGVFS(pVfs),zName); +} +static const char *apndNextSystemCall(sqlite3_vfs *pVfs, const char *zName){ + return ORIGVFS(pVfs)->xNextSystemCall(ORIGVFS(pVfs), zName); +} + + +#ifdef _WIN32 + +#endif +/* +** This routine is called when the extension is loaded. +** Register the new VFS. +*/ +int sqlite3_appendvfs_init( + sqlite3 *db, + char **pzErrMsg, + const sqlite3_api_routines *pApi +){ + int rc = SQLITE_OK; + sqlite3_vfs *pOrig; + SQLITE_EXTENSION_INIT2(pApi); + (void)pzErrMsg; + (void)db; + pOrig = sqlite3_vfs_find(0); + if( pOrig==0 ) return SQLITE_ERROR; + apnd_vfs.iVersion = pOrig->iVersion; + apnd_vfs.pAppData = pOrig; + apnd_vfs.szOsFile = pOrig->szOsFile + sizeof(ApndFile); + rc = sqlite3_vfs_register(&apnd_vfs, 0); +#ifdef APPENDVFS_TEST + if( rc==SQLITE_OK ){ + rc = sqlite3_auto_extension((void(*)(void))apndvfsRegister); + } +#endif + if( rc==SQLITE_OK ) rc = SQLITE_OK_LOAD_PERMANENTLY; + return rc; +} + +/************************* End ../ext/misc/appendvfs.c ********************/ +/************************* Begin ../ext/misc/memtrace.c ******************/ +/* +** 2019-01-21 +** +** The author disclaims copyright to this source code. In place of +** a legal notice, here is a blessing: +** +** May you do good and not evil. +** May you find forgiveness for yourself and forgive others. +** May you share freely, never taking more than you give. +** +************************************************************************* +** +** This file implements an extension that uses the SQLITE_CONFIG_MALLOC +** mechanism to add a tracing layer on top of SQLite. If this extension +** is registered prior to sqlite3_initialize(), it will cause all memory +** allocation activities to be logged on standard output, or to some other +** FILE specified by the initializer. +** +** This file needs to be compiled into the application that uses it. +** +** This extension is used to implement the --memtrace option of the +** command-line shell. +*/ +#include +#include +#include + +/* The original memory allocation routines */ +static sqlite3_mem_methods memtraceBase; +static FILE *memtraceOut; + +/* Methods that trace memory allocations */ +static void *memtraceMalloc(int n){ + if( memtraceOut ){ + fprintf(memtraceOut, "MEMTRACE: allocate %d bytes\n", + memtraceBase.xRoundup(n)); + } + return memtraceBase.xMalloc(n); +} +static void memtraceFree(void *p){ + if( p==0 ) return; + if( memtraceOut ){ + fprintf(memtraceOut, "MEMTRACE: free %d bytes\n", memtraceBase.xSize(p)); + } + memtraceBase.xFree(p); +} +static void *memtraceRealloc(void *p, int n){ + if( p==0 ) return memtraceMalloc(n); + if( n==0 ){ + memtraceFree(p); + return 0; + } + if( memtraceOut ){ + fprintf(memtraceOut, "MEMTRACE: resize %d -> %d bytes\n", + memtraceBase.xSize(p), memtraceBase.xRoundup(n)); + } + return memtraceBase.xRealloc(p, n); +} +static int memtraceSize(void *p){ + return memtraceBase.xSize(p); +} +static int memtraceRoundup(int n){ + return memtraceBase.xRoundup(n); +} +static int memtraceInit(void *p){ + return memtraceBase.xInit(p); +} +static void memtraceShutdown(void *p){ + memtraceBase.xShutdown(p); +} + +/* The substitute memory allocator */ +static sqlite3_mem_methods ersaztMethods = { + memtraceMalloc, + memtraceFree, + memtraceRealloc, + memtraceSize, + memtraceRoundup, + memtraceInit, + memtraceShutdown, + 0 +}; + +/* Begin tracing memory allocations to out. */ +int sqlite3MemTraceActivate(FILE *out){ + int rc = SQLITE_OK; + if( memtraceBase.xMalloc==0 ){ + rc = sqlite3_config(SQLITE_CONFIG_GETMALLOC, &memtraceBase); + if( rc==SQLITE_OK ){ + rc = sqlite3_config(SQLITE_CONFIG_MALLOC, &ersaztMethods); + } + } + memtraceOut = out; + return rc; +} + +/* Deactivate memory tracing */ +int sqlite3MemTraceDeactivate(void){ + int rc = SQLITE_OK; + if( memtraceBase.xMalloc!=0 ){ + rc = sqlite3_config(SQLITE_CONFIG_MALLOC, &memtraceBase); + if( rc==SQLITE_OK ){ + memset(&memtraceBase, 0, sizeof(memtraceBase)); + } + } + memtraceOut = 0; + return rc; +} + +/************************* End ../ext/misc/memtrace.c ********************/ +/************************* Begin ../ext/misc/uint.c ******************/ +/* +** 2020-04-14 +** +** The author disclaims copyright to this source code. In place of +** a legal notice, here is a blessing: +** +** May you do good and not evil. +** May you find forgiveness for yourself and forgive others. +** May you share freely, never taking more than you give. +** +****************************************************************************** +** +** This SQLite extension implements the UINT collating sequence. +** +** UINT works like BINARY for text, except that embedded strings +** of digits compare in numeric order. +** +** * Leading zeros are handled properly, in the sense that +** they do not mess of the maginitude comparison of embedded +** strings of digits. "x00123y" is equal to "x123y". +** +** * Only unsigned integers are recognized. Plus and minus +** signs are ignored. Decimal points and exponential notation +** are ignored. +** +** * Embedded integers can be of arbitrary length. Comparison +** is *not* limited integers that can be expressed as a +** 64-bit machine integer. +*/ +/* #include "sqlite3ext.h" */ +SQLITE_EXTENSION_INIT1 +#include +#include +#include + +/* +** Compare text in lexicographic order, except strings of digits +** compare in numeric order. +*/ +static int uintCollFunc( + void *notUsed, + int nKey1, const void *pKey1, + int nKey2, const void *pKey2 +){ + const unsigned char *zA = (const unsigned char*)pKey1; + const unsigned char *zB = (const unsigned char*)pKey2; + int i=0, j=0, x; + (void)notUsed; + while( i +#include +#include +#include + +/* Mark a function parameter as unused, to suppress nuisance compiler +** warnings. */ +#ifndef UNUSED_PARAMETER +# define UNUSED_PARAMETER(X) (void)(X) +#endif + + +/* A decimal object */ +typedef struct Decimal Decimal; +struct Decimal { + char sign; /* 0 for positive, 1 for negative */ + char oom; /* True if an OOM is encountered */ + char isNull; /* True if holds a NULL rather than a number */ + char isInit; /* True upon initialization */ + int nDigit; /* Total number of digits */ + int nFrac; /* Number of digits to the right of the decimal point */ + signed char *a; /* Array of digits. Most significant first. */ +}; + +/* +** Release memory held by a Decimal, but do not free the object itself. +*/ +static void decimal_clear(Decimal *p){ + sqlite3_free(p->a); +} + +/* +** Destroy a Decimal object +*/ +static void decimal_free(Decimal *p){ + if( p ){ + decimal_clear(p); + sqlite3_free(p); + } +} + +/* +** Allocate a new Decimal object. Initialize it to the number given +** by the input string. +*/ +static Decimal *decimal_new( + sqlite3_context *pCtx, + sqlite3_value *pIn, + int nAlt, + const unsigned char *zAlt +){ + Decimal *p; + int n, i; + const unsigned char *zIn; + int iExp = 0; + p = sqlite3_malloc( sizeof(*p) ); + if( p==0 ) goto new_no_mem; + p->sign = 0; + p->oom = 0; + p->isInit = 1; + p->isNull = 0; + p->nDigit = 0; + p->nFrac = 0; + if( zAlt ){ + n = nAlt, + zIn = zAlt; + }else{ + if( sqlite3_value_type(pIn)==SQLITE_NULL ){ + p->a = 0; + p->isNull = 1; + return p; + } + n = sqlite3_value_bytes(pIn); + zIn = sqlite3_value_text(pIn); + } + p->a = sqlite3_malloc64( n+1 ); + if( p->a==0 ) goto new_no_mem; + for(i=0; isspace(zIn[i]); i++){} + if( zIn[i]=='-' ){ + p->sign = 1; + i++; + }else if( zIn[i]=='+' ){ + i++; + } + while( i='0' && c<='9' ){ + p->a[p->nDigit++] = c - '0'; + }else if( c=='.' ){ + p->nFrac = p->nDigit + 1; + }else if( c=='e' || c=='E' ){ + int j = i+1; + int neg = 0; + if( j>=n ) break; + if( zIn[j]=='-' ){ + neg = 1; + j++; + }else if( zIn[j]=='+' ){ + j++; + } + while( j='0' && zIn[j]<='9' ){ + iExp = iExp*10 + zIn[j] - '0'; + } + j++; + } + if( neg ) iExp = -iExp; + break; + } + i++; + } + if( p->nFrac ){ + p->nFrac = p->nDigit - (p->nFrac - 1); + } + if( iExp>0 ){ + if( p->nFrac>0 ){ + if( iExp<=p->nFrac ){ + p->nFrac -= iExp; + iExp = 0; + }else{ + iExp -= p->nFrac; + p->nFrac = 0; + } + } + if( iExp>0 ){ + p->a = sqlite3_realloc64(p->a, p->nDigit + iExp + 1 ); + if( p->a==0 ) goto new_no_mem; + memset(p->a+p->nDigit, 0, iExp); + p->nDigit += iExp; + } + }else if( iExp<0 ){ + int nExtra; + iExp = -iExp; + nExtra = p->nDigit - p->nFrac - 1; + if( nExtra ){ + if( nExtra>=iExp ){ + p->nFrac += iExp; + iExp = 0; + }else{ + iExp -= nExtra; + p->nFrac = p->nDigit - 1; + } + } + if( iExp>0 ){ + p->a = sqlite3_realloc64(p->a, p->nDigit + iExp + 1 ); + if( p->a==0 ) goto new_no_mem; + memmove(p->a+iExp, p->a, p->nDigit); + memset(p->a, 0, iExp); + p->nDigit += iExp; + p->nFrac += iExp; + } + } + return p; + +new_no_mem: + if( pCtx ) sqlite3_result_error_nomem(pCtx); + sqlite3_free(p); + return 0; +} + +/* +** Make the given Decimal the result. +*/ +static void decimal_result(sqlite3_context *pCtx, Decimal *p){ + char *z; + int i, j; + int n; + if( p==0 || p->oom ){ + sqlite3_result_error_nomem(pCtx); + return; + } + if( p->isNull ){ + sqlite3_result_null(pCtx); + return; + } + z = sqlite3_malloc( p->nDigit+4 ); + if( z==0 ){ + sqlite3_result_error_nomem(pCtx); + return; + } + i = 0; + if( p->nDigit==0 || (p->nDigit==1 && p->a[0]==0) ){ + p->sign = 0; + } + if( p->sign ){ + z[0] = '-'; + i = 1; + } + n = p->nDigit - p->nFrac; + if( n<=0 ){ + z[i++] = '0'; + } + j = 0; + while( n>1 && p->a[j]==0 ){ + j++; + n--; + } + while( n>0 ){ + z[i++] = p->a[j] + '0'; + j++; + n--; + } + if( p->nFrac ){ + z[i++] = '.'; + do{ + z[i++] = p->a[j] + '0'; + j++; + }while( jnDigit ); + } + z[i] = 0; + sqlite3_result_text(pCtx, z, i, sqlite3_free); +} + +/* +** SQL Function: decimal(X) +** +** Convert input X into decimal and then back into text +*/ +static void decimalFunc( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + Decimal *p = decimal_new(context, argv[0], 0, 0); + UNUSED_PARAMETER(argc); + decimal_result(context, p); + decimal_free(p); +} + +/* +** Compare to Decimal objects. Return negative, 0, or positive if the +** first object is less than, equal to, or greater than the second. +** +** Preconditions for this routine: +** +** pA!=0 +** pA->isNull==0 +** pB!=0 +** pB->isNull==0 +*/ +static int decimal_cmp(const Decimal *pA, const Decimal *pB){ + int nASig, nBSig, rc, n; + if( pA->sign!=pB->sign ){ + return pA->sign ? -1 : +1; + } + if( pA->sign ){ + const Decimal *pTemp = pA; + pA = pB; + pB = pTemp; + } + nASig = pA->nDigit - pA->nFrac; + nBSig = pB->nDigit - pB->nFrac; + if( nASig!=nBSig ){ + return nASig - nBSig; + } + n = pA->nDigit; + if( n>pB->nDigit ) n = pB->nDigit; + rc = memcmp(pA->a, pB->a, n); + if( rc==0 ){ + rc = pA->nDigit - pB->nDigit; + } + return rc; +} + +/* +** SQL Function: decimal_cmp(X, Y) +** +** Return negative, zero, or positive if X is less then, equal to, or +** greater than Y. +*/ +static void decimalCmpFunc( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + Decimal *pA = 0, *pB = 0; + int rc; + + UNUSED_PARAMETER(argc); + pA = decimal_new(context, argv[0], 0, 0); + if( pA==0 || pA->isNull ) goto cmp_done; + pB = decimal_new(context, argv[1], 0, 0); + if( pB==0 || pB->isNull ) goto cmp_done; + rc = decimal_cmp(pA, pB); + if( rc<0 ) rc = -1; + else if( rc>0 ) rc = +1; + sqlite3_result_int(context, rc); +cmp_done: + decimal_free(pA); + decimal_free(pB); +} + +/* +** Expand the Decimal so that it has a least nDigit digits and nFrac +** digits to the right of the decimal point. +*/ +static void decimal_expand(Decimal *p, int nDigit, int nFrac){ + int nAddSig; + int nAddFrac; + if( p==0 ) return; + nAddFrac = nFrac - p->nFrac; + nAddSig = (nDigit - p->nDigit) - nAddFrac; + if( nAddFrac==0 && nAddSig==0 ) return; + p->a = sqlite3_realloc64(p->a, nDigit+1); + if( p->a==0 ){ + p->oom = 1; + return; + } + if( nAddSig ){ + memmove(p->a+nAddSig, p->a, p->nDigit); + memset(p->a, 0, nAddSig); + p->nDigit += nAddSig; + } + if( nAddFrac ){ + memset(p->a+p->nDigit, 0, nAddFrac); + p->nDigit += nAddFrac; + p->nFrac += nAddFrac; + } +} + +/* +** Add the value pB into pA. +** +** Both pA and pB might become denormalized by this routine. +*/ +static void decimal_add(Decimal *pA, Decimal *pB){ + int nSig, nFrac, nDigit; + int i, rc; + if( pA==0 ){ + return; + } + if( pA->oom || pB==0 || pB->oom ){ + pA->oom = 1; + return; + } + if( pA->isNull || pB->isNull ){ + pA->isNull = 1; + return; + } + nSig = pA->nDigit - pA->nFrac; + if( nSig && pA->a[0]==0 ) nSig--; + if( nSignDigit-pB->nFrac ){ + nSig = pB->nDigit - pB->nFrac; + } + nFrac = pA->nFrac; + if( nFracnFrac ) nFrac = pB->nFrac; + nDigit = nSig + nFrac + 1; + decimal_expand(pA, nDigit, nFrac); + decimal_expand(pB, nDigit, nFrac); + if( pA->oom || pB->oom ){ + pA->oom = 1; + }else{ + if( pA->sign==pB->sign ){ + int carry = 0; + for(i=nDigit-1; i>=0; i--){ + int x = pA->a[i] + pB->a[i] + carry; + if( x>=10 ){ + carry = 1; + pA->a[i] = x - 10; + }else{ + carry = 0; + pA->a[i] = x; + } + } + }else{ + signed char *aA, *aB; + int borrow = 0; + rc = memcmp(pA->a, pB->a, nDigit); + if( rc<0 ){ + aA = pB->a; + aB = pA->a; + pA->sign = !pA->sign; + }else{ + aA = pA->a; + aB = pB->a; + } + for(i=nDigit-1; i>=0; i--){ + int x = aA[i] - aB[i] - borrow; + if( x<0 ){ + pA->a[i] = x+10; + borrow = 1; + }else{ + pA->a[i] = x; + borrow = 0; + } + } + } + } +} + +/* +** Compare text in decimal order. +*/ +static int decimalCollFunc( + void *notUsed, + int nKey1, const void *pKey1, + int nKey2, const void *pKey2 +){ + const unsigned char *zA = (const unsigned char*)pKey1; + const unsigned char *zB = (const unsigned char*)pKey2; + Decimal *pA = decimal_new(0, 0, nKey1, zA); + Decimal *pB = decimal_new(0, 0, nKey2, zB); + int rc; + UNUSED_PARAMETER(notUsed); + if( pA==0 || pB==0 ){ + rc = 0; + }else{ + rc = decimal_cmp(pA, pB); + } + decimal_free(pA); + decimal_free(pB); + return rc; +} + + +/* +** SQL Function: decimal_add(X, Y) +** decimal_sub(X, Y) +** +** Return the sum or difference of X and Y. +*/ +static void decimalAddFunc( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + Decimal *pA = decimal_new(context, argv[0], 0, 0); + Decimal *pB = decimal_new(context, argv[1], 0, 0); + UNUSED_PARAMETER(argc); + decimal_add(pA, pB); + decimal_result(context, pA); + decimal_free(pA); + decimal_free(pB); +} +static void decimalSubFunc( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + Decimal *pA = decimal_new(context, argv[0], 0, 0); + Decimal *pB = decimal_new(context, argv[1], 0, 0); + UNUSED_PARAMETER(argc); + if( pB ){ + pB->sign = !pB->sign; + decimal_add(pA, pB); + decimal_result(context, pA); + } + decimal_free(pA); + decimal_free(pB); +} + +/* Aggregate funcion: decimal_sum(X) +** +** Works like sum() except that it uses decimal arithmetic for unlimited +** precision. +*/ +static void decimalSumStep( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + Decimal *p; + Decimal *pArg; + UNUSED_PARAMETER(argc); + p = sqlite3_aggregate_context(context, sizeof(*p)); + if( p==0 ) return; + if( !p->isInit ){ + p->isInit = 1; + p->a = sqlite3_malloc(2); + if( p->a==0 ){ + p->oom = 1; + }else{ + p->a[0] = 0; + } + p->nDigit = 1; + p->nFrac = 0; + } + if( sqlite3_value_type(argv[0])==SQLITE_NULL ) return; + pArg = decimal_new(context, argv[0], 0, 0); + decimal_add(p, pArg); + decimal_free(pArg); +} +static void decimalSumInverse( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + Decimal *p; + Decimal *pArg; + UNUSED_PARAMETER(argc); + p = sqlite3_aggregate_context(context, sizeof(*p)); + if( p==0 ) return; + if( sqlite3_value_type(argv[0])==SQLITE_NULL ) return; + pArg = decimal_new(context, argv[0], 0, 0); + if( pArg ) pArg->sign = !pArg->sign; + decimal_add(p, pArg); + decimal_free(pArg); +} +static void decimalSumValue(sqlite3_context *context){ + Decimal *p = sqlite3_aggregate_context(context, 0); + if( p==0 ) return; + decimal_result(context, p); +} +static void decimalSumFinalize(sqlite3_context *context){ + Decimal *p = sqlite3_aggregate_context(context, 0); + if( p==0 ) return; + decimal_result(context, p); + decimal_clear(p); +} + +/* +** SQL Function: decimal_mul(X, Y) +** +** Return the product of X and Y. +** +** All significant digits after the decimal point are retained. +** Trailing zeros after the decimal point are omitted as long as +** the number of digits after the decimal point is no less than +** either the number of digits in either input. +*/ +static void decimalMulFunc( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + Decimal *pA = decimal_new(context, argv[0], 0, 0); + Decimal *pB = decimal_new(context, argv[1], 0, 0); + signed char *acc = 0; + int i, j, k; + int minFrac; + UNUSED_PARAMETER(argc); + if( pA==0 || pA->oom || pA->isNull + || pB==0 || pB->oom || pB->isNull + ){ + goto mul_end; + } + acc = sqlite3_malloc64( pA->nDigit + pB->nDigit + 2 ); + if( acc==0 ){ + sqlite3_result_error_nomem(context); + goto mul_end; + } + memset(acc, 0, pA->nDigit + pB->nDigit + 2); + minFrac = pA->nFrac; + if( pB->nFracnFrac; + for(i=pA->nDigit-1; i>=0; i--){ + signed char f = pA->a[i]; + int carry = 0, x; + for(j=pB->nDigit-1, k=i+j+3; j>=0; j--, k--){ + x = acc[k] + f*pB->a[j] + carry; + acc[k] = x%10; + carry = x/10; + } + x = acc[k] + carry; + acc[k] = x%10; + acc[k-1] += x/10; + } + sqlite3_free(pA->a); + pA->a = acc; + acc = 0; + pA->nDigit += pB->nDigit + 2; + pA->nFrac += pB->nFrac; + pA->sign ^= pB->sign; + while( pA->nFrac>minFrac && pA->a[pA->nDigit-1]==0 ){ + pA->nFrac--; + pA->nDigit--; + } + decimal_result(context, pA); + +mul_end: + sqlite3_free(acc); + decimal_free(pA); + decimal_free(pB); +} + +#ifdef _WIN32 + +#endif +int sqlite3_decimal_init( + sqlite3 *db, + char **pzErrMsg, + const sqlite3_api_routines *pApi +){ + int rc = SQLITE_OK; + static const struct { + const char *zFuncName; + int nArg; + void (*xFunc)(sqlite3_context*,int,sqlite3_value**); + } aFunc[] = { + { "decimal", 1, decimalFunc }, + { "decimal_cmp", 2, decimalCmpFunc }, + { "decimal_add", 2, decimalAddFunc }, + { "decimal_sub", 2, decimalSubFunc }, + { "decimal_mul", 2, decimalMulFunc }, + }; + unsigned int i; + (void)pzErrMsg; /* Unused parameter */ + + SQLITE_EXTENSION_INIT2(pApi); + + for(i=0; i 'ieee754(2,0)' +** ieee754(45.25) -> 'ieee754(181,-2)' +** ieee754(2, 0) -> 2.0 +** ieee754(181, -2) -> 45.25 +** +** Two additional functions break apart the one-argument ieee754() +** result into separate integer values: +** +** ieee754_mantissa(45.25) -> 181 +** ieee754_exponent(45.25) -> -2 +** +** These functions convert binary64 numbers into blobs and back again. +** +** ieee754_from_blob(x'3ff0000000000000') -> 1.0 +** ieee754_to_blob(1.0) -> x'3ff0000000000000' +** +** In all single-argument functions, if the argument is an 8-byte blob +** then that blob is interpreted as a big-endian binary64 value. +** +** +** EXACT DECIMAL REPRESENTATION OF BINARY64 VALUES +** ----------------------------------------------- +** +** This extension in combination with the separate 'decimal' extension +** can be used to compute the exact decimal representation of binary64 +** values. To begin, first compute a table of exponent values: +** +** CREATE TABLE pow2(x INTEGER PRIMARY KEY, v TEXT); +** WITH RECURSIVE c(x,v) AS ( +** VALUES(0,'1') +** UNION ALL +** SELECT x+1, decimal_mul(v,'2') FROM c WHERE x+1<=971 +** ) INSERT INTO pow2(x,v) SELECT x, v FROM c; +** WITH RECURSIVE c(x,v) AS ( +** VALUES(-1,'0.5') +** UNION ALL +** SELECT x-1, decimal_mul(v,'0.5') FROM c WHERE x-1>=-1075 +** ) INSERT INTO pow2(x,v) SELECT x, v FROM c; +** +** Then, to compute the exact decimal representation of a floating +** point value (the value 47.49 is used in the example) do: +** +** WITH c(n) AS (VALUES(47.49)) +** ---------------^^^^^---- Replace with whatever you want +** SELECT decimal_mul(ieee754_mantissa(c.n),pow2.v) +** FROM pow2, c WHERE pow2.x=ieee754_exponent(c.n); +** +** Here is a query to show various boundry values for the binary64 +** number format: +** +** WITH c(name,bin) AS (VALUES +** ('minimum positive value', x'0000000000000001'), +** ('maximum subnormal value', x'000fffffffffffff'), +** ('mininum positive nornal value', x'0010000000000000'), +** ('maximum value', x'7fefffffffffffff')) +** SELECT c.name, decimal_mul(ieee754_mantissa(c.bin),pow2.v) +** FROM pow2, c WHERE pow2.x=ieee754_exponent(c.bin); +** +*/ +/* #include "sqlite3ext.h" */ +SQLITE_EXTENSION_INIT1 +#include +#include + +/* Mark a function parameter as unused, to suppress nuisance compiler +** warnings. */ +#ifndef UNUSED_PARAMETER +# define UNUSED_PARAMETER(X) (void)(X) +#endif + +/* +** Implementation of the ieee754() function +*/ +static void ieee754func( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + if( argc==1 ){ + sqlite3_int64 m, a; + double r; + int e; + int isNeg; + char zResult[100]; + assert( sizeof(m)==sizeof(r) ); + if( sqlite3_value_type(argv[0])==SQLITE_BLOB + && sqlite3_value_bytes(argv[0])==sizeof(r) + ){ + const unsigned char *x = sqlite3_value_blob(argv[0]); + unsigned int i; + sqlite3_uint64 v = 0; + for(i=0; i>52; + m = a & ((((sqlite3_int64)1)<<52)-1); + if( e==0 ){ + m <<= 1; + }else{ + m |= ((sqlite3_int64)1)<<52; + } + while( e<1075 && m>0 && (m&1)==0 ){ + m >>= 1; + e++; + } + if( isNeg ) m = -m; + } + switch( *(int*)sqlite3_user_data(context) ){ + case 0: + sqlite3_snprintf(sizeof(zResult), zResult, "ieee754(%lld,%d)", + m, e-1075); + sqlite3_result_text(context, zResult, -1, SQLITE_TRANSIENT); + break; + case 1: + sqlite3_result_int64(context, m); + break; + case 2: + sqlite3_result_int(context, e-1075); + break; + } + }else{ + sqlite3_int64 m, e, a; + double r; + int isNeg = 0; + m = sqlite3_value_int64(argv[0]); + e = sqlite3_value_int64(argv[1]); + + /* Limit the range of e. Ticket 22dea1cfdb9151e4 2021-03-02 */ + if( e>10000 ){ + e = 10000; + }else if( e<-10000 ){ + e = -10000; + } + + if( m<0 ){ + isNeg = 1; + m = -m; + if( m<0 ) return; + }else if( m==0 && e>-1000 && e<1000 ){ + sqlite3_result_double(context, 0.0); + return; + } + while( (m>>32)&0xffe00000 ){ + m >>= 1; + e++; + } + while( m!=0 && ((m>>32)&0xfff00000)==0 ){ + m <<= 1; + e--; + } + e += 1075; + if( e<=0 ){ + /* Subnormal */ + if( 1-e >= 64 ){ + m = 0; + }else{ + m >>= 1-e; + } + e = 0; + }else if( e>0x7ff ){ + e = 0x7ff; + } + a = m & ((((sqlite3_int64)1)<<52)-1); + a |= e<<52; + if( isNeg ) a |= ((sqlite3_uint64)1)<<63; + memcpy(&r, &a, sizeof(r)); + sqlite3_result_double(context, r); + } +} + +/* +** Functions to convert between blobs and floats. +*/ +static void ieee754func_from_blob( + sqlite3_context *context, + int argc, + sqlite3_value **argv +){ + UNUSED_PARAMETER(argc); + if( sqlite3_value_type(argv[0])==SQLITE_BLOB + && sqlite3_value_bytes(argv[0])==sizeof(double) + ){ + double r; + const unsigned char *x = sqlite3_value_blob(argv[0]); + unsigned int i; + sqlite3_uint64 v = 0; + for(i=0; i>= 8; + } + sqlite3_result_blob(context, a, sizeof(r), SQLITE_TRANSIENT); + } +} + + +#ifdef _WIN32 + +#endif +int sqlite3_ieee_init( + sqlite3 *db, + char **pzErrMsg, + const sqlite3_api_routines *pApi +){ + static const struct { + char *zFName; + int nArg; + int iAux; + void (*xFunc)(sqlite3_context*,int,sqlite3_value**); + } aFunc[] = { + { "ieee754", 1, 0, ieee754func }, + { "ieee754", 2, 0, ieee754func }, + { "ieee754_mantissa", 1, 1, ieee754func }, + { "ieee754_exponent", 1, 2, ieee754func }, + { "ieee754_to_blob", 1, 0, ieee754func_to_blob }, + { "ieee754_from_blob", 1, 0, ieee754func_from_blob }, + + }; + unsigned int i; + int rc = SQLITE_OK; + SQLITE_EXTENSION_INIT2(pApi); + (void)pzErrMsg; /* Unused parameter */ + for(i=0; i